Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | line-edit now supports positioning wth mouse click |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors |
Files: | files | file ages | folders |
SHA1: |
67dae557f2d06bdf500faa13d4cd7e09 |
User & Date: | aldo 2016-12-15 19:31:35 |
Context
2016-12-15
| ||
19:31 | line-edit now supports positioning wth mouse click Leaf check-in: 67dae557f2 user: aldo | |
01:04 | some experimental changes check-in: 2cda79e659 user: aldo tags: test | |
Changes
Changes to draw.ss.
11 12 13 14 15 16 17 18 19 20 21 22 23 24 ... 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 ... 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 ... 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 ... 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
;; Unless required by applicable law or agreed to in writing, software ;; distributed under the License is distributed on an "AS IS" BASIS, ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;; See the License for the specific language governing permissions and ;; limitations under the License. (define draw-pool '()) (define (round-rect x y width height br) (define-values (tlrx tlry trrx trry brrx brry blrx blry) (match br [((tlrx tlry) (trrx trry) (brrx brry) (blrx blry)) (values tlrx tlry trrx trry brrx brry blrx blry)] [else (values 0 0 0 0 0 0 0 0)])) ................................................................................ (draw-bg) (with-cairo (mi-cr) (set-source-color bg-color) (fill))) (draw-path)))) (define (text-extents text) (define font-size (mi-font-size)) (define font-family (mi-font-family)) (define font-style (mi-font-style)) (define font-weight (mi-font-weight)) (define text-align (mi-text-align)) (define color (mi-color)) (check-arg string? text draw-text) (let ([extents (cairo-text-extents-create)]) (cairo-set-font-size (mi-cr) font-size) (cairo-select-font-face (mi-cr) (string-append font-family (string #\nul)) (cairo-font-slant font-style) ;; normal|italic|oblique (cairo-font-weight font-weight)) ;; normal|bold (cairo-text-extents (mi-cr) text extents) ................................................................................ (syntax-rules () [(_ ftype fptr) (make-ftype-pointer ftype (ftype-pointer-address fptr))])) (define (*int ptr) (ftype-ref int () ptr)) (define (show-text cr text x y font-size) (define glyphs* (cairo-glyph*-create)) (define glyph-count (cairo-int-create)) (define clusters* (cairo-text-cluster*-create)) (define cluster-count (cairo-int-create)) (define clusterflags (cairo-text-cluster-flags-create)) (define scaled-face (cairo-get-scaled-font cr)) (define clusters #f) ................................................................................ (ftype-set! void* () (cast void* clusters*) 0) (ftype-set! void* () (cast void* glyphs*) 0) ;; THIS COULD BE CACHED SOMEWHERE? (unless (eq? 'success (cairo-scaled-font-text-to-glyphs scaled-face x y text (string-length text) glyphs* glyph-count clusters* cluster-count clusterflags)) (raise (error 'show-text "stat error" stat))) (set! clusters (cairo-guard-pointer (ftype-&ref cairo-text-cluster-t* (*) clusters*))) (set! glyphs (cairo-guard-pointer (ftype-&ref cairo-glyph-t* (*) glyphs*))) ;; WE COULD USE cairo-show-glyphs instead? (let loop ([glyph-index 0] [byte-index 0] [i 0]) (when (< i (*int cluster-count)) (let* ([cluster (ftype-&ref cairo-text-cluster-t () clusters i)] [clusterglyphs (ftype-&ref cairo-glyph-t () glyphs glyph-index)] [extents (cairo-text-extents-create)]) (let-struct cluster cairo-text-cluster-t (num-glyphs num-bytes) (cairo-scaled-font-glyph-extents scaled-face clusterglyphs (*int glyph-count) extents) ;;(printf "extents: status: ~d num-glyphs: ~d num-bytes: ~d~n" (cairo-status cr) num-glyphs num-bytes) (with-cairo cr (glyph-path clusterglyphs num-glyphs) (set-line-width 0) (fill-preserve) (stroke)) (loop (+ glyph-index num-glyphs) (+ byte-index num-bytes) (+ i 1))))))) (define (draw-text text x y w h) (define font-size (mi-font-size)) (define font-family (mi-font-family)) (define font-style (mi-font-style)) (define font-weight (mi-font-weight)) ................................................................................ [center (cairo-translate (mi-cr) (- (+ x (/ w 2)) (/ width 2)) (+ y height))] [right (cairo-translate (mi-cr) (- (+ x w) width x-bearing) (+ y height))] [else (cairo-translate (mi-cr) x (+ y height))]) (show-text (mi-cr) text 0 0 font-size) (cairo-identity-matrix (mi-cr)))) (list x-advance height)))) (define (draw-text/padding text x y w h) (draw-text text |
> > > > > > > > > > > > > > | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | | | | | | | | | | | | | | | | |
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 ... 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 ... 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 ... 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 ... 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 |
;; Unless required by applicable law or agreed to in writing, software ;; distributed under the License is distributed on an "AS IS" BASIS, ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;; See the License for the specific language governing permissions and ;; limitations under the License. (define draw-pool '()) (define (round-rect x y width height br) (define-values (tlrx tlry trrx trry brrx brry blrx blry) (match br [((tlrx tlry) (trrx trry) (brrx brry) (blrx blry)) (values tlrx tlry trrx trry brrx brry blrx blry)] [else (values 0 0 0 0 0 0 0 0)])) ................................................................................ (draw-bg) (with-cairo (mi-cr) (set-source-color bg-color) (fill))) (draw-path)))) (define (text-get-char-index-from-offset text) (define font-size (mi-font-size)) (define font-family (mi-font-family)) (define font-style (mi-font-style)) (define font-weight (mi-font-weight)) (define text-align (mi-text-align)) (define color (mi-color)) (check-arg string? text text-get-char-index-from-offset) ) (define (text-extents text) (define font-size (mi-font-size)) (define font-family (mi-font-family)) (define font-style (mi-font-style)) (define font-weight (mi-font-weight)) (define text-align (mi-text-align)) (define color (mi-color)) (check-arg string? text text-extents) (let ([extents (cairo-text-extents-create)]) (cairo-set-font-size (mi-cr) font-size) (cairo-select-font-face (mi-cr) (string-append font-family (string #\nul)) (cairo-font-slant font-style) ;; normal|italic|oblique (cairo-font-weight font-weight)) ;; normal|bold (cairo-text-extents (mi-cr) text extents) ................................................................................ (syntax-rules () [(_ ftype fptr) (make-ftype-pointer ftype (ftype-pointer-address fptr))])) (define (*int ptr) (ftype-ref int () ptr)) (define (get-text-glyphs cr text) (define glyphs* (cairo-glyph*-create)) (define glyph-count (cairo-int-create)) (define clusters* (cairo-text-cluster*-create)) (define cluster-count (cairo-int-create)) (define clusterflags (cairo-text-cluster-flags-create)) (define scaled-face (cairo-get-scaled-font cr)) (define clusters #f) ................................................................................ (ftype-set! void* () (cast void* clusters*) 0) (ftype-set! void* () (cast void* glyphs*) 0) ;; THIS COULD BE CACHED SOMEWHERE? (unless (eq? 'success (cairo-scaled-font-text-to-glyphs scaled-face 0 0 text (string-length text) glyphs* glyph-count clusters* cluster-count clusterflags)) (raise (error 'show-text "stat error" stat))) (values (cairo-guard-pointer (ftype-&ref cairo-text-cluster-t* (*) clusters*)) (*int cluster-count) (cairo-guard-pointer (ftype-&ref cairo-glyph-t* (*) glyphs*)) (*int glyph-count) scaled-face)) (define (get-text-char-index-from-offset cr text offset) (define-values (clusters cluster-count glyphs glyph-count scaled-face) (get-text-glyphs cr text)) (let loop ([glyph-index 0] [byte-index 0] [i 0] [x-pos 0]) (if (< i cluster-count) (let* ([cluster (ftype-&ref cairo-text-cluster-t () clusters i)] [clusterglyphs (ftype-&ref cairo-glyph-t () glyphs glyph-index)] [extents (cairo-text-extents-create)]) (let-struct cluster cairo-text-cluster-t (num-glyphs num-bytes) (cairo-scaled-font-glyph-extents scaled-face clusterglyphs num-glyphs extents) (let ([ w (ftype-ref cairo-text-extents-t (x-advance) extents)]) (if (and (< (+ x-pos (/ w 2)) offset )) (loop (+ glyph-index num-glyphs) (+ byte-index num-bytes) (+ i 1) (+ x-pos w)) i)))) i))) (define (show-text cr text) (define-values (clusters cluster-count glyphs glyph-count scaled-face) (get-text-glyphs cr text)) ;; we use cairo-show-glyphs instead of the below loop. ;; if not special glyph spacing / kerning is needed... (at least by now) (cairo-show-glyphs cr glyphs glyph-count) #; (let loop ([glyph-index 0] [byte-index 0] [i 0]) (when (< i cluster-count) (let* ([cluster (ftype-&ref cairo-text-cluster-t () clusters i)] [clusterglyphs (ftype-&ref cairo-glyph-t () glyphs glyph-index)] [extents (cairo-text-extents-create)]) (let-struct cluster cairo-text-cluster-t (num-glyphs num-bytes) (cairo-scaled-font-glyph-extents scaled-face clusterglyphs glyph-count extents) ;;(printf "extents: status: ~d num-glyphs: ~d num-bytes: ~d~n" (cairo-status cr) num-glyphs num-bytes) ; (with-cairo cr (glyph-path clusterglyphs num-glyphs) (set-line-width 0) (fill-preserve) (stroke)) (loop (+ glyph-index num-glyphs) (+ byte-index num-bytes) (+ i 1))))))) (define (draw-text text x y w h) (define font-size (mi-font-size)) (define font-family (mi-font-family)) (define font-style (mi-font-style)) (define font-weight (mi-font-weight)) ................................................................................ [center (cairo-translate (mi-cr) (- (+ x (/ w 2)) (/ width 2)) (+ y height))] [right (cairo-translate (mi-cr) (- (+ x w) width x-bearing) (+ y height))] [else (cairo-translate (mi-cr) x (+ y height))]) (show-text (mi-cr) text) (cairo-identity-matrix (mi-cr)))) (list x-advance height)))) (define (draw-text/padding text x y w h) (draw-text text |
Changes to widgets.ss.
162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
#t] [else #f]))))))) (import (only (srfi s14 char-sets) char-set char-set:digit char-set-contains?) (only (thunder-utils) string-split string-replace)) ;; TODO: improve the cursor calculation and maybe use the cairo-show-glyphs api ;; to have more control, then also text selection could be implemented... ;; need to implement the position of cursor when clicked ;; keyboard arrows, delete, backspace, home & end supported already (define (line-editor el id text validator) (create-element el id #t (lambda () (define-values (x y w h) (values (mi-x) (mi-y) (mi-w) (mi-h))) (define (cursor-pos) (mi-wget id 'cursor-pos 0)) (define (cursor-pos-move dir) (let ([cp (cursor-pos)]) (cond [(and (< dir 0) (> cp 0)) (mi-wset id 'cursor-pos (- cp 1))] [(and (> dir 0) (< cp (string-length (text)))) (mi-wset id 'cursor-pos (+ cp 1))]))) ;(draw-rect x y w h) (if (> (cursor-pos) (string-length (text))) (mi-wset id 'cursor-pos (string-length (text)))) (when (eq? (mi-kbd-item) id) (let ([txt (text)] [txt-len (string-length (text))]) (case (mi-key) |
< < < < | > > > |
162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
#t] [else #f]))))))) (import (only (srfi s14 char-sets) char-set char-set:digit char-set-contains?) (only (thunder-utils) string-split string-replace)) (define (line-editor el id text validator) (create-element el id #t (lambda () (define-values (x y w h) (values (mi-x) (mi-y) (mi-w) (mi-h))) (define (cursor-pos) (mi-wget id 'cursor-pos 0)) (define (cursor-pos-move dir) (let ([cp (cursor-pos)]) (cond [(and (< dir 0) (> cp 0)) (mi-wset id 'cursor-pos (- cp 1))] [(and (> dir 0) (< cp (string-length (text)))) (mi-wset id 'cursor-pos (+ cp 1))]))) ;;(draw-rect x y w h) (when (and (mi-active-item) (mi-mouse-down?) (eq? (mi-hot-item) id) (eq? (mi-state) 'ready)) (mi-wset id 'cursor-pos (get-text-char-index-from-offset (mi-cr) (text) (- (mi-mouse-x) x (mi-padding)))) (printf "cursor-pos: ~d mouse-x: ~d x: ~d\n" (cursor-pos) (mi-mouse-x) x)) (if (> (cursor-pos) (string-length (text))) (mi-wset id 'cursor-pos (string-length (text)))) (when (eq? (mi-kbd-item) id) (let ([txt (text)] [txt-len (string-length (text))]) (case (mi-key) |