(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 (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)
        (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-timestamps)
  (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> ...))
;;; Predicate: (need-signal? <signal>)
;;;
(define* (read-header port need-signal?)
  (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))

             ;; 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))

             ((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))
                    (name (string-concatenate
                           (insert-between
                            (cddddr cmd) " "))))
                (next-cmd timescale scope
                          (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)))
                                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 changes sample and return list of (time changes ...)
;;;
(define (read-sample port)
  (let read-rec ((time #f) (changes '()))
    (let ((line (get-line port)))
      (if (eof-object? line)
          (if time (cons time changes) #f)
          (let ((line (string-trim-both line)))
            (cond
             ((or (string-null? line)
                  ;; (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) #\#)
              (if time
                  (begin
                    (unget-string port (format "~a\n" line))
                    (cons time changes))
                  (let ((time (string->number (substring line 1))))
                    (if time
                        (read-rec time '())
                        (raise `(vcd-syntsx-error "Bad time format '~a'" line))))))

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

;;;
;;; Read and parse VCD data block
;;; Returns <vcd> record
;;;
(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)))
                         (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
                                 ;; 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))
                                             (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 #:optional (need-signal? (lambda (s) #t)))
  (call-with-values
      (lambda () (read-header port need-signal?))
    (cut read-data port <...>)))

;;;
;;; Convert 4-state binary string to hex
;;;
(define* (vcd-binary->hex binstr #:optional (trim #f))
  (let ((hex
         (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)))))))))
    (if trim
        (if (eq? (string-ref hex (- (string-length hex) 1)) #\0)
            "0"
            (string-append (string-trim hex #\0)))
        hex)))