;;; sim.lsp — Reversible bit-level simulator for our S-expression circuits.
;;;
;;; Reads a circuit portal, executes its op stream on classical bits,
;;; counts Toffoli & Clifford gates & peak live qubits, runs a reverse
;;; pass to confirm reversibility, writes a result portal.
;;;
;;; Runs on every lumbda tier — Python, C, asm — byte-identically.
;;;
;;; Public entry point: (simulate-portal in-path out-path)
;;;
;;; Wire format documented in gates.lsp.

;;; ── tiny utilities ────────────────────────────────────────────

(define (read-portal filename)
  "Slurp a portal as a single S-expression. Uses file->string +
   read-from-string for cross-tier portability — (read port) on a
   raw file handle falls back to stdin on lumbda's Python tier."
  (read-from-string (file->string filename)))

(define (write-portal! filename sexp)
  "Write an S-expression to a file atomically."
  (let ((tmp (string-append filename ".tmp")))
    (let ((port (open-output-file tmp)))
      (write sexp port)
      (newline port)
      (close-port port))
    (rename-file tmp filename)))

(define (section sexp tag)
  "Return body (everything past tag) of first child whose head = tag, else #f."
  (let loop ((children (cdr sexp)))
    (cond
      ((null? children) #f)
      ((and (pair? (car children)) (eq? (car (car children)) tag))
       (cdr (car children)))
      (else (loop (cdr children))))))

(define (int->bits n width)
  "Decode integer n into a vector of width bits, LSB at index 0."
  (let ((v (make-vector width 0)))
    (let loop ((i 0) (rest n))
      (if (= i width)
          v
          (begin (vector-set! v i (remainder rest 2))
                 (loop (+ i 1) (quotient rest 2)))))))

(define (bits->int v)
  "Encode a bit vector (LSB at index 0) back into an integer."
  (let loop ((i 0) (acc 0) (pow 1))
    (if (= i (vector-length v))
        acc
        (loop (+ i 1)
              (+ acc (* (vector-ref v i) pow))
              (* pow 2)))))

(define (vector-all-zero? v)
  (let loop ((i 0))
    (cond
      ((= i (vector-length v)) #t)
      ((not (= (vector-ref v i) 0)) #f)
      (else (loop (+ i 1))))))

(define (vector-equal? a b)
  (and (= (vector-length a) (vector-length b))
       (let loop ((i 0))
         (cond
           ((= i (vector-length a)) #t)
           ((not (= (vector-ref a i) (vector-ref b i))) #f)
           (else (loop (+ i 1)))))))

(define (vector-copy v)
  (let* ((n (vector-length v))
         (out (make-vector n 0)))
    (let loop ((i 0))
      (if (= i n)
          out
          (begin (vector-set! out i (vector-ref v i))
                 (loop (+ i 1)))))))

;;; ── simulator state ───────────────────────────────────────────
;;;
;;; State carries:
;;;   regs        hash-table: register-name → bit vector (mutable)
;;;   widths      hash-table: register-name → declared width
;;;   live        integer: sum of current register widths
;;;   peak        integer: max live ever reached
;;;   toffoli     integer: count of ccx ops
;;;   clifford    integer: count of x + cx ops

(define (make-sim-state)
  (vector (make-hash-table)       ; 0: regs
          (make-hash-table)       ; 1: widths
          0                       ; 2: live
          0                       ; 3: peak
          0                       ; 4: toffoli
          0                       ; 5: clifford
          'running                ; 6: status (running | leaked-ancilla | bad-op)
          (make-hash-table)       ; 7: bits (Tier-2 classical bits, int-id → 0/1)
          '()                     ; 8: cond-stack (Tier-2 push-cond / pop-cond)
          1))                     ; 9: cond (Tier-2, current conditional mask, 0 or 1)

(define (st-regs s)      (vector-ref s 0))
(define (st-widths s)    (vector-ref s 1))
(define (st-live s)      (vector-ref s 2))
(define (st-peak s)      (vector-ref s 3))
(define (st-toffoli s)   (vector-ref s 4))
(define (st-clifford s)  (vector-ref s 5))
(define (st-status s)    (vector-ref s 6))
(define (st-bits s)        (vector-ref s 7))
(define (st-cond-stack s)  (vector-ref s 8))
(define (st-cond s)        (vector-ref s 9))

(define (set-live! s v)         (vector-set! s 2 v))
(define (set-peak! s v)         (vector-set! s 3 v))
(define (set-toffoli! s v)      (vector-set! s 4 v))
(define (set-clifford! s v)     (vector-set! s 5 v))
(define (set-status! s v)       (vector-set! s 6 v))
(define (set-cond-stack! s v)   (vector-set! s 8 v))
(define (set-cond! s v)         (vector-set! s 9 v))

(define (bit-ref s id)
  "Read classical bit; defaults to 0 if not yet set."
  (let ((bits (st-bits s)))
    (cond
      ((hash-table-exists? bits id) (hash-table-ref bits id))
      (else 0))))

(define (bit-set! s id v)
  (hash-table-set! (st-bits s) id v))

(define (st-ok? s) (eq? (st-status s) 'running))

(define (touch-peak! s)
  (when (> (st-live s) (st-peak s))
    (set-peak! s (st-live s))))

;;; ── register initialization ───────────────────────────────────

(define (declare-registers! s registers-section input-section)
  ;; registers-section = ((target-x 4) (target-y 4) ...)
  ;; input-section     = ((target-x 11) (target-y 6) ...)
  (for-each
    (lambda (rec)
      (let ((name (car rec))
            (width (car (cdr rec))))
        (hash-table-set! (st-widths s) name width)
        (let ((initial 0))
          ;; lookup input value if present
          (let ((row (assoc name input-section)))
            (when row (set! initial (car (cdr row)))))
          (hash-table-set! (st-regs s) name (int->bits initial width)))
        (set-live! s (+ (st-live s) width))))
    registers-section)
  (touch-peak! s))

;;; ── op execution (forward and reverse) ────────────────────────

(define (qref->bit s ref)
  "ref = (reg-name idx)."
  (let ((reg (hash-table-ref (st-regs s) (car ref))))
    (vector-ref reg (car (cdr ref)))))

(define (qref-flip! s ref)
  (let* ((reg (hash-table-ref (st-regs s) (car ref)))
         (i   (car (cdr ref)))
         (cur (vector-ref reg i)))
    (vector-set! reg i (- 1 cur))))

(define (exec-op! s op forward?)
  "Apply one op. forward? = #t for forward pass, #f for reverse.
   All Phase B Tier-1 gates {x, z, cx, cz, ccx, ccz, r} are self-inverse
   on classical-bit-valued single-shot state (z/cz/ccz add no observable
   bit-value effect; r unconditionally zeros target). Tier-2 ops
   {bit-invert, bit-store0, bit-store1, hmr, push-cond, pop-cond} require
   reversibility-aware handling — see sweep-013 RESULTS.md for the
   classical-replay design."
  (case (car op)
    ((x)
     ;; sweep-041: gate on st-cond to match HEAD's sim_cpu.c (line 62):
     ;; uint64_t v = cond ...; qubits[tgt] ^= v. Under push-cond=0 the
     ;; gate must NOT fire. Tier-2 ops (bit-*, HMR) were already gated;
     ;; Tier-1 quantum ops were not until sweep-041 surfaced the gap
     ;; via verify-boundary-cond-replay round-trip failure. Clifford
     ;; counter also gated to mirror sim_cpu.c line 38-39.
     (when (= (st-cond s) 1)
       (qref-flip! s (car (cdr op)))
       (set-clifford! s (+ (st-clifford s) 1))))
    ((z)
     ;; Z is phase-only — no effect on classical-bit single-shot state.
     ;; Clifford counter gated on cond like other Cliffords.
     (when (= (st-cond s) 1)
       (set-clifford! s (+ (st-clifford s) 1))))
    ((cx)
     (when (= (st-cond s) 1)
       (let ((ctrl (car (cdr op)))
             (tgt  (car (cdr (cdr op)))))
         (when (= (qref->bit s ctrl) 1)
           (qref-flip! s tgt)))
       (set-clifford! s (+ (st-clifford s) 1))))
    ((cz)
     ;; CZ is phase-only — no bit-value effect. Gated counter bump.
     (when (= (st-cond s) 1)
       (set-clifford! s (+ (st-clifford s) 1))))
    ((ccx)
     (when (= (st-cond s) 1)
       (let ((c1  (car (cdr op)))
             (c2  (car (cdr (cdr op))))
             (tgt (car (cdr (cdr (cdr op))))))
         (when (and (= (qref->bit s c1) 1) (= (qref->bit s c2) 1))
           (qref-flip! s tgt)))
       ;; sweep-041: bump Toffoli only on cond=1 — mirrors HEAD's
       ;; sim_cpu.c line 37 (toffoli_gates += executed = POPCOUNT(cond)).
       ;; Single-shot classical: cond=1 → +1, cond=0 → +0. Without this
       ;; gating, cond-replay's "half-shot saving" doesn't show in our
       ;; sim's Toffoli count.
       (set-toffoli! s (+ (st-toffoli s) 1))))
    ((ccz)
     ;; CCZ is phase-only — no bit-value effect. One Toffoli charge,
     ;; gated on cond like CCX (matches sim_cpu.c line 36-37).
     (when (= (st-cond s) 1)
       (set-toffoli! s (+ (st-toffoli s) 1))))
    ((r)
     ;; Single-qubit reset. Under push-cond=0 the reset must NOT fire
     ;; (matches HEAD sim_cpu.c line 86-90: qubits &= ~cond). Clifford
     ;; counter also gated.
     (when (= (st-cond s) 1)
       (let* ((ref (car (cdr op)))
              (reg (hash-table-ref (st-regs s) (car ref)))
              (i   (car (cdr ref))))
         (vector-set! reg i 0))
       (set-clifford! s (+ (st-clifford s) 1))))
    ((bit-invert)
     (when (= (st-cond s) 1)
       (let ((id (car (cdr op))))
         (bit-set! s id (- 1 (bit-ref s id))))
       (set-clifford! s (+ (st-clifford s) 1))))
    ((bit-store0)
     (when (= (st-cond s) 1)
       (bit-set! s (car (cdr op)) 0)
       (set-clifford! s (+ (st-clifford s) 1))))
    ((bit-store1)
     (when (= (st-cond s) 1)
       (bit-set! s (car (cdr op)) 1)
       (set-clifford! s (+ (st-clifford s) 1))))
    ((hmr)
     ;; Hadamard + Measure + Reset. Forward: bit := qubit, qubit := 0.
     ;; Reverse: qubit := bit, bit := 0. Gated on conditional. Clifford
     ;; counter also gated for consistency with sim_cpu.c line 38-39.
     (when (= (st-cond s) 1)
       (let* ((qref (car (cdr op)))
              (bid  (car (cdr (cdr op))))
              (reg  (hash-table-ref (st-regs s) (car qref)))
              (i    (car (cdr qref))))
         (cond
           (forward?
            (bit-set! s bid (vector-ref reg i))
            (vector-set! reg i 0))
           (else
            (vector-set! reg i (bit-ref s bid))
            (bit-set! s bid 0))))
       (set-clifford! s (+ (st-clifford s) 1))))
    ((push-cond)
     ;; Forward: stack.push(cond); cond := cond AND bit.
     ;; Reverse: cond := stack.pop().
     (cond
       (forward?
        (set-cond-stack! s (cons (st-cond s) (st-cond-stack s)))
        (let ((bid (car (cdr op))))
          (set-cond! s (* (st-cond s) (bit-ref s bid)))))
       (else
        (cond
          ((null? (st-cond-stack s))
           (set-status! s 'pop-empty-stack))
          (else
           (set-cond! s (car (st-cond-stack s)))
           (set-cond-stack! s (cdr (st-cond-stack s))))))))
    ((pop-cond)
     ;; Forward: cond := stack.pop().
     ;; Reverse: stack.push(cond); cond := cond AND ??? — pop-cond
     ;; carries no bit-id, so reverse cannot reconstruct the narrowing.
     ;; Pop-cond's reverse therefore just pushes current cond.
     ;; (This is reversible iff push-cond and pop-cond bracket cleanly.)
     (cond
       (forward?
        (cond
          ((null? (st-cond-stack s))
           (set-status! s 'pop-empty-stack))
          (else
           (set-cond! s (car (st-cond-stack s)))
           (set-cond-stack! s (cdr (st-cond-stack s))))))
       (else
        (set-cond-stack! s (cons (st-cond s) (st-cond-stack s))))))
    ((alloc)
     (let ((name (car (cdr op)))
           (width (car (cdr (cdr op)))))
       (hash-table-set! (st-widths s) name width)
       (if forward?
           (begin
             (hash-table-set! (st-regs s) name (make-vector width 0))
             (set-live! s (+ (st-live s) width))
             (touch-peak! s))
           (let ((reg (hash-table-ref (st-regs s) name)))
             (if (vector-all-zero? reg)
                 (begin
                   (hash-table-delete! (st-regs s) name)
                   (set-live! s (- (st-live s) width)))
                 (set-status! s 'leaked-ancilla))))))
    ((free)
     (let* ((name (car (cdr op)))
            (width (hash-table-ref (st-widths s) name)))
       (if forward?
           (let ((reg (hash-table-ref (st-regs s) name)))
             (if (vector-all-zero? reg)
                 (begin
                   (hash-table-delete! (st-regs s) name)
                   (set-live! s (- (st-live s) width)))
                 (set-status! s 'leaked-ancilla)))
           (begin
             (hash-table-set! (st-regs s) name (make-vector width 0))
             (set-live! s (+ (st-live s) width))
             (touch-peak! s)))))
    (else (set-status! s 'bad-op))))

(define (run-ops! s ops forward?)
  "Walk ops in order, halting on first state-status flip."
  (let loop ((rest ops))
    (cond
      ((null? rest) #t)
      ((not (st-ok? s)) #f)
      (else
        (exec-op! s (car rest) forward?)
        (loop (cdr rest))))))

;;; ── simulate one circuit, return result S-expression ──────────

(define (simulate circuit)
  (let* ((regs-sect    (section circuit 'registers))
         (input-sect   (section circuit 'input))
         (ops-sect     (section circuit 'ops))
         (expected     (section circuit 'expected-output))
         (s            (make-sim-state)))
    (declare-registers! s regs-sect (or input-sect '()))
    (let ((initial-snapshot (snapshot-data-regs s regs-sect)))
      (run-ops! s ops-sect #t)
      (if (not (st-ok? s))
          (build-result s (st-status s) regs-sect expected)
          (let ((output-snapshot (snapshot-data-regs s regs-sect)))
            (let ((classical-ok?
                    (or (null? expected)
                        (expected-matches? expected output-snapshot))))
              (set-toffoli! s 0)
              (set-clifford! s 0)
              (run-ops! s (reverse ops-sect) #f)
              (let ((restored? (and (st-ok? s)
                                    (snapshot-equals? s initial-snapshot))))
                (cond
                  ((not classical-ok?)
                   (build-result-with-output s 'classical-mismatch
                                             output-snapshot expected))
                  ((not (st-ok? s))
                   (build-result-with-output s 'not-reversible
                                             output-snapshot expected))
                  ((not restored?)
                   (build-result-with-output s 'not-reversible
                                             output-snapshot expected))
                  (else
                   (build-result-with-output s 'ok
                                             output-snapshot expected))))))))))

(define (snapshot-data-regs s regs-sect)
  "Return alist (name . bit-vector) for declared data registers only."
  (map
    (lambda (rec)
      (let ((name (car rec)))
        (cons name (vector-copy (hash-table-ref (st-regs s) name)))))
    regs-sect))

(define (snapshot-equals? s snap)
  "Check every register in snap matches current state."
  (let loop ((rest snap))
    (cond
      ((null? rest) #t)
      (else
       (let* ((name (car (car rest)))
              (saved (cdr (car rest)))
              (current (hash-table-ref (st-regs s) name)))
         (and (vector-equal? saved current) (loop (cdr rest))))))))

(define (expected-matches? expected output-snapshot)
  "Compare each expected (name int) row against output-snapshot bits."
  (let loop ((rest expected))
    (cond
      ((null? rest) #t)
      (else
       (let* ((name (car (car rest)))
              (want (car (cdr (car rest))))
              (got-vec (cdr (assoc name output-snapshot)))
              (got (bits->int got-vec)))
         (and (= want got) (loop (cdr rest))))))))

(define (build-result s status regs-sect expected)
  (build-result-with-output s status
                            (snapshot-data-regs s regs-sect)
                            expected))

(define (build-result-with-output s status snap expected)
  (let ((output-rows
          (map (lambda (rec)
                 (list (car rec) (bits->int (cdr rec))))
               snap))
        (toffoli (st-toffoli s))
        (peak    (st-peak s)))
    (list 'result
          (list 'status status)
          (cons 'output output-rows)
          (list 'counts
                (list 'toffoli toffoli)
                (list 'clifford (st-clifford s))
                (list 'peak-qubits peak))
          (list 'score (* toffoli peak)))))

;;; ── top-level entrypoint ──────────────────────────────────────

(define (simulate-portal in-path out-path)
  "Read circuit portal, simulate, write result portal."
  (let* ((circuit (read-portal in-path))
         (result (simulate circuit)))
    (write-portal! out-path result)
    result))