Initial commit

This commit is contained in:
Tony Garnock-Jones 2016-09-25 15:07:06 -04:00
commit 08dd0f16d1
7 changed files with 755 additions and 0 deletions

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
compiled/

382
gui.rkt Normal file
View File

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

29
hsv.rkt Normal file
View File

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

191
layout/layout.rkt Normal file
View File

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

8
layout/main.rkt Normal file
View File

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

144
layout/sizing.rkt Normal file
View File

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

BIN
oakura-beach-20081225.jpg Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 483 KiB