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

.

Browse Source 
original commit: eb8561bb851e12c113aabac364a26cd4c446364c
This commit is contained in:
Robby Findler 2005-01-20 21:29:48 +00:00
parent ccb86c681f
commit eb7bfa19bb
3 changed files with 123 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

201
collects/framework/private/canvas.ss
View File

@ -11,7 +11,8 @@
(unit/sig framework:canvas^ (unit/sig framework:canvas^
(import mred^ (import mred^
[preferences : framework:preferences^] [preferences : framework:preferences^]
[frame : framework:frame^]) [frame : framework:frame^]
[text : framework:text^])
(rename [-color% color%]) (rename [-color% color%])
@ -71,111 +72,111 @@
add-wide-snip add-wide-snip
add-tall-snip)) add-tall-snip))
;; wx: this needs to collude with
;; the edit, since the edit has the right callbacks.
(define wide-snip-mixin (define wide-snip-mixin
(mixin (basic<%>) (wide-snip<%>) (mixin (basic<%>) (wide-snip<%>)
(inherit get-editor) (inherit get-editor)
[define wide-snips null] (define/private ((update-snip-size width?) s)
[define tall-snips null] (let* ([width (box 0)]
[define update-snip-size [height (box 0)]
(lambda (width?) [leftm (box 0)]
(lambda (s) [rightm (box 0)]
(let* ([width (box 0)] [topm (box 0)]
[height (box 0)] [bottomm (box 0)]
[leftm (box 0)] [left-edge-box (box 0)]
[rightm (box 0)] [top-edge-box (box 0)]
[topm (box 0)] [snip-media (send s get-editor)]
[bottomm (box 0)] [edit (get-editor)]
[left-edge-box (box 0)] [get-width
[top-edge-box (box 0)] (let ([bl (box 0)]
[snip-media (send s get-editor)] [br (box 0)])
[edit (get-editor)] (lambda (s)
[get-width (send edit get-snip-location s bl #f #f)
(let ([bl (box 0)] (send edit get-snip-location s br #f #t)
[br (box 0)]) (- (unbox br) (unbox bl))))]
(lambda (s) [calc-after-width
(send edit get-snip-location s bl #f #f) (lambda (s)
(send edit get-snip-location s br #f #t) (+ 4 ;; this is compensate for an autowrapping bug
(- (unbox br) (unbox bl))))] (let loop ([s s])
[calc-after-width (cond
(lambda (s) [(not s) 0]
(+ 4 ;; this is compensate for an autowrapping bug [(member 'hard-newline (send s get-flags)) 0]
(let loop ([s s]) [(member 'newline (send s get-flags)) 0]
(cond [else
[(not s) 0] (if s
[(member 'hard-newline (send s get-flags)) 0] (+ (get-width s)
[(member 'newline (send s get-flags)) 0] 2 ;; for the caret
[else (loop (send s next)))
(if s 0)]))))])
(+ (get-width s) (when edit
2 ;; for the caret (send edit
(loop (send s next))) run-after-edit-sequence
0)]))))]) (lambda ()
(when edit (let ([admin (send edit get-admin)])
(send edit (send admin get-view #f #f width height)
run-after-edit-sequence (send s get-margin leftm topm rightm bottomm)
(lambda ()
(let ([admin (send edit get-admin)])
(send admin get-view #f #f width height)
(send s get-margin leftm topm rightm bottomm)
;; when the width is to be maximized and there is a ;; when the width is to be maximized and there is a
;; newline just behind the snip, we know that the left ;; newline just behind the snip, we know that the left
;; edge is zero. Special case for efficiency in the ;; edge is zero. Special case for efficiency in the
;; console printer ;; console printer
(let ([fallback (let ([fallback
(lambda () (lambda ()
(send edit get-snip-location (send edit get-snip-location
s left-edge-box top-edge-box))]) s left-edge-box top-edge-box))])
(cond (cond
[(not width?) (fallback)] [(not width?) (fallback)]
[(let ([prev (send s previous)]) [(let ([prev (send s previous)])
(and prev (and prev
(member 'hard-newline (send prev get-flags)))) (member 'hard-newline (send prev get-flags))))
(set-box! left-edge-box 0)] (set-box! left-edge-box 0)]
[else (fallback)])) [else (fallback)]))
(if width? (if width?
(let* ([after-width (calc-after-width (send s next))] (let* ([after-width (calc-after-width (send s next))]
[snip-width (max 0 (- (unbox width) [snip-width (max 0 (- (unbox width)
(unbox left-edge-box) (unbox left-edge-box)
(unbox leftm) (unbox leftm)
(unbox rightm) (unbox rightm)
after-width after-width
;; this two is the space that ;; this two is the space that
;; the caret needs at the right of ;; the caret needs at the right of
;; a buffer. ;; a buffer.
2))]) 2))])
(send* s (send* s
(set-min-width snip-width) (set-min-width snip-width)
(set-max-width snip-width)) (set-max-width snip-width))
(when snip-media (when snip-media
(send snip-media set-max-width (send snip-media set-max-width
(if (send snip-media auto-wrap) (if (send snip-media auto-wrap)
snip-width snip-width
0)))) 0))))
(let ([snip-height (max 0 (- (unbox height) (let ([snip-height (max 0 (- (unbox height)
(unbox top-edge-box) (unbox top-edge-box)
(unbox topm) (unbox topm)
(unbox bottomm)))]) (unbox bottomm)))])
(send* s (send* s
(set-min-height snip-height) (set-min-height snip-height)
(set-max-height snip-height)))))))))))] (set-max-height snip-height))))))))))
(public recalc-snips add-wide-snip add-tall-snip) (define/public (recalc-snips)
[define recalc-snips (let ([editor (get-editor)])
(lambda () (unless (is-a? editor text:wide-snip<%>)
(for-each (update-snip-size #t) wide-snips) (error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor))
(for-each (update-snip-size #f) tall-snips))] (when (eq? (send editor get-canvas) this)
[define add-wide-snip (for-each (update-snip-size #t) (send editor get-wide-snips))
(lambda (snip) (for-each (update-snip-size #f) (send editor get-tall-snips)))))
(set! wide-snips (cons snip wide-snips)) (define/public (add-wide-snip snip)
((update-snip-size #t) snip))] (let ([editor (get-editor)])
[define add-tall-snip (unless (is-a? editor text:wide-snip<%>)
(lambda (snip) (error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
(set! tall-snips (cons snip tall-snips)) (send editor add-wide-snip snip))
((update-snip-size #f) snip))] ((update-snip-size #t) snip))
(define/public (add-tall-snip snip)
(let ([editor (get-editor)])
(unless (is-a? editor text:wide-snip<%>)
(error 'add-wide-snip "expected to have a text:wide-snip<%> editor, instead ~e" editor))
(send editor add-tall-snip snip))
((update-snip-size #f) snip))
(define/override (on-size width height) (define/override (on-size width height)
(recalc-snips) (recalc-snips)
(super on-size width height)) (super on-size width height))

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

@ -300,6 +300,7 @@
hide-caret/selection<%> hide-caret/selection<%>
nbsp->space<%> nbsp->space<%>
delegate<%> delegate<%>
wide-snip<%>
searching<%> searching<%>
return<%> return<%>
info<%> info<%>
@ -327,6 +328,7 @@
foreground-color-mixin foreground-color-mixin
hide-caret/selection-mixin hide-caret/selection-mixin
nbsp->space-mixin nbsp->space-mixin
wide-snip-mixin
delegate-mixin delegate-mixin
searching-mixin searching-mixin
return-mixin return-mixin

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

@ -429,7 +429,22 @@ WARNING: printf is rebound in the body of the unit to always
(char=? cr-code code)) (char=? cr-code code))
(return)) (return))
(super on-local-char key)))) (super on-local-char key))))
(super-instantiate ()))) (super-new)))
(define wide-snip<%>
(interface (basic<%>)
add-wide-snip
add-tall-snip))
(define wide-snip-mixin
(mixin (basic<%>) (wide-snip<%>)
(define wide-snips '())
(define tall-snips '())
(define/public (add-wide-snip s) (set! wide-snips (cons s wide-snips)))
(define/public (get-wide-snips) wide-snips)
(define/public (add-tall-snip s) (set! tall-snips (cons s tall-snips)))
(define/public (get-tall-snips) tall-snips)
(super-new)))
(define delegate<%> (interface (basic<%>) (define delegate<%> (interface (basic<%>)
get-delegate get-delegate
@ -1772,7 +1787,7 @@ WARNING: printf is rebound in the body of the unit to always
(define hide-caret/selection% (hide-caret/selection-mixin basic%)) (define hide-caret/selection% (hide-caret/selection-mixin basic%))
(define nbsp->space% (nbsp->space-mixin basic%)) (define nbsp->space% (nbsp->space-mixin basic%))
(define delegate% (delegate-mixin basic%)) (define delegate% (delegate-mixin basic%))
(define standard-style-list% (editor:standard-style-list-mixin basic%)) (define standard-style-list% (editor:standard-style-list-mixin (wide-snip-mixin basic%)))
(define -keymap% (editor:keymap-mixin standard-style-list%)) (define -keymap% (editor:keymap-mixin standard-style-list%))
(define return% (return-mixin -keymap%)) (define return% (return-mixin -keymap%))
(define autowrap% (editor:autowrap-mixin -keymap%)) (define autowrap% (editor:autowrap-mixin -keymap%))