diff --git a/circuit.lisp b/circuit.lisp index 97f1529..5ef2d90 100644 --- a/circuit.lisp +++ b/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-operator state matrix target))))) + (if control + (napply-controlled-gate state matrix target control) + (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) - (:x 1 nil circuit-matrix-operation) - (:y 1 nil circuit-matrix-operation) - (:z 1 nil circuit-matrix-operation) - (:h 1 nil circuit-matrix-operation) - (:p 1 nil circuit-matrix-operation) - (:t 1 nil circuit-matrix-operation) - (:cnot 2 nil circuit-matrix-operation) - (:cz 2 nil circuit-matrix-operation) - (:measure 2 t ,(lambda (state operator &rest args) - (declare (ignorable operator)) - (nmeasure state (car args) - :places *circuit-measure-places*))))) + `((:gate 2 nil nil circuit-arbitrary-gate) + (:cgate 3 nil nil circuit-arbitrary-gate) + (:* 1 nil nil circuit-matrix-operation) + (:x 1 nil nil circuit-matrix-operation) + (:y 1 nil nil circuit-matrix-operation) + (:z 1 nil nil circuit-matrix-operation) + (:h 1 nil nil circuit-matrix-operation) + (:p 1 nil nil circuit-matrix-operation) + (: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))) (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*)) - (largest-arg (apply 'max (remove-if-not 'integerp args)))) + (let ((entry (assoc operator *circuit-operators*))) (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)) - (error "Operator ~s expects ~s args, got ~s" operator - arg-count (length args))) - (when (> (1+ largest-arg) (car circuit)) - (setf (car circuit) (1+ largest-arg))) + (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)))) 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)) - (size-var (gensym)) - (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))) - `(,(car oper) (&rest ,arg) - (assert (= (length ,arg) ,(second oper)) - () - "~s expects ~s arguments, got ~s" - ,(car oper) ,(second oper) (length ,arg)) - `(,',ao-func (list ,',(car oper) ,@,arg))))) - *circuit-operators*)) - ,@body)) - (cons (1+ ,size-var) (nreverse ,circuit-var))))) + (let ((circuit-var (gensym))) + `(let ((,circuit-var)) + (macrolet + (,@(mapcar (lambda (oper) + (let ((arg (gensym)) + (arg-list (loop repeat (second oper) + collect (gensym))) + (whole-arg (when (third oper) + (gensym)))) + `(,(car oper) (&whole ,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) + (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 name = (car element) - for args = (cdr element) - for result = (apply-circuit-operator-to-state state name args) - when result - collect result))))) + (values + 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)))) diff --git a/cl-quantum.asd b/cl-quantum.asd index 0652987..ae6479d 100644 --- a/cl-quantum.asd +++ b/cl-quantum.asd @@ -2,6 +2,8 @@ :version "0.0.1" :description "Quantum computing operations in pure Common Lisp." :author "Alexander Rosenberg " + :maintainer "Alexander Rosenberg " + :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) - :serial t + :depends-on (#:cl-quantum #:cl-ppcre) :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"))) diff --git a/examples/bell.lisp b/examples/bell.lisp new file mode 100644 index 0000000..34efbc9 --- /dev/null +++ b/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))) diff --git a/examples/grover.lisp b/examples/grover.lisp new file mode 100644 index 0000000..9d28546 --- /dev/null +++ b/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))))) diff --git a/examples/package.lisp b/examples/package.lisp new file mode 100644 index 0000000..1793bf4 --- /dev/null +++ b/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)) diff --git a/math.lisp b/math.lisp index 34ff413..945423a 100644 --- a/math.lisp +++ b/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) diff --git a/package.lisp b/package.lisp index d6cd09d..714220e 100644 --- a/package.lisp +++ b/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 - #:napply-operator - #:apply-controlled-operator - #:napply-controlled-operator)) + #:make-n-toffoli-operator + #:make-n-controlled-z-operator + #:replace-state + #: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 diff --git a/parse.lisp b/parse.lisp index df294a1..f0c63ed 100644 --- a/parse.lisp +++ b/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) diff --git a/pprint.lisp b/pprint.lisp index dc620e7..3b3df2f 100644 --- a/pprint.lisp +++ b/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)) diff --git a/state.lisp b/state.lisp index ba75848..4c7f186 100644 --- a/state.lisp +++ b/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)))