; VCD Generator for ESIM
; Copyright (C) 2010-2012 Centaur Technology
;
; Contact:
;   Centaur Technology Formal Verification Group
;   7600-C N. Capital of Texas Highway, Suite 300, Austin, TX 78731, USA.
;   http://www.centtech.com/
;
; This program is free software; you can redistribute it and/or modify it under
; the terms of the GNU General Public License as published by the Free Software
; Foundation; either version 2 of the License, or (at your option) any later
; version.  This program is distributed in the hope that it will be useful but
; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License for
; more details.  You should have received a copy of the GNU General Public
; License along with this program; if not, write to the Free Software
; Foundation, Inc., 51 Franklin Street, Suite 500, Boston, MA 02110-1335, USA.
;
; Original author: Jared Davis <jared@centtech.com>

(in-package "VL")
(include-book "vcd-stub")
(include-book "oslib/date" :dir :system)
(include-book "centaur/misc/tshell" :dir :system)
(include-book "centaur/aig/faig-constructors" :dir :system)
(include-book "centaur/misc/hons-extra" :dir :system)
(include-book "centaur/vl/util/print" :dir :system)
(include-book "centaur/vl/toe/toe-emodwire" :dir :system)
(include-book "centaur/vl/toe/toe-verilogify" :dir :system)
(include-book "centaur/vl/util/prefix-hash" :dir :system)
(local (include-book "misc/assert" :dir :system))
(local (include-book "centaur/vl/util/arithmetic" :dir :system))
(local (include-book "centaur/vl/util/osets" :dir :system))
(set-state-ok t)


; VCD-DUMP can create a VCD ("value change dump") file corresponding to a
; concrete, multi-cycle ESIM simulation.  These files can be loaded into viewer
; programs like "gtkwave", allowing you to interactively debug the simulation.
;
; INTERFACE.
;
;   (vcd-dump <filename>   ; e.g., "my-simulation.dump"
;             <snapshots>  ; see below
;
;             ;; optional arguments
;
;             [:emap <emap>]                ; default: nil
;             [:viewer "/path/to/viewer"]   ; default: "gtkwave"
;             )
;
; This is an embeddable event.  For a non event-based version, you can directly
; call vcd-dump-fn.
;
;
; GENERATING SNAPSHOTS.
;
; Each "snapshot" is an alist binding NAME -> VALUE.  It is not necessary to
; use fast-alists.
;
; To generate a snapshot, you typically run ESIM-SEXPR, ESIM-SEXPR-PROBE, or
; similar functions and just append together:
;
;    (1) the input alist you used,
;    (2) the output alist you obtained,
;    (3) the next-state alist you obtained
;
; We expect each snapshot to bind exactly the same variables, so you probably
; want to generate each snapshot in a uniform way.
;
; The VALUE bound to each name may be:
;
;    - Concrete FAIGs
;          i.e., (faig-f), (faig-t), (faig-x), or (faig-z)
;
;    - Concrete S-Expression Results
;          i.e., *4vf*, *4vt*, *4vx*, or *4vz*   ('F, 'T, 'X, 'Z)
;
;    - Results from OT
;          i.e., NIL, T, 'X, or 'U
;          BOZO: should OT maybe produce 4vp's instead of NIL and U?
;
; The NAMES must be symbols.  We restrict the names of these symbols because we
; use them to infer the module hierarchy.  In particular:
;
;  - Your signal names must satisfy vl-emodwire-p (i.e., symbols like ACL2::foo
;    or ACL2::foo[3] that do not use certain characters).  This should always
;    be true in practice for modules that are generated by VL.
;
;  - We assume that any ".", "!", or "/" characters in signal names specify the
;    module hierarchy.  This assumption may not be valid if the Verilog you are
;    translating includes any escaped identifiers that use these characters,
;    but in practice it is probably not a problem.
;
;  - Your signal names must never contain two separators in a row (e.g., "..",
;    ".!", "!/", "!!") since we assume these are hierarchy separators.
;
;
; MAPPING NAMES TO VERILOG (EMAPS).
;
; Snapshots that include state names from E modules can be difficult to work
; with in a VCD viewer.  This is because the state names we generate in E, such
; as foo!bar!bit_0!BIT!S-, foo!bar!bit_1!BIT!S-, etc., do not really correspond
; to the actual regs in the Verilog design (e.g., foo.bar[0] and foo.bar[1]),
; and the "vector" nature of them is lost by breaking them into individual
; bits.
;
; To correct for this, VCD-DUMP can automatically apply an EMAP to rewrite your
; state-bit names into a more suitable form.  These EMAPS are generated by VL
; for each module.  At Centaur, we typically define |*foo-EMAP*| for every
; module |*foo*|.
;
;
; VIEWING VCD FILES.
;
; By default, VCD-DUMP will automatically launch "gtkwave" to allow you to view
; the resulting VCD file.  You can control this:
;
;     :viewer nil   -- just save the file, do not launch the viewer
;
;     :viewer "/path/to/my/viewer"   -- launch a different viewer
;
; We automatically suppress this during certify-book.
;
; EXAMPLES.
;
; See vcd-demo.lisp in this directory for a basic demo of using vcd-dump.

(local
 (progn
   ;; BOZO integrate this stuff into the supporting books

   ;; Should probably be local to prefix-hash
   (in-theory (disable butlast-1-removal))

   ;; Inappropriate forcing
   (in-theory (disable vl-emodwirelistlist-p-of-butlast
                       true-list-listp-of-last))


   ;; bizarre -- this already exists in strtok.lisp, so why did I add it?
   (defthm str::strtok-type
     (true-listp (str::strtok x delimiters))
     :rule-classes :type-prescription)

   (defthm first-of-last-under-iff-when-string-listp
     (implies (string-listp x)
              (iff (first (last x))
                   (consp x)))
     :hints(("Goal" :in-theory (e/d (last) ((force))))))

   (defthm stringp-of-car-when-string-listp
     (implies (string-listp x)
              (equal (stringp (car x))
                     (consp x))))

   (defthm string-listp-of-cdr
     (implies (string-listp x)
              (string-listp (cdr x))))

   (defthm strip-cars-under-iff
     (iff (strip-cars x)
          (consp x))
     :hints(("Goal" :in-theory (enable strip-cars))))))


(defsection hons-shrink-each-alist

  ;; BOZO find me a home

  (defund hons-shrink-each-alist (x)
    (declare (xargs :guard t))
    (if (atom x)
        nil
      (cons (hons-shrink-alist (car x) nil)
            (hons-shrink-each-alist (cdr x)))))

  (local (in-theory (enable hons-shrink-each-alist)))

  (defthm hons-shrink-each-alist-when-atom
    (implies (atom x)
             (equal (hons-shrink-each-alist x)
                    nil)))

  (defthm hons-shrink-each-alist-of-cons
    (equal (hons-shrink-each-alist (cons a x))
           (cons (hons-shrink-alist a nil)
                 (hons-shrink-each-alist x)))))

(defun make-each-alist-fast (x)
  ;; BOZO find me a home
  "Applies make-fast-alist to each member of the list x."
  (declare (xargs :guard t))
  (mbe :logic x
       :exec (if (atom x)
                 x
               (cons (make-fast-alist (car x))
                     (make-each-alist-fast (cdr x))))))

(defun fast-alist-free-each (x)
  ;; BOZO find me a home
  "Applies fast-alist-free to each member of the list x."
  (declare (xargs :guard t))
  (mbe :logic x
       :exec
       (if (atom x)
           x
         (progn$ (fast-alist-free (car x))
                 (fast-alist-free-each (cdr x))
                 x))))



; -----------------------------------------------------------------------------
;
;                               SNAPSHOTS
;
; -----------------------------------------------------------------------------

