Check-in [67dae557f2]
Not logged in

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:67dae557f2d06bdf500faa13d4cd7e099c2a8111
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
Hide Diffs Unified Diffs Ignore Whitespace Patch

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)