fixed the major pasteboard bugs
original commit: 0cfc7d5945fd67acb7c2bb79c04cbea188aaf692
This commit is contained in:
Mike MacHenry
parent
916aa86799
commit
a82730944d
|
|
@ -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 ())
|
||||
))
|
||||
)
|
||||
;not-yet-implemented
|
||||
(define aligned-snip-mixin (lambda (x) x))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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))]))))
|
||||
)
|
||||
|
||||
;; 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) ...))))]))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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%))
|
||||
|
|
|
|||
|
|
@ -5,7 +5,6 @@
|
|||
(lib "list.ss")
|
||||
"../aligned-pasteboard.ss"
|
||||
"../aligned-editor-container.ss"
|
||||
(lib "devel.ss" "mike")
|
||||
"snip-dumper.ss")
|
||||
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user