syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

weaken

This commit is contained in:
Tony Garnock-Jones 2016-09-12 12:44:22 -04:00
parent 3417d3d265
commit d6363a1f35
1 changed files with 70 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

99
racket/syndicate-ide/wm.rkt
View File

@ -151,11 +151,12 @@
(match-define (sizing v _ _) sv) (match-define (sizing v _ _) sv)
(define-values (lb-v lb-f) (transverse-bound sizings sizing-shrink - max)) (define-values (lb-v lb-f) (transverse-bound sizings sizing-shrink - max))
(define-values (ub-v ub-f) (transverse-bound sizings sizing-stretch + min)) (define-values (ub-v ub-f) (transverse-bound sizings sizing-stretch + min))
(define ideal-v (if v (define ideal-v (foldl max 0 (map sizing-ideal sizings)))
(cond [(and lb-v (> lb-v v)) lb-v] ;; (define ideal-v (if v
[(and ub-v (< ub-v v)) ub-v] ;; (cond [(and lb-v (> lb-v v)) lb-v]
[else v]) ;; [(and ub-v (< ub-v v)) ub-v]
(or lb-v 0))) ;; [else v])
;; (or lb-v 0)))
(sizing ideal-v (sizing ideal-v
(if ub-v (- ub-v ideal-v) ub-f) (if ub-v (- ub-v ideal-v) ub-f)
(if lb-v (- ideal-v lb-v) lb-f))) (if lb-v (- ideal-v lb-v) lb-f)))
@ -289,6 +290,35 @@
(match-define (list info t l w h) layout) (match-define (list info t l w h) layout)
(render! item info tty t l w h)))]) (render! item info tty t l w h)))])
(define (fill-weaken f w r)
(if (fill? f)
(fill w r)
f))
(define (sizing-weaken-fills 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)))
(struct weaken-fills (item weight rank) #:transparent
#:methods gen:tbox
[(define/generic sizings tbox-sizings)
(define/generic render! tbox-render!)
(define (tbox-sizings t sw sh)
(map (match-lambda
[(layout-option info w h)
(layout-option info
(sizing-weaken-fills w (weaken-fills-weight t) (weaken-fills-rank t))
(sizing-weaken-fills h (weaken-fills-weight t) (weaken-fills-rank t)))])
(sizings (weaken-fills-item t) sw sh)))
(define (tbox-render! t info tty top left width height)
(render! (weaken-fills-item t) info tty top left width height))])
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
(define (fill* w h rank) (define (fill* w h rank)
@ -308,10 +338,13 @@
(define (hbox . items) (adjacent-tbox #f (flatten items))) (define (hbox . items) (adjacent-tbox #f (flatten items)))
(define (vbox . items) (adjacent-tbox #t (flatten items))) (define (vbox . items) (adjacent-tbox #t (flatten items)))
(define (hpad item) (hbox (hfil) item (hfil))) (define (hpad item) (hbox (hfill) item (hfill)))
(define (vpad item) (vbox (vfil) item (vfil))) (define (vpad item) (vbox (vfill) item (vfill)))
(define (pad item) (vpad (hpad item))) (define (pad item) (vpad (hpad item)))
(define (weaken item [weight 1] [rank 0])
(weaken-fills item weight rank))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
(module+ main (module+ main
@ -327,30 +360,31 @@
(raise e)))] (raise e)))]
(tty-display tty "Ho ho ho\r\n") (tty-display tty "Ho ho ho\r\n")
(define R (glue-tbox (sizing 10 0 0) (sizing 5 0 0) ":" (pen color-white color-red #f #f))) (define R (glue-tbox (sizing 10 (fill 1 0) 0) (sizing 5 0 0) ":" (pen color-white color-red #f #f)))
(define G (glue-tbox (sizing 10 0 0) (sizing 5 0 0) ":" (pen color-white color-green #f #f))) (define G (glue-tbox (sizing 10 (fill 1 0) 0) (sizing 5 0 0) ":" (pen color-white color-green #f #f)))
(define B (glue-tbox (sizing 10 0 0) (sizing 5 0 0) ":" (pen color-white color-blue #f #f))) (define B (glue-tbox (sizing 10 (fill 1 0) 0) (sizing 5 0 0) ":" (pen color-white color-blue #f #f)))
(define (tbox-render-toplevel! widget tty)
(define w (tty-columns tty))
(define h (tty-rows tty))
(define layouts (tbox-sizings widget (sizing w (fill 1 0) w) (sizing h (fill 1 0) h)))
(tbox-render! widget (layout-option-info (car layouts)) tty 0 0 w h))
(define xpad values) (define xpad values)
(let ((widget (hbox (vbox (xpad R)
(pad G)
(xpad B))
(hfill)
(vbox R (vfil))
(hfill)
(vbox (vfil) G)
(hfill)
(pad B))))
(define (s v) (sizing v (fill 1 0) v))
(define layouts (tbox-sizings widget (s (tty-columns tty)) (s (tty-rows tty))))
(tbox-render! widget
(layout-option-info (car layouts))
tty
0
0
(tty-columns tty)
(tty-rows tty)))
(define toplevel-widget
(hbox (weaken (vbox (xpad R)
(pad G)
(xpad B)))
;; (hfill)
(vbox (weaken (hpad R)) (vfil))
;; (hfill)
(vbox (vfil) G)
;; (hfill)
(weaken (pad B))
))
(tbox-render-toplevel! toplevel-widget tty)
(tty-goto tty 0 0) (tty-goto tty 0 0)
(let loop () (let loop ()
@ -363,4 +397,11 @@
(tty-clear-to-eol tty) (tty-clear-to-eol tty)
(tty-display tty (format "~v" k)) (tty-display tty (format "~v" k))
(tty-goto tty (tty-cursor-row tty) 0) (tty-goto tty (tty-cursor-row tty) 0)
(loop)]))))))) (loop)])))))
;; (tty-shutdown!! tty)
;; (pretty-print toplevel-widget)
;; (pretty-print (tbox-sizings toplevel-widget
;; (sizing 80 (fill 1 0) 80)
;; (sizing 24 (fill 1 0) 24)))
))