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

Sort the mess with aligned-pasteboard tests.

Browse Source 
1. Lots of #lang-ization, other racketizations, code improvements, etc.

2. Some files that were not working now do.

3. "collects/tests/aligned-pasteboard" had some files that were near
   duplicates of "collects/mrlib/private/aligned-pasteboard/tests".
   I've removed the former since in a few places it looked like an older
   version (eg, there were bogus references to a non-existent
   "utils.rkt").  The former has more files that are in runnable
   condition now.

4. There are plenty of tests that look like they're failing, but it
   wasn't shown since they just return #f, and when they were running
   with a "-f" these results weren't displayed.

5. I have no idea about the code, this is all just reshuffling and minor
   editing.
This commit is contained in:
Eli Barzilay 2012-06-19 01:30:17 -04:00
parent 10c06d25a7
commit b8034828d0
44 changed files with 1065 additions and 2773 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/meta/props
View File

@ -788,11 +788,9 @@ path/s is either such a string or a list of them.
"collects/mred/private/wx/cocoa" drdr:command-line #f "collects/mred/private/wx/cocoa" drdr:command-line #f
"collects/mred/private/wx/win32" drdr:command-line #f "collects/mred/private/wx/win32" drdr:command-line #f
"collects/mrlib" responsible (mflatt robby) "collects/mrlib" responsible (mflatt robby)
"collects/mrlib/private/aligned-pasteboard/tests/actual-bigger.rktl" drdr:command-line (racket "-f" *) "collects/mrlib/private/aligned-pasteboard/tests/actual-bigger.rkt" drdr:command-line (gracket *)
"collects/mrlib/private/aligned-pasteboard/tests/edit-sequence-loop.rktl" drdr:command-line (gracket "-f" *)
"collects/mrlib/private/aligned-pasteboard/tests/example-min.rkt" drdr:command-line #f "collects/mrlib/private/aligned-pasteboard/tests/example-min.rkt" drdr:command-line #f
"collects/mrlib/private/aligned-pasteboard/tests/example.rkt" drdr:command-line #f "collects/mrlib/private/aligned-pasteboard/tests/example.rkt" drdr:command-line #f
"collects/mrlib/private/aligned-pasteboard/tests/insertion-without-display.rktl" drdr:command-line (racket "-f" *)
"collects/mrlib/private/aligned-pasteboard/tests/minimal.rkt" drdr:command-line #f "collects/mrlib/private/aligned-pasteboard/tests/minimal.rkt" drdr:command-line #f
"collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin-aligned.rkt" drdr:command-line #f "collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin-aligned.rkt" drdr:command-line #f
"collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin.rkt" drdr:command-line #f "collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin.rkt" drdr:command-line #f
@ -800,14 +798,13 @@ path/s is either such a string or a list of them.
"collects/mrlib/private/aligned-pasteboard/tests/more-tests-min.rkt" drdr:command-line #f "collects/mrlib/private/aligned-pasteboard/tests/more-tests-min.rkt" drdr:command-line #f
"collects/mrlib/private/aligned-pasteboard/tests/more-tests-text.rkt" drdr:command-line #f "collects/mrlib/private/aligned-pasteboard/tests/more-tests-text.rkt" drdr:command-line #f
"collects/mrlib/private/aligned-pasteboard/tests/more-tests.rkt" drdr:command-line #f "collects/mrlib/private/aligned-pasteboard/tests/more-tests.rkt" drdr:command-line #f
"collects/mrlib/private/aligned-pasteboard/tests/old-bugs" drdr:command-line #f
"collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test-min.rkt" drdr:command-line #f "collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test-min.rkt" drdr:command-line #f
"collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test.rkt" drdr:command-line #f "collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test.rkt" drdr:command-line #f
"collects/mrlib/private/aligned-pasteboard/tests/test-alignment.rktl" drdr:command-line (racket "-f" *)
"collects/mrlib/private/aligned-pasteboard/tests/test-locked-pasteboard.rkt" drdr:command-line #f "collects/mrlib/private/aligned-pasteboard/tests/test-locked-pasteboard.rkt" drdr:command-line #f
"collects/mrlib/private/aligned-pasteboard/tests/test-pasteboard-lib.rktl" drdr:command-line (racket "-f" *) "collects/mrlib/private/aligned-pasteboard/tests/test-snip-lib.rkt" drdr:command-line (gracket *)
"collects/mrlib/private/aligned-pasteboard/tests/test-snip-lib.rktl" drdr:command-line (gracket "-f" *) "collects/mrlib/private/aligned-pasteboard/tests/test.rkt" drdr:command-line (gracket *)
"collects/mrlib/private/aligned-pasteboard/tests/test.rktl" drdr:command-line (gracket "-f" *) "collects/mrlib/private/aligned-pasteboard/tests/test2.rkt" drdr:command-line (gracket *)
"collects/mrlib/private/aligned-pasteboard/tests/test2.rktl" drdr:command-line (gracket "-f" *)
"collects/mysterx" responsible (mflatt) "collects/mysterx" responsible (mflatt)
"collects/mysterx/main.rkt" drdr:command-line (mzc *) "collects/mysterx/main.rkt" drdr:command-line (mzc *)
"collects/mysterx/mysterx.rkt" drdr:command-line (mzc *) "collects/mysterx/mysterx.rkt" drdr:command-line (mzc *)
@ -981,15 +978,6 @@ path/s is either such a string or a list of them.
"collects/teachpack/htdp/graphing.ss" drdr:command-line (mzc *) "collects/teachpack/htdp/graphing.ss" drdr:command-line (mzc *)
"collects/test-box-recovery" responsible (mflatt) "collects/test-box-recovery" responsible (mflatt)
"collects/test-engine" responsible (kathyg) "collects/test-engine" responsible (kathyg)
"collects/tests/aligned-pasteboard" responsible (mflatt robby)
"collects/tests/aligned-pasteboard/example.rktl" drdr:command-line #f
"collects/tests/aligned-pasteboard/old-bugs/big-min.rktl" drdr:command-line #f
"collects/tests/aligned-pasteboard/old-bugs/missing-min.rktl" drdr:command-line #f
"collects/tests/aligned-pasteboard/test-alignment.rktl" drdr:command-line #f
"collects/tests/aligned-pasteboard/test-pasteboard-lib.rktl" drdr:command-line #f
"collects/tests/aligned-pasteboard/test-snip-lib.rktl" drdr:command-line #f
"collects/tests/aligned-pasteboard/test.rktl" drdr:command-line (gracket "-f" *)
"collects/tests/aligned-pasteboard/test2.rktl" drdr:command-line (gracket "-f" *)
"collects/tests/compiler" responsible (jay) "collects/tests/compiler" responsible (jay)
"collects/tests/compiler/demodularizer/demod-test.rkt" drdr:timeout 600 "collects/tests/compiler/demodularizer/demod-test.rkt" drdr:timeout 600
"collects/tests/compiler/regression.rkt" responsible (mflatt) "collects/tests/compiler/regression.rkt" responsible (mflatt)

41
collects/mrlib/private/aligned-pasteboard/alignment.rkt
View File

