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

207
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) ;; when the width is to be maximized and there is a
(send s get-margin leftm topm rightm bottomm) ;; newline just behind the snip, we know that the left
;; edge is zero. Special case for efficiency in the
;; console printer
;; when the width is to be maximized and there is a (let ([fallback
;; newline just behind the snip, we know that the left (lambda ()
;; edge is zero. Special case for efficiency in the (send edit get-snip-location
;; console printer s left-edge-box top-edge-box))])
(let ([fallback (cond
(lambda () [(not width?) (fallback)]
(send edit get-snip-location [(let ([prev (send s previous)])
s left-edge-box top-edge-box))]) (and prev
(cond (member 'hard-newline (send prev get-flags))))
[(not width?) (fallback)] (set-box! left-edge-box 0)]
[(let ([prev (send s previous)]) [else (fallback)]))
(and prev
(member 'hard-newline (send prev get-flags)))) (if width?
(set-box! left-edge-box 0)] (let* ([after-width (calc-after-width (send s next))]
[else (fallback)])) [snip-width (max 0 (- (unbox width)
(unbox left-edge-box)
(if width? (unbox leftm)
(let* ([after-width (calc-after-width (send s next))] (unbox rightm)
[snip-width (max 0 (- (unbox width) after-width
(unbox left-edge-box) ;; this two is the space that
(unbox leftm) ;; the caret needs at the right of
(unbox rightm) ;; a buffer.
after-width 2))])
;; this two is the space that (send* s
;; the caret needs at the right of (set-min-width snip-width)
;; a buffer. (set-max-width snip-width))
2))]) (when snip-media
(send* s (send snip-media set-max-width
(set-min-width snip-width) (if (send snip-media auto-wrap)
(set-max-width snip-width)) snip-width
(when snip-media 0))))
(send snip-media set-max-width (let ([snip-height (max 0 (- (unbox height)
(if (send snip-media auto-wrap) (unbox top-edge-box)
snip-width (unbox topm)
0)))) (unbox bottomm)))])
(let ([snip-height (max 0 (- (unbox height) (send* s
(unbox top-edge-box) (set-min-height snip-height)
(unbox topm) (set-max-height snip-height))))))))))
(unbox bottomm)))]) (define/public (recalc-snips)
(send* s (let ([editor (get-editor)])
(set-min-height snip-height) (unless (is-a? editor text:wide-snip<%>)
(set-max-height snip-height)))))))))))] (error 'recalc-snips "expected a text:wide-snip<%> editor, instead ~e" editor))
(public recalc-snips add-wide-snip add-tall-snip) (when (eq? (send editor get-canvas) this)
[define recalc-snips (for-each (update-snip-size #t) (send editor get-wide-snips))
(lambda () (for-each (update-snip-size #f) (send editor get-tall-snips)))))
(for-each (update-snip-size #t) wide-snips) (define/public (add-wide-snip snip)
(for-each (update-snip-size #f) tall-snips))] (let ([editor (get-editor)])
[define add-wide-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! wide-snips (cons snip wide-snips)) (send editor add-wide-snip snip))
((update-snip-size #t) snip))] ((update-snip-size #t) snip))
[define add-tall-snip (define/public (add-tall-snip snip)
(lambda (snip) (let ([editor (get-editor)])
(set! tall-snips (cons snip tall-snips)) (unless (is-a? editor text:wide-snip<%>)
((update-snip-size #f) 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%))