Add VCD to SVG conversion functions
This commit is contained in:
Nikolay Puzanov
parent
daa744f8b2
commit
e8ba09ecab
@ -19,7 +19,8 @@
|
||||
(ice-9 popen))
|
||||
|
||||
(import (embddr common)
|
||||
(embddr optargs))
|
||||
(embddr optargs)
|
||||
(embddr vcd))
|
||||
|
||||
(define INDEX-FILE "index.html")
|
||||
(define DELETE-WORK-DIR #t)
|
||||
@ -196,6 +197,221 @@
|
||||
#:content-type content-type
|
||||
#:content-type-params content-type-params))
|
||||
|
||||
;;;
|
||||
;;; Simple format with convert input number to inexact numbers
|
||||
;;;
|
||||
(define (format-inex . args)
|
||||
(apply format
|
||||
(map (lambda (arg)
|
||||
(if (number? arg)
|
||||
(exact->inexact
|
||||
(/ (round (* arg 100)) 100))
|
||||
arg))
|
||||
args)))
|
||||
|
||||
;;;
|
||||
;;; Make SVG drawing of VCD signals
|
||||
;;;
|
||||
(define* (vcd-signal->svg signal tstart tend x y width height text-position
|
||||
#:key (id #f) (data-hw 3))
|
||||
(let* ((time-per-pixel (/ (- tend tstart) width))
|
||||
(sig-width (vcd-signal-size signal))
|
||||
(sig-type (vcd-signal-type signal))
|
||||
(y0 y)
|
||||
(y1 (+ y height))
|
||||
(yz (+ y (/ height 2)))
|
||||
(half-dy (/ (- y1 y0) 2))
|
||||
(id (if id (format " id=\"~a\"" id) "")))
|
||||
|
||||
(let next-sample ((samples (append (vcd-signal-get signal) `((,tend . "-"))))
|
||||
(value (if (eq? sig-type 'real)
|
||||
0
|
||||
(make-string sig-width #\x)))
|
||||
(time tstart)
|
||||
(svg '()))
|
||||
|
||||
(if (null? samples)
|
||||
svg
|
||||
(let ((sample-time (car (car samples)))
|
||||
(sample-value (cdr (car samples))))
|
||||
(if (or (< (- sample-time time) time-per-pixel)
|
||||
(and (equal? value sample-value)
|
||||
(not (eq? sig-type 'event))))
|
||||
(next-sample
|
||||
(cdr samples)
|
||||
(if (<= sample-time tstart)
|
||||
sample-value
|
||||
value)
|
||||
time svg)
|
||||
(next-sample
|
||||
(cdr samples) sample-value sample-time
|
||||
(cons
|
||||
(cond
|
||||
((or (eq? sig-type 'bits)
|
||||
(eq? sig-type 'real))
|
||||
|
||||
(if (and (= sig-width 1)
|
||||
(not (eq? sig-type 'real))
|
||||
(not (char-ci=? (string-ref value 0) #\x)))
|
||||
;; Scalar
|
||||
(let ((x0 (+ x (/ (- time tstart) time-per-pixel)))
|
||||
(x1 (+ x (/ (- sample-time tstart) time-per-pixel))))
|
||||
(string-append
|
||||
(format-inex "<path~a d=\"M~a ~a v~a\"/>" id x0 y0 (- y1 y0))
|
||||
(format-inex "<path~a d=\"M~a ~a h~a\"/>"
|
||||
id x0
|
||||
(cond
|
||||
((equal? value "0") y1)
|
||||
((equal? value "1") y0)
|
||||
(else yz))
|
||||
(- x1 x0))))
|
||||
|
||||
;; Vector or Real
|
||||
(let ((x0 (+ x (/ (- time tstart) time-per-pixel)))
|
||||
(x1 (+ x (/ (- sample-time tstart) time-per-pixel))))
|
||||
(string-append
|
||||
;; Horizontal lines
|
||||
(let ((x0 (+ x0 (if (<= time tstart) 0 data-hw)))
|
||||
(x1 (- x1 (if (>= sample-time tend) 0 data-hw))))
|
||||
(format-inex
|
||||
"<path~a d=\"M~a ~a L~a ~a M~a ~a L~a ~a\"/>"
|
||||
id x0 y0 x1 y0 x0 y1 x1 y1))
|
||||
|
||||
;; Left cross
|
||||
(if (<= time tstart)
|
||||
""
|
||||
(format-inex "<path~a d=\"M~a ~a l~a ~a\"/><path d=\"M~a ~a l~a ~a\"/>"
|
||||
id
|
||||
x0 yz data-hw (- half-dy)
|
||||
x0 yz data-hw (+ half-dy)))
|
||||
|
||||
;; Right cross
|
||||
(if (>= sample-time tend)
|
||||
""
|
||||
(format-inex "<path~a d=\"M~a ~a l~a ~a\"/><path d=\"M~a ~a l~a ~a\"/>"
|
||||
id
|
||||
x1 yz (- data-hw) (- half-dy)
|
||||
x1 yz (- data-hw) (+ half-dy)))
|
||||
|
||||
;; Text
|
||||
(format-inex "<svg~a x=\"~a\" y=\"~a\" width=\"~a\" height=\"~a\">"
|
||||
id
|
||||
(+ x0 data-hw)
|
||||
y0
|
||||
(- x1 x0 (* data-hw 2))
|
||||
(- y1 y0))
|
||||
(format-inex "<text id=\"val\" x=\"~a\" y=\"~a\">" 0 text-position)
|
||||
(if (or (eq? sig-type 'real)
|
||||
(< sig-width 4))
|
||||
value
|
||||
(string-upcase
|
||||
(vcd-binary->hex value #t)))
|
||||
"</text></svg>"))))
|
||||
|
||||
;; Real number
|
||||
((eq? sig-type 'real)
|
||||
"")
|
||||
|
||||
;; Event
|
||||
((eq? sig-type 'event)
|
||||
""))
|
||||
svg))))))))
|
||||
|
||||
;;;
|
||||
;;; Make legend SVG text for VCD
|
||||
;;;
|
||||
(define* (vcd-signals->legend signals text-spacing text-position)
|
||||
(map
|
||||
(lambda (sig n)
|
||||
(string-append
|
||||
(format-inex "<text x=\"0\" y=\"~a\">~a</text>"
|
||||
(+ (* n text-spacing) text-position)
|
||||
(vcd-signal-name sig))))
|
||||
signals
|
||||
(iota (length signals))))
|
||||
|
||||
;;;
|
||||
;;; Create SVG from VCD
|
||||
;;;
|
||||
(define* (vcd->svg vcd width #:key
|
||||
(signal-height 15)
|
||||
(signal-text-position 12)
|
||||
(margin 5)
|
||||
(signal-spacing 5)
|
||||
(legend-width 100)
|
||||
(extra-delim-y 3))
|
||||
|
||||
(let ((tstart (apply min (vcd-timestamps vcd)))
|
||||
(tend (apply max (vcd-timestamps vcd)))
|
||||
(signals (sort
|
||||
(remove
|
||||
(lambda (sig) (< (length (vcd-signal-scope sig)) 2))
|
||||
(vcd-signals vcd))
|
||||
(lambda (a b)
|
||||
(or
|
||||
(and (equal? (vcd-signal-name a) "clock")
|
||||
(not (equal? (vcd-signal-name b) "clock")))
|
||||
|
||||
(< (length (vcd-signal-scope a))
|
||||
(length (vcd-signal-scope b)))
|
||||
|
||||
(string-ci<? (vcd-signal-name a)
|
||||
(vcd-signal-name b)))))))
|
||||
|
||||
(let ((signals-x (+ (* 2 margin) legend-width))
|
||||
(signals-w (- width legend-width (* 3 margin)))
|
||||
(height
|
||||
(+ (* 2 margin)
|
||||
(* signal-height (length signals))
|
||||
(* signal-spacing (- (length signals) 1)))))
|
||||
|
||||
(append
|
||||
;; Header
|
||||
(list
|
||||
(format-inex "<svg width=\"~a\" height=\"~a\"" width height)
|
||||
(format "preserveAspectRatio=\"xMidYMin slice\" role=\"img\"")
|
||||
(format "<g id=\"wave-background\"><rect width=\"100%\" height=\"100%\"/></g>")
|
||||
(format "<g id=\"wave-signals\">"))
|
||||
|
||||
;; Legend
|
||||
`(,(format-inex "<svg id=\"legend\" x=\"~a\" y=\"~a\" width=\"~a\" height=\"~a\">"
|
||||
margin margin legend-width (- height (* 2 margin))))
|
||||
(signals->legend signals
|
||||
(+ signal-height signal-spacing)
|
||||
signal-text-position)
|
||||
'("</svg>")
|
||||
|
||||
;; Clock
|
||||
(signal->svg (car signals) tstart tend
|
||||
signals-x margin
|
||||
signals-w signal-height signal-text-position
|
||||
#:id "clock")
|
||||
|
||||
;; Rest
|
||||
(fold
|
||||
(lambda (sig n out)
|
||||
(append
|
||||
out
|
||||
(signal->svg sig tstart tend
|
||||
signals-x
|
||||
(+ margin
|
||||
(* n signal-height)
|
||||
(* n signal-spacing))
|
||||
signals-w signal-height signal-text-position)))
|
||||
'()
|
||||
(cdr signals)
|
||||
(iota (length
|
||||
(cdr signals))
|
||||
1))
|
||||
|
||||
;; Delimiter
|
||||
`(,(format-inex "<path id=\"delim\" d=\"M~a ~a v~a\"/>"
|
||||
(+ legend-width (* 2 margin)) (- margin extra-delim-y)
|
||||
(- height (* 2 (- margin extra-delim-y)))))
|
||||
|
||||
;; Close svg tag
|
||||
'("</svg>")))))
|
||||
|
||||
;;;
|
||||
;;; Execute system command and capture stdout and stderr to string
|
||||
;;;
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user