Add VCD to SVG conversion functions
This commit is contained in:
Nikolay Puzanov
parent
daa744f8b2
commit
e8ba09ecab
@ -19,7 +19,8 @@
|
|||||||
(ice-9 popen))
|
(ice-9 popen))
|
||||||
|
|
||||||
(import (embddr common)
|
(import (embddr common)
|
||||||
(embddr optargs))
|
(embddr optargs)
|
||||||
|
(embddr vcd))
|
||||||
|
|
||||||
(define INDEX-FILE "index.html")
|
(define INDEX-FILE "index.html")
|
||||||
(define DELETE-WORK-DIR #t)
|
(define DELETE-WORK-DIR #t)
|
||||||
@ -196,6 +197,221 @@
|
|||||||
#:content-type content-type
|
#:content-type content-type
|
||||||
#:content-type-params content-type-params))
|
#: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
|
;;; Execute system command and capture stdout and stderr to string
|
||||||
;;;
|
;;;
|
||||||
|
|||||||
Loading…
x
Reference in New Issue
Block a user