(defsection vcd-name-split

; Example: ACL2::|foo.bar!baz[3]| --> (MV ("foo" "bar") "baz[3]")

  (defund vcd-name-split (x)
    "Returns (MV PATH TARGET)"
    (declare (xargs :guard (symbolp x)))
    (b* ((tokens (str::strtok (symbol-name x) (list #\. #\! #\/)))
         ((unless (consp tokens))
          (mv nil nil)))
      (mv (hons-copy (butlast tokens 1))
          (car (last tokens)))))

  ;; BOZO memoize?

  (local (in-theory (enable vcd-name-split)))

  (defthm string-listp-of-vcd-name-split-0
    (string-listp (mv-nth 0 (vcd-name-split x))))

  (defthm type-of-vcd-name-split-1
    (or (stringp (mv-nth 1 (vcd-name-split x)))
        (not (mv-nth 1 (vcd-name-split x))))
    :rule-classes :type-prescription))


(defsection vcd-name-p

; Recognize emod wires that can be split successfully and don't seem to have
; anything that would confuse the hierarchy.

; BOZO this might well be unnecessary now that we encode ., !, and / in emodwires,
; and indeed it might be pretty expensive to do this checking...

  (defund vcd-name-p (x)
    (declare (xargs :guard t))
    (b* (((unless (vl-emodwire-p x))
          nil)
         (name (vl-emodwire->basename x))
         ((when (or (str::substrp ".." name)
                    (str::substrp "!!" name)
                    (str::substrp "//" name)
                    (str::substrp ".!" name)
                    (str::substrp "!." name)
                    (str::substrp "./" name)
                    (str::substrp "/." name)
                    (str::substrp "!/" name)
                    (str::substrp "/!" name)))
          nil)
         ((mv & target)
          (vcd-name-split x)))
      (if target t nil)))

  (local (in-theory (enable vcd-name-p)))

  (defthm symbolp-when-vcd-name-p
    (implies (vcd-name-p x)
             (symbolp x))
    :rule-classes :compound-recognizer)

  (defthm vl-emodwire-p-when-vcd-name-p
    (implies (vcd-name-p x)
             (vl-emodwire-p x)))

  (defthm type-of-vcd-name-split-when-vcd-name-p
    (implies (vcd-name-p x)
             (stringp (mv-nth 1 (vcd-name-split x))))
    :rule-classes :type-prescription))


(defsection vcd-namelist-p

  (deflist vcd-namelist-p (x)
    (vcd-name-p x)
    :guard t
    :elementp-of-nil nil)

  (defthm vl-emodwirelist-p-when-vcd-namelist-p
    (implies (vcd-namelist-p x)
             (vl-emodwirelist-p x))
    :hints(("Goal" :induct (len x)))))



(defsection vcd-value-p

  (defund vcd-value-p (x)
    (declare (xargs :guard t))
    (if (consp x)
        (or (equal x (acl2::faig-f))
            (equal x (acl2::faig-t))
            (equal x (acl2::faig-x))
            (equal x (acl2::faig-z)))
      (or (eq x nil)
          (eq x 'acl2::f)
          (eq x t)
          (eq x 'acl2::x)
          (eq x 'acl2::z)
          (eq x 'acl2::u))))

  (definlined vcd-value->char (x)
    (declare (xargs :guard t))
    (b* (((unless (vcd-value-p x))
          (er hard? 'vcd-value->char "Not a vcd-value-p: ~x0." x)
          #\x)
         ((when (consp x))
          (cond ((equal x (acl2::faig-f)) #\0)
                ((equal x (acl2::faig-t)) #\1)
                ((equal x (acl2::faig-z)) #\z)
                (t                        #\x))))
      (case x
        ((nil acl2::f) #\0)
        ((t)           #\1)
        ((acl2::x)     #\x)
        (otherwise     #\z))))

  (local
   (progn
     (assert! (equal (vcd-value->char nil) #\0))
     (assert! (equal (vcd-value->char 'acl2::f) #\0))
     (assert! (equal (vcd-value->char 't) #\1))
     (assert! (equal (vcd-value->char 'acl2::x) #\x))
     (assert! (equal (vcd-value->char 'acl2::z) #\z))
     (assert! (equal (vcd-value->char 'acl2::u) #\z))
     (assert! (equal (vcd-value->char (acl2::faig-f)) #\0))
     (assert! (equal (vcd-value->char (acl2::faig-t)) #\1))
     (assert! (equal (vcd-value->char (acl2::faig-x)) #\x))
     (assert! (equal (vcd-value->char (acl2::faig-z)) #\z)))))


(defsection vcd-valuelist-p

  (deflist vcd-valuelist-p (x)
    (vcd-value-p x)
    :guard t
    :elementp-of-nil t)

  (defprojection vcd-valuelist->chars (x)
    (vcd-value->char x)
    :guard t
    :nil-preservingp nil)

  (defthm character-listp-of-vcd-valuelist->chars
    (character-listp (vcd-valuelist->chars x))
    :hints(("Goal" :induct (len x)))))



(defalist vcd-snapshot-p (x)
  :key (vcd-name-p x)
  :val (vcd-value-p x)
  :keyp-of-nil nil
  :valp-of-nil t)

(defsection vcd-snapshotlist-p

  (deflist vcd-snapshotlist-p (x)
    (vcd-snapshot-p x)
    :guard t
    :elementp-of-nil t)

  (defthm vcd-snapshotlist-p-of-hons-shrink-each-alist
    (implies (vcd-snapshotlist-p x)
             (vcd-snapshotlist-p (hons-shrink-each-alist x)))
    :hints(("Goal" :induct (len x)))))



(defsection snapshot-debugging

  (defun vcd-debug-snapshot (x)
    (declare (xargs :guard t))
    (b* (((when (atom x))
          nil)
         ((when (atom (car x)))
          (cw "Non-consp entry in snapshot: ~x0.~%" (car x))
          (vcd-debug-snapshot (cdr x)))
         (name (caar x))
         (val  (cdar x))
         (- (or (vcd-name-p name)
                (cw "Bad signal name for snapshot: ~x0. (val = ~x1)~%" name val)))
         (- (or (vcd-value-p val)
                (cw "Bad value for snapshot: ~x0. (name = ~x1)~%" val name))))
      (vcd-debug-snapshot (cdr x))))

  (defun vcd-debug-snapshotlist (x)
    (declare (xargs :guard t))
    (if (atom x)
        nil
      (prog2$ (vcd-debug-snapshot (car x))
              (vcd-debug-snapshotlist (cdr x))))))



(defsection vcd-fast-snapshotlist-p

; Checking for valid snapshots was taking a lot of time.  We now implement a
; faster check that only works if the snapshots are pre-sorted.  We avoid using
; vcd-name-p on the keys of subsequent snapshots, by first checking that the
; first snapshot's names are okay, then checking that the subsequent snapshots
; have identical names.

  (defund vcd-snapshot-names-okp (x)
    (declare (xargs :guard t))
    (if (atom x)
        t
      (if (atom (car x))
          nil
        (and (vcd-name-p (caar x))
             (vcd-snapshot-names-okp (cdr x))))))

  (defund vcd-snapshot-values-okp (x)
    (declare (xargs :guard t))
    (if (atom x)
        t
      (if (atom (car x))
          nil
        (and (vcd-value-p (cdar x))
             (vcd-snapshot-values-okp (cdr x))))))

  ;; Experimentally it seems better to check symbolp and eq, rather than equal.
  ;;
  ;; (let ((x 'foo)
  ;;       (y 'bar))
  ;;   ;; 2.019 seconds
  ;;   (time (loop for i fixnum from 1 to 1000000000 do
  ;;               (and (symbolp x)
  ;;                    (eq x y))))
  ;;   ;; 3.688 seconds
  ;;   (time (loop for i fixnum from 1 to 1000000000 do
  ;;               (equal x y))))

  (defund vcd-snapshot-keys-agree-p (x y)
    (declare (xargs :guard t))
    (if (atom x)
        (atom y)
      (and (consp (car x))
           (consp y)
           (consp (car y))
           (symbolp (caar x))
           (eq (caar x) (caar y))
           (vcd-snapshot-keys-agree-p (cdr x) (cdr y)))))

  (defund vcd-snapshotlist-keys-agree-p (x)
    (declare (xargs :guard t))
    (if (atom x)
        t
      (if (atom (cdr x))
          t
        (and (vcd-snapshot-keys-agree-p (car x) (cadr x))
             (vcd-snapshotlist-keys-agree-p (cdr x))))))

  (deflist vcd-snapshotlist-values-okp (x)
    (vcd-snapshot-values-okp x)
    :guard t
    :elementp-of-nil t)

  (deflist setlist-p (x)
    (setp x)
    :guard t
    :elementp-of-nil t)

  (defund vcd-fast-snapshotlist-p (x)
    (declare (xargs :guard (setlist-p x)))
    (if (atom x)
        t
      (and (vcd-snapshot-names-okp (car x))
           (vcd-snapshotlist-keys-agree-p x)
           (vcd-snapshotlist-values-okp x))))

  (local (defthm l0
           (implies (and (vcd-snapshot-names-okp x)
                         (vcd-snapshot-values-okp x))
                    (vcd-snapshot-p x))
           :hints(("Goal" :in-theory (enable vcd-snapshot-names-okp
                                             vcd-snapshot-values-okp)))))

  (local (defthm l1
           (implies (and (vcd-snapshot-keys-agree-p x y)
                         (vcd-snapshot-names-okp x))
                    (vcd-snapshot-names-okp y))
           :hints(("Goal" :in-theory (enable vcd-snapshot-keys-agree-p
                                             vcd-snapshot-names-okp)))))

  (local (defthm l2
           (implies (and (vcd-snapshot-names-okp (first x))
                         (vcd-snapshotlist-keys-agree-p x)
                         (vcd-snapshotlist-values-okp x))
                    (vcd-snapshotlist-p x))
           :hints(("Goal" :induct (len x)
                   :in-theory (enable vcd-snapshot-names-okp
                                      vcd-snapshotlist-keys-agree-p
                                      vcd-snapshotlist-values-okp)))))

  (defthm vcd-fast-snapshotlist-p-correct
    (implies (vcd-fast-snapshotlist-p x)
             (vcd-snapshotlist-p x))
    :hints(("Goal" :in-theory (enable vcd-fast-snapshotlist-p)))))




; -----------------------------------------------------------------------------
;
;                      REWRITING SNAPSHOTS WITH EMAPS
;
; -----------------------------------------------------------------------------

(defund usable-subseq (x start end)
  (declare (xargs :guard (stringp x)))
  (b* ((x (string-fix x))
       (len (length x))
       ((unless (and (natp start)
                     (<= start len)))
        (er hard? 'usable-subseq "Bad arguments to subseq: ~x0[~x1:~x2]" x start end)
        "")
       ((when (not end))
        (subseq x start nil))
       ((unless (and (natp end)
                     (<= start end)
                     (<= end len)))
        (er hard? 'usable-subseq "Bad arguments to subseq: ~x0[~x1:~x2]" x start end)
        ""))
    (subseq x start end)))

(defthm stringp-of-usable-subseq
  (stringp (usable-subseq x start end))
  :rule-classes :type-prescription
  :hints(("Goal" :in-theory (enable usable-subseq))))


(defund vcd-emap-signal-hack (x)
  ;; Convert names like |foo[3]:slave| to foo_SLAVE[3] and |foo:master| to
  ;; foo_MASTER.  We use this to rewrite an emap into a usable form.
  (declare (xargs :guard t))
  (b* (((unless (symbolp x))
        (er hard? 'vcd-emap-signal-hack "Expected a symbol."))
       (name (symbol-name x))
       ((when (str::strsuffixp ":slave" name))
        (b* (([ (str::strrpos "[" name))
             (] (str::strrpos "]" name))
             (new-name (cond ((and (not [) (not ]))
                              (str::cat (usable-subseq name 0
                                                       (- (length name) (length ":slave")))
                                        "_SLAVE"))
                             ((and [ ])
                              (str::cat (usable-subseq name 0 [)
                                        "_SLAVE"
                                        (usable-subseq name [ (+ 1 ]))))
                             (t
                              (prog2$
                               (er hard? 'vcd-emap-signal-hack "Bad signal name: ~x0." x)
                               "")))))
          (intern-in-package-of-symbol new-name x)))
       ((when (str::strsuffixp ":master" name))
        (b* (([ (str::strrpos "[" name))
             (] (str::strrpos "]" name))
             (new-name (cond ((and (not [) (not ]))
                              (str::cat (usable-subseq name 0
                                                       (- (length name) (length ":master")))
                                        "_MASTER"))
                             ((and [ ])
                              (str::cat (usable-subseq name 0 [)
                                        "_MASTER"
                                        (usable-subseq name [ (+ 1 ]))))
                             (t
                              (prog2$
                               (er hard? 'vcd-emap-signal-hack "Bad signal name: ~x0." x)
                               "")))))
          (intern-in-package-of-symbol new-name x))))
    x))

(defthm symbolp-of-vcd-emap-signal-hack
  (symbolp (vcd-emap-signal-hack x))
  :rule-classes :type-prescription
  :hints(("Goal" :in-theory (enable vcd-emap-signal-hack))))

(local
 (progn
   (assert! (equal (vcd-emap-signal-hack '|foo|) '|foo|))
   (assert! (equal (vcd-emap-signal-hack '|foo[3]|) '|foo[3]|))
   (assert! (equal (vcd-emap-signal-hack '|foo:slave|) '|foo_SLAVE|))
   (assert! (equal (vcd-emap-signal-hack '|foo[3]:slave|) '|foo_SLAVE[3]|))
   (assert! (equal (vcd-emap-signal-hack '|foo[13]:slave|) '|foo_SLAVE[13]|))
   (assert! (equal (vcd-emap-signal-hack '|foo:master|) '|foo_MASTER|))
   (assert! (equal (vcd-emap-signal-hack '|foo[3]:master|) '|foo_MASTER[3]|))
   (assert! (equal (vcd-emap-signal-hack '|foo[13]:master|) '|foo_MASTER[13]|))))

(defund vcd-emap-hack (emap)
  (declare (xargs :guard t))
  (cond ((atom emap)
         nil)
        ((atom (car emap))
         (cw "vcd-emap-hack: removing ill-formed emap entry ~x0." (car emap)))
        (t
         (hons-acons (caar emap) ;; ename, which we want to preserve
                     (vcd-emap-signal-hack (cdar emap)) ;; vname, which we want to alter
                     (vcd-emap-hack (cdr emap))))))

(defun vcd-rewrite-snapshot (x hacked-emap)
  (declare (xargs :guard t))
  (cond ((atom x)
         nil)
        ((atom (car x))
         (cw "vcd-rewrite-snapshot: removing ill-formed snapshot entry ~x0." (car x)))
        (t
         (let ((lookup (hons-get (caar x) hacked-emap)))
           (if lookup
               (cons (cons (cdr lookup) (cdar x))
                     (vcd-rewrite-snapshot (cdr x) hacked-emap))
             (cons (car x)
                   (vcd-rewrite-snapshot (cdr x) hacked-emap)))))))

(defun vcd-rewrite-snapshotlist (x hacked-emap)
  (declare (xargs :guard t))
  (if (atom x)
      nil
    (cons (vcd-rewrite-snapshot (car x) hacked-emap)
          (vcd-rewrite-snapshotlist (cdr x) hacked-emap))))




; -----------------------------------------------------------------------------
;
;                                    VCD NETS
;
; -----------------------------------------------------------------------------
;
; To build a VCD file, we first organize the signals in the simulation into
; VCD-NET structures.  The main purpose of these structures is to group up
; wires that are part of the same vector, e.g., we want to treat { foo[0],
; foo[1], ..., foo[5] } as a single vector, foo, because VCD files and viewers
; have support for such vectors.  Note: here we are assuming that any emaps
; have already been applied, so we don't try to deal with :slave/:master
; nonsense.

(defaggregate vcd-net
  (path       ;; Hierarchy leading to this signal
   target     ;; Name of the target signal with no hierarchy
   syms       ;; List of emodwires that form the vector's value in MSB-first order.
   idcode     ;; Identifier codes
   )
  :tag :vcd-net
  :legiblep nil ;; Necessary for acl2-count hack
  :require
  ((string-listp-of-vcd-net->path
    (string-listp path)
    :rule-classes ((:rewrite)
                   (:type-prescription :corollary
                                       (implies (force (vcd-net-p x))
                                                (true-listp (vcd-net->path x))))))
   (stringp-of-vcd-net->target
    (stringp target)
    :rule-classes :type-prescription)
   (symbol-listp-of-vcd-net->syms
    (symbol-listp syms)
    :rule-classes ((:rewrite)
                   (:type-prescription :corollary
                                       (implies (force (vcd-net-p x))
                                                (true-listp (vcd-net->syms x))))))
   (vl-maybe-string-p-of-vcd-net->idcode
    (vl-maybe-string-p idcode)
    :rule-classes :type-prescription)))

(defthm consp-of-vcd-net->path
  (implies (vcd-net-p x)
           (iff (consp (vcd-net->path x))
                (vcd-net->path x))))

(deflist vcd-netlist-p (x)
  (vcd-net-p x)
  :guard t
  :elementp-of-nil nil)

(defprojection vcd-netlist->paths (x)
  (vcd-net->path x)
  :guard (vcd-netlist-p x)
  :nil-preservingp t)

(defmapappend vcd-netlist-allsyms (x)
  (vcd-net->syms x)
  :guard (vcd-netlist-p x))


; Now we have a bunch of ugly code to group up the symbols into VCD-NETs.  We
; start by organizing the symbols into buckets based on their paths.  We call
; these "partitioned names" structures.

(defsection vcd-partitioned-names-p

  (defund vcd-partitioned-names-p (x)
    (declare (xargs :guard t))
    (if (atom x)
        t
      (and (consp (car x))
           (string-listp (caar x))
           (vcd-namelist-p (cdar x))
           (vcd-partitioned-names-p (cdr x)))))

  (local (in-theory (enable vcd-partitioned-names-p)))

  (defthm vcd-partitioned-names-p-when-atom
    (implies (atom x)
             (vcd-partitioned-names-p x)))

  (defthm vcd-partitioned-names-p-of-cons
    (equal (vcd-partitioned-names-p (cons a x))
           (and (consp a)
                (string-listp (car a))
                (vcd-namelist-p (cdr a))
                (vcd-partitioned-names-p x))))

  (defthm vcd-partitioned-names-p-of-hons-bucket-insert
    (implies (and (vcd-partitioned-names-p x)
                  (string-listp path)
                  (vcd-name-p name))
             (vcd-partitioned-names-p (hons-bucket-insert path name x)))
    :hints(("Goal" :in-theory (enable hons-bucket-insert))))

  (defthm vcd-partitioned-names-p-of-hons-shrink-alist
    (implies (and (vcd-partitioned-names-p x)
                  (vcd-partitioned-names-p acc))
             (vcd-partitioned-names-p (hons-shrink-alist x acc)))
    :hints(("Goal" :in-theory (enable (:induction hons-shrink-alist))))))


(defsection vcd-name-partition

  (defund vcd-name-partition-aux (names buckets)
    (declare (xargs :guard (vcd-namelist-p names)))
    (b* (((when (atom names))
          buckets)
         ((mv path &) (vcd-name-split (car names)))
         (buckets     (hons-bucket-insert path (car names) buckets)))
      (vcd-name-partition-aux (cdr names) buckets)))

  (defund vcd-name-partition (names)
    (declare (xargs :guard (vcd-namelist-p names)))
    (b* ((buckets (vcd-name-partition-aux names nil))
         (ret     (hons-shrink-alist buckets nil))
         (-       (fast-alist-free buckets)))
      ret))

  (local (in-theory (enable vcd-name-partition-aux
                            vcd-name-partition)))

  (defthm vcd-partitioned-names-p-of-vcd-name-partition-aux
    (implies (and (vcd-namelist-p names)
                  (vcd-partitioned-names-p buckets))
             (vcd-partitioned-names-p (vcd-name-partition-aux names buckets))))

  (defthm vcd-partitioned-names-p-of-vcd-name-partition
    (implies (force (vcd-namelist-p names))
             (vcd-partitioned-names-p (vcd-name-partition names)))))


(defsection vcd-emodwires-with-merged-index

;; Goofy function to extract the emodwires that match a merged index from a
;; superior list of emodwires.  We use this to collect the :syms for a vcd-net.

  (local (in-theory (enable vl-merged-index-p)))

  (defund vcd-emodwires-with-merged-index (index wires)
    (declare (xargs :guard (and (vl-merged-index-p index)
                                (vl-emodwirelist-p wires))))
    (b* (((when (atom wires))
          nil)
         (w1       (car wires))
         (w1-index (vl-emodwire->index w1))
         (matchp   (cond ((not index)  (not w1-index))
                         ((natp index) (equal w1-index index))
                         (t (let ((low  (car index))
                                  (high (cdr index)))
                              (and (natp w1-index)
                                   (<= low w1-index)
                                   (<= w1-index high))))))
         (rest     (vcd-emodwires-with-merged-index index (cdr wires))))
      (if matchp
          (cons (car wires) rest)
        rest)))

  (local (in-theory (enable vcd-emodwires-with-merged-index)))

  (defthm vl-emodwirelist-p-of-vcd-emodwires-with-merged-index
    (implies (and (vl-merged-index-p index)
                  (vl-emodwirelist-p wires))
             (vl-emodwirelist-p (vcd-emodwires-with-merged-index index wires)))))


(defsection vcd-net-from-merged-index

;; We assume wires are sorted!!

  (local (in-theory (enable vl-merged-index-p)))

  (defund vcd-net-from-merged-index (path target index wires)
    (declare (xargs :guard (and (string-listp path)
                                (stringp target)
                                (vl-merged-index-p index)
                                (vl-emodwirelist-p wires))
                    :guard-debug t))
    (b* ((syms (vcd-emodwires-with-merged-index index wires))
         ((when (not index))
          (or (= (length syms) 1)
              (er hard? 'vcd-net-from-merged-index "Expected one wire."))
          (make-vcd-net :path   path
                        :target target
                        :syms   syms))
         ((when (natp index))
          (or (= (length syms) 1)
              (er hard? 'vcd-net-from-merged-index "Expected one wire."))
          (make-vcd-net :path   path
                        :target (str::cat target "[" (str::natstr index) "]")
                        :syms   syms))
         (low   (car index))
         (high  (cdr index))
         (width (+ 1 (- high low))))
      (or (= width (length syms))
          (er hard? 'vcd-net-from-merged-index "Expected ~x0 wires, found ~x1."
              width (length syms)))
      (make-vcd-net :path   path
                    :target (str::cat target "[" (str::natstr high) ":" (str::natstr low) "]")
                    ;; Syms are in LSB order but we want MSB order.
                    :syms   (reverse syms))))

  (local (in-theory (enable vcd-net-from-merged-index)))

  (defthm vcd-net-p-of-vcd-net-from-merged-index
    (implies (and (force (string-listp path))
                  (force (stringp target))
                  (force (vl-merged-index-p index))
                  (force (vl-emodwirelist-p wires)))
             (vcd-net-p (vcd-net-from-merged-index path target index wires)))))


(defsection vcd-nets-from-merged-indices

;; Assumes wires are sorted.

  (defprojection vcd-nets-from-merged-indices (path target x wires)
    (vcd-net-from-merged-index path target x wires)
    :guard (and (string-listp path)
                (stringp target)
                (vl-merged-index-list-p x)
                (vl-emodwirelist-p wires)))

  (local (in-theory (enable vcd-nets-from-merged-indices)))

  (defthm vcd-netlist-p-of-vcd-nets-from-merged-index
    (implies (and (force (string-listp path))
                  (force (stringp target))
                  (force (vl-merged-index-list-p indices))
                  (force (vl-emodwirelist-p wires)))
             (vcd-netlist-p (vcd-nets-from-merged-indices path target indices wires)))))


(defsection vcd-collect-emodwires

; Assumes the list is sorted so we only gather names from the front.  Returns
; (MV MATCHES REST) where MATCHES are the emodwires with this name and REST are
; any other emodwires.

  (defund vcd-collect-emodwires (name x)
    (declare (xargs :guard (and (stringp name)
                                (vl-emodwirelist-p x))))
    (cond ((atom x)
           (mv nil x))
          ((equal name (vl-emodwire->basename (car x)))
           (mv-let (more-matches rest)
             (vcd-collect-emodwires name (cdr x))
             (mv (cons (car x) more-matches)
                 rest)))
          (t
           (mv nil x))))

  (local (in-theory (enable vcd-collect-emodwires)))

  (defthm vcd-collect-emodwires-basics
    (implies (and (force (stringp name))
                  (force (vl-emodwirelist-p x)))
             (let ((result (vcd-collect-emodwires name x)))
               (and (subsetp-equal (mv-nth 0 result) x)
                    (subsetp-equal (mv-nth 1 result) x)))))

  (defthm acl2-count-of-vcd-collect-emodwires-weak
    (<= (acl2-count (mv-nth 1 (vcd-collect-emodwires name x)))
        (acl2-count x))
    :rule-classes ((:rewrite) (:linear)))

  (defthm acl2-count-of-vcd-collect-emodwires-strong
    (implies (and (consp x)
                  (equal name (vl-emodwire->basename (car x))))
             (< (acl2-count (mv-nth 1 (vcd-collect-emodwires name x)))
                (acl2-count x)))
    :rule-classes ((:rewrite) (:linear))))



(defsection vcd-nets-from-split-up-wire

  (local (defthm crock
           (implies (vl-merged-index-list-p x)
                    (or (not (consp x))
                        (not (first x))
                        (natp (first x))
                        (and (consp (first x))
                             (natp (caar x)))))
           :rule-classes :forward-chaining
           :hints(("Goal" :in-theory (enable vl-merged-index-list-p
                                             vl-merged-index-p)))))

  (defund vcd-nets-from-split-up-wire (path target merged-indices wires)
    (declare (xargs :guard (and (string-listp path)
                                (stringp target)
                                (vl-merged-index-list-p merged-indices)
                                (vl-emodwirelist-p wires))
                    :guard-debug t))
    (b* (((when (atom merged-indices))
          nil)
         (index1 (car merged-indices))
         (low    (if (atom index1)
                     (nfix index1)
                   (car index1)))
         (target-part (str::cat target "_part" (str::natstr low))))
      (cons (vcd-net-from-merged-index path target-part index1 wires)
            (vcd-nets-from-split-up-wire path target (cdr merged-indices) wires))))

  (local (in-theory (enable vcd-nets-from-split-up-wire)))

  (defthm vcd-netlist-p-of-vcd-nets-from-split-up-wire
    (implies (and (force (string-listp path))
                  (force (stringp target))
                  (force (vl-merged-index-list-p indices))
                  (force (vl-emodwirelist-p wires)))
             (vcd-netlist-p (vcd-nets-from-split-up-wire path target indices wires)))))



(defsection vcd-nets-from-emodwires

; Assumes wires are sorted so we only need to gather names from the front.  The
; wires must agree on their path but may have different names.  We group up
; wires by their names, merge their indices, and put them into nets.  The
; resulting nets are "as few as possible."

  (defund vcd-nets-from-emodwires (path wires)
    (declare (xargs :guard (and (string-listp path)
                                (vl-emodwirelist-p wires))))
    (b* (((when (atom wires))
          nil)
         (name1             (vl-emodwire->basename (car wires)))
         ((mv group1 rest)  (vcd-collect-emodwires name1 wires))
         (plain-indices     (vl-emodwirelist->indices group1))
         (merged-indices    (vl-merge-contiguous-indices plain-indices))
         (target            (or (car (last (str::strtok name1 (list #\. #\! #\/))))
                                (progn$ (er hard? 'vcd-nets-from-emodwires
                                            "Bad wire: ~x0." (car wires))
                                        "")))

         (group1-nets
          (if (or (atom merged-indices)
                  (atom (cdr merged-indices)))
              ;; Ordinary case: one contiguous range:
              (vcd-nets-from-merged-indices path target merged-indices group1)
            ;; Special case: split multiple ranges into _part1 _part5 etc.
            (vcd-nets-from-split-up-wire path target merged-indices group1)))

         (other-nets (vcd-nets-from-emodwires path rest)))
      (append group1-nets other-nets)))

  (local (in-theory (enable vcd-nets-from-emodwires)))

  (defthm vcd-netlist-p-of-vcd-nets-from-emodwires
    (implies (and (string-listp path)
                  (vl-emodwirelist-p wires))
             (vcd-netlist-p (vcd-nets-from-emodwires path wires)))))


(defsection vcd-nets-from-partitioned-names

  (defund vcd-nets-from-partitioned-names (x)
    (declare (xargs :guard (vcd-partitioned-names-p x)))
    (if (atom x)
        nil
      (b* ((path1       (caar x))
           (wires1      (cdar x))
           (wires1-sort (vl-emodwire-sort (redundant-list-fix wires1)))
           (nets1       (vcd-nets-from-emodwires path1 wires1-sort)))
        (append nets1
                (vcd-nets-from-partitioned-names (cdr x))))))

  (local (in-theory (enable vcd-nets-from-partitioned-names)))

  (defthm vcd-netlist-p-of-vcd-nets-from-partitioned-names
    (implies (vcd-partitioned-names-p x)
             (vcd-netlist-p (vcd-nets-from-partitioned-names x)))
    ;; speed hint
    :hints(("Goal" :in-theory (disable subsetp-equal-when-first-two-same-yada-yada)))))



; Each VCD-NET needs to be assigned an identifier code.  These codes are listed
; in the variable definition section of the VCD file, and are then later used
; to refer to the variable when its value changes.  For each variable, we want
; to assign an arbitrary ASCII identifier using only printable characters from
; ! to ~ (i.e., character codes 33 to 126).  There are 93 of these numbers, so
; we basically do a base-93 encoding of our input, using (code-char 33) to
; represent 0, (code-char 34) for 1, and so forth, up to (code-char 126) for
; the 92nd digit.

(defsection vcd-93-bit-encode

  ;; This is roughly like explode-atom with a print-base of 93.

  (local (include-book "arithmetic-3/floor-mod/floor-mod" :dir :system))
  (local (in-theory (enable acl2-count)))

  (defund vcd-93-bit-encode-aux (n acc)
    (declare (xargs :guard (natp n)))
    (if (zp n)
        acc
      (vcd-93-bit-encode-aux
       (truncate n 93)
       (cons (code-char (the (unsigned-byte 8)
                             (+ (the (unsigned-byte 8) 33)
                                (the (unsigned-byte 8)
                                     (rem (the integer n) 93)))))
             acc))))

  (defund vcd-93-bit-encode-chars (n)
    (declare (xargs :guard (natp n)))
    (or (vcd-93-bit-encode-aux n nil)
        (list (code-char 33))))

  (local (in-theory (enable vcd-93-bit-encode-aux
                            vcd-93-bit-encode-chars)))

  (defthm character-listp-of-vcd-93-bit-encode-aux
    (implies (character-listp acc)
             (character-listp (vcd-93-bit-encode-aux n acc))))

  (defthm character-listp-of-vcd-93-bit-encode-chars
    (character-listp (vcd-93-bit-encode-chars n)))

  (defund vcd-93-bit-encode (n)
    (declare (xargs :guard (natp n)))
    (coerce (vcd-93-bit-encode-chars n) 'string))

  (defthm stringp-of-vcd-93-bit-encode
    (stringp (vcd-93-bit-encode n)))

  ;; A warm-fuzzy is that this returns T.
  ;;
  ;;   (uniquep (loop for i from 1 to 100000 collect (vl::vcd-93-bit-encode i)))

  )


(defsection vcd-make-codes

; Build a fast alist binding every net to a unique string made up of 93-bit
; printable ASCII characters.

  (defund vcd-make-codes-aux (nets free)
    (declare (xargs :guard (and (vcd-netlist-p nets)
                                (natp free))))
    (if (atom nets)
        nil
      (cons (change-vcd-net (car nets) :idcode (vcd-93-bit-encode free))
            (vcd-make-codes-aux (cdr nets) (+ 1 free)))))

  (defund vcd-make-codes (nets)
    (declare (xargs :guard (vcd-netlist-p nets)))
    (vcd-make-codes-aux nets 0))

  (local (in-theory (enable vcd-make-codes-aux
                            vcd-make-codes)))

  (defthm vcd-netlist-p-of-vcd-make-codes-aux
    (implies (and (vcd-netlist-p nets)
                  (natp free))
             (vcd-netlist-p (vcd-make-codes-aux nets free))))

  (defthm vcd-netlist-p-of-vcd-make-codes
    (implies (vcd-netlist-p nets)
             (vcd-netlist-p (vcd-make-codes nets)))))


(defsection vcd-make-nets

; Top level function for building VCD-NETS from names.  Does all necessary
; partitioning and sorting.  Double-checks that all signals are accounted for.

  (defund vcd-make-nets (names)
    (declare (xargs :guard (vcd-namelist-p names)))
    (b* ((partitioning (fast-alist-free (vcd-name-partition names)))
         (ret          (vcd-make-codes (vcd-nets-from-partitioned-names partitioning)))
         (orig-names-s (mergesort names))
         (ret-names    (vcd-netlist-allsyms ret))
         (ret-names-s  (mergesort ret-names)))
      (or (equal orig-names-s ret-names-s)
          (er hard? 'vcd-make-nets
              "VCD-NET syms don't match initial names.  ~
                - Lost names: ~x0.  ~
                - Somehow added names: ~x1."
              (difference orig-names-s ret-names-s)
              (difference ret-names-s orig-names-s)))
      (or (same-lengthp ret-names ret-names-s)
          (er hard? 'vcd-make-nets
              "Symbols are in multiple nets: ~x0."
              (duplicated-members ret-names)))
      ret))

  (local (in-theory (enable vcd-make-nets)))

  (defthm vcd-netlist-p-of-vcd-make-nets
    (implies (vcd-namelist-p names)
             (vcd-netlist-p (vcd-make-nets names)))))




; -----------------------------------------------------------------------------
;
;                     VARIABLE DECLARATION GENERATION
;
; -----------------------------------------------------------------------------
;
; We now want to build the declaration for each VCD-NET.
;
; A declaration looks like this:
;
;   $var  var_type  size   identifier_code   reference   $end
;           ^         ^           ^              ^
;           |         |           |              |
;          wire       |    93-bit encoded name   |
;                     |                          |
;                 width of wire           original name, can be
;                                            foo, foo[i], or
;                                           even foo[msb:lsb]
;
; This much is very straightforward once we have our VCD-NETs generated and
; their codes have been assigned.  We just say everything is a wire and the
; width is just the length of :syms.

(define vcd-print-var-decl ((x vcd-net-p) &key (ps 'ps))
  (b* (((vcd-net x) x)
       ((unless (stringp x.idcode))
        (er hard? 'vcd-net-to-declaration "no code for ~x0." x)
        ps))
    (vl-ps-seq (vl-print "$var wire ")
               (vl-print (length x.syms))
               (vl-print " ")
               (vl-print x.idcode)
               (vl-print " ")
               ;; BOZO might need to escape... bleh.
               (vl-print x.target)
               (vl-println " $end"))))

(define vcd-print-varlist-decls ((x vcd-netlist-p) &key (ps 'ps))
  (if (atom x)
      ps
    (vl-ps-seq (vcd-print-var-decl (car x))
               (vcd-print-varlist-decls (cdr x)))))

; Now we come to the tricky part: dealing with the hierarchy.  We basically
; need to organize the nets paths.  We basically have to write out something
; like this:
;
;    module foo {
;       $var ... $end
;       $var ... $end
;       module bar_inst1 {
;          $var ... $end
;          $var ... $end
;       }
;       module bar_inst2 {
;          $var ... $end
;          $var ... $end
;       }
;   }
;
; Except that the syntax is ten times uglier:
;
;     "module foo {"        -->   $scope module foo $end
;     "}"                   -->   $upscope $end
;
; This syntax is easy.  Organizing the nets into a hierarchy is trickier.

(defsection vcd-netlist-filter-atomic

  (defund vcd-netlist-filter-atomic (nets)
    (declare (xargs :guard (vcd-netlist-p nets)))
    (b* (((when (atom nets))
          (mv nil nil))
         ((mv yes no)
          (vcd-netlist-filter-atomic (cdr nets))))
      (if (atom (vcd-net->path (car nets)))
          (mv (cons (car nets) yes) no)
        (mv yes (cons (car nets) no)))))

  (local (in-theory (enable vcd-netlist-filter-atomic)))

  (defthm vcd-netlist-filter-atomic-basics
    (and (subsetp-equal (mv-nth 0 (vcd-netlist-filter-atomic nets)) nets)
         (subsetp-equal (mv-nth 1 (vcd-netlist-filter-atomic nets)) nets)))

  (defthm acl2-count-of-vcd-netlist-filter-atomic-1
    (<= (acl2-count (mv-nth 1 (vcd-netlist-filter-atomic nets)))
        (acl2-count nets))
    :hints(("Goal" :in-theory (e/d (acl2-count) ((force)))))
    :rule-classes ((:rewrite) (:linear))))


(defsection vcd-netlist-filter-path1

  (defund vcd-netlist-filter-path1 (path1 nets)
    (declare (xargs :guard (and (stringp path1)
                                (vcd-netlist-p nets))))
    (b* (((when (atom nets))
          (mv nil nil))
         ((mv yes no)
          (vcd-netlist-filter-path1 path1 (cdr nets))))
      (if (equal path1 (car (vcd-net->path (car nets))))
          (mv (cons (car nets) yes) no)
        (mv yes (cons (car nets) no)))))

  (local (in-theory (enable vcd-netlist-filter-path1)))

  (defthm vcd-netlist-filter-path1-basics
    (and (subsetp-equal (mv-nth 0 (vcd-netlist-filter-path1 path1 nets)) nets)
         (subsetp-equal (mv-nth 1 (vcd-netlist-filter-path1 path1 nets)) nets)))

  (defthm vcd-netlist-p-of-vcd-netlist-filter-path1
    (implies (force (vcd-netlist-p nets))
             (and (vcd-netlist-p (mv-nth 0 (vcd-netlist-filter-path1 path1 nets)))
                  (vcd-netlist-p (mv-nth 1 (vcd-netlist-filter-path1 path1 nets))))))

  (defthm acl2-count-of-vcd-netlist-filter-path1-weak-0
    (<= (acl2-count (mv-nth 0 (vcd-netlist-filter-path1 path1 nets)))
        (acl2-count nets))
    :hints(("Goal" :in-theory (enable acl2-count)))
    :rule-classes ((:rewrite) (:linear)))

  (defthm acl2-count-of-vcd-netlist-filter-path1-weak-1
    (<= (acl2-count (mv-nth 1 (vcd-netlist-filter-path1 path1 nets)))
        (acl2-count nets))
    :hints(("Goal" :in-theory (enable acl2-count)))
    :rule-classes ((:rewrite) (:linear)))

  (defthm acl2-count-of-vcd-netlist-filter-path1-strong
    (implies (and (equal (car (vcd-net->path (car nets))) path1)
                  (consp nets))
             (< (acl2-count (mv-nth 1 (vcd-netlist-filter-path1 path1 nets)))
                (acl2-count nets)))
    :hints(("Goal" :in-theory (enable acl2-count)))
    :rule-classes ((:rewrite) (:linear))))


(defsection vcd-netlist-drop-path1

  (defund vcd-netlist-drop-path1 (x)
    (declare (xargs :guard (vcd-netlist-p x)))
    (if (atom x)
        nil
      (let* ((net1     (car x))
             (old-path (vcd-net->path net1))
             (new-path (cdr old-path)))
        (cons (change-vcd-net net1 :path new-path)
              (vcd-netlist-drop-path1 (cdr x))))))

  (local (in-theory (enable vcd-netlist-drop-path1)))

  (defthm vcd-netlist-p-of-vcd-netlist-drop-path1
    (implies (vcd-netlist-p x)
             (vcd-netlist-p (vcd-netlist-drop-path1 x))))

  (local (defthm c0
           (implies (and (<= a b)
                         (<= c d))
                    (<= (+ a c) (+ b d)))))

  (local (defthm c1
           (implies (and (<= a b)
                         (<= c d))
                    (<= (+ c a) (+ b d)))))

  (local (defthm l0
           (implies (and (<= (acl2-count path)
                             (acl2-count (vcd-net->path x)))
                         (vcd-net-p x))
                    (<= (acl2-count (change-vcd-net x :path path))
                        (acl2-count x)))
           :hints(("Goal"
                   :in-theory (enable acl2-count
                                      vcd-net-p
                                      vcd-net
                                      vcd-net->target
                                      vcd-net->syms
                                      vcd-net->idcode
                                      vcd-net->path)
                   :do-not '(generalize fertilize)
                   :do-not-induct t))))

  (local (defthm l1
           (implies (and (< (acl2-count path)
                            (acl2-count (vcd-net->path x)))
                         (vcd-net-p x))
                    (< (acl2-count (change-vcd-net x :path path))
                       (acl2-count x)))
           :hints(("Goal"
                   :in-theory (enable acl2-count
                                      vcd-net-p
                                      vcd-net
                                      vcd-net->target
                                      vcd-net->syms
                                      vcd-net->idcode
                                      vcd-net->path)
                   :do-not '(generalize fertilize)
                   :do-not-induct t))))

  (defthm acl2-count-of-vcd-netlist-drop-path1-weak
    (implies (vcd-netlist-p nets)
             (<= (acl2-count (vcd-netlist-drop-path1 nets))
                 (acl2-count nets)))
    :rule-classes ((:rewrite) (:linear))
    :hints(("Goal"
            :in-theory (enable vcd-netlist-drop-path1 acl2-count)
            :do-not '(generalize fertilize))))

  (local (defthm c2
           (implies (and (< a b)
                         (<= 0 c))
                    (< a (+ b c)))))

  (local (defthm c3
           (implies (and (< a d)
                         (<= b c))
                    (< (+ a b) (+ c d)))))

  (local (defthm c4
           (implies (and (< a c)
                         (<= b d))
                    (< (+ a b) (+ c d)))))

  (local (defthm c5
           (implies (and (<= a d)
                         (< b c))
                    (< (+ a b) (+ c d)))))

  (defthm acl2-count-of-vcd-netlist-drop-path1-strong
    (implies (and (force (vcd-netlist-p nets))
                  (force (consp nets))
                  (force (consp (vcd-net->path (car nets)))))
             (< (acl2-count (vcd-netlist-drop-path1 nets))
                (acl2-count nets)))
    :rule-classes ((:rewrite) (:linear))
    :hints(("Goal"
            :induct (vcd-netlist-drop-path1 nets)
            :in-theory (enable vcd-netlist-drop-path1 acl2-count)
            :do-not '(eliminate-destructors generalize fertilize)))))


(defsection vcd-print-scopes-aux

  (local (defthm l0
           (implies (MV-NTH 1 (VCD-NETLIST-FILTER-ATOMIC NETS))
                    (consp (vcd-net->path (car (MV-NTH 1 (VCD-NETLIST-FILTER-ATOMIC NETS))))))
           :hints(("Goal" :in-theory (e/d (vcd-netlist-filter-atomic)
                                          ((force)))))))

  (local (defthm l1
           (implies (consp nets)
                    (CONSP (MV-NTH 0 (VCD-NETLIST-FILTER-PATH1 
                                      (first (VCD-NET->PATH (FIRST nets)))
                                      nets))))
           :hints(("Goal" :in-theory (enable vcd-netlist-filter-path1)))))

  (local (defthm l2
           (implies (consp nets)
                    (equal (CAR (MV-NTH 0 (VCD-NETLIST-FILTER-PATH1 
                                           (first (VCD-NET->PATH (FIRST nets)))
                                           nets)))
                           (CAR NETS)))
           :hints(("Goal" :in-theory (enable vcd-netlist-filter-path1)))))

  (define vcd-print-scopes-aux ((nets vcd-netlist-p) &key (ps 'ps))
    (b* (((unless (mbt (vcd-netlist-p nets)))
          ;; Stupid termination hack
          ps)
         ;; Start by printing any vars local to this scope.
         ((mv local-nets sub-nets)
          (vcd-netlist-filter-atomic nets))
         (ps (vcd-print-varlist-decls local-nets))
         ((when (atom sub-nets))
          ;; No subscopes, nothing else to print.
          ps)
         ;; Otherwise, we pick the first path and gather up all nets
         ;; that are related to it.
         (path1 (car (vcd-net->path (car sub-nets))))
         ((mv path1-nets other-nets)
          (vcd-netlist-filter-path1 path1 sub-nets))
         (ps (vl-ps-seq
              (vl-print "$scope module ")
              (vl-print path1) ;; bozo encoding issues
              (vl-println " $end")
              (vcd-print-scopes-aux (vcd-netlist-drop-path1 path1-nets))
              (vl-println "$upscope $end"))))
      ;; Finally we still need to print all the other stuff.
      (vcd-print-scopes-aux other-nets)))

  (define vcd-print-scopes ((nets vcd-netlist-p) &key (ps 'ps))
    (vl-ps-seq (vl-println "$scope module esim_top $end")
               (vcd-print-scopes-aux nets)
               (vl-println "$upscope $end"))))

(define vcd-print-header ((date stringp) (nets vcd-netlist-p) &key (ps 'ps))
  (vl-ps-seq (vl-print "$date ")
             (vl-println date)
             (vl-println "$end")
             (vl-println "$version ESIM Simulation")
             (vl-println "$end")
             ;; Timescale doesn't really make any sense, so we put in a totally
             ;; nonsensical timescale of 1 second.
             (vl-println "$timescale 1 s")
             (vl-println "$end")
             (vl-println "")
             (vcd-print-scopes nets)
             (vl-println "")
             (vl-println "$enddefinitions $end")))




; -----------------------------------------------------------------------------
;
;                           DUMP DATA GENERATION
;
; -----------------------------------------------------------------------------

(defsection maybe-compress-chars

; Changes to vectors may omit the first character in certain cases.  So this
; just drops any unnecessary leading bits.

  (defund maybe-compress-chars (x)
    (declare (xargs :guard (character-listp x)))
    (cond ((atom x)
           nil)
          ((atom (cdr x))
           x)
          (t
           (case (first x)
             (#\1 x) ;; no way to shorten
             (#\0
              (if (or (eql (second x) #\0)
                      (eql (second x) #\1))
                  (maybe-compress-chars (cdr x))
                x))
             (#\x
              (if (eql (second x) #\x)
                  (maybe-compress-chars (cdr x))
                x))
             (#\z
              (if (eql (second x) #\z)
                  (maybe-compress-chars (cdr x))
                x))))))

  (defthm character-listp-of-maybe-compress-chars
    (implies (character-listp x)
             (character-listp (maybe-compress-chars x)))
    :hints(("Goal" :in-theory (enable maybe-compress-chars)))))



(defsection vcd-print-netlist-updates

; Our top-level function for printing updates is VCD-PRINT-NETLIST-UPDATES,
; which takes a list of NETS (which we assume have been updated), and their
; current values, and prints a litany of VCD value_change elements to reflect
; these changes.

  (define vcd-print-net-update ((net vcd-net-p)
                                (snap vcd-snapshot-p)
                                &key (ps 'ps))
    (b* (((vcd-net net) net)
         ((when (atom net.syms))
          (raise "Net has no symbols: ~x0." net)
          ps)
         ((unless net.idcode)
          (raise "Net has no idcode: ~x0." net)
          ps)
         ((when (atom (cdr net.syms)))
          ;; Scalar net.
          (b* ((lookup (hons-get (car net.syms) snap))
               ((unless lookup)
                (raise "No binding for ~x0." net)
                ps))
            (vl-ps-seq (vl-print (vcd-value->char (cdr lookup)))
                       (vl-println net.idcode))))
         ;; Else, this is a vector net.
         (vals      (look-up-each-fast net.syms snap))
         (val-chars (maybe-compress-chars (vcd-valuelist->chars vals)))
         (rchars    (vl-ps->rchars))
         (rchars    (cons #\b rchars))
         (rchars    (revappend val-chars rchars))
         (rchars    (cons #\Space rchars))
         (rchars    (str::revappend-chars net.idcode rchars))
         (rchars    (cons #\Newline rchars))
         (ps        (vl-ps-update-rchars rchars))
         (ps        (vl-ps-update-col 0)))
      ps))

  (define vcd-print-netlist-updates ((nets vcd-netlist-p)
                                     (snap vcd-snapshot-p)
                                     &key (ps 'ps))
    (if (atom nets)
        ps
      (vl-ps-seq (vcd-print-net-update (car nets) snap)
                 (vcd-print-netlist-updates (cdr nets) snap)))))



; Of course we still have to figure out which elements have changed.  To do
; this, we first mergesort all the snapshots so that their keys will come in
; the proper order.  We can then just walk down both snapshots and see whether
; the values have changed, in a linear pass with no lookups needed.

(defprojection mergesort-lists (x)
  (mergesort x)
  :guard t
  :nil-preservingp t)

(defthm vcd-snapshotlist-p-of-mergesort-lists
  (implies (vcd-snapshotlist-p x)
           (vcd-snapshotlist-p (mergesort-lists x)))
  :hints(("Goal" :induct (len x))))



; I actually use redundant-mergesort-lists because it allows us to avoid doing
; the sorting when the snapshots are pre-sorted.  And, with some work, we can
; arrange things (in esim-snapshot.lisp) so that they will be sorted properly.

(defun redundant-mergesort-lists (x)
  (declare (xargs :guard t))
  (mbe :logic (mergesort-lists x)
       :exec (if (atom x)
                 nil
               (cons (redundant-mergesort (car x))
                     (redundant-mergesort-lists (cdr x))))))



(defsection vcd-snapshot-diff

; We use this to see what signals have changed between two snapshots.  It
; returns us a list of signal names that have changed.

  (local (defthm vcd-snapshot-keys-agree-elim
           (implies (and (vcd-snapshot-p x)
                         (vcd-snapshot-p y))
                    (equal (vcd-snapshot-keys-agree-p x y)
                           (equal (alist-keys x) (alist-keys y))))
           :hints(("Goal" :in-theory (enable vcd-snapshot-keys-agree-p
                                             alist-keys)))))

  (local (defthm alist-keys-when-vcd-snapshot-p
           (implies (vcd-snapshot-p x)
                    (iff (alist-keys x)
                         (consp x)))
           :hints(("Goal" :in-theory (enable alist-keys)))))

  (defund vcd-snapshot-diff (x y)
    (declare (xargs :guard (and (vcd-snapshot-p x)
                                (vcd-snapshot-p y)
                                (vcd-snapshot-keys-agree-p x y))))
    (cond ((atom x)
           nil)
          ((equal (cdar x) (cdar y))
           (vcd-snapshot-diff (cdr x) (cdr y)))
          (t
           (cons (caar y) (vcd-snapshot-diff (cdr x) (cdr y))))))

  (local (in-theory (enable vcd-snapshot-diff)))

  (defthm vcd-namelist-p-of-vcd-snapshot-diff
    (implies (and (force (vcd-snapshot-p x))
                  (force (vcd-snapshot-p y))
                  (force (equal (len x) (len y)))
                  (force (equal (alist-keys x) (alist-keys y))))
             (vcd-namelist-p (vcd-snapshot-diff x y)))))



; Once we find the signals that changed, we need to look up their associated
; nets.  To make this reasonably fast, we precompute a mapping from all signal
; names to their nets, and just use fast-alist lookups.

(defsection vcd-signal-map-p

  (defund vcd-signal-map-p (x)
    (declare (xargs :guard t))
    (if (atom x)
        t
      (and (consp (car x))
           (vcd-net-p (cdar x))
           (vcd-signal-map-p (cdr x)))))

  (local (in-theory (enable vcd-signal-map-p)))

  (defthm vcd-net-p-of-lookup-in-vcd-signal-map-p
    (implies (vcd-signal-map-p x)
             (equal (vcd-net-p (cdr (hons-assoc-equal name x)))
                    (if (hons-assoc-equal name x)
                        t
                      nil)))))


(defsection vcd-make-signal-map

  (defund hons-acons-each-key-to-val (keys val alist)
    (declare (xargs :guard t))
    (if (atom keys)
        alist
      (hons-acons-each-key-to-val (cdr keys)
                                  val
                                  (hons-acons (car keys) val alist))))

  (defund vcd-make-signal-map (nets)
    ;; Fast alist binding SYM -> NET for every SYM from every NET in NETS.
    ;; Lets us look up the net for this symbol.
    (declare (xargs :guard (vcd-netlist-p nets)))
    (if (atom nets)
        nil
      (hons-acons-each-key-to-val (vcd-net->syms (car nets))
                                  (car nets)
                                  (vcd-make-signal-map (cdr nets)))))

  (local (in-theory (enable hons-acons-each-key-to-val
                            vcd-make-signal-map
                            vcd-signal-map-p)))

  (defthm vcd-signal-map-p-of-hons-acons-each-key-to-val
    (implies (and (force (vcd-net-p net))
                  (force (vcd-signal-map-p alist)))
             (vcd-signal-map-p (hons-acons-each-key-to-val names net alist))))

  (defthm vcd-signal-map-p-of-vcd-make-signal-map
    (implies (vcd-netlist-p nets)
             (vcd-signal-map-p (vcd-make-signal-map nets)))))


(defsection vcd-look-up-nets

  (defund vcd-look-up-nets-aux (signals signal-map)
    (declare (xargs :guard (vcd-signal-map-p signal-map)))
    (b* (((when (atom signals))
          nil)
         (lookup (hons-get (car signals) signal-map))
         ((unless lookup)
          (er hard? 'vcd-look-up-nets-aux "No net for signal ~x0." (car signals))))
      (cons (cdr lookup)
            (vcd-look-up-nets-aux (cdr signals) signal-map))))

  (defund vcd-look-up-nets (signals signal-map)
    (declare (xargs :guard (vcd-signal-map-p signal-map)))
    (mergesort (vcd-look-up-nets-aux signals signal-map)))

  (local (in-theory (enable vcd-look-up-nets-aux
                            vcd-look-up-nets)))

  (defthm vcd-netlist-p-of-vcd-look-up-nets-aux
    (implies (vcd-signal-map-p signal-map)
             (vcd-netlist-p (vcd-look-up-nets-aux signals signal-map))))

  (defthm vcd-netlist-p-of-vcd-look-up-nets
    (implies (vcd-signal-map-p signal-map)
             (vcd-netlist-p (vcd-look-up-nets signals signal-map)))))


(define vcd-dump-aux (prev-snapshot snapshots signal-map time
                                    &key (ps 'ps))
  ;; All snapshots should be sorted, fast alists.
  :guard (and (vcd-snapshot-p prev-snapshot)
              (vcd-snapshotlist-p snapshots)
              (vcd-signal-map-p signal-map)
              (natp time))
  (b* (((when (atom snapshots))
        ps)
       (new-snapshot (car snapshots))
       ((unless (vcd-snapshot-keys-agree-p prev-snapshot new-snapshot))
        ;; Linear check that snapshots agree.
        (er hard? 'vcd-dump-aux
            "Expected same keys across all snapshots.  However, some snapshots ~
             do not have bindings for ~&0."
            (let ((keys1 (mergesort (alist-keys prev-snapshot)))
                  (keys2 (mergesort (alist-keys new-snapshot))))
              (union (difference keys1 keys2)
                     (difference keys2 keys1))))
        ps)
       (changed-sigs (vcd-snapshot-diff prev-snapshot new-snapshot))
       (changed-nets (vcd-look-up-nets changed-sigs signal-map))
       (ps (vl-ps-seq
            (vl-print "#")
            (vl-println time)
            (vl-println "$dumpall")
            (vcd-print-netlist-updates changed-nets new-snapshot)
            (vl-println "$end")
            (vl-println ""))))
    (vcd-dump-aux new-snapshot (cdr snapshots) signal-map
                  (+ 1 time))))

(define vcd-dump-main ((snapshots vcd-snapshotlist-p)
                       (nets      vcd-netlist-p)
                       &key (ps 'ps))
  (b* (((when (atom snapshots))
        (er hard? 'vcd-dump-main "No snapshots to dump?")
        ps)
       (first-snapshot (car snapshots))
       (ps (vl-ps-seq
            (vl-println "#0")
            (vl-println "$dumpvars")
            (vcd-print-netlist-updates nets first-snapshot)
            (vl-println "$end")
            (vl-println "")))
       (signal-map (vcd-make-signal-map nets))
       (ps (vcd-dump-aux first-snapshot (cdr snapshots) signal-map 1))
       (- (fast-alist-free signal-map)))
    ps))


(defttag writes-okp)
(remove-untouchable acl2::writes-okp nil)


(defun vcd-dump-fn-real (filename snapshots viewer emap state)
  (declare (xargs :guard (stringp filename)
                  :mode :program
                  :stobjs state))
  (b* (((mv date state) (oslib::date))
       ((unless (consp snapshots))
        (er hard? 'vcd-dump "No snapshots?")
        state)
       (snapshots
        ;; Rewrite the snapshots with the emap, if necessary
        (if emap
            (time$ (b* ((hacked-emap (vcd-emap-hack emap))
                        (snapshots   (vcd-rewrite-snapshotlist snapshots hacked-emap))
                        (-           (fast-alist-free hacked-emap)))
                     snapshots)
                   :msg "; vcd-dump applying emap: ~st seconds, ~sa bytes.~%")
          snapshots))
       (snapshots
        (time$ (b* (;; Remove any shadowed pairs before sorting the snapshots
                    (snapshots (hons-shrink-each-alist snapshots))
                    (snapshots (fast-alist-free-each snapshots))

; We now sort the snapshots so their keys are in the same order and make them
; fast so we can look up values quickly.

; SUBTLE: I use redundant-mergesort-lists which can avoid doing any consing at
; all if the snapshots are already sorted after being hons-shrink-each'ed.  But
; since hons-shrink-alist effectively reverses the snapshots, this means that
; to take advantage of this optimization you have to provide snapshots that are
; in reverse mergesorted order!  We try to do arrange for this to happen
; automatically in esim-snapshot.lisp.

                    (snapshots (redundant-mergesort-lists snapshots))
                    ;; Duplicate the final snapshot because otherwise it looks like
                    ;; the simulation ends early in a weird way
                    (snapshots (append snapshots (last snapshots)))
                    (snapshots (make-each-alist-fast snapshots)))
                 snapshots)
               ;; :mintime 1/2
               :msg "; vcd-dump snapshot preparation: ~st seconds, ~sa bytes.~%"))
       ((unless (time$ (vcd-fast-snapshotlist-p snapshots)
                       :msg "; vcd-dump checking snapshots: ~st seconds, ~sa bytes.~%"))
        (cw "vcd-dump: bad snapshots...~%")
        (vcd-debug-snapshotlist snapshots)
        (er hard? 'vcd-dump "bad snapshots.")
        state)
       (nets
        (time$ (vcd-make-nets (alist-keys (car snapshots)))
               ;; :mintime 1/2
               :msg "; vcd-dump net creation: ~st seconds, ~sa bytes.~%"))
       ((mv & & state) (assign acl2::writes-okp t))
       (state (time$ (with-ps-file filename
                                   (vcd-print-header date nets)
                                   (vcd-dump-main snapshots nets))
                     ;; :mintime 1/2
                     :msg "; vcd-dump file generation: ~st seconds, ~sa bytes.~%"))
       (- (fast-alist-free-each snapshots))

       (certifying-book-p (acl2::f-get-global 'acl2::certify-book-info state))
       ;; BOZO quote-escaping nonsense
       (- (if (and viewer (not certifying-book-p))
              (b* ((cmd (str::cat viewer " " filename)))
                (cw "; vcd-dump launching \"~s0\".~%" cmd)
                (acl2::tshell-ensure)
                (acl2::tshell-run-background cmd))
            nil)))
    state))

(progn!
 (set-raw-mode t)
 (defun vcd-dump-fn (filename snapshots viewer emap state)
   (vcd-dump-fn-real filename snapshots viewer emap state)))
