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

...

Browse Source 
original commit: f9e57633812809a3aaa007e6d49f36caa942eba3
This commit is contained in:
Robby Findler 2001-12-10 16:15:12 +00:00
parent 238029ba8f
commit a1037a0094
4 changed files with 67 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -917,6 +917,9 @@
position-location invalidate-bitmap-cache scroll-to-position position-location invalidate-bitmap-cache scroll-to-position
get-visible-position-range position-paragraph) get-visible-position-range position-paragraph)
(define/override (on-new-string-snip)
(instantiate text:1-pixel-string-snip% ()))
;; set-start/end-para : (union (#f #f -> void) (number number -> void)) ;; set-start/end-para : (union (#f #f -> void) (number number -> void))
(define/public (set-start/end-para _start-para _end-para) (define/public (set-start/end-para _start-para _end-para)
(unless (and (equal? _start-para start-para) (unless (and (equal? _start-para start-para)
@ -994,7 +997,10 @@
[b (box 0)]) [b (box 0)])
(position-location pos #f b top? #f #t) (position-location pos #f b top? #f #t)
(unbox b))) (unbox b)))
(super-instantiate ()))) (super-instantiate ())
(inherit set-line-spacing)
(set-line-spacing 0)))
(define delegate-mixin (define delegate-mixin
(mixin (text<%>) (delegate<%>) (mixin (text<%>) (delegate<%>)

5
collects/framework/private/group.ss
View File

@ -18,7 +18,8 @@
[preferences : framework:preferences^] [preferences : framework:preferences^]
[gui-utils : framework:gui-utils^] [gui-utils : framework:gui-utils^]
[text : framework:text^] [text : framework:text^]
[canvas : framework:canvas^]) [canvas : framework:canvas^]
[menu : framework:menu^])
(define-struct frame (frame id)) (define-struct frame (frame id))
@ -88,7 +89,7 @@
(lambda (menu) (lambda (menu)
(for-each (lambda (item) (send item delete)) (for-each (lambda (item) (send item delete))
(send menu get-items)) (send menu get-items))
(instantiate menu-item% () (instantiate menu:can-restore-checkable-menu-item% ()
(label (string-constant bring-frame-to-front...)) (label (string-constant bring-frame-to-front...))
(parent menu) (parent menu)
(callback (lambda (x y) (choose-a-frame (send (send menu get-parent) get-frame)))) (callback (lambda (x y) (choose-a-frame (send (send menu get-parent) get-frame))))

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

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

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

@ -378,15 +378,62 @@
(define delegate<%> (interface (basic<%>) (define delegate<%> (interface (basic<%>)
get-delegate get-delegate
set-delegate set-delegate))
get-delegate-style-delta
set-delegate-style-delta)) ;; this won't work properly for tab snips. probably need another subclass, or something.
(define small-style-delta (make-object style-delta% 'change-size 2)) (define 1-pixel-string-snip%
(class string-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-string-snip%
(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/override (draw dc x y left right top 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))))))
(apply super-make-object args)))
(define delegate-mixin (define delegate-mixin
(mixin (basic<%>) (delegate<%>) (mixin (basic<%>) (delegate<%>)
(inherit split-snip find-snip get-snip-position (inherit split-snip find-snip get-snip-position
find-first-snip get-style-list set-tabs) find-first-snip get-style-list set-tabs)
(define/private (copy snip)
(let ([res (make-object 1-pixel-string-snip%
(send snip get-text 0 (send snip get-count)))])
(send res set-flags (send snip get-flags))
res))
(field (delegate #f)) (field (delegate #f))
(define/public (get-delegate) delegate) (define/public (get-delegate) delegate)
(define/public (set-delegate _d) (define/public (set-delegate _d)
@ -402,14 +449,10 @@
(let loop ([snip (find-first-snip)]) (let loop ([snip (find-first-snip)])
(when snip (when snip
(send delegate insert (send delegate insert
(send snip copy) (copy snip)
(send delegate last-position) (send delegate last-position)
(send delegate last-position)) (send delegate last-position))
(loop (send snip next)))) (loop (send snip next))))
(send delegate change-style
delegate-style-delta
0
(send delegate last-position))
(send delegate lock #t) (send delegate lock #t)
(send delegate end-edit-sequence))) (send delegate end-edit-sequence)))
@ -422,12 +465,6 @@
(when canvas (when canvas
(send (send canvas get-top-level-window) delegate-moved))))) (send (send canvas get-top-level-window) delegate-moved)))))
(define delegate-style-delta (make-object style-delta% 'change-size 1))
(define/public (get-delegate-style-delta)
delegate-style-delta)
(define/public (set-delegate-style-delta _sd)
(set! delegate-style-delta _sd))
(rename [super-on-edit-sequence on-edit-sequence]) (rename [super-on-edit-sequence on-edit-sequence])
(define/override (on-edit-sequence) (define/override (on-edit-sequence)
(super-on-edit-sequence) (super-on-edit-sequence)
@ -451,9 +488,8 @@
(let loop ([snip (find-snip (+ start len) 'before)]) (let loop ([snip (find-snip (+ start len) 'before)])
(when snip (when snip
(unless ((get-snip-position snip) . < . start) (unless ((get-snip-position snip) . < . start)
(send delegate insert (send snip copy) start start) (send delegate insert (copy snip) start start)
(loop (send snip previous))))) (loop (send snip previous)))))
(send delegate change-style delegate-style-delta start (+ start len))
(send delegate lock #t) (send delegate lock #t)
(send delegate end-edit-sequence))) (send delegate end-edit-sequence)))
@ -477,9 +513,9 @@
(let* ([snip (find-snip start 'after)] (let* ([snip (find-snip start 'after)]
[style (send snip get-style)] [style (send snip get-style)]
[other-style [other-style
(send (send delegate get-style-list) find-or-create-style '(send (send delegate get-style-list) find-or-create-style
style delegate-style-delta)]) style delegate-style-delta)])
(send delegate change-style other-style start (+ start len))) (send delegate change-style style start (+ start len)))
(send delegate lock #f) (send delegate lock #f)
(send delegate end-edit-sequence))) (send delegate end-edit-sequence)))
@ -498,10 +534,6 @@
(send delegate lock #f) (send delegate lock #f)
(send delegate load-file filename format) (send delegate load-file filename format)
(send delegate set-filename #f) (send delegate set-filename #f)
(send delegate change-style
delegate-style-delta
0
(send delegate last-position))
(send delegate lock #t) (send delegate lock #t)
(send delegate end-edit-sequence))) (send delegate end-edit-sequence)))
(super-instantiate ()))) (super-instantiate ())))