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
                             (cddddr cmd) " "))))
                 (next-cmd timescale scope
-                          (let ((tag+sig (assoc tag tags+signals))
-                                (sig (signal-new (reverse scope)
-                                                 vname type width '())))
+                          (let ((sig (signal-new (reverse scope)
+                                                 name type width '())))
+                            (if (need-signal? sig)
+                                (let ((tag+sig (assoc tag tags+signals)))
                                   (if tag+sig
                                       (begin
                                         (set-cdr! tag+sig (cons sig (cdr tag+sig)))
                                         tags+signals)
-                                (cons (cons tag `(,sig)) tags+signals))))))
+                                      (cons (cons tag `(,sig)) tags+signals)))
+                                tags+signals)))))
 
              ((string-ci= "$upscope" (first cmd))
               (next-cmd timescale (cdr scope) tags+signals))
@@ -174,54 +177,58 @@
              (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)
-  (let read-rec ((samples '())
-                 (time #f)
-                 (changes '()))
+(define (read-sample port)
+  (let read-rec ((time #f) (changes '()))
     (let ((line (get-line port)))
       (if (eof-object? line)
-          (reverse
-           (if (and time (not (null? changes)))
-               (cons (cons time changes) samples)
-               samples))
+          (if time (cons time changes) #f)
           (let ((line (string-trim-both line)))
             (cond
              ((or (string-null? line)
-                  (equal? (string-ref line 0) #\$))
-              (read-rec samples time changes))
+                  ;; (equal? (string-ref line 0) #\$)
+                  (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 (and time (not (null? changes)))
-                   (cons (cons time changes) samples)
-                   samples)
+              (if time
+                  (begin
+                    (unget-string port (format "~a\n" line))
+                    (cons time changes))
                   (let ((time (string->number (substring line 1))))
                     (if time
-                     time
-                     (raise `(vcd-syntsx-error "Bad time format '~a'" line))))
-               '()))
+                        (read-rec time '())
+                        (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)
-  (let* ((samples-count (length samples))
-         (tags+signals-ht (alist->hash-table tags+signals)))
-
-    (for-each
-     (lambda (sample)
+(define (read-data port timescale tags+signals)
+  (let* ((tags+signals-ht (alist->hash-table tags+signals))
+         (timestamps
+          (let loop ((timestamps '()))
+            (let ((sample (read-sample port)))
+              (if 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
@@ -239,6 +246,8 @@
                                      (char-ci=? c0 #\r))
 
                                  ;; Fast but unsafe
+                                 ;; Does not remove leading and trailing spaces
+                                 ;; and spaces between value and tag
                                  (let ((val-idx (string-index rest #\space)))
                                    (if val-idx
                                        (let ((value (substring rest 0 val-idx))
@@ -249,59 +258,61 @@
                                                  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)))))
-                      ))))
+                                                ,(format "Bad value change string '~a'" line)))))))))
 
+                           ;; Update register values list
                            (let ((sigs (hash-table-ref/default tags+signals-ht tag #f)))
-                  (unless (null? sigs)
+                             (when sigs
                                (for-each
                                 (lambda (sig)
                                   (signal-add!
                                    sig
                                    (cons time (parse-value value (signal-size sig)))))
                                 sigs))))))
-          (cdr sample))))
-     samples)
+                     (cdr sample))
+
+                    (loop (cons time timestamps)))
+                  timestamps)))))
 
-    (vcd-new timescale
-             (map car samples)
     (let ((signals (fold (lambda (tag+sig out)
                            (append (cdr tag+sig) out))
-                                  '()  tags+signals))
-                   (last-time (car (last samples))))
+                         '()  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 (signal-get 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)))))
+                          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))
-    (cut parse-data
-         (read-data port)
-         <...>)))
+      (lambda () (read-header port need-signal?))
+    (cut read-data port <...>)))
 
 ;;;
 ;;; Convert 4-state binary string to hex
 ;;;
-(define (vcd-binary->hex binstr)
+(define* (vcd-binary->hex binstr #:optional (trim #f))
+  (let ((hex
          (string-concatenate
           (map
            (lambda (quad)
@@ -329,4 +340,9 @@
                 (string-drop str 4)
                 (cons
                  (string-reverse
-           (string-take str 4)) quads))))))))
+                  (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)))