circuit.lisp

@@ -4,13 +4,13 @@
 (defparameter *circuit-measure-places* 5
   "The number of places to use with the :measure instruction in circuits.")
 
-(defun circuit-arbitrary-gate (size operator gate target &optional control)
+(defun circuit-arbitrary-gate (state operator gate target &optional control)
   (declare (ignorable operator))
   (if control
-      (make-controlled-operator size gate target control)
-      (make-operator size gate target)))
+      (napply-controlled-gate state gate target control)
+      (napply-gate state gate target)))
 
-(defun circuit-matrix-operation (size operator target &optional control)
+(defun circuit-matrix-operation (state operator target &optional control)
   (let ((matrix (case operator
                   (:* +identity-2x2+)
                   (:x +pauli-x-gate+)
@@ -22,13 +22,16 @@
                   (:cnot +pauli-x-gate+)
                   (:cz +pauli-z-gate+))))
     (if control
-        (make-controlled-operator size matrix target control)
-        (make-operator size matrix target))))
+        (napply-controlled-gate state matrix target control)
+        (napply-gate state matrix target))))
 
-(defun circuit-n-controlled-gate (size operator target controls)
-  (case operator
-    (:ntoff (make-n-toffoli-operator size target controls))
-    (:ncz (make-n-controlled-z-operator size target controls))))
+(defun circuit-n-controlled-gate (state operator target controls)
+  (let ((func (case operator
+                (:ntoff 'make-n-toffoli-operator)
+                (:ncz 'make-n-controlled-z-operator))))
+    (replace-state state (*mv (funcall func (state-bits state)
+                                       target controls)
+                              state))))
 
 (defparameter *circuit-operators*
   ;; Operator, # args, more args?, has output?, function
@@ -44,72 +47,36 @@
     (:t 1 nil nil circuit-matrix-operation)
     (:cnot 2 nil nil circuit-matrix-operation)
     (:cz 2 nil nil circuit-matrix-operation)
+    (:measure 2 nil t ,(lambda (state operator &rest args)
+                         (declare (ignorable operator))
+                         (nmeasure state (car args)
+                                   :places *circuit-measure-places*)))
     (:ntoff 2 nil nil circuit-n-controlled-gate)
-    (:ncz 2 nil nil circuit-n-controlled-gate)
-    (:measure 2 nil t ,(lambda (size operator bit target)
-                         (declare (ignorable size operator target))
-                         (lambda (state)
-                           (nmeasure state bit
-                                     :places *circuit-measure-places*))))))
+    (:ncz 2 nil nil circuit-n-controlled-gate)))
 
-(defun make-circuit (bits)
-  "Create a new blank circuit of BITS bits."
-  `(:circuit ,bits))
-
-(defun circuitp (obj)
-  "Return non-nil if OBJ is a quantum circuit."
-  (and (eq (first obj) :circuit)
-       (integerp (second obj))))
+(defun make-circuit ()
+  "Create a new blank circuit."
+  '(:circuit))
 
 (defun add-to-circuit (circuit operator &rest args)
   "Add OPERATOR to CIRCUIT."
-  (let ((bits (second circuit))
-        (entry (assoc operator *circuit-operators*)))
+  (let ((entry (assoc operator *circuit-operators*)))
     (unless entry
       (error "Unknown circuit operator: ~s" operator))
-    (destructuring-bind (name arg-count has-rest has-output func) entry
-      (declare (ignorable name))
+    (destructuring-bind (name arg-count has-rest &rest r) entry
+      (declare (ignorable name r))
       (unless (or (and has-rest (>= (length args) arg-count))
                   (= (length args) arg-count))
         (error "Operator ~s expects ~@[~*exactly ~]~s arg~:p, got ~s" operator
                (not has-rest) arg-count (length args)))
-      (let ((action (apply func bits operator args))
-            (prev-action (car (last circuit))))
-        (cond
-          ((and (matrixp action) (matrixp prev-action))
-           (setf (car (last circuit)) (*mm action prev-action)))
-          ((functionp action)
-           (setf (cdr (last circuit)) (list (cons action
-                                                  (and has-output
-                                                       (car (last args)))))))
-          (t (setf (cdr (last circuit)) (list action))))))
+      (nconc circuit (list (cons operator args))))
     circuit))
 
-(defun build-circuit-add-action (bits actions args)
-  "Add the action denoted by ARGS to the front of ACTIONS. The action is assumed
-to operate on a state of BITS bits."
-  (let ((entry (assoc (car args) *circuit-operators*)))
-    (destructuring-bind (name arg-count has-rest has-output func) entry
-      (declare (ignorable arg-count has-rest))
-      (declare (ignorable name))
-      (let ((action (apply func bits (car args) (cdr args)))
-            (prev-action (car actions)))
-        (cond
-          ((and (matrixp action) (matrixp prev-action))
-           (setf (car actions) (*mm action prev-action)))
-          ((functionp action)
-           (push (cons action (and has-output (car (last args))))
-                 actions))
-          (t (push action actions)))
-        actions))))
-
-(defmacro with-build-circuit (bits &body body)
+(defmacro with-build-circuit (&body body)
   "Create a circuit using a simple DSL. BODY can be any valid Lisp forms, in
 addition to function calls to functions named in `*circuit-operators*'."
-  (let ((circuit-var (gensym))
-        (bits-var (gensym)))
-    `(let ((,circuit-var)
-           (,bits-var ,bits))
+  (let ((circuit-var (gensym)))
+    `(let ((,circuit-var))
        (macrolet
            (,@(mapcar (lambda (oper)
                         (let ((arg (gensym))
@@ -124,37 +91,44 @@ addition to function calls to functions named in `*circuit-operators*'."
                             (declare (ignorable ,@arg-list
                                                 ,@(when (third oper)
                                                     (list whole-arg))))
-                            `(setq ,',circuit-var
-                                   (build-circuit-add-action
-                                    ,',bits-var ,',circuit-var (list ,@,arg))))))
+                            `(push (list ,@,arg) ,',circuit-var))))
                 *circuit-operators*))
          ,@body)
-       (apply 'list :circuit ,bits-var (nreverse ,circuit-var)))))
+       (cons :circuit (nreverse ,circuit-var)))))
 
-(defun run-circuit (circuit &key (state :zero) (places 5))
-  "Run the circuit CIRCUIT and return the final state. The initial STATE can be
-specified in one of four ways:
- - :ZERO: a zero state is used -> #(1 0 0 0), etc.
- - :UNIFORM: a uniform state -> #(1/sqrt(2) 1/sqrt(2)), etc
- - a vector: the initial coefficients"
-  (let ((real-state (cond
-                 ((eq state :zero)
-                  (make-zero-state (second circuit)))
-                 ((eq state :uniform)
-                  (make-uniform-normal-state (second circuit)))
-                 (t (coerce state 'vector)))))
+(defun apply-circuit-operator-to-state (state operator args)
+  "Apply the circuit operator OPERATOR to STATE by calling its function with
+ARGS."
+  (destructuring-bind (&optional name arg-count has-rest has-output function)
+      (assoc operator *circuit-operators*)
+    (declare (ignorable name arg-count has-rest))
+    (assert function ()
+            "Invalid circuit operator: ~s" operator)
+    (let ((output (apply function state operator args)))
+      (when has-output
+        (cons (car (last args)) output)))))
+
+(defun run-circuit (circuit &key bits uniform coefficients probabilities (places 5))
+  "Run the circuit CIRCUIT and return the final state. The initial state can be
+specified in one of three ways:
+ - BITS: the number of qbits
+ - COEFFICIENTS: the initial coefficients
+ - PROBABILITES: the initial probabilities"
+  (assert (= 1 (count-if 'identity (list bits coefficients probabilities uniform)))
+          ()
+          "Exactly one of BITS, UNIFORM, COEFFICIENTS, and PROBABILITIES can ~
+be present")
+  (let ((state (cond
+                 (bits (make-zero-state bits))
+                 (uniform (make-uniform-normal-state uniform))
+                 (coefficients (coerce coefficients 'vector))
+                 (probabilities (make-normal-state probabilities)))))
     (values
-     real-state
+     state
      (loop with *circuit-measure-places* = places
-           with outputs = ()
-           for action in (cddr circuit) do
-             (cond
-               ((matrixp action)
-                (replace-state real-state (*mv action real-state)))
-               ((consp action)
-                (destructuring-bind (func output) action
-                  (let ((res (funcall func real-state)))
-                    (when output
-                      (push res outputs)
-                      (push output outputs)))))
-               (t (error "Unknown circuit element type: ~s" action)))))))
+           for element in (cdr circuit)
+           for name = (car element)
+           for args = (cdr element)
+           for result = (apply-circuit-operator-to-state state name args)
+           when result
+             collect result))))

examples/bell.lisp

@@ -1,29 +1,29 @@
 ;;;; Example Bell state creation circuits
 (in-package :cl-quantum/examples)
 
-(defun make-bell-phi+-circuit (bits)
+(defun make-bell-phi+-circuit ()
   "Return a circuit that makes a Bell phi+ state. That is |00>+|11>."
-  (with-build-circuit bits
+  (with-build-circuit
     (:h 0)
     (:cnot 1 0)))
 
-(defun make-bell-phi--circuit (bits)
+(defun make-bell-phi--circuit ()
   "Return a circuit that makes a Bell phi- state. That is |00>-|11>."
-  (with-build-circuit bits
+  (with-build-circuit
     (:h 0)
     (:cnot 1 0)
     (:z 1)))
 
-(defun make-bell-psi+-circuit (bits)
+(defun make-bell-psi+-circuit ()
   "Return a circuit that makes a Bell psi+ state. That is |01>+|10>."
-  (with-build-circuit bits
+  (with-build-circuit
     (:x 1)
     (:h 0)
     (:cnot 1 0)))
 
-(defun make-bell-psi--circuit (bits)
+(defun make-bell-psi--circuit ()
   "Return a circuit that makes a Bell psi- state. That is |01>-|10>."
-  (with-build-circuit bits
+  (with-build-circuit
     (:x 1)
     (:h 0)
     (:cnot 1 0)

examples/grover.lisp

@@ -12,7 +12,7 @@ bits and finds when the state is equal to TARGET."
   (assert (> (ash 1 bits) target)
           (bits target)
           "Target bit of ~s out of range for state with ~s bits." target bits)
-  (with-build-circuit bits
+  (with-build-circuit
     ;; Setup
     (loop for i below bits do (:h i))
 

math.lisp

@@ -42,11 +42,6 @@ VALUE, the ROW, and the COLUMN."
    (domatrix ((elem row col) matrix new-mat)
      (setf (aref new-mat row col) (funcall function elem row col)))))
 
-(defun matrixp (obj)
-  "Return non-nil if OBJ is a matrix."
-  (and (arrayp obj)
-       (= (array-rank obj) 2)))
-
 ;; Matrix subroutines
 (defun minor (mat i j)
   "Find the minor of MAT for I and J."

package.lisp

@@ -4,7 +4,6 @@ quantum operators.")
   (:use :cl)
   (:export #:domatrix
            #:mapmatrix
-           #:matrixp
            #:minor
            #:cofactor
            #:det