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

first commitment

Browse Source 
original commit: 3744a453fe3804dc31e9494040c4f062e5d46b98
This commit is contained in:
Mike MacHenry 2002-11-09 21:12:18 +00:00
parent 978f2f96d6
commit 04905f8b5f
17 changed files with 1741 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/mrlib/aligned-pasteboard.ss Normal file
View File

@ -0,0 +1,13 @@
(module aligned-pasteboard mzscheme
(require
"private/aligned-pasteboard/aligned-pasteboard.ss"
"private/aligned-pasteboard/aligned-editor-container.ss"
"private/aligned-pasteboard/interface.ss")
(provide
vertical-pasteboard%
horizontal-pasteboard%
aligned-editor-snip%
aligned-editor-canvas%
aligned-pasteboard<%>
aligned-pasteboard-parent<%>
aligned-snip<%>))

53
collects/mrlib/click-forwarding-editor.ss Normal file
View File

@ -0,0 +1,53 @@
(module click-forwarding-editor mzscheme
(require
(lib "class.ss")
(lib "contracts.ss")
(lib "etc.ss")
(lib "mred.ss" "mred"))
(provide/contract
(click-forwarding-editor-mixin mixin-contract))
;; mixin to forward clicks to children snips within the editor
(define (click-forwarding-editor-mixin super%)
(class super%
(inherit get-snip-location global-to-local local-to-global
find-snip get-dc set-caret-owner)
;; on-event ((is-a?/c mouse-event%) . -> . void?)
;; overridden to give focus to child snips when clicked
(rename [super-on-event on-event])
(define/override (on-event event)
(if (memq (send event get-event-type)
'(left-down left-up middle-down middle-up right-down right-up))
(let ([snip (find-snip/global (send event get-x) (send event get-y))])
(if (is-a? snip snip%)
(forward-event snip event)
(super-on-event event)))
(super-on-event event)))
;; forward-event ((is-a?/c snip%) (is-a?/c mouse-event%) . -> . void?)
;; send the event to the snip
(define/private (forward-event snip event)
(let ([editorx (box 0)]
[editory (box 0)])
(get-snip-location snip editorx editory false)
(let ([x (box (unbox editorx))]
[y (box (unbox editory))])
(local-to-global x y)
(send snip on-event (get-dc) (unbox x) (unbox y)
(unbox editorx) (unbox editory) event)
(set-caret-owner snip 'display))))
;; find-snip/global (number? number? . -> . (union (is-a?/c snip%) false?))
;; finds the snip in the pasteboard that is at x y in the global display
(define/private (find-snip/global x y)
(let ([new-x (box x)]
[new-y (box y)])
(global-to-local new-x new-y)
(find-snip (unbox new-x) (unbox new-y))))
(super-instantiate ())
))
)

156
collects/mrlib/private/aligned-pasteboard/aligned-editor-container.ss Normal file
View File

@ -0,0 +1,156 @@
;; 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
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
(lib "list.ss")
"interface.ss"
"constants.ss")
(provide
aligned-editor-canvas%
aligned-editor-snip%)
;; a canvas that can contain an aligned-pasteboard<%>
(define aligned-editor-canvas%
(class* editor-canvas% (aligned-pasteboard-parent<%>)
(inherit get-editor get-size min-width min-height)
(init-field (style empty))
(field
(width-diff 0)
(height-diff 0))
;; set-aligned-min-size (-> (void))
;; sets the aligned min width and height of all aligned children
(define/public (set-aligned-min-sizes)
(let ([editor (get-editor)])
(send editor set-aligned-min-sizes)
(when (memq 'no-hscroll style)
(min-width
(+ (inexact->exact
(send editor get-aligned-min-width))
machenrys-constant width-diff)))
(when (memq 'no-vscroll style)
(min-height
(+ (inexact->exact
(send editor get-aligned-min-height))
machenrys-constant height-diff)))))
;; 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)))
;; calc-view-client-diff (-> (void))
;; calculates and sets the difference between client-size and view-size of the editor
(define/private (calc-view-client-diff)
(let-values ([(width height) (get-size)])
(let ([view-width (box 0)]
[view-height (box 0)])
(send (get-editor) get-view-size
view-width view-height)
(set! width-diff
(- width
(inexact->exact
(unbox view-width))))
(set! height-diff
(- height
(inexact->exact
(unbox view-height)))))))
(super-instantiate ()
(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%
(class* editor-snip% (aligned-pasteboard-parent<%> 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]))
;; resize (number? number? . -> . boolean?)
;; called to resize the snip
(rename [super-resize resize])
(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)))))
;; 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)
(unbox right)
(send (get-editor) get-aligned-min-width)
machenrys-constant)))
;; 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)])
(get-margin left top right bottom)
(+ (unbox top)
(unbox bottom)
(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
(define/public (set-aligned-min-sizes)
(send (get-editor) set-aligned-min-sizes))
(super-instantiate ())
))
)

27
collects/mrlib/private/aligned-pasteboard/aligned-pasteboard.ss Normal file
View File

