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
This commit is contained in:
Robby Findler
parent
fbe5eb9909
commit
8cf124a6f3
|
|
@ -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?)
|
||||
|
|
|
|||
|
|
@ -305,74 +305,154 @@
|
|||
(define cursor-gaps null)
|
||||
|
||||
(define/override (place-children _infos width height)
|
||||
(set! cursor-gaps null)
|
||||
(update-percentages)
|
||||
(define-values (results gaps)
|
||||
(dragable-place-children _infos width height
|
||||
(map percentage-% percentages)
|
||||
bar-thickness
|
||||
(get-vertical?)))
|
||||
(set! cursor-gaps
|
||||
(let loop ([children (get-children)]
|
||||
[percentages percentages]
|
||||
[gaps gaps])
|
||||
(cond
|
||||
[(null? _infos) null]
|
||||
[(null? (cdr _infos)) (list (list 0 0 width height))]
|
||||
[(null? children) '()]
|
||||
[(null? (cdr children)) '()]
|
||||
[else
|
||||
(let ([available-extent (get-available-extent)]
|
||||
[show-error
|
||||
(λ (n)
|
||||
(error 'panel.ss::dragable-panel "internal error.~a" n))])
|
||||
(let loop ([percentages percentages]
|
||||
[children (get-children)]
|
||||
[infos _infos]
|
||||
[dim 0])
|
||||
(cond
|
||||
[(null? percentages)
|
||||
(unless (null? infos) (show-error 1))
|
||||
(unless (null? children) (show-error 2))
|
||||
null]
|
||||
[(null? (cdr percentages))
|
||||
(when (null? infos) (show-error 3))
|
||||
(when (null? children) (show-error 4))
|
||||
(unless (null? (cdr infos)) (show-error 5))
|
||||
(unless (null? (cdr children)) (show-error 6))
|
||||
(if (get-vertical?)
|
||||
(list (list 0 dim width (- height dim)))
|
||||
(list (list dim 0 (- width dim) height)))]
|
||||
[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
|
||||
(define gap (car gaps))
|
||||
(cons (make-gap (car children)
|
||||
(list-ref gap 0)
|
||||
(car percentages)
|
||||
(cadr children)
|
||||
(+ dim this-space bar-thickness)
|
||||
(list-ref gap 1)
|
||||
(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))))])))]))
|
||||
(loop (cdr children)
|
||||
(cdr percentages)
|
||||
(cdr gaps)))])))
|
||||
|
||||
results)
|
||||
|
||||
(define/override (container-size children-info)
|
||||
(update-percentages)
|
||||
(let loop ([percentages percentages]
|
||||
[children-info children-info]
|
||||
(dragable-container-size children-info bar-thickness (get-vertical?)))
|
||||
|
||||
(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)
|
||||
(if (get-vertical?)
|
||||
(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)))]
|
||||
[(null? percentages)
|
||||
(error 'panel.ss::dragable-panel "internal error.12")]
|
||||
(values (ceiling major-size) (ceiling minor-size))))]
|
||||
[else
|
||||
(let ([child-info (car children-info)]
|
||||
[percentage (car percentages)])
|
||||
(let ([child-info (car children-info)])
|
||||
(let-values ([(child-major major-stretch? child-minor minor-stretch?)
|
||||
(if (get-vertical?)
|
||||
(if vertical?
|
||||
;; 0 = width/horiz, 1 = height/vert
|
||||
(values (list-ref child-info 1)
|
||||
(list-ref child-info 3)
|
||||
(list-ref child-info 0)
|
||||
|
|
@ -381,16 +461,10 @@
|
|||
(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)
|
||||
(loop (cdr children-info)
|
||||
(+ child-major major-size)
|
||||
(max child-minor minor-size))))])))
|
||||
|
||||
(super-instantiate (parent))))
|
||||
|
||||
(define three-bar-pen-bar-width 8)
|
||||
|
||||
(define three-bar-canvas%
|
||||
|
|
|
|||
|
|
@ -59,7 +59,8 @@
|
|||
horizontal-dragable-mixin
|
||||
horizontal-dragable%))
|
||||
(define-signature panel^ extends panel-class^
|
||||
())
|
||||
(dragable-container-size
|
||||
dragable-place-children))
|
||||
|
||||
(define-signature application-class^
|
||||
())
|
||||
|
|
|
|||
|
|
@ -59,8 +59,8 @@
|
|||
`("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"
|
||||
preferences-file old-preferences-file)
|
||||
(debug-printf admin " saving preferences file ~s\n" 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")
|
||||
(begin (copy-file preferences-file old-preferences-file)
|
||||
|
|
@ -94,9 +94,11 @@
|
|||
(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"
|
||||
old-preferences-file preferences-file)
|
||||
(debug-printf admin " restoring preferences file ~s\n" old-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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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? 'windows (system-type)) "GRacket.exe" "gracket")))
|
||||
(if (eq? dir 'relative)
|
||||
'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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user