From 067e8a095124d2f916058b50ae942830549e7f4b Mon Sep 17 00:00:00 2001
From: Mike MacHenry <dskippy@ccs.neu.edu>
Date: Mon, 3 Nov 2003 18:55:15 +0000
Subject: [PATCH] ...

original commit: 411027680626f1cc5e7e5c538e2f422ab5290669
---
 .../geometry-managed-pasteboard.ss            |   4 +-
 .../private/aligned-pasteboard/interface.ss   |   5 +-
 .../aligned-pasteboard/locked-pasteboard.ss   |  36 +-
 .../aligned-pasteboard/tests/more-tests.ss    | 332 ++++++++++++++++++
 .../tests/test-locked-pasteboard.ss           |  20 ++
 5 files changed, 376 insertions(+), 21 deletions(-)
 create mode 100644 collects/mrlib/private/aligned-pasteboard/tests/more-tests.ss
 create mode 100644 collects/mrlib/private/aligned-pasteboard/tests/test-locked-pasteboard.ss

diff --git a/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss b/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss
index f9af9255..4b48a035 100644
--- a/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss
+++ b/collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss
@@ -30,8 +30,8 @@
        [aligned-rects empty])
       
       ;;temp fix
-      (define/public (ignore-resizing ignore?)
-        (set! ignore-resizing? ignore?))
+      ;(define/public (ignore-resizing ignore?)
+      ;  (set! ignore-resizing? ignore?))
       
       ;; get-aligned-min-width (-> number?)
       ;; the aligned-min-width of the pasteboard