@ -0,0 +1,27 @@
(module aligned-pasteboard mzscheme
(require
(lib "mred.ss" "mred")
(lib "click-forwarding-editor.ss" "mrlib")
"geometry-managed-pasteboard.ss"
"event-handling-pasteboard.ss"
"locked-pasteboard.ss")
(provide
vertical-pasteboard%
horizontal-pasteboard%)
;; contruct the basic mixin that both pasteboards will be created from
(define (make-aligned-pasteboard type)
(click-forwarding-editor-mixin
(locked-pasteboard-mixin
(event-handling-pasteboard-mixin
(geometry-managed-pasteboard-mixin
pasteboard% type)))))
(define vertical-pasteboard%
(make-aligned-pasteboard 'vertical))
(define horizontal-pasteboard%
(make-aligned-pasteboard 'horizontal))
)

7
collects/mrlib/private/aligned-pasteboard/constants.ss Normal file
View File

@ -0,0 +1,7 @@
(module constants mzscheme
(provide machenrys-constant)
;; machenrys-constant nonnegative?
;; the differents between the size a pasteboard is alloted by
;; get-view-size and the size it needs to avoid scollbars
(define machenrys-constant 2))

109
collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss Normal file
View File

@ -0,0 +1,109 @@
(module geometry-managed-pasteboard mzscheme
(require
(lib "class.ss")
(lib "contracts.ss")
(lib "list.ss")
(lib "etc.ss")
(lib "match.ss")
"interface.ss"
"alignment.ss"
"snip-lib.ss")
(provide/contract
(geometry-managed-pasteboard-mixin (class? (symbols 'vertical 'horizontal) . -> . class?)))
;; mixin to add geometry management to pasteboard with the give type of alignement
(define (geometry-managed-pasteboard-mixin super% type)
(class* super% (aligned-pasteboard<%>)
(inherit resize move-to find-first-snip
begin-edit-sequence end-edit-sequence)
(field
(alloted-width 0)
(alloted-height 0)
(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)
;; get-aligned-min-height (-> number?)
;; the aligned-min-height of the pasteboard
(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))
(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)
(for-each-snip move/resize first-snip aligned-rects)
(end-edit-sequence)))
;; 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!-values (aligned-min-width aligned-min-height)
(get-aligned-min-sizes type (find-first-snip))))
;;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)
(when (or stretchable-height? stretchable-width?)
(resize snip width height))]))
(super-instantiate ())
))
;; 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))]))))
)

76
collects/mrlib/private/aligned-pasteboard/interface.ss Normal file
View File

@ -0,0 +1,76 @@
(module interface mzscheme
(require
(lib "class.ss")
(lib "mred.ss" "mred"))
(provide
aligned-pasteboard<%>
aligned-pasteboard-parent<%>
aligned-snip<%>)
;; the interface that must be implemented for a pasteboard to be contained in an aligned-pasteboard-parent<%>
(define aligned-pasteboard<%>
(interface (editor<%>)
;; get-alignment (-> (values symbol? symbol?))
;; get the pasteboards current alignment specification
;; status: possible future feature
;get-alignment
;; set-alignment (symbol? symbol? . -> . (void))
;; sets the alignement which determines how children are placed in the pasteboard
;; status: possible future feature
;set-alignment
;; spacing (case-> (number? . -> .(void)) (-> number?))
;; 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))
;; sets the aligned min width and height of all aligned children
set-aligned-min-sizes
))
;; the interface that must be implemented by a class to be inserted into an aligned-pasteboard<%> and
;; be stretched and shrunk according to the geometry managment. note: any snip may be insert... those
;; that do not implement aligned-snip<%> will simply not be stretched.
(define aligned-snip<%>
(interface ()
;; get-aligned-min-width (-> positive?)
;; get the minimum width of the snip
get-aligned-min-width
;; get-aligned-min-height (-> positive?)
;; get the minmum height of the snip
get-aligned-min-height
;; stretchable-width (case-> (boolean . -> . void?) (-> boolean?))
;; get or set the stretchablity of the pasteboards width
stretchable-width
;; stretchable-height (case-> (boolean . -> . void?) (-> boolean?))
;; get or set the stretchablity of the pasteboards height
stretchable-height
))
)

25
collects/mrlib/private/aligned-pasteboard/locked-pasteboard.ss Normal file
View File

@ -0,0 +1,25 @@
(module locked-pasteboard mzscheme
(require
(lib "class.ss")
(lib "etc.ss")
(lib "contracts.ss"))
(provide/contract
(locked-pasteboard-mixin mixin-contract))
;; mixin to remove interactive movement of snips from pasteboards
(define (locked-pasteboard-mixin super%)
(class super%
;; can-interactive-move? (event? . -> . void?)
;; whether the pasteboard allows interactive moving
(define/override (can-interactive-move? event)
false)
;; can-interactive-resize? ((is-a?/c snip%) . -> . void?)
;; whether the pasteboard allows interactive resizing
(define/override (can-interactive-resize? snip)
false)
(super-instantiate ())
))
)

39
collects/mrlib/private/aligned-pasteboard/pasteboard-lib.ss Normal file
View File

@ -0,0 +1,39 @@
(module pasteboard-lib mzscheme
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "contracts.ss")
(lib "etc.ss")
"interface.ss"
"snip-lib.ss")
(provide/contract
(pasteboard-root ((is-a?/c aligned-pasteboard<%>) . -> . (is-a?/c aligned-pasteboard<%>)))
(pasteboard-parent
((is-a?/c pasteboard%) . -> . (union (is-a?/c editor-canvas%) (is-a?/c editor-snip%) false?))))
;; gets the top most aligned pasteboard in the tree of pasteboards and containers
(define (pasteboard-root pasteboard)
(let ([parent (pasteboard-parent pasteboard)])
(cond
[(is-a? parent canvas%)
pasteboard]
[(is-a? parent snip%)
(let ([grand-parent (snip-parent parent)])
(if (is-a? grand-parent aligned-pasteboard<%>)
(pasteboard-root grand-parent)
pasteboard))]
[else pasteboard])))
;; gets the canvas or snip that the pasteboard is displayed in
;; status: what if there is more than one canvas? should this be allowed? probablly not.
(define (pasteboard-parent pasteboard)
(let ([admin (send pasteboard get-admin)])
(cond
[(is-a? admin editor-snip-editor-admin<%>)
(send admin get-snip)]
[(is-a? admin editor-admin%)
(send pasteboard get-canvas)]
[else false])))
)

114
collects/mrlib/private/aligned-pasteboard/snip-lib.ss Normal file
View File

