Fix title absent

embddr/common.scm

@@ -19,6 +19,7 @@
           has-duplicates? find-duplicates
           insert-between
           string-replace-text
+          string-split-str
           string-split-trim
           get-word
           substitute
@@ -220,6 +221,18 @@
            (substitute str template-format subst-list))
          ls)))
 
+;;; Split the string STR into a list of the substrings delimited by DELIMITER
+(define (string-split-str str delimiter)
+  (if (string-null? str)
+      '()
+      (let ((didx (string-contains str delimiter)))
+        (if didx
+            (cons (substring str 0 didx)
+                  (string-split-str
+                   (substring str (+ didx (string-length delimiter)))
+                   delimiter))
+            (list str)))))
+
 ;;; Split string and remove empty itemes
 (define (string-split-trim str pred?)
   (remove string-null?

embddr/gnuplot.scm

@@ -0,0 +1,117 @@
+(define-module (embddr gnuplot))
+
+(import (srfi srfi-1)
+        (srfi srfi-26)
+        (ice-9 popen)
+        (ice-9 format))
+
+(export make-plot-xy
+        plot)
+
+;;;
+;;; println
+;;;
+(define (>> . args)
+  (when (not (null? args))
+    (apply format (cons #t args)))
+  (newline))
+
+;;;
+;;; Call app and write to stdin
+;;;
+(define (with-output-to-spawn cmd f)
+  (let ((port (open-output-pipe cmd)))
+    (with-output-to-port port f)
+    (force-output port)
+    (close-pipe port)))
+
+;;;
+;;; Make plot
+;;;
+(define* (make-plot-xy #:key
+                       (x #f)           ; abscissa
+                       y                ; ordinate
+                       (title #f)
+                       (with "lines"))
+  (let ((x (or x (iota (length y)))))
+    (if (not (= (length x)
+                (length y)))
+        (error "Length of X and Y lists is not equal")
+        (lambda (key)
+          (case key
+            ((x) x)
+            ((y) y)
+            ((title) (or title ""))
+            ((with) with)
+            (else #f))))))
+
+;;;
+;;; Plot plots
+;;;
+(define* (plot plots
+               #:key
+               (xlabel #f)
+               (ylabel #f)
+               (title #f)
+               (font "Iosevka")
+               (font-size 11))
+  (let ((plots (if (list? plots) plots `(,plots))))
+    (if (not (apply = (map (lambda (plot) (length (plot 'x))) plots)))
+        (error "Length of plots is not equal")
+        (let* ((file-port (mkstemp "/tmp/plot-data-XXXXXX" "w"))
+               (file-name (port-filename file-port)))
+
+          ;; Write data to temporary file
+          (with-output-to-port file-port
+            (lambda ()
+              (for-each
+               (cut >> <>)
+               (map (lambda (sample) (string-join (map
+                                              (lambda (x) (number->string
+                                                      (exact->inexact x)))
+                                              sample) " "))
+                    (apply zip (cons ((first plots) 'x)
+                                     (map (lambda (plot) (plot 'y)) plots)))))))
+          (close-port file-port)
+
+          ;; Call gnuplot
+          (with-output-to-spawn
+           "gnuplot"
+           (lambda ()
+             (>> "set term x11 enhanced font '~a,~a' persist size 640,480" font font-size)
+             ;; (>> "set output '~a'"                                                "draw.png")
+             (>> "set grid")
+             (when xlabel (>> "set xlabel '~a'" xlabel))
+             (when ylabel (>> "set ylabel '~a'" ylabel))
+             (when title  (>> "set title '~a'" title))
+             (>> "plot ~a"
+                 (string-join
+                  (map (lambda (plot n)
+                         (format #f "'~a' using 1:~a with ~a~a"
+                                 file-name
+                                 n
+                                 (plot 'with)
+                                 (if (plot 'title)
+                                     (format #f " title '~a'" (plot 'title))
+                                     "")))
+                       plots
+                       (iota (length plots) 2))
+                  ",\\\n"))))
+
+          ;; Delete temporary file
+          (delete-file file-name)))))
+
+
+;; (define (main args)
+;;   (plot
+;;    `(,(make-plot-xy
+;;        #:x (iota 17 20 -1)
+;;        #:y '(1 2 3 4 3 2 1 0 -1 -2 -3 -4 -3 -2 -1 0 1)
+;;        #:title "plot A"
+;;        #:with "lines lw 2")
+
+;;      ,(make-plot-xy
+;;        #:x (iota 17 20 -1)
+;;        #:y (map (cut * -0.5 <>) '(1 2 3 4 3 2 1 0 -1 -2 -3 -4 -3 -2 -1 0 1))
+;;        #:title "plot B"
+;;        #:with "lines"))))

embddr/vcd.scm

@@ -9,13 +9,12 @@
         (srfi srfi-69)                  ; Hash tables
         (ice-9 textual-ports))
 
-(import
- (ice-9 pretty-print)
- (statprof))
-
 (import (embddr common))
 
 (export vcd-parse
+        vcd-timescale
+        vcd-timestamps
+        vcd-signals
         (signal-scope . vcd-signal-scope)
         (signal-name . vcd-signal-name)
         (signal-type . vcd-signal-type)
@@ -30,7 +29,7 @@
   (vcd-new timescale timestamps signals)
   vcd?
   (timescale vcd-timescale)
-  (timestamps vcd-tstamps)
+  (timestamps vcd-timestamps)
   (signals vcd-signals))
 
 ;;;
@@ -124,8 +123,9 @@
 ;;;
 ;;; Parse VCD header
 ;;; Returns values of timescale and association list (tag . (<signal> ...))
+;;; Predicate: (need-signal? <signal>)
 ;;;
-(define (read-header port)
+(define* (read-header port need-signal?)
   (let next-cmd ((timescale #f)
                  (scope '())
                  (tags+signals '()))
@@ -139,6 +139,7 @@
              ((string-ci= name "$timescale")
               (next-cmd (parse-timescale (second cmd)) scope tags+signals))
 
+             ;; TODO: Add scope type (make scope as pair '(scope-type . scope-name))
              ((string-ci= name "$scope")
               (next-cmd timescale (cons (third cmd) scope) tags+signals))
 
@@ -150,18 +151,20 @@
                            (else 'bits)))
                     (width (string->number (third cmd)))
                     (tag (fourth cmd))
-                    (vname (string-concatenate
+                    (name (string-concatenate
-                            (insert-between
+                           (insert-between
-                             (cddddr cmd) " "))))
+                            (cddddr cmd) " "))))
                 (next-cmd timescale scope
-                          (let ((tag+sig (assoc tag tags+signals))
+                          (let ((sig (signal-new (reverse scope)
-                                (sig (signal-new (reverse scope)
+                                                 name type width '())))
-                                                 vname type width '())))
+                            (if (need-signal? sig)
-                            (if tag+sig
+                                (let ((tag+sig (assoc tag tags+signals)))
-                                (begin
+                                  (if tag+sig
-                                  (set-cdr! tag+sig (cons sig (cdr tag+sig)))
+                                      (begin
-                                  tags+signals)
+                                        (set-cdr! tag+sig (cons sig (cdr tag+sig)))
-                                (cons (cons tag `(,sig)) tags+signals))))))
+                                        tags+signals)
+                                      (cons (cons tag `(,sig)) tags+signals)))
+                                tags+signals)))))
 
              ((string-ci= "$upscope" (first cmd))
               (next-cmd timescale (cdr scope) tags+signals))
@@ -174,159 +177,172 @@
              (else (next-cmd timescale scope tags+signals))))))))
 
 ;;;
-;;; Read data block and return list of lists (time changes ..)
+;;; Read data changes sample and return list of (time changes ...)
 ;;;
-(define (read-data port)
+(define (read-sample port)
-  (let read-rec ((samples '())
+  (let read-rec ((time #f) (changes '()))
-                 (time #f)
-                 (changes '()))
     (let ((line (get-line port)))
       (if (eof-object? line)
-          (reverse
+          (if time (cons time changes) #f)
-           (if (and time (not (null? changes)))
-               (cons (cons time changes) samples)
-               samples))
           (let ((line (string-trim-both line)))
             (cond
              ((or (string-null? line)
-                  (equal? (string-ref line 0) #\$))
+                  ;; (equal? (string-ref line 0) #\$)
-              (read-rec samples time changes))
+                  (not
+                   (let ((c (string-ref line 0)))
+                     (or (eq? c #\0)
+                         (eq? c #\1)
+                         (eq? c #\x)
+                         (eq? c #\X)
+                         (eq? c #\z)
+                         (eq? c #\Z)
+                         (eq? c #\b)
+                         (eq? c #\r)
+                         (eq? c #\#)))))
+              (read-rec time changes))
 
              ((equal? (string-ref line 0) #\#)
-              (read-rec
+              (if time
-               (if (and time (not (null? changes)))
+                  (begin
-                   (cons (cons time changes) samples)
+                    (unget-string port (format "~a\n" line))
-                   samples)
+                    (cons time changes))
-               (let ((time (string->number (substring line 1))))
+                  (let ((time (string->number (substring line 1))))
-                 (if time
+                    (if time
-                     time
+                        (read-rec time '())
-                     (raise `(vcd-syntsx-error "Bad time format '~a'" line))))
+                        (raise `(vcd-syntsx-error "Bad time format '~a'" line))))))
-               '()))
 
              (else
-              (read-rec samples time (cons line changes)))))))))
+              (read-rec time (cons line changes)))))))))
 
 ;;;
-;;; Parse VCD data block
+;;; Read and parse VCD data block
 ;;; Returns <vcd> record
 ;;;
-(define (parse-data samples timescale tags+signals)
+(define (read-data port timescale tags+signals)
-  (let* ((samples-count (length samples))
+  (let* ((tags+signals-ht (alist->hash-table tags+signals))
-         (tags+signals-ht (alist->hash-table tags+signals)))
+         (timestamps
-
+          (let loop ((timestamps '()))
-    (for-each
+            (let ((sample (read-sample port)))
-     (lambda (sample)
+              (if sample
-       (let ((time (car sample)))
+                  (let ((time (car sample)))
-         (for-each
-          (lambda (line)
-            (let ((c0 (string-ref line 0))
-                  (rest (substring line 1)))
-              ;; (display (format "-- c0:'~a' rest:'~a'\n" c0 rest))
-              (let-values
-                  (((parse-value tag value)
-                    (cond
-                     ;; Scalar value
-                     ((or (equal? c0 #\0)
-                          (equal? c0 #\1)
-                          (char-ci=? c0 #\x)
-                          (char-ci=? c0 #\z))
-                      (values parse-binary-value
-                              rest
-                              (string (char-downcase c0))))
-
-                     ;; Binary or real value
-                     ((or (char-ci=? c0 #\b)
-                          (char-ci=? c0 #\r))
-
-                      ;; Fast but unsafe
-                      (let ((val-idx (string-index rest #\space)))
-                        (if val-idx
-                            (let ((value (substring rest 0 val-idx))
-                                  (tag (substring rest (+ val-idx 1))))
-                              (values (if (char-ci=? c0 #\b)
-                                          parse-binary-value
-                                          parse-real-value)
-                                      tag
-                                      value))
-                            (raise `(vcd-syntax-error
-                                     ,(format "Bad value change string '~a'" line)))))
-
-                      ;; Slow but safety
-                      ;; (let ((ss (string-split-trim rest char-whitespace?)))
-                      ;;   (if (= (length ss) 2)
-                      ;;       (let ((value (first ss))
-                      ;;             (tag (second ss)))
-                      ;;         (values (if (char-ci=? c0 #\b)
-                      ;;                     parse-binary-value
-                      ;;                     parse-real-value)
-                      ;;                 tag
-                      ;;                 value))
-                      ;;       (raise `(vcd-syntax-error
-                      ;;                ,(format "Bad value change string '~a'" line)))))
-                      ))))
-
-                (let ((sigs (hash-table-ref/default tags+signals-ht tag #f)))
-                  (unless (null? sigs)
                     (for-each
-                     (lambda (sig)
+                     (lambda (line)
-                       (signal-add!
+                       (let ((c0 (string-ref line 0))
-                        sig
+                             (rest (substring line 1)))
-                        (cons time (parse-value value (signal-size sig)))))
+                         (let-values
-                     sigs))))))
+                             (((parse-value tag value)
-          (cdr sample))))
+                               (cond
-     samples)
+                                ;; Scalar value
+                                ((or (equal? c0 #\0)
+                                     (equal? c0 #\1)
+                                     (char-ci=? c0 #\x)
+                                     (char-ci=? c0 #\z))
+                                 (values parse-binary-value
+                                         rest
+                                         (string (char-downcase c0))))
 
-    (vcd-new timescale
+                                ;; Binary or real value
-             (map car samples)
+                                ((or (char-ci=? c0 #\b)
-             (let ((signals (fold (lambda (tag+sig out)
+                                     (char-ci=? c0 #\r))
-                                    (append (cdr tag+sig) out))
+
-                                  '()  tags+signals))
+                                 ;; Fast but unsafe
-                   (last-time (car (last samples))))
+                                 ;; Does not remove leading and trailing spaces
-               (map (lambda (sig)
+                                 ;; and spaces between value and tag
-                      (signal-set! sig (reverse (signal-get sig)))
+                                 (let ((val-idx (string-index rest #\space)))
-                      sig)
+                                   (if val-idx
-                    signals)))))
+                                       (let ((value (substring rest 0 val-idx))
+                                             (tag (substring rest (+ val-idx 1))))
+                                         (values (if (char-ci=? c0 #\b)
+                                                     parse-binary-value
+                                                     parse-real-value)
+                                                 tag
+                                                 value))
+                                       (raise `(vcd-syntax-error
+                                                ,(format "Bad value change string '~a'" line)))))))))
+
+                           ;; Update register values list
+                           (let ((sigs (hash-table-ref/default tags+signals-ht tag #f)))
+                             (when sigs
+                               (for-each
+                                (lambda (sig)
+                                  (signal-add!
+                                   sig
+                                   (cons time (parse-value value (signal-size sig)))))
+                                sigs))))))
+                     (cdr sample))
+
+                    (loop (cons time timestamps)))
+                  timestamps)))))
+
+    (let ((signals (fold (lambda (tag+sig out)
+                           (append (cdr tag+sig) out))
+                         '()  tags+signals)))
+      (if (null? timestamps)
+          (vcd-new timescale timestamps signals)
+          (vcd-new timescale
+                   (reverse timestamps)
+                   ;; Complete values to last time stamp
+                   (let ((last-time (car timestamps)))
+                     (map (lambda (sig)
+                            (signal-set!
+                             sig
+                             (reverse
+                              (let ((values (signal-get sig)))
+                                (if (null? values)
+                                    '()
+                                    (let ((last-val (car values)))
+                                      (if (= last-time (car last-val))
+                                          values
+                                          (cons (cons last-time
+                                                      (cdr last-val))
+                                                values)))))))
+                            sig)
+                          signals)))))))
 
 ;;;
 ;;; Parse whole VCD
 ;;; Returns list of time stamps and list of lists (<signal> valuse ...)
 ;;;
-(define (vcd-parse port)
+(define* (vcd-parse port #:optional (need-signal? (lambda (s) #t)))
   (call-with-values
-      (lambda () (read-header port))
+      (lambda () (read-header port need-signal?))
-    (cut parse-data
+    (cut read-data port <...>)))
-         (read-data port)
-         <...>)))
 
 ;;;
 ;;; Convert 4-state binary string to hex
 ;;;
-(define (vcd-binary->hex binstr)
+(define* (vcd-binary->hex binstr #:optional (trim #f))
-  (string-concatenate
+  (let ((hex
-   (map
+         (string-concatenate
-    (lambda (quad)
+          (map
-      (if (string-every char-numeric? quad)
+           (lambda (quad)
-          (number->string
+             (if (string-every char-numeric? quad)
-           (string->number quad 2)
+                 (number->string
-           16)
+                  (string->number quad 2)
-          (if (string-every (cut char-ci=? #\z <>) quad)
+                  16)
-              "z"
+                 (if (string-every (cut char-ci=? #\z <>) quad)
-              "x")))
+                     "z"
-    (let split-by-quad ((str (string-reverse binstr))
+                     "x")))
-                        (quads '()))
+           (let split-by-quad ((str (string-reverse binstr))
-      (cond
+                               (quads '()))
-       ((string-null? str) quads)
+             (cond
-       ((<= (string-length str) 4)
+              ((string-null? str) quads)
-        (cons (string-append
+              ((<= (string-length str) 4)
-               (make-string
+               (cons (string-append
-                (- 4 (string-length str))
+                      (make-string
-                (let ((h (string-ref str 0)))
+                       (- 4 (string-length str))
-                  (if (char-numeric? h) #\0 h)))
+                       (let ((h (string-ref str 0)))
-               (string-reverse str))
+                         (if (char-numeric? h) #\0 h)))
-              quads))
+                      (string-reverse str))
-       (else
+                     quads))
-        (split-by-quad
+              (else
-         (string-drop str 4)
+               (split-by-quad
-         (cons
+                (string-drop str 4)
-          (string-reverse
+                (cons
-           (string-take str 4)) quads))))))))
+                 (string-reverse
+                  (string-take str 4)) quads)))))))))
+    (if trim
+        (if (eq? (string-ref hex (- (string-length hex) 1)) #\0)
+            "0"
+            (string-append (string-trim hex #\0)))
+        hex)))