Zander671/cl-quantum
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add examples and clean up some stuff

Browse Source
This commit is contained in:
Alexander Rosenberg 2024-12-08 22:06:58 -08:00
parent 5adc755be4
commit 9b8584bd6f
Signed by: Zander671
GPG Key ID: 5FD0394ADBD72730
10 changed files with 275 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

153
circuit.lisp
View File

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

19
cl-quantum.asd
View File

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

30
examples/bell.lisp Normal file
View File

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

38
examples/grover.lisp Normal file
View File

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

8
examples/package.lisp Normal file
View File

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

1
math.lisp
View File

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

20
package.lisp
View File

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

6
parse.lisp
View File

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

1
pprint.lisp
View File

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

101
state.lisp
View File

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