contracts.ss -> contract.ss

original commit: 51992dcc33e9214beb02f7ee7396d3ad8a2c2e3b

collects/mrlib/private/aligned-pasteboard/aligned-editor-container.ss

@@ -12,6 +12,7 @@
    (lib "mred.ss" "mred")
    (lib "etc.ss")
    (lib "list.ss")
+   "snip-lib.ss"
    "interface.ss"
    "constants.ss")
   
@@ -80,7 +81,7 @@
   ;; a snip that can contain an aligned-pasteboard<%> and also be stretched within an aligned-pasteboard<%>
   (define aligned-editor-snip%
     (class* editor-snip% (aligned-pasteboard-parent<%> aligned-snip<%>)
-      (inherit get-editor get-margin)
+      (inherit get-editor get-margin set-min-width set-min-height)
       
       (init
        (stretchable-width true)
@@ -150,7 +151,9 @@
       ;; set-aligned-min-size (-> (void))
       ;; calculates and stores the minimum height and width of the snip
       (define/public (set-aligned-min-sizes)
-        (send (get-editor) set-aligned-min-sizes))
+        (send (get-editor) set-aligned-min-sizes)
+        (set-min-width (get-aligned-min-width))
+        (set-min-height (get-aligned-min-height)))
       
       (super-instantiate ())
       ))
@@ -192,7 +195,15 @@
               [right (box 0)]
               [bottom (box 0)])
           (get-margin left top right bottom)
-          (+ (unbox left) (unbox right))))
+          (+ (unbox left)
+             (let* ([ed (get-editor)]
+                    [last (send ed last-line)])
+               (let loop ([line 0])
+                 (if (= line last)
+                     0
+                     (max (send ed line-length line)
+                          (loop (add1 line))))))
+             (unbox right))))
       
       ;; get-aligned-min-height (-> number?)
       ;; the minimum height of the snip based on the children
@@ -207,6 +218,70 @@
              (* (send editor line-location 0 false)
                 (add1 (send editor last-line))))))
       
