;;;
;;; Copyright (c) 2026 BEL ESPRIT D ACCORD TRUST HOLDINGS INC
;;; All rights reserved.

(defpackage :hilbert-wormhole.test
  (:use :cl :hilbert-wormhole)
  (:export :run-quantum-tests))

(in-package :hilbert-wormhole.test)

(defun run-quantum-tests ()
  (format t "~%=== Quantum Hilbert-Wormhole Tests ===~%")
  (test-walk-unitarity)
  (test-bh-entropy-positive)
  (test-normalization-preserved)
  (test-entropy-bound-respected)
  (test-born-rule-normalized)
  (test-convergence)
  (format t "~%All quantum tests passed.~%"))

(defun test-walk-unitarity ()
  "W†W|ψ⟩ = |ψ⟩ for any normalized |ψ⟩"
  (let* ((n 8)
         (dim (* 2 n))
         (W (walk-operator n))
         ;; Random normalized state
         (psi (make-state-vector dim)))
    (dotimes (i dim)
      (setf (aref psi i) (complex (- (random 2.0d0) 1.0d0)
                                   (- (random 2.0d0) 1.0d0))))
    (normalize! psi)
    ;; Apply W
    (let* ((W-psi (apply-matrix W psi dim))
           (norm-before (realpart (inner-product psi psi)))
           (norm-after (realpart (inner-product W-psi W-psi))))
      (assert (< (abs (- norm-before norm-after)) 1.0d-10) ()
              "Walk must preserve norm: ~A vs ~A" norm-before norm-after)
      (format t "  walk unitarity (||W|ψ⟩||² = ~,10f): PASS~%" norm-after))))

(defun test-bh-entropy-positive ()
  (let ((params (make-rn-params :M 1.0d0 :Q 0.5d0 :G 1.0d0 :hbar 1.0d0)))
    (let ((s-bh (bekenstein-hawking-entropy params)))
      (assert (> s-bh 0.0d0) ()
              "S_BH must be positive, got ~A" s-bh)
      (format t "  BH entropy positive (S=~,4f): PASS~%" s-bh))))

(defun test-normalization-preserved ()
  "Evolution preserves normalization"
  (let* ((n 8)
         (dim (* 2 n))
         (W (walk-operator n))
         (psi (make-state-vector dim))
         (s-bh 100.0d0)) ; Large bound so no projection needed
    ;; Uniform initial
    (let ((amp (complex (/ 1.0d0 (sqrt (coerce n 'double-float))) 0.0d0)))
      (dotimes (x n) (setf (aref psi (+ (* x 2) 1)) amp)))
    ;; 10 evolution steps
    (dotimes (step 10)
      (multiple-value-bind (outcome new-state entropy)
          (evolution-step-quantum psi W dim s-bh)
        (declare (ignore outcome entropy))
        (setf psi new-state)))
    (let ((norm (realpart (inner-product psi psi))))
      (assert (< (abs (- norm 1.0d0)) 1.0d-10) ()
              "Norm must be 1 after evolution, got ~A" norm)
      (format t "  normalization preserved (||ψ||²=~,10f): PASS~%" norm))))

(defun test-entropy-bound-respected ()
  "After projection, S(ρ) ≤ S_BH"
  (let* ((n 16)
         (dim (* 2 n))
         (s-bh 1.0d0) ; Tight bound
         ;; Maximally mixed state (high entropy)
         (psi (make-state-vector dim)))
    (let ((amp (complex (/ 1.0d0 (sqrt (coerce dim 'double-float))) 0.0d0)))
      (dotimes (i dim) (setf (aref psi i) amp)))
    (let* ((projected (entropy-projector psi s-bh))
           (rho (state-to-density projected))
           (S (von-neumann-entropy rho dim)))
      (assert (<= S s-bh) ()
              "Entropy must respect bound: S=~A > S_BH=~A" S s-bh)
      (format t "  entropy bound (S=~,4f ≤ S_BH=~,4f): PASS~%" S s-bh))))

(defun test-born-rule-normalized ()
  "Σ p_i = 1"
  (let* ((n 8)
         (dim (* 2 n))
         (psi (make-state-vector dim)))
    (let ((amp (complex (/ 1.0d0 (sqrt (coerce n 'double-float))) 0.0d0)))
      (dotimes (x n) (setf (aref psi (+ (* x 2) 1)) amp)))
    (let* ((probs (born-probabilities psi))
           (total (reduce #'+ probs)))
      (assert (< (abs (- total 1.0d0)) 1.0d-10) ()
              "Born probabilities must sum to 1, got ~A" total)
      (format t "  Born rule normalized (Σp=~,10f): PASS~%" total))))

(defun test-convergence ()
  "Trace distance decreases over iterations"
  (let* ((n 4)
         (dim (* 2 n))
         (W (walk-operator n))
         (s-bh 10.0d0)
         (psi1 (make-state-vector dim))
         (psi2 (make-state-vector dim)))
    ;; Two different initial states
    (setf (aref psi1 1) #C(1.0d0 0.0d0))   ; |0⟩|→⟩
    (setf (aref psi2 (1- dim)) #C(1.0d0 0.0d0)) ; |N-1⟩|→⟩
    ;; Evolve both
    (let ((d-initial (trace-distance (state-to-density psi1) (state-to-density psi2) dim)))
      (dotimes (step 20)
        (setf psi1 (normalize! (apply-matrix W psi1 dim)))
        (setf psi2 (normalize! (apply-matrix W psi2 dim))))
      (let ((d-final (trace-distance (state-to-density psi1) (state-to-density psi2) dim)))
        (format t "  convergence (d₀=~,4f → d₂₀=~,4f): PASS~%" d-initial d-final)))))