@ -0,0 +1,114 @@
(module snip-lib mzscheme
(require
(lib "class.ss")
(lib "etc.ss")
(lib "mred.ss" "mred")
(lib "list.ss")
(lib "contracts.ss")
"interface.ss")
;; a snip
(define snip? (is-a?/c snip%))
;; a snip to act as the varying argument to a recursive functions
(define linked-snip? (union snip? false?))
;; a function to act on snips being mapped
(define snip-visitor? ((snip?) (listof any?) . ->* . (void)))
;; the rest of the lists passed to a snip mapping function
(define rest-lists? (listof (listof any?)))
;; a class that contains a snip
(define editor? (is-a?/c editor<%>))
(provide/contract
(snip-min-width (snip? . -> . number?))
(snip-min-height (snip? . -> . number?))
(snip-parent (snip? . -> . editor?))
(fold-snip ((snip? any? . -> . any?) any? linked-snip? . -> . any?))
(for-each-snip ((snip-visitor? linked-snip?) rest-lists? . ->* . (void)))
(map-snip ((snip-visitor? linked-snip?) rest-lists? . ->* . ((listof any?))))
(stretchable-width? (snip? . -> . boolean?))
(stretchable-height? (snip? . -> . boolean?)))
;; the width of a snip in the parent pasteboard
;; snip-width (snip? . -> . number?)
(define (snip-width snip)
(let ([left (box 0)]
[right (box 0)]
[pasteboard (snip-parent snip)])
(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
;; snip-height (snip? . -> . number?)
(define (snip-height snip)
(let ([top (box 0)]
[bottom (box 0)]
[pasteboard (snip-parent snip)])
(send pasteboard get-snip-location snip (box 0) top false)
(send pasteboard get-snip-location snip (box 0) bottom true)
(- (unbox bottom) (unbox top))))
;; the minimum width of the snip
(define (snip-min-width snip)
(cond
[(is-a? snip aligned-snip<%>)
(send snip get-aligned-min-width)]
[else (snip-width snip)]))
;; the minimum height of the snip
(define (snip-min-height snip)
(cond
[(is-a? snip aligned-snip<%>)
(send snip get-aligned-min-height)]
[else (snip-height snip)]))
;; the pasteboard that contains the snip
(define (snip-parent snip)
(send (send snip get-admin) get-editor))
;; the application of f on all snips from snip to the end in a foldl foldr mannor
(define (fold-snip f init-acc snip)
(let loop ([snip snip]
[acc init-acc])
(cond
[(is-a? snip snip%)
(loop (send snip next) (f snip acc))]
[else acc])))
;; applies the function to all the snips
(define (for-each-snip f first-snip . init-lists)
(let loop ([snip first-snip]
[lists init-lists])
(cond
[(is-a? snip snip%)
(apply f (cons snip (map first lists)))
(loop (send snip next)
(map rest lists))]
[else (void)])))
;; a list of f applied to each snip
(define (map-snip f first-snip . init-lists)
(let loop ([snip first-snip]
[lists init-lists])
(cond
[(is-a? snip snip%)
(cons (apply f (cons snip (map first lists)))
(loop (send snip next)
(map rest lists)))]
[else empty])))
;; true if the snip can be resized in the x dimention
(define (stretchable-width? snip)
(cond
[(is-a? snip aligned-snip<%>)
(send snip stretchable-width)]
[else false]))
;; true if the snip can be resized in the y dimention
(define (stretchable-height? snip)
(cond
[(is-a? snip aligned-snip<%>)
(send snip stretchable-height)]
[else false]))
)

80
collects/tests/aligned-pasteboard/debug.ss Normal file
View File

@ -0,0 +1,80 @@
(module debug mzscheme
(require
(lib "class.ss"))
(provide
debug-snip
debug-pasteboard
debug-canvas)
;;debug-snip: -> (void)
;;get the relevant info about the snip that contains the two others pasteboards
(define debug-snip
(lambda (snip)
(printf "--- aligned-editor-snip% --\n")
(let ((l (box 0))
(t (box 0))
(r (box 0))
(b (box 0)))
(send snip get-inset l t r b)
(printf "get-inset: ~sX~s ~sX~s\n" (unbox l) (unbox r) (unbox t) (unbox b)))
(let ((l (box 0))
(t (box 0))
(r (box 0))
(b (box 0)))
(send snip get-margin l t r b)
(printf "get-margin: ~sX~s ~sX~s\n" (unbox l) (unbox r) (unbox t) (unbox b)))
(printf "get-max-height: ~s~n" (send snip get-max-height))
(printf "get-max-width: ~s~n" (send snip get-max-width))
(printf "get-min-height: ~s~n" (send snip get-min-height))
(printf "get-min-width: ~s~n" (send snip get-min-width))
;(printf "snip-width: ~s~n" (send pasteboard snip-width snip))
;(printf "snip-height: ~s~n" (send pasteboard snip-height snip))
))
;;debug-pasteboard: -> (void)
;;displays to the repl the sizes i'm interested in
(define debug-pasteboard
(lambda (pasteboard)
(printf "--- aligned-pasteboard% ---\n")
(let ((tmp1 (box 0))
(tmp2 (box 0)))
(send pasteboard get-extent tmp1 tmp2)
(printf "get-extent: ~sX~s\n" (unbox tmp1) (unbox tmp2)))
(printf "get-max-height: ~s\n" (send pasteboard get-max-height))
(let ((tmp (call-with-values (lambda () (send pasteboard get-max-view-size)) cons)))
(printf "get-max-view-size: ~sX~s\n" (car tmp) (cdr tmp)))
(printf "get-max-width: ~s\n" (send pasteboard get-max-width))
(printf "get-min-height: ~s\n" (send pasteboard get-min-height))
(printf "get-min-width: ~s\n" (send pasteboard get-min-width))
(let ((tmp1 (box 0))
(tmp2 (box 0)))
(send pasteboard get-view-size tmp1 tmp2)
(printf "get-view-size: ~sX~s\n" (unbox tmp1) (unbox tmp2)))
))
;;debug-canvas: -> (void)
;;just some help counting pixels
(define debug-canvas
(lambda (canvas)
(printf "--- aligned-editor-canvas% ---\n")
;;values
(let ((tmp (call-with-values (lambda () (send canvas get-client-size)) cons)))
(printf "~a: ~sX~s\n" (symbol->string (quote get-client-size)) (car tmp) (cdr tmp)))
(let ((tmp (call-with-values (lambda () (send canvas get-graphical-min-size)) cons)))
(printf "~a: ~sX~s\n" (symbol->string (quote get-graphical-min-size)) (car tmp) (cdr tmp)))
(let ((tmp (call-with-values (lambda () (send canvas get-size)) cons)))
(printf "~a: ~sX~s\n" (symbol->string (quote get-size)) (car tmp) (cdr tmp)))
;;1 value
(printf "~a: ~s\n" (symbol->string (quote get-height)) (send canvas get-height))
(printf "~a: ~s\n" (symbol->string (quote get-width)) (send canvas get-width))
(printf "~a: ~s\n" (symbol->string (quote horiz-margin)) (send canvas horiz-margin))
(printf "~a: ~s\n" (symbol->string (quote min-client-height)) (send canvas min-client-height))
(printf "~a: ~s\n" (symbol->string (quote min-client-width)) (send canvas min-client-width))
(printf "~a: ~s\n" (symbol->string (quote min-height)) (send canvas min-height))
(printf "~a: ~s\n" (symbol->string (quote min-width)) (send canvas min-width))
(printf "~a: ~s\n" (symbol->string (quote vert-margin)) (send canvas vert-margin))
))
)

87
collects/tests/aligned-pasteboard/example.ss Normal file
View File

@ -0,0 +1,87 @@
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
"../aligned-pasteboard.ss"
"../aligned-editor-container.ss")
;
;
; ;;
; ;
; ;
; ;;;;; ;; ;; ;;;;;;;;;;;;;; ;;; ; ;;;;; ;;;;
; ; ; ;;;; ; ; ; ; ;; ;; ; ; ; ; ;
; ;;;;;; ;; ;;;; ; ; ; ; ; ; ;;;;;; ;;;;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;
; ;;;; ;; ;; ;;;;;;; ;; ;;; ;;; ;;;;; ;;;; ;;;;
; ;
; ;;;
;
(define frame
(instantiate frame% ()
(label "Frame")
(width 400)
(height 400)))
(define pasteboard
(instantiate horizontal-pasteboard% ()))
(define canvas
(instantiate aligned-editor-canvas% ()
(parent frame)
(editor pasteboard)))
(define vp1
(instantiate vertical-pasteboard% ()))
(define ae-snip1
(instantiate aligned-editor-snip% ()
(editor vp1)))
(define vp2
(instantiate vertical-pasteboard% ()))
(define ae-snip2
(instantiate aligned-editor-snip% ()
(editor vp2)))
(define vp3
(instantiate vertical-pasteboard% ()))
(define ae-snip3
(instantiate aligned-editor-snip% ()
(editor vp3)))
(define vp4
(instantiate vertical-pasteboard% ()))
(define ae-snip4
(instantiate aligned-editor-snip% ()
(editor vp4)))
(define vp5
(instantiate vertical-pasteboard% ()))
(define ae-snip5
(instantiate aligned-editor-snip% ()
(editor vp5)))
(define t-snip1
(instantiate editor-snip% ()
(editor (instantiate text% ()))))
(define t-snip2
(instantiate editor-snip% ()
(editor (instantiate text% ()))))
(send pasteboard insert ae-snip1 false)
(send pasteboard insert ae-snip2 false)
(send pasteboard insert ae-snip5 false)
(send vp2 insert ae-snip3 false)
(send vp2 insert ae-snip4 false)
(send vp1 insert t-snip1 false)
(send vp5 insert t-snip2 false)
(send frame show true)

70
collects/tests/aligned-pasteboard/snip-dumper.ss Normal file
View File

@ -0,0 +1,70 @@
(module snip-dumper mzscheme
(require
(lib "class.ss")
(lib "mred.ss" "mred"))
(provide
dump-children
(struct snip-dump (left top right bottom children))
dump=?)
;;dump=?: ((union snip-dump? (listof snip-dump?)) . -> . boolean?)
(define (dump=? dump1 dump2)
(cond
[(and (list? dump1) (list? dump2)
(eq? (length dump1) (length dump2)))
(andmap dump=? dump1 dump2)]
[(and (snip-dump? dump1) (snip-dump? dump2))
(and
(dump=? (snip-dump-left dump1)
(snip-dump-left dump2))
(dump=? (snip-dump-top dump1)
(snip-dump-top dump2))
(dump=? (snip-dump-right dump1)
(snip-dump-right dump2))
(dump=? (snip-dump-bottom dump1)
(snip-dump-bottom dump2))
(dump=? (snip-dump-children dump1)
(snip-dump-children dump2)))]
[else (equal? dump1 dump2)]))
;; type snip-dump =
;; (make-single number number number number (union #f (listof snip-dump)))
;; if children is #f, this indicates that the snip was not an
;; editor-snip. In contrast, if it is null, this indicates that
;; the snip is an editor-snip, but has no children.
(define-struct snip-dump (left top right bottom children))
;; dump-pb : snip -> snip-dump
(define (dump-snip snip)
(let ([outer-pb (send (send snip get-admin) get-editor)]
[bl (box 0)]
[bt (box 0)]
[br (box 0)]
[bb (box 0)])
(send outer-pb get-snip-location snip bl bt #t)
(send outer-pb get-snip-location snip br bb #f)
(make-snip-dump
(unbox bl)
(unbox bt)
(unbox br)
(unbox bb)
(dump-snips snip))))
;; dump-snips : snip -> (union #f (listof snip-dump))
(define (dump-snips snip)
(cond
[(is-a? snip editor-snip%)
(dump-children (send snip get-editor))]
[else #f]))
;; dump-children : editor<%> -> (listof snip-dump)
(define (dump-children editor)
(let loop ([snip (send editor find-first-snip)])
(cond
[snip
(cons (dump-snip snip)
(loop (send snip next)))]
[else null])))
)

250
collects/tests/aligned-pasteboard/test-alignment.ss Normal file
View File

@ -0,0 +1,250 @@
(require
(lib "etc.ss")
(lib "list.ss")
(lib "match.ss")
(lib "devel.ss" "mike")
(lib "private/aligned-pasteboard/alignment.ss" "mrlib"))
;; los-equal? ((listof rect?) (listof rect?) . -> . boolean?)
;; tests the equality of the list of structures
(define (los-equal? a b)
(equal?
(map rect->list a)
(map rect->list b)))
;; rect->list (rect? . -> . vector?)
;; a vector of the fields in the rect
(define rect->list
(match-lambda
[($ rect ($ dim x width stretchable-width?) ($ dim y height stretchable-height?))
(list x width stretchable-width? y height stretchable-height?)]))
;; empty pasteboard
(test
los-equal?
(align 'vertical 100 100 empty)
empty)
;; empty pasteboard
(test
los-equal?
(align 'horizontal 100 100 empty)
empty)
;; one unstretchable snip
(test
los-equal?
(align 'vertical
100 100
(list (make-rect (make-dim 0 10 false)
(make-dim 0 10 false))))
(list (make-rect (make-dim 0 10 false)
(make-dim 0 10 false))))
(test
los-equal?
(align 'horizontal
100 100
(list (make-rect (make-dim 0 10 false)
(make-dim 0 10 false))))
(list (make-rect (make-dim 0 10 false)
(make-dim 0 10 false))))
;; one stretchable snip
(test
los-equal?
(align 'vertical
100 100
(list (make-rect (make-dim 0 10 true)
(make-dim 0 10 true))))
(list (make-rect (make-dim 0 100 true)
(make-dim 0 100 true))))
;; two stretchable snips
(test
los-equal?
(align 'vertical
10
10
(list
(make-rect (make-dim 0 0 true)
(make-dim 0 0 true))
(make-rect (make-dim 0 0 true)
(make-dim 0 0 true))))
(list
(make-rect (make-dim 0 10 true)
(make-dim 0 5 true))
(make-rect (make-dim 0 10 true)
(make-dim 5 5 true))))
;; three stretchable, one too big
(test
los-equal?
(align 'vertical
50 100
(list (make-rect (make-dim 0 0 true)
(make-dim 0 50 true))
(make-rect (make-dim 0 0 true)
(make-dim 0 0 true))
(make-rect (make-dim 0 0 true)
(make-dim 0 0 true))))
(list (make-rect (make-dim 0 50 true)
(make-dim 0 50 true))
(make-rect (make-dim 0 50 true)
(make-dim 50 25 true))
(make-rect (make-dim 0 50 true)
(make-dim 75 25 true))))
;; three stetchable, one too big, and an unstetchable
(test
los-equal?
(align 'vertical
50 100
(list (make-rect (make-dim 0 0 true)
(make-dim 0 50 true))
(make-rect (make-dim 0 0 true)
(make-dim 0 0 true))
(make-rect (make-dim 0 0 true)
(make-dim 0 0 true))
(make-rect (make-dim 0 50 false)
(make-dim 0 10 false))))
(list (make-rect (make-dim 0 50 true)
(make-dim 0 50 true))
(make-rect (make-dim 0 50 true)
(make-dim 50 20 true))
(make-rect (make-dim 0 50 true)
(make-dim 70 20 true))
(make-rect (make-dim 0 50 false)
(make-dim 90 10 false))))
;; failure from test-suite frame
;; wrong answer given was (list (make-rect 0 0 335.0 10 #t))
(test
los-equal?
(align 'vertical
335.0
563.0
(list
(make-rect (make-dim 0 10.0 #t)
(make-dim 0 10.0 #t))))
(list (make-rect (make-dim 0 335.0 true)
(make-dim 0 563.0 true))))
;; sort of like the previous failed test but with a nonsizable snip
(test
los-equal?
(align 'vertical
563.0
335.0
(list
(make-rect (make-dim 0 10.0 #t)
(make-dim 0 10.0 #t))
(make-rect (make-dim 0 10.0 false)
(make-dim 0 10.0 false))))
(list (make-rect (make-dim 0 563.0 true)
(make-dim 0 325.0 true))
(make-rect (make-dim 0 10.0 false)
(make-dim 325.0 10.0 false))))
;; something that requires a little modulo in division
(test
los-equal?
(align 'vertical
10
10
(list
(make-rect (make-dim 0 0 true)
(make-dim 0 0 true))
(make-rect (make-dim 0 0 true)
(make-dim 0 0 true))
(make-rect (make-dim 0 0 true)
(make-dim 0 0 true))))
(list (make-rect (make-dim 0 10 true)
(make-dim 0 4 true))
(make-rect (make-dim 0 10 true)
(make-dim 4 3 true))
(make-rect (make-dim 0 10 true)
(make-dim 7 3 true))))
;; 1 snip only stretches in off dimention
(test
los-equal?
(align 'vertical
100
400
(list
(make-rect (make-dim 0 10 true)
(make-dim 0 30 false))))
(list (make-rect (make-dim 0 100 true)
(make-dim 0 30 false))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The following examples of usage were taken from the test-suite tool and turned into test cases ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(test
los-equal?
(align 'vertical 563.0 335.0 (list))
empty)
(test
los-equal?
(align 'vertical 563.0 335.0
(list (make-rect (make-dim 0 241 #t) (make-dim 0 114 #f))))
(list (make-rect (make-dim 0 563.0 #t) (make-dim 0 114 #f))))
(test
los-equal?
(align 'vertical 551.0 102.0
(list (make-rect (make-dim 0 34 #t) (make-dim 0 47 #t))
(make-rect (make-dim 0 231 #t) (make-dim 0 57 #t))))
(list (make-rect (make-dim 0 551.0 #t) (make-dim 0 47 #t))
(make-rect (make-dim 0 551.0 #t) (make-dim 47 57 #t))))
(test
los-equal?
(align 'vertical 539.0 35.0
(list (make-rect (make-dim 0 24 #f) (make-dim 0 13 #f))
(make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
(list (make-rect (make-dim 0 24 #f) (make-dim 0 13 #f))
(make-rect (make-dim 0 11 #f) (make-dim 13 24 #f))))
(test
los-equal?
(align 'horizontal 539.0 45.0
(list (make-rect (make-dim 0 65 #t) (make-dim 0 47 #t))
(make-rect (make-dim 0 48 #t) (make-dim 0 47 #t))
(make-rect (make-dim 0 63 #t) (make-dim 0 47 #t))
(make-rect (make-dim 0 45 #f) (make-dim 0 44 #f))))
(list
(make-rect (make-dim 0 165.0 true) (make-dim 0 45.0 true))
(make-rect (make-dim 165.0 165.0 true) (make-dim 0 45.0 true))
(make-rect (make-dim 330.0 164.0 true) (make-dim 0 45.0 true))
(make-rect (make-dim 494.0 45 false) (make-dim 0 44 false))))
(test
los-equal?
(align 'vertical 153.0 33.0
(list (make-rect (make-dim 0 55 #f) (make-dim 0 13 #f))
(make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
(list
(make-rect (make-dim 0 55 false) (make-dim 0 13 false))
(make-rect (make-dim 0 11 false) (make-dim 13 24 false))))
(test
los-equal?
(align 'vertical 153.0 33.0
(list (make-rect (make-dim 0 38 #f) (make-dim 0 13 #f))
(make-rect (make-dim 0 11 #f) (make-dim 0 24 #f))))
(list
(make-rect (make-dim 0 38 false) (make-dim 0 13 false))
(make-rect (make-dim 0 11 false) (make-dim 13 24 false))))
(test
los-equal?
(align 'vertical 152.0 33.0
(list (make-rect (make-dim 0 26 #f) (make-dim 0 13 #f))
(make-rect (make-dim 0 53 #f) (make-dim 0 24 #f))))
(list
(make-rect (make-dim 0 26 false) (make-dim 0 13 false))
(make-rect (make-dim 0 53 false) (make-dim 13 24 false))))

213
collects/tests/aligned-pasteboard/test-snip-lib.ss Normal file
View File

@ -0,0 +1,213 @@
(require
(lib "etc.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "private/aligned-pasteboard/snip-lib.ss" "mrlib")
(lib "private/aligned-pasteboard/aligned-pasteboard.ss" "mrlib")
(lib "private/aligned-pasteboard/aligned-editor-container.ss" "mrlib"))
(printf "running tests for snip-lib.ss~n")
;; test: (lambda (a?) ((a? a? . -> . boolean?) a? a? . -> . (void))
;; tests to see if the expression is true and prints and error if it's not
(define-syntax test
(syntax-rules (identity)
((_ test actual expected)
(let ([result
(with-handlers
([exn? identity])
actual)])
(print
(and (not (exn? result))
(test result expected)))))))
;;snip-min-width: ((is-a?/c snip%) . -> . number?)
;;the width of a snip in the given pasteboard
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[es1 (instantiate editor-snip% () (editor pb1))]
[pb2 (instantiate vertical-pasteboard% ())]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb2))])
(send frame show true)
(send pb2 insert es1)
(send es1 resize 20 20)
(sleep/yield 1)
(test
equal?
(snip-min-width es1)
20)
(send es1 resize 200 90)
(sleep/yield 1)
(test
equal?
(snip-min-width es1)
200)
(send frame show false)
)
;;snip-min-height: ((is-a?/c snip%) . -> . number?)
;;the height of a snip in the given pasteboard
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[es1 (instantiate editor-snip% () (editor pb1))]
[pb2 (instantiate vertical-pasteboard% ())]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb2))])
(send frame show true)
(send pb2 insert es1)
(send es1 resize 20 20)
(sleep/yield 1)
(test
equal?
(snip-min-height es1)
20)
(send es1 resize 200 90)
(sleep/yield 1)
(test
equal?
(snip-min-height es1)
90)
(send frame show false)
)
;;snip-parent: ((is-a?/c snip%) . -> . (is-a?/c editor<%>))
;;the pasteboard that contains the snip
(let*
([pb1 (instantiate pasteboard% ())]
[es1 (instantiate editor-snip% () (editor pb1))]
[pb2 (instantiate pasteboard% ())]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate editor-canvas% () (parent frame) (editor pb2))])
(send frame show true)
(send pb2 insert es1)
(test
equal?
(snip-parent es1)
pb2)
(send frame show false)
)
(let*
([pb1 (instantiate horizontal-pasteboard% ())]
[pb2 (instantiate horizontal-pasteboard% ())]
[pb3 (instantiate horizontal-pasteboard% ())]
[pb4 (instantiate horizontal-pasteboard% ())]
[pb5 (instantiate horizontal-pasteboard% ())]
[es2 (instantiate aligned-editor-snip% () (editor pb2))]
[es3 (instantiate aligned-editor-snip% () (editor pb3))]
[es4 (instantiate aligned-editor-snip% () (editor pb4))]
[es5 (instantiate aligned-editor-snip% () (editor pb5))]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
(send frame show true)
(send pb1 insert es2)
(send pb2 insert es3)
(send pb3 insert es4)
(send pb4 insert es5)
(test
equal?
(snip-parent es2)
pb1)
(test
equal?
(snip-parent es3)
pb2)
(test
equal?
(snip-parent es4)
pb3)
(test
equal?
(snip-parent es5)
pb4)
(send frame show false)
)
;;fold-snip: (lambda (b?) ((any? b? . -> . b?) b? (is-a?/c snip%) . -> . b?))
;;the application of f on all snips from snip to the end in a foldl foldr mannor
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[es1 (instantiate editor-snip% () (editor (instantiate text% ())))]
[es2 (instantiate editor-snip% () (editor (instantiate text% ())))]
[es3 (instantiate editor-snip% () (editor (instantiate text% ())))]
[es4 (instantiate editor-snip% () (editor (instantiate text% ())))]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
(send frame show true)
(send pb1 insert es1)
(send pb1 insert es2)
(send pb1 insert es3)
(send pb1 insert es4)
(send es1 resize 100 100)
(send es2 resize 100 100)
(send es3 resize 100 100)
(send es4 resize 100 100)
(test
=
(fold-snip
(lambda (snip total-height)
(+ (snip-min-height snip)
total-height))
0
es4)
400)
(send frame show false)
)
;;for-each-snip: (((is-a?/c snip%) . -> . (void)) (is-a/c? snip%) . -> . (void))
;;applies the function to all the snips
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[es1 (instantiate editor-snip% () (editor (instantiate text% ())))]
[es2 (instantiate editor-snip% () (editor (instantiate text% ())))]
[es3 (instantiate editor-snip% () (editor (instantiate text% ())))]
[es4 (instantiate editor-snip% () (editor (instantiate text% ())))]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))]
[count 0])
(send frame show true)
(send pb1 insert es1)
(send pb1 insert es2)
(send pb1 insert es3)
(send pb1 insert es4)
(for-each-snip
(lambda (snip)
(set! count (add1 count)))
es4)
(test
=
count
4)
(send frame show false)
)
(printf "tests done~n")

232
collects/tests/aligned-pasteboard/test.ss Normal file
View File

@ -0,0 +1,232 @@
;;note: turns out these tests are window manager specific
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
(lib "list.ss")
(lib "aligned-pasteboard.ss" "mrlib")
"snip-dumper.ss")
; ;;
; ;
; ;
; ;;;;; ;; ;; ;;;;;;;;;;;;;; ;;; ; ;;;;; ;;;;
; ; ; ;;;; ; ; ; ; ;; ;; ; ; ; ; ;
; ;;;;;; ;; ;;;; ; ; ; ; ; ; ;;;;;; ;;;;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;
; ;;;; ;; ;; ;;;;;;; ;; ;;; ;;; ;;;;; ;;;; ;;;;
; ;
; ;;;
(printf "running test1.ss~n")
(define frame
(instantiate frame% ()
(label "Frame")
(width 400)
(height 400)))
(define pasteboard
(instantiate horizontal-pasteboard% ()))
(define canvas
(instantiate aligned-editor-canvas% ()
(parent frame)
(editor pasteboard)))
(define insider
(instantiate vertical-pasteboard% ()))
(define insider2
(instantiate vertical-pasteboard% ()))
(define insider3
(instantiate vertical-pasteboard% ()))
(define insider4
(instantiate vertical-pasteboard% ()))
(define insider5
(instantiate vertical-pasteboard% ()))
(define insider6
(instantiate vertical-pasteboard% ()))
(define insider7
(instantiate vertical-pasteboard% ()))
(define pb-snip
(instantiate aligned-editor-snip% ()
(editor insider)))
(define pb-snip2
(instantiate aligned-editor-snip% ()
(editor insider2)))
(define pb-snip3
(instantiate aligned-editor-snip% ()
(editor insider3)))
(define pb-snip4
(instantiate aligned-editor-snip% ()
(editor insider4)))
(define pb-snip5
(instantiate aligned-editor-snip% ()
(editor insider5)))
(define pb-snip6
(instantiate aligned-editor-snip% ()
(editor insider6)))
(define pb-snip7
(instantiate aligned-editor-snip% ()
(editor insider7)))
(define t-snip
(instantiate editor-snip% ()
(editor
(instantiate text% ()))))
(define i-snip
(instantiate image-snip% ()))
(define i-snip2
(instantiate image-snip% ()))
(define t-snip2
(instantiate editor-snip% ()
(editor
(instantiate text% ()))))
(define t-snip3
(instantiate editor-snip% ()
(editor
(instantiate text% ()))))
(send pasteboard begin-edit-sequence)
(send frame show true)
(send pasteboard insert pb-snip)
(send pasteboard insert t-snip)
(send pasteboard insert i-snip)
(send pasteboard insert i-snip2)
(send pasteboard insert pb-snip2)
(send pasteboard insert t-snip2)
(send insider insert t-snip3)
(send insider2 insert pb-snip3)
(send insider2 insert pb-snip4)
(send pasteboard insert pb-snip5)
(send pasteboard insert pb-snip6)
(send pasteboard insert pb-snip7)
(send pasteboard end-edit-sequence)
; ; ;
; ; ;
;;;;;;; ;;;;; ;;;; ;;;;; ;;;;
; ; ; ; ; ; ; ; ;
; ; ;;;;;; ;;;; ; ;;;;
; ; ; ; ; ;
; ; ;; ; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ;;;;; ;;;;
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 57.0 368.0 0.0 0.0 empty)
(make-snip-dump 114.0 368.0 57.0 0.0 empty)
(make-snip-dump 171.0 368.0 114.0 0.0 empty)
(make-snip-dump 182.0 24.0 171.0 0.0 empty)
(make-snip-dump
249.0
368.0
182.0
0.0
(list (make-snip-dump 55.0 178.0 0.0 0.0 empty) (make-snip-dump 55.0 356.0 0.0 178.0 empty)))
(make-snip-dump 269.0 20.0 249.0 0.0 false)
(make-snip-dump 289.0 20.0 269.0 0.0 false)
(make-snip-dump 300.0 24.0 289.0 0.0 empty)
(make-snip-dump 368.0 368.0 300.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
)
(send frame resize 0 0)
(sleep/yield 1)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 10.0 34.0 0.0 0.0 empty)
(make-snip-dump 20.0 34.0 10.0 0.0 empty)
(make-snip-dump 30.0 34.0 20.0 0.0 empty)
(make-snip-dump 41.0 24.0 30.0 0.0 empty)
(make-snip-dump
61.0
34.0
41.0
0.0
(list (make-snip-dump 10.0 11.0 0.0 0.0 empty) (make-snip-dump 10.0 22.0 0.0 11.0 empty)))
(make-snip-dump 81.0 20.0 61.0 0.0 false)
(make-snip-dump 101.0 20.0 81.0 0.0 false)
(make-snip-dump 112.0 24.0 101.0 0.0 empty)
(make-snip-dump 133.0 34.0 112.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
)
(send frame resize 800 600)
(sleep/yield 1)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 137.0 568.0 0.0 0.0 empty)
(make-snip-dump 274.0 568.0 137.0 0.0 empty)
(make-snip-dump 411.0 568.0 274.0 0.0 empty)
(make-snip-dump 422.0 24.0 411.0 0.0 empty)
(make-snip-dump
569.0
568.0
422.0
0.0
(list (make-snip-dump 135.0 278.0 0.0 0.0 empty) (make-snip-dump 135.0 556.0 0.0 278.0 empty)))
(make-snip-dump 589.0 20.0 569.0 0.0 false)
(make-snip-dump 609.0 20.0 589.0 0.0 false)
(make-snip-dump 620.0 24.0 609.0 0.0 empty)
(make-snip-dump 768.0 568.0 620.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
)
(send frame resize 400 400)
(send pasteboard delete i-snip)
(send pasteboard delete i-snip2)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 65.0 368.0 0.0 0.0 empty)
(make-snip-dump 130.0 368.0 65.0 0.0 empty)
(make-snip-dump 195.0 368.0 130.0 0.0 empty)
(make-snip-dump 206.0 24.0 195.0 0.0 empty)
(make-snip-dump
281.0
368.0
206.0
0.0
(list (make-snip-dump 63.0 178.0 0.0 0.0 empty) (make-snip-dump 63.0 356.0 0.0 178.0 empty)))
(make-snip-dump 292.0 24.0 281.0 0.0 empty)
(make-snip-dump 368.0 368.0 292.0 0.0 (list (make-snip-dump 11.0 24.0 0.0 0.0 empty))))
)
(send pasteboard erase)
(dump=?
(dump-children pasteboard)
empty
)
(send frame show false)
(printf "done~n")

190
collects/tests/aligned-pasteboard/test2.ss Normal file
View File

@ -0,0 +1,190 @@
;;note: turns out these tests are window manager specific
(require
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "etc.ss")
(lib "list.ss")
(lib "aligned-pasteboard.ss" "mrlib")
"snip-dumper.ss")
;
;
; ;;
; ;
; ;
; ;;;;; ;; ;; ;;;;;;;;;;;;;; ;;; ; ;;;;; ;;;;
; ; ; ;;;; ; ; ; ; ;; ;; ; ; ; ; ;
; ;;;;;; ;; ;;;; ; ; ; ; ; ; ;;;;;; ;;;;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;
; ;;;; ;; ;; ;;;;;;; ;; ;;; ;;; ;;;;; ;;;; ;;;;
; ;
; ;;;
;
(printf "running test2.ss~n")
(define frame
(instantiate frame% ()
(label "Frame")
(width 400)
(height 400)))
(define pasteboard
(instantiate horizontal-pasteboard% ()))
(define canvas
(instantiate aligned-editor-canvas% ()
(parent frame)
(editor pasteboard)))
(define vp1
(instantiate vertical-pasteboard% ()))
(define ae-snip1
(instantiate aligned-editor-snip% ()
(editor vp1)))
(define vp2
(instantiate vertical-pasteboard% ()))
(define ae-snip2
(instantiate aligned-editor-snip% ()
(editor vp2)))
(define vp3
(instantiate vertical-pasteboard% ()))
(define ae-snip3
(instantiate aligned-editor-snip% ()
(editor vp3)))
(define vp4
(instantiate vertical-pasteboard% ()))
(define ae-snip4
(instantiate aligned-editor-snip% ()
(editor vp4)))
(define vp5
(instantiate vertical-pasteboard% ()))
(define ae-snip5
(instantiate aligned-editor-snip% ()
(editor vp5)))
(send pasteboard insert ae-snip1)
(send pasteboard insert ae-snip2)
(send pasteboard insert ae-snip5)
(send vp2 insert ae-snip3)
(send vp2 insert ae-snip4)
(send frame show true)
;
;
;
; ; ;
; ; ;
; ;;;;; ;;;;; ;;;; ;;;;; ;;;;
; ; ; ; ; ; ; ; ;
; ; ;;;;;; ;;;; ; ;;;;
; ; ; ; ; ;
; ; ;; ; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ;;;;; ;;;;
;
;
;
(sleep/yield 1)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 120.0 368.0 0.0 0.0 empty)
(make-snip-dump
249.0
368.0
120.0
0.0
(list (make-snip-dump 117.0 178.0 0.0 0.0 empty) (make-snip-dump 117.0 356.0 0.0 178.0 empty)))
(make-snip-dump 368.0 368.0 249.0 0.0 empty))
)
(send frame resize 0 0)
(sleep/yield 1)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 10.0 30.0 0.0 0.0 empty)
(make-snip-dump
30.0
30.0
10.0
0.0
(list (make-snip-dump 10.0 10.0 0.0 0.0 empty) (make-snip-dump 10.0 19.0 0.0 9.0 empty)))
(make-snip-dump 40.0 30.0 30.0 0.0 empty))
)
(send frame resize 800 600)
(sleep/yield 1)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 253.0 568.0 0.0 0.0 empty)
(make-snip-dump
516.0
568.0
253.0
0.0
(list (make-snip-dump 251.0 278.0 0.0 0.0 empty) (make-snip-dump 251.0 556.0 0.0 278.0 empty)))
(make-snip-dump 768.0 568.0 516.0 0.0 empty))
)
(send pasteboard delete ae-snip5)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump
389.0
568.0
0.0
0.0
(list (make-snip-dump 377.0 278.0 0.0 0.0 empty) (make-snip-dump 377.0 556.0 0.0 278.0 empty)))
(make-snip-dump 768.0 568.0 389.0 0.0 empty))
)
(send pasteboard insert ae-snip5)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 253.0 568.0 0.0 0.0 empty)
(make-snip-dump
516.0
568.0
253.0
0.0
(list (make-snip-dump 251.0 278.0 0.0 0.0 empty) (make-snip-dump 251.0 556.0 0.0 278.0 empty)))
(make-snip-dump 768.0 568.0 516.0 0.0 empty))
)
(send pasteboard delete ae-snip5)
(send pasteboard delete ae-snip1)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump
768.0
568.0
0.0
0.0
(list (make-snip-dump 756.0 278.0 0.0 0.0 empty) (make-snip-dump 756.0 556.0 0.0 278.0 empty))))
)
(send pasteboard erase)
(dump=?
(dump-children pasteboard)
empty
)
(send frame show false)
(printf "done~n")