fixed up panel:dragable so that it actually does the right thing now

adjusted the framework test suite so that it runs under windows
closes PR 10880

original commit: 900d74714e1b24b2bfbdcf13099a6d7dc5661dd5

collects/framework/main.rkt

@@ -1436,6 +1436,41 @@
     is now the first keymap after @scheme[keymap:get-user] (if that keymap is
     in the list.)})
 
+ (proc-doc/names
+  panel:dragable-container-size
+  (-> (listof (list/c real? real? boolean? boolean?)) real? boolean?
+      (values real? real?))
+  (container-info bar-thickness vertical?)
+  @{Returns the minimum width and height for a @racket[panel:dragable<%>] object
+    where @racket[container-info] (see @method[area-container<%> container-size] for
+    more details on that argument) is the children's info, and @racket[bar-thickness] and
+    @racket[vertical?] indicate the properties of the panel.
+    
+    This function is exported mostly for the test suite.})
+
+ (proc-doc/names
+  panel:dragable-place-children
+  (-> (listof (list/c real? real? boolean? boolean?)) 
+      real?
+      real?
+      (listof (between/c 0 1)) 
+      real?
+      boolean?
+      (values (listof (list/c (integer-in 0 10000)
+                              (integer-in 0 10000)
+                              (integer-in 0 10000)
+                              (integer-in 0 10000)))
+              (listof (list/c (integer-in 0 10000)
+                              (integer-in 0 10000)))))
+  (container-info width height percentages bar-thickness vertical?)
+  @{Returns the geometry information for a dragable panel. The inputs
+    are the @racket[container-info] (see @method[area-container<%> place-children] for more info),
+    the @racket[width] and @racket[height] of the window, the @racket[percentages] for the spacing
+    of the children, and a real and a boolean indicating the thickness of the bar between
+    the child panels and whether or not this is a vertical panel, respectively.
+    
+    This function is exported mostly for the test suite.})
+ 
  (proc-doc/names
   color-model:rgb->xyz
   (number? number? number? . -> . color-model:xyz?)

collects/framework/private/panel.rkt

@@ -305,91 +305,165 @@
       (define cursor-gaps null)
       
       (define/override (place-children _infos width height)
-        (set! cursor-gaps null)
         (update-percentages)
-        (cond
+        (define-values (results gaps) 
-          [(null? _infos) null]
+          (dragable-place-children _infos width height
-          [(null? (cdr _infos)) (list (list 0 0 width height))]
+                                   (map percentage-% percentages)
-          [else
+                                   bar-thickness
-           (let ([available-extent (get-available-extent)]
+                                   (get-vertical?)))        
-                 [show-error
+        (set! cursor-gaps
-                  (λ (n)
+              (let loop ([children (get-children)]
-                    (error 'panel.ss::dragable-panel "internal error.~a" n))])
+                         [percentages percentages]
-             (let loop ([percentages percentages]
+                         [gaps gaps])
-                        [children (get-children)]
+                (cond
-                        [infos _infos]
+                  [(null? children) '()]
-                        [dim 0])
+                  [(null? (cdr children)) '()]
-               (cond
+                  [else
-                 [(null? percentages)
+                   (define gap (car gaps))
-                  (unless (null? infos) (show-error 1))
+                   (cons (make-gap (car children)
-                  (unless (null? children) (show-error 2))
+                                   (list-ref gap 0)
-                  null]
+                                   (car percentages)
-                 [(null? (cdr percentages))
+                                   (cadr children)
-                  (when (null? infos) (show-error 3))
+                                   (list-ref gap 1)
-                  (when (null? children) (show-error 4))
+                                   (cadr percentages))
-                  (unless (null? (cdr infos)) (show-error 5))
+                         (loop (cdr children)
-                  (unless (null? (cdr children)) (show-error 6))
+                               (cdr percentages)
-                  (if (get-vertical?)
+                               (cdr gaps)))])))
-                      (list (list 0 dim width (- height dim)))
+        
-                      (list (list dim 0 (- width dim) height)))]
+        results)
-                 [else
-                  (when (null? infos) (show-error 7))
-                  (when (null? children) (show-error 8))
-                  (when (null? (cdr infos)) (show-error 9))
-                  (when (null? (cdr children)) (show-error 10))
-                  (let* ([info (car infos)]
-                         [percentage (car percentages)]
-                         [this-space (floor (* (percentage-% percentage) available-extent))])
-                    (set! cursor-gaps (cons (make-gap (car children)
-                                                      (+ dim this-space)
-                                                      percentage
-                                                      (cadr children)
-                                                      (+ dim this-space bar-thickness)
-                                                      (cadr percentages))
-                                            cursor-gaps))
-                    (cons (if (get-vertical?)
-                              (list 0 dim width this-space)
-                              (list dim 0 this-space height))
-                          (loop (cdr percentages)
-                                (cdr children)
-                                (cdr infos)
-                                (+ dim this-space bar-thickness))))])))]))
       
       (define/override (container-size children-info)
         (update-percentages)
-        (let loop ([percentages percentages]
+        (dragable-container-size children-info bar-thickness (get-vertical?)))
-                   [children-info children-info]
-                   [major-size 0]
-                   [minor-size 0])
-          (cond
-            [(null? children-info)
-             (if (get-vertical?)
-                 (values (ceiling minor-size) (ceiling major-size))
-                 (values (ceiling major-size) (ceiling minor-size)))]
-            [(null? percentages)
-             (error 'panel.ss::dragable-panel "internal error.12")]
-            [else
-             (let ([child-info (car children-info)]
-                   [percentage (car percentages)])
-               (let-values ([(child-major major-stretch? child-minor minor-stretch?)
-                             (if (get-vertical?)
-                                 (values (list-ref child-info 1)
-                                         (list-ref child-info 3)
-                                         (list-ref child-info 0)
-                                         (list-ref child-info 2))
-                                 (values (list-ref child-info 0)
-                                         (list-ref child-info 2)
-                                         (list-ref child-info 1)
-                                         (list-ref child-info 3)))])
-                 (loop (cdr percentages)
-                       (cdr children-info)
-                       (max (if (zero? (percentage-% percentage))
-                                0
-                                (/ child-major (percentage-% percentage)))
-                            major-size)
-                       (max child-minor minor-size))))])))
       
       (super-instantiate (parent))))
+
+  ;; this function repeatedly checks to see if the current set of percentages and children
+  ;; would violate any minimum size constraints. If not, the percentages are used and the
+  ;; function termiantes. If some minimum sizes would be violated, the function pulls those 
+  ;; children out of the list under consideration, gives them their minimum sizes, rescales
+  ;; the remaining percentages back to 1, adjusts the available space after removing those
+  ;; panels, and tries again.
+  (define (dragable-place-children infos width height percentages bar-thickness vertical?)
+    (define original-major-dim-tot (- (if vertical? height width)
+                                      (* (max 0 (- (length infos) 1)) bar-thickness)))
+    ;; vec : id -o> major-dim size (width)
+    (define vec (make-vector (length infos) 0))
+    (let loop ([percentages percentages] ;; sums to 1.
+               [major-dim-mins (map (λ (info) (if vertical? (list-ref info 1) (list-ref info 0)))
+                                    infos)]
+               [major-dim-tot original-major-dim-tot]
+               [ids (build-list (length percentages) values)])
+      (define fitting-ones (extract-fitting-percentages percentages major-dim-mins major-dim-tot))
+      (cond
+        [(andmap not fitting-ones)
+         ;; all of them (perhaps none) fit, terminate.
+         (for ([id (in-list ids)]
+               [percentage (in-list percentages)])
+           (vector-set! vec id (* percentage major-dim-tot)))]
+        [else
+         ;; something doesn't fit; remove them and try again
+         (let ([next-percentages '()]
+               [next-major-dim-mins '()]
+               [next-major-dim-tot major-dim-tot]
+               [next-ids '()])
+           (for ([percentage (in-list percentages)]
+                 [major-dim-min (in-list major-dim-mins)]
+                 [id (in-list ids)]
+                 [fitting-one (in-list fitting-ones)])
+             (cond
+               [fitting-one
+                (vector-set! vec id fitting-one)
+                (set! next-major-dim-tot (- major-dim-tot fitting-one))]
+               [else
+                (set! next-percentages (cons percentage next-percentages))
+                (set! next-major-dim-mins (cons major-dim-min next-major-dim-mins))
+                (set! next-ids (cons id next-ids))]))
+           (define next-percentage-sum (apply + next-percentages))
+           (loop (map (λ (x) (/ x next-percentage-sum)) next-percentages)
+                 next-major-dim-mins
+                 next-major-dim-tot
+                 next-ids))]))
+
+    ;; adjust the contents of the vector if there are any fractional values
+    (let loop ([i 0]
+               [maj-val 0])
+      (cond
+        [(= i (vector-length vec))
+         (unless (= maj-val original-major-dim-tot)
+           (unless (zero? (vector-length vec))
+             (define last-index (- (vector-length vec) 1))
+             (vector-set! vec last-index (+ (vector-ref vec last-index) (- original-major-dim-tot maj-val)))))]
+        [else
+         (vector-set! vec i (floor (vector-ref vec i)))
+         (loop (+ i 1)
+               (+ maj-val (vector-ref vec i)))]))
+    
+    ;; build the result for the function from the major dim sizes
+    (let loop ([i 0]
+               [infos '()]
+               [gaps '()]
+               [maj-start 0])
+      (cond
+        [(= i (vector-length vec))
+         (values (reverse infos)
+                 (reverse gaps))]
+        [else
+         (define maj-stop (+ maj-start (vector-ref vec i)))
+         (define has-gap? (not (= i (- (vector-length vec) 1))))
+         (loop (+ i 1)
+               (cons (if vertical?
+                         (list 0
+                               maj-start
+                               width
+                               (- maj-stop maj-start))
+                         (list maj-start
+                               0
+                               (- maj-stop maj-start)
+                               height))
+                     infos)
+               (if has-gap?
+                   (cons (list maj-stop (+ maj-stop bar-thickness)) gaps)
+                   gaps)
+               (if has-gap?
+                   (+ maj-stop bar-thickness)
+                   maj-stop))])))
+  
+  (define (extract-fitting-percentages percentages major-dim-mins major-dim-tot)
+    (for/list ([percentage (in-list percentages)]
+               [major-dim-min (in-list major-dim-mins)])
+      (if (<= major-dim-min (* percentage major-dim-tot))
+          #f
+          major-dim-min)))
+  
+  (define (dragable-container-size orig-children-info bar-thickness vertical?)
+    (let loop ([children-info orig-children-info]
+               [major-size 0]
+               [minor-size 0])
+      (cond
+        [(null? children-info)
+         (let ([major-size (+ major-size 
+                              (* (max 0 (- (length orig-children-info) 1)) 
+                                 bar-thickness))])
+           (if vertical?
+               (values (ceiling minor-size) (ceiling major-size))
+               (values (ceiling major-size) (ceiling minor-size))))]
+        [else
+         (let ([child-info (car children-info)])
+           (let-values ([(child-major major-stretch? child-minor minor-stretch?)
+                         (if vertical?
+                             ;; 0 = width/horiz, 1 = height/vert
+                             (values (list-ref child-info 1)
+                                     (list-ref child-info 3)
+                                     (list-ref child-info 0)
+                                     (list-ref child-info 2))
+                             (values (list-ref child-info 0)
+                                     (list-ref child-info 2)
+                                     (list-ref child-info 1)
+                                     (list-ref child-info 3)))])
+             (loop (cdr children-info)
+                   (+ child-major major-size)
+                   (max child-minor minor-size))))])))
   
   (define three-bar-pen-bar-width 8)
   

collects/framework/private/sig.rkt

@@ -59,8 +59,9 @@
      horizontal-dragable-mixin
      horizontal-dragable%))
   (define-signature panel^ extends panel-class^
-    ())
+    (dragable-container-size
-  
+     dragable-place-children))
+
   (define-signature application-class^
     ())
   (define-signature application^ extends application-class^

collects/tests/framework/framework-test-engine.rkt

@@ -33,7 +33,7 @@
                        (build-path (find-system-path 'temp-dir)
                                    "framework-tests-receive-sexps-port.ss")
                      read)])
-	 (debug-printf mr-tcp "about to connect to ~a\n" port)
+         (debug-printf mr-tcp "about to connect to ~a\n" port)
 	 (let*-values ([(in out) (tcp-connect "127.0.0.1" port)])
 	   (let loop ()
 	     (debug-printf mr-tcp "about to read\n")

collects/tests/framework/main.rkt

@@ -51,7 +51,7 @@
    (let* ([throwouts (remove* all-files files)]
           [files (remove* throwouts files)])
      (when (not (null? throwouts))
-       (debug-printf admin "  ignoring files that don't occur in all-files: ~s\n" throwouts))
+       (debug-printf admin "   ignoring files that don't occur in all-files: ~s\n" throwouts))
      (set! files-to-process
            (cond [all?   all-files]
                  [batch? (remove* interactive-files all-files)]
@@ -59,12 +59,12 @@
  `("Names of the tests; defaults to all non-interactive tests"))
 
 (when (file-exists? preferences-file)
-  (debug-printf admin "  saving preferences file ~s to ~s\n"
+  (debug-printf admin "   saving preferences file ~s\n" preferences-file)
-                preferences-file old-preferences-file)
+  (debug-printf admin "                        to ~s\n" old-preferences-file)
   (if (file-exists? old-preferences-file)
-    (debug-printf admin "  backup preferences file exists, using that one\n")
+    (debug-printf admin "   backup preferences file exists, using that one\n")
     (begin (copy-file preferences-file old-preferences-file)
-           (debug-printf admin "  saved preferences file\n"))))
+           (debug-printf admin "   saved preferences file\n"))))
 
 (define jumped-out-tests '())
 
@@ -94,13 +94,15 @@
          (reset-section-jump!)))))
  files-to-process)
 
+(debug-printf schedule "ran ~a test~a\n" number-of-tests (if (= 1 number-of-tests) "" "s"))
+
 (when (file-exists? old-preferences-file)
-  (debug-printf admin "  restoring preferences file ~s to ~s\n"
+  (debug-printf admin "   restoring preferences file ~s\n" old-preferences-file)
-                old-preferences-file preferences-file)
+  (debug-printf admin "                           to ~s\n" preferences-file)
   (delete-file preferences-file)
   (copy-file old-preferences-file preferences-file)
   (delete-file old-preferences-file)
-  (debug-printf admin "  restored preferences file\n"))
+  (debug-printf admin "   restored preferences file\n"))
 
 (shutdown-listener)
 

collects/tests/framework/panel.rkt

@@ -1,6 +1,125 @@
 #lang mzscheme
 (require "test-suite-utils.ss")
 
+(test
+ 'dragable-min-size1
+ (λ (min-w/min-h) (equal? min-w/min-h '(10 20)))
+ `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f)) 0 #t))
+                    list))
+
+(test
+ 'dragable-min-size2
+ (λ (min-w/min-h) (equal? min-w/min-h '(10 20)))
+ `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f)) 0 #f))
+                    list))
+
+(test
+ 'dragable-min-size3
+ (λ (min-w/min-h) (equal? min-w/min-h '(30 60)))
+ `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 0 #t))
+                    list))
+
+(test
+ 'dragable-min-size4
+ (λ (min-w/min-h) (equal? min-w/min-h '(40 40)))
+ `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 0 #f))
+                    list))
+
+(test
+ 'dragable-min-size5
+ (λ (min-w/min-h) (equal? min-w/min-h '(30 65)))
+ `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 5 #t))
+                    list))
+
+(test
+ 'dragable-min-size6
+ (λ (min-w/min-h) (equal? min-w/min-h '(45 40)))
+ `(call-with-values (λ () (panel:dragable-container-size '((10 20 #f #f) (30 40 #f #f)) 5 #f))
+                    list))
+
+(test
+ 'dragable-place-children1
+ (λ (l) (equal? l '(() ())))
+ `(call-with-values (λ () (panel:dragable-place-children '() 100 200 '() 0 #t))
+                    list))
+
+(test
+ 'dragable-place-children2
+ (λ (l) (equal? l '(((0 0 100 200)) ())))
+ `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f)) 100 200 '(1) 0 #t))
+                    list))
+
+(test
+ 'dragable-place-children3
+ (λ (l) (equal? l '(((0 0 100 200)) ())))
+ `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f)) 100 200 '(1) 0 #f))
+                    list))
+
+(test
+ 'dragable-place-children4
+ (λ (l) (equal? l '(((0 0 100 150) (0 150 100 150)) ((150 150)))))
+ `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/2 1/2) 0 #t))
+                    list))
+
+(test
+ 'dragable-place-children5
+ (λ (l) (equal? l '(((0 0 50 300) (50 0 50 300)) ((50 50)))))
+ `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/2 1/2) 0 #f))
+                    list))
+
+(test
+ 'dragable-place-children5
+ (λ (l) (equal? l '(((0 0 100 100) (0 100 100 200)) ((100 100)))))
+ `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/3 2/3) 0 #t))
+                    list))
+
+(test
+ 'dragable-place-children6
+ (λ (l) (equal? l '(((0 0 10 300) (10 0 90 300)) ((10 10)))))
+ `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 100 300 '(1/10 9/10) 0 #f))
+                    list))
+
+(test
+ 'dragable-place-children7
+ (λ (l) (equal? l '(((0 0 10 300) (20 0 90 300)) ((10 20)))))
+ `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f)) 110 300 '(1/10 9/10) 10 #f))
+                    list))
+
+(test
+ 'dragable-place-children8
+ (λ (l) (equal? l '(((0 0 10 300) (20 0 20 300) (50 0 70 300)) ((10 20) (40 50)))))
+ `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (10 10 #t #f) (10 10 #t #f)) 120 300 '(1/10 2/10 7/10) 10 #f))
+                    list))
+
+(test
+ 'dragable-place-children9
+ (λ (l) (equal? l '(((0 0 30 300) (30 0 70 300)) ((30 30)))))
+ `(call-with-values (λ () (panel:dragable-place-children '((10 10 #t #f) (70 10 #t #f)) 100 300 '(1/2 1/2) 0 #f))
+                    list))
+
+(test
+ 'dragable-place-children10
+ (λ (l) (equal? l '(((0 0 70 300) (70 0 30 300)) ((70 70)))))
+ `(call-with-values (λ () (panel:dragable-place-children '((70 10 #t #f) (10 10 #t #f)) 100 300 '(1/2 1/2) 0 #f))
+                    list))
+
+(test
+ 'dragable-place-children11
+ (λ (l) (equal? l '(((0 0 70 300) (70 0 10 300) (80 0 20 300)) ((70 70) (80 80)))))
+ `(call-with-values (λ () (panel:dragable-place-children '((70 10 #t #f) (10 10 #t #f) (20 10 #t #f)) 100 300 '(1/2 1/4 1/4) 0 #f))
+                    list))
+
+(test
+ 'dragable-place-children12
+ (λ (l) (equal? l '(((0 0 242 629) (247 0 243 629)) ((242 247)))))
+ `(call-with-values (λ () (panel:dragable-place-children '((30 30 #t #t) (30 30 #t #t)) 490 629 '(1/2 1/2) 5 #f))
+                    list))
+
+;(dragable-place-children infos width height percentages gap-width vertical?)
+
+;; with stuff that doesn't fit....
+
+#;
 (test 
  'single-panel
  (lambda (x) (eq? x 'passed))

collects/tests/framework/test-suite-utils.rkt

@@ -8,6 +8,7 @@
 (provide
  test-name
  failed-tests
+ number-of-tests
  
  ;(struct eof-result ())
  eof-result?
@@ -48,6 +49,7 @@
 
 (define test-name "<<setup>>")
 (define failed-tests null)
+(define number-of-tests 0)
 
 (define-struct eof-result ())
 
@@ -87,8 +89,10 @@
        (build-path
         (let-values ([(dir exe _)
                       (split-path (find-system-path 'exec-file))])
-          dir)
+          (if (eq? dir 'relative)
-        (if (eq? 'windows (system-type)) "GRacket.exe" "gracket")))
+              'same
+              dir))
+        (if (eq? 'windows (system-type)) "Racket.exe" "racket")))
       (path->string
        (build-path (collection-path "tests" "framework")
                    "framework-test-engine.ss")))))
@@ -172,7 +176,7 @@
                      (or (not (char-ready? in-port))
                          (not (eof-object? (peek-char in-port))))))
         (restart-mred))
-      (debug-printf messages "  ~a // ~a: sending to gracket:\n"
+      (debug-printf messages "  ~a // ~a: sending to framework side to eval:\n"
                     section-name test-name)
       (show-text sexp)
       (with-handlers ([exn:fail?
@@ -254,6 +258,7 @@
                                                 (exn->str x)
                                                 (format "~s" x))))])
                           (not (passed? result)))])
+           (set! number-of-tests (+ number-of-tests 1))
            (when failed
              (debug-printf schedule "FAILED ~a:\n  ~s\n" test-name result)
              (set! failed-tests (cons (cons section-name test-name) failed-tests))