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 Side-by-Side Diffs Ignore Whitespace Patch

Changes to draw.ss.

    11     11   ;; Unless required by applicable law or agreed to in writing, software
    12     12   ;; distributed under the License is distributed on an "AS IS" BASIS,
    13     13   ;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
    14     14   ;; See the License for the specific language governing permissions and
    15     15   ;; limitations under the License.
    16     16   
    17     17   (define draw-pool '())
           18  +
    18     19   (define (round-rect x y width height br)
    19     20     (define-values (tlrx tlry trrx trry brrx brry blrx blry)
    20     21       (match br
    21     22   	   [((tlrx tlry) (trrx trry) (brrx brry) (blrx blry))
    22     23   	    (values tlrx tlry trrx trry brrx brry blrx blry)]
    23     24   	   [else
    24     25   	    (values 0 0 0 0 0 0 0 0)]))
................................................................................
   148    149   	   (draw-bg)
   149    150   	   (with-cairo (mi-cr)
   150    151   		       (set-source-color bg-color)
   151    152   		       (fill)))
   152    153        
   153    154   	   (draw-path))))
   154    155   
          156  +(define (text-get-char-index-from-offset text)
          157  +  
          158  +  (define font-size (mi-font-size))
          159  +  (define font-family (mi-font-family))
          160  +  (define font-style (mi-font-style))
          161  +  (define font-weight (mi-font-weight))
          162  +  (define text-align (mi-text-align))
          163  +  (define color (mi-color))
          164  +
          165  +  (check-arg string? text text-get-char-index-from-offset)
          166  +
          167  +  )
          168  +  
   155    169   (define (text-extents text)
   156    170     (define font-size (mi-font-size))
   157    171     (define font-family (mi-font-family))
   158    172     (define font-style (mi-font-style))
   159    173     (define font-weight (mi-font-weight))
   160    174     (define text-align (mi-text-align))
   161    175     (define color (mi-color))
   162    176   
   163         -  (check-arg string? text draw-text)
          177  +  (check-arg string? text text-extents)
   164    178   
   165    179     (let ([extents (cairo-text-extents-create)])
   166    180       (cairo-set-font-size (mi-cr) font-size)
   167    181       (cairo-select-font-face  (mi-cr) (string-append font-family (string #\nul))
   168    182   					    (cairo-font-slant font-style) ;; normal|italic|oblique
   169    183   					    (cairo-font-weight font-weight)) ;; normal|bold
   170    184       (cairo-text-extents (mi-cr) text extents)
................................................................................
   176    190     (syntax-rules ()
   177    191       [(_ ftype fptr)
   178    192        (make-ftype-pointer ftype
   179    193   			 (ftype-pointer-address fptr))]))
   180    194   
   181    195   (define (*int ptr) (ftype-ref int () ptr))
   182    196   
   183         -(define (show-text cr text x y font-size)
          197  +(define (get-text-glyphs cr text)
   184    198     (define glyphs* (cairo-glyph*-create))
   185    199     (define glyph-count (cairo-int-create))
   186    200     (define clusters* (cairo-text-cluster*-create))
   187    201     (define cluster-count (cairo-int-create))
   188    202     (define clusterflags (cairo-text-cluster-flags-create))
   189    203     (define scaled-face (cairo-get-scaled-font cr))
   190    204     (define clusters #f)
................................................................................
   192    206     
   193    207     (ftype-set! void* () (cast void* clusters*) 0)
   194    208     (ftype-set! void* () (cast void* glyphs*) 0)
   195    209   
   196    210     ;; THIS COULD BE CACHED SOMEWHERE?
   197    211     (unless (eq? 'success
   198    212   	       (cairo-scaled-font-text-to-glyphs
   199         -		scaled-face x y text (string-length text)
          213  +		scaled-face 0 0  text (string-length text)
   200    214   		glyphs* glyph-count
   201    215   		clusters* cluster-count
   202    216   		clusterflags))
   203    217   	  (raise (error 'show-text "stat error" stat)))
   204    218   
   205         -  (set! clusters (cairo-guard-pointer (ftype-&ref cairo-text-cluster-t* (*) clusters*)))
   206         -  (set! glyphs (cairo-guard-pointer (ftype-&ref cairo-glyph-t* (*) glyphs*)))
          219  +  (values (cairo-guard-pointer (ftype-&ref cairo-text-cluster-t* (*) clusters*))
          220  +	  (*int cluster-count)
          221  +	  (cairo-guard-pointer (ftype-&ref cairo-glyph-t* (*) glyphs*))
          222  +	  (*int glyph-count)
          223  +	  scaled-face))
          224  +
          225  +
          226  +(define (get-text-char-index-from-offset cr text offset)
          227  +  (define-values (clusters cluster-count glyphs glyph-count scaled-face)
          228  +    (get-text-glyphs cr text))
          229  +  
          230  +  (let loop ([glyph-index 0] [byte-index 0] [i 0] [x-pos 0])
          231  +    (if (< i cluster-count)
          232  +	(let* ([cluster       (ftype-&ref cairo-text-cluster-t () clusters i)]
          233  +	       [clusterglyphs (ftype-&ref cairo-glyph-t () glyphs glyph-index)]
          234  +	       [extents (cairo-text-extents-create)])
          235  +	  (let-struct cluster cairo-text-cluster-t (num-glyphs num-bytes)
          236  +		      (cairo-scaled-font-glyph-extents scaled-face clusterglyphs num-glyphs extents)
          237  +		      (let ([ w (ftype-ref cairo-text-extents-t (x-advance) extents)])
          238  +			(if  (and (< (+ x-pos (/ w 2)) offset ))
          239  +			     (loop (+ glyph-index num-glyphs)
          240  +				   (+ byte-index num-bytes)
          241  +				   (+ i 1)
          242  +				   (+ x-pos w))
          243  +			     i))))
          244  +	i)))
   207    245   
   208         -  ;; WE COULD USE cairo-show-glyphs instead?
          246  +(define (show-text cr text)
          247  +  (define-values (clusters cluster-count glyphs glyph-count scaled-face)
          248  +    (get-text-glyphs cr text))
          249  +  
          250  +  ;; we use cairo-show-glyphs instead of the below loop.
          251  +  ;; if not special glyph spacing / kerning is needed... (at least by now)
          252  +  (cairo-show-glyphs cr glyphs glyph-count)
          253  +  #;
   209    254     (let loop ([glyph-index 0] [byte-index 0] [i 0])
   210         -    (when (< i (*int cluster-count))
   211         -	  (let* ([cluster       (ftype-&ref cairo-text-cluster-t () clusters i)]
   212         -		 [clusterglyphs (ftype-&ref cairo-glyph-t () glyphs glyph-index)]
   213         -		 [extents (cairo-text-extents-create)])
   214         -	    (let-struct
   215         -	     cluster cairo-text-cluster-t (num-glyphs num-bytes)
   216         -	     (cairo-scaled-font-glyph-extents scaled-face clusterglyphs (*int glyph-count) extents)
   217         -	     ;;(printf "extents: status: ~d num-glyphs: ~d num-bytes: ~d~n" (cairo-status cr) num-glyphs num-bytes)
   218         -	     (with-cairo cr
   219         -			 (glyph-path clusterglyphs num-glyphs)
   220         -			 (set-line-width 0)
   221         -			 (fill-preserve)
   222         -			 (stroke))
   223         -	     (loop (+ glyph-index num-glyphs)
   224         -		   (+ byte-index num-bytes)
   225         -		   (+ i 1)))))))
          255  +  (when (< i cluster-count)
          256  +  (let* ([cluster       (ftype-&ref cairo-text-cluster-t () clusters i)]
          257  +  [clusterglyphs (ftype-&ref cairo-glyph-t () glyphs glyph-index)]
          258  +  [extents (cairo-text-extents-create)])
          259  +  (let-struct
          260  +  cluster cairo-text-cluster-t (num-glyphs num-bytes)
          261  +  (cairo-scaled-font-glyph-extents scaled-face clusterglyphs glyph-count extents)
          262  +  ;;(printf "extents: status: ~d num-glyphs: ~d num-bytes: ~d~n" (cairo-status cr) num-glyphs num-bytes) ;
          263  +  (with-cairo cr
          264  +  (glyph-path clusterglyphs num-glyphs)
          265  +  (set-line-width 0)
          266  +  (fill-preserve)
          267  +  (stroke))
          268  +  (loop (+ glyph-index num-glyphs)
          269  +  (+ byte-index num-bytes)
          270  +  (+ i 1)))))))
   226    271   
   227    272   
   228    273   (define (draw-text text x y w h)
   229    274     (define font-size (mi-font-size))
   230    275     (define font-family (mi-font-family))
   231    276     (define font-style (mi-font-style))
   232    277     (define font-weight (mi-font-weight))
................................................................................
   260    305   			[center
   261    306   			 (cairo-translate (mi-cr) (- (+ x (/ w 2)) (/ width 2)) (+ y height))]
   262    307   			[right
   263    308   			 (cairo-translate (mi-cr) (- (+ x w) width x-bearing) (+ y height))]
   264    309   			[else
   265    310   			 (cairo-translate (mi-cr) x (+ y height))])
   266    311   		      
   267         -		      (show-text (mi-cr) text 0 0 font-size)
          312  +		      (show-text (mi-cr) text)
   268    313   		      
   269    314   		      (cairo-identity-matrix (mi-cr))))
   270    315   		   
   271    316   		   (list x-advance height))))
   272    317   
   273    318   (define (draw-text/padding text x y w h)
   274    319     (draw-text text 

Changes to widgets.ss.

   162    162   		    #t]
   163    163   		   [else #f])))))))
   164    164   
   165    165   
   166    166   (import (only (srfi s14 char-sets) char-set char-set:digit char-set-contains?)
   167    167   	(only (thunder-utils) string-split string-replace))
   168    168   
   169         -;; TODO: improve the cursor calculation and maybe use the cairo-show-glyphs api
   170         -;; to have more control, then also text selection could be implemented...
   171         -;; need to implement the position of cursor when clicked
   172         -;; keyboard arrows, delete, backspace, home & end supported already
   173    169   (define (line-editor el id text validator)
   174    170     (create-element 
   175    171      el id #t
   176    172      (lambda ()
   177    173        (define-values (x y w h) (values (mi-x) (mi-y) (mi-w) (mi-h)))
   178    174        (define (cursor-pos) (mi-wget id 'cursor-pos 0))
   179    175        (define (cursor-pos-move dir)
   180    176          (let ([cp (cursor-pos)])
   181    177   	 (cond
   182    178   	  [(and (< dir 0) (> cp 0))
   183    179   	   (mi-wset id 'cursor-pos (- cp 1))]
   184    180   	  [(and (> dir 0) (< cp (string-length (text))))
   185    181   	   (mi-wset id 'cursor-pos (+ cp 1))])))
   186         -     ;(draw-rect x y w h)
          182  +     ;;(draw-rect x y w h)
          183  +     (when (and (mi-active-item) (mi-mouse-down?) (eq? (mi-hot-item) id) (eq? (mi-state) 'ready))
          184  +	   (mi-wset id 'cursor-pos (get-text-char-index-from-offset (mi-cr) (text) (- (mi-mouse-x) x (mi-padding))))
          185  +	   (printf "cursor-pos: ~d mouse-x: ~d x: ~d\n" (cursor-pos) (mi-mouse-x) x))
   187    186        (if (> (cursor-pos) (string-length (text)))
   188    187   	 (mi-wset id 'cursor-pos (string-length (text))))
   189    188   
   190    189        (when (eq? (mi-kbd-item) id)
   191    190          (let ([txt (text)]
   192    191   	     [txt-len (string-length (text))])
   193    192   	 (case (mi-key)