Work on parsing and operators

.gitignore

@@ -0,0 +1 @@
+*.fasl

math.lisp

@@ -60,13 +60,6 @@ VALUE, the ROW, and the COLUMN."
                                col)))
               (setf (aref minor out-row out-col) (aref mat row col)))))))))
 
-(defun first-column-cofactors (mat)
-  "Find the cofactors for the first column of MAT."
-  (let* ((height (array-dimension mat 0))
-         (out-arr (make-array height)))
-    (dotimes (i height out-arr)
-      (setf (aref out-arr i) (cofactor mat i 0)))))
-
 (defun cofactor-sgn (i j)
   "Return the sign of the cofactor at I and J."
   (expt -1 (+ i j)))
@@ -75,6 +68,13 @@ VALUE, the ROW, and the COLUMN."
   "Find the cofactor for I and J in MAT."
   (* (cofactor-sgn i j) (det (mat-minor mat i j))))
 
+(defun first-column-cofactors (mat)
+  "Find the cofactors for the first column of MAT."
+  (let* ((height (array-dimension mat 0))
+         (out-arr (make-array height)))
+    (dotimes (i height out-arr)
+      (setf (aref out-arr i) (cofactor mat i 0)))))
+
 (defun det2x2 (mat)
   "Find the determinate of a 2x2 matrix MAT."
   (let ((a (aref mat 0 0))
@@ -295,6 +295,84 @@ already been calculated, they can be supplied in FIRST-COLUMN-COFACTORS."
     (dotimes (i n mat)
       (setf (aref mat i i) 1))))
 
+(defun copy-matrix (mat)
+  "Return a copy of MAT."
+  (mapmatrix (lambda (val row col)
+               (declare (ignorable row col))
+               val)
+             mat))
+
+(defun nswap-rows (mat r1 r2)
+  "Swap rows R1 and R2 in mat. R1 and R2 are 0-indexed. This operation is
+destructive."
+  (let ((width (array-dimension mat 1)))
+    (dotimes (i width mat)
+      (rotatef (aref mat r1 i) (aref mat r2 i)))))
+
+(defun swap-rows (mat r1 r2)
+  "Swap rows R1 and R2 in mat. R1 and R2 are 0-indexed. This operation is
+not destructive."
+  (mapmatrix (lambda (val row col)
+               (cond
+                 ((= r1 row)
+                  (aref mat r2 col))
+                 ((= r2 row)
+                  (aref mat r1 col))
+                 (t val)))
+             mat))
+
+(defun nscale-row (mat row scale)
+  "Replace ROW in MAT with itself multiplied by SCALE. ROW is 0-indexed."
+  (let ((width (array-dimension mat 1)))
+    (dotimes (i width mat)
+      (setf (aref mat row i)
+            (* scale (aref mat row i))))))
+
+(defun scale-row (mat row scale)
+  "Like `nscale-row', but copy MAT."
+  (mapmatrix (lambda (val irow col)
+               (declare (ignorable col))
+               (if (= irow row)
+                   (* val scale)
+                   val))
+             mat))
+
+(defun nreplace-row-with-sum (mat r1 r2 &key (scale 1))
+  "Replace row R2 in MAT with R1 + SCALE * R2. ROW is 0-indexed."
+  (let ((width (array-dimension mat 1)))
+    (dotimes (i width mat)
+      (incf (aref mat r1 i) (* scale (aref mat r2 i))))))
+
+(defun replace-row-with-sum (mat r1 r2 &key (scale 1))
+  "Like `nreplace-row-with-sum', but copy MAT."
+  (mapmatrix (lambda (val row col)
+               (if (= row r1)
+                   (+ val (* scale (aref mat r2 col)))
+                   val))
+             mat))
+
+(defun tensor-mm (m1 m2)
+  "Calculate the tensor product of M1 and M2."
+  (let* ((height (* (array-dimension m1 0)
+                    (array-dimension m2 0)))
+         (width (* (array-dimension m1 1)
+                   (array-dimension m2 1)))
+         (out-mat (make-array (list height width))))
+    (dotimes (row height out-mat)
+      (dotimes (col width)
+        (setf (aref out-mat row col)
+              (* (aref m1 (floor row (array-dimension m2 0))
+                       (floor col (array-dimension m2 1)))
+                 (aref m2 (mod row (array-dimension m2 0))
+                       (mod col (array-dimension m2 1)))))))))
+
+(defun tensor-vv (v1 v2)
+  "Calculate the tensor product of V1 and V2."
+  (apply 'concatenate 'vector
+         (map 'list (lambda (elt)
+                      (*vs v2 elt))
+              v1)))
+
 (defun round-to-place (num places &key (base 10))
   "Round NUM to PLACES places in BASE."
   (let ((scale (expt base places)))
@@ -387,5 +465,3 @@ which parsing stopped. That is, the index of the first un-parsed character."
                     (< pos end))
                (error "Junk in string: ~s" (subseq string start end))
                (return (values num pos)))))
-
-

state.lisp

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