syndicate-gui-2017/layout/layout.rkt

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)))))