From e8ba09ecab3e056ea5d1f3e5db51228060fcc062 Mon Sep 17 00:00:00 2001
From: Nikolay Puzanov <np@embddr.com>
Date: Tue, 6 Dec 2022 20:06:26 +0300
Subject: [PATCH] Add VCD to SVG conversion functions

---
 _web_server/server/playground-server.scm | 218 ++++++++++++++++++++++-
 1 file changed, 217 insertions(+), 1 deletion(-)

diff --git a/_web_server/server/playground-server.scm b/_web_server/server/playground-server.scm
index 4dbbce0..ef06232 100755
--- a/_web_server/server/playground-server.scm
+++ b/_web_server/server/playground-server.scm
@@ -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
 ;;;