Initial commit
This commit is contained in:
commit
08dd0f16d1
|
@ -0,0 +1 @@
|
||||||
|
compiled/
|
|
@ -0,0 +1,382 @@
|
||||||
|
#lang syndicate/actor
|
||||||
|
|
||||||
|
(require racket/set)
|
||||||
|
(require (prefix-in i: 2htdp/image))
|
||||||
|
(require (prefix-in p: pict))
|
||||||
|
(require syndicate-gl/2d)
|
||||||
|
(require "layout/main.rkt")
|
||||||
|
(require "hsv.rkt")
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(define theme-font (make-parameter "Roboto"))
|
||||||
|
(define theme-font-size (make-parameter 16))
|
||||||
|
(define theme-title-font (make-parameter "Roboto Condensed"))
|
||||||
|
(define theme-title-font-size (make-parameter 20))
|
||||||
|
(define theme-title-font-color (make-parameter "white"))
|
||||||
|
(define theme-title-bar-color (make-parameter (hsv->color 260 1 1)))
|
||||||
|
(define theme-title-bar-height (make-parameter 48))
|
||||||
|
(define theme-button-background-color (make-parameter (hsv->color 30 0.9 1)))
|
||||||
|
(define theme-button-color (make-parameter "white"))
|
||||||
|
(define theme-button-x-padding (make-parameter 40))
|
||||||
|
(define theme-button-y-padding (make-parameter 24))
|
||||||
|
(define theme-button-min-height (make-parameter 48))
|
||||||
|
(define theme-window-border-width (make-parameter 8))
|
||||||
|
(define theme-window-resize-corner-size (make-parameter 16))
|
||||||
|
(define theme-menu-item-color (make-parameter "white"))
|
||||||
|
(define theme-menu-item-background-color (make-parameter (hsv->color 240 1 0.8)))
|
||||||
|
(define theme-menu-item-selected-background-color (make-parameter (hsv->color 345 1 1)))
|
||||||
|
(define theme-menu-item-padding (make-parameter 16))
|
||||||
|
(define theme-menu-separator-width (make-parameter 2))
|
||||||
|
(define theme-menu-separator-color (make-parameter "white"))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(define (*width x)
|
||||||
|
(cond [(i:image? x) (i:image-width x)]
|
||||||
|
[(p:pict? x) (p:pict-width x)]
|
||||||
|
[else (error '*width "Neither an image nor a pict: ~v" x)]))
|
||||||
|
|
||||||
|
(define (*height x)
|
||||||
|
(cond [(i:image? x) (i:image-height x)]
|
||||||
|
[(p:pict? x) (p:pict-height x)]
|
||||||
|
[else (error '*height "Neither an image nor a pict: ~v" x)]))
|
||||||
|
|
||||||
|
(define (costume #:id [id #f] #:parent [parent-id #f] i)
|
||||||
|
(define iw (*width i))
|
||||||
|
(define ih (*height i))
|
||||||
|
(define iaspect (/ iw ih))
|
||||||
|
(lambda (z rect)
|
||||||
|
(match-define (rectangle left top sw sh) rect)
|
||||||
|
(define saspect (if (and (positive? sw) (positive? sh)) (/ sw sh) 1))
|
||||||
|
(define-values (scale-w scale-h translate-x translate-y)
|
||||||
|
(if (> saspect iaspect)
|
||||||
|
(let ((scale-h (/ sw iaspect)))
|
||||||
|
(values sw scale-h 0 (/ (- sh scale-h) 2)))
|
||||||
|
(let ((scale-w (* sh iaspect)))
|
||||||
|
(values scale-w sh (/ (- sw scale-w) 2) 0))))
|
||||||
|
(sprite #:id (or id (gensym 'costume))
|
||||||
|
#:parent parent-id
|
||||||
|
z
|
||||||
|
`((translate ,left ,top)
|
||||||
|
(push-matrix (scale ,sw ,sh)
|
||||||
|
,@(if id
|
||||||
|
`((touchable ,id ,in-unit-square?))
|
||||||
|
`())
|
||||||
|
(texture ,i
|
||||||
|
,(- (/ translate-x scale-w))
|
||||||
|
,(- (/ translate-y scale-h))
|
||||||
|
,(/ sw scale-w)
|
||||||
|
,(/ sh scale-h)
|
||||||
|
))
|
||||||
|
(render-children)))))
|
||||||
|
|
||||||
|
(define (draggable-mixin touching? x y z)
|
||||||
|
(define (idle)
|
||||||
|
(react (stop-when #:when (touching?)
|
||||||
|
(message (inbound (mouse-event 'left-down (mouse-state $mx $my _ _ _))))
|
||||||
|
(dragging (- mx (x)) (- my (y))))))
|
||||||
|
|
||||||
|
(define (dragging dx dy)
|
||||||
|
(z (- (current-inexact-milliseconds)))
|
||||||
|
(react (on (message (inbound (mouse-event 'motion (mouse-state $mx $my _ _ _))))
|
||||||
|
(x (- mx dx))
|
||||||
|
(y (- my dy)))
|
||||||
|
(stop-when (message (inbound (mouse-event 'left-up _))) (idle))
|
||||||
|
(stop-when (message (inbound (mouse-event 'leave _))) (idle))))
|
||||||
|
|
||||||
|
(idle))
|
||||||
|
|
||||||
|
(actor #:name 'root-window
|
||||||
|
(define c (costume #:id 'root (i:bitmap "oakura-beach-20081225.jpg")))
|
||||||
|
(define/query-value touching? #f (inbound (touching 'root)) #t)
|
||||||
|
(on #:when (touching?) (message (inbound (mouse-event 'right-down (mouse-state $x $y _ _ _))))
|
||||||
|
(send! (pop-up-menu-trigger 'system-menu x y 0 0.5 'right-up)))
|
||||||
|
(during (inbound (window $width $height))
|
||||||
|
(assert (outbound (c 0 (rectangle 0 0 width height))))))
|
||||||
|
|
||||||
|
(define (button-underlay i)
|
||||||
|
(define w (+ (*width i) (theme-button-x-padding)))
|
||||||
|
(define h (max (+ (*height i) (theme-button-y-padding)) (theme-button-min-height)))
|
||||||
|
(i:rectangle w h "solid" (theme-button-background-color)))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(struct pop-up-menu-trigger (menu-id x y x-pin y-pin release-event) #:transparent)
|
||||||
|
(struct menu-separator (menu-id order) #:transparent)
|
||||||
|
(struct menu-item (menu-id order image message) #:transparent)
|
||||||
|
|
||||||
|
(actor #:name 'pop-up-menu-driver
|
||||||
|
(on (message (pop-up-menu-trigger $menu-id $x $y $x-pin $y-pin $release-event))
|
||||||
|
(run-pop-up-menu menu-id x y x-pin y-pin release-event)))
|
||||||
|
|
||||||
|
(define (menu-item-order-key i)
|
||||||
|
(cond [(menu-item? i) (menu-item-order i)]
|
||||||
|
[(menu-separator? i) (menu-separator-order i)]))
|
||||||
|
|
||||||
|
(define (run-pop-up-menu menu-id pop-up-cursor-x pop-up-cursor-y x-pin y-pin release-event)
|
||||||
|
(define instance-id (list menu-id (gensym 'instance)))
|
||||||
|
(define pad (theme-menu-item-padding))
|
||||||
|
(define pad2 (* pad 2))
|
||||||
|
(define highlight (i:rectangle 1 1 "solid" (theme-menu-item-selected-background-color)))
|
||||||
|
(define separator (i:rectangle 1 1 "solid" (theme-menu-separator-color)))
|
||||||
|
(actor #:name instance-id
|
||||||
|
(define/query-set items ($ i (menu-item menu-id _ _ _)) i)
|
||||||
|
(define/query-set separators ($ s (menu-separator menu-id _)) s)
|
||||||
|
(define/dataflow ordered-items (sort (append (set->list (items))
|
||||||
|
(set->list (separators)))
|
||||||
|
< #:key menu-item-order-key)
|
||||||
|
#:default '())
|
||||||
|
(define/dataflow menu-table (for/list [(i (ordered-items))]
|
||||||
|
(match i
|
||||||
|
[(menu-item _ _ (seal im) _)
|
||||||
|
(list (box-size (sizing (+ pad2 (*width im)) 0 0)
|
||||||
|
(sizing (+ pad2 (*height im)) 0 0)))]
|
||||||
|
[(menu-separator _ _)
|
||||||
|
(list (box-size (sizing 0 weak-fill 0)
|
||||||
|
(sizing (theme-menu-separator-width) 0 0)))])))
|
||||||
|
(define/dataflow total-size (table-sizing (menu-table))
|
||||||
|
#:default zero-box-size)
|
||||||
|
(define (menu-width) (sizing-ideal (box-size-horizontal (total-size))))
|
||||||
|
(define (menu-height) (sizing-ideal (box-size-vertical (total-size))))
|
||||||
|
(define/dataflow layout (table-layout (menu-table) 0 0 (menu-width) (menu-height))
|
||||||
|
#:default '())
|
||||||
|
|
||||||
|
(define (render-menu)
|
||||||
|
(define offset-x (- pop-up-cursor-x (* x-pin (+ (menu-width) 2)) -1))
|
||||||
|
(define offset-y (- pop-up-cursor-y (* y-pin (+ (menu-height) 2)) -1))
|
||||||
|
(sprite #:id instance-id
|
||||||
|
-1
|
||||||
|
`((translate ,offset-x ,offset-y)
|
||||||
|
(push-matrix (scale ,(menu-width) ,(menu-height))
|
||||||
|
(texture ,(i:rectangle 1 1 "solid" (theme-menu-item-background-color))))
|
||||||
|
,@(for/list [(item (ordered-items)) (row (layout))]
|
||||||
|
(match-define (rectangle left top width height) (car row))
|
||||||
|
(match item
|
||||||
|
[(menu-item _ _ (seal im) _)
|
||||||
|
`(begin
|
||||||
|
(push-matrix (translate ,left ,top)
|
||||||
|
(scale ,width ,height)
|
||||||
|
(touchable (,instance-id ,(seal item)) ,in-unit-square?)
|
||||||
|
,@(if (eq? (selected-item) item)
|
||||||
|
`((texture ,highlight))
|
||||||
|
`()))
|
||||||
|
(push-matrix (translate ,(+ left pad) ,(+ top pad))
|
||||||
|
(scale ,(*width im) ,(*height im))
|
||||||
|
(texture ,im)))]
|
||||||
|
[(menu-separator _ _)
|
||||||
|
`(push-matrix (translate ,left ,top)
|
||||||
|
(scale ,width ,height)
|
||||||
|
(texture ,separator))]))
|
||||||
|
(render-children))))
|
||||||
|
|
||||||
|
(define/query-value selected-item* #f (inbound (touching `(,instance-id ,$sealed-item)))
|
||||||
|
(seal-contents sealed-item))
|
||||||
|
(field [selected-item #f])
|
||||||
|
(begin/dataflow (when (not (eq? (selected-item) (selected-item*)))
|
||||||
|
(selected-item (selected-item*))))
|
||||||
|
|
||||||
|
(assert (outbound (render-menu)))
|
||||||
|
(stop-when (message (inbound (mouse-event release-event _)))
|
||||||
|
(when (selected-item)
|
||||||
|
(send! (menu-item-message (selected-item)))))
|
||||||
|
(on (asserted ($ s (mouse-state _ _ _ _ _)))
|
||||||
|
(log-info "MENU ~v: ~v" menu-id s))))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(define (system-text str [color #f])
|
||||||
|
(i:text/font str (theme-font-size) (or color "white")
|
||||||
|
(theme-font) 'default 'normal 'normal #f))
|
||||||
|
|
||||||
|
(define (title-font-text str)
|
||||||
|
(i:text/font str (theme-title-font-size) (theme-title-font-color)
|
||||||
|
(theme-title-font) 'default 'normal 'normal #f))
|
||||||
|
|
||||||
|
(define (menu-item/text menu-id order str message)
|
||||||
|
(menu-item menu-id order (seal (system-text str (theme-menu-item-color))) message))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(struct window-state (window-id state) #:transparent)
|
||||||
|
(struct raise-widget (id) #:transparent)
|
||||||
|
|
||||||
|
(define close-icon-i
|
||||||
|
(parameterize ((theme-font-size (round (* 4/3 (theme-title-font-size)))))
|
||||||
|
(system-text "×" (theme-title-font-color))))
|
||||||
|
|
||||||
|
(define (window-frame id title backdrop-color
|
||||||
|
#:close-icon? [close-icon? #t]
|
||||||
|
#:parent [parent-id 'root])
|
||||||
|
(define title-text-i (title-font-text title))
|
||||||
|
(define title-text-w (i:image-width title-text-i))
|
||||||
|
(define title-text-h (i:image-height title-text-i))
|
||||||
|
(define title-bar-i (i:rectangle 1 1 "solid" (theme-title-bar-color)))
|
||||||
|
(define close-icon-w (i:image-width close-icon-i))
|
||||||
|
(define close-icon-h (i:image-height close-icon-i))
|
||||||
|
(define gap (/ (- (theme-title-bar-height) close-icon-w) 2))
|
||||||
|
(define backdrop (i:rectangle 1 1 "solid" backdrop-color))
|
||||||
|
(lambda (z rect)
|
||||||
|
(match-define (rectangle left top width height) rect)
|
||||||
|
(sprite #:id id
|
||||||
|
#:parent parent-id
|
||||||
|
z
|
||||||
|
`((translate ,left ,top)
|
||||||
|
(push-matrix (translate ,(- (theme-window-border-width))
|
||||||
|
,(- (theme-title-bar-height)))
|
||||||
|
(scale ,(+ width (* 2 (theme-window-border-width)))
|
||||||
|
,(+ height (theme-title-bar-height) (theme-window-border-width)))
|
||||||
|
(touchable (,id window-backdrop) ,in-unit-square?)
|
||||||
|
(texture ,title-bar-i))
|
||||||
|
(push-matrix (translate 0 ,(- (theme-title-bar-height)))
|
||||||
|
(scale ,width ,(theme-title-bar-height))
|
||||||
|
(touchable (,id title-bar) ,in-unit-square?))
|
||||||
|
(push-matrix (translate ,(- (+ width (theme-window-border-width))
|
||||||
|
(theme-window-resize-corner-size))
|
||||||
|
,(- (+ height (theme-window-border-width))
|
||||||
|
(theme-window-resize-corner-size)))
|
||||||
|
(scale ,(theme-window-resize-corner-size)
|
||||||
|
,(theme-window-resize-corner-size))
|
||||||
|
(touchable (,id resize-corner) ,in-unit-square?))
|
||||||
|
,@(if close-icon?
|
||||||
|
`((push-matrix
|
||||||
|
(translate ,gap ,(- (/ (+ (theme-title-bar-height) close-icon-h) 2)))
|
||||||
|
(scale ,close-icon-w ,close-icon-h)
|
||||||
|
(touchable (,id close-icon) ,in-unit-square?)
|
||||||
|
(texture ,close-icon-i)))
|
||||||
|
`())
|
||||||
|
(push-matrix (translate ,(/ (- width title-text-w) 2)
|
||||||
|
,(- (/ (+ (theme-title-bar-height) title-text-h) 2)))
|
||||||
|
(scale ,title-text-w ,title-text-h)
|
||||||
|
(texture ,title-text-i))
|
||||||
|
(push-matrix (scale ,width ,height)
|
||||||
|
(texture ,backdrop))
|
||||||
|
(render-children)))))
|
||||||
|
|
||||||
|
(define (open-window window-id window-title x y width height [backdrop-color (hsv->color 200 1 1)]
|
||||||
|
#:resizable? [resizable? #t])
|
||||||
|
(define c (window-frame window-id window-title backdrop-color))
|
||||||
|
|
||||||
|
(field [z (- (current-inexact-milliseconds))])
|
||||||
|
(define/query-value touching-title-bar?
|
||||||
|
#f (inbound (touching `(,window-id title-bar))) #t)
|
||||||
|
(on-start (draggable-mixin touching-title-bar? x y z))
|
||||||
|
|
||||||
|
(when resizable?
|
||||||
|
(define/query-value touching-resize-corner?
|
||||||
|
#f (inbound (touching `(,window-id resize-corner))) #t)
|
||||||
|
(on-start (draggable-mixin touching-resize-corner? width height z)))
|
||||||
|
|
||||||
|
(define/query-value touching-close-icon?
|
||||||
|
#f (inbound (touching `(,window-id close-icon))) #t)
|
||||||
|
(stop-when #:when (touching-close-icon?) (message (inbound (mouse-event 'left-up _))))
|
||||||
|
|
||||||
|
(on (message (raise-widget window-id))
|
||||||
|
(z (- (current-inexact-milliseconds))))
|
||||||
|
|
||||||
|
(define/dataflow bounds (rectangle (x) (y) (width) (height)) #:default zero-rectangle)
|
||||||
|
(assert (window-state window-id (bounds)))
|
||||||
|
(assert (outbound (c (z) (bounds)))))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(struct button-click (id mouse-state) #:transparent)
|
||||||
|
|
||||||
|
(begin-for-declarations
|
||||||
|
;; TODO: figure out what it is about (define (f #:x x) x) that
|
||||||
|
;; mandates begin-for-declarations to hide it from syndicate/lang's
|
||||||
|
;; local-expansion here :-(
|
||||||
|
(define (pushbutton label-str x y
|
||||||
|
#:id id
|
||||||
|
#:parent parent-id
|
||||||
|
#:trigger-event [trigger-event 'left-up])
|
||||||
|
(define label (system-text label-str (theme-button-color)))
|
||||||
|
(define i (i:overlay/align "middle" "middle" label (button-underlay label)))
|
||||||
|
(define c (costume #:id id #:parent parent-id i))
|
||||||
|
|
||||||
|
(define/query-value touching? #f (inbound (touching id)) #t)
|
||||||
|
(on #:when (touching?) (message (inbound (mouse-event trigger-event $s)))
|
||||||
|
(send! (button-click id s)))
|
||||||
|
(assert (outbound (c 0 (rectangle x y (*width i) (*height i)))))))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(define (enforce-minimum f v)
|
||||||
|
(begin/dataflow (when (< (f) v) (f v))))
|
||||||
|
|
||||||
|
(begin-for-declarations
|
||||||
|
(define (message-box title init-x init-y body #:id id)
|
||||||
|
(define msg (system-text body))
|
||||||
|
(actor #:name (list 'message-box id)
|
||||||
|
(field [x init-x]
|
||||||
|
[y init-y]
|
||||||
|
[width (max 250 (*width msg))]
|
||||||
|
[height (max 100 (*height msg))])
|
||||||
|
(open-window id title x y width height #:resizable? #f)
|
||||||
|
(assert (outbound ((costume #:parent id msg)
|
||||||
|
0
|
||||||
|
(rectangle (/ (- (width) (*width msg)) 2)
|
||||||
|
(/ (- (height) (*height msg)) 2)
|
||||||
|
(*width msg)
|
||||||
|
(*height msg))))))))
|
||||||
|
|
||||||
|
(actor #:name 'test-window
|
||||||
|
|
||||||
|
(field [x 140] [y 140] [width 400] [height 300])
|
||||||
|
(open-window 'w "Window Title" x y width height)
|
||||||
|
(enforce-minimum width 300)
|
||||||
|
(enforce-minimum height 300)
|
||||||
|
|
||||||
|
(assert (menu-item/text 'testmenu 0 "First item" '(testmenu first)))
|
||||||
|
(assert (menu-item/text 'testmenu 1 "Second item" '(testmenu second)))
|
||||||
|
(assert (menu-item/text 'testmenu 2 "Third item" '(testmenu third)))
|
||||||
|
|
||||||
|
(during (inbound (window $width $height))
|
||||||
|
(on (message `(testmenu ,$which))
|
||||||
|
(define box-id (gensym 'box))
|
||||||
|
(message-box #:id box-id
|
||||||
|
"Menu item selected" (random width) (random height)
|
||||||
|
(format "~a" which))))
|
||||||
|
|
||||||
|
(pushbutton "Click me" 100 100 #:id 'click-me #:parent 'w #:trigger-event 'left-down)
|
||||||
|
(on (message (button-click 'click-me (mouse-state $x $y _ _ _)))
|
||||||
|
(send! (pop-up-menu-trigger 'testmenu x y 0 0.5 'left-up))))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
(actor #:name 'fullscreen-menu-item
|
||||||
|
(field [fullscreen? #t])
|
||||||
|
(assert (menu-item/text 'system-menu -1
|
||||||
|
(if (fullscreen?)
|
||||||
|
"Fullscreen ✓"
|
||||||
|
"Fullscreen")
|
||||||
|
'(system-menu toggle-fullscreen)))
|
||||||
|
(assert (menu-separator 'system-menu -0.9))
|
||||||
|
(on (message '(system-menu toggle-fullscreen))
|
||||||
|
(fullscreen? (not (fullscreen?))))
|
||||||
|
(assert #:when (fullscreen?) (outbound 'fullscreen)))
|
||||||
|
|
||||||
|
(actor #:name 'quit-menu-item
|
||||||
|
(assert (menu-item/text 'system-menu 0 "Quit" '(system-menu quit)))
|
||||||
|
(stop-when (message '(system-menu quit))
|
||||||
|
(actor (assert (outbound 'stop))))
|
||||||
|
(stop-when (message (inbound (key-event #\q #t _)))
|
||||||
|
(actor (assert (outbound 'stop)))))
|
||||||
|
|
||||||
|
;; (actor #:name 'toolbar
|
||||||
|
|
||||||
|
;; (field [window-width 0] [window-height 0])
|
||||||
|
;; (on (asserted (inbound (window $w $h)))
|
||||||
|
;; (window-width w)
|
||||||
|
;; (window-height h))
|
||||||
|
|
||||||
|
;; (assert (outbound ((costume #:id 'toolbar #:parent #f
|
||||||
|
;; (i:rectangle 1 1 "solid" "black"))
|
||||||
|
;; -0.5
|
||||||
|
;; (rectangle 0
|
||||||
|
;; (- (window-height) (theme-title-bar-height))
|
||||||
|
;; (window-width)
|
||||||
|
;; (theme-title-bar-height))))))
|
||||||
|
|
||||||
|
(module+ main
|
||||||
|
(current-ground-dataspace (2d-dataspace)))
|
|
@ -0,0 +1,29 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide fmod
|
||||||
|
hsv->color
|
||||||
|
color-by-hash)
|
||||||
|
|
||||||
|
(require 2htdp/image)
|
||||||
|
|
||||||
|
(define (fmod a b)
|
||||||
|
(- a (* b (truncate (/ a b)))))
|
||||||
|
|
||||||
|
(define (hsv->color h s v)
|
||||||
|
(define h* (fmod (/ h 60.0) 6))
|
||||||
|
(define chroma (* v s))
|
||||||
|
(define x (* chroma (- 1 (abs (- (fmod h* 2) 1)))))
|
||||||
|
(define-values (r g b)
|
||||||
|
(cond
|
||||||
|
[(< h* 1) (values chroma x 0)]
|
||||||
|
[(< h* 2) (values x chroma 0)]
|
||||||
|
[(< h* 3) (values 0 chroma x)]
|
||||||
|
[(< h* 4) (values 0 x chroma)]
|
||||||
|
[(< h* 5) (values x 0 chroma)]
|
||||||
|
[else (values chroma 0 x)]))
|
||||||
|
(define m (- v chroma))
|
||||||
|
(define (scale x) (inexact->exact (truncate (* 255 (+ x m)))))
|
||||||
|
(make-color (scale r) (scale g) (scale b)))
|
||||||
|
|
||||||
|
(define (color-by-hash v)
|
||||||
|
(hsv->color (* 360.0 (/ (bitwise-and (equal-hash-code v) 16777215) 16777216.0)) 1 1))
|
|
@ -0,0 +1,191 @@
|
||||||
|
#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)))))
|
|
@ -0,0 +1,8 @@
|
||||||
|
#lang racket/base
|
||||||
|
;; Layout, based loosely on TeX's boxes-and-glue model.
|
||||||
|
|
||||||
|
(require "sizing.rkt")
|
||||||
|
(require "layout.rkt")
|
||||||
|
|
||||||
|
(provide (all-from-out "sizing.rkt")
|
||||||
|
(all-from-out "layout.rkt"))
|
|
@ -0,0 +1,144 @@
|
||||||
|
#lang racket/base
|
||||||
|
;; Dimension sizing, based loosely on TeX's boxes-and-glue model.
|
||||||
|
|
||||||
|
(provide (struct-out fill)
|
||||||
|
(struct-out sizing)
|
||||||
|
(struct-out box-size)
|
||||||
|
(struct-out rectangle)
|
||||||
|
|
||||||
|
weak-fill
|
||||||
|
zero-sizing
|
||||||
|
zero-box-size
|
||||||
|
zero-rectangle
|
||||||
|
|
||||||
|
fill+
|
||||||
|
fill-max
|
||||||
|
fill-min
|
||||||
|
fill-scale
|
||||||
|
fill-weaken
|
||||||
|
|
||||||
|
sizing-contains?
|
||||||
|
sizing-min
|
||||||
|
sizing-max
|
||||||
|
sizing-overlap?
|
||||||
|
sizing-scale
|
||||||
|
sizing-weaken
|
||||||
|
sizing-pad
|
||||||
|
sizing-adjust-ideal
|
||||||
|
sizing-sum
|
||||||
|
|
||||||
|
box-size-weaken)
|
||||||
|
|
||||||
|
(require racket/match)
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
;; A Fill is one of
|
||||||
|
;; - a Nat, a fixed amount of space
|
||||||
|
;; - a (fill Nat Nat), a potentially infinite amount of space
|
||||||
|
(struct fill (weight rank) #:transparent)
|
||||||
|
|
||||||
|
;; A Sizing is a (sizing Nat Fill Fill)
|
||||||
|
(struct sizing (ideal stretch shrink) #:transparent)
|
||||||
|
|
||||||
|
;; A BoxSize is a (box-size Sizing Sizing)
|
||||||
|
(struct box-size (horizontal vertical) #:transparent)
|
||||||
|
|
||||||
|
;; A Rectangle is a (rectangle Nat Nat BoxSize)
|
||||||
|
(struct rectangle (left top width height) #:transparent)
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
;; A very weak fill.
|
||||||
|
(define weak-fill (fill 1 -1))
|
||||||
|
|
||||||
|
(define zero-sizing (sizing 0 0 0))
|
||||||
|
|
||||||
|
(define zero-box-size (box-size zero-sizing zero-sizing))
|
||||||
|
|
||||||
|
(define zero-rectangle (rectangle 0 0 0 0))
|
||||||
|
|
||||||
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
|
;; (Nat Nat -> Nat) -> (Fill Fill -> Fill)
|
||||||
|
(define ((fill-binop op) a b)
|
||||||
|
(match* (a b)
|
||||||
|
[((? number?) (? number?)) (op a b)]
|
||||||
|
[((? number?) (? fill?)) b]
|
||||||
|
[((? fill?) (? number?)) a]
|
||||||
|
[((fill w1 r1) (fill w2 r2))
|
||||||
|
(cond [(= r1 r2) (fill (op w1 w2) r1)]
|
||||||
|
[(> r1 r2) (fill w1 r1)]
|
||||||
|
[(< r1 r2) (fill w2 r2)])]))
|
||||||
|
|
||||||
|
;; Fill Fill -> Fill
|
||||||
|
(define fill+ (fill-binop +))
|
||||||
|
(define fill-max (fill-binop max))
|
||||||
|
(define (fill-min a b)
|
||||||
|
(if (and (number? a) (number? b))
|
||||||
|
(min a b)
|
||||||
|
0))
|
||||||
|
|
||||||
|
(define (fill-scale f scale)
|
||||||
|
(if (number? f)
|
||||||
|
(* f scale)
|
||||||
|
f))
|
||||||
|
|
||||||
|
(define (fill-weaken f w r)
|
||||||
|
(if (fill? f)
|
||||||
|
(fill w r)
|
||||||
|
f))
|
||||||
|
|
||||||
|
(define (sizing-contains? s v)
|
||||||
|
(match-define (sizing x x+ x-) s)
|
||||||
|
(cond [(>= v x) (if (number? x+) (<= v (+ x x+)) #t)]
|
||||||
|
[(<= v x) (if (number? x-) (>= v (- x x-)) #t)]))
|
||||||
|
|
||||||
|
(define (sizing-min s)
|
||||||
|
(match (sizing-shrink s)
|
||||||
|
[(? number? n) (- (sizing-ideal s) n)]
|
||||||
|
[(? fill?) -inf.0]))
|
||||||
|
|
||||||
|
(define (sizing-max s)
|
||||||
|
(match (sizing-stretch s)
|
||||||
|
[(? number? n) (+ (sizing-ideal s) n)]
|
||||||
|
[(? fill?) +inf.0]))
|
||||||
|
|
||||||
|
(define (sizing-overlap? x y)
|
||||||
|
(define largest-min (max (sizing-min x) (sizing-min y)))
|
||||||
|
(define smallest-max (min (sizing-max x) (sizing-max y)))
|
||||||
|
(< largest-min smallest-max))
|
||||||
|
|
||||||
|
(define (sizing-scale s scale)
|
||||||
|
(match-define (sizing x x+ x-) s)
|
||||||
|
(sizing (* x scale) (fill-scale x+ scale) (fill-scale x- scale)))
|
||||||
|
|
||||||
|
(define (sizing-weaken s
|
||||||
|
[stretch-weight 1]
|
||||||
|
[stretch-rank 0]
|
||||||
|
[shrink-weight stretch-weight]
|
||||||
|
[shrink-rank stretch-rank])
|
||||||
|
(match-define (sizing x x+ x-) s)
|
||||||
|
(sizing x
|
||||||
|
(fill-weaken x+ stretch-weight stretch-rank)
|
||||||
|
(fill-weaken x- shrink-weight shrink-rank)))
|
||||||
|
|
||||||
|
(define (sizing-pad s amount)
|
||||||
|
(match-define (sizing x x+ x-) s)
|
||||||
|
(sizing (+ x amount) x+ x-))
|
||||||
|
|
||||||
|
(define (sizing-adjust-ideal s i)
|
||||||
|
(match-define (sizing x x+ x-) s)
|
||||||
|
(sizing i
|
||||||
|
(if (fill? x+) x+ (+ x+ (- x i)))
|
||||||
|
(if (fill? x-) x- (- x- (- x i)))))
|
||||||
|
|
||||||
|
(define (sizing-sum sizings)
|
||||||
|
(sizing (foldl + 0 (map sizing-ideal sizings))
|
||||||
|
(foldl fill+ 0 (map sizing-stretch sizings))
|
||||||
|
(foldl fill+ 0 (map sizing-shrink sizings))))
|
||||||
|
|
||||||
|
(define (box-size-weaken bs [weight 1] [rank 0])
|
||||||
|
(match-define (box-size h v) bs)
|
||||||
|
(box-size (sizing-weaken h weight rank)
|
||||||
|
(sizing-weaken v weight rank)))
|
Binary file not shown.
After Width: | Height: | Size: 483 KiB |
Loading…
Reference in New Issue