Experiment

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 (state operator gate target &optional control)
+(defun circuit-arbitrary-gate (size operator gate target &optional control)
   (declare (ignorable operator))
   (if control
-      (napply-controlled-gate state gate target control)
-      (napply-gate state gate target)))
+      (make-controlled-operator size gate target control)
+      (make-operator size gate target)))
 
-(defun circuit-matrix-operation (state operator target &optional control)
+(defun circuit-matrix-operation (size operator target &optional control)
   (let ((matrix (case operator
                   (:* +identity-2x2+)
                   (:x +pauli-x-gate+)
@@ -22,16 +22,13 @@
                   (:cnot +pauli-x-gate+)
                   (:cz +pauli-z-gate+))))
     (if control
-        (napply-controlled-gate state matrix target control)
-        (napply-gate state matrix target))))
+        (make-controlled-operator size matrix target control)
+        (make-operator size matrix target))))
 
-(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))))
+(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))))
 
 (defparameter *circuit-operators*
   ;; Operator, # args, more args?, has output?, function
@@ -47,36 +44,72 @@
     (: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)))
+    (: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*))))))
 
-(defun make-circuit ()
-  "Create a new blank circuit."
-  '(:circuit))
+(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 add-to-circuit (circuit operator &rest args)
   "Add OPERATOR to CIRCUIT."
-  (let ((entry (assoc operator *circuit-operators*)))
+  (let ((bits (second circuit))
+        (entry (assoc operator *circuit-operators*)))
     (unless entry
       (error "Unknown circuit operator: ~s" operator))
-    (destructuring-bind (name arg-count has-rest &rest r) entry
-      (declare (ignorable name r))
+    (destructuring-bind (name arg-count has-rest has-output func) entry
+      (declare (ignorable name))
       (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)))
-      (nconc circuit (list (cons operator 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))))))
     circuit))
 
-(defmacro with-build-circuit (&body body)
+(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)
   "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)))
-    `(let ((,circuit-var))
+  (let ((circuit-var (gensym))
+        (bits-var (gensym)))
+    `(let ((,circuit-var)
+           (,bits-var ,bits))
        (macrolet
            (,@(mapcar (lambda (oper)
                         (let ((arg (gensym))
@@ -91,44 +124,37 @@ addition to function calls to functions named in `*circuit-operators*'."
                             (declare (ignorable ,@arg-list
                                                 ,@(when (third oper)
                                                     (list whole-arg))))
-                            `(push (list ,@,arg) ,',circuit-var))))
+                            `(setq ,',circuit-var
+                                   (build-circuit-add-action
+                                    ,',bits-var ,',circuit-var (list ,@,arg))))))
                 *circuit-operators*))
          ,@body)
-       (cons :circuit (nreverse ,circuit-var)))))
+       (apply 'list :circuit ,bits-var (nreverse ,circuit-var)))))
 
-(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)))))
+(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)))))
     (values
-     state
+     real-state
      (loop with *circuit-measure-places* = places
-           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))))
+           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)))))))

examples/bell.lisp

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

math.lisp

@@ -42,6 +42,11 @@ 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,6 +4,7 @@ quantum operators.")
   (:use :cl)
   (:export #:domatrix
            #:mapmatrix
+           #:matrixp
            #:minor
            #:cofactor
            #:det