Add examples and clean up some stuff

circuit.lisp

@@ -1,9 +1,16 @@
+;;;; High-level interface for building quantum circuits
 (in-package :cl-quantum/circuit)
 
 (defparameter *circuit-measure-places* 5
   "The number of places to use with the :measure instruction in circuits.")
 
-(defun circuit-matrix-operation (state operator &rest args)
+(defun circuit-arbitrary-gate (state operator gate target &optional control)
+  (declare (ignorable operator))
+  (if control
+      (napply-controlled-gate state gate target control)
+      (napply-gate state gate target)))
+
+(defun circuit-matrix-operation (state operator target &optional control)
   (let ((matrix (case operator
                   (:* +identity-2x2+)
                   (:x +pauli-x-gate+)
@@ -14,112 +21,114 @@
                   (:t +pi/8-gate+)
                   (:cnot +pauli-x-gate+)
                   (:cz +pauli-z-gate+))))
-    (destructuring-bind (target &optional control) args
     (if control
-          (napply-controlled-operator state matrix target control)
+        (napply-controlled-gate state matrix target control)
-          (napply-operator state matrix target)))))
+        (napply-gate state 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))))
 
 (defparameter *circuit-operators*
-  ;; Operator, # args, has output?, function
+  ;; Operator, # args, more args?, has output?, function
   ;; The output is always the last argument
-  `((:* 1 nil circuit-matrix-operation)
+  `((:gate 2 nil nil circuit-arbitrary-gate)
-    (:x 1 nil circuit-matrix-operation)
+    (:cgate 3 nil nil circuit-arbitrary-gate)
-    (:y 1 nil circuit-matrix-operation)
+    (:* 1 nil nil circuit-matrix-operation)
-    (:z 1 nil circuit-matrix-operation)
+    (:x 1 nil nil circuit-matrix-operation)
-    (:h 1 nil circuit-matrix-operation)
+    (:y 1 nil nil circuit-matrix-operation)
-    (:p 1 nil circuit-matrix-operation)
+    (:z 1 nil nil circuit-matrix-operation)
-    (:t 1 nil circuit-matrix-operation)
+    (:h 1 nil nil circuit-matrix-operation)
-    (:cnot 2 nil circuit-matrix-operation)
+    (:p 1 nil nil circuit-matrix-operation)
-    (:cz 2 nil circuit-matrix-operation)
+    (:t 1 nil nil circuit-matrix-operation)
-    (:measure 2 t ,(lambda (state operator &rest args)
+    (: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*)))))
+                                   :places *circuit-measure-places*)))
+    (:ntoff 2 nil nil circuit-n-controlled-gate)
+    (:ncz 2 nil nil circuit-n-controlled-gate)))
 
 (defun make-circuit ()
   "Create a new blank circuit."
-  '(0))
+  '(:circuit))
 
 (defun add-to-circuit (circuit operator &rest args)
   "Add OPERATOR to CIRCUIT."
-  (let ((entry (assoc operator *circuit-operators*))
+  (let ((entry (assoc operator *circuit-operators*)))
-        (largest-arg (apply 'max (remove-if-not 'integerp args))))
     (unless entry
       (error "Unknown circuit operator: ~s" operator))
-    (destructuring-bind (name arg-count &rest r) entry
+    (destructuring-bind (name arg-count has-rest &rest r) entry
       (declare (ignorable name r))
-      (unless (= arg-count (length args))
+      (unless (or (and has-rest (>= (length args) arg-count))
-        (error "Operator ~s expects ~s args, got ~s" operator
+                  (= (length args) arg-count))
-               arg-count (length args)))
+        (error "Operator ~s expects ~@[~*exactly ~]~s arg~:p, got ~s" operator
-      (when (> (1+ largest-arg) (car circuit))
+               (not has-rest) arg-count (length args)))
-        (setf (car circuit) (1+ largest-arg)))
       (nconc circuit (list (cons operator args))))
     circuit))
 
 (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))
+  (let ((circuit-var (gensym)))
-        (size-var (gensym))
+    `(let ((,circuit-var))
-        (ao-func (gensym))
-        (ao-entry-var (gensym))
-        (ao-i-var (gensym)))
-    `(let ((,circuit-var)
-           (,size-var 0))
-       (flet ((,ao-func (,ao-entry-var)
-                (dolist (,ao-i-var ,ao-entry-var)
-                  (when (and (integerp ,ao-i-var)
-                             (< ,size-var ,ao-i-var))
-                    (setq ,size-var ,ao-i-var)))
-                (push ,ao-entry-var ,circuit-var)))
        (macrolet
            (,@(mapcar (lambda (oper)
-                          (let ((arg (gensym)))
+                        (let ((arg (gensym))
-                            `(,(car oper) (&rest ,arg)
+                              (arg-list (loop repeat (second oper)
-                              (assert (= (length ,arg) ,(second oper))
+                                              collect (gensym)))
-                                      ()
+                              (whole-arg (when (third oper)
-                                      "~s expects ~s arguments, got ~s"
+                                           (gensym))))
-                                      ,(car oper) ,(second oper) (length ,arg))
+                          `(,(car oper) (&whole ,arg
-                              `(,',ao-func (list ,',(car oper) ,@,arg)))))
+                                                ,@arg-list
+                                                ,@(when (third oper)
+                                                    (list '&rest whole-arg)))
+                            (declare (ignorable ,@arg-list
+                                                ,@(when (third oper)
+                                                    (list whole-arg))))
+                            `(push (list ,@,arg) ,',circuit-var))))
                 *circuit-operators*))
-           ,@body))
+         ,@body)
-       (cons (1+ ,size-var) (nreverse ,circuit-var)))))
+       (cons :circuit (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-output function)
+  (destructuring-bind (&optional name arg-count has-rest has-output function)
       (assoc operator *circuit-operators*)
-    (declare (ignorable name arg-count))
+    (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 coefficients probabilities (places 5))
+(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)))
+  (assert (= 1 (count-if 'identity (list bits coefficients probabilities uniform)))
           ()
-          "Exactly one of BITS, COEFFICIENTS, and PROBABILITIES can be present")
+          "Exactly one of BITS, UNIFORM, COEFFICIENTS, and PROBABILITIES can ~
+be present")
   (let ((state (cond
-                 (bits (make-uniform-normal-state bits))
+                 (bits (make-zero-state bits))
+                 (uniform (make-uniform-normal-state uniform))
                  (coefficients (coerce coefficients 'vector))
                  (probabilities (make-normal-state probabilities)))))
-    (destructuring-bind (circuit-size &rest elements) circuit
-      (when (> circuit-size (state-bits state))
-        (error "Circuit needs at least ~s bits, got ~s" circuit-size
-               (state-bits state)))
     (values
      state
      (loop with *circuit-measure-places* = places
-             for element in elements
+           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)))))
+             collect result))))

cl-quantum.asd

@@ -2,6 +2,8 @@
   :version "0.0.1"
   :description "Quantum computing operations in pure Common Lisp."
   :author "Alexander Rosenberg <zanderpkg@pm.me>"
+  :maintainer "Alexander Rosenberg <zanderpkg@pm.me>"
+  :homepage "https://git.zander.im/Zander671/cl-quantum"
   :license "GPL3"
   :depends-on ()
   :serial t
@@ -10,11 +12,22 @@
    (:file "math")
    (:file "state")
    (:file "circuit")
-   (:file "pprint")))
+   (:file "pprint"))
+  :long-description
+  #.(uiop:read-file-string
+     (uiop:subpathname *load-pathname* "README.md")))
 
 (defsystem #:cl-quantum/parse
   :description "Textual state parsing component for cl-quantum."
-  :depends-on (#:cl-ppcre)
+  :depends-on (#:cl-quantum #:cl-ppcre)
-  :serial t
   :components
   ((:file "parse")))
+
+(defsystem #:cl-quantum/examples
+  :description "A collection of examples for ql-quantum."
+  :depends-on (#:cl-quantum)
+  :serial t
+  :components
+  ((:file "examples/package")
+   (:file "examples/grover")
+   (:file "examples/bell")))

examples/bell.lisp

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

examples/grover.lisp

@@ -0,0 +1,38 @@
+;;;; An example of Grover's algorithm (quantum search)
+(in-package :cl-quantum/examples)
+
+(defun count-grover-iterations (bits targets)
+  "Count the number of iterations it takes to have a high probability of finding
+TARGETS in a search space of 2^BITS."
+  (values (floor (* (/ pi 4) (sqrt (/ (ash 1 bits) targets))))))
+
+(defun make-grover-circuit (bits target)
+  "Generate a quantum circuit that runs Grover's algorithm over a state of BITS
+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
+    ;; Setup
+    (loop for i below bits do (:h i))
+
+    ;; Oracle
+    (loop
+      repeat (count-grover-iterations bits 1)
+      do
+         (loop for i below bits
+               for cur = (logand (ash target (- i)) 1)
+               when (zerop cur)
+                 do (:x i))
+         (:ncz 0 (loop for i from 1 below bits collect i))
+         (loop for i below bits
+               for cur = (logand (ash target (- i)) 1)
+               when (zerop cur)
+                 do (:x i))
+
+         ;; Diffuser
+         (loop for i below bits do (:h i))
+         (loop for i below bits do (:x i))
+         (:ncz 0 (loop for i from 1 below bits collect i))
+         (loop for i below bits do (:x i))
+         (loop for i below bits do (:h i)))))

examples/package.lisp

@@ -0,0 +1,8 @@
+(defpackage :cl-quantum/examples
+  (:documentation "A collection of examples for ql-quantum.")
+  (:use :cl :cl-quantum/state :cl-quantum/circuit)
+  (:export #:make-grover-circuit
+           #:make-bell-phi+-circuit
+           #:make-bell-phi--circuit
+           #:make-bell-psi+-circuit
+           #:make-bell-psi--circuit))

math.lisp

@@ -1,3 +1,4 @@
+;;;; Basic linear algebra subroutines used to implement the quantum operators
 (in-package :cl-quantum/math)
 
 (defmacro domatrix ((var matrix &optional retval) &body body)

package.lisp

@@ -1,4 +1,6 @@
 (defpackage :cl-quantum/math
+  (:documentation "Basic linear algebra subroutines used to implement the
+quantum operators.")
   (:use :cl)
   (:export #:domatrix
            #:mapmatrix
@@ -47,8 +49,10 @@
            #:vector=))
 
 (defpackage :cl-quantum/state
+  (:documentation "Functions for creating and applying quantum gates.")
   (:use :cl :cl-quantum/math)
-  (:export #:+unset-projector+
+  (:export #:define-constant
+           #:+unset-projector+
            #:+set-projector+
            #:+identity-2x2+
            #:+pauli-x-gate+
@@ -65,6 +69,7 @@
            #:normalize-state
            #:nnormalize-state
            #:state-bits
+           #:make-zero-state
            #:make-normal-state
            #:make-uniform-normal-state
            #:bit-unset-index
@@ -76,12 +81,16 @@
            #:collapse
            #:make-operator
            #:make-controlled-operator
-           #:apply-operator
+           #:make-n-toffoli-operator
-           #:napply-operator
+           #:make-n-controlled-z-operator
-           #:apply-controlled-operator
+           #:replace-state
-           #:napply-controlled-operator))
+           #:apply-gate
+           #:napply-gate
+           #:apply-controlled-gate
+           #:napply-controlled-gate))
 
 (defpackage :cl-quantum/circuit
+  (:documentation "High-level interface for building quantum circuits.")
   (:use :cl :cl-quantum/math :cl-quantum/state)
   (:export #:*circuit-measure-places*
            #:*circuit-operators*
@@ -91,6 +100,7 @@
            #:run-circuit))
 
 (defpackage :cl-quantum/pprint
+  (:documentation "High-level interface for building quantum circuits.")
   (:use :cl :cl-quantum/math :cl-quantum/state)
   (:export #:pprint-complex
            #:pprint-format-bits

parse.lisp

@@ -1,5 +1,7 @@
+;;;; Parse back the states printed by pprint.lisp
 (defpackage :cl-quantum/parse
-  (:use :cl :cl-quantum/state)
+  (:documentation "Parse back the states printed by pprint.lisp.")
+  (:use :cl :cl-quantum/math :cl-quantum/state)
   (:export #:parse-real
            #:parse-complex
            #:parse-state
@@ -44,7 +46,7 @@ stopped. That is, the index of the first un-parsed character."
         (list 0 0)
         (error "Malformed number: ~s" (subseq string start end))))))
 
-(define-constatnt +parse-complex-regexp+
+(define-constant +parse-complex-regexp+
     (ppcre:create-scanner
      "^\\s*([-+])?\\s*([-+]?)([0-9/.]+(?:[eE][-+]?[0-9]+)?)?(i)?"
      :extended-mode t)

pprint.lisp

@@ -1,3 +1,4 @@
+;;;; Create nice looking textual representations of quantum states
 (in-package :cl-quantum/pprint)
 
 (defun pprint-complex (n &key parens (places 5))

state.lisp

@@ -1,6 +1,7 @@
+;;;; Functions for creating and applying quantum gates
 (in-package :cl-quantum/state)
 
-;;; Fix SBCL's strict handling of `defconstant'
+;; Fix SBCL's strict handling of `defconstant'
 (defmacro define-constant (name value &optional doc)
   "Define NAME to be a constant with value VALUE. If NAME is already defined, do
 nothing."
@@ -12,59 +13,72 @@ nothing."
 ;;; Gates and Operators:
 (define-constant +unset-projector+
   #2A((1 0)
-      (0 0)))
+      (0 0))
+  "|0><0| projector matrix.")
 
 (define-constant +set-projector+
   #2A((0 0)
-      (0 1)))
+      (0 1))
+  "|1><1| projector matrix.")
 
 (define-constant +identity-2x2+
-    (make-identity-matrix 2))
+    (make-identity-matrix 2)
+  "A 2 by 2 identity matrix.")
 
 (define-constant +pauli-x-gate+
   #2A((0 1)
-      (1 0)))
+      (1 0))
+  "A 2 by 2 Pauli X gate that can be applied to a single qbit.")
 
 (define-constant +pauli-y-gate+
   #2A((0 #C(0 -1))
-      (#C(0 -1) 0)))
+      (#C(0 -1) 0))
+  "A 2 by 2 Pauli Y gate that can be applied to a single qbit.")
 
 (define-constant +pauli-z-gate+
   #2A((1 0)
-      (0 -1)))
+      (0 -1))
+  "A 2 by 2 Pauli Z gate that can be applied to a single qbit.")
 
 (define-constant +hadamard-gate+
     (let ((oort (/ (sqrt 2))))
       (make-array '(2 2) :initial-contents
                   `((,oort ,oort)
-                    (,oort ,(- oort))))))
+                    (,oort ,(- oort)))))
+  "A 2 by 2 Hadamard gate that can be applied to a single qbit.")
 
 (define-constant +phase-gate+
   #2A((1 0)
-      (0 #C(0 1))))
+      (0 #C(0 1)))
+  "A 2 by 2 phase gate that can be applied to a single qbit.")
 
 (define-constant +pi/8-gate+
     (make-array '(2 2) :initial-contents
                 `((1 0)
-                  (0 ,(exp (complex 0 (/ pi 4)))))))
+                  (0 ,(exp (complex 0 (/ pi 4))))))
+  "A 2 by 2 phase gate that can be applied to a single qbit.")
 
 (define-constant +cnot-gate+
   #2A((1 0 0 0)
       (0 1 0 0)
       (0 0 0 1)
-      (0 0 1 0)))
+      (0 0 1 0))
+  "A 4 by 4 controlled NOT (Pauli X) gate that applies to a 2 qbit state. The 0
+indexed qbit is the target and the 1 indexed qbit is the control.")
 
 (define-constant +cz-gate+
   #2A((1 0 0 0)
       (0 1 0 0)
       (0 0 1 0)
-      (0 0 0 -1)))
+      (0 0 0 -1))
+  "A 4 by 4 controlled Pauli Z gate that applies to a 2 qbit state.")
 
 (define-constant +swap-gate+
   #2A((1 0 0 0)
       (0 0 1 0)
       (0 1 0 0)
-      (0 0 0 1)))
+      (0 0 0 1))
+  "A 4 by 4 swap gate that applies to a 2 qbit state.")
 
 (define-constant +ccnot-gate+
   #2A((1 0 0 0 0 0 0 0)
@@ -74,7 +88,9 @@ nothing."
       (0 0 0 0 1 0 0 0)
       (0 0 0 0 0 1 0 0)
       (0 0 0 0 0 0 0 1)
-      (0 0 0 0 0 0 1 0)))
+      (0 0 0 0 0 0 1 0))
+  "An 8 by 8 2-controlled NOT (Pauli X) gate that applies to a 3 qbit sate. The
+0 indexed qbit is the target and the 1 and 2 indexed qbits are the controls.")
 
 ;;; State Functions:
 (defun normal-state-p (state &key (places 5))
@@ -96,6 +112,13 @@ round the norm of STATE before checking."
   "Return the number of bits in STATE."
   (values (ceiling (log (length state) 2))))
 
