panel.rkt
1 #lang racket/base 2 3 (require racket/class 4 racket/list 5 racket/unit 6 "sig.rkt" 7 mred/mred-sig 8 mrlib/switchable-button) 9 (provide panel@) 10 11 (define-unit panel@ 12 (import [prefix icon: framework:icon^] 13 mred^) 14 (export framework:panel^) 15 (init-depend mred^) 16 17 (define single<%> (interface (area-container<%>) active-child)) 18 (define single-mixin 19 (mixin (area-container<%>) (single<%>) 20 (inherit get-alignment change-children) 21 (define/override (after-new-child c) 22 (unless (is-a? c window<%>) 23 24 ;; would like to remove the child here, waiting on a PR submitted 25 ;; about change-children during after-new-child 26 (change-children 27 (λ (l) 28 (remq c l))) 29 30 (error 'single-mixin::after-new-child 31 "all children must implement window<%>, got ~e" 32 c)) 33 (if current-active-child 34 (send c show #f) 35 (set! current-active-child c))) 36 [define/override (container-size l) 37 (if (null? l) 38 (values 0 0) 39 (values (apply max (map car l)) (apply max (map cadr l))))] 40 [define/override (place-children l width height) 41 (let-values ([(h-align-spec v-align-spec) (get-alignment)]) 42 (let ([align 43 (λ (total-size spec item-size) 44 (floor 45 (case spec 46 [(center) (- (/ total-size 2) (/ item-size 2))] 47 [(left top) 0] 48 [(right bottom) (- total-size item-size)] 49 [else (error 'place-children 50 "alignment spec is unknown ~a\n" spec)])))]) 51 (map (λ (l) 52 (let*-values ([(min-width min-height h-stretch? v-stretch?) 53 (apply values l)] 54 [(x this-width) 55 (if h-stretch? 56 (values 0 width) 57 (values (align width h-align-spec min-width) 58 min-width))] 59 [(y this-height) 60 (if v-stretch? 61 (values 0 height) 62 (values (align height v-align-spec min-height) 63 min-height))]) 64 (list x y this-width this-height))) 65 l)))] 66 67 (inherit get-children begin-container-sequence end-container-sequence) 68 [define current-active-child #f] 69 (define/public active-child 70 (case-lambda 71 [() current-active-child] 72 [(x) 73 (unless (memq x (get-children)) 74 (error 'active-child "got a panel that is not a child: ~e" x)) 75 (unless (eq? x current-active-child) 76 (begin-container-sequence) 77 (for-each (λ (x) (send x show #f)) 78 (get-children)) 79 (set! current-active-child x) 80 (send current-active-child show #t) 81 (end-container-sequence))])) 82 (super-instantiate ()))) 83 84 (define single-window<%> (interface (single<%> window<%>))) 85 (define single-window-mixin 86 (mixin (single<%> window<%>) (single-window<%>) 87 (inherit get-client-size get-size) 88 [define/override container-size 89 (λ (l) 90 (let-values ([(super-width super-height) (super container-size l)] 91 [(client-width client-height) (get-client-size)] 92 [(window-width window-height) (get-size)] 93 [(calc-size) 94 (λ (super client window) 95 (+ super (max 0 (- window client))))]) 96 97 (values 98 (calc-size super-width client-width window-width) 99 (calc-size super-height client-height window-height))))] 100 (super-new))) 101 102 (define multi-view<%> 103 (interface (area-container<%>) 104 split-vertically 105 split-horizontally 106 collapse)) 107 108 (define multi-view-mixin 109 (mixin (area-container<%>) (multi-view<%>) 110 (init-field parent editor) 111 (public get-editor-canvas% get-vertical% get-horizontal%) 112 [define get-editor-canvas% 113 (λ () 114 editor-canvas%)] 115 [define get-vertical% 116 (λ () 117 vertical-panel%)] 118 [define get-horizontal% 119 (λ () 120 horizontal-panel%)] 121 122 (define/private (split p%) 123 (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] 124 [ec% (get-editor-canvas%)]) 125 (when (and canvas 126 (is-a? canvas ec%) 127 (eq? (send canvas get-editor) editor)) 128 (let ([p (send canvas get-parent)]) 129 (send p change-children (λ (x) null)) 130 (let ([pc (make-object p% p)]) 131 (send (make-object ec% (make-object vertical-panel% pc) editor) focus) 132 (make-object ec% (make-object vertical-panel% pc) editor)))))) 133 [define/public split-vertically 134 (λ () 135 (split (get-vertical%)))] 136 [define/public split-horizontally 137 (λ () 138 (split (get-horizontal%)))] 139 140 (define/public (collapse) 141 (let ([canvas (send (send parent get-top-level-window) get-edit-target-window)] 142 [ec% (get-editor-canvas%)]) 143 (when (and canvas 144 (is-a? canvas ec%) 145 (eq? (send canvas get-editor) editor)) 146 (let ([p (send canvas get-parent)]) 147 (if (eq? p this) 148 (bell) 149 (let* ([sp (send p get-parent)] 150 [p-to-remain (send sp get-parent)]) 151 (send p-to-remain change-children (λ (x) null)) 152 (send (make-object ec% p-to-remain editor) focus))))))) 153 154 155 (super-instantiate () (parent parent)) 156 (make-object (get-editor-canvas%) this editor))) 157 158 (define single% (single-window-mixin (single-mixin panel%))) 159 (define single-pane% (single-mixin pane%)) 160 (define multi-view% (multi-view-mixin vertical-panel%)) 161 162 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 163 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 164 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 165 166 ;; type gap = (make-gap number area<%> percentage number area<%> percentage) 167 (define-struct gap (before before-dim before-percentage after after-dim after-percentage)) 168 169 ;; type percentage : (make-percentage number) 170 (define-struct percentage (%) #:mutable) 171 172 (define dragable<%> 173 (interface (window<%> area-container<%>) 174 after-percentage-change 175 set-percentages 176 get-percentages 177 get-vertical? 178 get-default-percentages 179 right-click-in-gap 180 set-orientation)) 181 182 (define vertical-dragable<%> 183 (interface (dragable<%>))) 184 185 (define horizontal-dragable<%> 186 (interface (dragable<%>))) 187 188 (define dragable-mixin 189 (mixin (window<%> area-container<%>) (dragable<%>) 190 (init parent) 191 192 (init-field vertical?) 193 (define/public-final (get-vertical?) vertical?) 194 (define/public-final (set-orientation h?) 195 (define v? (not h?)) 196 (unless (eq? vertical? v?) 197 (set! vertical? v?) 198 (container-flow-modified))) 199 (define/private (min-extent child) 200 (let-values ([(w h) (send child get-graphical-min-size)]) 201 (if (get-vertical?) 202 (max (send child min-height) h) 203 (max (send child min-width) w)))) 204 (define/private (event-get-dim evt) 205 (if (get-vertical?) 206 (send evt get-y) 207 (send evt get-x))) 208 (define/private (get-gap-cursor) 209 (if (get-vertical?) 210 (icon:get-up/down-cursor) 211 (icon:get-left/right-cursor))) 212 213 (define/public (right-click-in-gap evt before after) (void)) 214 215 (inherit get-client-size container-flow-modified) 216 217 (init-field [bar-thickness 5]) 218 219 ;; percentages : (listof percentage) 220 (define percentages null) 221 222 ;; get-percentages : -> (listof number) 223 (define/public (get-percentages) 224 (map percentage-% percentages)) 225 226 (define/public (set-percentages ps) 227 (unless (and (list? ps) 228 (andmap number? ps) 229 (= 1 (apply + ps)) 230 (andmap positive? ps)) 231 (error 'set-percentages 232 "expected a list of numbers that are all positive and sum to 1, got: ~e" 233 ps)) 234 (unless (= (length ps) (length (get-children))) 235 (error 'set-percentages 236 "expected a list of numbers whose length is the number of children: ~a, got ~e" 237 (length (get-children)) 238 ps)) 239 (set! percentages (map make-percentage ps)) 240 (container-flow-modified)) 241 242 (define/pubment (after-percentage-change) (inner (void) after-percentage-change)) 243 244 (define/private (get-available-extent) 245 (let-values ([(width height) (get-client-size)]) 246 (- (if (get-vertical?) height width) 247 (* bar-thickness (- (length (get-children)) 1))))) 248 249 (inherit get-children) 250 251 (define/private (update-percentages) 252 (let ([len-children (length (get-children))]) 253 (unless (= len-children (length percentages)) 254 (cond 255 [(zero? len-children) 256 (set! percentages '())] 257 [else 258 (set! percentages (map make-percentage (get-default-percentages len-children)))]) 259 (after-percentage-change)))) 260 261 (define/pubment (get-default-percentages i) 262 (define res (inner (if (zero? i) '() (make-list i (/ i))) 263 get-default-percentages i)) 264 (unless (and (list? res) 265 (andmap (λ (x) (and (real? x) (<= 0 x 1))) res) 266 (= 1 (apply + res)) 267 (= (length res) i)) 268 (error 'get-default-percentages 269 "expected inner call to return a list of real numbers that sum to 1 and has length ~a" 270 i)) 271 res) 272 273 (define/override (after-new-child child) 274 (update-percentages)) 275 276 (define resizing-dim #f) 277 (define resizing-gap #f) 278 279 (inherit set-cursor) 280 (define/override (on-subwindow-event receiver evt) 281 (if (eq? receiver this) 282 (let ([gap 283 (ormap (λ (gap) 284 (and (<= (gap-before-dim gap) 285 (event-get-dim evt) 286 (gap-after-dim gap)) 287 gap)) 288 cursor-gaps)]) 289 (set-cursor (and (or gap 290 resizing-dim) 291 (let ([c (get-gap-cursor)]) 292 (and (send c ok?) 293 c)))) 294 (cond 295 [(and gap (send evt button-down? 'right)) 296 (right-click-in-gap evt (gap-before gap) (gap-after gap))] 297 [(and gap (send evt button-down? 'left)) 298 (set! resizing-dim (event-get-dim evt)) 299 (set! resizing-gap gap)] 300 [(send evt button-up? 'left) 301 (set! resizing-dim #f) 302 (set! resizing-gap #f)] 303 [(and resizing-dim resizing-gap (send evt moving?)) 304 (let-values ([(width height) (get-client-size)]) 305 (let* ([before-percentage (gap-before-percentage resizing-gap)] 306 [orig-before (percentage-% before-percentage)] 307 [after-percentage (gap-after-percentage resizing-gap)] 308 [orig-after (percentage-% after-percentage)] 309 [available-extent (get-available-extent)] 310 [change-in-percentage (/ (- resizing-dim (event-get-dim evt)) available-extent)] 311 [new-before (- (percentage-% before-percentage) change-in-percentage)] 312 [new-after (+ (percentage-% after-percentage) change-in-percentage)]) 313 (when ((floor (* new-before available-extent)) . > . (min-extent (gap-before resizing-gap))) 314 (when ((floor (* new-after available-extent)) . > . (min-extent (gap-after resizing-gap))) 315 (set-percentage-%! before-percentage new-before) 316 (set-percentage-%! after-percentage new-after) 317 (after-percentage-change) 318 (set! resizing-dim (event-get-dim evt)) 319 (container-flow-modified)))))] 320 [else (super on-subwindow-event receiver evt)])) 321 (begin 322 (set-cursor #f) 323 (super on-subwindow-event receiver evt)))) 324 325 (define cursor-gaps null) 326 327 (define/override (place-children _infos width height) 328 (update-percentages) 329 (define-values (results gaps) 330 (dragable-place-children _infos width height 331 (map percentage-% percentages) 332 bar-thickness 333 (get-vertical?))) 334 (set! cursor-gaps 335 (let loop ([children (get-children)] 336 [percentages percentages] 337 [gaps gaps]) 338 (cond 339 [(null? children) '()] 340 [(null? (cdr children)) '()] 341 [else 342 (define gap (car gaps)) 343 (cons (make-gap (car children) 344 (list-ref gap 0) 345 (car percentages) 346 (cadr children) 347 (list-ref gap 1) 348 (cadr percentages)) 349 (loop (cdr children) 350 (cdr percentages) 351 (cdr gaps)))]))) 352 353 results) 354 355 (define/override (container-size children-info) 356 (update-percentages) 357 (dragable-container-size children-info bar-thickness (get-vertical?))) 358 359 (super-new [parent parent]))) 360 361 ;; this function repeatedly checks to see if the current set of percentages and children 362 ;; would violate any minimum size constraints. If not, the percentages are used and the 363 ;; function termiantes. If some minimum sizes would be violated, the function pulls those 364 ;; children out of the list under consideration, gives them their minimum sizes, rescales 365 ;; the remaining percentages back to 1, adjusts the available space after removing those 366 ;; panels, and tries again. 367 (define (dragable-place-children infos width height percentages bar-thickness vertical?) 368 (define original-major-dim-tot (- (if vertical? height width) 369 (* (max 0 (- (length infos) 1)) bar-thickness))) 370 ;; vec : id -o> major-dim size (width) 371 (define vec (make-vector (length infos) 0)) 372 (let loop ([percentages percentages] ;; sums to 1. 373 [major-dim-mins (map (λ (info) (if vertical? (list-ref info 1) (list-ref info 0))) 374 infos)] 375 [major-dim-tot original-major-dim-tot] 376 [ids (build-list (length percentages) values)]) 377 (define fitting-ones (extract-fitting-percentages percentages major-dim-mins major-dim-tot)) 378 (cond 379 [(andmap not fitting-ones) 380 ;; all of them (perhaps none) fit, terminate. 381 (for ([id (in-list ids)] 382 [percentage (in-list percentages)]) 383 (vector-set! vec id (* percentage major-dim-tot)))] 384 [else 385 ;; something doesn't fit; remove them and try again 386 (let ([next-percentages '()] 387 [next-major-dim-mins '()] 388 [next-major-dim-tot major-dim-tot] 389 [next-ids '()]) 390 (for ([percentage (in-list percentages)] 391 [major-dim-min (in-list major-dim-mins)] 392 [id (in-list ids)] 393 [fitting-one (in-list fitting-ones)]) 394 (cond 395 [fitting-one 396 (vector-set! vec id fitting-one) 397 (set! next-major-dim-tot (- major-dim-tot fitting-one))] 398 [else 399 (set! next-percentages (cons percentage next-percentages)) 400 (set! next-major-dim-mins (cons major-dim-min next-major-dim-mins)) 401 (set! next-ids (cons id next-ids))])) 402 (define next-percentage-sum (apply + next-percentages)) 403 (loop (map (λ (x) (/ x next-percentage-sum)) next-percentages) 404 next-major-dim-mins 405 next-major-dim-tot 406 next-ids))])) 407 408 ;; adjust the contents of the vector if there are any fractional values 409 (let loop ([i 0] 410 [maj-val 0]) 411 (cond 412 [(= i (vector-length vec)) 413 (unless (= maj-val original-major-dim-tot) 414 (unless (zero? (vector-length vec)) 415 (define last-index (- (vector-length vec) 1)) 416 (vector-set! vec last-index (+ (vector-ref vec last-index) (- original-major-dim-tot maj-val)))))] 417 [else 418 (vector-set! vec i (floor (vector-ref vec i))) 419 (loop (+ i 1) 420 (+ maj-val (vector-ref vec i)))])) 421 422 ;; build the result for the function from the major dim sizes 423 (let loop ([i 0] 424 [infos '()] 425 [gaps '()] 426 [maj-start 0]) 427 (cond 428 [(= i (vector-length vec)) 429 (values (reverse infos) 430 (reverse gaps))] 431 [else 432 (define maj-stop (+ maj-start (vector-ref vec i))) 433 (define has-gap? (not (= i (- (vector-length vec) 1)))) 434 (loop (+ i 1) 435 (cons (if vertical? 436 (list 0 437 maj-start 438 width 439 (- maj-stop maj-start)) 440 (list maj-start 441 0 442 (- maj-stop maj-start) 443 height)) 444 infos) 445 (if has-gap? 446 (cons (list maj-stop (+ maj-stop bar-thickness)) gaps) 447 gaps) 448 (if has-gap? 449 (+ maj-stop bar-thickness) 450 maj-stop))]))) 451 452 (define (extract-fitting-percentages percentages major-dim-mins major-dim-tot) 453 (for/list ([percentage (in-list percentages)] 454 [major-dim-min (in-list major-dim-mins)]) 455 (if (<= major-dim-min (* percentage major-dim-tot)) 456 #f 457 major-dim-min))) 458 459 (define (dragable-container-size orig-children-info bar-thickness vertical?) 460 (let loop ([children-info orig-children-info] 461 [major-size 0] 462 [minor-size 0]) 463 (cond 464 [(null? children-info) 465 (let ([major-size (+ major-size 466 (* (max 0 (- (length orig-children-info) 1)) 467 bar-thickness))]) 468 (if vertical? 469 (values (ceiling minor-size) (ceiling major-size)) 470 (values (ceiling major-size) (ceiling minor-size))))] 471 [else 472 (let ([child-info (car children-info)]) 473 (let-values ([(child-major major-stretch? child-minor minor-stretch?) 474 (if vertical? 475 ;; 0 = width/horiz, 1 = height/vert 476 (values (list-ref child-info 1) 477 (list-ref child-info 3) 478 (list-ref child-info 0) 479 (list-ref child-info 2)) 480 (values (list-ref child-info 0) 481 (list-ref child-info 2) 482 (list-ref child-info 1) 483 (list-ref child-info 3)))]) 484 (loop (cdr children-info) 485 (+ child-major major-size) 486 (max child-minor minor-size))))]))) 487 488 (define three-bar-pen-bar-width 8) 489 490 (define three-bar-canvas% 491 (class canvas% 492 (inherit get-dc get-client-size) 493 (define/override (on-paint) 494 (let ([dc (get-dc)]) 495 (let-values ([(w h) (get-client-size)]) 496 (let ([sx (floor (- (/ w 2) (/ three-bar-pen-bar-width 2)))]) 497 (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) 498 (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) 499 (send dc draw-rectangle 0 0 w h) 500 501 (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid)) 502 (send dc draw-line sx 1 (+ sx three-bar-pen-bar-width) 1) 503 (send dc draw-line sx 4 (+ sx three-bar-pen-bar-width) 4) 504 (send dc draw-line sx 7 (+ sx three-bar-pen-bar-width) 7) 505 506 (send dc set-pen (send the-pen-list find-or-create-pen "gray" 1 'solid)) 507 (send dc draw-line sx 2 (+ sx three-bar-pen-bar-width) 2) 508 (send dc draw-line sx 5 (+ sx three-bar-pen-bar-width) 5) 509 (send dc draw-line sx 8 (+ sx three-bar-pen-bar-width) 8))))) 510 511 (super-new [style '(no-focus)]) 512 (inherit stretchable-height min-height) 513 (stretchable-height #f) 514 (min-height 10))) 515 516 (define vertical-dragable-mixin 517 (mixin (dragable<%>) (vertical-dragable<%>) 518 (super-new [vertical? #t]))) 519 520 (define horizontal-dragable-mixin 521 (mixin (dragable<%>) (horizontal-dragable<%>) 522 (super-new [vertical? #f]))) 523 524 (define vertical-dragable% (vertical-dragable-mixin (dragable-mixin panel%))) 525 526 (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin panel%))) 527 528 (define splitter<%> (interface () split-horizontal split-vertical collapse)) 529 ;; we need a private interface so we can use `generic' because `generic' 530 ;; doesn't work on mixins 531 (define splitter-private<%> (interface () self-vertical? self-horizontal?)) 532 533 (define splitter-mixin 534 (mixin (area-container<%> dragable<%>) (splitter<%> splitter-private<%>) 535 (super-new) 536 (inherit get-children add-child 537 delete-child 538 change-children 539 begin-container-sequence 540 end-container-sequence) 541 542 (field [horizontal-panel% horizontal-dragable%] 543 [vertical-panel% vertical-dragable%]) 544 545 (define/public (self-vertical?) 546 (send this get-vertical?)) 547 548 (define/public (self-horizontal?) 549 (not (send this get-vertical?))) 550 551 ;; insert an item into a list after some element 552 ;; FIXME: this is probably a library function somewhere 553 (define/private (insert-after list before item) 554 (let loop ([so-far '()] 555 [list list]) 556 (cond 557 [(null? list) (reverse so-far)] 558 [(eq? (car list) before) (loop (cons item (cons before so-far)) 559 (cdr list))] 560 [else (loop (cons (car list) so-far) (cdr list))]))) 561 562 ;; replace an element with a list of stuff 563 ;; FIXME: this is probably a library function somewhere 564 (define/private (replace list at stuff) 565 (let loop ([so-far '()] 566 [list list]) 567 (cond 568 [(null? list) (reverse so-far)] 569 [(eq? (car list) at) (append (reverse so-far) stuff (cdr list))] 570 [else (loop (cons (car list) so-far) (cdr list))]))) 571 572 ;; remove a canvas and merge split panels if necessary 573 ;; TODO: restore percentages 574 (define/public (collapse canvas) 575 (begin-container-sequence) 576 (for ([child (get-children)]) 577 (cond 578 [(eq? child canvas) 579 (when (> (length (get-children)) 1) 580 (change-children 581 (lambda (old-children) 582 (remq canvas old-children))))] 583 [(is-a? child splitter<%>) 584 (send child collapse canvas)])) 585 (change-children 586 (lambda (old-children) 587 (for/list ([child old-children]) 588 (if (and (is-a? child splitter<%>) 589 (= (length (send child get-children)) 1)) 590 (let () 591 (define single (car (send child get-children))) 592 (send single reparent this) 593 single) 594 child)))) 595 (end-container-sequence)) 596 597 ;; split a canvas by creating a new editor and either 598 ;; 1) adding it to the panel if the panel is already using the same 599 ;; orientation as the split that is about to occur 600 ;; 2) create a new panel with the orientation of the split about to 601 ;; occur and add a new editor 602 ;; 603 ;; in both cases the new editor is returned 604 (define/private (do-split canvas maker orientation? orientation% split) 605 (define new-canvas #f) 606 (for ([child (get-children)]) 607 (cond 608 [(eq? child canvas) 609 (begin-container-sequence) 610 (change-children 611 (lambda (old-children) 612 (if (send-generic this orientation?) 613 (let ([new (maker this)]) 614 (set! new-canvas new) 615 (insert-after old-children child new)) 616 (let () 617 (define container (new (splitter-mixin orientation%) 618 [parent this])) 619 (send canvas reparent container) 620 (define created (maker container)) 621 (set! new-canvas created) 622 ;; this throws out the old child but we should probably 623 ;; try to keep it 624 (replace old-children child (list container)))))) 625 (end-container-sequence)] 626 627 [(is-a? child splitter<%>) 628 (let ([something (send-generic child split canvas maker)]) 629 (when something 630 (set! new-canvas something)))])) 631 new-canvas) 632 633 ;; canvas (widget -> editor) -> editor 634 (define/public (split-horizontal canvas maker) 635 (do-split canvas maker (generic splitter-private<%> self-horizontal?) 636 horizontal-panel% (generic splitter<%> split-horizontal))) 637 638 ;; canvas (widget -> editor) -> editor 639 (define/public (split-vertical canvas maker) 640 (do-split canvas maker (generic splitter-private<%> self-vertical?) 641 vertical-panel% (generic splitter<%> split-vertical))))) 642 643 644 (define discrete-child<%> 645 (interface () 646 get-discrete-widths 647 get-discrete-heights)) 648 649 (define discrete-sizes<%> (interface ((class->interface panel%)) 650 get-orientation 651 set-orientation)) 652 (define (discrete-get-widths c) 653 (cond 654 [(is-a? c switchable-button%) 655 (if (send c get-label-visible) 656 (list (send c get-large-width) 657 (send c get-small-width)) 658 (list (send c get-without-label-small-width)))] 659 [(is-a? c discrete-sizes<%>) 660 (send c get-discrete-widths)] 661 [else 662 #f])) 663 664 (define (discrete-get-heights c) 665 (cond 666 [(is-a? c discrete-sizes<%>) 667 (send c get-discrete-heights)] 668 [else 669 #f])) 670 671 (define discrete-sizes-mixin 672 (mixin ((class->interface panel%)) (discrete-sizes<%> discrete-child<%>) 673 (inherit get-children spacing get-alignment border container-flow-modified 674 get-size get-client-size) 675 (define horizontal? #t) 676 (define/public (get-orientation) horizontal?) 677 (define/public (set-orientation h?) 678 (unless (equal? horizontal? h?) 679 (set! horizontal? h?) 680 (container-flow-modified))) 681 682 (define/public (get-discrete-widths) 683 (cond 684 [horizontal? 685 (define ws 686 (for/list ([c (in-list (get-children))]) 687 (discrete-get-widths c))) 688 (and (andmap values ws) 689 (remove-duplicates 690 (map 691 (λ (x) (apply + x)) 692 (candidate-sizes ws))))] 693 [else #f])) 694 695 (define/public (get-discrete-heights) 696 (cond 697 [horizontal? #f] 698 [else 699 (define hs 700 (for/list ([c (in-list (get-children))]) 701 (discrete-get-heights c))) 702 (and (andmap values hs) 703 (remove-duplicates 704 (map 705 (λ (x) (apply + x)) 706 (candidate-sizes hs))))])) 707 708 (define/override (container-size infos) 709 (define the-spacing (spacing)) 710 (define the-border (spacing)) 711 (define-values (total-min-w total-min-h) 712 (for/fold ([w 0] [h 0]) 713 ([info (in-list infos)] 714 [n (in-naturals)]) 715 (define-values (min-w min-h h-stretch? v-stretch?) 716 (apply values info)) 717 (define this-spacing (if (zero? n) 0 the-spacing)) 718 (cond 719 [horizontal? 720 (values (+ w this-spacing min-w) 721 (max h min-h))] 722 [else 723 (values (max w min-w) 724 (+ h this-spacing min-h))]))) 725 (define-values (sw sh) (get-size)) 726 (define-values (cw ch) (get-client-size)) 727 (values (+ total-min-w the-border the-border 728 (- sw cw)) 729 (+ total-min-h the-border the-border 730 (- sh ch)))) 731 732 (define/override (place-children infos w h) 733 (define the-spacing (spacing)) 734 (define the-border (border)) 735 (define-values (halign valign) (get-alignment)) 736 (define children (get-children)) 737 (define all-sizess 738 (candidate-sizes 739 (for/list ([c (in-list children)] 740 [info (in-list infos)] 741 #:unless (if horizontal? 742 (and (not (discrete-get-widths c)) 743 (list-ref info 2)) 744 (and (not (discrete-get-heights c)) 745 (list-ref info 3)))) 746 (if horizontal? 747 (or (discrete-get-widths c) 748 (list (list-ref info 0))) 749 (or (discrete-get-heights c) 750 (list (list-ref info 1))))))) 751 (define fitting-sizes 752 (for/or ([sizes (in-list all-sizess)]) 753 (and (<= (apply + sizes) 754 (- (if horizontal? w h) 755 (* 2 the-border))) 756 sizes))) 757 (define fixed-size (apply + fitting-sizes)) 758 (define number-stretchable 759 (for/sum ([info (in-list infos)] 760 [c children]) 761 (if (if horizontal? 762 (and (not (discrete-get-widths c)) 763 (list-ref info 2)) 764 (and (not (discrete-get-heights c)) 765 (list-ref info 3))) 766 1 767 0))) 768 (define initial-position 769 (+ the-border 770 (if (zero? number-stretchable) 771 (if horizontal? 772 (case halign 773 [(right) (- w fixed-size)] 774 [(center) (round (/ (- w fixed-size) 2))] 775 [(left) 0]) 776 (case valign 777 [(bottom) (- h fixed-size)] 778 [(center) (round (/ (- h fixed-size) 2))] 779 [(top) 0])) 780 0))) 781 (define-values (stretchable-size stretchable-leftover) 782 (if (zero? number-stretchable) 783 (values 0 0) 784 (let ([total 785 (- (if horizontal? 786 w 787 h) 788 fixed-size)]) 789 (values (quotient total number-stretchable) 790 (modulo total number-stretchable))))) 791 (define (take-one) 792 (cond 793 [(zero? stretchable-leftover) 794 0] 795 [else 796 (set! stretchable-leftover (- stretchable-leftover 1)) 797 1])) 798 (let loop ([infos infos] 799 [children children] 800 [spot initial-position]) 801 (cond 802 [(null? infos) null] 803 [else 804 (define-values (min-w min-h h-stretch? v-stretch?) 805 (apply values (car infos))) 806 (define discrete-child? (if horizontal? 807 (discrete-get-widths (car children)) 808 (discrete-get-heights (car children)))) 809 (define this-one 810 (cond 811 [(and horizontal? h-stretch? (not discrete-child?)) 812 (list spot 813 (round (- (/ h 2) (/ min-h 2))) 814 (+ stretchable-size (take-one)) 815 min-h)] 816 [(and (not horizontal?) v-stretch? (not discrete-child?)) 817 (list (round (- (/ w 2) (/ min-w 2))) 818 spot 819 min-w 820 (+ stretchable-size (take-one)))] 821 [horizontal? 822 (define size (car fitting-sizes)) 823 (set! fitting-sizes (cdr fitting-sizes)) 824 (list spot 825 (round (- (/ h 2) (/ min-h 2))) 826 size 827 min-h)] 828 [else 829 (define size (car fitting-sizes)) 830 (set! fitting-sizes (cdr fitting-sizes)) 831 (list (round (- (/ w 2) (/ min-w 2))) 832 spot 833 min-w 834 size)])) 835 (cons this-one (loop (cdr infos) 836 (cdr children) 837 (+ spot 838 (if horizontal? 839 (list-ref this-one 2) 840 (list-ref this-one 3)))))]))) 841 842 (super-new))) 843 844 (define horizontal-discrete-sizes% 845 ;; extra wrapper to get the name right 846 (class (discrete-sizes-mixin panel%) 847 (super-new))) 848 (define vertical-discrete-sizes% 849 (class (discrete-sizes-mixin panel%) 850 (super-new) 851 (inherit set-orientation) 852 (set-orientation #f)))) 853 854 855 ;; candidate-sizes : (listof (listof number)) -> (listof (listof number)) 856 ;; in the input, the outer list corresponds to the children for a panel, 857 ;; and each inner list are the sizes that the children can take on. 858 ;; This function returns each possible configuration of sizes, starting 859 ;; with the largest for each and then shrinking each child one size 860 ;; at a time, starting from the earlier children in the list. 861 ;; Note that this will not try all combinations of sizes; once a child 862 ;; has been shrunk one size, larger sizes for that child will not be 863 ;; considered, and shrinking always proceeds from the left to the right. 864 (define (candidate-sizes lolon) 865 (define all-boxes (map (λ (x) (box (sort x >))) lolon)) 866 (define answer '()) 867 (define (record-current) 868 (set! answer (cons (map car (map unbox all-boxes)) answer))) 869 (for ([box (in-list all-boxes)]) 870 (for ([i (in-range (- (length (unbox box)) 1))]) 871 (record-current) 872 (set-box! box (cdr (unbox box))))) 873 (record-current) 874 (reverse answer)) 875 876 (module+ test 877 (require rackunit) 878 879 (define (log-em lolon) (candidate-sizes lolon)) 880 881 (check-equal? (log-em '((1))) 882 (list '(1))) 883 (check-equal? (log-em '((1) (2) (3))) 884 (list '(1 2 3))) 885 (check-equal? (log-em '((4 3 2 1))) 886 (list '(4) '(3) '(2) '(1))) 887 (check-equal? (log-em '((1 2 3 4))) 888 (list '(4) '(3) '(2) '(1))) 889 (check-equal? (log-em '((5 1) (6 2) (7 3))) 890 (list '(5 6 7) 891 '(1 6 7) 892 '(1 2 7) 893 '(1 2 3))) 894 (check-equal? (log-em '((10 9 8) (7 6 5))) 895 (list '(10 7) 896 '(9 7) 897 '(8 7) 898 '(8 6) 899 '(8 5))))