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

Fiddle with spacing of MSD renders

This commit is contained in:
Tony Garnock-Jones 2017-09-03 11:44:21 +01:00
parent 5ce1cec2ea
commit 6a436f4c12
1 changed files with 11 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
racket/syndicate/trace/render-msd.rkt
View File

@ -212,6 +212,9 @@
(define (transpose xs) (define (transpose xs)
(apply map list xs)) (apply map list xs))
(define (FR color w h)
(filled-rectangle #:color color #:draw-border? #f w h))
(define (render-underlay max-lane prev-row current-row next-row height) (define (render-underlay max-lane prev-row current-row next-row height)
(for/list [(lane (+ max-lane 1))] (for/list [(lane (+ max-lane 1))]
(define prev-state (hash-ref prev-row lane #f)) (define prev-state (hash-ref prev-row lane #f))
@ -220,20 +223,14 @@
(match (match (hash-ref current-row lane #f) (match (match (hash-ref current-row lane #f)
[(labelled-cell s _ u) u] [(labelled-cell s _ u) u]
[u u]) [u u])
['inactive (filled-rectangle #:color "gray" ['inactive (FR "gray" (/ ACTIVE-WIDTH 2) height)]
#:draw-border? #f
(/ ACTIVE-WIDTH 2)
height)]
['active ['active
(define (trunk height) (define (trunk height)
(hb-append 0 (hb-append 0
(vline 1 height) (FR "black" 1 height)
(filled-rectangle #:color "white" (FR "white" (- ACTIVE-WIDTH 2) height)
#:draw-border? #f (FR "black" 1 height)))
(- ACTIVE-WIDTH 2) (define bar (FR "black" ACTIVE-WIDTH 1))
height)
(vline 1 height)))
(define bar (hline (- ACTIVE-WIDTH 1) 1))
(match* (prev-state next-state) (match* (prev-state next-state)
[('active 'active) (trunk height)] [('active 'active) (trunk height)]
[('active _) (vl-append 0 (trunk (- height 1)) bar)] [('active _) (vl-append 0 (trunk (- height 1)) bar)]
@ -241,8 +238,8 @@
[(_ _) (vl-append 0 bar (trunk (- height 2)) bar)])] [(_ _) (vl-append 0 bar (trunk (- height 2)) bar)])]
['terminating ['terminating
(match next-state (match next-state
[#f (vc-append (vline 1 height #:segment 2) [#f (vc-append (vline 1 (- height 1) #:segment 2)
(hline (* ACTIVE-WIDTH 2) 1))] (hline (- (* ACTIVE-WIDTH 2) 1) 1))]
[_ (vline 1 height #:segment 2)])] [_ (vline 1 height #:segment 2)])]
[#f (blank 0)])))) [#f (blank 0)]))))
@ -263,10 +260,7 @@
(disk 4) (disk 4)
(frame (frame
(cc-superimpose (cc-superimpose
(filled-rectangle #:color color (FR color (+ (pict-width para) 8) (+ (pict-height para) 8))
#:draw-border? #f
(+ (pict-width para) 8)
(+ (pict-height para) 8))
para)))] para)))]
[_ #f])))) [_ #f]))))