+(defun make-zero-state (bits)
+  "Make a normalized state with a value of zero (probability of 1 in the zero
+place)."
+  (let ((arr (make-array (ash 1 bits) :initial-element 0)))
+    (setf (aref arr 0) 1)
+    arr))
+
 (defun make-normal-state (probabilities)
   "Create a new normalized state with the probability of each state
 corresponding to an element in PROBABILITIES."
@@ -116,6 +139,11 @@ corresponding to an element in PROBABILITIES."
   "Return the Nth index in a state in which BIT is 1."
   (+ period (bit-unset-index bit n :period period)))
 
+(defun bit-set-p (bit n)
+  "Return non-nil if BIT would be set at index N."
+  (let ((period (ash 1 bit)))
+    (>= (rem n (* 2 period)) period)))
+
 (defun bit-probability (state bit)
   "Return the probability that BIT is set in STATE."
   (setq state (normalize-state state))
@@ -215,6 +243,39 @@ apply OPERATOR to TARGET if CONTROL is set."
     (+mm (tensor-chain +identity-2x2+ +unset-projector+)
          (tensor-chain operator +set-projector+))))
 
+(defun make-n-toffoli-operator (bits target controls)
+  "Create an n-Toffoli gate for a state of BITS bits that targets TARGET and is
+controlled by CONTROLS."
+  (assert (not (member target controls :test '=))
+          (target controls)
+          "Target ~s cannot be in control set ~s" target controls)
+  (let* ((state-size (ash 1 bits))
+         (mat (make-identity-matrix state-size))
+         (offset (ash 1 target)))
+    (loop for i below (/ state-size 2)
+          for index = (bit-unset-index target i)
+          when (every (lambda (elt)
+                        (bit-set-p elt index))
+                      controls)
+            do (nswap-rows mat index (+ index offset)))
+    mat))
+
+(defun make-n-controlled-z-operator (bits target controls)
+  "Create an n-controlled z gate for a state of BITS bits that targets TARGET
+and is controlled by CONTROLS."
+  (assert (not (member target controls :test '=))
+          (target controls)
+          "Target ~s cannot be in control set ~s" target controls)
+  (let* ((state-size (ash 1 bits))
+         (mat (make-identity-matrix state-size)))
+    (loop for i below (/ state-size 2)
+          for index = (bit-set-index target i)
+          when (every (lambda (elt)
+                        (bit-set-p elt index))
+                      controls)
+            do (setf (aref mat index index) -1))
+    mat))
+
 (defun replace-state (target template)
   "Replace each element of TARGET with the corresponding element in TEMPLATE."
   (assert (= (length target) (length template))
@@ -223,20 +284,20 @@ apply OPERATOR to TARGET if CONTROL is set."
   (dotimes (i (length target) target)
     (setf (aref target i) (aref template i))))
 
-(defun apply-operator (state operator target)
+(defun apply-gate (state operator target)
   "Apply OPERATOR to the bit numbered TARGET in STATE."
   (*mv (make-operator (state-bits state) operator target) state))
 
-(defun napply-operator (state operator target)
+(defun napply-gate (state operator target)
   "Apply OPERATOR to the bit numbered TARGET in STATE. This modifies state."
-  (replace-state state (apply-operator state operator target)))
+  (replace-state state (apply-gate state operator target)))
 
-(defun apply-controlled-operator (state operator target control)
+(defun apply-controlled-gate (state operator target control)
   "Apply OPERATOR to the bit numbered TARGET in STATE if CONTROL is set."
   (*mv (make-controlled-operator (state-bits state) operator target control)
        state))
 
-(defun napply-controlled-operator (state operator target control)
+(defun napply-controlled-gate (state operator target control)
   "Apply OPERATOR to the bit numbered TARGET in STATE if CONTROL is set. This
 modified STATE."
-  (replace-state state (apply-controlled-operator state operator target control)))
+  (replace-state state (apply-controlled-gate state operator target control)))