Work on parsing and operators

2024-12-06 22:24:29 -08:00
parent 0a8dbada39
commit 5d8b495a06
3 changed files with 213 additions and 9 deletions
@@ -111,3 +111,130 @@ round the norm of STATE before checking."
  "Make a uniform normalized quantum state of BITS qbits."
  (let ((size (ash 1 bits)))
    (make-array (ash 1 bits) :initial-element (/ (sqrt size)))))
+
+(defun bit-unset-index (bit n &key (period (ash 1 bit)))
+  "Return the Nth index in a state in which BIT is 0."
+  (multiple-value-bind (quo rem)
+      (floor n period)
+    (+ (* 2 period quo) rem)))
+
+(defun bit-set-index (bit n &key (period (ash 1 bit)))
+  "Return the Nth index in a state in which BIT is 1."
+  (+ (bit-unset-index bit n :period period)))
+
+(defun bit-probability (state bit)
+  "Return the probability that BIT is set in STATE."
+  (setq state (normalize-state state))
+  (loop with period = (ash 1 bit)
+        for i below (/ (length state) 2)
+        for index = (bit-set-index bit i :period period)
+        for coef = (aref state index)
+        summing (* coef coef)))
+
+(defun nmeasure (state bit)
+  "Collapse BIT in STATE by measuring it. This will return t or nil depending
+on the state the bit collapsed to. Note that this will also modify STATE."
+  (loop with prob = (round-to-place (bit-probability state bit) 5)
+        with limit = (* most-positive-fixnum prob)
+        with rnum = (random most-positive-fixnum)
+        with result = (>= rnum limit)
+        with period = (ash 1 bit)
+        for i below (/ (length state) 2)
+        for unset-index = (bit-unset-index bit i :period period)
+        for set-index = (+ period unset-index)
+        for unset-coef = (aref state unset-index)
+        for set-coef = (aref state set-index)
+        for new-coef = (sqrt (+ (* set-coef set-coef)
+                                (* unset-coef unset-coef)))
+        if result
+          do (setf (aref state unset-index) 0
+                   (aref state set-index) new-coef)
+        else
+          do (setf (aref state unset-index) new-coef
+                   (aref state set-index) 0)
+        finally (return (values result state))))
+
+(defun make-operator (bits operator target)
+  "Create an operator matrix that can act on a state with BITS bits and will
+apply OPERATOR to TARGET."
+  (loop with out = (if (= (1- bits) target)
+                       operator
+                       identity-2x2)
+        for i from (- bits 2) downto 0
+        do (setq out (tensor-mm out (if (= i target)
+                                        operator
+                                        identity-2x2)))
+        finally (return out)))
+
+(defun make-controlled-operator (bits operator target controls)
+  "Create an operator matrix that can act on a state with BITS bits and will
+apply OPERATOR to TARGET if CONTROLS are all set."
+  (labels ((matrix-for (bit target-operator control-operator)
+             (cond
+               ((= bit target) target-operator)
+               ((member bit controls :test '=) control-operator)
+               (t identity-2x2)))
+           (tensor-chain (target-operator control-operator)
+             (loop with out = (matrix-for (1- bits) target-operator
+                                          control-operator)
+                   for i from (- bits 2) downto 0
+                   do (setq out (tensor-mm out (matrix-for i target-operator
+                                                           control-operator)))
+                   finally (return out))))
+    (+mm (tensor-chain identity-2x2 unset-projector)
+         (tensor-chain operator set-projector))))
+
+;;; Gates and Operators:
+(defconstant unset-projector
+  #2A((1 0)
+      (0 0)))
+
+(defconstant set-projector
+  #2A((0 0)
+      (0 1)))
+
+(defconstant identity-2x2
+  (make-identity-matrix 2))
+
+(defconstant pauli-x-gate
+  #2A((0 1)
+      (1 0)))
+
+(defconstant pauli-y-gate
+  #2A((0 #C(0 -1))
+      (#C(0 -1) 0)))
+
+(defconstant pauli-z-gate
+  #2A((1 0)
+      (0 -1)))
+
+(defconstant hadamard-gate
+  (let ((oort (/ (sqrt 2))))
+    (make-array '(2 2) :initial-contents
+                `((,oort ,oort)
+                  (,oort ,(- oort))))))
+
+(defconstant phase-gate
+  #2A((1 0)
+      (0 #C(0 1))))
+
+(defconstant cnot-gate
+  #2A((1 0 0 0)
+      (0 1 0 0)
+      (0 0 0 1)
+      (0 0 1 0)))
+
+(defconstant cz-gate
+  #2A((1 0 0 0)
+      (0 1 0 0)
+      (0 0 1 0)
+      (0 0 0 -1)))
+
+(defconstant swap-gate
+  #2A((1 0 0 0)
+      (0 0 1 0)
+      (0 1 0 0)
+      (0 0 0 1)))
+
+(defconstant ccnot-gate
+  (nswap-rows (make-identity-matrix 9) 7 8))