262 lines
8.0 KiB
Racket
262 lines
8.0 KiB
Racket
#| This tests to make sure show works. It's not a correct test because
|
|
it's been abandoned and was reduced to wont-shrink.rkt This is still
|
|
a good file for sandboxing show stuff though.
|
|
|#
|
|
|
|
(require
|
|
mzlib/class
|
|
mred
|
|
mzlib/etc
|
|
mzlib/list
|
|
mzlib/match
|
|
(prefix a: "../alignment.rkt")
|
|
|
|
"../snip-lib.rkt"
|
|
"../interface.rkt"
|
|
"../alignment-helpers.rkt"
|
|
mrlib/click-forwarding-editor
|
|
"../on-show-pasteboard.rkt"
|
|
"../really-resized-pasteboard.rkt"
|
|
"../interface.rkt"
|
|
"../snip-lib.rkt"
|
|
"../locked-pasteboard.rkt"
|
|
"../verthoriz-alignment.rkt"
|
|
"../suppress-modify-editor.rkt")
|
|
|
|
(require mike-lib/print-debug)
|
|
|
|
(define aligned-pasteboard%
|
|
(class (click-forwarding-editor-mixin
|
|
(on-show-pasteboard-mixin
|
|
(suppress-modify-editor-mixin
|
|
(locked-pasteboard-mixin
|
|
(really-resized-pasteboard-mixin pasteboard%)))))
|
|
|
|
(inherit begin-edit-sequence end-edit-sequence
|
|
get-max-view-size refresh-delayed?)
|
|
(init align)
|
|
(field
|
|
[alignment (new (case align
|
|
[(horizontal) horizontal-alignment%]
|
|
[(vertical) vertical-alignment%]))]
|
|
[lock-alignment? false]
|
|
[needs-alignment? false])
|
|
|
|
(define/public (get-alignment) alignment)
|
|
|
|
#|
|
|
snip : snip% object
|
|
before : snip% object or #f
|
|
x : real number
|
|
y : real number
|
|
|#
|
|
(rename [super-after-insert after-insert])
|
|
(define/override (after-insert snip before x y)
|
|
(super-after-insert snip before x y)
|
|
(realign))
|
|
|
|
#|
|
|
snip : snip% object
|
|
|#
|
|
(rename [super-after-delete after-delete])
|
|
(define/override (after-delete snip)
|
|
(super-after-delete snip)
|
|
(realign))
|
|
|
|
#|
|
|
snip : snip% object
|
|
|#
|
|
(rename [super-really-resized really-resized])
|
|
(define/override (really-resized snip)
|
|
(super-really-resized snip)
|
|
(realign))
|
|
|
|
(rename [super-on-show on-show])
|
|
(define/override (on-show)
|
|
(realign)
|
|
(super-on-show))
|
|
|
|
(define/public (lock-alignment lock?)
|
|
(set! lock-alignment? lock?)
|
|
(when (and needs-alignment? (not lock-alignment?))
|
|
(realign))
|
|
(if lock?
|
|
(begin-edit-sequence)
|
|
(end-edit-sequence)))
|
|
|
|
(define/public (realign)
|
|
(if lock-alignment?
|
|
(set! needs-alignment? true)
|
|
(fluid-let ([lock-alignment? true])
|
|
(send alignment set-min-sizes)
|
|
(let ([width (send alignment get-min-width)]
|
|
[height (send alignment get-min-height)])
|
|
(unless (or (zero? width) (zero? height))
|
|
(send alignment align 0 0 width height)
|
|
(set! needs-alignment? false))))))
|
|
|
|
(super-new)
|
|
(send alignment set-pasteboard this)))
|
|
|
|
(define (vert/horiz-alignment type)
|
|
(class* object% (alignment<%>)
|
|
|
|
(init-field
|
|
[parent false]
|
|
[show? true])
|
|
|
|
(field
|
|
[pasteboard false]
|
|
[children empty]
|
|
[min-width 0]
|
|
[min-height 0])
|
|
|
|
;; STATUS: This function (through lock-alignment false) invokes a call
|
|
;; to realign of the pasteboard even when this alignement has show? = false
|
|
;; so the call is not needed.
|
|
(define/public (add child)
|
|
(set! children (append children (list child)))
|
|
(send pasteboard lock-alignment true)
|
|
(cond
|
|
[(is-a? child snip%)
|
|
(when (get-show?)
|
|
(send pasteboard insert child false))]
|
|
[(is-a? child alignment<%>)
|
|
(send child set-pasteboard pasteboard)])
|
|
(send pasteboard lock-alignment false))
|
|
|
|
(define/public (get-min-width)
|
|
(if (get-show?) min-width 0))
|
|
(define/public (get-min-height)
|
|
(if (get-show?) min-height 0))
|
|
(define/public (set-pasteboard pb) (set! pasteboard pb))
|
|
(define/public (stretchable-width?) true)
|
|
(define/public (stretchable-height?) true)
|
|
|
|
#;(boolean? . -> . void?)
|
|
;; Shows or hides the alignment
|
|
(define/public (show bool)
|
|
(set! show? bool)
|
|
(when (parent-show?)
|
|
(send pasteboard lock-alignment true)
|
|
(show/hide-snips show?)
|
|
(send pasteboard lock-alignment false)))
|
|
|
|
#;(boolean? . -> . void?)
|
|
;; Inserts or deletes all the snips in the tree.
|
|
(define/public (show/hide-snips bool)
|
|
(when (boolean=? show? bool)
|
|
(for-each (show/hide-child bool) children)))
|
|
|
|
(define ((show/hide-child show?) child)
|
|
(if (is-a? child alignment<%>)
|
|
(send child show/hide-snips show?)
|
|
(if show?
|
|
(send pasteboard insert child)
|
|
(send pasteboard release-snip child))))
|
|
|
|
(define/public (get-show?)
|
|
(and show? (parent-show?)))
|
|
|
|
(define (parent-show?)
|
|
(if (and parent (is-a? parent alignment<%>))
|
|
(send parent get-show?)
|
|
true))
|
|
|
|
(define/public (align x-offset y-offset width height)
|
|
|
|
(define move/resize
|
|
(match-lambda*
|
|
[(child ($ a:rect
|
|
($ a:dim x w stretchable-width?)
|
|
($ a:dim y h stretchable-height?)))
|
|
(let ([global-x (+ x x-offset)]
|
|
[global-y (+ y y-offset)])
|
|
(cond
|
|
[(is-a? child snip%)
|
|
(send pasteboard move-to child global-x global-y)
|
|
(when (or stretchable-width? stretchable-height?)
|
|
(send child stretch w h))]
|
|
[(is-a? child alignment<%>)
|
|
(send child align global-x global-y w h)]))]))
|
|
|
|
(when (and (get-show?) (not (empty? children)))
|
|
(for-each move/resize
|
|
children
|
|
(a:align type width height
|
|
(map build-rect children)))))
|
|
|
|
(define/public (set-min-sizes)
|
|
(when show?
|
|
(for-each
|
|
(lambda (child)
|
|
(when (is-a? child alignment<%>)
|
|
(send child set-min-sizes)))
|
|
children)
|
|
(let-values ([(x-accum y-accum)
|
|
(if (symbol=? type 'vertical)
|
|
(values vacuous-max +)
|
|
(values + vacuous-max))])
|
|
(set! min-width
|
|
(apply x-accum
|
|
(map child-width
|
|
children)))
|
|
(set! min-height
|
|
(apply y-accum
|
|
(map child-height
|
|
children))))))
|
|
|
|
(super-new)
|
|
;; NOTE: Try to figure out how it's getting a nonalignment<%> parent
|
|
(when (and parent (is-a? parent alignment<%>))
|
|
(send parent add this))))
|
|
|
|
(define vertical-alignment% (vert/horiz-alignment 'vertical))
|
|
(define horizontal-alignment% (vert/horiz-alignment 'horizontal))
|
|
|
|
;; build-rect ((is-a?/c snip%) . -> . rect?)
|
|
;; makes a new default rect out of a snip
|
|
(define (build-rect item)
|
|
(cond
|
|
[(is-a? item snip%)
|
|
(a:make-rect
|
|
(a:make-dim 0 (snip-min-width item) (stretchable-width? item))
|
|
(a:make-dim 0 (snip-min-height item) (stretchable-height? item)))]
|
|
[(is-a? item alignment<%>)
|
|
(a:make-rect
|
|
(a:make-dim 0 (send item get-min-width) (send item stretchable-width?))
|
|
(a:make-dim 0 (send item get-min-height) (send item stretchable-height?)))]))
|
|
|
|
;;;;;;;;;;
|
|
;; main
|
|
|
|
(define f (new frame% (label "f") (width 400) (height 400)))
|
|
(define e (new text%))
|
|
(define c (new editor-canvas% (parent f) (editor e)))
|
|
(define ap (new aligned-pasteboard% (align 'horizontal)))
|
|
(define es (new editor-snip% (editor ap)))
|
|
(define a1 (send ap get-alignment))
|
|
|
|
(define a2 (new vertical-alignment% (parent a1)))
|
|
(define a3 (new vertical-alignment% (parent a1)))
|
|
(define a4 (new vertical-alignment% (parent a3)))
|
|
(define a5 (new vertical-alignment% (parent a3) (show? #f)))
|
|
|
|
(send a2 add (make-object string-snip% "a2"))
|
|
(send a4 add (make-object string-snip% "a4"))
|
|
(send a5 add (make-object string-snip% "a5"))
|
|
|
|
;; this next line blows up but should not
|
|
#;(send a5 show #t)
|
|
|
|
(send f show #t)
|
|
(send e insert es)
|
|
|
|
(let ([a (send a1 get-min-height)])
|
|
(send a5 show #t)
|
|
(let ([b (send a1 get-min-height)])
|
|
(send a5 show #f)
|
|
(let ([c (send a1 get-min-height)])
|
|
(values (equal? a c)
|
|
(equal? a (/ b 2))))))
|