MSD ("message sequence diagram"/trace) renderer, based on some of my PhD code
This commit is contained in:
parent
1b9eddc0b6
commit
2fe0d24911
2
Makefile
2
Makefile
|
|
@ -1,6 +1,6 @@
|
|||
__ignored__ := $(shell ./setup.sh)
|
||||
|
||||
PACKAGES=syndicate syndicate-examples
|
||||
PACKAGES=syndicate syndicate-examples syndicate-msd
|
||||
COLLECTS=syndicate syndicate-examples
|
||||
|
||||
all: setup
|
||||
|
|
|
|||
|
|
@ -0,0 +1,36 @@
|
|||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||
;;; SPDX-FileCopyrightText: Copyright © 2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||
|
||||
#lang setup/infotab
|
||||
(define collection 'multi)
|
||||
|
||||
(define deps '(
|
||||
|
||||
"base"
|
||||
|
||||
"syndicate"
|
||||
"preserves"
|
||||
|
||||
"struct-defaults"
|
||||
|
||||
;; "bitsyntax"
|
||||
;; "packet-socket"
|
||||
;; "compatibility-lib"
|
||||
;; "data-lib"
|
||||
;; "gui-lib"
|
||||
;; "htdp-lib"
|
||||
;; "images-lib"
|
||||
;; "net-lib"
|
||||
;; "pict-lib"
|
||||
;; "plot-lib"
|
||||
;; "srfi-lite-lib"
|
||||
|
||||
))
|
||||
|
||||
;; (define build-deps '("rackunit-lib"))
|
||||
|
||||
(define racket-launcher-names
|
||||
'("syndicate-render-msd"))
|
||||
|
||||
(define racket-launcher-libraries
|
||||
'("syndicate/msd/bin/syndicate-render-msd.rkt"))
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
#lang racket
|
||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||
;;; SPDX-FileCopyrightText: Copyright © 2017-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||
|
||||
(module+ main
|
||||
(require racket/cmdline)
|
||||
(require "../types.rkt")
|
||||
(require "../read.rkt")
|
||||
(require "../render.rkt")
|
||||
|
||||
(define config (render-config))
|
||||
(define *target* 'screen)
|
||||
|
||||
(define-syntax-rule (! [fld val] ...)
|
||||
(set! config (struct-copy <render-config> config [fld val] ...)))
|
||||
|
||||
(define filename
|
||||
(command-line
|
||||
#:once-each
|
||||
[("-s" "--scale") scale "Rescales output; 1 = 100%"
|
||||
(! [scale (string->number scale)])]
|
||||
[("-t" "--target") target "Choose target: screen, png, png@2x, svg, eps, pdf"
|
||||
(set! *target* (string->symbol target))]
|
||||
[("--width") width ((format "Width of swimlane cells (default: ~a)"
|
||||
(render-config-width config)))
|
||||
(! [width (string->number width)])]
|
||||
[("--height") height ((format "Minimum height of rows (default: ~a)"
|
||||
(render-config-width config)))
|
||||
(! [height (string->number height)])]
|
||||
[("--gap") gap ((format "Extra space between rows (default: ~a)" (render-config-gap config)))
|
||||
(! [gap (string->number gap)])]
|
||||
[("--number") "Enables step numbering"
|
||||
(! [number-steps? #t])]
|
||||
[("--no-number") "Disables step numbering"
|
||||
(! [number-steps? #f])]
|
||||
[("--number-gap") number-gap ((format "Extra space to row numbers (default: ~a)"
|
||||
(render-config-number-gap config)))
|
||||
(! [number-gap (string->number number-gap)])]
|
||||
#:args (filename)
|
||||
filename))
|
||||
|
||||
(define (read-input port)
|
||||
(read-msd port #:config config))
|
||||
|
||||
(define msd (if (equal? filename "-")
|
||||
(read-input (current-input-port))
|
||||
(call-with-input-file filename read-input)))
|
||||
|
||||
(render (msd->pict msd #:config config)
|
||||
#:target *target*))
|
||||
|
|
@ -0,0 +1,220 @@
|
|||
#lang racket/base
|
||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||
;;; SPDX-FileCopyrightText: Copyright © 2017-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||
|
||||
(provide read-msd)
|
||||
|
||||
(require (only-in racket/format ~a ~r))
|
||||
(require (only-in racket/list flatten))
|
||||
(require racket/match)
|
||||
(require racket/set)
|
||||
|
||||
(require preserves)
|
||||
(require preserves-schema/methods)
|
||||
(require syndicate/schemas/trace)
|
||||
(require (prefix-in P: syndicate/schemas/protocol))
|
||||
(require "types.rkt")
|
||||
|
||||
(define (read-msd port #:config [config (render-config)])
|
||||
(define max-lane -1)
|
||||
(define logical-time 1)
|
||||
(define swimlane-map (make-hash))
|
||||
(define turn-map (make-hash))
|
||||
(define handle-map (make-hash))
|
||||
(define events-rev '())
|
||||
|
||||
(define (emit! e)
|
||||
(when e
|
||||
(set! logical-time (+ logical-time 1))
|
||||
(set! events-rev (cons e events-rev))))
|
||||
|
||||
(define (find-unused-lane swimlane-map)
|
||||
(let ((used-lanes (list->set (hash-values swimlane-map))))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((not (set-member? used-lanes i)) i))))
|
||||
|
||||
(define (translate! actor-id [moment logical-time])
|
||||
(define new? #f)
|
||||
(define p (diagram-position (hash-ref! swimlane-map
|
||||
actor-id
|
||||
(lambda ()
|
||||
(define lane (find-unused-lane swimlane-map))
|
||||
(when (> lane max-lane) (set! max-lane lane))
|
||||
(set! new? #t)
|
||||
lane))
|
||||
moment))
|
||||
(when new? (emit! (begin-swimlane p)))
|
||||
p)
|
||||
|
||||
(define (vacate-lane! actor-id)
|
||||
(hash-remove! swimlane-map actor-id))
|
||||
|
||||
(define (turn-actor turn-id)
|
||||
(car (hash-ref turn-map turn-id)))
|
||||
|
||||
(define (turn-moment turn-id)
|
||||
(cdr (hash-ref turn-map turn-id)))
|
||||
|
||||
(define (connection* #:bidirectional? [bidirectional? #f] source-actor-id sink-actor-id)
|
||||
(and source-actor-id
|
||||
(connection bidirectional?
|
||||
(translate! source-actor-id)
|
||||
(translate! sink-actor-id))))
|
||||
|
||||
(define (format-turn-label actor-id turn-id turn-cause)
|
||||
(define sub-label
|
||||
(match turn-cause
|
||||
[(TurnCause-turn other)
|
||||
(emit! (connection #f
|
||||
(translate! (turn-actor other) (turn-moment other))
|
||||
(translate! actor-id)))
|
||||
(format "caused by ~a" (~turn other))]
|
||||
[(TurnCause-cleanup)
|
||||
"cleanup"]
|
||||
[(TurnCause-linkedTaskRelease task reason)
|
||||
(format "task ~a ended: ~a" task (->preserve reason))]
|
||||
[(TurnCause-periodicActivation period)
|
||||
(format "timer: every ~as" period)]
|
||||
[(TurnCause-delay other-turn delay-amount)
|
||||
(emit! (connection* (turn-actor other-turn) actor-id))
|
||||
(format "delay: ~as" delay-amount)]
|
||||
[(TurnCause-external desc)
|
||||
(format "external: ~a" desc)]))
|
||||
(format "~a: ~a" (~turn turn-id) sub-label))
|
||||
|
||||
(define (~actor-id a)
|
||||
(~a (ActorId-value a)))
|
||||
|
||||
(define (~turn t)
|
||||
(format "#~a" (TurnId-value t)))
|
||||
|
||||
(define (~target e)
|
||||
(match-define (Target actor-id facet-id oid) e)
|
||||
(format "~a/~a:~a"
|
||||
(~actor-id actor-id)
|
||||
(FacetId-value facet-id)
|
||||
(let ((oid (Oid-value oid)))
|
||||
(if (number? oid)
|
||||
(~r oid #:base 16 #:min-width 16 #:pad-string "0")
|
||||
oid))))
|
||||
|
||||
(define (~handle h)
|
||||
(format "H~a" (P:Handle-value h)))
|
||||
|
||||
(define (~adesc adesc)
|
||||
(match adesc
|
||||
[(AssertionDescription-value v) (preserve->string v #:encode-embedded values #:commas? #f)]
|
||||
[(AssertionDescription-opaque d) (format "⌜~a⌝" d)]))
|
||||
|
||||
(define (~turn-event te is-action?)
|
||||
(match te
|
||||
[(TurnEvent-assert adesc handle)
|
||||
(when is-action?
|
||||
(when (hash-has-key? handle-map handle)
|
||||
(log-error "Duplicate use of handle ~a" (~handle handle)))
|
||||
(hash-set! handle-map handle adesc))
|
||||
(format "assert ~a: ~a" (~handle handle) (~adesc adesc))]
|
||||
[(TurnEvent-retract handle)
|
||||
(define adesc (hash-ref handle-map handle #f))
|
||||
(format "retract ~a: ~a" (~handle handle) (if adesc (~adesc adesc) "(missing)"))]
|
||||
[(TurnEvent-message adesc)
|
||||
(format "message ~a" (~adesc adesc))]
|
||||
[(TurnEvent-sync peer)
|
||||
(format "sync ~a" (~target peer))]
|
||||
[(TurnEvent-breakLink source-actor-id handle)
|
||||
(format "break link from ~a" (~actor-id source-actor-id))]))
|
||||
|
||||
(define (~targeted-turn-event tte is-action?)
|
||||
(match-define (TargetedTurnEvent target detail) tte)
|
||||
(format "~a <-- ~a" (~target target) (~turn-event detail is-action?)))
|
||||
|
||||
(define (process-action! actor-id action)
|
||||
(let-values
|
||||
(((variation label)
|
||||
(match action
|
||||
[(ActionDescription-dequeue tte)
|
||||
(values 'event (~targeted-turn-event tte #f))]
|
||||
[(ActionDescription-enqueue tte)
|
||||
(values 'action (~targeted-turn-event tte #t))]
|
||||
[(ActionDescription-dequeueInternal tte)
|
||||
(values 'event (format "(internal) ~a" (~targeted-turn-event tte #f)))]
|
||||
[(ActionDescription-enqueueInternal tte)
|
||||
(values 'action (format "(internal) ~a" (~targeted-turn-event tte #t)))]
|
||||
[(ActionDescription-spawn linked? child-actor-id)
|
||||
(translate! child-actor-id) ;; allocates swimlane
|
||||
(define L (annotate-swimlane (translate! actor-id)
|
||||
(render-config-action-color config)
|
||||
(format "spawn~a ~a" (if linked? "/link" "") (~actor-id child-actor-id))))
|
||||
(define C (and (not linked?) (connection* actor-id child-actor-id)))
|
||||
(emit! L)
|
||||
(when C (emit! C))
|
||||
(values #f #f)]
|
||||
[(ActionDescription-link parent-actor-id handle-child->parent child-actor-id handle-parent->child)
|
||||
(define L1 (annotate-swimlane (translate! parent-actor-id)
|
||||
(render-config-action-color config)
|
||||
(format "linked to ~a" (~actor-id child-actor-id))))
|
||||
(define L2 (annotate-swimlane (translate! child-actor-id)
|
||||
(render-config-action-color config)
|
||||
(format "linked to ~a" (~actor-id parent-actor-id))))
|
||||
(define C (connection* #:bidirectional? #t parent-actor-id child-actor-id))
|
||||
(emit! L1)
|
||||
(emit! L2)
|
||||
(emit! C)
|
||||
(values #f #f)]
|
||||
[(ActionDescription-facetStart facet-ids)
|
||||
(values 'action (format "+facet ~a" (map FacetId-value facet-ids)))]
|
||||
[(ActionDescription-facetStop facet-ids reason)
|
||||
(values 'action (format "-facet ~a ~a" (map FacetId-value facet-ids) (->preserve reason)))]
|
||||
[(ActionDescription-linkedTaskStart name task-id)
|
||||
(values 'action (format "task ~a started: ~a" task-id name))])))
|
||||
(when label
|
||||
(emit! (annotate-swimlane (translate! actor-id)
|
||||
(match variation
|
||||
['event (render-config-event-color config)]
|
||||
['action (render-config-action-color config)])
|
||||
label)))))
|
||||
|
||||
(define (process-trace-entry! entry)
|
||||
(match-define (TraceEntry _timestamp actor-id activation) entry)
|
||||
(match activation
|
||||
[(ActorActivation-start name)
|
||||
(emit! (annotate-swimlane (translate! actor-id)
|
||||
(render-config-label-color config)
|
||||
(match name
|
||||
[(Name-anonymous) "(anonymous)"]
|
||||
[(Name-named n) (preserve->string n
|
||||
#:encode-embedded values
|
||||
#:indent 2
|
||||
#:commas? #f)])))]
|
||||
[(ActorActivation-turn (TurnDescription turn-id turn-cause actions))
|
||||
(emit! (activate-swimlane (translate! actor-id)))
|
||||
(let ((label (format-turn-label actor-id turn-id turn-cause)))
|
||||
(emit! (annotate-swimlane (translate! actor-id) (render-config-event-color config) label)))
|
||||
(for [(a (in-list actions))] (process-action! actor-id a))
|
||||
;; (let ((action-count (length actions)))
|
||||
;; (when (positive? action-count)
|
||||
;; (emit! (annotate-swimlane (translate! actor-id)
|
||||
;; (render-config-action-color config)
|
||||
;; (match action-count
|
||||
;; [1 "1 action"]
|
||||
;; [n (format "~a actions" n)])))))
|
||||
(hash-set! turn-map turn-id (cons actor-id logical-time))
|
||||
(emit! (deactivate-swimlane (translate! actor-id)))
|
||||
]
|
||||
[(ActorActivation-stop status)
|
||||
(emit! (end-swimlane (translate! actor-id)))
|
||||
(when (ExitStatus-Error? status)
|
||||
(emit! (annotate-swimlane (translate! actor-id)
|
||||
(render-config-label-color config)
|
||||
(format "crashed: ~a" (->preserve status)))))
|
||||
(vacate-lane! actor-id)]))
|
||||
|
||||
(let loop ()
|
||||
(match (read-preserve port #:decode-embedded values)
|
||||
[(? eof-object?)
|
||||
(msd max-lane (reverse events-rev))]
|
||||
[input
|
||||
(match (parse-TraceEntry input)
|
||||
[(? eof-object?) (error 'read-msd "Invalid trace entry: ~v" input)]
|
||||
[entry (process-trace-entry! entry)])
|
||||
(loop)])))
|
||||
|
|
@ -0,0 +1,268 @@
|
|||
#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))]))
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
#lang racket/base
|
||||
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
||||
;;; SPDX-FileCopyrightText: Copyright © 2017-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
||||
|
||||
(provide (except-out (all-defined-out) render-config)
|
||||
(rename-out [make-render-config render-config]
|
||||
[render-config <render-config>]))
|
||||
|
||||
(require struct-defaults)
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Representation of a parsed trace.
|
||||
|
||||
(struct msd (max-lane events) #:prefab)
|
||||
|
||||
(struct diagram-position (lane row) #:prefab)
|
||||
|
||||
(struct begin-swimlane (pos) #:prefab)
|
||||
(struct activate-swimlane (pos) #:prefab)
|
||||
(struct deactivate-swimlane (pos) #:prefab)
|
||||
(struct end-swimlane (pos) #:prefab)
|
||||
(struct annotate-swimlane (pos color annotation) #:prefab)
|
||||
(struct connection (bidirectional? from-pos to-pos) #:prefab)
|
||||
|
||||
;;---------------------------------------------------------------------------
|
||||
;; Configuration for the renderer
|
||||
|
||||
(struct render-config (
|
||||
width
|
||||
height
|
||||
gap
|
||||
number-steps?
|
||||
number-gap
|
||||
active-width
|
||||
activation-color
|
||||
action-color
|
||||
event-color
|
||||
label-color
|
||||
scale
|
||||
) #:prefab)
|
||||
|
||||
(define-struct-defaults make-render-config render-config
|
||||
[
|
||||
#:width [render-config-width 100]
|
||||
#:height [render-config-height 4]
|
||||
#:gap [render-config-gap 12]
|
||||
|
||||
#:number-steps? [render-config-number-steps? #f]
|
||||
#:number-gap [render-config-number-gap 0]
|
||||
|
||||
#:active-width [render-config-active-width 10]
|
||||
|
||||
#:activation-color [render-config-activation-color "pink"]
|
||||
#:action-color [render-config-action-color "white"]
|
||||
#:event-color [render-config-event-color "orange"]
|
||||
#:label-color [render-config-label-color "palegreen"]
|
||||
|
||||
#:scale [render-config-scale 1]
|
||||
])
|
||||
Loading…
Reference in New Issue