269 lines
10 KiB
Racket
269 lines
10 KiB
Racket
#lang racket/base
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
|
;;; SPDX-FileCopyrightText: Copyright © 2017-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
|
|
|
(provide msd->pict
|
|
render)
|
|
|
|
(require (only-in racket/list partition last))
|
|
(require racket/match)
|
|
(require racket/math)
|
|
(require racket/set)
|
|
(require (only-in racket/string string-split))
|
|
|
|
(require preserves)
|
|
|
|
(require pict)
|
|
(require pict/color)
|
|
(require file/convertible)
|
|
|
|
(require "types.rkt")
|
|
|
|
;;---------------------------------------------------------------------------
|
|
|
|
(define N (* pi 1/2))
|
|
(define S (* pi -1/2))
|
|
(define E (* pi 0))
|
|
(define W (* pi 1))
|
|
|
|
(define NE (* pi 1/4))
|
|
(define SE (* pi -1/4))
|
|
(define NW (* pi 3/4))
|
|
(define SW (* pi -3/4))
|
|
|
|
(define ENE (* pi 1/8))
|
|
(define ESE (* pi -1/8))
|
|
(define WNW (* pi 7/8))
|
|
(define WSW (* pi -7/8))
|
|
|
|
;; A SwimlaneState is
|
|
;; - a (labelled-cell String ColorString SwimlaneState), representing
|
|
;; a fresh annotation on a possibly-new swimlane
|
|
;; - 'inactive, an occupied but inactive lane
|
|
;; - 'active, an occupied and active lane
|
|
;; - #f, an unoccupied lane
|
|
|
|
(struct labelled-cell (label color underlying-state) #:prefab)
|
|
|
|
(define (hash-set-or-remove h k v)
|
|
(if v
|
|
(hash-set h k v)
|
|
(hash-remove h k)))
|
|
|
|
(define (reset-label v)
|
|
(match v
|
|
[(labelled-cell _ _ underlying-state) underlying-state]
|
|
[_ v]))
|
|
|
|
(define (reset-statemap statemap)
|
|
(for/hash [((k v) (in-hash statemap))]
|
|
(values k (reset-label v))))
|
|
|
|
(define (transpose xs)
|
|
(apply map list xs))
|
|
|
|
(define (FR color w h)
|
|
(filled-rectangle #:color color #:draw-border? #f w h))
|
|
|
|
(define (should-label-row? row-number max-lane current-row)
|
|
(and (not (negative? row-number))
|
|
(for/or [(lane (+ max-lane 1))]
|
|
(labelled-cell? (hash-ref current-row lane #f)))))
|
|
|
|
(define (msd->pict m #:config [config (render-config)])
|
|
(match-define (msd max-lane all-events) m)
|
|
(define-values (connections events) (partition connection? all-events))
|
|
|
|
(define-values (_row-count statemaps)
|
|
(for/fold [(previous-row 0) (table (hash))]
|
|
[(event (in-list events))]
|
|
(define-values (pos new-state)
|
|
(match event
|
|
[(begin-swimlane pos)
|
|
(values pos 'inactive)]
|
|
[(activate-swimlane pos)
|
|
(values pos 'active)]
|
|
[(deactivate-swimlane pos)
|
|
(values pos 'inactive)]
|
|
[(end-swimlane pos)
|
|
(values pos #f)]
|
|
[(annotate-swimlane pos color annotation)
|
|
(values pos (list color annotation))]))
|
|
|
|
(match-define (diagram-position lane row) pos)
|
|
|
|
(define old-statemap
|
|
(hash-ref table row (lambda () (reset-statemap (hash-ref table previous-row hash)))))
|
|
|
|
(define new-statemap
|
|
(hash-set-or-remove old-statemap
|
|
lane
|
|
(match new-state
|
|
[(list color annotation)
|
|
(labelled-cell annotation color (hash-ref old-statemap lane 'inactive))]
|
|
[_ new-state])))
|
|
|
|
(values row (hash-set-or-remove table row (if (hash-empty? new-statemap) #f new-statemap)))))
|
|
|
|
(define (fill-out height p)
|
|
(ct-superimpose (blank (render-config-width config) height)
|
|
(if p
|
|
(inset p (* -1/2 (pict-width p)) 0)
|
|
(blank 0))))
|
|
|
|
(define (inactive height)
|
|
(FR "gray" (/ (render-config-active-width config) 2) height))
|
|
|
|
(define (render-underlay max-lane prev-row current-row next-row height)
|
|
(for/list [(lane (+ max-lane 1))]
|
|
(define prev-state (hash-ref prev-row lane #f))
|
|
(define next-state (hash-ref next-row lane #f))
|
|
(fill-out height
|
|
(match (match (hash-ref current-row lane #f)
|
|
[(labelled-cell s _ u) u]
|
|
[u u])
|
|
['inactive (inactive height)]
|
|
['active
|
|
(define (trunk height)
|
|
(hb-append 0
|
|
(FR "black" 1 height)
|
|
(FR (render-config-activation-color config) (- (render-config-active-width config) 2) height)
|
|
(FR "black" 1 height)))
|
|
(define bar (FR "black" (render-config-active-width config) 1))
|
|
(match* (prev-state next-state)
|
|
[('active 'active) (trunk height)]
|
|
[('active _) (vl-append 0 (trunk (- height 1)) bar)]
|
|
[(_ 'active) (vl-append 0 bar (trunk (- height 1)))]
|
|
[(_ _) (vl-append 0 bar (trunk (- height 2)) bar)])]
|
|
[#f (blank 0)]))))
|
|
|
|
(define (render-overlay max-lane current-row)
|
|
(for/list [(lane (+ max-lane 1))]
|
|
(fill-out (render-config-height config)
|
|
(match (hash-ref current-row lane #f)
|
|
[(labelled-cell s color u)
|
|
(define para (apply vl-append 0
|
|
(map (lambda (s)
|
|
(define limit 200)
|
|
(text (if (> (string-length s) limit)
|
|
(string-append (substring s 0 limit) "...")
|
|
s)
|
|
'modern))
|
|
(string-split s "\n"))))
|
|
(vc-append
|
|
(disk 4)
|
|
(frame
|
|
(cc-superimpose
|
|
(FR color (+ (pict-width para) 8) (+ (pict-height para) 8))
|
|
para)))]
|
|
[_ #f]))))
|
|
|
|
(define rows (sort (hash->list statemaps) < #:key car))
|
|
|
|
(define dummy-initial-row (cons (- (car (car rows)) 1) (hash)))
|
|
(define dummy-final-row (match (last rows)
|
|
[(cons final-row final-statemap)
|
|
(cons (+ final-row 1) (reset-statemap final-statemap))]))
|
|
(define row-triples
|
|
(map (lambda (a b c)
|
|
(list (car b)
|
|
(reset-statemap (cdr a))
|
|
(cdr b)
|
|
(reset-statemap (cdr c))))
|
|
(cons dummy-initial-row rows)
|
|
(append rows (list dummy-final-row))
|
|
(append (cdr rows) (list dummy-final-row dummy-final-row))))
|
|
|
|
(define over-and-unders
|
|
(map (match-lambda
|
|
[(list row-number prev-row current-row next-row)
|
|
(define overlay (render-overlay max-lane current-row))
|
|
(define height (+ (render-config-gap config) (apply max (map pict-height overlay))))
|
|
(define underlay (render-underlay max-lane prev-row current-row next-row height))
|
|
(list row-number
|
|
underlay
|
|
overlay
|
|
(should-label-row? row-number max-lane current-row))])
|
|
row-triples))
|
|
|
|
(define overlay-index (for/hash [(entry over-and-unders)]
|
|
(values (car entry) (caddr entry))))
|
|
|
|
(define base-pict
|
|
(apply vl-append 0
|
|
(map (lambda (over-and-under)
|
|
(hc-append (ct-superimpose (apply hb-append 4 (cadr over-and-under))
|
|
(apply hb-append 4 (caddr over-and-under)))
|
|
(if (and (render-config-number-steps? config) (cadddr over-and-under))
|
|
(let ((L (cc-superimpose
|
|
(circle 30)
|
|
(text (number->string (car over-and-under))))))
|
|
(hc-append (blank (render-config-number-gap config) 0)
|
|
(inset L
|
|
(- (pict-width L))
|
|
(- (pict-height L)))))
|
|
(blank 0))))
|
|
over-and-unders)))
|
|
|
|
(define (overlay-pict lane row)
|
|
(define picts (hash-ref overlay-index row '()))
|
|
(and (< lane (length picts)) (list-ref picts lane)))
|
|
|
|
(define (find-overlay lane row)
|
|
(or (for/or [(r (in-naturals row))] (overlay-pict lane r))
|
|
(for/or [(r (in-range (- row 1) -1 -1))] (overlay-pict lane r))))
|
|
|
|
(define unscaled-pict
|
|
(for/fold [(base-pict base-pict)]
|
|
[(c connections)]
|
|
(match-define (connection bidirectional?
|
|
(diagram-position from-lane from-row)
|
|
(diagram-position to-lane to-row))
|
|
c)
|
|
(define from-pict (find-overlay from-lane from-row))
|
|
(define to-pict (find-overlay to-lane to-row))
|
|
(if (and from-pict to-pict)
|
|
(if bidirectional?
|
|
(pin-arrows-line 10 base-pict
|
|
from-pict
|
|
(if (>= to-lane from-lane) rc-find lc-find)
|
|
to-pict
|
|
(if (>= to-lane from-lane) lc-find rc-find)
|
|
#:start-angle (if (>= to-lane from-lane) E W)
|
|
#:start-pull 1/10
|
|
#:end-angle (if (<= to-lane from-lane) W E)
|
|
#:end-pull 1/10)
|
|
(pin-arrow-line 10 base-pict
|
|
from-pict
|
|
cb-find
|
|
to-pict
|
|
ct-find
|
|
#:start-angle (if (>= to-lane from-lane) SE SW)
|
|
#:start-pull 1/10
|
|
#:end-angle (if (<= to-lane from-lane) SW SE)
|
|
#:end-pull 1/10))
|
|
base-pict)))
|
|
|
|
(scale unscaled-pict (render-config-scale config)))
|
|
|
|
(define (render p #:target target)
|
|
(define (final-border) 1)
|
|
(define final-pict (cc-superimpose (blank (+ (pict-width p) (* 2 (final-border)))
|
|
(+ (pict-height p) (* 2 (final-border))))
|
|
(panorama p)))
|
|
(case target
|
|
[(screen)
|
|
(local-require racket/gui/base)
|
|
(show-pict final-pict 800 600)
|
|
(void)]
|
|
[(png)
|
|
(display (convert final-pict 'png-bytes))]
|
|
[(png@2x)
|
|
(display (convert final-pict 'png@2x-bytes))]
|
|
[(svg)
|
|
(display (convert final-pict 'svg-bytes))]
|
|
[(eps)
|
|
(display (convert final-pict 'eps-bytes))]
|
|
[(pdf)
|
|
(display (convert final-pict 'pdf-bytes))]))
|