suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

...

Browse Source 
original commit: 0b86fb91d4d744e66d1a87432eb6df4871e1ed35
This commit is contained in:
Robby Findler 2001-12-10 17:32:04 +00:00
parent a1037a0094
commit 9040278b04
3 changed files with 100 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/framework/private/frame.ss
View File

@ -915,21 +915,31 @@
(define view-width-b (box 0))
(inherit paragraph-start-position paragraph-end-position
position-location invalidate-bitmap-cache scroll-to-position
get-visible-position-range position-paragraph)
get-visible-position-range position-paragraph
last-position)
(define/override (on-new-string-snip)
(instantiate text:1-pixel-string-snip% ()))
(define/override (on-new-tab-snip)
(instantiate text:1-pixel-tab-snip% ()))
;; set-start/end-para : (union (#f #f -> void) (number number -> void))
(define/public (set-start/end-para _start-para _end-para)
(unless (and (equal? _start-para start-para)
(equal? _end-para end-para))
(let ([old-start-para start-para]
[old-end-para end-para])
(set! start-para _start-para)
(set! end-para _end-para)
(cond
[(= 0 (last-position))
(set! start-para #f)
(set! end-para #f)]
[else
(set! start-para _start-para)
(set! end-para _end-para)])
(when (and start-para end-para)
(let-values ([(v-start v-end) (let ([bs (box 0)]
[bf (box 0)])
(get-visible-position-range bs bf)

1
collects/framework/private/sig.ss
View File

@ -150,6 +150,7 @@
basic%
hide-caret/selection%
1-pixel-string-snip%
1-pixel-tab-snip%
delegate%
keymap%
return%

106
collects/framework/private/text.ss
View File

@ -398,30 +398,96 @@
(get-text 0 (get-count)))])
(send cpy set-flags (get-flags))))
(define/override (get-extent dc x y wb hb db sb lb rb)
(let ([set/f!
(lambda (b n)
(when (box? b)
(set-box! b n)))])
(cond
[(memq 'invisible (get-flags))
(set/f! wb 0)
(set/f! hb 0)]
[else
(set/f! wb (get-count))
(set/f! hb 1)])
(set/f! db 0)
(set/f! sb 0)
(set/f! lb 0)
(set/f! rb 0))
(define (for-each/sections f str)
(let loop ([n (string-length str)]
[len 0]
[blank? #t])
(cond
[(memq 'invisible (get-flags))
(set/f! wb 0)
(set/f! hb 0)]
[(zero? n)
(unless blank?
(f n len))]
[else
(set/f! wb (get-count))
(set/f! hb 1)])
(set/f! db 0)
(set/f! sb 0)
(set/f! lb 0)
(set/f! rb 0)))
(define/override (draw dc x y left right top bottom dx dy draw-caret)
(let ([white? (char-whitespace? (string-ref str (- n 1)))])
(cond
[(eq? white? blank?)
(loop (- n 1) (+ len 1) blank?)]
[else
(unless blank?
(f n len))
(loop (- n 1)
1
(not blank?))]))])))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let ([str (get-text 0 (get-count))])
(let loop ([n (string-length str)])
(unless (zero? n)
(let ([char (string-ref str (- n 1))])
(unless (char-whitespace? char)
(send dc draw-point (+ x (- n 1)) y)))
(loop (- n 1))))))
(when (<= top y bottom)
(for-each/sections
(lambda (start len)
(send dc draw-line
(+ x start)
y
(+ x start (- len 1))
y))
str))))
(apply super-make-object args)))
(define 1-pixel-tab-snip%
(class tab-snip%
(init-rest args)
(inherit get-text get-count set-count get-flags)
(define/override (split position first second)
(let* ([str (get-text 0 (get-count))]
[new-second (make-object 1-pixel-string-snip%
(substring str position (string-length str)))])
(set-box! first this)
(set-box! second new-second)
(set-count position)
(void)))
(define/override (copy)
(let ([cpy (make-object 1-pixel-tab-snip%)])
(send cpy set-flags (get-flags))))
(inherit get-admin)
(define/override (get-extent dc x y wb hb db sb lb rb)
(set/f! wb 0)
(let ([admin (get-admin)])
(when admin
(let ([ed (send admin get-editor)])
(when (is-a? ed text%)
(let ([len-b (box 0)]
[tab-width-b (box 0)]
[in-units-b (box #f)])
(send ed get-tabs len-b tab-width-b in-units-b)
(when (and (or (equal? (unbox len-b) 0)
(equal? (unbox len-b) null))
(not (unbox in-units-b)))
(set/f! wb (unbox tab-width-b))))))))
(set/f! hb 0)
(set/f! db 0)
(set/f! sb 0)
(set/f! lb 0)
(set/f! rb 0))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(void))
(apply super-make-object args)))
(define (set/f! b n)
(when (box? b)
(set-box! b n)))
(define delegate-mixin
(mixin (basic<%>) (delegate<%>)