192 lines
7.3 KiB
Racket
192 lines
7.3 KiB
Racket
|
#lang racket/base
|
||
|
;; Tabular layout
|
||
|
|
||
|
(provide table-sizing
|
||
|
table-layout)
|
||
|
|
||
|
(require racket/match)
|
||
|
(require "sizing.rkt")
|
||
|
|
||
|
(module+ test (require rackunit))
|
||
|
|
||
|
;;---------------------------------------------------------------------------
|
||
|
|
||
|
(define (transpose rows)
|
||
|
(if (null? rows)
|
||
|
'()
|
||
|
(apply map list rows)))
|
||
|
|
||
|
(define (swedish-round x)
|
||
|
(floor (+ x 1/2)))
|
||
|
|
||
|
;;---------------------------------------------------------------------------
|
||
|
|
||
|
(define (table-sizing box-sizes)
|
||
|
(box-size (sizing-sum (table-column-widths box-sizes))
|
||
|
(sizing-sum (table-row-heights box-sizes))))
|
||
|
|
||
|
(define (table-row-heights box-sizes)
|
||
|
(map transverse-sizing (extract box-size-vertical box-sizes)))
|
||
|
|
||
|
(define (table-column-widths box-sizes)
|
||
|
(map transverse-sizing (extract box-size-horizontal (transpose box-sizes))))
|
||
|
|
||
|
(define (extract acc mtx)
|
||
|
(map (lambda (r) (map acc r)) mtx))
|
||
|
|
||
|
(define (transverse-sizing sizings)
|
||
|
(define-values (lb-v lb-f) (transverse-bound sizings sizing-shrink - max))
|
||
|
(define-values (ub-v ub-f) (transverse-bound sizings sizing-stretch + min))
|
||
|
(let* ((ideal-v (foldl max 0 (map sizing-ideal sizings)))
|
||
|
(ideal-v (if ub-v (min ideal-v ub-v) ideal-v))
|
||
|
(ideal-v (if lb-v (max ideal-v lb-v) ideal-v)))
|
||
|
(sizing ideal-v
|
||
|
(if ub-v (- ub-v ideal-v) ub-f)
|
||
|
(if lb-v (- ideal-v lb-v) lb-f))))
|
||
|
|
||
|
(define (transverse-bound sizings sizing-accessor minus-or-plus max-or-min)
|
||
|
(define vals (for/list [(s sizings) #:when (number? (sizing-accessor s))]
|
||
|
(minus-or-plus (sizing-ideal s) (sizing-accessor s))))
|
||
|
(values (and (pair? vals) (apply max-or-min vals))
|
||
|
(foldl fill-max 0 (filter fill? (map sizing-accessor sizings)))))
|
||
|
|
||
|
;;---------------------------------------------------------------------------
|
||
|
|
||
|
(define (table-layout box-sizes top left width height #:round [round? #t])
|
||
|
(define row-sizings (table-row-heights box-sizes))
|
||
|
(define col-sizings (table-column-widths box-sizes))
|
||
|
(define row-heights (compute-concrete-adjacent-sizes row-sizings height))
|
||
|
(define col-widths (compute-concrete-adjacent-sizes col-sizings width))
|
||
|
(define local-round (if round? swedish-round values))
|
||
|
(define-values (_bot rows-rev)
|
||
|
(for/fold [(top top) (rows-rev '())] [(row-height row-heights)]
|
||
|
(define next-top (+ top row-height))
|
||
|
(define rounded-top (local-round top))
|
||
|
(define rounded-height (- (local-round next-top) rounded-top))
|
||
|
(define-values (_right cells-rev)
|
||
|
(for/fold [(left left) (cells-rev '())] [(col-width col-widths)]
|
||
|
(define next-left (+ left col-width))
|
||
|
(define rounded-left (local-round left))
|
||
|
(define rounded-width (- (local-round next-left) rounded-left))
|
||
|
(values next-left
|
||
|
(cons (rectangle rounded-left
|
||
|
rounded-top
|
||
|
rounded-width
|
||
|
rounded-height)
|
||
|
cells-rev))))
|
||
|
(values next-top
|
||
|
(cons (reverse cells-rev) rows-rev))))
|
||
|
(reverse rows-rev))
|
||
|
|
||
|
(define (compute-concrete-adjacent-sizes sizings actual-bound)
|
||
|
(define ideal-total (foldl + 0 (map sizing-ideal sizings)))
|
||
|
(define-values (available-slop sizing-give apply-give)
|
||
|
(if (<= ideal-total actual-bound)
|
||
|
(values (- actual-bound ideal-total) sizing-stretch +)
|
||
|
(values (- ideal-total actual-bound) sizing-shrink -)))
|
||
|
(define total-give (foldl fill+ 0 (map sizing-give sizings)))
|
||
|
(if (number? total-give)
|
||
|
(let ((scale (if (zero? total-give) 0 (/ available-slop total-give))))
|
||
|
(map (lambda (s)
|
||
|
;; numeric total-give ⇒ no fills for any give in the list
|
||
|
(apply-give (sizing-ideal s) (* (sizing-give s) scale)))
|
||
|
sizings))
|
||
|
(let* ((weight (fill-weight total-give))
|
||
|
(rank (fill-rank total-give))
|
||
|
(scale (if (zero? weight) 0 (/ available-slop weight))))
|
||
|
(map (lambda (s)
|
||
|
(match (sizing-give s)
|
||
|
[(fill w (== rank)) (apply-give (sizing-ideal s) (* w scale))]
|
||
|
[_ (sizing-ideal s)]))
|
||
|
sizings))))
|
||
|
|
||
|
;;---------------------------------------------------------------------------
|
||
|
|
||
|
(module+ test
|
||
|
(check-equal? (transpose '((1 2 3) (4 5 6) (7 8 9))) '((1 4 7) (2 5 8) (3 6 9)))
|
||
|
(check-equal? (swedish-round 0.1) 0.0)
|
||
|
(check-equal? (swedish-round 0.5) 1.0)
|
||
|
(check-equal? (swedish-round 0.9) 1.0)
|
||
|
(check-equal? (swedish-round 1.1) 1.0)
|
||
|
(check-equal? (swedish-round 1.5) 2.0)
|
||
|
(check-equal? (swedish-round 1.9) 2.0))
|
||
|
|
||
|
(module+ test
|
||
|
(define s211 (sizing 2 1 1))
|
||
|
(define s0f0 (sizing 0 weak-fill 0))
|
||
|
(define b22 (box-size s211 s211))
|
||
|
(define b42 (box-size (sizing 4 1 1) s211))
|
||
|
(define b62 (box-size (sizing 6 1 1) s211))
|
||
|
(define b00 (box-size s0f0 s0f0))
|
||
|
|
||
|
(define t1 (list (list b22 b22 b00 b22)
|
||
|
(list b22 b22 b00 b22)
|
||
|
(list b22 b22 b00 b22)))
|
||
|
|
||
|
(define t2 (list (list b22 b22 b22)
|
||
|
(list b22 b00 b22)
|
||
|
(list b22 b22 b22)))
|
||
|
|
||
|
(define t3 (list (list b22 b42 b22)
|
||
|
(list b22 b00 b22)
|
||
|
(list b22 b22 b22)))
|
||
|
|
||
|
(define t4 (list (list b22 b62 b22)
|
||
|
(list b22 b00 b22)
|
||
|
(list b22 b22 b22)))
|
||
|
|
||
|
(check-equal? (table-sizing t1)
|
||
|
(box-size (sizing 6 weak-fill 3)
|
||
|
(sizing 6 3 3)))
|
||
|
|
||
|
(check-equal? (table-sizing t2)
|
||
|
(box-size (sizing 6 3 3)
|
||
|
(sizing 6 3 3)))
|
||
|
|
||
|
;; Is this sane?
|
||
|
(check-equal? (table-sizing t3)
|
||
|
(box-size (sizing 7 2 2)
|
||
|
(sizing 6 3 3)))
|
||
|
|
||
|
;; Is this sane?
|
||
|
(check-equal? (table-sizing t4)
|
||
|
(box-size (sizing 9 0 2)
|
||
|
(sizing 6 3 3)))
|
||
|
|
||
|
(check-equal? (table-layout t1 0 0 20 20)
|
||
|
(list (list (rectangle 0 0 2 7)
|
||
|
(rectangle 2 0 2 7)
|
||
|
(rectangle 4 0 14 7)
|
||
|
(rectangle 18 0 2 7))
|
||
|
(list (rectangle 0 7 2 6)
|
||
|
(rectangle 2 7 2 6)
|
||
|
(rectangle 4 7 14 6)
|
||
|
(rectangle 18 7 2 6))
|
||
|
(list (rectangle 0 13 2 7)
|
||
|
(rectangle 2 13 2 7)
|
||
|
(rectangle 4 13 14 7)
|
||
|
(rectangle 18 13 2 7))))
|
||
|
|
||
|
(check-equal? (table-layout t2 0 0 20 20)
|
||
|
(list (list (rectangle 0 0 7 7)
|
||
|
(rectangle 7 0 6 7)
|
||
|
(rectangle 13 0 7 7))
|
||
|
(list (rectangle 0 7 7 6)
|
||
|
(rectangle 7 7 6 6)
|
||
|
(rectangle 13 7 7 6))
|
||
|
(list (rectangle 0 13 7 7)
|
||
|
(rectangle 7 13 6 7)
|
||
|
(rectangle 13 13 7 7))))
|
||
|
|
||
|
;; Is this sane?
|
||
|
(check-equal? (table-layout t3 0 0 20 20)
|
||
|
(list (list (rectangle 0 0 9 7)
|
||
|
(rectangle 9 0 3 7)
|
||
|
(rectangle 12 0 8 7))
|
||
|
(list (rectangle 0 7 9 6)
|
||
|
(rectangle 9 7 3 6)
|
||
|
(rectangle 12 7 8 6))
|
||
|
(list (rectangle 0 13 9 7)
|
||
|
(rectangle 9 13 3 7)
|
||
|
(rectangle 12 13 8 7)))))
|