(define-module (embddr vcd))

(import (srfi srfi-1)                   ; Lists
        (srfi srfi-9)                   ; Records
        (srfi srfi-11)                  ; Values
        (srfi srfi-26)                  ; Cut
        (srfi srfi-28)                  ; Simple format
        (srfi srfi-34)                  ; Exceptions
        (srfi srfi-69)                  ; Hash tables
        (ice-9 textual-ports))

(import
 (ice-9 pretty-print)
 (statprof))

(import (embddr common))

(export vcd-parse
        (signal-scope . vcd-signal-scope)
        (signal-name . vcd-signal-name)
        (signal-type . vcd-signal-type)
        (signal-size . vcd-signal-size)
        (signal-get . vcd-signal-get)
        vcd-binary->hex)

;;;
;;; VCD data structure
;;;
(define-record-type <vcd>
  (vcd-new timescale timestamps signals)
  vcd?
  (timescale vcd-timescale)
  (timestamps vcd-tstamps)
  (signals vcd-signals))

;;;
;;; Signal representation structure
;;;
(define-record-type <signal>
  (signal-new scope name type size value)
  signal?
  (scope signal-scope)
  (name signal-name)
  (type signal-type)
  (size signal-size)
  (value signal-get signal-set!))

;;; Add sample to signal values list
(define (signal-add! sig value)
  (signal-set! sig (cons value (signal-get sig))))

;;;
;;; Parse timescale value (eg: 1ps, 100ns etc)
;;; Returns value in ns
;;;
(define (parse-timescale ts)
  (let ((dim-idx (string-skip ts char-numeric?)))
    (if dim-idx
        (let* ((n (string->number (substring ts 0 dim-idx)))
               (unit (substring ts dim-idx))
               (k (assoc unit '(("s" 1e9) ("ms" 1e6) ("us" 1e3) ("ns" 1) ("ps" 1e-3) (fs 1e-6)))))
          (if k
              (* n (cadr k))
              (raise `(vcd-syntax-error
                       ,(format "Unknown timescale unit '~a'" unit)))))
        (raise `(vcd-syntax-error
                 ,(format "Wrong timescale '~a'" ts))))))

;;;
;;; Parse and extend binary value
;;;
(define (parse-binary-value str width)
  (let ((len (string-length str)))
    (cond
     ((zero? len)
      (raise `(vcd-syntax-error "Empty binary value")))

     ((> len width)
      (raise `(vcd-syntax-error
               ,(format "Binary value (~a) length > signal width (~a)" str width))))

     ;; Extend shorter
     ((< len width)
      (string-append
       (make-string
        (- width len)
        (let ((h (string-ref str 0)))
          (if (char-numeric? h) #\0 h)))
       str))

     (else str))))

;;;
;;; Parse real value
;;;
(define (parse-real-value str unused) str)

;;;
;;; Get VCD tag as ($keyword ... $end) as words list without $end
;;;
(define* (vcd-get-command port)
  (let get-cmd-rec ((wlist '()))
    (let ((w (get-word port)))
      (if (not w)
          (if (null? wlist)
              #f
              (reverse wlist))
          (if (null? wlist)
              (if (or (equal? w "$comment")
                      (equal? w "$date")
                      (equal? w "$enddefinitions")
                      (equal? w "$scope")
                      (equal? w "$timescale")
                      (equal? w "$upscope")
                      (equal? w "$var")
                      (equal? w "$version"))
                  (get-cmd-rec `(,w))
                  (raise `(vcd-syntax-error
                           ,(format "Unknown declaration keyword '~a'" w))))
              (if (equal? w "$end")
                  (reverse wlist)
                  (get-cmd-rec (cons w wlist))))))))

;;;
;;; Parse VCD header
;;; Returns values of timescale and association list (tag . (<signal> ...))
;;;
(define (read-header port)
  (let next-cmd ((timescale #f)
                 (scope '())
                 (tags+signals '()))
    (let ((cmd (vcd-get-command port)))
      (if (not cmd)
          (if timescale
              (values timescale tags+signals)
              (raise `(vcd-syntax-error "Timescale is not defined")))
          (let ((name (first cmd)))
            (cond
             ((string-ci= name "$timescale")
              (next-cmd (parse-timescale (second cmd)) scope tags+signals))

             ((string-ci= name "$scope")
              (next-cmd timescale (cons (third cmd) scope) tags+signals))

             ((string-ci= name "$var")
              (let ((type (cond
                           ((or (equal? "real" (second cmd))
                                (equal? "realtime" (second cmd))) 'real)
                           ((equal? "event" (second cmd)) 'event)
                           (else 'bits)))
                    (width (string->number (third cmd)))
                    (tag (fourth cmd))
                    (vname (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 '())))
                            (if tag+sig
                                (begin
                                  (set-cdr! tag+sig (cons sig (cdr tag+sig)))
                                  tags+signals)
                                (cons (cons tag `(,sig)) tags+signals))))))

             ((string-ci= "$upscope" (first cmd))
              (next-cmd timescale (cdr scope) tags+signals))

             ((string-ci= "$enddefinitions" (first cmd))
              (if (not timescale)
                  (raise '(vcd-syntax-error "Timescale is not defined"))
                  (values timescale tags+signals)))

             (else (next-cmd timescale scope tags+signals))))))))

;;;
;;; Read data block and return list of lists (time changes ..)
;;;
(define (read-data port)
  (let read-rec ((samples '())
                 (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))
          (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) #\#)
              (read-rec
               (if (and time (not (null? changes)))
                   (cons (cons time changes) samples)
                   samples)
               (let ((time (string->number (substring line 1))))
                 (if time
                     time
                     (raise `(vcd-syntsx-error "Bad time format '~a'" line))))
               '()))

             (else
              (read-rec samples time (cons line changes)))))))))

;;;
;;; 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)
       (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)
                       (signal-add!
                        sig
                        (cons time (parse-value value (signal-size sig)))))
                     sigs))))))
          (cdr sample))))
     samples)

    (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))))
               (map (lambda (sig)
                      (signal-set! sig (reverse (signal-get sig)))
                      sig)
                    signals)))))

;;;
;;; Parse whole VCD
;;; Returns list of time stamps and list of lists (<signal> valuse ...)
;;;
(define (vcd-parse port)
  (call-with-values
      (lambda () (read-header port))
    (cut parse-data
         (read-data port)
         <...>)))

;;;
;;; Convert 4-state binary string to hex
;;;
(define (vcd-binary->hex binstr)
  (string-concatenate
   (map
    (lambda (quad)
      (if (string-every char-numeric? quad)
          (number->string
           (string->number quad 2)
           16)
          (if (string-every (cut char-ci=? #\z <>) quad)
              "z"
              "x")))
    (let split-by-quad ((str (string-reverse binstr))
                        (quads '()))
      (cond
       ((string-null? str) quads)
       ((<= (string-length str) 4)
        (cons (string-append
               (make-string
                (- 4 (string-length str))
                (let ((h (string-ref str 0)))
                  (if (char-numeric? h) #\0 h)))
               (string-reverse str))
              quads))
       (else
        (split-by-quad
         (string-drop str 4)
         (cons
          (string-reverse
           (string-take str 4)) quads))))))))