From a82730944dd94572d3f1dc8af6146e9633b662b0 Mon Sep 17 00:00:00 2001 From: Mike MacHenry Date: Mon, 15 Dec 2003 18:53:03 +0000 Subject: [PATCH] fixed the major pasteboard bugs original commit: 0cfc7d5945fd67acb7c2bb79c04cbea188aaf692 --- .../aligned-editor-container.ss | 221 +++++---------- .../geometry-managed-pasteboard.ss | 211 ++++++-------- .../private/aligned-pasteboard/interface.ss | 53 ++-- .../private/aligned-pasteboard/snip-lib.ss | 12 +- .../aligned-pasteboard/tests/more-tests.ss | 263 +----------------- .../private/aligned-pasteboard/tests/test2.ss | 1 - 6 files changed, 207 insertions(+), 554 deletions(-) diff --git a/collects/mrlib/private/aligned-pasteboard/aligned-editor-container.ss b/collects/mrlib/private/aligned-pasteboard/aligned-editor-container.ss index d58092eb..86544435 100644 --- a/collects/mrlib/private/aligned-pasteboard/aligned-editor-container.ss +++ b/collects/mrlib/private/aligned-pasteboard/aligned-editor-container.ss @@ -1,10 +1,3 @@ -;; notes: When resize of the editor snip is called, the child pasteboard gets sizes for its get-view-size -;; method set. These values are based on the snips size and it's margin. Since the snips can be -;; invisable at times (often due to scroll bars) using get-view-size is not sufficient. I have -;; calculated the view size myself in the snips resize method. It is possible for the margins to -;; change size after the resize callback is invoked. This would cause inconsistencies so I may have -;; to override set-margin (and any other methods that may change the margin) to maintain consistency. - (module aligned-editor-container mzscheme (require @@ -22,6 +15,13 @@ aligned-snip-mixin) ;; a canvas that can contain an aligned-pasteboard<%> + ;; STATUS: When both min-width and min-height change the size of the canvas + ;; I might be getting two on-size method invocations inside + ;; set-aligned-min-sizes. + ;; Also, I might not need to call realign-to-alloted in + ;; set-aligned-min-sizes of the canvas because realign is called from + ;; within on-size. This is true if and only if realignment needs to + ;; be called only when the canvas size changes. (define aligned-editor-canvas% (class* editor-canvas% (aligned-pasteboard-parent<%>) (inherit get-editor get-size min-width min-height) @@ -33,9 +33,8 @@ ;; set-aligned-min-size (-> (void)) ;; sets the aligned min width and height of all aligned children - (define/public (set-aligned-min-sizes) + (define/public (aligned-min-sizes-invalid) (let ([editor (get-editor)]) - (send editor set-aligned-min-sizes) (when (memq 'no-hscroll style) (min-width (+ (inexact->exact @@ -45,16 +44,21 @@ (min-height (+ (inexact->exact (send editor get-aligned-min-height)) - machenrys-constant height-diff))))) + machenrys-constant height-diff))) + ;; I might need to call realign not realign-to-alloted, but with what values? + (send editor realign-to-alloted))) ;; on-size (number? number? . -> . (void)) ;; called when the canvas's parent size changes (rename (super-on-size on-size)) (define/override (on-size width height) (super-on-size width height) - (send (get-editor) realign - (- width width-diff machenrys-constant) - (- height height-diff machenrys-constant))) + (let ([w (- width width-diff machenrys-constant)] + [h (- height height-diff machenrys-constant)]) + (when (and (positive? w) (positive? h)) + (send* (get-editor) + (set-aligned-min-sizes) + (realign w h))))) ;; calc-view-client-diff (-> (void)) ;; calculates and sets the difference between client-size and view-size of the editor @@ -73,10 +77,8 @@ (inexact->exact (unbox view-height))))))) - (super-instantiate () - (style style)) - (calc-view-client-diff) - )) + (super-new (style style)) + (calc-view-client-diff))) ;; a snip that can contain an aligned-pasteboard<%> and also be stretched within an aligned-pasteboard<%> (define aligned-editor-snip% @@ -111,16 +113,17 @@ ;; resize (number? number? . -> . boolean?) ;; called to resize the snip (rename [super-resize resize]) - (define/override (resize width height) + (define/override (resize width height) (super-resize width height) (let ([left (box 0)] [top (box 0)] [right (box 0)] [bottom (box 0)]) (get-margin left top right bottom) - (send (get-editor) realign - (- width (unbox left) (unbox right)) - (- height (unbox top) (unbox bottom))))) + (let ([w (- width (unbox left) (unbox right))] + [h (- height (unbox top) (unbox bottom))]) + (when (and (positive? w) (positive? h)) + (send (get-editor) realign w h))))) ;; get-aligned-min-width (-> number?) ;; the minimum width of the snip based on the children @@ -148,140 +151,48 @@ (send (get-editor) get-aligned-min-height) machenrys-constant))) - ;; set-aligned-min-size (-> (void)) - ;; calculates and stores the minimum height and width of the snip + ;; (-> void?) + ;; sets the aligned-min-sizes of all the editors and snips in this snip (define/public (set-aligned-min-sizes) - (send (get-editor) set-aligned-min-sizes) - (set-min-width (get-aligned-min-width)) - (set-min-height (get-aligned-min-height))) + (send (get-editor) set-aligned-min-sizes)) - (super-instantiate ()) - )) + ;; (-> void?) + ;; calculates and stores the minimum height and width of the snip + ;; note: more efficient to check for parent ahead of time and not + ;; calculate the margins when I don't have one. + (define/public (aligned-min-sizes-invalid) + (let ([parent (snip-parent this)]) + (cond + [(not parent) (void)] + [(is-a? parent aligned-pasteboard<%>) + (send parent aligned-min-sizes-invalid)] + [else (align-to-min)]))) + + ;; This code is needed to probe the tree of editors for their real sizes when they + ;; finally know them. This happens when the top level snip gets an admin. + (rename [super-set-admin set-admin]) + (define/override (set-admin admin) + (super-set-admin admin) + (let ([parent (snip-parent this)]) + (when (and parent (not (is-a? parent aligned-pasteboard<%>))) + (set-aligned-min-sizes) + (align-to-min)))) + + (define (align-to-min) + ;; Note: Not setting the min-width might improve efficientcy and + ;; may not be necessary since snips grow to the size of + ;; the things they contain. I'm going to try it so the + ;; following two lines are commented out. + ;(set-min-width aligned-min-width) + ;(set-min-height aligned-min-height) + (let* ([ed (get-editor)] + [w (send ed get-aligned-min-width)] + [h (send ed get-aligned-min-height)]) + (when (and (positive? w) (positive? h)) + (send ed realign w h)))) + + (super-new))) - (define (aligned-snip-mixin super%) - (class* super% (aligned-snip<%>) - (inherit get-editor get-margin) - - (init - (stretchable-width true) - (stretchable-height true)) - - (field - (stretchable-width-field stretchable-width) - (stretchable-height-field stretchable-height)) - - (public (stretchable-width-method stretchable-width) - (stretchable-height-method stretchable-height)) - - ;; stretchable-width (case-> (Boolean . -> . (void)) (-> Boolean)) - ;; get or set the stretchablity of the pasteboards width - (define stretchable-width-method - (case-lambda - [(value) (set! stretchable-width-field value)] - [() stretchable-width-field])) - - ;; stretchable-height (case-> (Boolean . -> .(void)) (-> Boolean)) - ;; get or set the stretchablity of the pasteboards height - (define stretchable-height-method - (case-lambda - [(value) (set! stretchable-height-field value)] - [() stretchable-height-field])) - - ;; get-aligned-min-width (-> number?) - ;; the minimum width of the snip based on the children - (define/public (get-aligned-min-width) - (let ([left (box 0)] - [top (box 0)] - [right (box 0)] - [bottom (box 0)]) - (get-margin left top right bottom) - (+ (unbox left) - (let* ([ed (get-editor)] - [last (send ed last-line)]) - (let loop ([line 0]) - (if (= line last) - 0 - (max (send ed line-length line) - (loop (add1 line)))))) - (unbox right)))) - - ;; get-aligned-min-height (-> number?) - ;; the minimum height of the snip based on the children - (define/public (get-aligned-min-height) - (let ([left (box 0)] - [top (box 0)] - [right (box 0)] - [bottom (box 0)] - [editor (get-editor)]) - (get-margin left top right bottom) - (+ (unbox top) (unbox bottom) - (* (send editor line-location 0 false) - (add1 (send editor last-line)))))) - -; ; get-aligned-min-width (-> number?) -; ; the minimum width of the snip based on the children -; (inherit get-max-width set-max-width get-min-width set-min-width) -; (define/public (get-aligned-min-width) -; (let* ([parent (snip-parent this)] -; [ed (get-editor)] -; [ed-max (send ed get-max-width)] -; [ed-min (send ed get-min-width)] -; [this-max (get-max-width)] -; [this-min (get-min-width)]) -; (when (is-a? parent aligned-pasteboard<%>) -; (send parent ignore-resizing true)) -; (send parent begin-edit-sequence) -; (send ed begin-edit-sequence) -; (send ed set-max-width 'none) -; (send ed set-min-width 'none) -; (set-max-width 'none) -; (set-min-width 'none) -; (begin0 -; (let ([left (box 0)] -; [top (box 0)] -; [right (box 0)] -; [bottom (box 0)]) -; (get-margin left top right bottom) -; (+ (unbox left) -; (snip-width this))) -; (send ed set-max-width ed-max) -; (send ed set-max-width ed-min) -; (set-min-width this-min) -; (set-max-width this-max) -; (send ed end-edit-sequence) -; (send parent end-edit-sequence) -; (when (is-a? parent aligned-pasteboard<%>) -; (send parent ignore-resizing false))))) -; -; ; get-aligned-min-height (-> number?) -; ; the minimum height of the snip based on the children -; (inherit get-max-height set-max-height get-min-height set-min-height) -; (define/public (get-aligned-min-height) -; (let* ([parent (snip-parent this)] -; [ed (get-editor)] -; [ed-max (send ed get-max-height)] -; [ed-min (send ed get-min-height)] -; [this-max (get-max-height)] -; [this-min (get-min-height)]) -; (when (is-a? parent aligned-pasteboard<%>) -; (send parent ignore-resizing true)) -; (send parent begin-edit-sequence) -; (send ed begin-edit-sequence) -; (send ed set-max-height 'none) -; (send ed set-min-height 'none) -; (set-max-height 'none) -; (set-min-height 'none) -; (begin0 -; (snip-height this) -; (send ed set-max-height ed-max) -; (send ed set-min-height ed-min) -; (set-min-height this-min) -; (set-max-height this-max) -; (send ed end-edit-sequence) -; (send parent end-edit-sequence) -; (when (is-a? parent aligned-pasteboard<%>) -; (send parent ignore-resizing false))))) - - (super-instantiate ()) - )) - ) \ No newline at end of file + ;not-yet-implemented + (define aligned-snip-mixin (lambda (x) x)) + ) diff --git a/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss b/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss index c426939b..7be7c7cf 100644 --- a/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss +++ b/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss @@ -12,6 +12,19 @@ "snip-lib.ss" "pasteboard-lib.ss") + (define f 0) + (define rect-print + (match-lambda + [() (void)] + [(($ rect + ($ dim x width stretchable-width?) + ($ dim y height stretchable-height?)) + others ...) + (printf "(make-rect (make-dim ~s ~s ~s) (make-dim ~s ~s ~s))~n" + x width stretchable-width? + y height stretchable-height?) + (rect-print others)])) + (provide/contract (make-aligned-pasteboard ((symbols 'vertical 'horizontal) . -> . class?))) ;; mixin to add geometry management to pasteboard with the give type of alignement @@ -22,60 +35,65 @@ (field [needs-realign? false] - [my-edit-sequence? false] [ignore-resizing? false] - [alloted-width 0] - [alloted-height 0] + [alloted-width false] + [alloted-height false] [aligned-min-width 0] [aligned-min-height 0] [aligned-rects empty]) ;; get-aligned-min-width (-> number?) ;; the aligned-min-width of the pasteboard - (define/public (get-aligned-min-width) - aligned-min-width) + (define/public (get-aligned-min-width) aligned-min-width) ;; get-aligned-min-height (-> number?) ;; the aligned-min-height of the pasteboard - (define/public (get-aligned-min-height) - aligned-min-height) + (define/public (get-aligned-min-height) aligned-min-height) - ;; realign (case-> (-> void?) (positive? positive? . -> . void?)) - ;; called by the parent to realign the pasteboard's children - (define/public realign - (case-lambda - [(width height) - (set! alloted-width width) - (set! alloted-height height) - (realign)] - [() - (when (and (positive? alloted-width) - (positive? alloted-height)) - (set! needs-realign? false) - (realign-to-alloted))])) - - ;; realign-to-alloted (-> void?) - ;; realign the snips to fill the alloted width and height - (define/private (realign-to-alloted) - (let ([first-snip (find-first-snip)]) - (set! aligned-rects - (align type alloted-width alloted-height - (map-snip build-rect first-snip))) - (begin-edit-sequence) - (set! my-edit-sequence? true) - (set! ignore-resizing? true) - (for-each-snip move/resize first-snip aligned-rects) - (set! ignore-resizing? false) - (set! my-edit-sequence? false) - (end-edit-sequence))) + (define/public (set-aligned-min-sizes) + (dynamic-let ([ignore-resizing? true]) + (for-each-snip + (lambda (s) + (if (is-a? s aligned-snip<%>) + (send s set-aligned-min-sizes))) + (find-first-snip)) + (set!-values (aligned-min-width aligned-min-height) + (get-aligned-min-sizes type (find-first-snip))))) ;; set-algined-min-sizes (-> void?) ;; set the aligned min width and height of the pasteboard based on it's children snips - (define/public (set-aligned-min-sizes) - (set! ignore-resizing? true) - (set!-values (aligned-min-width aligned-min-height) - (get-aligned-min-sizes type (find-first-snip))) - (set! ignore-resizing? false)) + (define/public (aligned-min-sizes-invalid) + ;; Do I need to dynamic-let ignore-resizing? in here? + (if (refresh-delayed?) + (set! needs-realign? true) + (begin + (set! needs-realign? false) + (set!-values (aligned-min-width aligned-min-height) + (get-aligned-min-sizes type (find-first-snip))) + (let ([parent (pasteboard-parent this)]) + (when parent (send parent aligned-min-sizes-invalid)))))) + + ;; realign (case-> (-> void?) (positive? positive? . -> . void?)) + ;; called by the parent to realign the pasteboard's children + (define/public (realign width height) + (set! alloted-width width) + (set! alloted-height height) + (realign-to-alloted)) + + ;; realign-to-alloted (-> void?) + ;; realign the snips to fill the alloted width and height + (define/public (realign-to-alloted) + (when (and alloted-width alloted-height) + (when (not (and (positive? alloted-width) (positive? alloted-height))) + (error 'here "I am")) + (dynamic-let ([ignore-resizing? true]) + (let* ([first-snip (find-first-snip)] + [aligned-rects + (align type alloted-width alloted-height + (map-snip build-rect first-snip))]) + (begin-edit-sequence) + (for-each-snip move/resize first-snip aligned-rects) + (end-edit-sequence))))) ;;move/resize (snip-pos? rect? . -> . void?) ;;moves and resizes the snips with in pasteboard @@ -85,13 +103,10 @@ ($ dim x width stretchable-width?) ($ dim y height stretchable-height?))) (move-to snip x y) + ;; Maybe I don't need to resize it if it's aligned-pasteboard-parent<%> and only if it's + ;; a stretchable snip. (when (or stretchable-height? stretchable-width? (is-a? snip aligned-pasteboard-parent<%>)) - (resize snip width height)) - ;(resize snip width height) - ;(when (is-a? snip editor-snip%) - ; (send snip set-min-width 'none) - ; (send (send snip get-editor) set-min-width 'none)) - ])) + (resize snip width height))])) ;;;;;;;;;; ;; Events @@ -100,21 +115,21 @@ ;; called after a snip is inserted to the pasteboard (rename [super-after-insert after-insert]) (define/override (after-insert snip before x y) - (calc/realign) + (aligned-min-sizes-invalid) (super-after-insert snip before x y)) ;; after-delete ((is-a?/c snip%) . -> . void?) ;; called after a snip is deleted from the pasteboard% (rename [super-after-delete after-delete]) (define/override (after-delete snip) - (calc/realign) + (aligned-min-sizes-invalid) (super-after-delete snip)) - ;; after-reorder ((is-a?/c snip%) (is-a?/c snip%) boolean? . -> . void?) + ; after-reorder ((is-a?/c snip%) (is-a?/c snip%) boolean? . -> . void?) ;; called after a snip is moved in the front to back snip order (rename [super-after-reorder after-reorder]) (define/override (after-reorder snip to-snip before?) - (realign) + (realign-to-alloted) (super-after-reorder snip to-snip before?)) ;; resized ((is-a?/c snip%) . -> . void?) @@ -123,82 +138,16 @@ (define/override (resized snip redraw-now?) (super-resized snip redraw-now?) (unless ignore-resizing? - (when (or redraw-now? - (and (not (refresh-delayed?)) - (needs-resize? snip))) - (calc/realign)))) + (aligned-min-sizes-invalid))) ;; after-edit-sequence (-> void?) ;; called after an edit-sequence ends (rename [super-after-edit-sequence after-edit-sequence]) (define/override (after-edit-sequence) - (when needs-realign? (calc/realign))) + (super-after-edit-sequence) + (when needs-realign? (aligned-min-sizes-invalid))) - ;; calc/realign (-> void?) - ;; sends a message to the pasteboard to recalculate min sizes and realign - (define/private (calc/realign) - (unless ignore-resizing? - (if (refresh-delayed?) - (unless my-edit-sequence? (set! needs-realign? true)) - (let* ([root (pasteboard-root this)] - [parent (pasteboard-parent root)]) - (when parent - (send parent set-aligned-min-sizes) - (send root realign)))))) - - ;; needs-resize? ((is-a?/c snip%) . -> . boolean?) - ;; determines if the snip's size is smaller than it's min size - (define/private (needs-resize? snip) - (with-handlers ([exn? (lambda a false)]) - (match-let ([($ rect - ($ dim _ alloted-width _) - ($ dim _ alloted-height _)) - (find-rect snip)]) - (if (is-a? snip aligned-snip<%>) - (or (< alloted-width (send snip get-aligned-min-width)) - (< alloted-height (send snip get-aligned-min-height))) - (if (empty? aligned-rects) - false - - (match-let ([($ rect - ($ dim _ actual-width _) - ($ dim _ actual-height _)) - (build-rect snip)]) - (not (and (= alloted-width actual-width) - (= alloted-height actual-height))))))))) - - ;(define/private (needs-resize? snip) - ; (cond - ; [(is-a? snip aligned-snip<%>) - ; (or (< (snip-width snip) - ; (send snip get-aligned-min-width)) - ; (< (snip-height snip) - ; (send snip get-aligned-min-height)) - ; (and (not (send snip stretchable-width)) - ; (> (snip-width snip) - ; (send snip get-aligned-min-width))) - ; (and (not (send snip stretchable-height)) - ; (> (snip-height snip) - ; (send snip get-aligned-min-height))))] - ; [else false])) - - ;; find-rect ((is-a?/c snip%) . -> . rect?) - ;; finds the rect that corresponds to the given snip - (define/private (find-rect target-snip) - (letrec ([find-rect-aux - (lambda (snip rects) - (cond - [(or (equal? snip false) (empty? rects)) - (error 'find-rect "Snip not found")] - [else - (if (equal? snip target-snip) - (car rects) - (find-rect-aux (send snip next) - (rest rects)))]))]) - (find-rect-aux (find-first-snip) aligned-rects))) - - (super-instantiate ()) - )) + (super-new))) ;; build-rect ((is-a?/c snip%) . -> . rect?) ;; makes a new default rect out of a snip @@ -218,12 +167,24 @@ [width 0] [height 0]) (cond - [(boolean? snip) - (values width height)] + [(boolean? snip) (values width height)] [else - (when (is-a? snip aligned-pasteboard-parent<%>) - (send snip set-aligned-min-sizes)) (loop (send snip next) (x-func (snip-min-width snip) width) (y-func (snip-min-height snip) height))])))) - ) \ No newline at end of file + + ;; dynamic-let is just like fluid-let but is less expensive and not safe over continuations + (define-syntax (dynamic-let stx) + (syntax-case stx () + [(_ ((x y) ...) body body2 ...) + (andmap identifier? (syntax-e #'(x ...))) + (with-syntax ([(old-x ...) (generate-temporaries #'(x ...))]) + #'(let ((old-x x) ...) + (begin + (set! x y) ... + (begin0 + (begin + body + body2 ...) + (set! x old-x) ...))))])) + ) diff --git a/collects/mrlib/private/aligned-pasteboard/interface.ss b/collects/mrlib/private/aligned-pasteboard/interface.ss index f94f50d6..a17037e9 100644 --- a/collects/mrlib/private/aligned-pasteboard/interface.ss +++ b/collects/mrlib/private/aligned-pasteboard/interface.ss @@ -11,7 +11,33 @@ ;; the interface that must be implemented for a pasteboard to be contained in an aligned-pasteboard-parent<%> (define aligned-pasteboard<%> - (interface (editor<%>) + (interface (editor<%>) + + ;; (positive? positive? -> void?) + ;; called by the parent to resize and position the pasteboard's children + realign + + ;; (-> void?) + ;; called to realign a pasteboard to the already alloted width and height + realign-to-alloted + + ;; (-> void?) + ;; calculates the minimum width and height of the of the pasteboard + set-aligned-min-sizes + + ;; (-> void?) + ;; Called by a child snip to alert the parent that it's is now invalid due + ;; to a change in its own minimum size. + aligned-min-sizes-invalid + + ;; get-aligned-min-width: (-> number?) + ;; the minimum width of the pasteboard determined by its children + get-aligned-min-width + + ;; get-aligned-min-height: (-> number?) + ;; the minimum width of the pasteboard determined by its children + get-aligned-min-height + ;; get-alignment (-> (values symbol? symbol?)) ;; get the pasteboards current alignment specification ;; status: possible future feature @@ -26,30 +52,19 @@ ;; get or set the spacing in pixels placed between each child snip of the pasteboard ;; status: possible future feature ;spacing - - ;; realign (-> (void)) - ;; called by the parent to resize and position the pasteboard's children - realign - - ;; set-aligned-min-sizes (-> void?) - ;; calculates the minimum width and height of the of the pasteboard - set-aligned-min-sizes - - ;; get-aligned-min-width: (-> number?) - ;; the minimum width of the pasteboard determined by its children - get-aligned-min-width - - ;; get-aligned-min-height: (-> number?) - ;; the minimum width of the pasteboard determined by its children - get-aligned-min-height )) ;; the interface that must be implemented by a class to be the parent of an aligned-pasteboard<%> (define aligned-pasteboard-parent<%> (interface () - ;; set-aligned-min-size: (-> (void)) + ;; (-> void?) ;; sets the aligned min width and height of all aligned children - set-aligned-min-sizes + aligned-min-sizes-invalid + + ;; (-> void?) + ;; sets the aligned min sizes of this snip and its child editor + ;; required only for the aligned-editor-snip% + ;set-aligned-min-sizes )) ;; the interface that must be implemented by a class to be inserted into an aligned-pasteboard<%> and diff --git a/collects/mrlib/private/aligned-pasteboard/snip-lib.ss b/collects/mrlib/private/aligned-pasteboard/snip-lib.ss index 068daa39..8d204a06 100644 --- a/collects/mrlib/private/aligned-pasteboard/snip-lib.ss +++ b/collects/mrlib/private/aligned-pasteboard/snip-lib.ss @@ -6,7 +6,8 @@ (lib "mred.ss" "mred") (lib "list.ss") (lib "contract.ss") - "interface.ss") + "interface.ss" + (lib "debug.ss" "mike-lib")) ;; a snip (define snip? (is-a?/c snip%)) @@ -24,7 +25,7 @@ (snip-height (snip? . -> . number?)) (snip-min-width (snip? . -> . number?)) (snip-min-height (snip? . -> . number?)) - (snip-parent (snip? . -> . editor?)) + (snip-parent (snip? . -> . (union editor? false?))) (fold-snip ((snip? any? . -> . any?) any? linked-snip? . -> . any?)) (for-each-snip any? #;((snip-visitor? linked-snip?) rest-lists? . ->* . (void))) (map-snip any? #;((snip-visitor? linked-snip?) rest-lists? . ->* . ((listof any?)))) @@ -39,7 +40,7 @@ (send pasteboard get-snip-location snip left (box 0) false) (send pasteboard get-snip-location snip right (box 0) true) (- (unbox right) (unbox left)))) - + ;; the height of a snip in the parent pasteboard (define (snip-height snip) (let ([top (box 0)] @@ -65,7 +66,10 @@ ;; the pasteboard that contains the snip (define (snip-parent snip) - (send (send snip get-admin) get-editor)) + (let ([admin (send snip get-admin)]) + (if admin + (send admin get-editor) + false))) ;; the application of f on all snips from snip to the end in a foldl foldr mannor (define (fold-snip f init-acc snip) diff --git a/collects/mrlib/private/aligned-pasteboard/tests/more-tests.ss b/collects/mrlib/private/aligned-pasteboard/tests/more-tests.ss index 770ecdbe..907eabba 100644 --- a/collects/mrlib/private/aligned-pasteboard/tests/more-tests.ss +++ b/collects/mrlib/private/aligned-pasteboard/tests/more-tests.ss @@ -4,248 +4,8 @@ (lib "class.ss") (lib "mred.ss" "mred") (lib "etc.ss") - (lib "list.ss") - (lib "match.ss") "../aligned-editor-container.ss" - "../interface.ss" - "../alignment.ss" - "../snip-lib.ss" - "../pasteboard-lib.ss") - -(define (make-aligned-pasteboard type) - (class* pasteboard% (aligned-pasteboard<%>) - (inherit resize move-to find-first-snip refresh-delayed? - begin-edit-sequence end-edit-sequence) - - (field - [needs-realign? false] - [ignore-resizing? false] - [alloted-width 0] - [alloted-height 0] - [aligned-min-width 0] - [aligned-min-height 0] - [aligned-rects empty] - [in-edit-sequence? false]) - - ;;;;;;;;;; - ;; accessors - - ;; get-aligned-min-width (-> number?) - ;; the aligned-min-width of the pasteboard - (define/public (get-aligned-min-width) aligned-min-width) - - ;; get-aligned-min-height (-> number?) - ;; the aligned-min-height of the pasteboard - (define/public (get-aligned-min-height) aligned-min-height) - - ;;;;;;;;;; - ;; size calculations - - ;; set-algined-min-sizes (-> void?) - ;; set the aligned min width and height of the pasteboard based on it's children snips - (define/public (set-aligned-min-sizes) - (set! ignore-resizing? true) - (set!-values (aligned-min-width aligned-min-height) - (get-aligned-min-sizes type (find-first-snip))) - (set! ignore-resizing? false)) - - ;;;;;;;;;; - ;; realignment - - ;; realign (case-> (-> void?) (positive? positive? . -> . void?)) - ;; called by the parent to realign the pasteboard's children - (define/public realign - (case-lambda - [(width height) - (set! alloted-width width) - (set! alloted-height height) - (realign)] - [() - (when (and (positive? alloted-width) - (positive? alloted-height)) - (set! needs-realign? false) - (realign-to-alloted))])) - - ;; realign-to-alloted (-> void?) - ;; realign the snips to fill the alloted width and height - (define/private (realign-to-alloted) - (let ([first-snip (find-first-snip)]) - (set! aligned-rects - (align type alloted-width alloted-height - (map-snip build-rect first-snip))) - (begin-edit-sequence) - (set! ignore-resizing? true) - (for-each-snip move/resize first-snip aligned-rects) - (set! ignore-resizing? false) - (end-edit-sequence))) - - ;;move/resize (snip-pos? rect? . -> . void?) - ;;moves and resizes the snips with in pasteboard - (define move/resize - (match-lambda* - [(snip ($ rect - ($ dim x width stretchable-width?) - ($ dim y height stretchable-height?))) - (move-to snip x y) - ;; let's try this way to do it. - (when (and (is-a? snip stretchable-snip<%>) - (or stretchable-width? stretchable-height?)) - (send snip stretch-to width height)) - ;; one way to do it? - ;(when (or stretchable-height? stretchable-width? (is-a? snip aligned-pasteboard-parent<%>)) - ; (resize snip width height)) - ;; another way to do it? - ;(resize snip width height) - ;(when (is-a? snip editor-snip%) - ; (send snip set-min-width 'none) - ; (send (send snip get-editor) set-min-width 'none)) - ])) - - ;;;;;;;;;; - ;; event-handling - - ;; after-insert ((is-a?/c snip%) (is-a?/c snip%) number? number? . -> . void?) - ;; called after a snip is inserted to the pasteboard - (rename [super-after-insert after-insert]) - (define/override (after-insert snip before x y) - (calc/realign) - (super-after-insert snip before x y)) - - ;; after-delete ((is-a?/c snip%) . -> . void?) - ;; called after a snip is deleted from the pasteboard% - (rename [super-after-delete after-delete]) - (define/override (after-delete snip) - (calc/realign) - (super-after-delete snip)) - - ;; do I need to override release-snip or does after-delete handle this for me? - ;(rename [super-release-snip release-snip]) - ;(define/override (release-snip snip) - ; (super-release-snip snip)) - - ;; after-reorder ((is-a?/c snip%) (is-a?/c snip%) boolean? . -> . void?) - ;; called after a snip is moved in the front to back snip order - (rename [super-after-reorder after-reorder]) - (define/override (after-reorder snip to-snip before?) - (realign) - (super-after-reorder snip to-snip before?)) - - ;; resized ((is-a?/c snip%) . -> . void?) - ;; called when a snip inside the editor is resized - (rename [super-resized resized]) - (define/override (resized snip redraw-now?) - (super-resized snip redraw-now?) - (unless ignore-resizing? - (when (or redraw-now? - (and (not (refresh-delayed?)) - (needs-resize? snip))) - (calc/realign)))) - - ;; after-edit-sequence (-> void?) - ;; called after an edit-sequence ends - (rename [super-after-edit-sequence after-edit-sequence]) - (define/override (after-edit-sequence) - (set! in-edit-sequence? false) - (when needs-realign? (calc/realign))) - - (rename [super-on-edit-sequence on-edit-sequence]) - (define/override (on-edit-sequence) - (set! in-edit-sequence? true) - (super-on-edit-sequence)) - - ;; calc/realign (-> void?) - ;; sends a message to the pasteboard to recalculate min sizes and realign - (define/private (calc/realign) - (if in-edit-sequence? - (set! needs-realign? true) - (let* ([root (pasteboard-root this)] - [parent (pasteboard-parent root)]) - (when parent - (send parent set-aligned-min-sizes) - (send root realign))))) - - ;; needs-resize? ((is-a?/c snip%) . -> . boolean?) - ;; determines if the snip's size is smaller than it's min size - (define/private (needs-resize? snip) - (with-handlers ([exn? (lambda a false)]) - (match-let ([($ rect - ($ dim _ alloted-width _) - ($ dim _ alloted-height _)) - (find-rect snip)]) - (if (is-a? snip aligned-snip<%>) - (or (< alloted-width (send snip get-aligned-min-width)) - (< alloted-height (send snip get-aligned-min-height))) - (if (empty? aligned-rects) - false - - (match-let ([($ rect - ($ dim _ actual-width _) - ($ dim _ actual-height _)) - (build-rect snip)]) - (not (and (= alloted-width actual-width) - (= alloted-height actual-height))))))))) - - ;(define/private (needs-resize? snip) - ; (cond - ; [(is-a? snip aligned-snip<%>) - ; (or (< (snip-width snip) - ; (send snip get-aligned-min-width)) - ; (< (snip-height snip) - ; (send snip get-aligned-min-height)) - ; (and (not (send snip stretchable-width)) - ; (> (snip-width snip) - ; (send snip get-aligned-min-width))) - ; (and (not (send snip stretchable-height)) - ; (> (snip-height snip) - ; (send snip get-aligned-min-height))))] - ; [else false])) - - ;; find-rect ((is-a?/c snip%) . -> . rect?) - ;; finds the rect that corresponds to the given snip - (define/private (find-rect target-snip) - (letrec ([find-rect-aux - (lambda (snip rects) - (cond - [(or (equal? snip false) (empty? rects)) - (error 'find-rect "Snip not found")] - [else - (if (equal? snip target-snip) - (car rects) - (find-rect-aux (send snip next) - (rest rects)))]))]) - (find-rect-aux (find-first-snip) aligned-rects))) - - (super-new))) - -;; build-rect ((is-a?/c snip%) . -> . rect?) -;; makes a new default rect out of a snip -(define (build-rect snip) - (make-rect - (make-dim 0 (snip-min-width snip) (stretchable-width? snip)) - (make-dim 0 (snip-min-height snip) (stretchable-height? snip)))) - -;; get-aligned-min-sizes (((symbols 'horizontal vertical) (is-a?/c snip%)) . ->* . (number? number?)) -;; calculate the aligned min sizes for the pasteboard containing the given snips -(define (get-aligned-min-sizes type init-snip) - (let-values ([(x-func y-func) - (if (symbol=? type 'horizontal) - (values + max) - (values max +))]) - (let loop ([snip init-snip] - [width 0] - [height 0]) - (cond - [(boolean? snip) - (values width height)] - [else - (when (is-a? snip aligned-pasteboard-parent<%>) - (send snip set-aligned-min-sizes)) - (loop (send snip next) - (x-func (snip-min-width snip) width) - (y-func (snip-min-height snip) height))])))) - -(define vertical-pasteboard% (make-aligned-pasteboard 'vertical)) -(define horizontal-pasteboard% (make-aligned-pasteboard 'horizontal)) + "../aligned-pasteboard.ss") ;; a text-case snip (define test-case-box% @@ -254,22 +14,20 @@ ;; these edit-sequences are looping (define/public (hide-entries) (send* editor - ;(begin-edit-sequence) + (begin-edit-sequence) (release-snip call-line) (release-snip exp-line) (release-snip act-line) - ;(end-edit-sequence) - )) + (end-edit-sequence))) ;; these edit-sequences are looping (define/public (show-entries) (send* editor - ;(begin-edit-sequence) + (begin-edit-sequence) (insert call-line false) (insert exp-line false) (insert act-line false) - ;(end-edit-sequence) - )) + (end-edit-sequence))) (field [editor (new vertical-pasteboard%)] @@ -289,8 +47,8 @@ (super-new (editor editor) - (stretchable-height false) - (stretchable-width false)))) + (stretchable-height #f) + (stretchable-width #f)))) ;; the top line of the test-case (define (make-top-line turn-snip comment result-snip) @@ -316,13 +74,18 @@ (define (text-field text) (new editor-snip% (editor text))) +;; To make case 3 work, I need to send the forward set-aligned-min-sizes +;; from the snip. Currently that call only originates in the on-size of +;; the canvas but in case 3 the canvas does not belong to the aligned-* +;; collection. I think the place to call this forward set-aligned-min-sizes +;; is from within size-cache-invalid of the aligned-editor-snip (define top (case 3 [(1) (cons vertical-pasteboard% aligned-editor-canvas%)] [(2) (cons text% editor-canvas%)] [(3) (cons pasteboard% editor-canvas%)])) -(define f (new frame% (label "test") (width 200) (height 200))) +(define f (new frame% (label "test") (width 200) (height 250))) (define e (new (car top))) (define c (new (cdr top) (editor e) (parent f))) (define t (new test-case-box%)) diff --git a/collects/mrlib/private/aligned-pasteboard/tests/test2.ss b/collects/mrlib/private/aligned-pasteboard/tests/test2.ss index 83a1f0c6..6d81df05 100644 --- a/collects/mrlib/private/aligned-pasteboard/tests/test2.ss +++ b/collects/mrlib/private/aligned-pasteboard/tests/test2.ss @@ -5,7 +5,6 @@ (lib "list.ss") "../aligned-pasteboard.ss" "../aligned-editor-container.ss" - (lib "devel.ss" "mike") "snip-dumper.ss") ;