diff --git a/collects/mrlib/private/aligned-pasteboard/interface.ss b/collects/mrlib/private/aligned-pasteboard/interface.ss
index 901d4b13..f94f50d6 100644
--- a/collects/mrlib/private/aligned-pasteboard/interface.ss
+++ b/collects/mrlib/private/aligned-pasteboard/interface.ss
@@ -11,10 +11,7 @@
   
   ;; the interface that must be implemented for a pasteboard to be contained in an aligned-pasteboard-parent<%>
   (define aligned-pasteboard<%>
-    (interface (editor<%>)
-      ;; temp fix
-      ignore-resizing
-      
+    (interface (editor<%>)      
       ;; get-alignment (-> (values symbol? symbol?))
       ;; get the pasteboards current alignment specification
       ;; status: possible future feature
diff --git a/collects/mrlib/private/aligned-pasteboard/locked-pasteboard.ss b/collects/mrlib/private/aligned-pasteboard/locked-pasteboard.ss
index 53fe4c84..1a4d060b 100644
--- a/collects/mrlib/private/aligned-pasteboard/locked-pasteboard.ss
+++ b/collects/mrlib/private/aligned-pasteboard/locked-pasteboard.ss
@@ -1,25 +1,31 @@
+;; This module provides a mixin that locks a pasteboard to all mouse interaction. This
+;; means that there is no interactive dragging, no keyboard deletion, no handles drawn
+;; at the corners of the snips for dragging, and anything else that must be added.
+
 (module locked-pasteboard mzscheme
   
   (require
    (lib "class.ss")
+   (lib "mred.ss" "mred")
    (lib "etc.ss")
-   (lib "contract.ss"))
+   (lib "contract.ss")
+   (lib "framework.ss" "framework"))
   
   (provide/contract
    (locked-pasteboard-mixin mixin-contract))
   
   ;; mixin to remove interactive movement of snips from pasteboards
-  (define (locked-pasteboard-mixin super%)
-    (class super%
-      ;; can-interactive-move? (event? . -> . void?)
-      ;; whether the pasteboard allows interactive moving
-      (define/override (can-interactive-move? event)
-        false)
-      
-      ;; can-interactive-resize? ((is-a?/c snip%) . -> . void?)
-      ;; whether the pasteboard allows interactive resizing
-      (define/override (can-interactive-resize? snip)
-        false)
-      (super-instantiate ())
-      ))
-  )
+  ;; STATUS: Look into and make sure I don't need to deal with the following.
+  ;;           interactive-adjust-mouse, interactive-adjust-move, on-default-event
+  ;;           interactive-adjust-resize
+  (define locked-pasteboard-mixin
+    (mixin ((class->interface pasteboard%)) ()
+      (define/override (on-default-event event) (void))
+      ;; The rest of the methods I believe to be redundant but
+      ;; are overriden anyway for consistancy.
+      (define/override (can-interactive-move? event) false)
+      (define/override (can-interactive-resize? snip) false)
+      (define/override (get-dragable) false)
+      (define/override (get-selection-visible) false)
+      (super-new)))
+  )
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/more-tests.ss b/collects/mrlib/private/aligned-pasteboard/tests/more-tests.ss
new file mode 100644
index 00000000..770ecdbe
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/more-tests.ss
@@ -0,0 +1,332 @@
+;; some more advanced aligned-pasteboard tests take from the test-case-boxes
+
+(require
+ (lib "class.ss")
+ (lib "mred.ss" "mred")
+ (lib "etc.ss")
+ (lib "list.ss")
+ (lib "match.ss")
+ "../aligned-editor-container.ss"
+ "../interface.ss"
+ "../alignment.ss"
+ "../snip-lib.ss"
+ "../pasteboard-lib.ss")
+
+(define (make-aligned-pasteboard type)
+  (class* pasteboard% (aligned-pasteboard<%>)
+    (inherit resize move-to find-first-snip refresh-delayed?
+             begin-edit-sequence end-edit-sequence)
+    
+    (field
+     [needs-realign? false]
+     [ignore-resizing? false]
+     [alloted-width 0]
+     [alloted-height 0]
+     [aligned-min-width 0]
+     [aligned-min-height 0]
+     [aligned-rects empty]
+     [in-edit-sequence? false])
+    
+    ;;;;;;;;;;
+    ;; accessors
+    
+    ;; get-aligned-min-width (-> number?)
+    ;; the aligned-min-width of the pasteboard
+    (define/public (get-aligned-min-width) aligned-min-width)
+    
+    ;; get-aligned-min-height (-> number?)
+    ;; the aligned-min-height of the pasteboard
+    (define/public (get-aligned-min-height) aligned-min-height)
+    
+    ;;;;;;;;;;
+    ;; size calculations
+    
+    ;; set-algined-min-sizes (-> void?)
+    ;; set the aligned min width and height of the pasteboard based on it's children snips
+    (define/public (set-aligned-min-sizes)
+      (set! ignore-resizing? true)
+      (set!-values (aligned-min-width aligned-min-height)
+                   (get-aligned-min-sizes type (find-first-snip)))
+      (set! ignore-resizing? false))
+    
+    ;;;;;;;;;;
+    ;; realignment
+    
+    ;; realign (case-> (-> void?) (positive? positive? . -> . void?))
+    ;; called by the parent to realign the pasteboard's children
+    (define/public realign
+      (case-lambda
+        [(width height)
+         (set! alloted-width width)
+         (set! alloted-height height)
+         (realign)]
+        [()
+         (when (and (positive? alloted-width)
+                    (positive? alloted-height))
+           (set! needs-realign? false)
+           (realign-to-alloted))]))
+    
+    ;; realign-to-alloted (-> void?)
+    ;; realign the snips to fill the alloted width and height
+    (define/private (realign-to-alloted)
+      (let ([first-snip (find-first-snip)])
+        (set! aligned-rects
+              (align type alloted-width alloted-height
+                     (map-snip build-rect first-snip)))
+        (begin-edit-sequence)
+        (set! ignore-resizing? true)
+        (for-each-snip move/resize first-snip aligned-rects)
+        (set! ignore-resizing? false)
+        (end-edit-sequence)))
+    
+    ;;move/resize (snip-pos? rect? . -> . void?)
+    ;;moves and resizes the snips with in pasteboard
+    (define move/resize
+      (match-lambda*
+        [(snip ($ rect
+                  ($ dim x width stretchable-width?)
+                  ($ dim y height stretchable-height?)))
+         (move-to snip x y)
+         ;; let's try this way to do it.
+         (when (and (is-a? snip stretchable-snip<%>)
+                    (or stretchable-width? stretchable-height?))
+           (send snip stretch-to width height))
+         ;; one way to do it?
+         ;(when (or stretchable-height? stretchable-width? (is-a? snip aligned-pasteboard-parent<%>))
+         ;  (resize snip width height))
+         ;; another way to do it?
+         ;(resize snip width height)
+         ;(when (is-a? snip editor-snip%)
+         ;  (send snip set-min-width 'none)
+         ;  (send (send snip get-editor) set-min-width 'none))
+         ]))
+    
+    ;;;;;;;;;;
+    ;; event-handling
+    
+    ;; after-insert ((is-a?/c snip%) (is-a?/c snip%) number? number? . -> . void?)
+    ;; called after a snip is inserted to the pasteboard
+    (rename [super-after-insert after-insert])
+    (define/override (after-insert snip before x y)
+      (calc/realign)
+      (super-after-insert snip before x y))
+    
+    ;; after-delete ((is-a?/c snip%) . -> . void?)
+    ;; called after a snip is deleted from the pasteboard%
+    (rename [super-after-delete after-delete])
+    (define/override (after-delete snip)
+      (calc/realign)
+      (super-after-delete snip))
+    
+    ;; do I need to override release-snip or does after-delete handle this for me?
+    ;(rename [super-release-snip release-snip])
+    ;(define/override (release-snip snip)
+    ;  (super-release-snip snip))
+    
+    ;; after-reorder ((is-a?/c snip%) (is-a?/c snip%) boolean? . -> . void?)
+    ;; called after a snip is moved in the front to back snip order
+    (rename [super-after-reorder after-reorder])
+    (define/override (after-reorder snip to-snip before?)
+      (realign)
+      (super-after-reorder snip to-snip before?))
+    
+    ;; resized ((is-a?/c snip%) . -> . void?)
+    ;; called when a snip inside the editor is resized
+    (rename [super-resized resized])
+    (define/override (resized snip redraw-now?)
+      (super-resized snip redraw-now?)
+      (unless ignore-resizing?
+        (when (or redraw-now?
+                  (and (not (refresh-delayed?))
+                       (needs-resize? snip)))
+          (calc/realign))))
+    
+    ;; after-edit-sequence (-> void?)
+    ;; called after an edit-sequence ends
+    (rename [super-after-edit-sequence after-edit-sequence])
+    (define/override (after-edit-sequence)
+      (set! in-edit-sequence? false)
+      (when needs-realign? (calc/realign)))
+    
+    (rename [super-on-edit-sequence on-edit-sequence])
+    (define/override (on-edit-sequence)
+      (set! in-edit-sequence? true)
+      (super-on-edit-sequence))
+    
+    ;; calc/realign (-> void?)
+    ;; sends a message to the pasteboard to recalculate min sizes and realign
+    (define/private (calc/realign)
+      (if in-edit-sequence?
+          (set! needs-realign? true)
+          (let* ([root (pasteboard-root this)]
+                 [parent (pasteboard-parent root)])
+            (when parent
+              (send parent set-aligned-min-sizes)
+              (send root realign)))))
+    
+    ;; needs-resize? ((is-a?/c snip%) . -> . boolean?)
+    ;; determines if the snip's size is smaller than it's min size
+    (define/private (needs-resize? snip)
+      (with-handlers ([exn? (lambda a false)])
+        (match-let ([($ rect
+                        ($ dim _ alloted-width _)
+                        ($ dim _ alloted-height _))
+                     (find-rect snip)])
+          (if (is-a? snip aligned-snip<%>)
+              (or (< alloted-width (send snip get-aligned-min-width))
+                  (< alloted-height (send snip get-aligned-min-height)))
+              (if (empty? aligned-rects)
+                  false
+                  
+                  (match-let ([($ rect
+                                  ($ dim _ actual-width _)
+                                  ($ dim _ actual-height _))
+                               (build-rect snip)])
+                    (not (and (= alloted-width actual-width)
+                              (= alloted-height actual-height)))))))))
+    
+    ;(define/private (needs-resize? snip)
+    ;  (cond
+    ;    [(is-a? snip aligned-snip<%>)
+    ;     (or (< (snip-width snip)
+    ;            (send snip get-aligned-min-width))
+    ;         (< (snip-height snip)
+    ;            (send snip get-aligned-min-height))
+    ;         (and (not (send snip stretchable-width))
+    ;              (> (snip-width snip)
+    ;                 (send snip get-aligned-min-width)))
+    ;         (and (not (send snip stretchable-height))
+    ;              (> (snip-height snip)
+    ;                 (send snip get-aligned-min-height))))]
+    ;    [else false]))
+    
+    ;; find-rect ((is-a?/c snip%) . -> . rect?)
+    ;; finds the rect that corresponds to the given snip
+    (define/private (find-rect target-snip)
+      (letrec ([find-rect-aux
+                (lambda (snip rects)
+                  (cond
+                    [(or (equal? snip false) (empty? rects))
+                     (error 'find-rect "Snip not found")]
+                    [else
+                     (if (equal? snip target-snip)
+                         (car rects)
+                         (find-rect-aux (send snip next)
+                                        (rest rects)))]))])
+        (find-rect-aux (find-first-snip) aligned-rects)))
+    
+    (super-new)))
+
+;; build-rect ((is-a?/c snip%) . -> . rect?)
+;; makes a new default rect out of a snip
+(define (build-rect snip)
+  (make-rect
+   (make-dim 0 (snip-min-width snip) (stretchable-width? snip))
+   (make-dim 0 (snip-min-height snip) (stretchable-height? snip))))
+
+;; get-aligned-min-sizes (((symbols 'horizontal vertical) (is-a?/c snip%)) . ->* . (number? number?))
+;; calculate the aligned min sizes for the pasteboard containing the given snips
+(define (get-aligned-min-sizes type init-snip)
+  (let-values ([(x-func y-func)
+                (if (symbol=? type 'horizontal)
+                    (values + max)
+                    (values max +))])
+    (let loop ([snip init-snip]
+               [width 0]
+               [height 0])
+      (cond
+        [(boolean? snip)
+         (values width height)]
+        [else
+         (when (is-a? snip aligned-pasteboard-parent<%>)
+           (send snip set-aligned-min-sizes))
+         (loop (send snip next)
+               (x-func (snip-min-width snip) width)
+               (y-func (snip-min-height snip) height))]))))
+
+(define vertical-pasteboard% (make-aligned-pasteboard 'vertical))
+(define horizontal-pasteboard% (make-aligned-pasteboard 'horizontal))
+
+;; a text-case snip
+(define test-case-box%
+  (class aligned-editor-snip%
+    
+    ;; these edit-sequences are looping
+    (define/public (hide-entries)
+      (send* editor
+        ;(begin-edit-sequence)
+        (release-snip call-line)
+        (release-snip exp-line)
+        (release-snip act-line)
+        ;(end-edit-sequence)
+        ))
+    
+    ;; these edit-sequences are looping
+    (define/public (show-entries)
+      (send* editor
+        ;(begin-edit-sequence)
+        (insert call-line false)
+        (insert exp-line false)
+        (insert act-line false)
+        ;(end-edit-sequence)
+        ))
+    
+    (field
+     [editor (new vertical-pasteboard%)]
+     [turn-button (new image-snip%)]
+     [comment (new text%)]
+     [result (new image-snip%)]
+     [call (new text%)]
+     [expected (new text%)]
+     [actual (new text%)]
+     [top-line (make-top-line turn-button comment result)]
+     [call-line (make-line "Call" call)]
+     [exp-line (make-line "Expected" expected)]
+     [act-line (make-line "Actual" actual)])
+    
+    (send editor insert top-line)
+    (show-entries)
+    
+    (super-new
+     (editor editor)
+     (stretchable-height false)
+     (stretchable-width false))))
+
+;; the top line of the test-case
+(define (make-top-line turn-snip comment result-snip)
+  (let ([pb (new horizontal-pasteboard%)])
+    (send* pb
+      (insert turn-snip false)
+      (insert (text-field comment) false)
+      (insert result-snip false))
+    (new aligned-editor-snip%
+         (stretchable-height false)
+         (editor pb))))
+
+;; a line labeled with the given string and containing a given text
+(define (make-line str text)
+  (let ([pb (new horizontal-pasteboard%)])
+    (send* pb
+      (insert (make-object string-snip% str) false)
+      (insert (text-field text) false))
+    (new aligned-editor-snip% (editor pb))))
+
+;; a text field fit to be in a test-case (no borders or margins etc.)
+;;STATUS: this should really return an aligned-snip<%> not an editor-snip% of fixed size.
+(define (text-field text)
+  (new editor-snip% (editor text)))
+
+(define top
+  (case 3
+    [(1) (cons vertical-pasteboard% aligned-editor-canvas%)]
+    [(2) (cons text% editor-canvas%)]
+    [(3) (cons pasteboard% editor-canvas%)]))
+
+(define f (new frame% (label "test") (width 200) (height 200)))
+(define e (new (car top)))
+(define c (new (cdr top) (editor e) (parent f)))
+(define t (new test-case-box%))
+(send e insert t)
+(send f show #t)
+;(send t hide-entries)
+;(send t show-entries)
\ No newline at end of file
diff --git a/collects/mrlib/private/aligned-pasteboard/tests/test-locked-pasteboard.ss b/collects/mrlib/private/aligned-pasteboard/tests/test-locked-pasteboard.ss
new file mode 100644
index 00000000..ae70b53f
--- /dev/null
+++ b/collects/mrlib/private/aligned-pasteboard/tests/test-locked-pasteboard.ss
@@ -0,0 +1,20 @@
+(require
+ "../locked-pasteboard.ss"
+ (lib "framework.ss" "framework")
+ (lib "click-forwarding-editor.ss" "mrlib"))
+
+(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 s (new editor-snip% (editor t)))
+(send e insert s 0 100)
+(define t2 (new text%))
+(define s2 (new editor-snip% (editor t2)))
+(send e insert s2 100 0)
+(send f show #t)
+;; This test is not automated. To test it try to use the pasteboard that appears.
+;(test:mouse-click 'left 0 100)
+;(test:keystroke #\A)
+;(string=? (send s get-text) "A")
+;(send f show #f)
\ No newline at end of file