+;      ; get-aligned-min-width (-> number?)
+;      ; the minimum width of the snip based on the children
+;      (inherit get-max-width set-max-width get-min-width set-min-width)
+;      (define/public (get-aligned-min-width)
+;        (let* ([parent (snip-parent this)]
+;               [ed (get-editor)]
+;               [ed-max (send ed get-max-width)]
+;               [ed-min (send ed get-min-width)]
+;               [this-max (get-max-width)]
+;               [this-min (get-min-width)])
+;          (when (is-a? parent aligned-pasteboard<%>)
+;            (send parent ignore-resizing true))
+;          (send parent begin-edit-sequence)
+;          (send ed begin-edit-sequence)
+;          (send ed set-max-width 'none)
+;          (send ed set-min-width 'none)
+;          (set-max-width 'none)
+;          (set-min-width 'none)
+;          (begin0
+;            (let ([left (box 0)]
+;                  [top (box 0)]
+;                  [right (box 0)]
+;                  [bottom (box 0)])
+;              (get-margin left top right bottom)
+;              (+ (unbox left)
+;                 (snip-width this)))
+;            (send ed set-max-width ed-max)
+;            (send ed set-max-width ed-min)
+;            (set-min-width this-min)
+;            (set-max-width this-max)
+;            (send ed end-edit-sequence)
+;            (send parent end-edit-sequence)
+;            (when (is-a? parent aligned-pasteboard<%>)
+;              (send parent ignore-resizing false)))))
+;      
+;      ; get-aligned-min-height (-> number?)
+;      ; the minimum height of the snip based on the children
+;      (inherit get-max-height set-max-height get-min-height set-min-height)
+;      (define/public (get-aligned-min-height)
+;        (let* ([parent (snip-parent this)]
+;               [ed (get-editor)]
+;               [ed-max (send ed get-max-height)]
+;               [ed-min (send ed get-min-height)]
+;               [this-max (get-max-height)]
+;               [this-min (get-min-height)])
+;          (when (is-a? parent aligned-pasteboard<%>)
+;            (send parent ignore-resizing true))
+;          (send parent begin-edit-sequence)
+;          (send ed begin-edit-sequence)
+;          (send ed set-max-height 'none)
+;          (send ed set-min-height 'none)
+;          (set-max-height 'none)
+;          (set-min-height 'none)
+;          (begin0
+;            (snip-height this)
+;            (send ed set-max-height ed-max)
+;            (send ed set-min-height ed-min)
+;            (set-min-height this-min)
+;            (set-max-height this-max)
+;            (send ed end-edit-sequence)
+;            (send parent end-edit-sequence)
+;            (when (is-a? parent aligned-pasteboard<%>)
+;              (send parent ignore-resizing false)))))
+      
       (super-instantiate ())
       ))
   )

collects/mrlib/private/aligned-pasteboard/aligned-pasteboard.ss

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

collects/mrlib/private/aligned-pasteboard/alignment.ss

@@ -22,7 +22,7 @@
   
   (require
    (lib "match.ss")
-   (lib "contracts.ss")
+   (lib "contract.ss")
    (lib "etc.ss")
    (lib "list.ss"))
   

collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.ss

@@ -2,21 +2,22 @@
   
   (require
    (lib "class.ss")
-   (lib "contracts.ss")
+   (lib "contract.ss")
    (lib "list.ss")
    (lib "etc.ss")
    (lib "match.ss")
-   "interface.ss"
+   (lib "mred.ss" "mred")  "interface.ss"
    "alignment.ss"
-   "snip-lib.ss")
+   "snip-lib.ss"
+   "pasteboard-lib.ss")
   
   (provide/contract
-   (geometry-managed-pasteboard-mixin (class? (symbols 'vertical 'horizontal) . -> . class?)))
+   (make-aligned-pasteboard ((symbols 'vertical 'horizontal) . -> . class?)))
   
   ;;  mixin to add geometry management to pasteboard with the give type of alignement
-  (define (geometry-managed-pasteboard-mixin super% type)
+  (define (make-aligned-pasteboard type)
-    (class* super% (aligned-pasteboard<%>)
+    (class* pasteboard% (aligned-pasteboard<%>)
-      (inherit resize move-to find-first-snip
+      (inherit resize move-to find-first-snip refresh-delayed?
                begin-edit-sequence end-edit-sequence)
       
       (field
@@ -28,6 +29,10 @@
        [aligned-min-height 0]
        [aligned-rects empty])
       
+      ;;temp fix
+      (define/public (ignore-resizing ignore?)
+        (set! ignore-resizing? ignore?))
+      
       ;; get-aligned-min-width (-> number?)
       ;; the aligned-min-width of the pasteboard
       (define/public (get-aligned-min-width)
@@ -81,8 +86,122 @@
                     ($ dim x width stretchable-width?)
                     ($ dim y height stretchable-height?)))
            (move-to snip x y)
-           (when (or stretchable-height? stretchable-width?)
+           (when (or stretchable-height? stretchable-width? (is-a? snip aligned-pasteboard-parent<%>))
-             (resize snip width height))]))
+             (resize snip width height))
+           ;(resize snip width height)
+           ;(when (is-a? snip editor-snip%)
+           ;  (send snip set-min-width 'none)
+           ;  (send (send snip get-editor) set-min-width 'none))
+           ]))
+      
+      (field [in-edit-sequence? false])
+      
+      ;; 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))
+      
+      ;; 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-instantiate ())
       ))

collects/mrlib/private/aligned-pasteboard/interface.ss

@@ -12,6 +12,9 @@
   ;; 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
+      
       ;; get-alignment (-> (values symbol? symbol?))
       ;; get the pasteboards current alignment specification
       ;; status: possible future feature

collects/mrlib/private/aligned-pasteboard/locked-pasteboard.ss

@@ -3,7 +3,7 @@
   (require
    (lib "class.ss")
    (lib "etc.ss")
-   (lib "contracts.ss"))
+   (lib "contract.ss"))
   
   (provide/contract
    (locked-pasteboard-mixin mixin-contract))

collects/mrlib/private/aligned-pasteboard/pasteboard-lib.ss

@@ -3,7 +3,7 @@
   (require
    (lib "class.ss")
    (lib "mred.ss" "mred")
-   (lib "contracts.ss")
+   (lib "contract.ss")
    (lib "etc.ss")
    "interface.ss"
    "snip-lib.ss")

collects/mrlib/private/aligned-pasteboard/snip-lib.ss

@@ -5,7 +5,7 @@
    (lib "etc.ss")
    (lib "mred.ss" "mred")
    (lib "list.ss")
-   (lib "contracts.ss")
+   (lib "contract.ss")
    "interface.ss")
   
   ;; a snip