@ -1,23 +1,26 @@
#| #|
This code computes the sizees for the rectangles in the space using the on dimension This code computes the sizes for the rectangles in the space using the
off dimension method of referencing sizes. This means for example instead of saying on dimension off dimension method of referencing sizes. This means for
width we say off dimension for vertical alignment. Inorder to consume and return example instead of saying width we say off dimension for vertical
the values in terms of width and height manipulation had to be done. I chose to create alignment. Inorder to consume and return the values in terms of width
a struct abs-rect (abstract rectangle) and have code map horizontal and vertical rect and height manipulation had to be done. I chose to create a struct
stucts on to them. This code is a bit long but more readable than the other two options abs-rect (abstract rectangle) and have code map horizontal and vertical
I came up with. rect stucts on to them. This code is a bit long but more readable than
1) define all functions to be letrec bound functions inside align. align then take the other two options I came up with.
accessors for the rect struct. The caller of align swaps the order of ondimension 1) define all functions to be letrec bound functions inside align.
and off dimension accessors for vertical or horizontal code. This method does not align then take accessors for the rect struct. The caller of align
allow the use of the readable, short, consis pattern matching code. As some of the swaps the order of ondimension and off dimension accessors for
matching code is easily removed this may be a good option but a large letrec vertical or horizontal code. This method does not allow the use of
is harder to write tests for. the readable, short, consis pattern matching code. As some of the
2) define a pattern matcher syntax that will match the struct rect but swap the fields matching code is easily removed this may be a good option but a
based on wich on is the on or off dimension. This would have been shorter but much large letrec is harder to write tests for.
more confusing. 2) define a pattern matcher syntax that will match the struct rect but
The current implementation requires align to map over the rects and allocate new stucts swap the fields based on wich on is the on or off dimension. This
for each one on both passing into and returning from stretch-to-fit; This is not a bottle would have been shorter but much more confusing.
neck and it is the most readable solution. The current implementation requires align to map over the rects and
allocate new stucts for each one on both passing into and returning from
stretch-to-fit; This is not a bottle neck and it is the most readable
solution.
|# |#
(module alignment mzscheme (module alignment mzscheme

17
collects/mrlib/private/aligned-pasteboard/tests/actual-bigger.rktl → collects/mrlib/private/aligned-pasteboard/tests/actual-bigger.rkt
View File

@ -1,25 +1,26 @@
(require mzlib/class mzlib/list mred mzlib/etc #lang racket/gui
"../aligned-editor-container.rkt"
"../aligned-pasteboard.rkt" (require "../aligned-editor-container.rkt" "../aligned-pasteboard.rkt"
"../snip-lib.rkt") "../snip-lib.rkt")
(define f (new frame% (label "test") (width 200) (height 200))) (define f (new frame% [label "test"] [width 200] [height 200]))
(define e (new text%)) (define e (new text%))
(define c (new editor-canvas% (editor e) (parent f))) (define c (new editor-canvas% [editor e] [parent f]))
(define vpb1 (new vertical-pasteboard%)) (define vpb1 (new vertical-pasteboard%))
(define aes1 (new aligned-editor-snip% (editor vpb1))) (define aes1 (new aligned-editor-snip% [editor vpb1]))
(define vpb2 (new vertical-pasteboard%)) (define vpb2 (new vertical-pasteboard%))
(define aes2 (new aligned-editor-snip% (editor vpb2))) (define aes2 (new aligned-editor-snip% [editor vpb2]))
(define t (new text%)) (define t (new text%))
(define es (new editor-snip% (editor t))) (define es (new editor-snip% (editor t)))
(send vpb1 insert aes2 false) (send vpb1 insert aes2 false)
(send vpb2 insert es) (send vpb2 insert es)
(send e insert aes1) (send e insert aes1)
(send f show #t) (send f show #t)
(sleep 0.2)
(send f show #f) (send f show #f)
(send t begin-edit-sequence) (send t begin-edit-sequence)

135
collects/mrlib/private/aligned-pasteboard/tests/debug.rkt
View File

@ -1,80 +1,57 @@
(module debug mzscheme #lang racket/gui
(require
mzlib/class) (provide debug-snip debug-pasteboard debug-canvas)
(provide ;; debug-snip: -> (void)
debug-snip ;; get the relevant info about the snip that contains the two others
debug-pasteboard ;; pasteboards
debug-canvas) (define (debug-snip snip)
(printf "--- aligned-editor-snip% --\n")
;;debug-snip: -> (void) (let ([l (box 0)] [t (box 0)] [r (box 0)] [b (box 0)])
;;get the relevant info about the snip that contains the two others pasteboards (send snip get-inset l t r b)
(define debug-snip (printf "get-inset: ~sX~s ~sX~s\n"
(lambda (snip) (unbox l) (unbox r) (unbox t) (unbox b)))
(printf "--- aligned-editor-snip% --\n") (let ([l (box 0)] [t (box 0)] [r (box 0)] [b (box 0)])
(let ((l (box 0)) (send snip get-margin l t r b)
(t (box 0)) (printf "get-margin: ~sX~s ~sX~s\n"
(r (box 0)) (unbox l) (unbox r) (unbox t) (unbox b)))
(b (box 0))) (printf "get-max-height: ~s\n" (send snip get-max-height))
(send snip get-inset l t r b) (printf "get-max-width: ~s\n" (send snip get-max-width))
(printf "get-inset: ~sX~s ~sX~s\n" (unbox l) (unbox r) (unbox t) (unbox b))) (printf "get-min-height: ~s\n" (send snip get-min-height))
(printf "get-min-width: ~s\n" (send snip get-min-width))
(let ((l (box 0)) ;; (printf "snip-width: ~s\n" (send pasteboard snip-width snip))
(t (box 0)) ;; (printf "snip-height: ~s\n" (send pasteboard snip-height snip))
(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))
))
) )
;; debug-pasteboard: -> (void)
;; displays to the repl the sizes i'm interested in
(define (debug-pasteboard pasteboard)
(printf "--- aligned-pasteboard% ---\n")
(let ([t1 (box 0)] [t2 (box 0)])
(send pasteboard get-extent t1 t2)
(printf "get-extent: ~sX~s\n" (unbox t1) (unbox t2)))
(printf "get-max-height: ~s\n" (send pasteboard get-max-height))
(let ([t (call-with-values (λ () (send pasteboard get-max-view-size)) cons)])
(printf "get-max-view-size: ~sX~s\n" (car t) (cdr t)))
(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 ([t1 (box 0)] [t2 (box 0)])
(send pasteboard get-view-size t1 t2)
(printf "get-view-size: ~sX~s\n" (unbox t1) (unbox t2))))
;; debug-canvas: -> (void)
;; just some help counting pixels
(define (debug-canvas canvas)
(printf "--- aligned-editor-canvas% ---\n")
;; values
(define-syntax-rule (show* what ...)
(begin (let ([t (call-with-values (λ () (send canvas what)) cons)])
(printf "~a: ~sX~s\n" 'what (car t) (cdr t)))
...))
(show* get-client-size get-graphical-min-size get-size)
;; 1 value
(define-syntax-rule (show1 what ...)
(begin (printf "~a: ~s\n" 'what (send canvas what)) ...))
(show1 get-height get-width horiz-margin min-client-height min-client-width
min-height min-width vert-margin))

19
collects/mrlib/private/aligned-pasteboard/tests/edit-sequence-loop.rkt Normal file
View File

@ -0,0 +1,19 @@
#lang racket/gui
(require "../aligned-pasteboard.rkt" "../aligned-editor-container.rkt")
(define f (new frame% (label "test")))
(define e (new text%))
(define c (new editor-canvas% (editor e) (parent f)))
(define pb (new vertical-pasteboard%))
(define actual (new text%))
(define act-line (new aligned-editor-snip% (editor (new vertical-pasteboard%))))
(define t (new aligned-editor-snip% (editor pb)))
(send e insert t)
(send* pb (begin-edit-sequence) (insert act-line #f) (end-edit-sequence))
;; Eli: for some reason, this used to pass the result into this
;; function:
;; (define (converges? x) #t)
;; I take it that the requirement is that it finishes after some time,
;; so there's no need for the function.

14
collects/mrlib/private/aligned-pasteboard/tests/edit-sequence-loop.rktl
View File

@ -1,14 +0,0 @@
(require "../aligned-pasteboard.rkt" "../aligned-editor-container.rkt")
(define (converges? x) #t)
(converges?
(let* ((f (new frame% (label "test")))
(e (new text%))
(c (new editor-canvas% (editor e) (parent f)))
(pb (new vertical-pasteboard%))
(actual (new text%))
(act-line (new aligned-editor-snip% (editor (new vertical-pasteboard%))))
(t (new aligned-editor-snip% (editor pb))))
(send e insert t)
(send* pb (begin-edit-sequence) (insert act-line #f) (end-edit-sequence))))

9
collects/mrlib/private/aligned-pasteboard/tests/example-min.rkt
View File

@ -1,9 +1,6 @@
(require #lang racket/gui
mzlib/class
mred (require "../aligned-pasteboard.rkt" "../aligned-editor-container.rkt")
mzlib/etc
"../aligned-pasteboard.rkt"
"../aligned-editor-container.rkt")
(define f (new frame% (label "") (width 400) (height 400))) (define f (new frame% (label "") (width 400) (height 400)))
(define e (new horizontal-pasteboard%)) (define e (new horizontal-pasteboard%))

92
collects/mrlib/private/aligned-pasteboard/tests/example.rkt
View File

@ -1,81 +1,23 @@
(require #lang racket/gui
mzlib/class
mred
mzlib/etc
"../aligned-pasteboard.rkt"
"../aligned-editor-container.rkt")
; (require "../aligned-pasteboard.rkt" "../aligned-editor-container.rkt")
;
; ;;
; ;
; ;
; ;;;;; ;; ;; ;;;;;;;;;;;;;; ;;; ; ;;;;; ;;;;
; ; ; ;;;; ; ; ; ; ;; ;; ; ; ; ; ;
; ;;;;;; ;; ;;;; ; ; ; ; ; ; ;;;;;; ;;;;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;
; ;;;; ;; ;; ;;;;;;; ;; ;;; ;;; ;;;;; ;;;; ;;;;
; ;
; ;;;
;
(define frame (define frame (new frame% [label "Frame"] [width 400] [height 400]))
(instantiate frame% () (define pasteboard (new horizontal-pasteboard%))
(label "Frame") (define canvas (new aligned-editor-canvas% [parent frame] [editor pasteboard]))
(width 400)
(height 400)))
(define pasteboard (define vp1 (new vertical-pasteboard%))
(instantiate horizontal-pasteboard% ())) (define ae-snip1 (new aligned-editor-snip% [editor vp1]))
(define vp2 (new vertical-pasteboard%))
(define canvas (define ae-snip2 (new aligned-editor-snip% [editor vp2]))
(instantiate aligned-editor-canvas% () (define vp3 (new vertical-pasteboard%))
(parent frame) (define ae-snip3 (new aligned-editor-snip% [editor vp3]))
(editor pasteboard))) (define vp4 (new vertical-pasteboard%))
(define ae-snip4 (new aligned-editor-snip% [editor vp4]))
(define vp1 (define vp5 (new vertical-pasteboard%))
(instantiate vertical-pasteboard% ())) (define ae-snip5 (new aligned-editor-snip% [editor vp5]))
(define t-snip1 (new editor-snip% [editor (instantiate text% ())]))
(define ae-snip1 (define t-snip2 (new editor-snip% [editor (instantiate text% ())]))
(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-snip1 false)
(send pasteboard insert ae-snip2 false) (send pasteboard insert ae-snip2 false)

8
collects/mrlib/private/aligned-pasteboard/tests/insertion-without-display.rkt Normal file
View File

@ -0,0 +1,8 @@
#lang racket/gui
(require mrlib/aligned-pasteboard)
(with-handlers ([exn? (lambda (x) #f)])
(send (new pasteboard%)
insert (new aligned-editor-snip% [editor (new horizontal-pasteboard%)]))
#t)

4
collects/mrlib/private/aligned-pasteboard/tests/insertion-without-display.rktl
View File

@ -1,4 +0,0 @@
(require mrlib/aligned-pasteboard)
(with-handlers ([exn? (lambda (x) #f)])
(send (new pasteboard%) insert (new aligned-editor-snip% (editor (new horizontal-pasteboard%))))
#t)

15
collects/mrlib/private/aligned-pasteboard/tests/minimal.rkt
View File

@ -1,12 +1,13 @@
(require #lang racket/gui
"../aligned-editor-container.rkt"
"../aligned-pasteboard.rkt")
(define f (new frame% (label "test") (width 200) (height 200))) (require "../aligned-editor-container.rkt" "../aligned-pasteboard.rkt")
(define e (new vertical-pasteboard%))
(define c (new aligned-editor-canvas% (editor e) (parent f))) (define f (new frame% [label "test"] [width 200] [height 200]))
(define e (new vertical-pasteboard%))
(define c (new aligned-editor-canvas% [editor e] [parent f]))
(define pb (new vertical-pasteboard%)) (define pb (new vertical-pasteboard%))
(define s (new aligned-editor-snip% (editor pb) (stretchable-height #f) (stretchable-width #f))) (define s (new aligned-editor-snip%
[editor pb] [stretchable-height #f] [stretchable-width #f]))
(send pb insert (make-object string-snip% "Long snip")) (send pb insert (make-object string-snip% "Long snip"))
(send pb insert (make-object string-snip% "Longer snip")) (send pb insert (make-object string-snip% "Longer snip"))
(send e insert s) (send e insert s)

33
collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin-aligned.rkt
View File

@ -1,15 +1,16 @@
(require #lang racket/gui
"../aligned-editor-container.rkt"
"../aligned-pasteboard.rkt") (require "../aligned-editor-container.rkt" "../aligned-pasteboard.rkt")
(define pb (new horizontal-pasteboard%)) (define pb (new horizontal-pasteboard%))
(send* pb (send* pb
(insert (make-object string-snip% "Call") #f) (insert (make-object string-snip% "Call") #f)
(insert (new editor-snip% (editor (new text%))) #f)) (insert (new editor-snip% [editor (new text%)]) #f))
(define z (new aligned-editor-snip% (editor pb) (stretchable-height #f) (stretchable-width #f))) (define z (new aligned-editor-snip%
(define f (new frame% (label "more-tests-text") (width 200) (height 200))) [editor pb] [stretchable-height #f] [stretchable-width #f]))
(define f (new frame% [label "more-tests-text"] [width 200] [height 200]))
(define e (new vertical-pasteboard%)) (define e (new vertical-pasteboard%))
(define c (new aligned-editor-canvas% (editor e) (parent f))) (define c (new aligned-editor-canvas% [editor e] [parent f]))
(send e insert z) (send e insert z)
(send f show #t) (send f show #t)
@ -17,12 +18,12 @@
;; exploration ;; exploration
(require "../snip-lib.rkt") (require "../snip-lib.rkt")
(define (margin snip) (define (margin snip)
(let ([left (box 0)] (define left (box 0))
[top (box 0)] (define top (box 0))
[right (box 0)] (define right (box 0))
[bottom (box 0)]) (define bottom (box 0))
(send snip get-margin left top right bottom) (send snip get-margin left top right bottom)
(list (cons 'left (unbox left)) (list (cons 'left (unbox left))
(cons 'right (unbox right)) (cons 'right (unbox right))
(cons 'top (unbox top)) (cons 'top (unbox top))
(cons 'bottom (unbox bottom))))) (cons 'bottom (unbox bottom))))

32
collects/mrlib/private/aligned-pasteboard/tests/more-tests-margin.rkt
View File

@ -1,15 +1,15 @@
(require #lang racket/gui
"../aligned-editor-container.rkt"
"../aligned-pasteboard.rkt") (require "../aligned-editor-container.rkt" "../aligned-pasteboard.rkt")
(define pb (new horizontal-pasteboard%)) (define pb (new horizontal-pasteboard%))
(send* pb (send* pb
(insert (make-object string-snip% "Call") #f) (insert (make-object string-snip% "Call") #f)
(insert (new editor-snip% (editor (new text%))) #f)) (insert (new editor-snip% [editor (new text%)]) #f))
(define z (new aligned-editor-snip% (editor pb))) (define z (new aligned-editor-snip% [editor pb]))
(define f (new frame% (label "more-tests-text") (width 200) (height 200))) (define f (new frame% [label "more-tests-text"] [width 200] [height 200]))
(define e (new pasteboard%)) (define e (new pasteboard%))
(define c (new editor-canvas% (editor e) (parent f))) (define c (new editor-canvas% [editor e] [parent f]))
(send e insert z) (send e insert z)
(send f show #t) (send f show #t)
@ -17,12 +17,12 @@
;; exploration ;; exploration
(require "../snip-lib.rkt") (require "../snip-lib.rkt")
(define (margin snip) (define (margin snip)
(let ([left (box 0)] (define left (box 0))
[top (box 0)] (define top (box 0))
[right (box 0)] (define right (box 0))
[bottom (box 0)]) (define bottom (box 0))
(send snip get-margin left top right bottom) (send snip get-margin left top right bottom)
(list (cons 'left (unbox left)) (list (cons 'left (unbox left))
(cons 'right (unbox right)) (cons 'right (unbox right))
(cons 'top (unbox top)) (cons 'top (unbox top))
(cons 'bottom (unbox bottom))))) (cons 'bottom (unbox bottom))))

36
collects/mrlib/private/aligned-pasteboard/tests/more-tests-min-stretchable.rkt
View File

@ -1,18 +1,17 @@
(require #lang racket/gui
"../aligned-editor-container.rkt"
"../aligned-pasteboard.rkt") (require "../aligned-editor-container.rkt" "../aligned-pasteboard.rkt")
(define editor (new vertical-pasteboard%)) (define editor (new vertical-pasteboard%))
(define pb (new horizontal-pasteboard%)) (define pb (new horizontal-pasteboard%))
(send* pb (send* pb
(insert (make-object string-snip% "Call") #f) (insert (make-object string-snip% "Call") #f)
(insert (new editor-snip% (editor (new text%))) #f)) (insert (new editor-snip% [editor (new text%)]) #f))
(send editor insert (new aligned-editor-snip% (editor pb))) (send editor insert (new aligned-editor-snip% [editor pb]))
(define f (new frame% (label "more-test-jacob") (width 200) (height 200))) (define f (new frame% [label "more-test-jacob"] [width 200] [height 200]))
(define e (new vertical-pasteboard%)) (define e (new vertical-pasteboard%))
(define c (new aligned-editor-canvas% (editor e) (parent f))) (define c (new aligned-editor-canvas% [editor e] [parent f]))
(define t (new aligned-editor-snip% (define t (new aligned-editor-snip% [editor editor]))
(editor editor)))
(send e insert t) (send e insert t)
(send f show #t) (send f show #t)
@ -23,18 +22,17 @@
(send t-e get-aligned-min-width) (send t-e get-aligned-min-width)
(send t get-aligned-min-width) (send t get-aligned-min-width)
(define fs (send t-e find-first-snip)) (define fs (send t-e find-first-snip))
(define fs (send t-e find-first-snip))
(define fs-e (send fs get-editor)) (define fs-e (send fs get-editor))
(send fs-e find-first-snip) (send fs-e find-first-snip)
(send fs-e get-aligned-min-width) (send fs-e get-aligned-min-width)
(send fs get-aligned-min-width) (send fs get-aligned-min-width)
(define (margin snip) (define (margin snip)
(let ([left (box 0)] (define left (box 0))
[top (box 0)] (define top (box 0))
[right (box 0)] (define right (box 0))
[bottom (box 0)]) (define bottom (box 0))
(send snip get-margin left top right bottom) (send snip get-margin left top right bottom)
(list (cons 'left (unbox left)) (list (cons 'left (unbox left))
(cons 'right (unbox right)) (cons 'right (unbox right))
(cons 'top (unbox top)) (cons 'top (unbox top))
(cons 'bottom (unbox bottom))))) (cons 'bottom (unbox bottom))))

37
collects/mrlib/private/aligned-pasteboard/tests/more-tests-min.rkt
View File

@ -1,20 +1,18 @@
(require #lang racket/gui
"../aligned-editor-container.rkt"
"../aligned-pasteboard.rkt") (require "../aligned-editor-container.rkt" "../aligned-pasteboard.rkt")
(define editor (new vertical-pasteboard%)) (define editor (new vertical-pasteboard%))
(define pb (new horizontal-pasteboard%)) (define pb (new horizontal-pasteboard%))
(send* pb (send* pb
(insert (make-object string-snip% "Call") #f) (insert (make-object string-snip% "Call") #f)
(insert (new editor-snip% (editor (new text%))) #f)) (insert (new editor-snip% [editor (new text%)]) #f))
(send editor insert (new aligned-editor-snip% (editor pb))) (send editor insert (new aligned-editor-snip% [editor pb]))
(define f (new frame% (label "more-test-jacob") (width 200) (height 200))) (define f (new frame% [label "more-test-jacob"] [width 200] [height 200]))
(define e (new vertical-pasteboard%)) (define e (new vertical-pasteboard%))
(define c (new aligned-editor-canvas% (editor e) (parent f))) (define c (new aligned-editor-canvas% [editor e] [parent f]))
(define t (new aligned-editor-snip% (define t (new aligned-editor-snip%
(editor editor) [editor editor] [stretchable-height #f] [stretchable-width #f]))
(stretchable-height #f)
(stretchable-width #f)))
(send e insert t) (send e insert t)
(send f show #t) (send f show #t)
@ -25,18 +23,17 @@
(send t-e get-aligned-min-width) (send t-e get-aligned-min-width)
(send t get-aligned-min-width) (send t get-aligned-min-width)
(define fs (send t-e find-first-snip)) (define fs (send t-e find-first-snip))
(define fs (send t-e find-first-snip))
(define fs-e (send fs get-editor)) (define fs-e (send fs get-editor))
(send fs-e find-first-snip) (send fs-e find-first-snip)
(send fs-e get-aligned-min-width) (send fs-e get-aligned-min-width)
(send fs get-aligned-min-width) (send fs get-aligned-min-width)
(define (margin snip) (define (margin snip)
(let ([left (box 0)] (define left (box 0))
[top (box 0)] (define top (box 0))
[right (box 0)] (define right (box 0))
[bottom (box 0)]) (define bottom (box 0))
(send snip get-margin left top right bottom) (send snip get-margin left top right bottom)
(list (cons 'left (unbox left)) (list (cons 'left (unbox left))
(cons 'right (unbox right)) (cons 'right (unbox right))
(cons 'top (unbox top)) (cons 'top (unbox top))
(cons 'bottom (unbox bottom))))) (cons 'bottom (unbox bottom))))

43
collects/mrlib/private/aligned-pasteboard/tests/more-tests-text.rkt
View File

@ -1,27 +1,24 @@
;; Note this test case fails when the snip 'y' is stretchable. There is lots of extra space. Finding out #lang racket/gui
;; why will probably fix the test case's extra space.
(require ;; Note this test case fails when the snip 'y' is stretchable. There is
"../aligned-editor-container.rkt" ;; lots of extra space. Finding out why will probably fix the test
"../aligned-pasteboard.rkt") ;; case's extra space.
(require "../aligned-editor-container.rkt" "../aligned-pasteboard.rkt")
(define editor (new vertical-pasteboard%)) (define editor (new vertical-pasteboard%))
(define pb (new horizontal-pasteboard%)) (define pb (new horizontal-pasteboard%))
(define z (new editor-snip% (editor (new text%)))) (define z (new editor-snip% [editor (new text%)]))
(send* pb (send* pb
(insert (make-object string-snip% "Call") #f) (insert (make-object string-snip% "Call") #f)
(insert z #f)) (insert z #f))
(define y (new aligned-editor-snip% (define y (new aligned-editor-snip%
(editor pb) [editor pb] [stretchable-width #t] [stretchable-height #t]))
(stretchable-width #t)
(stretchable-height #t)))
(send editor insert y) (send editor insert y)
(define f (new frame% (label "more-tests-text") (width 200) (height 200))) (define f (new frame% [label "more-tests-text"] [width 200] [height 200]))
(define e (new pasteboard%)) (define e (new pasteboard%))
(define c (new editor-canvas% (editor e) (parent f))) (define c (new editor-canvas% [editor e] [parent f]))
(define t (new aligned-editor-snip% (define t (new aligned-editor-snip%
(editor editor) [editor editor] [stretchable-height #f] [stretchable-width #f]))
(stretchable-height #f)
(stretchable-width #f)))
(send e insert t) (send e insert t)
(send f show #t) (send f show #t)
@ -31,12 +28,12 @@
(eq-hash-code t) (eq-hash-code t)
(require "../snip-lib.rkt") (require "../snip-lib.rkt")
(define (margin snip) (define (margin snip)
(let ([left (box 0)] (define left (box 0))
[top (box 0)] (define top (box 0))
[right (box 0)] (define right (box 0))
[bottom (box 0)]) (define bottom (box 0))
(send snip get-margin left top right bottom) (send snip get-margin left top right bottom)
(list (cons 'left (unbox left)) (list (cons 'left (unbox left))
(cons 'right (unbox right)) (cons 'right (unbox right))
(cons 'top (unbox top)) (cons 'top (unbox top))
(cons 'bottom (unbox bottom))))) (cons 'bottom (unbox bottom))))

80
collects/mrlib/private/aligned-pasteboard/tests/more-tests.rkt
View File

@ -1,16 +1,13 @@
;; some more advanced aligned-pasteboard tests take from the test-case-boxes #lang racket/gui
(require ;; some more advanced aligned-pasteboard tests take from the
mzlib/class ;; test-case-boxes
mred
mzlib/etc (require "../aligned-editor-container.rkt" "../aligned-pasteboard.rkt")
"../aligned-editor-container.rkt"
"../aligned-pasteboard.rkt")
;; a text-case snip ;; a text-case snip
(define test-case-box% (define test-case-box%
(class aligned-editor-snip% (class aligned-editor-snip%
;; these edit-sequences are looping ;; these edit-sequences are looping
(define/public (hide-entries) (define/public (hide-entries)
(send* editor (send* editor
@ -19,7 +16,6 @@
(release-snip exp-line) (release-snip exp-line)
(release-snip act-line) (release-snip act-line)
(end-edit-sequence))) (end-edit-sequence)))
;; these edit-sequences are looping ;; these edit-sequences are looping
(define/public (show-entries) (define/public (show-entries)
(send* editor (send* editor
@ -28,51 +24,43 @@
(insert exp-line false) (insert exp-line false)
(insert act-line false) (insert act-line false)
(end-edit-sequence))) (end-edit-sequence)))
(field [editor (new vertical-pasteboard%)]
(field [turn-button (new image-snip%)]
[editor (new vertical-pasteboard%)] [comment (new text%)]
[turn-button (new image-snip%)] [result (new image-snip%)]
[comment (new text%)] [call (new text%)]
[result (new image-snip%)] [expected (new text%)]
[call (new text%)] [actual (new text%)]
[expected (new text%)] [top-line (make-top-line turn-button comment result)]
[actual (new text%)] [call-line (make-line "Call" call)]
[top-line (make-top-line turn-button comment result)] [exp-line (make-line "Expected" expected)]
[call-line (make-line "Call" call)] [act-line (make-line "Actual" actual)])
[exp-line (make-line "Expected" expected)]
[act-line (make-line "Actual" actual)])
(send editor insert top-line) (send editor insert top-line)
(show-entries) (show-entries)
(super-new [editor editor] [stretchable-height #f] [stretchable-width #f])))
(super-new
(editor editor)
(stretchable-height #f)
(stretchable-width #f))))
;; the top line of the test-case ;; the top line of the test-case
(define (make-top-line turn-snip comment result-snip) (define (make-top-line turn-snip comment result-snip)
(let ([pb (new horizontal-pasteboard%)]) (define pb (new horizontal-pasteboard%))
(send* pb (send* pb
(insert turn-snip false) (insert turn-snip false)
(insert (text-field comment) false) (insert (text-field comment) false)
(insert result-snip false)) (insert result-snip false))
(new aligned-editor-snip% (new aligned-editor-snip% [stretchable-height false] [editor pb]))
(stretchable-height false)
(editor pb))))
;; a line labeled with the given string and containing a given text ;; a line labeled with the given string and containing a given text
(define (make-line str text) (define (make-line str text)
(let ([pb (new horizontal-pasteboard%)]) (define pb (new horizontal-pasteboard%))
(send* pb (send* pb
(insert (make-object string-snip% str) false) (insert (make-object string-snip% str) false)
(insert (text-field text) false)) (insert (text-field text) false))
(new aligned-editor-snip% (editor pb)))) (new aligned-editor-snip% [editor pb]))
;; a text field fit to be in a test-case (no borders or margins etc.) ;; a text field fit to be in a test-case (no borders or margins etc.)
;;STATUS: this should really return a stretchable-snip<%> not an editor-snip% of fixed size. ;; STATUS: this should really return a stretchable-snip<%> not an
;; editor-snip% of fixed size.
(define (text-field text) (define (text-field text)
(new editor-snip% (editor text))) (new editor-snip% [editor text]))
;; To make case 3 work, I need to send the forward set-aligned-min-sizes ;; 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 ;; from the snip. Currently that call only originates in the on-size of
@ -85,11 +73,11 @@
[(2) (cons text% editor-canvas%)] [(2) (cons text% editor-canvas%)]
[(3) (cons pasteboard% editor-canvas%)])) [(3) (cons pasteboard% editor-canvas%)]))
(define f (new frame% (label "test") (width 200) (height 250))) (define f (new frame% [label "test"] [width 200] [height 250]))
(define e (new (car top))) (define e (new (car top)))
(define c (new (cdr top) (editor e) (parent f))) (define c (new (cdr top) (editor e) (parent f)))
(define t (new test-case-box%)) (define t (new test-case-box%))
(send e insert t) (send e insert t)
(send f show #t) (send f show #t)
;(send t hide-entries) ;; (send t hide-entries)
;(send t show-entries) ;; (send t show-entries)

23
collects/mrlib/private/aligned-pasteboard/tests/old-bugs/big-min.rkt Normal file
View File

@ -0,0 +1,23 @@
#lang racket/gui
(require mrlib/aligned-pasteboard)
(define frame (new frame% [label "big-min"] [width 400] [height 500]))
(define test-suite (new vertical-pasteboard%))
(new aligned-editor-canvas% [parent frame] [editor test-suite])
(define top-string #f)
(define (new*)
(define main-pb (new horizontal-pasteboard%))
(define pb (new vertical-pasteboard%))
(define snip (new aligned-editor-snip% [editor pb]))
(define string (make-object string-snip% "Testing String Snip"))
(set! top-string string)
(send main-pb insert snip false)
(send main-pb insert string false)
(new aligned-editor-snip% [editor main-pb]))
(send frame show #t)
(define (add) (send test-suite insert (new*)))
(add)

18
collects/mrlib/private/aligned-pasteboard/tests/old-bugs/missing-min.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang racket/gui
(require mrlib/aligned-pasteboard)
(define f (new frame% [label "test"] [width 400] [height 500]))
(define pb1 (new vertical-pasteboard%))
(define ec (new aligned-editor-canvas%
[parent f] [editor pb1] [style '(no-hscroll)]))
(define pb2 (new vertical-pasteboard%))
(define es2 (new aligned-editor-snip% [editor pb2]))
(define t (new text%))
(define es3 (new editor-snip% [editor t]))
(send pb1 insert es2)
(send pb2 insert es3)
(send f show true)

115
collects/mrlib/private/aligned-pasteboard/tests/snip-dumper.rkt
View File

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

27
collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test-min.rkt
View File

@ -1,24 +1,19 @@
(require #lang racket/gui
"../aligned-pasteboard.rkt"
"../aligned-editor-container.rkt"
"../stretchable-editor-snip.rkt"
"../snip-lib.rkt")
(define f (new frame% (label "") (width 500) (height 500))) (require "../aligned-pasteboard.rkt" "../aligned-editor-container.rkt"
"../stretchable-editor-snip.rkt" "../snip-lib.rkt")
(define f (new frame% [label ""] [width 500] [height 500]))
(define e (new vertical-pasteboard%)) (define e (new vertical-pasteboard%))
(define c (new aligned-editor-canvas% (parent f) (editor e))) (define c (new aligned-editor-canvas% [parent f] [editor e]))
(define pb (new vertical-pasteboard%)) (define pb (new vertical-pasteboard%))
(define aes (new aligned-editor-snip% (define aes (new aligned-editor-snip%
(editor pb) [editor pb] [stretchable-width #f] [stretchable-height #f]))
(stretchable-width #f) (define t2 (new text%))
(stretchable-height #f)))
(define t2 (new text%))
(define ses (new stretchable-editor-snip% (define ses (new stretchable-editor-snip%
(editor t2) [editor t2] [min-width 100]
(min-width 100) [stretchable-width #t] [stretchable-height #f]))
(stretchable-width #t)
(stretchable-height #f)))
(send e insert aes) (send e insert aes)
(send pb insert ses) (send pb insert ses)

29
collects/mrlib/private/aligned-pasteboard/tests/stretchable-editor-snip-test.rkt
View File

@ -1,25 +1,20 @@
(require #lang racket/gui
"../aligned-pasteboard.rkt"
"../aligned-editor-container.rkt"
"../stretchable-editor-snip.rkt"
"../snip-lib.rkt")
(define f (new frame% (label "") (width 500) (height 500))) (require "../aligned-pasteboard.rkt" "../aligned-editor-container.rkt"
"../stretchable-editor-snip.rkt" "../snip-lib.rkt")
(define f (new frame% [label ""] [width 500] [height 500]))
(define e (new vertical-pasteboard%)) (define e (new vertical-pasteboard%))
(define c (new aligned-editor-canvas% (parent f) (editor e))) (define c (new aligned-editor-canvas% [parent f] [editor e]))
(define pb (new vertical-pasteboard%)) (define pb (new vertical-pasteboard%))
(define aes (new aligned-editor-snip% (define aes (new aligned-editor-snip%
(editor pb) [editor pb] [stretchable-width #f] [stretchable-height #f]))
(stretchable-width #f) (define t1 (new text%))
(stretchable-height #f))) (define es (new editor-snip% [editor t1]))
(define t1 (new text%)) (define t2 (new text%))
(define es (new editor-snip% (editor t1)))
(define t2 (new text%))
(define ses (new stretchable-editor-snip% (define ses (new stretchable-editor-snip%
(editor t2) [editor t2] [stretchable-width #t] [stretchable-height #f]))
(stretchable-width #t)
(stretchable-height #f)))
(send t1 insert "String") (send t1 insert "String")
(send e insert aes) (send e insert aes)

159
collects/mrlib/private/aligned-pasteboard/tests/test-alignment.rkt Normal file
View File

@ -0,0 +1,159 @@
#lang racket/gui
(require mzlib/etc mzlib/list mzlib/match)
(require "../alignment.rkt" "test-macro.rkt")
;;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 pasteboard
(test los-equal? (align 'horizontal 100 100 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)) '())
(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))))

245
collects/mrlib/private/aligned-pasteboard/tests/test-alignment.rktl
View File

@ -1,245 +0,0 @@
(require mzlib/etc mzlib/list mzlib/match "../alignment.rkt" "test-macro.rkt")
;;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))))

28
collects/mrlib/private/aligned-pasteboard/tests/test-locked-pasteboard.rkt
View File

@ -1,19 +1,21 @@
(require #lang racket/gui
"../locked-pasteboard.rkt"
mrlib/click-forwarding-editor)
(define f (new frame% (width 400) (height 500) (label "test"))) (require "../locked-pasteboard.rkt" mrlib/click-forwarding-editor)
(define e (new (click-forwarding-editor-mixin (locked-pasteboard-mixin pasteboard%))))
(define c (new editor-canvas% (parent f) (editor e))) (define f (new frame% [width 400] [height 500] [label "test"]))
(define e (new (click-forwarding-editor-mixin
(locked-pasteboard-mixin pasteboard%))))
(define c (new editor-canvas% [parent f] [editor e]))
(define t (new text%)) (define t (new text%))
(define s (new editor-snip% (editor t))) (define s (new editor-snip% [editor t]))
(send e insert s 0 100) (send e insert s 0 100)
(define t2 (new text%)) (define t2 (new text%))
(define s2 (new editor-snip% (editor t2))) (define s2 (new editor-snip% [editor t2]))
(send e insert s2 100 0) (send e insert s2 100 0)
(send f show #t) (send f show #t)
;; This test is not automated. To test it try to use the pasteboard that appears. ;; This test is not automated. To test it try to use the pasteboard that
;(test:mouse-click 'left 0 100) ;; appears.
;(test:keystroke #\A) ;; (test:mouse-click 'left 0 100)
;(string=? (send s get-text) "A") ;; (test:keystroke #\A)
;(send f show #f) ;; (string=? (send s get-text) "A")
;; (send f show #f)

29
collects/mrlib/private/aligned-pasteboard/tests/test-macro.rkt
View File

@ -1,17 +1,12 @@
(module test-macro mzscheme #lang racket/base
(require mzlib/etc)
(provide test) (provide test)
;; test: (lambda (a?) ((a? a? . -> . boolean?) a? a? . -> . (void)) ;; 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 ;; tests to see if the expression is true and prints and error if it's not
(define-syntax test (define-syntax test
(syntax-rules (identity) (syntax-rules (identity)
((_ test actual expected) [(_ = actual expected)
(let ([result (let ([result (with-handlers ([exn? (λ (x) x)]) actual)])
(with-handlers (unless (and (not (exn? result)) (= result expected))
([exn? identity]) (eprintf "test failed: ~s != ~s\n" result expected)))]))
actual)])
(unless (and (not (exn? result))
(test result expected))
(eprintf "test failed: ~s != ~s\n" result expected))))))
)

113
collects/mrlib/private/aligned-pasteboard/tests/test-pasteboard-lib.rkt Normal file
View File

@ -0,0 +1,113 @@
#lang racket/gui
(require "test-macro.rkt" "../pasteboard-lib.rkt"
"../aligned-pasteboard.rkt" "../aligned-editor-container.rkt")
;; (printf "running tests for pasteboard-lib.rkt\n")
;; pasteboard-root:
;; ((is-a?/c aligned-pasteboard<%>) -> (is-a?/c aligned-pasteboard<%>))
;; gets the top most aligned pasteboard in the tree of pasteboards and
;; containers
(let* ([pb1 (new vertical-pasteboard%)]
[pb2 (new horizontal-pasteboard%)]
[pb3 (new vertical-pasteboard%)]
[es2 (new aligned-editor-snip% [editor pb2])]
[es3 (new aligned-editor-snip% [editor pb3])]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new aligned-editor-canvas% [parent frame] [editor pb1])])
(send pb1 insert es2)
(send pb2 insert es3)
;;
(test equal? (pasteboard-root pb3) pb1)
(test equal? (pasteboard-root pb2) pb1)
(test equal? (pasteboard-root pb1) pb1))
(let* ([pb1 (new vertical-pasteboard%)]
[pb2 (new horizontal-pasteboard%)]
[pb3 (new vertical-pasteboard%)]
[es1 (new aligned-editor-snip% [editor pb1])]
[es3 (new aligned-editor-snip% [editor pb3])]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new aligned-editor-canvas% [parent frame] [editor pb2])])
(send pb2 insert es1)
(send pb2 insert es3)
;;
(test equal? (pasteboard-root pb3) pb2)
(test equal? (pasteboard-root pb2) pb2)
(test equal? (pasteboard-root pb1) pb2))
;;pasteboard-parent: ((is-a?/c pasteboard%) . -> . (is-a?/c aligned-editor-container<%>))
;;gets the canvas or snip that the pasteboard is displayed in
(let* ([pb1 (new vertical-pasteboard%)]
[pb2 (new horizontal-pasteboard%)]
[pb3 (new vertical-pasteboard%)]
[es2 (new aligned-editor-snip% [editor pb2])]
[es3 (new aligned-editor-snip% [editor pb3])]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new aligned-editor-canvas% [parent frame] [editor pb1])])
(send pb1 insert es2)
(send pb2 insert es3)
;;
(test equal? (pasteboard-parent pb1) canvas)
(test equal? (pasteboard-parent pb2) es2)
(test equal? (pasteboard-parent pb3) es3))
(let* ([pb1 (new vertical-pasteboard%)]
[pb2 (new horizontal-pasteboard%)]
[pb3 (new vertical-pasteboard%)]
[es2 (new aligned-editor-snip% [editor pb2])]
[es3 (new aligned-editor-snip% [editor pb3])]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new aligned-editor-canvas% [parent frame] [editor pb1])])
(send pb1 insert es2)
(send pb1 insert es3)
;;
(test equal? (pasteboard-parent pb1) canvas)
(test equal? (pasteboard-parent pb2) es2)
(test equal? (pasteboard-parent pb3) es3))
#|
;; num-sizeable: ((is-a?/c aligned-pasteboard<%>) . -> . number?)
;; the number of snips in the pasteboard that can be resized
(let* ([pb1 (new vertical-pasteboard% ())]
[es1 (new editor-snip% [editor (new text%)])]
[es2 (new editor-snip% [editor (new text%)])]
[es3 (new editor-snip% [editor (new text%)])]
[es4 (new editor-snip% [editor (new text%)])]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new aligned-editor-canvas% [parent frame] [editor pb1])])
(send frame show #t)
(send pb1 insert es1)
(send pb1 insert es2)
(send pb1 insert es3)
(send pb1 insert es4)
;;
(test = (num-sizeable pb1) 0)
(send pb1 delete es1)
(test = (num-sizeable pb1) 0)
(send frame show #f))
(let* ([pb1 (new vertical-pasteboard%)]
[es1 (new aligned-editor-snip% [editor (new vertical-pasteboard%)])]
[es2 (new aligned-editor-snip% [editor (new vertical-pasteboard%)])]
[es3 (new aligned-editor-snip% [editor (new vertical-pasteboard%)])]
[es4 (new aligned-editor-snip% [editor (new vertical-pasteboard%)])]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new aligned-editor-canvas% [parent frame] [editor pb1])])
(send frame show #t)
(send pb1 insert es1)
(send pb1 insert es2)
(send pb1 insert es3)
(send pb1 insert es4)
;;
(test = (num-sizeable pb1) 4)
(send pb1 delete es1)
(test = (num-sizeable pb1) 3)
(send pb1 erase)
(test = (num-sizeable pb1) 0)
(send frame show #f))
(printf "tests done\n")
|#

202
collects/mrlib/private/aligned-pasteboard/tests/test-pasteboard-lib.rktl
View File

@ -1,202 +0,0 @@
(require mzlib/etc mzlib/class "test-macro.rkt" mred
"../pasteboard-lib.rkt"
"../aligned-pasteboard.rkt"
"../aligned-editor-container.rkt")
;; (printf "running tests for pasteboard-lib.rkt\n")
;;pasteboard-root: ((is-a?/c aligned-pasteboard<%>) -> (is-a?/c aligned-pasteboard<%>))
;;gets the top most aligned pasteboard in the tree of pasteboards and containers
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[pb2 (instantiate horizontal-pasteboard% ())]
[pb3 (instantiate vertical-pasteboard% ())]
[es2 (instantiate aligned-editor-snip% () (editor pb2))]
[es3 (instantiate aligned-editor-snip% () (editor pb3))]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
(send pb1 insert es2)
(send pb2 insert es3)
(test
equal?
(pasteboard-root pb3)
pb1)
(test
equal?
(pasteboard-root pb2)
pb1)
(test
equal?
(pasteboard-root pb1)
pb1)
)
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[pb2 (instantiate horizontal-pasteboard% ())]
[pb3 (instantiate vertical-pasteboard% ())]
[es1 (instantiate aligned-editor-snip% () (editor pb1))]
[es3 (instantiate aligned-editor-snip% () (editor pb3))]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb2))])
(send pb2 insert es1)
(send pb2 insert es3)
(test
equal?
(pasteboard-root pb3)
pb2)
(test
equal?
(pasteboard-root pb2)
pb2)
(test
equal?
(pasteboard-root pb1)
pb2)
)
;;pasteboard-parent: ((is-a?/c pasteboard%) . -> . (is-a?/c aligned-editor-container<%>))
;;gets the canvas or snip that the pasteboard is displayed in
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[pb2 (instantiate horizontal-pasteboard% ())]
[pb3 (instantiate vertical-pasteboard% ())]
[es2 (instantiate aligned-editor-snip% () (editor pb2))]
[es3 (instantiate aligned-editor-snip% () (editor pb3))]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
(send pb1 insert es2)
(send pb2 insert es3)
(test
equal?
(pasteboard-parent pb1)
canvas)
(test
equal?
(pasteboard-parent pb2)
es2)
(test
equal?
(pasteboard-parent pb3)
es3)
)
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[pb2 (instantiate horizontal-pasteboard% ())]
[pb3 (instantiate vertical-pasteboard% ())]
[es2 (instantiate aligned-editor-snip% () (editor pb2))]
[es3 (instantiate aligned-editor-snip% () (editor pb3))]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
(send pb1 insert es2)
(send pb1 insert es3)
(test
equal?
(pasteboard-parent pb1)
canvas)
(test
equal?
(pasteboard-parent pb2)
es2)
(test
equal?
(pasteboard-parent pb3)
es3)
)
#|
;;num-sizeable: ((is-a?/c aligned-pasteboard<%>) . -> . number?)
;;the number of snips in the pasteboard that can be resized
(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)
(test
=
(num-sizeable pb1)
0)
(send pb1 delete es1)
(test
=
(num-sizeable pb1)
0)
(send frame show false)
)
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[es1 (instantiate aligned-editor-snip% () (editor (instantiate vertical-pasteboard% ())))]
[es2 (instantiate aligned-editor-snip% () (editor (instantiate vertical-pasteboard% ())))]
[es3 (instantiate aligned-editor-snip% () (editor (instantiate vertical-pasteboard% ())))]
[es4 (instantiate aligned-editor-snip% () (editor (instantiate vertical-pasteboard% ())))]
[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)
(test
=
(num-sizeable pb1)
4)
(send pb1 delete es1)
(test
=
(num-sizeable pb1)
3)
(send pb1 erase)
(test
=
(num-sizeable pb1)
0)
(send frame show false)
)
(printf "tests done\n")
|#

128
collects/mrlib/private/aligned-pasteboard/tests/test-snip-lib.rkt Normal file
View File

@ -0,0 +1,128 @@
#lang racket/gui
(require "test-macro.rkt" "../snip-lib.rkt"
"../aligned-pasteboard.rkt" "../aligned-editor-container.rkt")
;; (printf "running tests for snip-lib.rkt\n")
;; snip-width: ((is-a?/c aligned-pasteboard<%>) (is-a?/c snip%) . -> . number?)
;; the width of a snip in the given pasteboard
(let* ([pb1 (new vertical-pasteboard%)]
[es1 (new editor-snip% [editor pb1])]
[pb2 (new vertical-pasteboard%)]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new aligned-editor-canvas% [parent frame] [editor pb2])])
(send frame show #t)
(send pb2 insert es1)
(send es1 resize 20 20)
(sleep/yield 0.3)
(test equal? (snip-width #;pb2 es1) 20.0)
(send es1 resize 200 90)
(sleep/yield 0.3)
(test equal? (snip-width #;pb2 es1) 200.0)
(send frame show #f))
;; snip-height:
;; ((is-a?/c aligned-pasteboard<%>) (is-a?/c snip%) . -> . number?)
;; the height of a snip in the given pasteboard
(let* ([pb1 (new vertical-pasteboard%)]
[es1 (new editor-snip% [editor pb1])]
[pb2 (new vertical-pasteboard%)]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new aligned-editor-canvas% [parent frame] [editor pb2])])
(send frame show #t)
(send pb2 insert es1)
(send es1 resize 20 20)
(sleep/yield 0.3)
(test equal? (snip-height #;pb2 es1) 20.0)
(send es1 resize 200 90)
(sleep/yield 0.3)
(test equal? (snip-height #;pb2 es1) 90.0)
(send frame show #f))
;; snip-min-width: ((is-a?/c snip%) . -> . number?)
;; the minimum width of the snip
;; snip-min-height: ((is-a?/c snip%) . -> . number?)
;; the minimum height of the snip
;; snip-parent: ((is-a?/c snip%) . -> . (is-a?/c editor<%>))
;; the pasteboard that contains the snip
(let* ([pb1 (new pasteboard%)]
[es1 (new editor-snip% [editor pb1])]
[pb2 (new pasteboard%)]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new editor-canvas% [parent frame] [editor pb2])])
(send frame show #t)
(send pb2 insert es1)
(test equal? (snip-parent es1) pb2)
(send frame show #f))
(let* ([pb1 (new horizontal-pasteboard%)]
[pb2 (new horizontal-pasteboard%)]
[pb3 (new horizontal-pasteboard%)]
[pb4 (new horizontal-pasteboard%)]
[pb5 (new horizontal-pasteboard%)]
[es2 (new aligned-editor-snip% [editor pb2])]
[es3 (new aligned-editor-snip% [editor pb3])]
[es4 (new aligned-editor-snip% [editor pb4])]
[es5 (new aligned-editor-snip% [editor pb5])]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new aligned-editor-canvas% [parent frame] [editor pb1])])
(send frame show #t)
(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 #f))
;; 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 (new vertical-pasteboard%)]
[es1 (new editor-snip% [editor (new text%)])]
[es2 (new editor-snip% [editor (new text%)])]
[es3 (new editor-snip% [editor (new text%)])]
[es4 (new editor-snip% [editor (new text%)])]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new aligned-editor-canvas% [parent frame] [editor pb1])])
(send frame show #t)
(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 (λ (snip total-height)
(+ (snip-height #;pb1 snip) total-height))
0 es1)
400)
(send frame show #f))
;; for-each-snip:
;; (((is-a?/c snip%) . -> . (void)) (is-a/c? snip%) . -> . (void))
;; applies the function to all the snips
(let* ([pb1 (new vertical-pasteboard%)]
[es1 (new editor-snip% [editor (new text%)])]
[es2 (new editor-snip% [editor (new text%)])]
[es3 (new editor-snip% [editor (new text%)])]
[es4 (new editor-snip% [editor (new text%)])]
[frame (new frame% [label "l"] [width 10] [height 10])]
[canvas (new aligned-editor-canvas% [parent frame] [editor pb1])]
[count 0])
(send frame show #t)
(send pb1 insert es1)
(send pb1 insert es2)
(send pb1 insert es3)
(send pb1 insert es4)
(for-each-snip (λ (snip) (set! count (add1 count))) es1)
(test = count 4)
(send frame show #f))
;; (printf "tests done\n")

203
collects/mrlib/private/aligned-pasteboard/tests/test-snip-lib.rktl
View File

@ -1,203 +0,0 @@
(require mzlib/etc mzlib/class mred "test-macro.rkt"
"../snip-lib.rkt"
"../aligned-pasteboard.rkt"
"../aligned-editor-container.rkt")
;;(printf "running tests for snip-lib.rkt\n")
;;snip-width: ((is-a?/c aligned-pasteboard<%>) (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-width #;pb2 es1)
20.0)
(send es1 resize 200 90)
(sleep/yield 1)
(test
equal?
(snip-width #;pb2 es1)
200.0)
(send frame show false)
)
;;snip-height: ((is-a?/c aligned-pasteboard<%>) (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-height #;pb2 es1)
20.0)
(send es1 resize 200 90)
(sleep/yield 1)
(test
equal?
(snip-height #;pb2 es1)
90.0)
(send frame show false)
)
;;snip-min-width: ((is-a?/c snip%) . -> . number?)
;;the minimum width of the snip
;;snip-min-height: ((is-a?/c snip%) . -> . number?)
;;the minimum height of the snip
;;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-height #;pb1 snip)
total-height))
0
es1)
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)))
es1)
(test
=
count
4)
(send frame show false)
)
;;(printf "tests done\n")

147
collects/mrlib/private/aligned-pasteboard/tests/test.rkt Normal file
View File

@ -0,0 +1,147 @@
#lang racket/gui
(require "../aligned-pasteboard.rkt" "../aligned-editor-container.rkt"
"snip-dumper.rkt")
; ;;
; ;
; ;
; ;;;;; ;; ;; ;;;;;;;;;;;;;; ;;; ; ;;;;; ;;;;
; ; ; ;;;; ; ; ; ; ;; ;; ; ; ; ; ;
; ;;;;;; ;; ;;;; ; ; ; ; ; ; ;;;;;; ;;;;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;
; ;;;; ;; ;; ;;;;;;; ;; ;;; ;;; ;;;;; ;;;; ;;;;
; ;
; ;;;
(printf "running test.rkt\n")
(define frame (new frame% [label "Frame"] [width 400] [height 400]))
(define pasteboard (new horizontal-pasteboard%))
(define canvas (new aligned-editor-canvas% [parent frame] [editor pasteboard]))
(define insider (new vertical-pasteboard%))
(define insider2 (new vertical-pasteboard%))
(define insider3 (new vertical-pasteboard%))
(define insider4 (new vertical-pasteboard%))
(define insider5 (new vertical-pasteboard%))
(define insider6 (new vertical-pasteboard%))
(define insider7 (new vertical-pasteboard%))
(define pb-snip (new aligned-editor-snip% [editor insider]))
(define pb-snip2 (new aligned-editor-snip% [editor insider2]))
(define pb-snip3 (new aligned-editor-snip% [editor insider3]))
(define pb-snip4 (new aligned-editor-snip% [editor insider4]))
(define pb-snip5 (new aligned-editor-snip% [editor insider5]))
(define pb-snip6 (new aligned-editor-snip% [editor insider6]))
(define pb-snip7 (new aligned-editor-snip% [editor insider7]))
(define t-snip (new editor-snip% [editor (new text%)]))
(define i-snip (new image-snip%))
(define i-snip2 (new image-snip%))
(define t-snip2 (new editor-snip% [editor (new text%)]))
(define t-snip3 (new editor-snip% [editor (new text%)]))
(send pasteboard begin-edit-sequence)
(send frame show #t)
(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)
; ; ;
; ; ;
;;;;;;; ;;;;; ;;;; ;;;;; ;;;;
; ; ; ; ; ; ; ; ;
; ; ;;;;;; ;;;; ; ;;;;
; ; ; ; ; ;
; ; ;; ; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ;;;;; ;;;;
;; Eli: Looks like these tests are supposed to return #t, so most are
;; failing (wasn't visible when this was running via "gracket -f")
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 57.0 368.0 0.0 0.0 '())
(make-snip-dump 114.0 368.0 57.0 0.0 '())
(make-snip-dump 171.0 368.0 114.0 0.0 '())
(make-snip-dump 182.0 24.0 171.0 0.0 '())
(make-snip-dump 249.0 368.0 182.0 0.0
(list (make-snip-dump 55.0 178.0 0.0 0.0 '())
(make-snip-dump 55.0 356.0 0.0 178.0 '())))
(make-snip-dump 269.0 20.0 249.0 0.0 #f)
(make-snip-dump 289.0 20.0 269.0 0.0 #f)
(make-snip-dump 300.0 24.0 289.0 0.0 '())
(make-snip-dump 368.0 368.0 300.0 0.0
(list (make-snip-dump 11.0 24.0 0.0 0.0 '())))))
(send frame resize 0 0)
(sleep/yield 0.5)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 10.0 34.0 0.0 0.0 '())
(make-snip-dump 20.0 34.0 10.0 0.0 '())
(make-snip-dump 30.0 34.0 20.0 0.0 '())
(make-snip-dump 41.0 24.0 30.0 0.0 '())
(make-snip-dump 61.0 34.0 41.0 0.0
(list (make-snip-dump 10.0 11.0 0.0 0.0 '())
(make-snip-dump 10.0 22.0 0.0 11.0 '())))
(make-snip-dump 81.0 20.0 61.0 0.0 #f)
(make-snip-dump 101.0 20.0 81.0 0.0 #f)
(make-snip-dump 112.0 24.0 101.0 0.0 '())
(make-snip-dump 133.0 34.0 112.0 0.0
(list (make-snip-dump 11.0 24.0 0.0 0.0 '())))))
(send frame resize 800 600)
(sleep/yield 0.5)
(dump=?
(dump-children pasteboard)
(list (make-snip-dump 137.0 568.0 0.0 0.0 '())
(make-snip-dump 274.0 568.0 137.0 0.0 '())
(make-snip-dump 411.0 568.0 274.0 0.0 '())
(make-snip-dump 422.0 24.0 411.0 0.0 '())
(make-snip-dump 569.0 568.0 422.0 0.0
(list (make-snip-dump 135.0 278.0 0.0 0.0 '())
(make-snip-dump 135.0 556.0 0.0 278.0 '())))
(make-snip-dump 589.0 20.0 569.0 0.0 #f)
(make-snip-dump 609.0 20.0 589.0 0.0 #f)
(make-snip-dump 620.0 24.0 609.0 0.0 '())
(make-snip-dump 768.0 568.0 620.0 0.0
(list (make-snip-dump 11.0 24.0 0.0 0.0 '())))))
(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 '())
(make-snip-dump 130.0 368.0 65.0 0.0 '())
(make-snip-dump 195.0 368.0 130.0 0.0 '())
(make-snip-dump 206.0 24.0 195.0 0.0 '())
(make-snip-dump 281.0 368.0 206.0 0.0
(list (make-snip-dump 63.0 178.0 0.0 0.0 '())
(make-snip-dump 63.0 356.0 0.0 178.0 '())))
(make-snip-dump 292.0 24.0 281.0 0.0 '())
(make-snip-dump 368.0 368.0 292.0 0.0
(list (make-snip-dump 11.0 24.0 0.0 0.0 '())))))
(send pasteboard erase)
(dump=? (dump-children pasteboard) '())
(send frame show #f)
(printf "done\n")

226
collects/mrlib/private/aligned-pasteboard/tests/test.rktl
View File

@ -1,226 +0,0 @@
(require mzlib/class mred mzlib/etc mzlib/list
"../aligned-pasteboard.rkt"
"../aligned-editor-container.rkt"
"snip-dumper.rkt")
; ;;
; ;
; ;
; ;;;;; ;; ;; ;;;;;;;;;;;;;; ;;; ; ;;;;; ;;;;
; ; ; ;;;; ; ; ; ; ;; ;; ; ; ; ; ;
; ;;;;;; ;; ;;;; ; ; ; ; ; ; ;;;;;; ;;;;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;
; ;;;; ;; ;; ;;;;;;; ;; ;;; ;;; ;;;;; ;;;; ;;;;
; ;
; ;;;
(printf "running test.rktl\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")

114
collects/mrlib/private/aligned-pasteboard/tests/test2.rkt Normal file
View File

@ -0,0 +1,114 @@
#lang racket/gui
(require "../aligned-pasteboard.rkt" "../aligned-editor-container.rkt"
"snip-dumper.rkt")
; ;;
; ;
; ;
; ;;;;; ;; ;; ;;;;;;;;;;;;;; ;;; ; ;;;;; ;;;;
; ; ; ;;;; ; ; ; ; ;; ;; ; ; ; ; ;
; ;;;;;; ;; ;;;; ; ; ; ; ; ; ;;;;;; ;;;;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;
; ;;;; ;; ;; ;;;;;;; ;; ;;; ;;; ;;;;; ;;;; ;;;;
; ;
; ;;;
(printf "running test2.rkt\n")
(define frame (new frame% [label "Frame"] [width 400] [height 400]))
(define pasteboard (new horizontal-pasteboard%))
(define canvas (new aligned-editor-canvas% [parent frame] [editor pasteboard]))
(define vp1 (new vertical-pasteboard%))
(define ae-snip1 (new aligned-editor-snip% [editor vp1]))
(define vp2 (new vertical-pasteboard%))
(define ae-snip2 (new aligned-editor-snip% [editor vp2]))
(define vp3 (new vertical-pasteboard%))
(define ae-snip3 (new aligned-editor-snip% [editor vp3]))
(define vp4 (new vertical-pasteboard%))
(define ae-snip4 (new aligned-editor-snip% [editor vp4]))
(define vp5 (new vertical-pasteboard%))
(define ae-snip5 (new 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 #t)
; ; ;
; ; ;
; ;;;;; ;;;;; ;;;; ;;;;; ;;;;
; ; ; ; ; ; ; ; ;
; ; ;;;;;; ;;;; ; ;;;;
; ; ; ; ; ;
; ; ;; ; ; ; ; ; ;
; ;;;;; ;;;; ;;;; ;;;;; ;;;;
;; Eli: Looks like these tests are supposed to return #t, so most are
;; failing (wasn't visible when this was running via "gracket -f")
(sleep/yield 0.5)
(dump=?
(dump-children pasteboard)
(list (make-snip-dump 120.0 368.0 0.0 0.0 '())
(make-snip-dump 249.0 368.0 120.0 0.0
(list (make-snip-dump 117.0 178.0 0.0 0.0 '())
(make-snip-dump 117.0 356.0 0.0 178.0 '())))
(make-snip-dump 368.0 368.0 249.0 0.0 '())))
(send frame resize 0 0)
(sleep/yield 0.5)
(dump=?
(dump-children pasteboard)
(list (make-snip-dump 10.0 30.0 0.0 0.0 '())
(make-snip-dump 30.0 30.0 10.0 0.0
(list (make-snip-dump 10.0 10.0 0.0 0.0 '())
(make-snip-dump 10.0 19.0 0.0 9.0 '())))
(make-snip-dump 40.0 30.0 30.0 0.0 '())))
(send frame resize 800 600)
(sleep/yield 0.5)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 253.0 568.0 0.0 0.0 '())
(make-snip-dump 516.0 568.0 253.0 0.0
(list (make-snip-dump 251.0 278.0 0.0 0.0 '())
(make-snip-dump 251.0 556.0 0.0 278.0 '())))
(make-snip-dump 768.0 568.0 516.0 0.0 '())))
(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 '())
(make-snip-dump 377.0 556.0 0.0 278.0 '())))
(make-snip-dump 768.0 568.0 389.0 0.0 '())))
(send pasteboard insert ae-snip5)
(dump=?
(dump-children pasteboard)
(list
(make-snip-dump 253.0 568.0 0.0 0.0 '())
(make-snip-dump 516.0 568.0 253.0 0.0
(list (make-snip-dump 251.0 278.0 0.0 0.0 '())
(make-snip-dump 251.0 556.0 0.0 278.0 '())))
(make-snip-dump 768.0 568.0 516.0 0.0 '())))
(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 '())
(make-snip-dump 756.0 556.0 0.0 278.0 '())))))
(send pasteboard erase)
(dump=? (dump-children pasteboard) '())
(send frame show #f)
(printf "done\n")

185
collects/mrlib/private/aligned-pasteboard/tests/test2.rktl
View File

@ -1,185 +0,0 @@
(require mzlib/class mred mzlib/etc mzlib/list
"../aligned-pasteboard.rkt"
"../aligned-editor-container.rkt"
"snip-dumper.rkt")
;
;
; ;;
; ;
; ;
; ;;;;; ;; ;; ;;;;;;;;;;;;;; ;;; ; ;;;;; ;;;;
; ; ; ;;;; ; ; ; ; ;; ;; ; ; ; ; ;
; ;;;;;; ;; ;;;; ; ; ; ; ; ; ;;;;;; ;;;;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;
; ;;;; ;; ;; ;;;;;;; ;; ;;; ;;; ;;;;; ;;;; ;;;;
; ;
; ;;;
;
(printf "running test2.rktl\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")

80
collects/tests/aligned-pasteboard/debug.rkt
View File

@ -1,80 +0,0 @@
(module debug mzscheme
(require
mzlib/class)
(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))
))
)

84
collects/tests/aligned-pasteboard/example.rktl
View File

@ -1,84 +0,0 @@
(require mzlib/class mred mzlib/etc
"../aligned-pasteboard.rkt"
"../aligned-editor-container.rkt")
;
;
; ;;
; ;
; ;
; ;;;;; ;; ;; ;;;;;;;;;;;;;; ;;; ; ;;;;; ;;;;
; ; ; ;;;; ; ; ; ; ;; ;; ; ; ; ; ;
; ;;;;;; ;; ;;;; ; ; ; ; ; ; ;;;;;; ;;;;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;
; ;;;; ;; ;; ;;;;;;; ;; ;;; ;;; ;;;;; ;;;; ;;;;
; ;
; ;;;
;
(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)

25
collects/tests/aligned-pasteboard/old-bugs/big-min.rktl
View File

@ -1,25 +0,0 @@
(require
mzlib/class
mred
mzlib/etc
mrlib/aligned-pasteboard)
(define frame (instantiate frame% () (label "big-min") (width 400) (height 500)))
(define test-suite (instantiate vertical-pasteboard% ()))
(instantiate aligned-editor-canvas% () (parent frame) (editor test-suite))
(define top-string false)
(define (new)
(let* ([main-pb (instantiate horizontal-pasteboard% ())]
[pb (instantiate vertical-pasteboard% ())]
[snip (instantiate aligned-editor-snip% () (editor pb))]
[string (make-object string-snip% "Testing String Snip")])
(set! top-string string)
(send main-pb insert snip false)
(send main-pb insert string false)
(instantiate aligned-editor-snip% () (editor main-pb))))
(send frame show true)
(define (add) (send test-suite insert (new)))
(add)

20
collects/tests/aligned-pasteboard/old-bugs/missing-min.rktl
View File

@ -1,20 +0,0 @@
(require
mzlib/class
mzlib/etc
mrlib/aligned-pasteboard
mzlib/class
mred)
(define f (instantiate frame% () (label "test") (width 400) (height 500)))
(define pb1 (instantiate vertical-pasteboard% ()))
(define ec (instantiate aligned-editor-canvas% () (parent f) (editor pb1) (style '(no-hscroll))))
(define pb2 (instantiate vertical-pasteboard% ()))
(define es2 (instantiate aligned-editor-snip% () (editor pb2)))
(define t (instantiate text% ()))
(define es3 (instantiate editor-snip% () (editor t)))
(send pb1 insert es2)
(send pb2 insert es3)
(send f show true)

70
collects/tests/aligned-pasteboard/snip-dumper.rkt
View File

@ -1,70 +0,0 @@
(module snip-dumper mzscheme
(require
mzlib/class
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])))
)

248
collects/tests/aligned-pasteboard/test-alignment.rktl
View File

@ -1,248 +0,0 @@
(require "utils.rkt" mzlib/etc mzlib/list mzlib/match
mrlib/private/aligned-pasteboard/alignment)
;; 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))))
(tests-done)

113
collects/tests/aligned-pasteboard/test-pasteboard-lib.rktl
View File

@ -1,113 +0,0 @@
(require "utils.rkt" mzlib/etc mzlib/class mred
mrlib/private/aligned-pasteboard/pasteboard-lib
mrlib/aligned-pasteboard)
;; pasteboard-root: ((is-a?/c aligned-pasteboard<%>) -> (is-a?/c aligned-pasteboard<%>))
;; gets the top most aligned pasteboard in the tree of pasteboards and containers
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[pb2 (instantiate horizontal-pasteboard% ())]
[pb3 (instantiate vertical-pasteboard% ())]
[es2 (instantiate aligned-editor-snip% () (editor pb2))]
[es3 (instantiate aligned-editor-snip% () (editor pb3))]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
(send pb1 insert es2)
(send pb2 insert es3)
(test equal?
(pasteboard-root pb3)
pb1)
(test equal?
(pasteboard-root pb2)
pb1)
(test equal?
(pasteboard-root pb1)
pb1)
)
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[pb2 (instantiate horizontal-pasteboard% ())]
[pb3 (instantiate vertical-pasteboard% ())]
[es1 (instantiate aligned-editor-snip% () (editor pb1))]
[es3 (instantiate aligned-editor-snip% () (editor pb3))]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb2))])
(send pb2 insert es1)
(send pb2 insert es3)
(test equal?
(pasteboard-root pb3)
pb2)
(test equal?
(pasteboard-root pb2)
pb2)
(test equal?
(pasteboard-root pb1)
pb2)
)
;; pasteboard-parent: ((is-a?/c pasteboard%) . -> . (is-a?/c aligned-editor-container<%>))
;; gets the canvas or snip that the pasteboard is displayed in
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[pb2 (instantiate horizontal-pasteboard% ())]
[pb3 (instantiate vertical-pasteboard% ())]
[es2 (instantiate aligned-editor-snip% () (editor pb2))]
[es3 (instantiate aligned-editor-snip% () (editor pb3))]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
(send pb1 insert es2)
(send pb2 insert es3)
(test equal?
(pasteboard-parent pb1)
canvas)
(test equal?
(pasteboard-parent pb2)
es2)
(test equal?
(pasteboard-parent pb3)
es3)
)
(let*
([pb1 (instantiate vertical-pasteboard% ())]
[pb2 (instantiate horizontal-pasteboard% ())]
[pb3 (instantiate vertical-pasteboard% ())]
[es2 (instantiate aligned-editor-snip% () (editor pb2))]
[es3 (instantiate aligned-editor-snip% () (editor pb3))]
[frame (instantiate frame% () (label "l") (width 10) (height 10))]
[canvas (instantiate aligned-editor-canvas% () (parent frame) (editor pb1))])
(send pb1 insert es2)
(send pb1 insert es3)
(test equal?
(pasteboard-parent pb1)
canvas)
(test equal?
(pasteboard-parent pb2)
es2)
(test equal?
(pasteboard-parent pb3)
es3)
)
(tests-done)

159
collects/tests/aligned-pasteboard/test-snip-lib.rktl
View File

@ -1,159 +0,0 @@
(require "utils.rkt"
mzlib/etc mzlib/class mred
mrlib/private/aligned-pasteboard/snip-lib
mrlib/private/aligned-pasteboard/aligned-pasteboard
mrlib/private/aligned-pasteboard/aligned-editor-container)
(printf "running tests for snip-lib.rkt\n")
;;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 = (snip-min-width es1) 20)
(send es1 resize 200 90)
(sleep/yield 1)
(test = (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 = (snip-min-height es1) 20)
(send es1 resize 200 90)
(sleep/yield 1)
(test = (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)
)
(tests-done)

226
collects/tests/aligned-pasteboard/test.rktl
View File

@ -1,226 +0,0 @@
;;note: turns out these tests are window manager specific
(require mzlib/class mred mzlib/etc mzlib/list mrlib/aligned-pasteboard
"snip-dumper.rkt")
; ;;
; ;
; ;
; ;;;;; ;; ;; ;;;;;;;;;;;;;; ;;; ; ;;;;; ;;;;
; ; ; ;;;; ; ; ; ; ;; ;; ; ; ; ; ;
; ;;;;;; ;; ;;;; ; ; ; ; ; ; ;;;;;; ;;;;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;
; ;;;; ;; ;; ;;;;;;; ;; ;;; ;;; ;;;;; ;;;; ;;;;
; ;
; ;;;
(printf "running test1.rkt\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")

185
collects/tests/aligned-pasteboard/test2.rktl
View File

@ -1,185 +0,0 @@
;;note: turns out these tests are window manager specific
(require mzlib/class mred mzlib/etc mzlib/list mrlib/aligned-pasteboard
"snip-dumper.rkt")
;
;
; ;;
; ;
; ;
; ;;;;; ;; ;; ;;;;;;;;;;;;;; ;;; ; ;;;;; ;;;;
; ; ; ;;;; ; ; ; ; ;; ;; ; ; ; ; ;
; ;;;;;; ;; ;;;; ; ; ; ; ; ; ;;;;;; ;;;;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ;; ; ; ; ; ; ; ; ; ;; ;; ; ;; ; ; ;
; ;;;; ;; ;; ;;;;;;; ;; ;;; ;;; ;;;;; ;;;; ;;;;
; ;
; ;;;
;
(printf "running test2.rkt\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")