diff --git a/benchmarking/foust/foust-benchmarking.lisp b/benchmarking/foust/foust-benchmarking.lisp new file mode 100644 index 000000000..c2d165026 --- /dev/null +++ b/benchmarking/foust/foust-benchmarking.lisp @@ -0,0 +1,238 @@ +;;;; foust-benchmarking.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil-benchmarking.foust + (:use + #:coalton + #:coalton-prelude) + (:use + #:coalton-quil + #:cl-quil.foust-quil) + (:import-from #:coalton-library/math/complex #:square-magnitude) + (:local-nicknames + (#:bits #:coalton-library/bits) + (#:cell #:coalton-library/cell) + (#:file #:coalton-library/file) + (#:iter #:coalton-library/iterator) + (#:list #:coalton-library/list) + (#:map #:coalton-library/ord-map) + (#:string #:coalton-library/string)) + (:export + #:foust-benchmark-qasm-suite + #:cl-foust-benchmark-qasm-suite)) + +(in-package #:cl-quil-benchmarking.foust) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (declare qasm-prefix file:Pathname) + (define qasm-prefix + "The pathname of the directory in which the QASM benchmarking files are stored." + (unwrap (file:system-relative-pathname "cl-quil" "benchmarking/ibm_qx_mapping/examples/"))) + + (declare qasm-test-files (Unit -> (List file:Pathname))) + (define (qasm-test-files) + "A list of pathnames associated with the QASM benchmarking files." + (filter (compose (string:substring? ".qasm") into) (unwrap (file:directory-files qasm-prefix)))) + + (declare parsed-program-multi-qubit-depth (QuilParsedProgram -> UFix)) + (define (parsed-program-multi-qubit-depth parsed-program-p) + "The number of gates applied to two or more qubits in a parsed program." + (match (get-parsed-program-executable-code parsed-program-p) + ((QuilExecutableCode instructions) + (list:countby (fn (instruction) + (match instruction + ((QuilGateApplication gate-application-g) + (<= 2 (length (get-quil-gate-application-qubits gate-application-g)))) + (_ False))) + instructions))))) + +(coalton-toplevel + + (declare remap-ufix (QuilRewiring -> UFix -> UFix)) + (define (remap-ufix rewiring n) + "Transform a number by a bitwise rewiring." + (iter:fold! (fn (n-prime (Tuple new-m old-m)) + (if (< 0 (bits:and n (bits:shift (as Integer old-m) 1))) + (+ n-prime (bits:shift (as Integer new-m) 1)) + n-prime)) + 0 + (iter:enumerate! + (iter:into-iter (get-quil-rewiring-p2l rewiring))))) + + (declare parsed-program-amplitudes (QuilParsedProgram -> (map:Map UFix (Complex Double-Float)))) + (define (parsed-program-amplitudes parsed-program-p) + "Simulate a parsed program with the initial state |00...0⟩ and return the resulting amplitudes." + (let ((raw-amplitudes (lisp (List (Complex Double-Float)) (parsed-program-p) + (cl:coerce (qvm::amplitudes (qvm:run-program 16 parsed-program-p)) 'cl:list)))) + (pipe (match (find (compose (< 0.0000001d0) square-magnitude) raw-amplitudes) + ((Some first-amp) (let ((phase (/ first-amp (into (sqrt (square-magnitude first-amp)))))) + (map (flip / phase) raw-amplitudes))) + ((None) raw-amplitudes)) + iter:into-iter + iter:enumerate! + map:collect!))) + + (declare complex== ((Complex Double-Float) -> (Complex Double-Float) -> Boolean)) + (define (complex== a b) + "Are `a` and `b` approximately equal?" + (> 0.000001d0 (square-magnitude (- a b)))) + + (declare amplitudes==at (QuilRewiring -> QuilRewiring + -> (map:Map UFix (Complex Double-Float)) -> (map:Map UFix (Complex Double-Float)) + -> UFix -> Boolean)) + (define (amplitudes==at rewiring-one rewiring-two amplitudes-one amplitudes-two n) + "Given a pair of rewirings, are two sets of amplitudes equal by `complex==` for an index `n`." + (complex== (unwrap (map:lookup amplitudes-one (remap-ufix rewiring-one n))) + (unwrap (map:lookup amplitudes-two (remap-ufix rewiring-two n)))))) + +(coalton-toplevel + + (declare ==by-qvm (QuilParsedProgram -> QuilParsedProgram -> Boolean)) + (define (==by-qvm parsed-program-one parsed-program-two) + "Do two parsed programs produce the same amplitudes when simulated on the initial state |00...0⟩" + (let ((rewiring-one (get-parsed-program-final-rewiring parsed-program-one)) + (rewiring-two (get-parsed-program-final-rewiring parsed-program-two)) + (amplitudes-one (parsed-program-amplitudes parsed-program-one)) + (amplitudes-two (parsed-program-amplitudes parsed-program-two))) + (all (amplitudes==at rewiring-one rewiring-two amplitudes-one amplitudes-two) + (range 0 (1- (bits:shift 16 1))))))) + +(coalton-toplevel + + + (declare nstring (UFix -> String -> String)) + (define (nstring n str) + "Repeat the String `str` `n` times and concatenate." + (iter:fold! <> mempty (iter:take! n (iter:repeat str)))) + + (declare num->stringm ((Num :a) (Into :a String) => UFix -> :a -> String)) + (define (num->stringm m n) + "Produce a String of length `m` from the String representation of the number `n`." + (let ((str (string:substring (into n) 0 m)) + (len (string:length str))) + (string:concat (nstring (- m len) " ") str))) + + (declare stringm (UFix -> String -> String)) + (define (stringm m str) + "Produce a String of length `m` from `str`, adding trailing spaces or trimming as needed." + (let ((str2 (string:substring str 0 16))) + (string:concat str2 (nstring (- m (string:length str2)) " "))))) + +;; This macro is copied directly from +;; quilc/benchmarking/rewiring-analysis.lisp +;; written by Robert Smith. +(cl:defmacro with-stopwatch (elapsed-var cl:&body body) + (cl:let ((start-time (cl:gensym))) + `(cl:let ((,start-time (cl:get-internal-real-time))) + (cl:symbol-macrolet ((,elapsed-var (cl:- (cl:get-internal-real-time) ,start-time))) + ,@body)))) + +;; The code in the following block is adapted from +;; the function benchmark-qasm-suite in the file +;; quilc/benchmarking/qasm-benchmarking.lisp +;; for use with Foust in Coalton. +(coalton-toplevel + + (declare foust-benchmark-qasm-suite (UFix -> Unit)) + (define (foust-benchmark-qasm-suite timeout) + "Benchmark Foust by compiling a suite of QASM files to the chip `ibm-qx-5` with the Quil compiler, with and without using Foust in its `preserve` mode." + (print "┌─────────────────┬───────────────────────────┬───────────────────────────┬───────────────────────────┬──────────────────────┐") + (print "│ │ WITHOUT FOUST │ WITH NAIVE FOUST │ WITH CHIP-AWARE FOUST │ VALIDATION │") + (print "├─────────────────┼───────────────────────────┼───────────────────────────┼───────────────────────────┼──────────────────────┤") + (print "│ NAME │ TIME (s) SWAPS 2Q DEPTH │ TIME (s) SWAPS 2Q DEPTH │ TIME (s) SWAPS 2Q DEPTH │ Matrix? Amplitudes? │") + (print "├─────────────────┼───────────────────────────┼───────────────────────────┼───────────────────────────┼──────────────────────┤") + (for file-f in (qasm-test-files) + (let ((pp (parse-file file-f)) + (unfousted-cpp (cell:new (the (Optional QuilParsedProgram) None))) + (fousted-cpp (cell:new (the (Optional QuilParsedProgram) None)))) + (print + (mconcat + (make-list + "│ " (stringm 16 (unwrap (string:strip-suffix ".qasm" (unwrap (string:strip-prefix (into qasm-prefix) (into file-f)))))) + (match (lisp (Tuple (Optional QuilParsedProgram) String) (timeout pp) + (trivial-garbage:gc :full cl:t) + (cl:handler-case + (bordeaux-threads:with-timeout (timeout) + (with-stopwatch elapsed-time + (coalton + (match (compiler-hook (lisp QuilParsedProgram () pp) (build-IBM-Qx5) True False) + ((Tuple3 cpp swaps _) + (Tuple (Some cpp) + (mconcat + (make-list + "│ " (num->stringm 8 (lisp Double-Float () (cl:coerce (cl:/ elapsed-time 1000000) 'cl:double-float))) " " + " " (num->stringm 5 swaps) " " + " " (num->stringm 8 (parsed-program-multi-qubit-depth cpp)) " ")))))))) + (bordeaux-threads:timeout () + (coalton (Tuple None "│ TIMEOUT! ????? ???????? "))))) + ((Tuple cpp str) + (progn (cell:write! unfousted-cpp cpp) str))) + (match (lisp (Tuple (Optional QuilParsedProgram) String) (timeout pp) + (trivial-garbage:gc :full cl:t) + (cl:handler-case + (bordeaux-threads:with-timeout (timeout) + (with-stopwatch elapsed-time + (coalton + (match (compiler-hook + (foust-parsed-program (lisp QuilParsedProgram () pp) None True False) + (build-IBM-Qx5) True False) + ((Tuple3 cpp swaps _) + (Tuple (Some cpp) + (mconcat + (make-list + "│ " (num->stringm 8 (lisp Double-Float () (cl:coerce (cl:/ elapsed-time 1000000) 'cl:double-float))) " " + " " (num->stringm 5 swaps) " " + " " (num->stringm 8 (parsed-program-multi-qubit-depth cpp)) " ")))))))) + (bordeaux-threads:timeout () + (coalton (Tuple None "│ TIMEOUT! ????? ???????? "))))) + ((Tuple _ str) str)) + (match (lisp (Tuple (Optional QuilParsedProgram) String) (timeout pp) + ;; + (trivial-garbage:gc :full cl:t) + (cl:handler-case + (bordeaux-threads:with-timeout (timeout) + (with-stopwatch elapsed-time + (coalton + (match (compiler-hook + (foust-parsed-program (lisp QuilParsedProgram () pp) (Some (build-IBM-Qx5)) True False) + (build-IBM-Qx5) True False) + ((Tuple3 cpp swaps _) + (Tuple (Some cpp) + (mconcat + (make-list + "│ " (num->stringm 8 (lisp Double-Float () (cl:coerce (cl:/ elapsed-time 1000000) 'cl:double-float))) " " + " " (num->stringm 5 swaps) " " + " " (num->stringm 8 (parsed-program-multi-qubit-depth cpp)) " ")))))))) + (bordeaux-threads:timeout () + (coalton (Tuple None "│ TIMEOUT! ????? ???????? "))))) + ((Tuple cpp str) + (progn (cell:write! fousted-cpp cpp) str))) + (match (Tuple (cell:read unfousted-cpp) (cell:read fousted-cpp)) + ((Tuple (Some unwrapped-unfousted-cpp) (Some unwrapped-fousted-cpp)) + (lisp String (timeout unwrapped-unfousted-cpp unwrapped-fousted-cpp) + (cl:concatenate + 'cl:string + (cl:handler-case + (bordeaux-threads:with-timeout (timeout) + (coalton + (if (== (lisp QuilParsedProgram () unwrapped-unfousted-cpp) + (lisp QuilParsedProgram () unwrapped-fousted-cpp)) + "│ YES " "│ NO "))) + (sb-kernel::heap-exhausted-error () "│ ??????? ") + (bordeaux-threads:timeout () "│ ??????? ")) + (cl:handler-case + (bordeaux-threads:with-timeout (timeout) + (coalton + (if (==by-qvm (lisp QuilParsedProgram () unwrapped-unfousted-cpp) + (lisp QuilParsedProgram () unwrapped-fousted-cpp)) + " YES │" " NO │"))) + (bordeaux-threads:timeout () " ????????? │"))))) + (_ "│ ??????? ??????????? │"))))))) + (print "└─────────────────┴───────────────────────────┴───────────────────────────┴───────────────────────────┴──────────────────────┘"))) + +(cl:defun cl-foust-benchmark-qasm-suite (cl:&key (timeout 30)) + (coalton (foust-benchmark-qasm-suite (lisp UFix () timeout)))) diff --git a/cl-quil-benchmarking.asd b/cl-quil-benchmarking.asd index 5400a8afd..9a8f7c436 100644 --- a/cl-quil-benchmarking.asd +++ b/cl-quil-benchmarking.asd @@ -18,3 +18,16 @@ (:file "quilc-perf") (:file "quilc-mon-prof") (:file "suite"))) + +(asdf:defsystem "cl-quil-benchmarking/foust" + :depends-on ("coalton" + "cl-quil/coalton" + "cl-quil/foust" + "bordeaux-threads" + "trivial-garbage") + :author "Yarin Heffes" + :description "A benchmark for Foust." + :license "Apache License 2.0" + :pathname "benchmarking/foust/" + :serial t + :components ((:file "foust-benchmarking"))) diff --git a/cl-quil-tests.asd b/cl-quil-tests.asd index 314b3c5f9..ebcbb6bd6 100644 --- a/cl-quil-tests.asd +++ b/cl-quil-tests.asd @@ -54,3 +54,27 @@ (:file "permutation-tests") (:file "sqisw-decomp-tests") (:file "extern-tests"))) + +(asdf:defsystem "cl-quil-tests/foust-tests" + :depends-on ("coalton/testing" + "fiasco" + "cl-quil/foust") + :license "Apache License 2.0" + :pathname "tests/foust" + :serial t + :components ((:file "tests")) + :perform (test-op (o s) (symbol-call '#:cl-quil-tests/foust-tests '#:run-tests))) + +(asdf:defsystem "cl-quil-tests/discrete-tests" + :description "Test suite for cl-quil/discrete." + :license "Apache License 2.0 (See LICENSE.txt)" + :depends-on (#:cl-quil/discrete #:coalton #:coalton/testing #:fiasco) + :perform (asdf:test-op (o s) + (uiop:symbol-call ':cl-quil.discrete-tests + '#:run-discrete-tests)) + :pathname "tests/discrete/" + :serial t + :components ((:file "package") + (:file "suite") + (:file "rz-approx-tests") + (:file "compilation-tests"))) diff --git a/cl-quil.asd b/cl-quil.asd index e5f814d5d..a455d55ca 100644 --- a/cl-quil.asd +++ b/cl-quil.asd @@ -237,6 +237,42 @@ (:file "calibration-tests") (:file "analysis-tests"))) +(asdf:defsystem "cl-quil/coalton" + :description "Coalton integration in `cl-quil`." + :author "Yarin Heffes" + :license "Apache License 2.0" + :depends-on ("cl-quil" + "coalton") + :pathname "src/coalton" + :serial t + :components ((:file "coalton-quil"))) + +(asdf:defsystem "cl-quil/foust" + :description "???" + :author "Yarin Heffes" + :license "Apache License 2.0" + :depends-on ("coalton" + "cl-quil/coalton") + :pathname "src/foust/" + :serial t + :components ((:file "sign") + (:file "angle") + (:file "pauli-operator") + (:file "pauli") + (:file "frame") + (:file "assignments") + (:file "node") + (:file "gate") + (:file "circuit") + (:file "graph") + (:file "cost") + (:file "reduce") + (:file "optimize") + (:file "compile") + (:file "foust") + (:file "foust-quil")) + :in-order-to ((test-op (test-op "cl-quil-tests/foust-tests")))) + (asdf:defsystem #:cl-quil/discrete :description "Extensions to CL-QUIL to allow compilation to a discrete gate set." :license "Apache License 2.0 (See LICENSE.txt)" @@ -247,7 +283,7 @@ #:parse-float #:coalton #:coalton/library/big-float) - :in-order-to ((asdf:test-op (asdf:test-op #:cl-quil/discrete-tests))) + :in-order-to ((asdf:test-op (asdf:test-op #:cl-quil-tests/discrete-tests))) :around-compile (lambda (compile) (let (#+sbcl (sb-ext:*derive-function-types* t)) (funcall compile))) @@ -289,20 +325,6 @@ :serial t :components ((:file "clifford-t"))))) -(asdf:defsystem #:cl-quil/discrete-tests - :description "Test suite for cl-quil/discrete." - :license "Apache License 2.0 (See LICENSE.txt)" - :depends-on (#:cl-quil/discrete #:coalton #:coalton/testing #:fiasco) - :perform (asdf:test-op (o s) - (uiop:symbol-call ':cl-quil.discrete-tests - '#:run-discrete-tests)) - :pathname "tests/discrete/" - :serial t - :components ((:file "package") - (:file "suite") - (:file "rz-approx-tests") - (:file "compilation-tests"))) - (asdf:defsystem #:cl-quil/quilec :description "Quantum error correction toolkit." :author "Juan M. Bello-Rivas" diff --git a/src/coalton/README.md b/src/coalton/README.md new file mode 100644 index 000000000..40a73b186 --- /dev/null +++ b/src/coalton/README.md @@ -0,0 +1,3 @@ +# `COALTON-QUIL` + +This is a rudimentary interface to the Quil AST via Coalton. This was developed primarily for Foust, and it is expected to be elaborated upon in the near future. diff --git a/src/coalton/coalton-quil.lisp b/src/coalton/coalton-quil.lisp new file mode 100644 index 000000000..ded9ae438 --- /dev/null +++ b/src/coalton/coalton-quil.lisp @@ -0,0 +1,616 @@ +;;;; coalton-quil.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:coalton-quil + (:documentation + "This package defines an interface between Coalton and the Common Lisp library `cl-quil`.") + (:use + #:coalton + #:coalton-prelude) + (:local-nicknames + (#:tree #:coalton-library/ord-tree) + (#:map #:coalton-library/ord-map)) + (:export + #:QuilMemoryRef + #:QuilMemoryDescriptor + #:QuilGateApplication + #:QuilMeasure + #:QuilMeasureDiscard + #:QuilMeasurement + #:QuilClassicalMove + #:QuilClassicalExclusiveOr + #:QuilBinaryClassicalInstruction + #:QuilPragma + #:QuilHalt + #:QuilInstruction + #:QuilNamedOperator + #:QuilDaggerOperator + #:QuilOperatorDescription + #:QuilParsedProgram + #:QuilExecutableCode + #:QuilChipSpecification + #:QuilRewiring + #:parse-quil + #:parse-file + #:get-parsed-program-memory-definitions + #:set-parsed-program-memory-definitions! + #:map-parsed-program-memory-definitions! + #:get-parsed-program-executable-code + #:set-parsed-program-executable-code! + #:copy-parsed-program + #:print-parsed-program + #:get-parsed-program-final-rewiring + #:get-quil-gate-application-qubits + #:get-quil-gate-application-angle + #:get-quil-measure-qubit + #:get-quil-measure-discard-qubit + #:get-quil-measurement-qubit + #:get-quil-measure-address + #:get-quil-measurement-address + #:get-quil-operator-description + #:get-quil-named-operator-name + #:get-quil-dagger-operator-operator + #:make-quil-gate-application + #:make-quil-measurement + #:make-quil-classical-move + #:make-quil-classical-exclusive-or + #:make-quil-memory-descriptor + #:make-quil-memory-ref + #:compiler-hook + #:get-chip-specification-links + #:build-IBM-Qx5 + #:build-nQ-fully-connected-chip + #:parse-gate-information + #:build-nQ-fully-connected-chip2 + #:get-quil-rewiring-l2p + #:get-quil-rewiring-p2l)) + +(in-package #:coalton-quil) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (repr :native cl-quil:memory-ref) + (define-type QuilMemoryRef) + + (repr :native cl-quil:memory-descriptor) + (define-type QuilMemoryDescriptor) + + (repr :native cl-quil:gate-application) + (define-type QuilGateApplication) + + (repr :native cl-quil:measure) + (define-type QuilMeasure) + + (repr :native cl-quil:measure-discard) + (define-type QuilMeasureDiscard) + + (repr :native cl-quil:measurement) + (define-type ClQuilMeasurement) + + (repr :native cl-quil:classical-move) + (define-type QuilClassicalMove) + + (repr :native cl-quil:classical-exclusive-or) + (define-type QuilClassicalExclusiveOr) + + (repr :native cl-quil:binary-classical-instruction) + (define-type ClQuilBinaryClassicalInstruction) + + (repr :native cl-quil:pragma) + (define-type QuilPragma) + + (repr :native cl-quil:halt) + (define-type QuilHalt) + + (repr :native cl-quil:instruction) + (define-type ClQuilInstruction) + + (repr :native cl-quil:named-operator) + (define-type QuilNamedOperator) + + (repr :native cl-quil:dagger-operator) + (define-type QuilDaggerOperator) + + (repr :native cl-quil:operator-description) + (define-type ClQuilOperatorDescription) + + (repr :native cl-quil:parsed-program) + (define-type QuilParsedProgram) + + (repr :native cl:simple-vector) + (define-type ClQuilExecutableCode) + + (repr :native cl-quil::chip-specification) + (define-type QuilChipSpecification) + + (repr :native cl:hash-table) + (define-type QuilGateInformation) + + (repr :native cl-quil:rewiring) + (define-type QuilRewiring)) + +(coalton-toplevel + + (define-type QuilMeasurement + (QuilMeasure QuilMeasure) + (QuilMeasureDiscard QuilMeasureDiscard)) + + (define-instance (Into ClQuilMeasurement QuilMeasurement) + (define (into measurement-m) + (lisp QuilMeasurement (measurement-m) + (adt:match cl-quil:measurement measurement-m + ((cl-quil:measure) + (coalton (QuilMeasure (lisp QuilMeasure () measurement-m)))) + ((cl-quil:measure-discard) + (coalton (QuilMeasureDiscard (lisp QuilMeasureDiscard () measurement-m)))) + (_ (coalton (error "Unexcepted cl-quil:measurement. + +Must be in {cl-quil:measure, cl-quil:measure-discard}."))))))) + (define-instance (Into QuilMeasurement ClQuilMeasurement) + (define (into measurement-m) + (match measurement-m + ((QuilMeasure measure-m) + (lisp ClQuilMeasurement (measure-m) measure-m)) + ((QuilMeasureDiscard measure-discard-m) + (lisp ClQuilMeasurement (measure-discard-m) measure-discard-m))))) + (define-instance (Iso QuilMeasurement ClQuilMeasurement))) + +(coalton-toplevel + + (define-type QuilBinaryClassicalInstruction + (QuilClassicalMove QuilClassicalMove) + (QuilClassicalExclusiveOr QuilClassicalExclusiveOr)) + + (define-instance (Into ClQuilBinaryClassicalInstruction QuilBinaryClassicalInstruction) + (define (into instruction-i) + (lisp QuilBinaryClassicalInstruction (instruction-i) + (adt:match cl-quil:binary-classical-instruction instruction-i + ((cl-quil:classical-move) + (coalton (QuilClassicalMove (lisp QuilClassicalMove () instruction-i)))) + ((cl-quil:classical-exclusive-or) + (coalton (QuilClassicalExclusiveOr (lisp QuilClassicalExclusiveOr () instruction-i)))) + (_ (coalton (error "Unexpected cl-quil:classical-instruction. + +Must be in {cl-quil:classical-move, cl-quil:classical-exclusive-or}."))))))) + (define-instance (Into QuilBinaryClassicalInstruction ClQuilBinaryClassicalInstruction) + (define (into instruction-i) + (match instruction-i + ((QuilClassicalMove classical-move-m) + (lisp ClQuilBinaryClassicalInstruction (classical-move-m) classical-move-m)) + ((QuilClassicalExclusiveOr classical-exclusive-or-x) + (lisp ClQuilBinaryClassicalInstruction (classical-exclusive-or-x) classical-exclusive-or-x))))) + (define-instance (Iso QuilBinaryClassicalInstruction ClQuilBinaryClassicalInstruction))) + +(coalton-toplevel + + (define-instance (Into ClQuilMeasurement ClQuilInstruction) + (define (into measurement-m) + (lisp ClQuilInstruction (measurement-m) measurement-m))) + + (define-instance (Into ClQuilBinaryClassicalInstruction ClQuilInstruction) + (define (into classical-instruction-i) + (lisp ClQuilInstruction (classical-instruction-i) classical-instruction-i))) + + (define-type QuilInstruction + (QuilGateApplication QuilGateApplication) + (QuilMeasurement QuilMeasurement) + (QuilBinaryClassicalInstruction QuilBinaryClassicalInstruction) + (QuilPragma QuilPragma) + (QuilHalt QuilHalt)) + + (define-instance (Into ClQuilInstruction QuilInstruction) + (define (into instruction-i) + (lisp QuilInstruction (instruction-i) + (adt:match cl-quil:instruction instruction-i + ((cl-quil:gate-application) + (coalton (QuilGateApplication (lisp QuilGateApplication () instruction-i)))) + ((cl-quil:measurement) + (coalton (QuilMeasurement (into (lisp ClQuilMeasurement () instruction-i))))) + ((cl-quil:binary-classical-instruction) + (coalton (QuilBinaryClassicalInstruction (into (lisp ClQuilBinaryClassicalInstruction () instruction-i))))) + ((cl-quil:pragma) + (coalton (QuilPragma (lisp QuilPragma () instruction-i)))) + ((cl-quil:halt) + (coalton (QuilHalt (lisp QuilHalt () instruction-i)))) + (_ (coalton (error "Unexpected cl-quil:instruction. + +Must be in {cl-quil:gate-application, cl-quil:measurement, cl-quil:binary-classical-instruction, cl-quil:pragma, cl-quil:halt}."))))))) + (define-instance (Into QuilInstruction ClQuilInstruction) + (define (into instruction-i) + (match instruction-i + ((QuilGateApplication gate-application-g) + (lisp ClQuilInstruction (gate-application-g) gate-application-g)) + ((QuilMeasurement measurement-m) + (into (as ClQuilMeasurement measurement-m))) + ((QuilBinaryClassicalInstruction classical-instruction-i) + (into (as ClQuilBinaryClassicalInstruction classical-instruction-i))) + ((QuilPragma pragma-p) + (lisp ClQuilInstruction (pragma-p) pragma-p)) + ((QuilHalt halt-h) + (lisp ClQuilInstruction (halt-h) halt-h))))) + (define-instance (Iso QuilInstruction ClQuilInstruction))) + +(coalton-toplevel + + (define-type QuilOperatorDescription + (QuilNamedOperator QuilNamedOperator) + (QuilDaggerOperator QuilDaggerOperator)) + + (define-instance (into ClQuilOperatorDescription QuilOperatorDescription) + (define (into operator-description-o) + (lisp QuilOperatorDescription (operator-description-o) + (adt:match cl-quil:operator-description operator-description-o + ((cl-quil:named-operator) + (coalton (QuilNamedOperator (lisp QuilNamedOperator () operator-description-o)))) + ((cl-quil:dagger-operator) + (coalton (QuilDaggerOperator (lisp QuilDaggerOperator () operator-description-o)))) + (_ (coalton (error "Unexpected cl-quil:operator-description. + +Must be in {cl-quil:named-operator, cl-quil:dagger-operator}."))))))) + (define-instance (into QuilOperatorDescription ClQuilOperatorDescription) + (define (into operator-description-o) + (match operator-description-o + ((QuilNamedOperator named-operator-o) + (lisp ClQuilOperatorDescription (named-operator-o) named-operator-o)) + ((QuilDaggerOperator dagger-operator-o) + (lisp ClQuilOperatorDescription (dagger-operator-o) dagger-operator-o))))) + (define-instance (iso QuilOperatorDescription ClQuilOperatorDescription))) + +(coalton-toplevel + + (define-type QuilExecutableCode (QuilExecutableCode (List QuilInstruction))) + (define-instance (Into ClQuilExecutableCode QuilExecutableCode) + (define (into cl-executable-code-c) + (QuilExecutableCode + (map into (lisp (List ClQuilInstruction) (cl-executable-code-c) + (cl:coerce cl-executable-code-c 'cl:list)))))) + (define-instance (Into QuilExecutableCode ClQuilExecutableCode) + (define (into (QuilExecutableCode executable-code-c)) + (let ((cl-instructions (map (as ClQuilInstruction) executable-code-c))) + (lisp ClQuilExecutableCode (cl-instructions) + (cl:coerce cl-instructions 'cl:vector))))) + (define-instance (Iso QuilExecutableCode ClQuilExecutableCode))) + +(coalton-toplevel + + (declare parse-quil (String -> QuilParsedProgram)) + (define (parse-quil quil-string) + "Parse Quil code, given as a `String`, into a `QuilParsedProgram`." + (lisp QuilParsedProgram (quil-string) + (cl-quil:parse-quil quil-string))) + + (declare parse-file (coalton-library/file:Pathname -> QuilParsedProgram)) + (define (parse-file file) + "Parse a file, such as a `.qasm` file, to a `QuilParsedProgram`." + (let ((file-string (unwrap (coalton-library/file:read-file-to-string file)))) + (lisp QuilParsedProgram (file file-string) + (cl-quil:parse file-string :originating-file file))))) + +(coalton-toplevel + + (define-instance (Eq QuilParsedProgram) + (define (== pp1 pp2) + (lisp Boolean (pp1 pp2) + (cl-quil::matrix-equals-dwim + (cl-quil:parsed-program-to-logical-matrix pp1 :compress-qubits cl:t) + (cl-quil:parsed-program-to-logical-matrix pp2 :compress-qubits cl:t))))) + + (declare copy-parsed-program (QuilParsedProgram -> QuilParsedProgram)) + (define (copy-parsed-program pp) + "Copy a `QuilParsedProgram` object." + (lisp QuilParsedProgram (pp) + (cl-quil:copy-instance pp))) + + (declare print-parsed-program (QuilParsedProgram -> QuilParsedProgram)) + (define (print-parsed-program pp) + "Print a `QuilParsedProgram`." + (lisp QuilParsedProgram (pp) + (cl:progn (cl-quil:print-parsed-program pp) + pp))) + + (declare get-parsed-program-final-rewiring (QuilParsedProgram -> QuilRewiring)) + (define (get-parsed-program-final-rewiring pp) + "Get the exit `QuilRewiring` from `pp`." + (lisp QuilRewiring (pp) + (cl:loop :for instr :across (cl-quil:parsed-program-executable-code pp) + :do (cl:let ((exit (cl:nth-value 1 (cl-quil:instruction-rewirings instr)))) + (cl:if exit (cl:return exit)))))) + + (declare get-parsed-program-memory-definitions (QuilParsedProgram -> (List QuilMemoryDescriptor))) + (define (get-parsed-program-memory-definitions pp) + "Get the memory definitions of `pp`." + (lisp (List QuilMemoryDescriptor) (pp) + (cl-quil:parsed-program-memory-definitions pp))) + + (declare set-parsed-program-memory-definitions! (QuilParsedProgram -> (List QuilMemoryDescriptor) -> QuilParsedProgram)) + (define (set-parsed-program-memory-definitions! pp ds) + "Set the memory definitions of `pp` to `ds`." + (lisp QuilParsedProgram (pp ds) + (cl:progn (cl:setf (cl-quil:parsed-program-memory-definitions pp) ds) + pp))) + + (declare map-parsed-program-memory-definitions! + (((List QuilMemoryDescriptor) -> (List QuilMemoryDescriptor)) -> QuilParsedProgram -> QuilParsedProgram)) + (define (map-parsed-program-memory-definitions! f pp) + "Map the memory definitions of `pp` over `f`." + (pipe (f (get-parsed-program-memory-definitions pp)) + (set-parsed-program-memory-definitions! pp))) + + (declare get-parsed-program-executable-code (QuilParsedProgram -> QuilExecutableCode)) + (define (get-parsed-program-executable-code pp) + "Get the `QuilExecutableCode` of `pp`." + (into + (lisp ClQuilExecutableCode (pp) + (cl-quil:parsed-program-executable-code pp)))) + + (declare set-parsed-program-executable-code! (QuilExecutableCode -> QuilParsedProgram -> QuilParsedProgram)) + (define (set-parsed-program-executable-code! executable-code-c pp) + "Set the `QuilExecutableCode` of `pp`." + (let ((cl-executable-code-c (as ClQuilExecutableCode executable-code-c))) + (lisp QuilParsedProgram (pp cl-executable-code-c) + (cl:progn (cl:setf (cl-quil:parsed-program-executable-code pp) + cl-executable-code-c) + pp))))) + +(coalton-toplevel + + (declare get-quil-gate-application-qubits (QuilGateApplication -> (List UFix))) + (define (get-quil-gate-application-qubits gate-application-g) + "Get the `List` of qubits to which `gate-application-g` applies." + (lisp (List UFix) (gate-application-g) + (cl:map 'cl:list 'cl-quil:qubit-index (cl-quil:application-arguments gate-application-g)))) + + (declare get-quil-gate-application-angle (QuilGateApplication -> Fraction)) + (define (get-quil-gate-application-angle gate-application-g) + "Unsafe! Get the angle which parameterizes `gate-application-g`; for rotation gates only. + +The result will be a `Fraction` in [0,1) which corresponds to revolutions." + (lisp Fraction (gate-application-g) + (cl:rationalize + (cl:/ (cl-quil:constant-value (cl:first (cl-quil:application-parameters gate-application-g))) 2 cl:pi))))) + +(coalton-toplevel + + (declare get-quil-measure-qubit (QuilMeasure -> UFix)) + (define (get-quil-measure-qubit measure-m) + "Get the qubit index measured by `measure-m`." + (lisp UFix (measure-m) + (cl-quil:qubit-index + (cl-quil:measurement-qubit measure-m)))) + + (declare get-quil-measure-discard-qubit (QuilMeasureDiscard -> UFix)) + (define (get-quil-measure-discard-qubit measure-discard-m) + "Get the qubit index measured by `measure-discard-m`." + (lisp UFix (measure-discard-m) + (cl-quil:qubit-index + (cl-quil:measurement-qubit measure-discard-m)))) + + (declare get-quil-measurement-qubit (QuilMeasurement -> UFix)) + (define (get-quil-measurement-qubit measurement-m) + "Get the qubit index measured by `measurement-m`." + (match measurement-m + ((QuilMeasure measure-m) + (get-quil-measure-qubit measure-m)) + ((QuilMeasureDiscard measure-discard-m) + (get-quil-measure-discard-qubit measure-discard-m)))) + + (declare get-quil-measure-address (QuilMeasure -> QuilMemoryRef)) + (define (get-quil-measure-address measure-m) + "Get the address to which `measure-m` writes a bit." + (lisp QuilMemoryRef (measure-m) + (cl-quil:measure-address measure-m))) + + (declare get-quil-measurement-address (QuilMeasurement -> (Optional QuilMemoryRef))) + (define (get-quil-measurement-address measurement-m) + "If `measurement-m` is a `QuilMeasure`, then get the address to which it writes a bit." + (match measurement-m + ((QuilMeasure measure-m) + (Some (get-quil-measure-address measure-m))) + ((QuilMeasureDiscard _) + None)))) + +(coalton-toplevel + + (declare get-quil-operator-description (QuilGateApplication -> QuilOperatorDescription)) + (define (get-quil-operator-description gate-application-g) + "Get the `operator-description` of a `gate-application`." + (lisp QuilOperatorDescription (gate-application-g) + (cl:let ((operator-description-o (cl-quil:application-operator gate-application-g))) + (adt:match cl-quil:operator-description operator-description-o + ((cl-quil:named-operator) + (coalton (QuilNamedOperator (lisp QuilNamedOperator () operator-description-o)))) + ((cl-quil:dagger-operator) + (coalton (QuilDaggerOperator (lisp QuilDaggerOperator () operator-description-o)))) + (_ (coalton (error "Unexpected cl-quil:operator-description. + +Must be in {cl-quil:named-operator, cl-quil:dagger-operator}."))))))) + + (declare get-quil-named-operator-name (QuilNamedOperator -> String)) + (define (get-quil-named-operator-name named-operator-o) + "Get the name of `named-operator-o`." + (lisp String (named-operator-o) + (adt:match cl-quil:operator-description named-operator-o + ((cl-quil:named-operator s) s) + (_ (coalton (error "QuilNamedOperator does not have a name.")))))) + + (declare get-quil-dagger-operator-operator (QuilDaggerOperator -> QuilOperatorDescription)) + (define (get-quil-dagger-operator-operator dagger-operator-o) + "Get the `operator-description` which is modified by `dagger-operator`." + (lisp QuilOperatorDescription (dagger-operator-o) + (adt:match cl-quil:operator-description dagger-operator-o + ((cl-quil:dagger-operator operator-description-o) + (adt:match cl-quil:operator-description operator-description-o + ((cl-quil:named-operator) + (coalton (QuilNamedOperator (lisp QuilNamedOperator () operator-description-o)))) + ((cl-quil:dagger-operator) + (coalton (QuilDaggerOperator (lisp QuilDaggerOperator () operator-description-o)))) + (_ (coalton (error "Unexpected cl-quil:operator-description. + +Must be in {cl-quil:named-operator, cl-quil:dagger-operator}."))))) + (_ (coalton (error "Bad Operator"))))))) + +(coalton-toplevel + + (declare make-quil-gate-application (Boolean -> String -> (List Double-Float) -> (List UFix) -> QuilGateApplication)) + (define (make-quil-gate-application dag? name args qubits) + "Make a `QuilGateApplication` from the supplied parameters." + (if dag? + (lisp QuilGateApplication (name args qubits) + (cl:apply #'cl-quil:build-gate (cl-quil:dagger-operator (cl-quil:named-operator name)) args qubits)) + (lisp QuilGateApplication (name args qubits) + (cl:apply #'cl-quil:build-gate name args qubits)))) + + (declare make-quil-measurement ((Optional QuilMemoryRef) -> UFix -> QuilMeasurement)) + (define (make-quil-measurement wrapped-memory-ref index-q) + "Make a `QuilMeasurement` from the supplied parameters, discarding if no address is supplied." + (match wrapped-memory-ref + ((Some memory-ref) + (QuilMeasure + (lisp QuilMeasure (memory-ref index-q) + (cl:make-instance 'cl-quil:measure + :address memory-ref + :qubit (cl-quil:qubit index-q))))) + ((None) + (QuilMeasureDiscard + (lisp QuilMeasureDiscard (index-q) + (cl:make-instance 'cl-quil:measure-discard + :qubit (cl-quil:qubit index-q))))))) + + (declare make-quil-classical-move (QuilMemoryRef -> UFix -> QuilClassicalMove)) + (define (make-quil-classical-move address bit) + "Make a `QuilClassicalMove` from the supplied parameters." + (lisp QuilClassicalMove (address bit) + (cl:make-instance 'cl-quil:classical-move + :left address + :right (cl-quil:constant bit cl-quil:quil-bit)))) + + (declare make-quil-classical-exclusive-or (QuilMemoryRef -> QuilMemoryRef -> QuilClassicalExclusiveOr)) + (define (make-quil-classical-exclusive-or left-address right-address) + "Make a `QuilClassicalExclusiveOr` from the supplied parameters." + (lisp QuilClassicalExclusiveOr (left-address right-address) + (cl:make-instance 'cl-quil:classical-exclusive-or + :left left-address + :right right-address))) + + (declare make-quil-memory-descriptor (String -> UFix -> QuilMemoryDescriptor)) + (define (make-quil-memory-descriptor name size) + "Make a QuilMemoryDescriptor called `name` of size `size`. The descriptor will be of type `cl-quil:quil-bit`." + (lisp QuilMemoryDescriptor (name size) + (cl-quil:make-memory-descriptor :name name + :type cl-quil:quil-bit + :length size))) + + (declare make-quil-memory-ref (QuilMemoryDescriptor -> UFix -> QuilMemoryRef)) + (define (make-quil-memory-ref memory-ref-r idx) + "Make a new `QuilMemoryRef` for `idx` in register `memory-ref-r`." + (lisp QuilMemoryRef (memory-ref-r idx) + (cl-quil:mref (cl-quil:memory-descriptor-name memory-ref-r) idx memory-ref-r)))) + +(coalton-toplevel + + (declare compiler-hook (QuilParsedProgram -> QuilChipSpecification -> Boolean -> Boolean + -> (Tuple3 QuilParsedProgram UFix Fraction))) + (define (compiler-hook parsed-program chip-specification protoquil? destructive?) + "Compile `parsed-program` to the given `chip-specification`." + (lisp (Tuple3 QuilParsedProgram UFix Fraction) (parsed-program chip-specification protoquil? destructive?) + (cl:let ((cl-user:*muffled-warnings* cl:t)) + (cl:multiple-value-bind (cpp swaps duration) + (cl-quil:compiler-hook parsed-program chip-specification + :protoquil protoquil? :destructive destructive?) + (Tuple3 cpp swaps duration)))))) + +(coalton-toplevel + + (declare map-from-links ((List (List UFix)) -> (map:Map UFix (tree:Tree UFix)))) + (define (map-from-links links) + "Construct a `Map` representing the graph given by a list of edges called `links`." + (let ((expanded-links (concatmap + (fn (link) + (match link + ((Cons qi (Cons qj (Nil))) + (make-list (Tuple qi qj) (Tuple qj qi))) + (_ (error "Unnexpected link.")))) + links))) + (fold (fn (link-map (Tuple from to)) + (unwrap (map:update (flip tree:insert-or-replace to) link-map from))) + (map:collect (map (compose (pair-with (const tree:Empty)) fst) expanded-links)) + expanded-links))) + + (declare get-chip-specification-links (QuilChipSpecification -> (map:Map UFix (tree:Tree UFix)))) + (define (get-chip-specification-links chip-spec) + "Construct a `Map` from qubit indices to `Tree`s of qubit indices, representing the connectivity from a `QuilChipSpecification`." + (map-from-links + (lisp (List (List UFix)) (chip-spec) + (cl:map 'cl:list + (cl:lambda (link) + (cl:coerce (cl-quil::vnth 0 (cl-quil::hardware-object-cxns link)) 'cl:list)) + (cl-quil::chip-spec-links chip-spec))))) + + (declare build-IBM-Qx5 (Unit -> QuilChipSpecification)) + (define (build-IBM-Qx5) + "Construct a `QuilChipSpecification` corresponding to the specifications of the IBM Qx5 chip." + (lisp QuilChipSpecification () (cl-quil::build-IBM-Qx5))) + + (declare build-nQ-fully-connected-chip (UFix -> (List String) -> QuilChipSpecification)) + (define (build-nQ-fully-connected-chip n architecture) + "Construct a `QuilChipSpecification` for a chip with fully connected qubits with the architecture specified." + (lisp QuilChipSpecification (n architecture) + (cl-quil::build-nQ-fully-connected-chip + n + :architecture (cl:map 'cl:list #'cl:read-from-string architecture)))) + + (declare parse-gate-information ((List (Tuple3 String (List String) (List String))) -> QuilGateInformation)) + (define (parse-gate-information gates) + "Parse `QuilGateInformation` given in the form (Tuple3 operator (List parameter) (List argument)). + +E.g., (Tuple3 \"RZ\" (singleton \"_\") (singleton \"_\"))." + (let ((gates-field + (map (fn ((Tuple3 operator parameters arguments)) + (lisp :gates-entry (operator parameters arguments) + (cl:let ((gate-hash (cl:make-hash-table :test #'cl:equalp))) + (cl:setf (cl:gethash "operator" gate-hash) operator) + (cl:setf (cl:gethash "parameters" gate-hash) parameters) + (cl:setf (cl:gethash "arguments" gate-hash) arguments) + gate-hash))) + gates))) + (lisp QuilGateInformation (gates-field) + (cl-quil::parse-gates-field gates-field)))) + + (declare build-nQ-fully-connected-chip2 (UFix -> QuilGateInformation -> (List String) -> QuilChipSpecification)) + (define (build-nQ-fully-connected-chip2 n gate-information architecture) + "Construct a `QuilChipSpecification` for a chip with fully connected qubits with the single-qubit gates + +and the architecture specified." + (lisp QuilChipSpecification (n gate-information architecture) + ;; The following block of code is adapted directly from the original implementation + ;; of cl-quil::build-nQ-fully-connected-chip in the file /quilc/src/chip/chip-specification.lisp. + (cl:let ((architecture (cl:map 'cl:list #'cl:read-from-string architecture)) + (chip-spec + (cl-quil::make-chip-specification :generic-rewriting-rules (cl:coerce (cl-quil::global-rewriting-rules) 'cl:vector)))) + (cl-quil::install-generic-compilers chip-spec architecture) + ;; prep the qubits + (cl:loop :for q :below n + :do (cl-quil::adjoin-hardware-object (cl-quil::build-qubit q :gate-information gate-information) chip-spec)) + ;; prep the links + (cl:dotimes (i n) + (cl:dotimes (j i) + (cl-quil::install-link-onto-chip chip-spec j i :architecture architecture))) + (cl-quil::warm-hardware-objects chip-spec))))) + + +(coalton-toplevel + + (declare get-quil-rewiring-l2p (QuilRewiring -> (List UFix))) + (define (get-quil-rewiring-l2p rewiring) + "Get the logical-to-physical qubit map from `rewiring`." + (lisp (List UFix) (rewiring) + (cl:coerce (cl-quil:rewiring-l2p rewiring) 'cl:list))) + + (declare get-quil-rewiring-p2l (QuilRewiring -> (List UFix))) + (define (get-quil-rewiring-p2l rewiring) + "Get the physical-to-logical qubit map from `rewiring`." + (lisp (List UFix) (rewiring) + (cl:coerce (cl-quil:rewiring-p2l rewiring) 'cl:list)))) diff --git a/src/foust/README.md b/src/foust/README.md new file mode 100644 index 000000000..9f8650478 --- /dev/null +++ b/src/foust/README.md @@ -0,0 +1,295 @@ +# Foust + +Foust is an optimization pass for quantum compilers, written in Coalton, and based on [Intel's PCOAST](https://arxiv.org/abs/2305.10966). + +Foust takes advantage of properties of the Clifford group as the _normalizer_ of the Pauli group by representing all non-Clifford gates in terms of tensor products of Pauli operators or an anticommuting pair thereof. A preserving Foust guarantees that the final quantum state of the output circuit is equivalent to that of the input circuit. A releasing Foust applies more aggressive optimizations while only guaranteeing that measurement statistics are preserved. + +## Getting Started + +First, [install Coalton](https://github.com/coalton-lang/coalton). Then execute the following command to install other dependencies and load Foust: + +``` lisp +(ql:quickload "cl-quil/foust") +``` + +To run the tests, execute: + +``` lisp +(asdf:test-system "cl-quil/foust") +``` + +## Method + +### Hermitian Paulis + +Foust will express every gate that is not a single- or two-qubit Clifford gate in terms of one or two Hermitian Paulis. Here, the term Hermitian Pauli refers to any unitary of the form + +```math + \mathbf{P}=\pm P_{n-1}\otimes P_{n-2}\cdots\otimes P_2\otimes P_1\otimes P_0, + ``` + + where $`P_i\in\{I,X,Y,Z\}`$ and $`n`$ describes the number of qubits spanned by the relevant Hilbert space. More concretely, the Hermitian Paulis make up the subgroup of the Pauli group whose elements have a phase of $`\pm 1`$. + + The group operation the closes the subgroup of Hermitian Paulis is a special product defined as, + + ```math + \left(\mathbf{P}_1,\mathbf{P}_2\right)= + \begin{cases} +\mathbf{P}_1\mathbf{P}_2 & [\mathbf{P}_1,\mathbf{P}_2]=0\\ +-i\mathbf{P}_1\mathbf{P}_2 & \{\mathbf{P}_1,\mathbf{P}_2\}=0 + \end{cases}, + ``` + +where $`\mathbf{P}_1`$ and $`\mathbf{P}_2`$ are elements of the subgroup of Hermitian Paulis and the operators $`[\cdot,\cdot]`$ and $`\{\cdot,\cdot\}`$ are the commutator and anti-commutator respectively. This definition is complete, as all members of the Pauli group, and, by extension, of the subgroup of Hermitian Paulis, either commute or anti-commute with the others. + +### Clifford Frames + +All gates which are Clifford gates will be expressed by Foust in terms of Clifford Frames [1]. Clifford Frames are also called stabilizer tableaus or sometimes Pauli tableaus, and they arise from the fact that the Clifford group is the normalizer of the Pauli group, and also of the subgroup of Hermitian Paulis. Equivalently, + +```math +\mathbf{U}^\dag\mathbf{P}\mathbf{U}=\mathbf{P}', +``` + +where $`\mathbf{U}`$ is an element of the Clifford group and $`\mathbf{P}`$ and $`\mathbf{P}'`$ are Hermitian Paulis. Since the Hermitian Paulis are spanned by the set of single-qubit Pauli operators $`\{Z_i, X_i\mid0\le i < n\}`$, then every member $`\mathbf{U}`$ of the Clifford group is uniquely determined by the map, + +```math +i\mapsto\left(\mathbf{U}^\dag Z_i\mathbf{U},\mathbf{U}^\dag X_i\mathbf{U}\right), +``` +where, once again, $`n`$ describes the number of qubits spanned by the relevant Hilbert space. This map encodes the effect of "pushing" a Clifford operator past a Pauli operator. I.e., if a Clifford operator appears upstream by a Pauli operator, e.g., $`\mathbf{P}\mathbf{U}`$, then the map above describes how to transform $`\mathbf{P}\to\mathbf{P}'`$ such that $`\mathbf{P}\mathbf{U}=\mathbf{U}\mathbf{P}'`$. Foust likes to push Clifford operators downstream, and, therefore, this representation is ideal for efficiency. + +### The Gate Set + +Foust will interpret all elements of a circuit as one of six elements [1]. These elements include single-axis and bi-axial rotations, preparations, measurements, Clifford gates (Frames), and classical assignments. + +Single axis rotations are defined in terms of a single Hermitian Pauli as, + +$$\operatorname{Rot}\left(\mathbf{P},\theta\right)=\exp\left(-i\frac{\theta}{2}\mathbf{P}\right).$$ + +Bi-axial rotations are defined in terms of a pair of anti-commuting Hermitian Paulis as, +$$\operatorname{Rot}_2\left(\mathbf{P},\mathbf{Q},\theta,\varphi\right)=\exp\left(-i\frac{\theta}{2}\left(\cos(\varphi)\mathbf{P}+\sin(\varphi)\mathbf{Q}\right)\right).$$ + +Measurements are defined in terms of a single Hermitian Pauli as +$$\operatorname{Meas}\left(\mathbf{P}\rightarrow c\right),$$ +collapsing a quantum state to the $`+1`$ or $`-1`$ eigenstate of the operator $`\mathbf{P}`$ and storing $`0`$ or $`1`$ in the classical variable $`c`$, respectively. + +Preparations are defined in terms of a pair of anti-commuting Hermitian Paulis as, +$$\operatorname{Prep}\left(\mathbf{P},\mathbf{Q}\right),$$ +equivalent to the sequence, +$$\operatorname{Meas}\left(\mathbf{P}\rightarrow c\right);\text{ if } c=1\text{, then apply }\operatorname{Rot}\left(\mathbf{P},\pi\right);\text{ discard }c.$$ + +Frames have already been described, and classical assignments are nothing more than a series of classical instructions, manipulating the stored values of classical binary variables. + +### Two-Qubit Entangling Gates (TQEs) + +The Clifford gates in a Fousted circuit include arbitary single-qubit Clifford gates, of which there are twenty-four, and two-qubit entangling gates. These two-qubit entangling gates (TQEs) are extensions of the gates of the same name presented in [1], extended with insights from [3] to generalize to arbitrary architectures. TQEs, as presented in [1], are generalized $`\operatorname{CNOT}`$ gates, defined by two non-identity Pauli operators, $`P_i`$ and $`P_j`$. A TQE is interpretted accordingly as the operation $`P_j`$ controlled on the qubits being in a negative eigenstate of the operator $`P_i`$, and, symmetrically, as the operation $`P_i`$ controlled on the qubits being in a negative eigenstate of the operator $`P_j`$. Accordingly, the gate $`\operatorname{CNOT}_{ij}`$ is equivalent to to the gate $`\operatorname{TQE}Z_iX_j`$. Altogether, there are nine TQEs of this form. + +Foust extends this notion of TQEs with a boolean, `True` or `False`, answering the question "then swap?" There are eighteen TQEs of this form. Any two-qubit Clifford gate capable of producing entanglement is conjugable to one of these eighteen gates by at most two single-qubit Clifford gates [3]. This extension is necessary for Foust to optimize to architectures which perform $`\operatorname{ISWAP}`$ operations, or similar operations, which are not trivially conjugable to other entangling gates including $`\operatorname{CNOT}`$ and $`\operatorname{CZ}`$ gates. + +### Foust Graphs + +With few exceptions, Foust's optimizations are accomplished by compiling a circuit to a graph and back to a circuit. These foust graphs have several notable properties. First, they consist only of the elements described in the preceding section. Next, with few exceptions, they store only a single frame and a single set of assignments, and these will always be pushed downstream to the end of the graph. Lastly, edges are drawn from upstream to downstream nodes if and only if the nodes do not commute with one another. + +### The Search Algorithm + +Most of the computation during the optimization occurs in the process of compiling from a graph back to a circuit. This is because the resulting circuit should have only gates which operate on a single qubit, with the exception of two-qubit entangling gates. In order to accomplish this compilation, elements have to be reduced to ones considered "free". For example, a single qubit rotation is "free", but a two-qubit rotation has a cost of $`1`$ because it will take exactly one two-qubit entangling gate to reduce it to a "free" rotation. The algorithm for reducing these various elements is described by the following simplified pseudo-code [2]. + +```lisp +(loop (process-and-remove-free-elements elements) + (reduce-cost-of-cheapest-element elements)) +``` + +Very simply, all free elements are processed, and then the cheapest element remaining is reduced. This is repeated until all elements are processed. Here, a processed element can mean a single-qubit gate added to a circuit or a row of a Clifford Frame interpretted as a single-qubit Clifford operator. It also can mean a single-qubit measurement added to a circuit, chosen to span remaining commuting terminal measurements in a subroutine of the aggressive releasing Foust optimization. + +## Benchmarking + +To run benchmarks, execute the following commands (assuming all dependencies have been installed): + +``` lisp +> (asdf:load-system "cl-quil-benchmarking/foust") +> (cl-quil-benchmarking.foust:cl-foust-benchmark-qasm-suite) +``` + +The following benchmark was generated on a MacBook Pro, 2020, with a 2.3 GHz Quad-Core Intel Core i7 processor and 16 GB 3744 MHz of memory. It was completed on September 24, 2024, with SBCL, and with Coalton compiled in Release mode. The `timeout` for each of the five steps per file was set to two minutes. + +`WITHOUT FOUST` corresponds to the sequence, `parse file -> compile to chip`. + +`WITH NAIVE FOUST` corresponds to the sequence, `parse file -> preserving Foust without knowledge of connectivity -> compile to chip`. + +`WITH CHIP-AWARE FOUST` corresponds to the sequence, `parse file -> preserving Foust with knowledge of connectivity -> compile to chip`. + +Under `VALIDATION`, the `Matrix?` column includes the results of computing the unitary matrices from the compilations with and without Foust and checking their equality, and the `Amplitudes?` column includes the results of simulating the compiled circuits with the intial state $\mid0\rangle$ and checking the equality of the resulting amplitudes. + +``` +┌─────────────────┬───────────────────────────┬───────────────────────────┬───────────────────────────┬──────────────────────┐ +│ │ WITHOUT FOUST │ WITH NAIVE FOUST │ WITH CHIP-AWARE FOUST │ VALIDATION │ +├─────────────────┼───────────────────────────┼───────────────────────────┼───────────────────────────┼──────────────────────┤ +│ NAME │ TIME (s) SWAPS 2Q DEPTH │ TIME (s) SWAPS 2Q DEPTH │ TIME (s) SWAPS 2Q DEPTH │ Matrix? Amplitudes? │ +├─────────────────┼───────────────────────────┼───────────────────────────┼───────────────────────────┼──────────────────────┤ +│ 0410184_169 │ 5.434993 84 254 │ 6.819166 72 262 │ 7.308465 75 277 │ ??????? YES │ +│ 3_17_13 │ 0.584091 9 30 │ 0.531976 5 17 │ 0.703073 5 17 │ YES YES │ +│ 4_49_16 │ 3.499261 70 205 │ 3.519753 31 123 │ 3.629836 29 120 │ ??????? YES │ +│ 4gt10-v1_81 │ 2.941124 48 150 │ 2.528865 21 86 │ 2.840503 22 91 │ ??????? YES │ +│ 4gt11_82 │ 1.076145 10 38 │ 0.625058 2 17 │ 0.799723 2 19 │ YES YES │ +│ 4gt11_83 │ 0.710385 9 25 │ 0.766203 3 14 │ 0.950857 3 14 │ YES YES │ +│ 4gt11_84 │ 0.534709 5 16 │ 0.577918 4 12 │ 0.751102 4 12 │ YES YES │ +│ 4gt12-v0_86 │ 3.065752 82 218 │ 4.959093 43 181 │ 4.650787 40 168 │ ??????? YES │ +│ 4gt12-v0_87 │ 2.797707 81 209 │ 4.323994 33 143 │ 4.549477 36 147 │ YES YES │ +│ 4gt12-v0_88 │ 3.512212 64 190 │ 3.070276 22 93 │ 3.307328 24 100 │ YES YES │ +│ 4gt12-v1_89 │ 4.561983 80 216 │ 3.821413 29 116 │ 3.731989 26 122 │ YES YES │ +│ 4gt13-v1_93 │ 1.724873 23 75 │ 1.356688 6 34 │ 1.595813 9 40 │ YES YES │ +│ 4gt13_90 │ 2.314276 33 106 │ 2.044489 12 51 │ 2.167138 15 53 │ ??????? YES │ +│ 4gt13_91 │ 1.957302 30 87 │ 1.941258 9 41 │ 2.360064 13 53 │ ??????? YES │ +│ 4gt13_92 │ 1.718212 18 62 │ 1.535821 8 36 │ 1.651441 8 34 │ ??????? YES │ +│ 4gt4-v0_72 │ 5.329608 81 242 │ 3.860548 32 136 │ 4.455689 33 141 │ ??????? YES │ +│ 4gt4-v0_73 │ 6.107811 146 397 │ 7.191699 50 230 │ 6.914364 52 210 │ ??????? YES │ +│ 4gt4-v0_78 │ 3.824298 80 223 │ 4.396927 34 149 │ 4.107442 35 150 │ ??????? YES │ +│ 4gt4-v0_79 │ 3.333978 84 211 │ 4.569832 41 162 │ 4.269905 41 150 │ ??????? YES │ +│ 4gt4-v0_80 │ 3.087508 65 168 │ 2.794643 25 105 │ 2.700779 29 101 │ YES YES │ +│ 4gt4-v1_74 │ 4.213719 100 273 │ 4.629115 49 188 │ 4.561379 49 176 │ ??????? YES │ +│ 4gt5_75 │ 1.894525 25 73 │ 1.789174 12 55 │ 1.838855 12 55 │ ??????? YES │ +│ 4gt5_76 │ 1.590932 27 81 │ 1.619844 11 40 │ 1.832533 10 43 │ YES YES │ +│ 4gt5_77 │ 2.459703 45 129 │ 2.597585 16 71 │ 2.233986 13 62 │ YES YES │ +│ 4mod5-bdd_287 │ 1.335535 27 64 │ 1.710778 12 48 │ 2.009443 11 50 │ YES YES │ +│ 4mod5-v0_18 │ 1.511314 21 62 │ 0.967416 4 19 │ 1.136701 4 19 │ ??????? YES │ +│ 4mod5-v0_19 │ 0.838548 12 30 │ 0.524911 2 16 │ 0.761018 3 17 │ ??????? YES │ +│ 4mod5-v0_20 │ 0.891199 6 20 │ 0.558662 1 8 │ 0.719657 1 8 │ YES YES │ +│ 4mod5-v1_22 │ 0.534318 6 15 │ 0.571506 1 9 │ 0.742357 1 9 │ YES YES │ +│ 4mod5-v1_23 │ 1.565726 26 66 │ 1.220043 9 38 │ 1.411457 7 29 │ ??????? YES │ +│ 4mod5-v1_24 │ 0.750352 11 31 │ 0.756183 6 19 │ 0.939305 6 19 │ YES YES │ +│ 4mod7-v0_94 │ 2.595309 51 143 │ 2.644835 18 82 │ 2.712855 17 79 │ ??????? YES │ +│ 4mod7-v1_96 │ 3.188251 47 147 │ 2.834817 22 99 │ 2.688376 22 78 │ ??????? YES │ +│ 9symml_195 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ C17_204 │ 7.871588 160 435 │ 7.41188d 70 290 │ 7.427954 72 287 │ ??????? YES │ +│ adr4_197 │ 78.90072 1279 3631 │ 85.71614 784 2867 │ 86.59163 752 2844 │ ??????? YES │ +│ aj-e11_165 │ 2.118564 53 144 │ 2.814403 20 87 │ 3.016477 19 93 │ ??????? YES │ +│ alu-bdd_288 │ 1.825783 31 93 │ 2.239364 13 62 │ 2.268767 9 53 │ ??????? YES │ +│ alu-v0_26 │ 1.832608 28 88 │ 1.766567 11 51 │ 2.126935 13 56 │ ??????? YES │ +│ alu-v0_27 │ 1.003823 10 29 │ 1.012316 6 26 │ 1.184181 6 26 │ YES YES │ +│ alu-v1_28 │ 0.887704 11 33 │ 1.166676 8 31 │ 1.338864 8 31 │ ??????? YES │ +│ alu-v1_29 │ 0.90041d 11 34 │ 1.037104 7 27 │ 1.219797 7 27 │ YES YES │ +│ alu-v2_30 │ 8.240795 167 482 │ 10.14291 97 397 │ 9.712682 96 377 │ ??????? YES │ +│ alu-v2_31 │ 6.323501 129 425 │ 5.170911 47 198 │ 5.616206 47 213 │ ??????? YES │ +│ alu-v2_32 │ 2.970368 48 156 │ 2.533304 24 83 │ 2.775326 24 86 │ ??????? YES │ +│ alu-v2_33 │ 0.883954 9 32 │ 1.455583 8 31 │ 1.429287 12 39 │ YES YES │ +│ alu-v3_34 │ 1.383926 18 48 │ 1.113164 8 35 │ 1.289934 8 33 │ YES YES │ +│ alu-v3_35 │ 0.757969 11 33 │ 0.891819 4 23 │ 1.077609 6 26 │ YES YES │ +│ alu-v4_36 │ 2.204023 40 99 │ 1.934736 17 65 │ 1.993952 16 58 │ ??????? YES │ +│ alu-v4_37 │ 0.944076 8 30 │ 0.882757 4 23 │ 1.071947 6 26 │ YES YES │ +│ clip_206 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ cm152a_212 │ 24.60386 456 1302 │ 22.02956 242 886 │ 20.75268 214 812 │ ??????? YES │ +│ cm42a_207 │ 35.81942 621 1749 │ 31.53656 303 1161 │ 31.58101 333 1199 │ ??????? YES │ +│ cm82a_208 │ 9.546753 234 635 │ 10.84165 114 443 │ 10.87445 122 448 │ ??????? YES │ +│ cm85a_209 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ cnt3-5_179 │ 5.097061 62 211 │ 5.412739 63 230 │ 4.792542 63 205 │ ??????? YES │ +│ cnt3-5_180 │ 10.78354 200 581 │ 11.05494 111 412 │ 11.63988 127 439 │ ??????? YES │ +│ co14_215 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ con1_216 │ 18.48109 335 994 │ 17.97559 176 691 │ 19.04326 182 734 │ ??????? YES │ +│ cycle10_2_110 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ dc1_220 │ 34.76177 699 1916 │ 31.83980 297 1161 │ 31.94121 314 1194 │ ??????? YES │ +│ dc2_222 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ decod24-bdd_294 │ 1.262529 19 67 │ 1.656618 11 47 │ 1.684842 10 40 │ ??????? YES │ +│ decod24-enable_1│ 4.700182 116 311 │ 5.868329 60 242 │ 5.605282 51 226 │ ??????? YES │ +│ decod24-v0_38 │ 0.783475 12 41 │ 0.971348 7 28 │ 1.311501 7 29 │ YES YES │ +│ decod24-v1_41 │ 1.750348 25 77 │ 1.737498 10 45 │ 2.045407 14 56 │ ??????? YES │ +│ decod24-v2_43 │ 1.080869 17 43 │ 0.999158 7 27 │ 1.186024 7 27 │ YES YES │ +│ decod24-v3_45 │ 3.253719 45 147 │ 2.495069 23 85 │ 2.571311 19 84 │ ??????? YES │ +│ dist_223 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ ex-1_166 │ 0.438912 6 15 │ 0.459111 2 10 │ 0.655752 2 10 │ YES YES │ +│ ex1_226 │ 0.653424 2 11 │ 0.578156 1 6 │ 0.745807 1 6 │ YES YES │ +│ ex2_227 │ 11.21455 228 619 │ 10.13860 91 359 │ 9.763664 85 361 │ ??????? YES │ +│ ex3_229 │ 6.432813 130 379 │ 5.369566 65 236 │ 6.431119 66 261 │ ??????? YES │ +│ f2_232 │ 20.70101 414 1203 │ 19.26006 191 748 │ 19.93907 201 773 │ ??????? YES │ +│ graycode6_47 │ 0.572593 0 5 │ 0.579443 0 5 │ 0.76122d 0 5 │ YES YES │ +│ ground_state_est│ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ ham15_107 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ ham3_102 │ 0.45215d 6 15 │ 0.460556 2 12 │ 0.634868 2 12 │ YES YES │ +│ ham7_104 │ 5.793778 107 344 │ 5.366379 52 203 │ 5.366162 54 217 │ YES YES │ +│ hwb4_49 │ 3.968223 79 221 │ 3.32519d 32 128 │ 3.752171 26 127 │ YES YES │ +│ hwb5_53 │ 22.14278 464 1342 │ 23.26987 206 808 │ 24.06706 203 838 │ ??????? YES │ +│ hwb6_56 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ hwb7_59 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ hwb8_113 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ hwb9_119 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ inc_237 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ ising_model_10 │ 2.820152 0 90 │ 3.906171 27 146 │ 3.497601 19 120 │ YES YES │ +│ ising_model_13 │ 3.651733 0 120 │ 3.943744 17 130 │ 4.069509 17 130 │ ??????? YES │ +│ ising_model_16 │ 4.520813 0 150 │ 5.813972 42 203 │ 6.003973 42 203 │ ??????? YES │ +│ life_238 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ majority_239 │ 10.48284 227 592 │ 9.896523 92 373 │ 9.368513 89 356 │ YES YES │ +│ max46_240 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ miller_11 │ 0.829021 18 42 │ 0.606117 8 27 │ 0.781736 8 27 │ YES YES │ +│ mini-alu_167 │ 5.030934 89 271 │ 4.9064d0 53 203 │ 5.238117 47 189 │ ??????? YES │ +│ mini_alu_305 │ 3.348382 67 176 │ 3.945122 35 144 │ 3.844715 34 141 │ YES YES │ +│ misex1_241 │ 116.8705 1754 5074 │ 114.9082 963 3519 │ 112.4831 933 3408 │ ??????? YES │ +│ mlp4_245 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ mod10_171 │ 3.719048 75 221 │ 4.190276 38 148 │ 4.341344 39 146 │ ??????? YES │ +│ mod10_176 │ 2.860989 55 161 │ 2.956164 24 96 │ 3.459286 26 112 │ ??????? YES │ +│ mod5adder_127 │ 10.43395 193 556 │ 9.104099 97 387 │ 9.546436 91 360 │ ??????? YES │ +│ mod5d1_63 │ 0.682147 7 22 │ 0.782448 2 13 │ 0.945044 2 13 │ YES YES │ +│ mod5d2_64 │ 1.579111 19 60 │ 1.595403 7 36 │ 1.622918 7 36 │ ??????? YES │ +│ mod5mils_65 │ 0.894053 12 36 │ 0.538619 2 16 │ 0.957025 3 20 │ YES YES │ +│ mod8-10_177 │ 6.5774d0 154 426 │ 7.021142 63 261 │ 7.385633 71 282 │ ??????? YES │ +│ mod8-10_178 │ 5.588831 122 324 │ 5.412794 59 220 │ 5.98028d 63 240 │ ??????? YES │ +│ one-two-three-v0│ 4.582656 100 266 │ 4.761999 43 171 │ 4.522265 39 161 │ ??????? YES │ +│ one-two-three-v0│ 3.058477 52 141 │ 2.33818d 19 81 │ 2.691727 16 74 │ ??????? YES │ +│ one-two-three-v1│ 2.543129 42 125 │ 2.376811 20 78 │ 2.768463 26 89 │ ??????? YES │ +│ one-two-three-v2│ 1.463773 19 65 │ 1.79979d 12 52 │ 1.575904 9 36 │ YES YES │ +│ one-two-three-v3│ 1.608093 17 69 │ 1.30194d 7 32 │ 1.432287 9 37 │ YES YES │ +│ plus63mod4096_16│ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ plus63mod8192_16│ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ pm1_249 │ 34.34187 644 1821 │ 30.45709 325 1198 │ 29.08482 281 1105 │ ??????? YES │ +│ qft_10 │ 3.427826 27 75 │ 0.35742d 0 0 │ 0.543182 0 0 │ YES YES │ +│ qft_16 │ 7.862491 73 219 │ 0.38389d 0 0 │ 0.546227 0 0 │ ??????? YES │ +│ radd_250 │ 73.01250 1185 3336 │ 74.20134 691 2543 │ 69.60619 657 2454 │ ??????? YES │ +│ rd32-v0_66 │ 0.685994 13 27 │ 0.651639 4 12 │ 0.853011 5 13 │ YES YES │ +│ rd32-v1_68 │ 0.682358 13 27 │ 0.6757d0 4 12 │ 0.854469 5 13 │ YES YES │ +│ rd32_270 │ 1.350219 29 77 │ 0.945657 5 19 │ 1.259529 6 26 │ YES YES │ +│ rd53_130 │ 17.72819 357 1017 │ 17.72945 170 690 │ 17.98085 165 685 │ ??????? YES │ +│ rd53_131 │ 7.840166 142 438 │ 5.330062 44 206 │ 6.230953 59 231 │ ??????? YES │ +│ rd53_133 │ 11.17963 188 568 │ 7.938754 61 265 │ 8.945099 71 308 │ ??????? YES │ +│ rd53_135 │ 5.189258 101 313 │ 5.297009 45 191 │ 4.829433 45 176 │ YES YES │ +│ rd53_138 │ 2.433397 42 126 │ 2.859891 27 106 │ 3.394739 25 110 │ ??????? YES │ +│ rd53_251 │ 23.45042 448 1262 │ 21.92869 191 742 │ 19.58051 176 706 │ ??????? YES │ +│ rd53_311 │ 6.427317 109 323 │ 6.296362 56 209 │ 5.833245 52 209 │ ??????? YES │ +│ rd73_140 │ 3.901325 87 229 │ 5.311533 54 206 │ 5.681796 49 200 │ YES YES │ +│ rd73_252 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ rd84_142 │ 8.619611 138 436 │ 9.378002 100 373 │ 9.750892 102 382 │ ??????? YES │ +│ rd84_253 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ root_255 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ sao2_257 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ sf_274 │ 11.89924 266 740 │ 8.409004 76 335 │ 9.546996 91 367 │ YES YES │ +│ sf_276 │ 12.11126 262 724 │ 10.80923 132 497 │ 10.70163 132 484 │ ??????? YES │ +│ sqn_258 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ sqrt8_260 │ 71.67304 1160 3376 │ 66.17784 624 2327 │ 69.4444d 700 2527 │ ??????? YES │ +│ squar5_261 │ 40.7386d 738 2053 │ 41.33606 404 1465 │ 39.24379 383 1440 │ ??????? YES │ +│ square_root_7 │ TIMEOUT! ????? ???????? │ 115.3819 868 3400 │ 118.0053 923 3686 │ ??????? ??????????? │ +│ sym10_262 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ sym6_145 │ 75.15256 1396 3853 │ 72.87222 587 2336 │ 72.04769 601 2327 │ ??????? YES │ +│ sym6_316 │ 5.531204 125 338 │ 5.457592 47 181 │ 6.057509 59 221 │ ??????? YES │ +│ sym9_146 │ 6.624973 115 335 │ 7.319453 80 302 │ 7.004103 77 293 │ ??????? YES │ +│ sym9_148 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ sym9_193 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ sys6-v0_111 │ 4.00192d 73 227 │ 4.605682 36 163 │ 5.900882 44 193 │ YES YES │ +│ urf1_149 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ urf1_278 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ urf2_152 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ urf2_277 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ urf3_155 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ urf3_279 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ urf4_187 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ urf5_158 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ urf5_280 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ urf6_160 │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ TIMEOUT! ????? ???????? │ ??????? ??????????? │ +│ wim_266 │ 18.31915 344 987 │ 16.29483 162 654 │ 16.87495 154 643 │ ??????? YES │ +│ xor5_254 │ 0.707601 2 11 │ 0.586785 1 6 │ 0.779968 1 6 │ YES YES │ +│ z4_268 │ 65.14839 1142 3243 │ 66.39029 606 2260 │ 67.48103 593 2262 │ ??????? YES │ +└─────────────────┴───────────────────────────┴───────────────────────────┴───────────────────────────┴──────────────────────┘ +``` + +## References + +[1] J. Paykin, A. T. Schmitz, M. Ibrahim, X.-C. Wu, and A. Y. Matsuura, Pcoast: A Pauli-based Quantum Circuit Optimization Framework (Extended Version) (2023), [arXiv:2305.10966v2](https://arxiv.org/abs/2305.10966v2) [quant-ph]. + +[2] A. T. Schmitz, M. Ibrahim, N. P. D. Sawaya, G. G. Guerreschi, J. Paykin, X.-C. Wu, and A. Y. Matsuura, Optimization at the Interface of Unitary and Non-unitary Quantum Operations in PCOAST (2023), [arXiv:2305.09843](https://arxiv.org/abs/2305.09843) [quant-ph]. + +[3] D. Grier and L. Schaeffer, The Classification of Clifford Gates over Qubits, Quantum 6, 734 (2022), [arXiv:1603.03999v4](https://arxiv.org/abs/1603.03999v4) [quant-ph]. diff --git a/src/foust/angle.lisp b/src/foust/angle.lisp new file mode 100644 index 000000000..e134969e2 --- /dev/null +++ b/src/foust/angle.lisp @@ -0,0 +1,84 @@ +;;;; angle.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/angle + (:documentation + "This package represents angles as `Fraction`s, in units of revolutions, i.e., θ ∈ [0,1).") + (:use + #:coalton + #:coalton-prelude) + (:import-from + #:coalton-library/math/fraction + #:numerator + #:denominator) + (:import-from + #:coalton-library/math/elementary + #:pi) + (:import-from + #:coalton-library/math/arith + #:general/) + (:import-from + #:coalton-library/math/integral + #:divmod) + (:export + #:Angle + #:Angle + #:angle-order + #:angle->radians)) + +(in-package #:cl-quil.foust/angle) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (repr :transparent) + (define-type Angle (%Angle Fraction)) + + (declare Angle (Fraction -> Angle)) + (define (Angle fraction) (%Angle (mod fraction 1))) + + (define-instance (Eq Angle) + (define (== (%Angle fraction-one) (%Angle fraction-two)) + (== fraction-one fraction-two))) + + (define-instance (Default Angle) + (define (default) (Angle 0/1))) + + (define-instance (Into Angle String) + (define (into (%Angle fraction)) + (let ((frac (* 2 fraction)) + (tnumer (numerator frac)) + (denom (denominator frac)) + (numer (if (> tnumer denom) + (- tnumer (* 2 denom)) + tnumer))) + (cond + ((== 0 numer) "0") + ((== 1 numer) (if (== 1 denom) "π" (<> "π/" (into denom)))) + ((== -1 numer) (if (== 1 denom) "-π" (<> "-π/" (into denom)))) + (True (mconcat (make-list (into numer) "π/" (into denom)))))))) + + (define-instance (Num Angle) + (define (+ (%Angle fraction-one) (%Angle fraction-two)) + (Angle (+ fraction-one fraction-two))) + (define (- (%Angle fraction-one) (%Angle fraction-two)) + (Angle (- fraction-one fraction-two))) + (define (* (%Angle fraction-one) (%Angle fraction-two)) + (Angle (* fraction-one fraction-two))) + (define fromInt (const (default)))) + + (declare angle-order (Angle -> (Optional UFix))) + (define (angle-order (%Angle fraction)) + "If an `Angle` is an integer `n` multiple of `π/4`, return `(Some n)`, otherwise `None`." + (match (divmod fraction 1/4) + ((Tuple order x) + (if (== 0 x) (Some (unwrap (tryInto (numerator order)))) None))))) + +(coalton-toplevel + + (declare angle->radians (Angle -> Double-Float)) + (define (angle->radians (%Angle theta)) + "Convert revolution units stored in an `Angle` object, to a `Double-Float` in radian units." + (product (make-list 2 pi (general/ (numerator theta) (denominator theta)))))) diff --git a/src/foust/assignments.lisp b/src/foust/assignments.lisp new file mode 100644 index 000000000..25c8049a3 --- /dev/null +++ b/src/foust/assignments.lisp @@ -0,0 +1,205 @@ +;;;; assignments.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/assignments + (:documentation + "This package defines classical expressions and represents classical instructions as `List`s of assignments, + +storing the first and the next fresh variables.") + (:use + #:coalton + #:coalton-prelude) + (:local-nicknames + (#:iter #:coalton-library/iterator) + (#:list #:coalton-library/list) + (#:map #:coalton-library/ord-map)) + (:export #:ClassicalExpression + #:ClassicalBit + #:ClassicalVariable + #:get-classical-expression-variables + #:get-classical-expression-bit + #:classical-bit-flip + #:classical-xor + #:Assignments + #:get-assignments-instructions + #:get-assignments-first-fresh-index + #:get-assignments-next-fresh-index + #:null-assignments + #:assignments-compose + #:assignments-increment + #:assign-fresh + #:add-instruction + #:simplify-assignments)) + +(in-package #:cl-quil.foust/assignments) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-type ClassicalExpression + "Represent a classical expression as a `List` of bit variables to be summed together with a constant bit. + +A `ClassicalExpression` is designed to represent expressions which evaluate to one bit." + (ClassicalExpression (List UFix) Boolean)) + + (declare ClassicalBit (Boolean -> ClassicalExpression)) + (define (ClassicalBit b) (ClassicalExpression Nil b)) + + (declare ClassicalVariable (UFix -> ClassicalExpression)) + (define (ClassicalVariable v) (ClassicalExpression (singleton v) False)) + + (declare get-classical-expression-variables (ClassicalExpression -> (List UFix))) + (define (get-classical-expression-variables (ClassicalExpression vs _ )) vs) + + (declare get-classical-expression-bit (ClassicalExpression -> Boolean)) + (define (get-classical-expression-bit (ClassicalExpression _ b)) b) + + (define-instance (Default ClassicalExpression) + (define (default) (ClassicalExpression Nil False))) + + (define-instance (Eq ClassicalExpression) + (define (== (ClassicalExpression vs-one b-one) (ClassicalExpression vs-two b-two)) + (and (== b-one b-two) (== (list:sort vs-one) (list:sort vs-two))))) + + (declare classical-bit-flip (ClassicalExpression -> ClassicalExpression)) + (define (classical-bit-flip (ClassicalExpression vs b)) + "Take a `ClassicalExpression` and return a new one with the bit flipped." + (ClassicalExpression vs (not b))) + + (declare classical-xor (ClassicalExpression -> ClassicalExpression -> ClassicalExpression)) + (define (classical-xor (ClassicalExpression vs-one b-one) (ClassicalExpression vs-two b-two)) + "Take two `ClassicalExpression`s and return the result of combining them with XOR." + (ClassicalExpression (list:difference (list:union vs-one vs-two) + (list:intersection vs-one vs-two)) + (boolean-xor b-one b-two))) + + (define-instance (Semigroup ClassicalExpression) + (define <> classical-xor)) + + (define-instance (Monoid ClassicalExpression) + (define mempty (default))) + + (define-instance (Into ClassicalExpression String) + (define (into (ClassicalExpression vs b)) + (if (list:null? vs) + (if b "1" "0") + ((if b (flip <> " + 1") id) + (mconcat (Cons "c" (list:intersperse " + c" (map into (list:sort vs)))))))))) + +(coalton-toplevel + + (define-type Assignments + "`Assignment`s store a list of classical instructions: var <- expression. The head of the `List` + +is the last instruction. The two `UFix`s correspond to: + +The first fresh index, i.e., the first index which is not user-defined. + +All variable IDs below this value correspond to user-defined variables + +as provided in a circuit input to Foust. + +The next fresh index, i.e., all values at or above this index are guaranteed + +not to have been used in preceeding instructions." + (Assignments (List (Tuple UFix ClassicalExpression)) UFix UFix)) + + (declare get-assignments-instructions (Assignments -> (List (Tuple UFix ClassicalExpression)))) + (define (get-assignments-instructions (Assignments instructions _ _)) instructions) + + (declare get-assignments-first-fresh-index (Assignments -> UFix)) + (define (get-assignments-first-fresh-index (Assignments _ first-fresh-index _)) first-fresh-index) + + (declare get-assignments-next-fresh-index (Assignments -> UFix)) + (define (get-assignments-next-fresh-index (Assignments _ _ next-fresh-index)) next-fresh-index) + + (define-instance (Default Assignments) + (define (default) (Assignments Nil 0 0))) + + (define-instance (Eq Assignments) + (define (== (Assignments instructions-one first-fresh-index-one next-fresh-index-one) + (Assignments instructions-two first-fresh-index-two next-fresh-index-two)) + (and (== instructions-one instructions-two) + (== first-fresh-index-one first-fresh-index-two) + (== next-fresh-index-one next-fresh-index-two)))) + + (declare null-assignments (UFix -> Assignments)) + (define (null-assignments fresh-index) + "Create an empty `Assignments` with the first and next fresh indices set." + (Assignments Nil fresh-index fresh-index)) + + + (declare assignments-compose (Assignments -> Assignments -> Assignments)) + (define (Assignments-compose (Assignments instructions-two first-fresh-index-two next-fresh-index-two) + (Assignments instructions-one first-fresh-index-one next-fresh-index-one)) + "Concatenate two `Assignments`." + (Assignments (list:append instructions-two instructions-one) + (max first-fresh-index-one first-fresh-index-two) + (max next-fresh-index-one next-fresh-index-two))) + + (define-instance (Semigroup Assignments) + (define <> assignments-compose)) + + (define-instance (Monoid Assignments) + (define mempty (default))) + + (declare assignments-increment (Assignments -> Assignments)) + (define (assignments-increment (Assignments instructions first-fresh-index next-fresh-index)) + "Increment the next fresh index." + (Assignments instructions first-fresh-index (1+ next-fresh-index))) + + (declare add-instruction (Assignments -> (Tuple UFix ClassicalExpression) -> Assignments)) + (define (add-instruction (Assignments instructions first-fresh-index next-fresh-index) instruction) + "Add an instruction among existing variables to an `Assignments`." + (Assignments (Cons instruction instructions) first-fresh-index next-fresh-index)) + + (declare assign-fresh (Assignments -> UFix -> Assignments)) + (define (assign-fresh (Assignments instructions first-fresh-index next-fresh-index) v) + "Assign a fresh variable to `v` and add the instruction to the `Assignments`." + (Assignments (Cons (Tuple v (ClassicalVariable next-fresh-index)) instructions) + first-fresh-index (1+ next-fresh-index))) + + (define-instance (Into Assignments String) + (define (into a) + (mconcat + (list:intersperse + (into #\newline) + (concat (make-list (make-list "┌───────────────────┐" + "│ Assignments │" + "└───────────────────┘" + "┌──────") + (map (fn ((Tuple v e)) + (mconcat (make-list "│ c" (into v) " <- " (into e)))) + (get-assignments-instructions a)) + (singleton "└──────")))))))) + +(coalton-toplevel + + (declare fold-instructions ((List (Tuple UFix ClassicalExpression)) -> (map:Map UFix ClassicalExpression))) + (define (fold-instructions instructions) + "Take the `List` of instructions and perform all necessary simplifying substitutions." + (fold (fn (instruction-map (Tuple v (ClassicalExpression vs b))) + (map:insert-or-replace + instruction-map + v + ;; while walking through the instructions, check if the + ;; assigned expression contains any variables that have + ;; already been assigned, and make the appropriate + ;; substitutions. + (msum (Cons (ClassicalBit b) + (map (fn (v-prime) + (with-default (ClassicalVariable v-prime) + (map:lookup instruction-map v-prime))) + vs))))) + map:Empty + instructions)) + + (declare simplify-assignments (Assignments -> Assignments)) + (define (simplify-assignments (Assignments instructions first-fresh-index next-fresh-index)) + "Simplify `Assignments` to a sequence of instructions assigning only variables below the first fresh index." + (Assignments (iter:collect! (iter:filter! (compose (> first-fresh-index) fst) + (map:entries (fold-instructions instructions)))) + first-fresh-index + next-fresh-index))) diff --git a/src/foust/circuit.lisp b/src/foust/circuit.lisp new file mode 100644 index 000000000..6e281925f --- /dev/null +++ b/src/foust/circuit.lisp @@ -0,0 +1,106 @@ +;;;; circuit.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/circuit + (:documentation + "This package represents `Circuit`s as `List`s of `Gate`s and an `Assignments`.") + (:use + #:coalton + #:coalton-prelude) + (:use + #:cl-quil.foust/pauli + #:cl-quil.foust/assignments + #:cl-quil.foust/gate) + (:local-nicknames + (#:list #:coalton-library/list)) + (:export + #:Circuit + #:get-circuit-gates + #:set-circuit-gates + #:map-circuit-gates + #:get-circuit-assignments + #:set-circuit-assignments + #:map-circuit-assignments + #:add-gate + #:circuit-gate-count + #:circuit-tqe-count + #:get-circuit-next-fresh-index + #:make-circuit)) + +(in-package #:cl-quil.foust/circuit) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-type Circuit (Circuit (List Gate) Assignments)) + + (define-instance (Default Circuit) + (define (default) (Circuit Nil (default)))) + + (declare get-circuit-gates (Circuit -> (List Gate))) + (define (get-circuit-gates (Circuit gs _)) gs) + + (declare set-circuit-gates (Circuit -> (List Gate) -> Circuit)) + (define (set-circuit-gates (Circuit _ a) gs) (Circuit gs a)) + + (declare map-circuit-gates (((List Gate) -> (List Gate)) -> Circuit -> Circuit)) + (define (map-circuit-gates f (Circuit gs a)) (Circuit (f gs) a)) + + (declare get-circuit-assignments (Circuit -> Assignments)) + (define (get-circuit-assignments (Circuit _ a)) a) + + (declare set-circuit-assignments (Circuit -> Assignments -> Circuit)) + (define (set-circuit-assignments (Circuit gs _) a) (Circuit gs a)) + + (declare map-circuit-assignments ((Assignments -> Assignments) -> Circuit -> Circuit)) + (define (map-circuit-assignments f (Circuit gs a)) (Circuit gs (f a))) + + (declare add-gate (Circuit -> Gate -> Circuit)) + (define (add-gate (Circuit gs a) g) + "Add a `Gate` to the end of a `Circuit`." + (Circuit (list:append gs (singleton g)) a)) + + (declare circuit-gate-count (Circuit -> UFix)) + (define (circuit-gate-count (Circuit gs _)) + "Get the number of `Gate`s in a `Circuit`." + (length gs)) + + (declare circuit-tqe-count (Circuit -> UFix)) + (define (circuit-tqe-count (Circuit gs _)) + "Get the number of TQE `Gate`s in a `Circuit`." + (list:countby tqe? gs)) + + (declare get-circuit-next-fresh-index (Circuit -> UFix)) + (define (get-circuit-next-fresh-index (Circuit _ a)) + "Get the next fresh index from the `Assignments` of the `Circuit`." + (get-assignments-next-fresh-index a)) + + (declare make-circuit ((List Gate) -> Circuit)) + (define (make-circuit gs) + "Make a `Circuit` from a `List` of `Gate`s, setting the first fresh index of the `Assignments`." + (Circuit gs + (null-assignments + (fold (fn (fresh-index g) + (match g + ((Meas _ _ _ v) (max (1+ v) fresh-index)) + ((MeasMult _ v) (max (1+ v) fresh-index)) + (_ fresh-index))) + 0 + gs)))) + + (define-instance (Into Circuit String) + (define (into (Circuit gs a)) + (mconcat + (list:intersperse + (into #\newline) + (concat (make-list (make-list "┌───────────────────┐" + "│ Circuit │" + "└───────────────────┘" + "┌──────" + (<> "│ Gates : " (into (length gs))) + (<> "│ TQEs : " (into (list:countby tqe? gs))) + "└──────") + (map into gs) + (singleton (into a))))))))) diff --git a/src/foust/compile.lisp b/src/foust/compile.lisp new file mode 100644 index 000000000..3b0b2d3bf --- /dev/null +++ b/src/foust/compile.lisp @@ -0,0 +1,318 @@ +;;;; compile.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/compile + (:documentation + "This package defines the functions that compile `Circuit`s to `Graph`s and `Graph`s to `Circuit`s, + +including the compilation of `Frame`s into single-qubit Clifford `Gate`s and `TQE`s.") + (:use + #:coalton + #:coalton-prelude) + (:use + #:cl-quil.foust/pauli + #:cl-quil.foust/frame + #:cl-quil.foust/assignments + #:cl-quil.foust/node + #:cl-quil.foust/gate + #:cl-quil.foust/circuit + #:cl-quil.foust/graph + #:cl-quil.foust/cost + #:cl-quil.foust/reduce + #:cl-quil.foust/optimize) + (:local-nicknames + (#:iter #:coalton-library/iterator) + (#:map #:coalton-library/ord-map) + (#:tree #:coalton-library/ord-tree)) + (:local-nicknames + (#:fraction #:coalton-library/math/fraction)) + (:export + #:circuit->graph + #:graph->circuit)) + +(in-package #:cl-quil.foust/compile) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (declare add-node (Node -> Graph -> Graph)) + (define (add-node n g) + "Add any `Node` to the end of a `Graph`." + (match n + ((FrameNode f) (map-graph-frame (flip <> f) g)) + ((AssignmentsNode a) (map-graph-assignments (<> a) g)) + (_ + ;; If the new `Node` merges with a previously-terminating `Node`, + ;; remove the old `Node`, and re-add the merged `Node`. + (for (Tuple n0-index n0) in (get-terminal-tuples g) + (match (merge-nodes n0 n) + ((Some (Tuple n0-prime a0)) + (return (pipe (remove-vertex g n0-index) + (map-graph-assignments (<> a0)) + (add-node n0-prime)))) + ((None) (continue)))) + ;; + ;; Draw edges to new node from all nodes which do not commute + ;; with it. + ;; + ;; TODO: Efficiently reduce the number of edges drawn. This is + ;; a nontrivial problem. Consider the following graph. + ;; + ;; ->-1->-2->-3->-4 + ;; \ \ <- 7 + ;; 5->-6 + ;; + ;; It may be the case that 7 commutes with 3, 4 and 6, but not + ;; with 1, 2, or 5. In this case, we need to draw an edge from + ;; 5 to 7, but we don't want to draw it twice. The result that + ;; we want is + ;; + ;; ->-1->-2->-3->-4 + ;; \ \ + ;; 5->-6 + ;; \ + ;; 7 + ;; + ;; Currently, the algorithm *will* draw the edge from 1 and 2 to 7. + ;; + (let ((node-index (get-graph-fresh-node-index g))) + (iter:fold! (fn (g-prime (Tuple n0-index (Tuple n0 _))) + (if (commute? n n0) g-prime (add-edge g-prime n0-index node-index))) + (add-vertex g n) + (map:entries (get-graph-node-map g))))))) + + (declare circuit->graph (Circuit -> Graph)) + (define (circuit->graph c) + "Compile a `Circuit` to a `Graph`." + (fold (fn (g n) + (match n + ((FrameNode f) (map-graph-frame (<> f) g)) + ((MeasurementNode (Measurement p v)) + (add-node (frame-node-> + (get-graph-frame g) + (MeasurementNode (Measurement p (get-assignments-next-fresh-index (get-graph-assignments g))))) + (map-graph-assignments (flip assign-fresh v) g))) + (_ (add-node (frame-node-> (get-graph-frame g) n) g)))) + (map-graph-assignments (<> (get-circuit-assignments c)) (default)) + (map gate->node (get-circuit-gates c))))) + +(coalton-toplevel + + ;; The following protocol is used to reconstruct a `Graph` as a + ;; `Circuit`, except the terminal `Frame` in the case where the quantum + ;; state is to be preserved, or the terminal `Measurement`s in the + ;; case where the quantum state is to be released. + + (declare keep-if-not-preserve? (Graph -> (Tuple UFix Node) -> Boolean)) + (define (keep-if-not-preserve? g (Tuple node-index n)) + "Should `n` be processed in the case where `preserve-state? = False`?" + (not (and (measurement-node? n) (is-terminal-at? g node-index)))) + + (declare continue-search? (Boolean -> Graph -> Boolean)) + (define (continue-search? preserve-state? g) + "Should we continue compiling non-Clifford `Node`s?" + (not (if preserve-state? (graph-empty? g) (graph-empty-except-terminal-measurements? g)))) + + (declare process-zero-cost ((Gate -> (Tuple (List Gate) Frame)) + -> (Tuple Circuit Graph) + -> (Tuple UFix Node) + -> (Tuple Circuit Graph))) + (define (process-zero-cost corrections (Tuple c g) (Tuple node-index n)) + "Remove a free `Node` from the `Graph` and add it as a `Gate` to the `Circuit`." + (let ((correct-and-add-gate + (compose (bimap (fold add-gate c) (push-frame (remove-vertex g node-index))) corrections))) + (match n + ((MeasurementNode (Measurement p v)) + (if (== Minus (get-pauli-sign p)) + (process-zero-cost corrections + (Tuple c (map-graph-assignments + (flip add-instruction (Tuple v (classical-bit-flip (ClassicalVariable v)))) + g)) + (Tuple node-index (MeasurementNode (Measurement (pauli-* p (make-pauli-i Minus)) v)))) + (correct-and-add-gate (node->gate n)))) + (_ (correct-and-add-gate (node->gate n)))))) + + (declare fold-zero-cost (Boolean + -> (Gate -> (Tuple (List Gate) Frame)) + -> (Tuple Circuit Graph) -> (Tuple Circuit Graph))) + (define (fold-zero-cost preserve-state? corrections (Tuple c g)) + "Transfer all free entry `Node`s from the `Graph` to the `Circuit`." + (let ((zero-cost-tuples (iter:filter! (fn ((Tuple _ n)) (== 0 (node-cost n))) (get-entry-tuples g)))) + (iter:fold! (process-zero-cost corrections) + (Tuple c g) + ((if preserve-state? id (iter:filter! (keep-if-not-preserve? g))) zero-cost-tuples)))) + + (declare process-min-cost (Boolean + -> (Gate -> (Tuple (List Gate) Frame)) + -> (Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> (Tuple Circuit Graph) + -> (Tuple UFix Node) + -> (Tuple Circuit Graph))) + (define (process-min-cost preserve-state? corrections clifford-costs then-swap?? (Tuple c gr) (Tuple node-index n)) + "Process the cheapest entry `Node` by adding a `TQE` to the `Circuit` and pushing it through the `Graph`." + (if (== 0 (node-cost n)) + (process-zero-cost corrections (Tuple c gr) (Tuple node-index n)) + (match (iter:minimize-by! (fn (g) + (+ (clifford-costs g) (gate-cost preserve-state? gr g))) + (reduce-node then-swap?? n)) + ((Some g) (Tuple (add-gate c g) (push-frame gr (gate->frame (dagger-tqe g))))) + ((None) (error "Unable to reduce `Node`!"))))) + + (declare reduce-min-cost (Boolean + -> (Gate -> (Tuple (List Gate) Frame)) + -> (Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> (Tuple Circuit Graph) -> (Tuple Circuit Graph))) + (define (reduce-min-cost preserve-state? corrections clifford-costs then-swap?? (Tuple c g)) + "Reduce the cost of the cheapest entry `Node` of the `Graph` by adding a `TQE` to the `Circuit`." + (pipe (get-entry-tuples g) + (if preserve-state? id (iter:filter! (keep-if-not-preserve? g))) + (iter:minimize-by! (compose node-cost snd)) + (unwrap-or-else (process-min-cost preserve-state? corrections clifford-costs then-swap?? (Tuple c g)) + (fn () (Tuple c g))))) + + (declare search-non-clifford (Boolean + -> (Gate -> (Tuple (List Gate) Frame)) + -> (Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> (Tuple Circuit Graph) + -> (Tuple Circuit Graph))) + (define (search-non-clifford preserve-state? corrections clifford-costs then-swap?? (Tuple c g)) + "Transpile all `Node`s from the `Graph` to the `Circuit`, ignoring terminal `Measurement`s if `hold? = False`." + (if (not (continue-search? preserve-state? g)) + (Tuple c g) + (pipe (Tuple c g) + (fold-zero-cost preserve-state? corrections) + (reduce-min-cost preserve-state? corrections clifford-costs then-swap??) + (search-non-clifford preserve-state? corrections clifford-costs then-swap??))))) + +(coalton-toplevel + + ;; The following protocol is used to generate a sequences of `TQE`s + ;; single-qubit Clifford `Gate`s that is equivalent to a particular + ;; `Frame`. Within the Foust pipeline, it is used exclusively to + ;; reconstruct the terminal `Frame` when the quantum state is to be + ;; preserved. + + (declare process-zero-cost-row ((Tuple Circuit Frame) -> (Tuple UFix (Tuple Pauli Pauli)) -> (Tuple Circuit Frame))) + (define (process-zero-cost-row (Tuple c f) row) + "Remove a free row from the `Frame` and add it as a `Gate` to the `Circuit`." + (Tuple (add-gate c (row->gate False row)) + (<> f (gate->frame (row->gate True row))))) + + (declare fold-zero-cost-rows ((map:Map UFix UFix) -> (Tuple Circuit Frame) -> (Tuple Circuit Frame))) + (define (fold-zero-cost-rows row-costs (Tuple c f)) + "Compile all free rows into single-qubit Clifford `Gate`s." + (iter:fold! process-zero-cost-row + (Tuple c f) + (iter:filter! (fn ((Tuple row _)) + (== 0 (unwrap (map:lookup row-costs row)))) + (map:entries (get-frame-row-map f))))) + + (declare process-min-cost-row ((Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> (Tuple Circuit Frame) + -> (Tuple UFix (Tuple Pauli Pauli)) + -> (Tuple Circuit Frame))) + (define (process-min-cost-row clifford-costs then-swap?? (Tuple c f) row) + "Process the cheapest row with a `TQE`." + (match (iter:minimize-by! (fn (g) (+ (clifford-costs g) (delta-frame-cost g f))) + (reduce-row then-swap?? row)) + ((Some g) (Tuple (add-gate c g) (<> f (gate->frame (dagger-tqe g))))) + ((None) (error "Unable to reduce row!")))) + + (declare reduce-min-cost-row ((Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> (map:Map UFix UFix) + -> (Tuple Circuit Frame) + -> (Tuple Circuit Frame))) + (define (reduce-min-cost-row clifford-costs then-swap?? row-costs (Tuple c f)) + "Reduce the cost of the cheapest row." + (match (iter:minimize-by! (.< unwrap (map:lookup row-costs) fst) (map:entries (get-frame-row-map f))) + ((Some row) + (if (== 0 (unwrap (map:lookup row-costs (fst row)))) + (process-zero-cost-row (Tuple c f) row) + (process-min-cost-row clifford-costs then-swap?? (Tuple c f) row))) + ((None) (Tuple c f)))) + + (declare synthesize-frame ((Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> (Tuple Circuit Frame) + -> (Tuple Circuit Frame))) + (define (synthesize-frame clifford-costs then-swap?? (Tuple c f)) + "Convert a `Frame` to a series of `TQE`s and single-qubit Clifford `Gate`s." + (if (== f (default)) + (Tuple c f) + (let ((row-costs (get-row-costs f))) + (pipe (Tuple c f) + (fold-zero-cost-rows row-costs) + (reduce-min-cost-row clifford-costs then-swap?? row-costs) + (synthesize-frame clifford-costs then-swap??)))))) + +(coalton-toplevel + + (declare add-measurement-with-corrections ((Gate -> (Tuple (List Gate) Frame)) + -> Circuit + -> Gate + -> Circuit)) + (define (add-measurement-with-corrections corrections c m) + "Assuming `measurement-m` is a single-qubit `Measurement`, after which the qubit will not be operated on, + +correct and add the `Measurement` to the `Circuit`." + (pipe m corrections fst (fold add-gate c))) + + (declare synthesize-measurements ((Gate -> (Tuple (List Gate) Frame)) + -> (Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> (Tuple Circuit Graph) + -> Circuit)) + (define (synthesize-measurements corrections clifford-costs then-swap?? (Tuple c g)) + "Synthesize terminal `Measurement`s as single-qubit `Measurement`s, and a correcting `Assignments`." + (let ((terminal-measurements (map (fn ((Tuple node-index n)) + (if (is-terminal-at? g node-index) + (match n + ((MeasurementNode m) m) + (_ (error "Expected only `MeasurementNodes`."))) + (error "Expected only terminal `Nodes`."))) + (iter:collect! (map:entries (map fst (get-graph-node-map g)))))) + (tuple-cf (search-measurements True + clifford-costs + then-swap?? + (get-circuit-next-fresh-index c) + terminal-measurements)) + (assignments-mu-prime (uncurry (map-measurements terminal-measurements) + tuple-cf))) + (fold (add-measurement-with-corrections corrections) + (map-circuit-assignments (assignments-compose assignments-mu-prime) c) + (get-circuit-gates (fst tuple-cf)))))) + +(coalton-toplevel + + (declare graph->circuit (Boolean + -> (Gate -> (Tuple (List Gate) Frame)) + -> (Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> Graph + -> Circuit)) + (define (graph->circuit preserve-state? corrections clifford-costs then-swap?? g) + "Make a `Circuit` from a `Graph`." + (match (search-non-clifford preserve-state? corrections clifford-costs then-swap?? (Tuple (default) g)) + ((Tuple c-prime g-prime) + (let ((tuple-cg (pipe (Tuple c-prime g-prime) + (nest map-fst + map-circuit-assignments + assignments-compose + get-graph-assignments + g-prime)))) + (if preserve-state? + (pipe tuple-cg + (map-snd get-graph-frame) + (synthesize-frame clifford-costs then-swap??) + fst + (map-circuit-assignments simplify-assignments)) + (pipe tuple-cg + (synthesize-measurements corrections clifford-costs then-swap??) + (map-circuit-assignments simplify-assignments)))))))) diff --git a/src/foust/cost.lisp b/src/foust/cost.lisp new file mode 100644 index 000000000..d9aaeaf92 --- /dev/null +++ b/src/foust/cost.lisp @@ -0,0 +1,215 @@ +;;;; cost.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/cost + (:documentation "This package defines costs for various elements involved in the circuit->graph->circuit compilation pipeline.") + (:use + #:coalton + #:coalton-prelude) + (:use + #:cl-quil.foust/pauli + #:cl-quil.foust/frame + #:cl-quil.foust/node + #:cl-quil.foust/gate + #:cl-quil.foust/graph) + (:local-nicknames + (#:bits #:coalton-library/bits) + (#:iter #:coalton-library/iterator) + (#:list #:coalton-library/list) + (#:map #:coalton-library/ord-map)) + (:export + #:row-cost + #:get-row-costs + #:frame-cost + #:singlet-cost + #:factor-cost + #:node-cost + #:get-node-costs + #:get-entry-node-costs + #:delta-singlet-cost + #:delta-row-cost + #:delta-frame-cost + #:delta-node-cost + #:gate-cost)) + +(in-package #:cl-quil.foust/cost) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (declare singlet-cost (Pauli -> UFix)) + (define (singlet-cost p) + "Return the cost of a singlet `Node`, given it's `Pauli`." + ;; The cost of a singlet `Node`, one defined by a single `Pauli`, is + ;; just one less than the number of qubits on which it operates. + ;; This is because a node operating on a single qubit is directly + ;; convertible to a `Gate`, and for any other `Node`, one TQE is + ;; required to reduce it from operating on n to n-1 qubits. + (let ((support (iter:count! (map:keys (get-pauli-operator-map p))))) + (if (== 0 support) + (error "`singlet-cost` encountered the Identity `Pauli`.") + (1- support)))) + + (declare factor-support (Pauli -> Pauli -> (Tuple UFix UFix))) + (define (factor-support p q) + "Return the number of qubits on which P or Q operate, and the + +number of qubits to which P and Q assign anti-commuting Pauli operators." + (let ((operator-pairs (map (fn (qubit) + (Tuple (get-pauli-operator-at qubit p) + (get-pauli-operator-at qubit q))) + (list:union (get-pauli-support p) + (get-pauli-support q))))) + (Tuple + ;; weak support = number of qubits on which either P or Q + ;; operates. + (length operator-pairs) + ;; strong support = number of qubits for which P and Q assign + ;; anti-commuting Pauli operators. + (list:countby (complement (uncurry commute?)) operator-pairs)))) + + (declare factor-cost (Pauli -> Pauli -> UFix)) + (define (factor-cost p q) + "Return the cost of a factor `Node`, given as a pair of anti-commuting `Pauli`s." + ;; The cost of a factor `Node`, one defined by anti-commuting + ;; `Pauli`s is one less than the number of qubits on which it + ;; operates, plus and additional unit of cost for every extra pair + ;; of qubits at which the `Pauli`s anti-commute. See + ;; `foust/reduce` and the README for more details. + (match (factor-support p q) + ((Tuple weak-support strong-support) + (+ (1- weak-support) (bits:shift -1 (1- strong-support))))))) + +(coalton-toplevel + + (declare row-cost ((Tuple UFix (Tuple Pauli Pauli)) -> UFix)) + (define (row-cost (Tuple row-index (Tuple p q))) + "Return the cost of a row of a `Frame`." + ;; In addition to the cost of a row treated as a factor `Node` + ;; (see above), the cost of a row depends on its index being the + ;; same as that of the qubit on which its defining `Pauli`s + ;; operate. See `foust/reduce` and the README for more details. + (+ (factor-cost p q) + (let ((operator-p (get-pauli-operator-at row-index p)) + (operator-q (get-pauli-operator-at row-index q))) + (cond + ;; This case requires a SWAP = 3 TQEs + ((conjoin (== operator-p) (== operator-q) I) 3) + ;; This case requires a single TQE + ((commute? operator-p operator-q) 1) + (True 0))))) + + (declare get-row-costs (Frame -> (map:Map UFix UFix))) + (define (get-row-costs f) + "Return the costs of all of the rows in a `Frame` as a `Map`." + (map:collect! (map (compose (map-fst fst) (pair-with row-cost)) + (map:entries (get-frame-row-map f))))) + + (declare frame-cost (Frame -> UFix)) + (define (frame-cost f) + "Return the cost of a `Frame`." + (iter:sum! (map (compose 1+ row-cost) (map:entries (get-frame-row-map f)))))) + +(coalton-toplevel + + (declare node-cost (Node -> UFix)) + (define (node-cost n) + "Return the cost to implement `n` as a single-qubit `Gate` a circuit." + (match n + ((FrameNode f) (frame-cost f)) + ((AssignmentsNode _) 0) + ((RotationNode (Rotation p _)) (singlet-cost p)) + ((Rotation2Node (Rotation2 p q _ _)) (factor-cost p q)) + ((PreparationNode (Preparation p q)) (factor-cost p q)) + ((MeasurementNode (Measurement p _)) (singlet-cost p))))) + +(coalton-toplevel + + (declare delta-singlet-cost (Gate -> Pauli -> IFix)) + (define (delta-singlet-cost g p) + "Compute the change in singlet `Node` cost upon the action of a TQE `Gate`." + (match g + ((TQE t-one t-two qubit-one qubit-two _) + (let ((p-one (get-pauli-operator-at qubit-one p)) + (p-two (get-pauli-operator-at qubit-two p))) + (+ (cond + ((commute? p-one t-one) 0) ;; Here, p2 remains unchanged. + ((== p-two I) +1) ;; Here, p2 = I goes to P2 in {X, Y, Z} + ((== p-two t-two) -1) ;; Here, p2 in {X, Y, Z} goes to p2 = I + (True 0)) ;; Here, p2 stays in {X, Y, Z} + (cond + ;; See above; cases apply symmetrically. + ((commute? p-two t-two) 0) + ((== p-one I) +1) + ((== p-one t-one) -1) + (True 0))))) + (_ (error "Expected TQE Gate for delta-singlet-costs."))))) + +(coalton-toplevel + + (declare delta-factor-cost (Gate -> Pauli -> Pauli -> IFix)) + (define (delta-factor-cost g p q) + "Compute the change in factor `Node` cost upon the action of a TQE `Gate`." + (match g + ((TQE _ _ qubit-one qubit-two _) + (let ((f (gate->frame (dagger-tqe g))) + ;; Here, rather than matching many cases, we simply + ;; consider a "subnode", looking only at the qubits affected + ;; by the TQE, and compute the change in cost directly. + ;; While it may be more efficient to match cases, as with + ;; `delta-singlet-cost`, this operation still terminates + ;; in constant time. + (old-subpaulis (bimap (subpauli (make-list qubit-one qubit-two)) + (subpauli (make-list qubit-one qubit-two)) + (Tuple p q))) + (new-subpaulis (bimap (frame-> f) (frame-> f) old-subpaulis))) + (match (Tuple (uncurry factor-support new-subpaulis) + (uncurry factor-support old-subpaulis)) + ((Tuple (Tuple new-weak-support new-strong-support) + (Tuple old-weak-support old-strong-support)) + (+ (- (into new-weak-support) (into old-weak-support)) + (bits:shift -1 (- (into new-strong-support) (into old-strong-support)))))))) + (_ (error "Expected TQE Gate for delta-factor-cost."))))) + +(coalton-toplevel + + (declare delta-row-cost (Gate -> (Tuple UFix (Tuple Pauli Pauli)) -> IFix)) + (define (delta-row-cost g (Tuple row-index (Tuple p q))) + "Compute the change in row cost upon the action of a TQE `Gate`." + (match g + ((TQE _ _ qubit-one qubit-two _) + (if (disjoin (== qubit-one) (== qubit-two) row-index) + (- (let ((f (gate->frame (dagger-tqe g)))) + (into (row-cost (Tuple row-index (Tuple (frame-> f p) (frame-> f q)))))) + (into (row-cost (Tuple row-index (Tuple p q))))) + (delta-factor-cost g p q))) + (_ (error "Expected TQE `Gate` for delta-row-cost.")))) + + (declare delta-frame-cost (Gate -> Frame -> IFix)) + (define (delta-frame-cost g f) + "Compute the change in `Frame` cost upon action of a TQE `gate`." + (iter:sum! (map (delta-row-cost g) (map:entries (get-frame-row-map f)))))) + +(coalton-toplevel + + (declare delta-node-cost (Gate -> Node -> IFix)) + (define (delta-node-cost g n) + "Compute the change in `Node` cost upon action of a TQE `Gate`." + (match n + ((FrameNode f) (delta-frame-cost g f)) + ((AssignmentsNode _) (error "`AssignmentsNode` has no cost.")) + ((RotationNode (Rotation p _)) (delta-singlet-cost g p)) + ((Rotation2Node (Rotation2 p q _ _)) (delta-factor-cost g p q)) + ((PreparationNode (Preparation p q)) (delta-factor-cost g p q)) + ((MeasurementNode (Measurement p _)) (delta-singlet-cost g p))))) + +(coalton-toplevel + + (declare gate-cost (Boolean -> Graph -> Gate -> IFix)) + (define (gate-cost preserve-state? (Graph _ node-map f _) g) + "Calculate the cost of adding a TQE `Gate`, by pushing the associated `Frame` through the `Graph`." + ;; The frame cost only matters if it will be synthesized in the preserve-state case. + (pipe (iter:sum! (map (compose (delta-node-cost g) fst) (map:values node-map))) + (if preserve-state? (+ (delta-frame-cost g f)) id)))) diff --git a/src/foust/foust-quil.lisp b/src/foust/foust-quil.lisp new file mode 100644 index 000000000..668d302d9 --- /dev/null +++ b/src/foust/foust-quil.lisp @@ -0,0 +1,494 @@ +;;;; foust-quil.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust-quil + (:documentation + "This package defines an interface between Foust and the Quil compiler via the Coalton function + +`foust-parsed-program` and the equivalent Common Lisp function `cl-foust-parsed-program`, which + +each Foust a `cl-quil:parsed-program`, parametrized by a variable `preserve-state?` or + +`preserve-state-p`, respectively.") + (:use + #:coalton + #:coalton-prelude) + (:use + #:coalton-quil) + (:local-nicknames + (#:foust #:cl-quil.foust) + (#:iter #:coalton-library/iterator) + (#:list #:coalton-library/list) + (#:map #:coalton-library/ord-map) + (#:tree #:coalton-library/ord-tree)) + (:export + #:foust-parsed-program + #:cl-foust-parsed-program)) + +(in-package #:cl-quil.foust-quil) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-type FoustAtlas + "A `FoustAtlas` will keep track of the qubits used in the original ciruit, as well as the original + +`Measurement`s mapped to from the classical variables used within foust. Moreover, it keeps track of + +the gates in a circuit prior to conversion into `foust:Circuit`." + (FoustAtlas + ;; A reverse List of Gates. + (List foust:Gate) + ;; A Tree of qubit indices. + (tree:Tree UFix) + ;; Map from Foust classical variable IDs + ;; to `cl-quil` memory addresses. + (map:Map UFix QuilMemoryRef) + ;; The next available classical variable ID. + UFix)) + + (define-instance (Default FoustAtlas) + (define (default) (FoustAtlas Nil tree:Empty map:Empty 0))) + + (declare get-foust-atlas-ro-map (FoustAtlas -> (map:Map UFix QuilMemoryRef))) + (define (get-foust-atlas-ro-map (FoustAtlas _ _ ro-map _)) ro-map) + + (declare add-gate-to-atlas (FoustAtlas -> foust:Gate -> FoustAtlas)) + (define (add-gate-to-atlas (FoustAtlas gs qubits ro-map next-fresh-index) g) + "Add a `foust:Gate` to a `FoustAtlas`" + (FoustAtlas (Cons g gs) (fold tree:insert-or-replace qubits (foust:get-gate-qubits g)) ro-map next-fresh-index)) + + (declare add-measurement-to-atlas (FoustAtlas -> UFix -> (Optional QuilMemoryRef) -> FoustAtlas)) + (define (add-measurement-to-atlas (FoustAtlas gs qubits ro-map next-fresh-index) qubit wrapped-memory-ref) + "Add a `Measurement` of `qubit-q` to a `FoustAtlas`. Record the `Measurement` if an address is supplied." + (FoustAtlas (Cons (foust:Meas foust:Plus foust:Z qubit next-fresh-index) gs) + (tree:insert-or-replace qubits qubit) + (match wrapped-memory-ref + ((Some memory-ref) (map:insert-or-replace ro-map next-fresh-index memory-ref)) + ((None) ro-map)) + (1+ next-fresh-index))) + + (declare circuit-from-atlas (Boolean -> FoustAtlas -> foust:Circuit)) + (define (circuit-from-atlas add-preparations? (FoustAtlas gs qubits _ _)) + "Make a `foust:Circuit` from a `FoustAtlas`, preparing all qubits in |0⟩ if `add-preparations?`." + (foust:make-circuit (iter:fold! (flip Cons) + (reverse gs) + (if add-preparations? + (map (foust:Prep foust:Plus foust:Z foust:X) + (tree:decreasing-order qubits)) + iter:Empty))))) + +(coalton-toplevel + + (declare add-quil-instruction-to-foust-atlas (FoustAtlas -> QuilInstruction -> FoustAtlas)) + (define (add-quil-instruction-to-foust-atlas foust-atlas instruction-i) + "Compile a `cl-quil:instruction` to a `foust:Gate`, and add it to `foust-atlas`." + (match instruction-i + ((QuilPragma _) foust-atlas) + ((QuilHalt _) foust-atlas) + ((QuilMeasurement measurement-m) + (add-measurement-to-atlas foust-atlas + (get-quil-measurement-qubit measurement-m) + (get-quil-measurement-address measurement-m))) + ((QuilGateApplication gate-application-g) + (add-gate-to-atlas + foust-atlas + (match (get-quil-operator-description gate-application-g) + ((QuilNamedOperator named-operator-o) + (let ((name (get-quil-named-operator-name named-operator-o))) + (cond + ((== name "X") + (foust:PauliGate foust:X (list:nth 0 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "Y") + (foust:PauliGate foust:Y (list:nth 0 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "Z") + (foust:PauliGate foust:Z (list:nth 0 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "H") + (foust:H foust:Plus foust:Y (list:nth 0 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "S") + (foust:S foust:Z (list:nth 0 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "CNOT") + (foust:Controlled foust:X + (list:nth 0 (get-quil-gate-application-qubits gate-application-g)) + (list:nth 1 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "CZ") + (foust:Controlled foust:Z + (list:nth 0 (get-quil-gate-application-qubits gate-application-g)) + (list:nth 1 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "ISWAP") + (foust:iSwap (list:nth 0 (get-quil-gate-application-qubits gate-application-g)) + (list:nth 1 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "SWAP") + (foust:Swap (list:nth 0 (get-quil-gate-application-qubits gate-application-g)) + (list:nth 1 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "RX") + (foust:R foust:X + (foust:Angle (get-quil-gate-application-angle gate-application-g)) + (list:nth 0 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "RY") + (foust:R foust:Y + (foust:Angle (get-quil-gate-application-angle gate-application-g)) + (list:nth 0 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "RZ") + (foust:R foust:Z + (foust:Angle (get-quil-gate-application-angle gate-application-g)) + (list:nth 0 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "T") + (foust:R foust:Z + (foust:Angle 1/8) + (list:nth 0 (get-quil-gate-application-qubits gate-application-g)))) + (True (error (mconcat (make-list "Gate " name " not supported."))))))) + ((QuilDaggerOperator dagger-operator-o) + (match (get-quil-dagger-operator-operator dagger-operator-o) + ((QuilNamedOperator named-operator-o) + (let ((name (get-quil-named-operator-name named-operator-o))) + (cond + ((== name "S") + (foust:SDag foust:Z (list:nth 0 (get-quil-gate-application-qubits gate-application-g)))) + ((== name "T") + (foust:R foust:Z (foust:Angle -1/8) (list:nth 0 (get-quil-gate-application-qubits gate-application-g)))) + (True (error (mconcat (make-list "Gate DAGGER " name " not supported."))))))) + (_ (error "Operand of `dagger-operator` must be `named-operator`."))))))) + (_ (error "Instruction not supported."))))) + +(coalton-toplevel + + (declare quil-parsed-program->foust-atlas (QuilParsedProgram -> FoustAtlas)) + (define (quil-parsed-program->foust-atlas parsed-program-p) + "Represent a `parsed-program` as a `FoustAtlas`, by adding all compatible instructions." + (fold add-quil-instruction-to-foust-atlas + (default) + (match (get-parsed-program-executable-code parsed-program-p) + ((QuilExecutableCode instructions-is) instructions-is))))) + +(coalton-toplevel + + (declare handle-quil-memory-from-simplified-assignments + (foust:Assignments -> (Optional (Tuple QuilMemoryDescriptor (map:Map UFix QuilMemoryRef))))) + (define (handle-quil-memory-from-simplified-assignments assignments-mu) + "If classical variables are assigned, construct a classical register for them, and + +a mapping from variable IDs to dense memory addresses." + (let ((classical-variables (remove-duplicates + (concatmap (compose foust:get-classical-expression-variables snd) + (foust:get-assignments-instructions assignments-mu)))) + (number-of-classical-variables (length classical-variables))) + (if (== 0 number-of-classical-variables) + None + (let ((foustro (make-quil-memory-descriptor "foustro" number-of-classical-variables))) + (Some (Tuple foustro + (pipe (zip classical-variables (range 0 (1- number-of-classical-variables))) + (map (map-snd (make-quil-memory-ref foustro))) + iter:into-iter + map:collect!)))))))) + +(coalton-toplevel + + (declare foust-gate->quil-instruction ((map:Map UFix QuilMemoryRef) -> foust:Gate -> QuilInstruction)) + (define (foust-gate->quil-instruction memory-map gate-g) + "Compile a `foust:Gate` to a `cl-quil:instruction`." + (match gate-g + ((foust:Meas sign-s pauli-operator-p qubit cvar-c) + (if (and (== sign-s foust:Plus) + (== pauli-operator-p foust:Z)) + (QuilMeasurement (make-quil-measurement (map:lookup memory-map cvar-c) qubit)) + (error "Encountered non-standard Meas gate."))) + ((foust:PauliGate pauli-operator-p qubit) + (cond + ((== pauli-operator-p foust:X) + (QuilGateApplication (make-quil-gate-application False "X" Nil (singleton qubit)))) + ((== pauli-operator-p foust:Y) + (QuilGateApplication (make-quil-gate-application False "Y" Nil (singleton qubit)))) + ((== pauli-operator-p foust:Z) + (QuilGateApplication (make-quil-gate-application False "Z" Nil (singleton qubit)))) + (True (error "Unexpected PauliOperator in PauliGate gate.")))) + ((foust:H sign-s pauli-operator-p qubit) + (if (and (== sign-s foust:Plus) + (== pauli-operator-p foust:Y)) + (QuilGateApplication (make-quil-gate-application False "H" Nil (singleton qubit))) + (error "Cannot handle non-standard Hadamard gate."))) + ((foust:S pauli-operator-p qubit) + (if (== pauli-operator-p foust:Z) + (QuilGateApplication (make-quil-gate-application False "S" Nil (singleton qubit))) + (error "Cannot handle non-standard S gate."))) + ((foust:SDag pauli-operator-p qubit) + (if (== pauli-operator-p foust:Z) + (QuilGateApplication (make-quil-gate-application True "S" Nil (singleton qubit))) + (error "Cannot handle non-standard SDag gate."))) + ((foust:Controlled pauli-operator-p control-index target-index) + (cond + ((== pauli-operator-p foust:X) + (QuilGateApplication (make-quil-gate-application False "CNOT" Nil (make-list control-index target-index)))) + ((== pauli-operator-p foust:Z) + (QuilGateApplication (make-quil-gate-application False "CZ" NIL (make-list control-index target-index)))) + (True + (error "Can only handle CZ and CNOT, not CY.")))) + ((foust:iSwap qubit-one qubit-two) + (QuilGateApplication (make-quil-gate-application False "ISWAP" Nil (make-list qubit-one qubit-two)))) + ((foust:Swap qubit-one qubit-two) + (QuilGateApplication (make-quil-gate-application False "SWAP" Nil (make-list qubit-one qubit-two)))) + ((foust:R pauli-operator-p theta qubit) + (QuilGateApplication + (cond + ((== pauli-operator-p foust:X) + (make-quil-gate-application False "RX" (singleton (foust:angle->radians theta)) (singleton qubit))) + ((== pauli-operator-p foust:Y) + (make-quil-gate-application False "RY" (singleton (foust:angle->radians theta)) (singleton qubit))) + ((== pauli-operator-p foust:Z) + (cond + ((== theta (foust:Angle 1/4)) + (make-quil-gate-application False "S" Nil (singleton qubit))) + ((== theta (foust:Angle 3/4)) + (make-quil-gate-application True "S" Nil (singleton qubit))) + ((== theta (foust:Angle 1/8)) + (make-quil-gate-application False "T" Nil (singleton qubit))) + ((== theta (foust:Angle 7/8)) + (make-quil-gate-application True "T" Nil (singleton qubit))) + (True + (make-quil-gate-application False "RZ" (singleton (foust:angle->radians theta)) (singleton qubit))))) + (True (error "Unexpected `PauliOperator` in `R` gate."))))) + (_ (error (mconcat (make-list "Foust `Gate` " (into gate-g) " cannot be converted to a QuilInstruction."))))))) + +(coalton-toplevel + + ;; The following three functions define a basic, or default, chip + ;; architecture to be used with QuilC and Foust. It supports CZ and + ;; CNOT, single-qubit rotations RX, RY, and RZ, and single-qubit + ;; measurements of +Z, as well as H and S. It assumed all-to-all + ;; connectivity. + + (declare basic-quil-corrections (foust:Gate -> (Tuple (List foust:Gate) foust:Frame))) + (define (basic-quil-corrections gate-g) + "Map a Foust `Gate` to a list of Quil-compatible Foust `Gate`s followed by a correcting `Frame` s.t G = G1;G2;...;GN;GF." + (match gate-g + ((foust:Prep sign-s p _ qubit) + (Tuple (singleton (foust:Prep foust:Plus foust:Z foust:X qubit)) + (cond + ((== p foust:X) + (foust:frame-from-s (== sign-s foust:Plus) foust:Y qubit)) + ((== p foust:Y) + (foust:frame-from-s (== sign-s foust:Minus) foust:X qubit)) + (True (default))))) + ((foust:Meas sign-s p qubit classical-variable-c) + (if (and (== sign-s foust:Plus) + (== p foust:Z)) + (Tuple (singleton gate-g) (default)) + (let ((pre-correction (cond + ((== p foust:X) + (foust:R foust:Y + (foust:Angle (if (== sign-s foust:Plus) -1/4 1/4)) + qubit)) + ((== p foust:Y) + (foust:R foust:X + (foust:Angle (if (== sign-s foust:Plus) 1/4 -1/4)) + qubit)) + (True (foust:PauliGate foust:X qubit))))) + (Tuple (make-list pre-correction + (foust:Meas foust:Plus foust:Z qubit classical-variable-c)) + (foust:frame-inverse (foust:gate->frame pre-correction)))))) + (_ (Tuple (singleton gate-g) (default))))) + + (declare dag-distance-helper ((map:Map UFix (tree:Tree UFix)) -> UFix -> UFix -> (List UFix) -> UFix)) + (define (dag-distance-helper link-map from to visited) + (match (map:lookup link-map from) + ((Some tre) (match (tree:lookup tre to) + ((Some _) 1) + ((None) + (match (iter:min! + (map (fn (new-from) + (dag-distance-helper link-map new-from to (Cons from visited))) + (iter:filter! (complement (flip list:member visited)) (iter:into-iter tre)))) + ((Some x) (1+ x)) + ((None) (coalton-library/bits:not 0)))))) + ((None) (error "Encountered unconnected qubit!")))) + + (declare dag-distance ((map:Map UFix (tree:Tree UFix)) -> UFix -> UFix -> UFix)) + (define (dag-distance link-map from to) + (dag-distance-helper link-map from to Nil)) + + (declare basic-quil-costs ((Optional (map:Map UFix (tree:Tree UFix))) -> foust:Gate -> IFix)) + (define (basic-quil-costs wrapped-link-map gate-g) + "Map a `TQE` gate to an `IFIX` reflecting the cost to implement the gate." + (match gate-g + ((foust:TQE pauli-operator-one pauli-operator-two index-one index-two _) + (pipe + (cond + ((== pauli-operator-one foust:Z) + (if (== pauli-operator-two foust:Y) 2 0)) + ((== pauli-operator-one foust:X) + (if (== pauli-operator-two foust:Z) 0 2)) + (True + (if (== pauli-operator-two foust:Y) 4 2))) + (match wrapped-link-map + ((Some link-map) (+ (into (* 3 (1- (dag-distance link-map index-one index-two)))))) + ((None) id)))) + (_ (error "Can only compute cost for TQE gates.")))) + + (declare basic-quil-then-swap?? (UFix -> UFix -> Boolean)) + (define (basic-quil-then-swap?? _ _) + "Indicate the kind of interaction between each pair of indexed qubits: + +True if the interaction can be conjugated to an ISWAP with single-qubit Cliffords. + +False if the interaction can be conjugated to a CZ with single-qubit Cliffords." + False) + + (declare basic-quil-replacements (foust:Gate -> (List foust:Gate))) + (define (basic-quil-replacements gate-g) + "A mapping from Foust single-qubit Cliffords and TQE gates to an equivalent list of QUIL-compatible gates." + (match gate-g + ((foust:TQE pauli-operator-one pauli-operator-two index-one index-two then-swap?) + (if then-swap? + (error "Expected only non-swapping TQEs for basic QUIL Foust.") + (cond + ((== pauli-operator-one foust:Y) + (concat (make-list (singleton (foust:R foust:X (foust:Angle 1/4) index-one)) + (basic-quil-replacements (foust:TQE foust:Z + pauli-operator-two + index-one + index-two + then-swap?)) + (singleton (foust:R foust:X (foust:Angle -1/4) index-one))))) + ((== pauli-operator-two foust:Y) + (concat (make-list (singleton (foust:R foust:X (foust:Angle 1/4) index-two)) + (basic-quil-replacements (foust:TQE pauli-operator-one + foust:Z + index-one + index-two + then-swap?)) + (singleton (foust:R foust:X (foust:Angle -1/4) index-two))))) + ((== pauli-operator-one foust:Z) + (singleton (foust:Controlled pauli-operator-two index-one index-two))) + ((== pauli-operator-two foust:X) + (make-list (foust:H foust:Plus foust:Y index-one) + (foust:Controlled foust:X index-one index-two) + (foust:H foust:Plus foust:Y index-one))) + (True + (singleton (foust:Controlled foust:X index-two index-one)))))) + ((foust:S p index-q) + (if (== p foust:Z) + (singleton gate-g) + (singleton (foust:R p (foust:Angle 1/4) index-q)))) + ((foust:SDag p index-q) + (if (== p foust:Z) + (singleton gate-g) + (singleton (foust:R p (foust:Angle -1/4) index-q)))) + ((foust:H sign-s p index-q) + (if (and (== sign-s foust:Plus) + (== p foust:Y)) + (singleton gate-g) + (make-list (foust:PauliGate (foust:next-pauli-operator p) index-q) + (foust:R p (foust:Angle (if (== sign-s foust:Plus) 1/4 -1/4)) index-q)))) + ((foust:Permute sign-x sign-y sign-z index-q) + (pipe (make-list (foust:R foust:X (foust:Angle (if (== sign-x foust:Plus) -1/4 1/4)) index-q) + (foust:R foust:Y (foust:Angle (if (== sign-y foust:Plus) -1/4 1/4)) index-q)) + (if (== foust:Plus (msum (make-list sign-x sign-y sign-z))) id reverse))) + (_ (singleton gate-g))))) + +(coalton-toplevel + + (declare is-basic-preparation? (foust:Gate -> Boolean)) + (define (is-basic-preparation? gate-g) + "Is `gate-g` a basic preparation (Prep+Z)?" + (match gate-g + ((foust:Prep sign-s p _ _) + (and (== sign-s foust:Plus) (== p foust:Z))) + (_ False))) + + (declare remove-entry-preparations (foust:Circuit -> foust:Circuit)) + (define (remove-entry-preparations (foust:Circuit gates-gs assignments-mu)) + "While the first gate in a Circuit is a basic preparation Prep+Z, remove + +the first gate of the Circuit; repeat." + (match (head gates-gs) + ((Some gate-g) + (if (is-basic-preparation? gate-g) + (remove-entry-preparations (foust:Circuit (unwrap (tail gates-gs)) assignments-mu)) + (foust:Circuit gates-gs assignments-mu))) + ((None) (foust:Circuit gates-gs assignments-mu))))) + +(coalton-toplevel + + (declare process-foust-assignment ((map:Map UFix QuilMemoryRef) + -> (map:Map UFix QuilMemoryRef) + -> (Tuple UFix foust:ClassicalExpression) + -> (List QuilInstruction))) + (define (process-foust-assignment ro-map foustro-map (Tuple cvar-c cexpr-e)) + "Given maps from classical variables to original and new classical addresses, + +construct a list of classical instructions equivalent to a classical assignment." + (let ((ro-address (unwrap (map:lookup ro-map cvar-c)))) + (map QuilBinaryClassicalInstruction + (Cons (QuilClassicalMove + (make-quil-classical-move ro-address (if (foust:get-classical-expression-bit cexpr-e) 1 0))) + (map (compose + (fn (foustro-address) + (QuilClassicalExclusiveOr + (make-quil-classical-exclusive-or ro-address foustro-address))) + (compose unwrap (map:lookup foustro-map))) + (foust:get-classical-expression-variables cexpr-e))))))) + +(coalton-toplevel + + (declare build-executable-code (foust:Circuit -> (map:Map UFix QuilMemoryRef) -> FoustAtlas -> QuilExecutableCode)) + (define (build-executable-code final-circuit foustro-map foust-atlas) + "Construct the executable code of a parsed program by compiling all `foust:Gate`s and + +then compiling all classical assignments into a list of classical instructions to be appended." + (pipe (let ((ro-map (get-foust-atlas-ro-map foust-atlas)) + (gates (foust:get-circuit-gates final-circuit)) + (assignments (foust:get-assignments-instructions + (foust:get-circuit-assignments final-circuit)))) + (append (map (foust-gate->quil-instruction foustro-map) gates) + (concatmap (process-foust-assignment ro-map foustro-map) + (filter (fn (assignment) + (iter:any! (== (fst assignment)) (map:keys ro-map))) + assignments)))) + QuilExecutableCode))) + +(coalton-toplevel + + (declare foust-quil ((Optional QuilChipSpecification) -> Boolean -> foust:Circuit -> foust:Circuit)) + (define (foust-quil chip-specification preserve-state?) + "Perform a `foust`, preserving the quantum state if `preserve-state?`, and applying + +the basic corrections, costs, and TQE spec functions." + (let ((link-map (map get-chip-specification-links chip-specification))) + (foust:foust preserve-state? basic-quil-corrections (basic-quil-costs link-map) basic-quil-then-swap??))) + + (declare foust-parsed-program (QuilParsedProgram -> (Optional QuilChipSpecification) -> Boolean -> Boolean -> QuilParsedProgram)) + (define (foust-parsed-program parsed-program chip-specification preserve-state? add-preparations?) + "Foust a parsed program by compiling it to a `foust:Circuit, adding initial preparations if + +`add-preparations` then fousting the `foust:Circuit` according to `preserve-state?` and then + +compiling the `foust:Circuit` back to a `cl-quil:parsed-program`. Lastly, print all four stages + +if `print-progress?`." + (let ((parsed-program-prime (copy-parsed-program parsed-program)) + (foust-atlas (quil-parsed-program->foust-atlas parsed-program-prime)) + (initial-circuit (circuit-from-atlas add-preparations? foust-atlas)) + (final-circuit (pipe initial-circuit + (foust-quil chip-specification preserve-state?) + remove-entry-preparations + (foust:map-circuit-gates (concatmap basic-quil-replacements))))) + (progn (match (handle-quil-memory-from-simplified-assignments + (foust:get-circuit-assignments final-circuit)) + ((None) (pipe parsed-program-prime + (set-parsed-program-executable-code! + (build-executable-code final-circuit map:empty foust-atlas)))) + ((Some (Tuple memory-descriptor foustro-map)) + (pipe parsed-program-prime + (map-parsed-program-memory-definitions! (Cons memory-descriptor)) + (set-parsed-program-executable-code! + (build-executable-code final-circuit foustro-map foust-atlas))))) + parsed-program-prime)))) + +(cl:defun cl-foust-parsed-program (parsed-program cl:&key chip-specification (preserve-state-p cl:t) (add-preparations-p cl:nil)) + (coalton (foust-parsed-program (lisp QuilParsedProgram () parsed-program) + (lisp (Optional QuilChipSpecification) () + (cl:if chip-specification (Some chip-specification) None)) + (lisp Boolean () preserve-state-p) + (lisp Boolean () add-preparations-p)))) diff --git a/src/foust/foust-user.lisp b/src/foust/foust-user.lisp new file mode 100644 index 000000000..aed968451 --- /dev/null +++ b/src/foust/foust-user.lisp @@ -0,0 +1,151 @@ +;;;; foust-user.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust-user + (:use + #:coalton + #:coalton-prelude) + (:import-from + #:cl-quil.foust/graphviz + #:graphviz) + (:import-from + #:cl-quil.foust + #:releasing-foust + #:preserving-foust) + (:local-nicknames + (#:gate #:cl-quil.foust/gate))) + +(in-package #:cl-quil.foust-user) + +(named-readtables:in-readtable coalton:coalton) + +;; This package defines functions and variables for a user to +;; experiment with Foust and Fousting in a sandbox-like environment. + +(coalton-toplevel + + (declare default-corrections (foust:Gate -> (Tuple (List foust:Gate) foust:Frame))) + (define (default-corrections gate-g) (Tuple (singleton gate-g) (default))) + + (declare default-clifford-costs (foust:Gate -> IFix)) + (define (default-clifford-costs _) 0) + + (declare default-then-swap?? (UFix -> UFix -> Boolean)) + (define (default-then-swap?? _ _) False) + + (declare default-releasing-foust (foust:Circuit -> foust:Circuit)) + (define (default-releasing-foust circuit-c) + (releasing-foust default-corrections default-clifford-costs default-then-swap?? circuit-c)) + + (declare default-preserving-foust (foust:Circuit -> foust:Circuit)) + (define (default-preserving-foust circuit-c) + (preserving-foust default-corrections default-clifford-costs default-then-swap?? circuit-c))) + +(coalton-toplevel + + (define X (fn (qubit) (singleton (foust:PauliGate foust:X qubit)))) + (define Y (fn (qubit) (singleton (foust:PauliGate foust:Y qubit)))) + (define Z (fn (qubit) (singleton (foust:PauliGate foust:Z qubit)))) + + (define H (fn (qubit) (singleton (foust:H foust:Plus foust:Y qubit)))) + (define S (fn (qubit) (singleton (foust:S foust:Z qubit)))) + (define Sdg (fn (qubit) (singleton (foust:SDag foust:Z qubit)))) + (define T (fn (qubit) (singleton (foust:R foust:Z (foust:Angle 1/8) qubit)))) + (define Tdg (fn (qubit) (singleton (foust:R foust:Z (foust:Angle -1/8) qubit)))) + + (define CNOT (fn (control-qubit target-qubit) (singleton (foust:Controlled foust:X control-qubit target-qubit)))) + (define CZ (fn (qubit-one qubit-two) (singleton (foust:TQE foust:Z foust:Z qubit-one qubit-two)))) + (define iSWAP (fn (qubit-one qubit-two) (singleton (foust:iSwap qubit-one qubit-two)))) + (define SWAP (fn (qubit-one qubit-two) (singleton (foust:Swap qubit-one qubit-two)))) + + (define RX (fn (qubit angle) (singleton (foust:R foust:X (foust:Angle angle) qubit)))) + (define RY (fn (qubit angle) (singleton (foust:R foust:Y (foust:Angle angle) qubit)))) + (define RZ (fn (qubit angle) (singleton (foust:R foust:Z (foust:Angle angle) qubit)))) + + ;; 9 single qubit gates (7 Ts, 2 Cliffords), 6 TQEs. + (define Toffoli (fn (control-qubit-one control-qubit-two target-qubit) + (mconcat (make-list (H target-qubit) + (CNOT control-qubit-two target-qubit) + (Tdg target-qubit) + (CNOT control-qubit-one target-qubit) + (T target-qubit) + (CNOT control-qubit-two target-qubit) + (Tdg target-qubit) + (CNOT control-qubit-one target-qubit) + (T control-qubit-two) + (T target-qubit) + (CNOT control-qubit-one control-qubit-two) + (H target-qubit) + (T control-qubit-one) + (Tdg control-qubit-two) + (CNOT control-qubit-one control-qubit-two))))) + + (define Prep (fn (qubit) (singleton (foust:Prep foust:Plus foust:Z foust:X qubit)))) + (define Meas (fn (qubit classical-variable) (singleton (foust:Meas foust:Plus foust:Z qubit classical-variable))))) + +(coalton-toplevel + + ;; The following circuit is adapted from arXiv:2305.10966v2, Fig. 1. + + (define example-circuit-one (foust:make-circuit (mconcat (make-list (Prep 0) + (Prep 1) + (RX 0 1/3) + (H 1) + (CNOT 1 0) + (RX 0 1/5) + (CNOT 0 1) + (RX 0 1/7) + (Meas 0 0) + (Meas 1 1))))) + + ;; The following circuit is a Deutsch-Joza circuit for two qubits. + + (define example-circuit-two (foust:make-circuit (mconcat (make-list (Prep 0) + (Prep 1) + (X 1) + (H 0) + (H 1) + (CNOT 0 1) + (H 0) + (Meas 0 0))))) + + ;; The following circuit is a Grover Search on three qubits for the state |110>, + ;; adapted from https://www.quantum-inspire.com/kbase/grover-algorithm/ + ;; 99 gates: 75 single qubit gates (28 Ts, 47 Cliffords), 24 TQEs. + ;; Reduces to 44 gates: 28 single qubit gates (all pi/4 rotations), 16 TQEs. + + (define example-circuit-three + (let ((oracle (mconcat (make-list (X 0) + (H 2) + (Toffoli 0 1 2) + (X 0) + (H 2)))) + (diffusion (mconcat (make-list (H 0) (H 1) (H 2) + (X 0) (X 1) (X 2) + (H 2) (Toffoli 0 1 2) (H 2) + (X 0) (X 1) (X 2) + (H 0) (H 1) (H 2))))) + (foust:make-circuit (mconcat (make-list (Prep 0) (Prep 1) (Prep 2) + (H 0) (H 1) (H 2) + oracle + diffusion + oracle + diffusion + (Meas 0 0) (Meas 1 1) (Meas 2 2)))))) + + ;; Test Preserve mode equivalence with the Toffoli and Swap gates. + + (define example-circuit-four (foust:make-circuit (Toffoli 0 1 2))) + (define example-circuit-five (foust:make-circuit (mconcat (make-list (SWAP 0 1))))) + (define example-circuit-six (foust:make-circuit (mconcat (make-list (iSWAP 0 1))))) + + ;; Test Release mode equivalence with the Toffoli applied to |110>. + + (define example-circuit-seven (foust:make-circuit (mconcat (make-list (Prep 0) + (Prep 1) + (Prep 2) + (X 0) + (X 1) + (Toffoli 0 1 2) + (Meas 2 0)))))) diff --git a/src/foust/foust.lisp b/src/foust/foust.lisp new file mode 100644 index 000000000..84de437ec --- /dev/null +++ b/src/foust/foust.lisp @@ -0,0 +1,162 @@ +;;;; foust.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust + (:documentation + "This package defines the complete set `foust` cycles, including a `releasing-foust`, a `preserving-foust` + +and a `foust` which takes `preserve-state` as a parameter.") + (:use + #:coalton + #:coalton-prelude) + (:import-from + #:coalton-library/math/integral + #:divmod) + (:use + #:cl-quil.foust/pauli + #:cl-quil.foust/frame + #:cl-quil.foust/assignments + #:cl-quil.foust/node + #:cl-quil.foust/gate + #:cl-quil.foust/circuit + #:cl-quil.foust/graph + #:cl-quil.foust/optimize + #:cl-quil.foust/compile) + (:export + #:PauliOperator + #:I + #:X + #:Y + #:Z + #:Sign + #:Plus + #:Minus + #:Pauli + #:Pauli + #:Angle + #:Angle + #:angle->radians + #:Frame + #:Frame + #:frame-> + #:frame<- + #:frame-inverse + #:frame-from-pauli-gate + #:frame-from-s + #:frame-from-h + #:frame-from-permute + #:frame-from-tqe + #:frame-from-controlled + #:frame-from-swap + #:frame-from-npi2-rotation + #:Assignments + #:get-assignments-instructions + #:get-classical-expression-variables + #:get-classical-expression-bit + #:Gate + #:PauliGate + #:S + #:SDag + #:H + #:Permute + #:TQE + #:iSwap + #:Swap + #:Controlled + #:R + #:RR + #:RMult + #:R2 + #:R2Mult + #:Prep + #:PrepMult + #:Meas + #:MeasMult + #:make-tqe + #:gate->frame + #:Circuit + #:get-circuit-gates + #:set-circuit-gates + #:map-circuit-gates + #:get-circuit-assignments + #:set-circuit-assignments + #:map-circuit-assignments + #:make-circuit + #:releasing-foust + #:preserving-foust + #:foust)) + +(in-package #:cl-quil.foust) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (declare releasing-foust ((Gate -> (Tuple (List Gate) Frame)) + -> (Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> Circuit + -> Circuit + )) + (define (releasing-foust corrections clifford-costs then-swap?? c) + "Foust a `Circuit, releasing the quantum state for additional optimizations." + (pipe c + circuit->graph + (optimize-graph False clifford-costs) + (graph->circuit False corrections clifford-costs then-swap??))) + + (declare preserving-foust ((Gate -> (Tuple (List Gate) Frame)) + -> (Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> Circuit + -> Circuit + )) + (define (preserving-foust corrections clifford-costs then-swap?? c) + "Foust a `Circuit`, preserving the quantum state for future compution." + (pipe c + circuit->graph + (optimize-graph True clifford-costs) + (graph->circuit True corrections clifford-costs then-swap??))) + + + (declare foust (Boolean + -> (Gate -> (Tuple (List Gate) Frame)) + -> (Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> Circuit + -> Circuit)) + (define (foust preserve-state? corrections clifford-costs then-swap?? c) + "Foust a `Circuit`. + +`preserve-state?` + : Should `foust` make sure its output is equivalent to its input as a unitary matrix, + i.e., should the quantum states which are the results of applying each successive gate + in the input and output circuits, respectively, be preserved? If not, more aggressive + optimizations are applied. However, this is only suitable for the case that measurements + are included in the circuit. + +`corrections` + : This is a user-defined function for nativizing the Clifford gates emitted by `foust`. It + operates by replacing a Clifford `Gate` with a `List` of `Gate`s followed by a `Frame`. + The `Frame` will be \"pushed\" back into `Foust` for further optimizations. For example, + if Prep(+Z) is desired and Prep(-X) is encountered, then `corrections` should return + `(Tuple (singleton (Prep Plus Z X qubit)) (frame-from-s True Y qubit))`. + +`clifford-costs` + : This user-defined function operates on TQE gates whenever they are used for reduction. + TQE costs should return an IFIX that reflects both architecture of the quantum processor + as well as the native gate set. For example, if the native gate set only contains CX, then + TQE Z X should return a lower cost than TQE Z Y which should also return a lower cost than + TQE Y Y. Similarly, if the processor has a linear, nearest-neighbor architecture, then TQE + P Q 0 3 should return a higher cost than TQE P Q 0 2. + +`then-swap??` + : This user-defined function takes two qubit indices and returns `True` if the physical + interaction among them is conjugable by single-qubit Cliffords to an `iSwap` and False + otherwise, i.e., if it is conjugable to a `CZ`. If two qubits are not at all connected, + then it does not matter which option is chosen. Instead, use `clifford-costs` to indicate + how expensive it would be to implement that gate natively. For homogeneous architecures, + use `(fn (_ _) True)` or `(fn (_ _) False)`." + ((if preserve-state? preserving-foust releasing-foust) + corrections clifford-costs then-swap?? c))) diff --git a/src/foust/frame.lisp b/src/foust/frame.lisp new file mode 100644 index 000000000..ac64c9809 --- /dev/null +++ b/src/foust/frame.lisp @@ -0,0 +1,303 @@ +;;;; frame.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/frame + (:documentation + "This package represents Clifford operators as stabilizer or Pauli tableaus, hereafter referred to as frames.") + (:use + #:coalton + #:coalton-prelude) + (:use + #:cl-quil.foust/pauli) + (:local-nicknames + (#:iter #:coalton-library/iterator) + (#:list #:coalton-library/list) + (#:map #:coalton-library/ord-map)) + (:export + #:Frame + #:Frame + #:get-frame-row-map + #:get-frame-support + #:get-pair-at + #:frame-> + #:frame<- + #:frame-inverse + #:frame-compose + #:frame-from-pauli-gate + #:frame-from-s + #:frame-from-h + #:frame-from-permute + #:frame-from-tqe + #:frame-from-controlled + #:frame-from-swap + #:frame-from-npi2-rotation)) + +(in-package #:cl-quil.foust/frame) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-type Frame + "A `Frame` represents the Clifford operator (U) as a sparse map from index i to a `Tuple`, + +storing (Udg)(Zi)(U) and (Udg)(Xi)(U), where Udg is the Hermitian conjugate of U, + +and Zi and Xi represent the Pauli operators Z and X acting on the qubit i." + (%Frame (map:Map UFix (Tuple Pauli Pauli)))) + + (declare Frame ((iter:IntoIterator :collection (Tuple UFix (Tuple Pauli Pauli))) => :collection -> Frame)) + (define (Frame row-map) + "Construct a `Frame` from a collection of row-index <-> Pauli-pair pairs." + (%Frame (iter:collect! (iter:filter! (complement default-row?) (iter:into-iter row-map))))) + + (declare get-frame-row-map (Frame -> (map:Map UFix (Tuple Pauli Pauli)))) + (define (get-frame-row-map (%Frame row-map)) row-map) + + (define-instance (Eq Frame) + (define (== (%Frame row-map-one) (%Frame row-map-two)) + (== row-map-one row-map-two))) + + (define-instance (Default Frame) + (define (default) (Frame map:Empty))) + + (declare get-frame-support (Frame -> (List UFix))) + (define (get-frame-support (%Frame row-map)) + "Return the nontrivial row indices from a `Frame` as a `List`." + (iter:collect! (map:keys row-map))) + + (declare default-stabilizer (UFix -> Pauli)) + (define (default-stabilizer row-index) + "Return the default stabilizer `Pauli` for row row-index" + (make-pauli-one Z row-index Plus)) + + (declare default-destabilizer (UFix -> Pauli)) + (define (default-destabilizer row-index) + "Return the default destabilizer `Pauli` for row row-index" + (make-pauli-one X row-index Plus)) + + (declare default-pair (UFix -> (Tuple Pauli Pauli))) + (define (default-pair row-index) + "Return the default stabilizer <-> destabilizer pair for row row-index" + (bimap default-stabilizer default-destabilizer (Tuple row-index row-index))) + + (declare default-row? ((Tuple UFix (Tuple Pauli Pauli)) -> Boolean)) + (define (default-row? (Tuple row-index pauli-pair)) + "Is `pauli-pair` the default pair for the row at `row-index`?" + (== pauli-pair (default-pair row-index))) + + (declare get-pair-at (Frame -> UFix -> (Tuple Pauli Pauli))) + (define (get-pair-at (%Frame row-map) row-index) + "Return the stabilizer <-> destabilizer pair associated with `row-index`." + (with-default (default-pair row-index) (map:lookup row-map row-index))) + + (declare get-stabilizer-at (Frame -> UFix -> Pauli)) + (define (get-stabilizer-at (%Frame row-map) row-index) + "Return the stabilizer associated with `row-index`." + (with-default (default-stabilizer row-index) (map fst (map:lookup row-map row-index)))) + + (declare get-destabilizer-at (Frame -> UFix -> Pauli)) + (define (get-destabilizer-at (%Frame row-map) row-index) + "Return the stabilizer associated with `row-index`." + (with-default (default-destabilizer row-index) (map snd (map:lookup row-map row-index)))) + + (define-instance (Into Frame String) + (define (into f) + (mconcat + (list:intersperse + (into #\newline) + (map (compose + (fn ((Tuple left right)) + (mconcat (make-list "(" (into left) " " (into right) ")"))) + (get-pair-at f)) + (range 0 (reduce max 0 (get-frame-support f))))))))) + +(coalton-toplevel + + (declare frame-> (Frame -> Pauli -> Pauli)) + (define (frame-> f p) + "Push a `Frame` downstream, conjugating a `Pauli`. If F represents U, then (P)(U) -> (U)[(U+)P(U)]." + (iter:fold! pauli-* + (make-pauli-i (get-pauli-sign p)) + (map (fn ((Tuple qubit operator)) + (match operator + ((I) (make-pauli-i Plus)) + ((X) (get-destabilizer-at f qubit)) + ((Y) (uncurry pauli-* (get-pair-at f qubit))) + ((Z) (get-stabilizer-at f qubit)))) + (map:entries (get-pauli-operator-map p))))) + + (declare frame<- (Frame -> Pauli -> Pauli)) + (define (frame<- f p) + "Push a `Frame` upstream and, conjugating a `Pauli`. If F represents U, then (U)(P) -> [(U)P(U+)](U)." + (pipe + (iter:fold! (fn ((Tuple p-prime q) (Tuple row-index (Tuple stabilizer-z destabilizer-x))) + (match (bimap (complement (commute? p-prime)) + (complement (commute? p-prime)) + (Tuple stabilizer-z destabilizer-x)) + ((Tuple (True) (False)) + (Tuple (pauli-* p-prime destabilizer-x) + (Cons (Tuple row-index X) q))) + ((Tuple (True) (True)) + (Tuple (msum (make-list p-prime stabilizer-z destabilizer-x)) + (Cons (Tuple row-index Y) q))) + ((Tuple (False) (True)) + (Tuple (pauli-* p-prime stabilizer-z) + (Cons (Tuple row-index Z) q))) + ((Tuple (False) (False)) (Tuple p-prime q)))) + (Tuple p Nil) + (map:entries (get-frame-row-map f))) + (fn ((Tuple (cl-quil.foust/pauli::%Pauli sign operator-map) q)) + (cl-quil.foust/pauli::%Pauli sign (map:merge operator-map (map:collect q)))))) + + (declare frame-inverse (Frame -> Frame)) + (define (frame-inverse f) + "Invert, or dagger, a `Frame`." + (Frame + (map (pair-with (compose + ;; [(U+)(Zi)(U)]+ = ((U+)+)(Zi)(U+) = (U)(Zi)(U+). + (bimap (frame<- f) (frame<- f)) + default-pair)) + (map:keys (get-frame-row-map f))))) + + (declare frame-compose (Frame -> Frame -> Frame)) + (define (frame-compose f-two f-one) + "Compose two `Frame`s such that the equivalent operator is (U2)(U1)." + (Frame + (map (pair-with (compose + ;; Since U2 is pushed downstream before U1, + ;; conjugation by U2 is prior to U1, and we can + ;; compose them by conjugating the pairs in U2 + ;; by U1. + (bimap (frame-> f-one) (frame-> f-one)) + (get-pair-at f-two))) + (list:union (get-frame-support f-one) + (get-frame-support f-two))))) + + (define-instance (Semigroup Frame) + (define <> frame-compose)) + + (define-instance (Monoid Frame) + (define mempty (default)))) + +(coalton-toplevel + + (declare map-pair ((PauliOperator -> Pauli) -> (Tuple Pauli Pauli))) + (define (map-pair f) + "Map the canonical stabilizer <-> destabilizer pair." + (bimap f f (Tuple Z X))) + + (declare frame-from-pauli-gate (PauliOperator -> UFix -> Frame)) + (define (frame-from-pauli-gate p qubit) + "Make a `Frame` corresponding to a Pauli gate." + (Frame + (iter:once + (Tuple qubit + (map-pair (fn (q) + ;; A Pauli gate is a 180deg rotation, so its + ;; action is to flip the sign of any Pauli + ;; string which anticommutes with it. + (make-pauli-one q qubit (if (commute? p q) Plus Minus)))))))) + + (declare frame-from-s (Boolean -> PauliOperator -> UFix -> Frame)) + (define (frame-from-s dag? p qubit) + "Make a `Frame` corresponding to sqrt(p) on `qubit`, daggered if `dag?`." + (Frame + (iter:once + (Tuple qubit + (map-pair (fn (q) + ;; An S (SDag) gate is a 90deg (270deg) rotation. + (make-pauli-one (if (commute? p q) q (pauli-operator-* p q)) + qubit + (if (== (levi-civita p q) (if dag? -1 +1)) Minus Plus)))))))) + + (declare frame-from-h (Sign -> PauliOperator -> UFix -> Frame)) + (define (frame-from-h sign p qubit) + "Make a `Frame` corresponding to a Hadamard: take p -> -p and flip other axis with `sign`." + (Frame + (iter:once + (Tuple qubit + (map-pair (fn (q) + ;; A Hadamard gate will interchange two axes. + (if (commute? p q) + (make-pauli-one q qubit Minus) + (make-pauli-one (pauli-operator-* p q) qubit sign)))))))) + + (declare frame-from-permute (Sign -> Sign -> Sign -> UFix -> Frame)) + (define (frame-from-permute sign-x sign-y sign-z qubit) + "Make a `Frame` corresponding to the right-handed permutation of axes specified by the `Signs`." + (let permuter-f = (if (== Plus (msum (make-list sign-x sign-y sign-z))) + next-pauli-operator prev-pauli-operator)) + (let signer-f = (fn (q) + (if (commute? (permuter-f q) (msum (make-list (if (== sign-x Plus) I X) + (if (== sign-y Plus) I Y) + (if (== sign-z Plus) I Z)))) + Plus Minus))) + (Frame + (iter:once + (Tuple qubit (map-pair (fn (q) (let ((p (permuter-f q))) + (make-pauli-one p qubit (signer-f p))))))))) + + (declare frame-from-tqe (PauliOperator -> PauliOperator -> UFix -> UFix -> Boolean -> Frame)) + (define (frame-from-tqe operator-one operator-two qubit-one qubit-two then-swap?) + "Make a `Frame` corresponding to a TQE, flipping the sign of a state where both qubits are in the corresponding (-) eigenstates." + (Frame + ;; The resulting frame will be + ;; + ;; row i : (if [P, Z], then Zi, else ZiQj) (if [P, X], then Xi, else XiQj) + ;; row j : (if [Q, Z], then Zj, else PiZj) (if [Q, X], then Xj, else PiXj) + ;; + ;; with the rows swapped if `then-swap?` + ;; + ;; e.g. CNOT i j = TQE Z X i j False + ;; + ;; row i : Zi XiXj + ;; row j : ZiZj Xj + (make-list (Tuple (if then-swap? qubit-two qubit-one) + (map-pair (fn (operator) + (make-pauli-two operator + (if (commute? operator operator-one) I operator-two) + qubit-one qubit-two Plus)))) + (Tuple (if then-swap? qubit-one qubit-two) + (map-pair (fn (operator) + (make-pauli-two (if (commute? operator operator-two) I operator-one) + operator qubit-one qubit-two Plus))))))) + + (declare frame-from-controlled (PauliOperator -> UFix -> UFix -> Frame)) + (define (frame-from-controlled p control-qubit target-qubit) + "Make a `Frame` from a controlled Pauli gate." + (frame-from-tqe Z p control-qubit target-qubit False)) + + (declare frame-from-swap (UFix -> UFix -> Frame)) + (define (frame-from-swap qubit-one qubit-two) + "Make a `Frame` for a SWAP operation." + (Frame (make-list (Tuple qubit-one (default-pair qubit-two)) + (Tuple qubit-two (default-pair qubit-one))))) + + (declare frame-from-npi2-rotation (Pauli -> UFix -> Frame)) + (define (frame-from-npi2-rotation p order) + "Make a `Frame` from an integral rotation about a `Pauli` p. Order 0 -> 0, 1 -> π/2, 2 -> π, 3 -> -π/2." + (cond + ((== 0 order) (default)) + ((== 2 order) + ;; These are 180deg rotations, implemented similarly to PauliGate Frames. + (Frame + (map (fn ((Tuple qubit operator-one)) + (Tuple qubit + (map-pair (fn (operator-two) + (make-pauli-one operator-two qubit + (if (commute? operator-one operator-two) Plus Minus)))))) + (map:entries (get-pauli-operator-map p))))) + ((disjoin (== 1) (== 3) order) + ;; These are 90deg and 270deg rotations, implemented similarly to S and SDag Frames. + (let ((sign (if (== 1 order) Plus Minus))) + (Frame + (map (fn ((Tuple qubit operator-one)) + (Tuple qubit + (map-pair (fn (operator-two) + (if (commute? operator-one operator-two) + (make-pauli-one operator-two qubit Plus) + (pauli-* (make-pauli-one operator-two qubit sign) p)))))) + (map:entries (get-pauli-operator-map p)))))) + (True (error "Invalid `order`. Must be 0, 1, 2, or 3."))))) diff --git a/src/foust/gate.lisp b/src/foust/gate.lisp new file mode 100644 index 000000000..3805df3a0 --- /dev/null +++ b/src/foust/gate.lisp @@ -0,0 +1,512 @@ +;;;; gate.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/gate + (:documentation + "This package represents `Gate`s and defines their interactions and compilations with/into/from `Node`s and `Frame`s.") + (:use + #:coalton + #:coalton-prelude) + (:use + #:cl-quil.foust/pauli + #:cl-quil.foust/frame + #:cl-quil.foust/assignments + #:cl-quil.foust/node) + (:local-nicknames + (#:iter #:coalton-library/iterator) + (#:list #:coalton-library/list) + (#:map #:coalton-library/ord-map)) + (:export + #:Gate + #:PauliGate + #:S + #:SDag + #:H + #:Permute + #:TQE + #:iSwap + #:Swap + #:Controlled + #:R + #:RR + #:RMult + #:R2 + #:R2Mult + #:Prep + #:PrepMult + #:Meas + #:MeasMult + #:get-gate-qubits + #:make-tqe + #:tqe? + #:dagger-tqe + #:gate->node + #:gate->frame + #:node->gate + #:row->gate)) + +(in-package #:cl-quil.foust/gate) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-type Gate + + ;; A standard single-qubit Pauli gate. + (PauliGate PauliOperator ;; this operator. + Ufix ;; qubit + ) + + ;; A gate equivalent to exp(-i(π/2)P) + (S PauliOperator ;; SQRT of this operator. + Ufix ;; qubit + ) + + ;; A gate equivalent to exp(i(π/2)P) + (SDag PauliOperator ;; SQRT^dag of this operator. + UFix ;; qubit + ) + + ;; A generalized Hadamard gate which can be conceptualized as a + ;; 180° rotation about a diagonal axis. + (H Sign ;; the other operators get this sign change + PauliOperator ;; this operator gets a sign flip + UFix ;; qubit + ) + + ;; A right-handed permutation of the axes ±x, ±y, and ±z. + (Permute Sign ;; + or - x axis + Sign ;; + or - y axis + Sign ;; + or - z axis + UFix ;; qubit + ) + + ;; A gate which performs a phase flip which each qubit is in the + ;; negative eigenstate of its respective Pauli operator. + (TQE PauliOperator ;; control on first qubit + PauliOperator ;; control on second qubit + UFix ;; first qubit + UFix ;; second qubit + Boolean ;; follow with a Swap? + ) + + ;; A gate which swaps the indexed qubits and adds a phase of i if + ;; they are in opposite eigenstates of Z. + (iSwap UFix ;; first qubit + UFix ;; second qubit + ) + + ;; A gate which swaps the indexed qubits. + (Swap UFix ;; first qubit + UFix ;; second qubit + ) + + ;; A subset of the TQE gates which performs the Pauli operator on + ;; the target (second) qubit, conditioned on the control (first) + ;; qubit being in the (-1) eigenstate of Z. + (Controlled PauliOperator ;; applied to target qubit conditionally + UFix ;; control qubit + UFix ;; target qubit + ) + + ;; A single-qubit rotation gate equivalent to exp(-i(θ/2)P) + (R PauliOperator ;; axis + Angle ;; angle + UFix ;; qubit + ) + + ;; A two-qubit rotation gate equivalent to exp(-i(θ/2)Pᵢ⊗Qⱼ) + (RR PauliOperator ;; axis defined by this on qubit one + PauliOperator ;; and this on qubit two + Angle ;; angle of rotation + UFix ;; qubit one + UFix ;; qubit two + ) + + ;; A multi-qubit rotation about a Pauli axis + (RMult Pauli ;; axis + Angle ;; angle of rotation + ) + + ;; A single-qubit rotation gate equivalent to + ;; exp[-i(θ/2)(cos(φ)P+sin(φ)Q) + (R2 PauliOperator ;; P + PauliOperator ;; Q + Angle ;; θ + Angle ;; φ + UFix ;; qubit + ) + + ;; A multi-qubit rotation along an axis within the span of two + ;; orthogonal Paulis. + (R2Mult Pauli ;; P + Pauli ;; Q + Angle ;; θ + Angle ;; φ + ) + + ;; A preparation of a single qubit in the eigenstate of P + ;; specified by the sign, and corrected by Q. + (Prep Sign ;; Prepare positive or negative eigenstate + PauliOperator ;; of this operator + PauliOperator ;; corrected by this operator. + UFix ;; qubit + ) + + ;; A preparation of multiple qubits in the positive eigenstate of + ;; P and corrected by Q. + (PrepMult Pauli ;; Prepare + eigenstate of this Pauli + Pauli ;; corrected by this Pauli. + ) + + ;; A measurement of ±Pᵢ stored in the variable specified by the + ;; second index. + (Meas Sign ;; measure 0 if this (+ or -) eigenstate is found. + PauliOperator ;; which operator to measure + UFix ;; qubit + UFix ;; classical-variable ID. + ) + + ;; A measurement of P stored in the variable specified. + (MeasMult Pauli ;; Measure this Pauli + UFix ;; classical-variable ID. + )) + + (declare get-gate-qubits (Gate -> (List UFix))) + (define (get-gate-qubits g) + "Get a `List` of the qubits on which `g` operates." + (match g + ((PauliGate _ qubit) + (singleton qubit)) + ((S _ qubit) + (singleton qubit)) + ((SDag _ qubit) + (singleton qubit)) + ((H _ _ qubit) + (singleton qubit)) + ((Permute _ _ _ qubit) + (singleton qubit)) + ((TQE _ _ qubit-one qubit-two _) + (make-list qubit-one qubit-two)) + ((iSwap qubit-one qubit-two) + (make-list qubit-one qubit-two)) + ((Controlled _ qubit-one qubit-two) + (make-list qubit-one qubit-two)) + ((Swap qubit-one qubit-two) + (make-list qubit-one qubit-two)) + ((R _ _ qubit) + (singleton qubit)) + ((RR _ _ _ qubit-one qubit-two) + (make-list qubit-one qubit-two)) + ((RMult pauli-p _) + (get-pauli-support pauli-p)) + ((R2 _ _ _ _ qubit) + (singleton qubit)) + ((R2Mult pauli-p pauli-q _ _) + (list:union (get-pauli-support pauli-p) + (get-pauli-support pauli-q))) + ((Prep _ _ _ qubit) + (singleton qubit)) + ((PrepMult pauli-p pauli-q) + (list:union (get-pauli-support pauli-p) + (get-pauli-support pauli-q))) + ((Meas _ _ qubit _) + (singleton qubit)) + ((MeasMult pauli-p _) + (get-pauli-support pauli-p)))) + + (define-instance (Into Gate String) + (define (into g) + (match g + ((PauliGate p qubit) + (mconcat (make-list (into p) (into qubit)))) + ((S p qubit) + (mconcat (make-list "S" (into p) (into qubit)))) + ((SDag p qubit) + (mconcat (make-list "Sdg" (into p) (into qubit)))) + ((H sign p qubit) + (mconcat (make-list "H " (into sign) (into p) (into qubit)))) + ((Permute sign-x sign-y sign-z qubit) + (mconcat (make-list "Permute " + (into sign-x) "x, " + (into sign-y) "y, " + (into sign-z) "z " + (into qubit)))) + ((TQE operator-one operator-two qubit-one qubit-two then-swap?) + (mconcat (make-list "TQE " + (into operator-one) (into qubit-one) " " + (into operator-two) (into qubit-two) + (if then-swap? " ; Swap" "")))) + ((iSwap qubit-one qubit-two) + (mconcat (make-list "iSwap " (into qubit-one) ", " (into qubit-two)))) + ((Controlled p control-qubit target-qubit) + (mconcat (make-list "C" (into p) " " (into control-qubit) ", " (into target-qubit)))) + ((Swap qubit-one qubit-two) + (mconcat (make-list "Swap " (into qubit-one) ", " (into qubit-two)))) + ((R p theta qubit) + (mconcat (make-list "R" (into p) " " (into theta) " " (into qubit)))) + ((RR operator-one operator-two theta qubit-one qubit-two) + (mconcat (make-list "RR " + (into operator-one) (into qubit-one) " " + (into operator-two) (into qubit-two) " " + (into theta)))) + ((RMult p theta) + (mconcat (make-list "RMult " (into p) " " (into theta)))) + ((R2 p q theta phi qubit) + (mconcat (make-list "R2 " + (into p) (into qubit) " " + (into q) (into qubit) " " + (into theta) " " (into phi)))) + ((R2Mult p q theta phi) + (mconcat (make-list "R2Mult " (into p) " " (into q) " " (into theta) " " (into phi)))) + ((Prep sign p q qubit) + (mconcat (make-list "Prep " (into sign) (into p) " " (into q) " " (into qubit)))) + ((PrepMult p q) + (mconcat (make-list "Prep " (into p) ", " (into q)))) + ((Meas sign p qubit v) + (mconcat (make-list "Meas " (into sign) (into p) (into qubit) " -> c" (into v)))) + ((MeasMult p v) + (mconcat (make-list "Meas " (into p) " -> c" (into v))))))) + + (declare make-tqe (PauliOperator -> PauliOperator -> UFix -> UFix -> Boolean -> Gate)) + (define (make-tqe operator-one operator-two qubit-one qubit-two then-swap?) + "Make a TQE `Gate` with sorted indices." + (if (< qubit-one qubit-two) + (TQE operator-one operator-two qubit-one qubit-two then-swap?) + (TQE operator-two operator-one qubit-two qubit-one then-swap?))) + + (declare tqe? (Gate -> Boolean)) + (define (tqe? g) + "Is `g` a two-qubit entangling (TQE) `Gate`?" + (match g + ((TQE _ _ _ _ _) True) + ((Controlled _ _ _) True) + ((iSwap _ _) True) + (_ False))) + + (declare dagger-tqe (Gate -> Gate)) + (define (dagger-tqe g) + "Given a two-qubit entangling (TQE) `gate`, return it's inverse." + (match g + ((TQE operator-one operator-two qubit-one qubit-two then-swap?) + (if then-swap? + (TQE operator-two operator-one qubit-one qubit-two then-swap?) + g)) + (_ (error "Expected TQE gate."))))) + +(coalton-toplevel + + (declare gate->node (Gate -> Node)) + (define (gate->node g) + "Cast a Gate to a Node" + (match g + ;; Clifford Gates + ((PauliGate p qubit) + (FrameNode (frame-from-pauli-gate p qubit))) + ((S p qubit) + (FrameNode (frame-from-s False p qubit))) + ((SDag p qubit) + (FrameNode (frame-from-s True p qubit))) + ((H sign p qubit) + (FrameNode (frame-from-h sign p qubit))) + ((Permute sign-x sign-y sign-z qubit) + (FrameNode (frame-from-permute sign-x sign-y sign-z qubit))) + ((TQE operator-one operator-two qubit-one qubit-two then-swap?) + (FrameNode (frame-from-tqe operator-one operator-two qubit-one qubit-two then-swap?))) + ((iSwap qubit-one qubit-two) + (FrameNode (msum (make-list (frame-from-tqe Z Z qubit-one qubit-two True) + (frame-from-s False Z qubit-one) + (frame-from-s False Z qubit-two))))) + ((Controlled p control-qubit target-qubit) + (FrameNode (frame-from-controlled p control-qubit target-qubit))) + ((Swap qubit-one qubit-two) + (FrameNode (frame-from-swap qubit-one qubit-two))) + + ;; Rotation Gates + ((R operator theta qubit) + (let ((p (make-pauli-one operator qubit Plus))) + (match (angle-order theta) + ((Some order) (FrameNode (frame-from-npi2-rotation p order))) + ((None) (RotationNode (Rotation p theta)))))) + ((RR operator-one operator-two theta qubit-one qubit-two) + (let ((p (make-pauli-two operator-one operator-two qubit-one qubit-two Plus))) + (match (angle-order theta) + ((Some order) (FrameNode (frame-from-npi2-rotation p order))) + ((None) (RotationNode (Rotation p theta)))))) + ((RMult p theta) + (match (angle-order theta) + ((Some order) (FrameNode (frame-from-npi2-rotation p order))) + ((None) (RotationNode (Rotation p theta))))) + ((R2 p q theta phi qubit) + (match (angle-order phi) + ((Some order) + (gate->node (R (if (even? order) p q) + (if (< 2 order) theta (negate theta)) + qubit))) + ((None) + (Rotation2Node (Rotation2 (make-pauli-one p qubit Plus) + (make-pauli-one q qubit Plus) + theta phi))))) + ((R2Mult p q theta phi) + (match (angle-order phi) + ((Some order) + (gate->node (RMult (if (even? order) p q) + (if (< 2 order) theta (negate theta))))) + ((None) (Rotation2Node (Rotation2 p q theta phi))))) + + ;; Preparation and Measurement Gates + ((Prep sign p q qubit) + (PreparationNode (Preparation (make-pauli-one p qubit sign) + (make-pauli-one q qubit Plus)))) + ((PrepMult p q) (PreparationNode (Preparation p q))) + ((Meas sign p qubit v) (MeasurementNode (Measurement (make-pauli-one p qubit sign) v))) + ((MeasMult p v) (MeasurementNode (Measurement p v))))) + + (declare gate->frame (Gate -> Frame)) + (define (gate->frame g) + "Extract a `Frame` from `g` if it is a `FrameNode`." + (match (gate->node g) + ((FrameNode f) f) + (_ (error "Cannot make Frame from Gate."))))) + +(coalton-toplevel + + (declare get-single-qubit-pair (Pauli -> (Tuple UFix PauliOperator))) + (define (get-single-qubit-pair p) + "If `p` acts on a single qubit, return it's index and associated operator, otherwise error." + (match (iter:collect! (map:entries (get-pauli-operator-map p))) + ((Cons pair (Nil)) pair) + (_ (error "Pauli does not act on exactly one qubit")))) + + (declare rotation->gate (Rotation -> Gate)) + (define (rotation->gate (Rotation p theta)) + "Wrap a single-qubit `Rotation` into a `Gate`." + (match (get-single-qubit-pair p) + ((Tuple qubit operator) + (R operator (if (== Minus (get-pauli-sign p)) (negate theta) theta) qubit)))) + + (declare rotation2->gate (Rotation2 -> Gate)) + (define (rotation2->gate (Rotation2 p q theta phi)) + "Wrap a single-qubit `Rotation2` into a `Gate`." + (match (Tuple (get-single-qubit-pair p) + (get-single-qubit-pair q)) + ((Tuple (Tuple qubit operator-p) + (Tuple %qubit operator-q)) + (if (/= qubit %qubit) + (error "`Rotation2` `Pauli`s do not have the same support.") + (R2 operator-p operator-q + (if (== Minus (get-pauli-sign p)) (negate theta) theta) + (if (xor (== Minus (get-pauli-sign p)) + (== Minus (get-pauli-sign q))) + (negate phi) phi) + qubit))))) + + (declare preparation->gate (Preparation -> Gate)) + (define (preparation->gate (Preparation p q)) + "Wrap a single-qubit `Preparation` into a `Gate`." + (match (Tuple (get-single-qubit-pair p) + (get-single-qubit-pair q)) + ((Tuple (Tuple qubit operator-p) + (Tuple %qubit operator-q)) + (if (/= qubit %qubit) + (error "`Preparation` `Pauli`s do not have the same support.") + (Prep (get-pauli-sign p) operator-p operator-q qubit))))) + + (declare measurement->gate (Measurement -> Gate)) + (define (measurement->gate (Measurement p v)) + "Wrap a single-qubit `Measurement` into a `Gate`." + (match (get-single-qubit-pair p) + ((Tuple qubit operator) + (Meas (get-pauli-sign p) operator qubit v)))) + + (declare node->gate (Node -> Gate)) + (define (node->gate n) + "Wrap a single-qubit non-Clifford `Node` into a `Gate`." + (match n + ((RotationNode rotation-r) + (rotation->gate rotation-r)) + ((Rotation2Node rotation2-r) + (rotation2->gate rotation2-r)) + ((PreparationNode preparation-p) + (preparation->gate preparation-p)) + ((MeasurementNode measurement-m) + (measurement->gate measurement-m)) + ((FrameNode _) (error "Do not use node->gate for FrameNode.")) + ((AssignmentsNode _) (error "Cannot make gate from Assignments."))))) + +(coalton-toplevel + + ;; The following helpers were designed to map the patterns in + ;; single-qubit Frames. There are 24 possible frames: + ;; 1 identity frame. + ;; 3 frames which correspond to Paulis: X, Y, and Z. + ;; 6 frames which correspond to 90° rotations: SX, SY, SZ, and their daggers. + ;; 6 frames which correspond to Hadamards: H±X H±Y H±Z. + ;; 8 frames which correspond to each possible right-handed permutation. + + ;; All Pauli Gate frames are (±Zᵢ ±Xᵢ) + (declare pauli-gate-helper (Sign -> Sign -> UFix -> Gate)) + (define (pauli-gate-helper sign-p sign-q qubit) + "Helper for casting row to `Gate` when row corresponds to `PauliGate`." + (PauliGate (pauli-operator-* (if (== Minus sign-p) X I) + (if (== Minus sign-q) Z I)) + qubit)) + + (declare permute-helper (Boolean -> Sign -> Sign -> PauliOperator -> PauliOperator -> UFix -> Gate)) + (define (permute-helper dag? sign-p sign-q p q qubit) + "Helper for casting row to `Gate` when row corresponds to `PauliGate`." + (Permute (sign-* (if dag? Plus Minus) + (if (== p X) + (msum (make-list Minus sign-p sign-q)) + sign-p)) + (sign-* (if dag? Minus Plus) + (if (== X p) + sign-p + (sign-* Minus sign-q))) + (sign-* (if dag? Minus Plus) + (if (== q Z) + (msum (make-list Minus sign-p sign-q)) + sign-q)) + qubit)) + + (declare h-helper (Sign -> Sign -> PauliOperator -> PauliOperator -> UFix -> Gate)) + (define (h-helper sign-p sign-q p _ qubit) + "Helper for casting row to `Gate` when row corresponds to `H`." + (H (if (== Minus sign-p) sign-q Plus) + (if (== p Z) Z (pauli-operator-* Z p)) + qubit)) + + (declare s-helper (Boolean -> Sign -> Sign -> PauliOperator -> PauliOperator -> UFix -> Gate)) + (define (s-helper dag? sign-p sign-q p q qubit) + "Helper for casting row to `Gate` when row corresponds to `S` or `SDag`." + ((if (== dag? + (cond + ((== p Z) (== Plus sign-q)) + ((== q X) (== Minus sign-p)) + (True (== Plus sign-p)))) + S SDag) + (if (== p Z) Z (pauli-operator-* Z p)) + qubit)) + + (declare row->gate (Boolean -> (Tuple UFix (Tuple Pauli Pauli)) -> Gate)) + (define (row->gate dag? (Tuple row-index (Tuple p q))) + "Cast a `Frame` row to a `Gate`." + (if (or (/= 1 (length (get-pauli-support p))) + (/= 1 (length (get-pauli-support q)))) + (error "Expected single-qubit Paulis for gate-from-row.") + (let ((operator-p (get-pauli-operator-at row-index p)) + (operator-q (get-pauli-operator-at row-index q)) + (sign-p (get-pauli-sign p)) + (sign-q (get-pauli-sign q))) + (if (commute? operator-p operator-q) + (error "Expected row with anti-commuting `Paulis`.") + (if (== 1 (levi-civita operator-p operator-q)) + (if (== Y (pauli-operator-* operator-p operator-q)) + (pauli-gate-helper sign-p sign-q row-index) + (permute-helper dag? sign-p sign-q operator-p operator-q row-index)) + (if (== (if (== Z operator-p) Minus sign-q) + (if (== X operator-q) Minus sign-p)) + (h-helper sign-p sign-q operator-p operator-q row-index) + (s-helper dag? sign-p sign-q operator-p operator-q row-index)))))))) diff --git a/src/foust/graph.lisp b/src/foust/graph.lisp new file mode 100644 index 000000000..35c3ca0a2 --- /dev/null +++ b/src/foust/graph.lisp @@ -0,0 +1,168 @@ +;;;; graph.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/graph + (:documentation + "This package represents Foust `Graph`s as `Map`s, storing incoming and outgoing `Node` indices, + +with special treatment for the terminal `Frame` and `Assignments`.") + (:use + #:coalton + #:coalton-prelude) + (:use + #:cl-quil.foust/frame + #:cl-quil.foust/assignments + #:cl-quil.foust/node) + (:local-nicknames + (#:iter #:coalton-library/iterator) + (#:map #:coalton-library/ord-map) + (#:tree #:coalton-library/ord-tree)) + (:export + #:Graph + #:get-graph-fresh-node-index + #:get-graph-node-map + #:get-graph-frame + #:get-graph-assignments + #:map-graph-frame + #:map-graph-assignments + #:map-graph-nodes + #:map-graph-edges + #:remove-vertex + #:add-vertex + #:add-edge + #:is-entry-at? + #:is-terminal-at? + #:get-entry-tuples + #:get-terminal-tuples + #:graph-any? + #:graph-empty? + #:graph-empty-except-terminal-measurements? + #:push-frame)) + +(in-package #:cl-quil.foust/graph) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-type Graph + "A D.A.G., storing the next available `Node` index, a `Map` from `Node` indices to + +The `Node`s themselves, paired with `Tree`s comprising the indices of the incoming + +and outgoing `Node`s, respectively." + (Graph UFix (map:Map UFix (Tuple Node (Tuple (tree:Tree UFix) (tree:Tree UFix)))) Frame Assignments)) + + (define-instance (Default Graph) + (define (default) (Graph 0 map:Empty (default) (default)))) + + (declare get-graph-fresh-node-index (Graph -> UFix)) + (define (get-graph-fresh-node-index (Graph fresh-node-index _ _ _)) fresh-node-index) + + (declare get-graph-node-map (Graph -> (map:Map UFix (Tuple Node (Tuple (tree:Tree UFix) (tree:Tree UFix)))))) + (define (get-graph-node-map (Graph _ node-map _ _)) node-map) + + (declare get-graph-frame (Graph -> Frame)) + (define (get-graph-frame (Graph _ _ f _)) f) + + (declare map-graph-frame ((Frame -> Frame) -> Graph -> Graph)) + (define (map-graph-frame func (Graph fresh-node-index node-map f a)) + (Graph fresh-node-index node-map (func f) a)) + + (declare get-graph-assignments (Graph -> Assignments)) + (define (get-graph-assignments (Graph _ _ _ a)) a) + + (declare map-graph-assignments ((Assignments -> assignments) -> Graph -> Graph)) + (define (map-graph-assignments func (Graph fresh-node-index node-map f a)) + (Graph fresh-node-index node-map f (func a)))) + +(coalton-toplevel + + (declare map-graph-nodes ((Node -> Node) -> Graph -> Graph)) + (define (map-graph-nodes func (Graph fresh-node-index node-map f a)) + "Map the `Node`s of a `Graph`." + (Graph fresh-node-index (map (map-fst func) node-map) f a)) + + (declare map-graph-edges (((tree:Tree UFix) -> (tree:Tree UFix)) -> Graph -> Graph)) + (define (map-graph-edges func (Graph fresh-node-index node-map f a)) + "Map the edges of a `Graph`." + (Graph fresh-node-index (map (map-snd (bimap func func)) node-map) f a))) + +(coalton-toplevel + + (declare remove-vertex (Graph -> UFix -> Graph)) + (define (remove-vertex (Graph fresh-node-index node-map f a) node-index) + "Remove a `Node` from a `Graph`." + (map-graph-edges (fn (edge) (with-default edge (tree:remove edge node-index))) + (Graph fresh-node-index (unwrap (map:remove node-map node-index)) f a))) + + (declare add-vertex (Graph -> Node -> Graph)) + (define (add-vertex (Graph fresh-node-index node-map f a) n) + "Add a `n` to the `Graph`." + (Graph (1+ fresh-node-index) + (map:insert-or-replace node-map fresh-node-index (Tuple n (Tuple tree:Empty tree:Empty))) + f a)) + + (declare add-edge (Graph -> UFix -> UFix -> Graph)) + (define (add-edge (Graph fresh-node-index node-map f a) from-index to-index) + "Add an edge from one `Node` to another." + (Graph fresh-node-index + (unwrap (map:update (map-snd (map-fst (flip tree:insert-or-replace from-index))) + (unwrap (map:update (map-snd (map-snd (flip tree:insert-or-replace to-index))) + node-map + from-index)) + to-index)) + f a))) + +(coalton-toplevel + + (declare is-entry-at? (Graph -> UFix -> Boolean)) + (define (is-entry-at? (Graph _ node-map _ _) node-index) + "Is the `Node` indexed by `node-index` pointed to by no others?" + (== tree:Empty (fst (snd (unwrap (map:lookup node-map node-index)))))) + + (declare is-terminal-at? (Graph -> UFix -> Boolean)) + (define (is-terminal-at? (Graph _ node-map _ _) node-index) + "Does the `Node` indexed by `node-index` point to no others?" + (== tree:Empty (snd (snd (unwrap (map:lookup node-map node-index)))))) + + (declare get-entry-tuples (Graph -> (iter:Iterator (Tuple UFix Node)))) + (define (get-entry-tuples (Graph _ node-map _ _)) + "Return entry `Node`s as an iterator of node index <-> `Node` pairs." + (map (map-snd fst) (iter:filter! (fn ((Tuple _ (Tuple _ (Tuple ins _)))) + (== tree:Empty ins)) + (map:entries node-map)))) + + (declare get-terminal-tuples (Graph -> (iter:Iterator (Tuple UFix Node)))) + (define (get-terminal-tuples (Graph _ node-map _ _)) + "Return terminal nodes as an iterator of (Node ID, Node)." + (map (map-snd fst) (iter:filter! (fn ((Tuple _ (Tuple _ (Tuple _ outs)))) + (== tree:Empty outs)) + (map:entries node-map))))) + +(coalton-toplevel + + (declare graph-empty? (Graph -> Boolean)) + (define (graph-empty? (Graph _ node-map _ _)) + "Is the `Graph` empty, except terminal `Frame` and `Assignments`?" + (none? (iter:next! (map:entries node-map)))) + + (declare graph-empty-except-terminal-measurements? (Graph -> Boolean)) + (define (graph-empty-except-terminal-measurements? (Graph _ node-map _ _)) + "Is the `Graph` empty, except terminal `MeasurementNode`s, `Frame`, and `Assignments`?" + (iter:and! (map (fn ((Tuple n (Tuple _ outs))) + (and (measurement-node? n) (== tree:Empty outs))) + (map:values node-map)))) + + (declare graph-any? ((Node -> Boolean) -> Graph -> Boolean)) + (define (graph-any? node-satisfies? (Graph _ node-map _ _)) + "Do any `Node`s in the `Graph` satisfy `node-satisfies?`" + (iter:any! node-satisfies? (map fst (map:values node-map))))) + +(coalton-toplevel + + (declare push-frame (Graph -> Frame -> Graph)) + (define (push-frame g f) + "Push `f` through `g` and merge it into `g`'s terminating `Frame`." + (pipe g (map-graph-nodes (frame-node-> f)) (map-graph-frame (flip <> f))))) diff --git a/src/foust/graphviz.lisp b/src/foust/graphviz.lisp new file mode 100644 index 000000000..3cf574cf3 --- /dev/null +++ b/src/foust/graphviz.lisp @@ -0,0 +1,81 @@ +;;;; graphviz.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/graphviz + (:use + #:coalton + #:coalton-prelude) + (:use + #:cl-quil.foust/graph) + (:local-nicknames + (#:iter #:coalton-library/iterator) + (#:list #:coalton-library/list) + (#:map #:coalton-library/ord-map)) + (:export #:graphviz-command + #:graphviz)) + +(in-package #:cl-quil.foust/graphviz) + +(named-readtables:in-readtable coalton:coalton) + +;; This package supports visualization of Foust Graphs via the `dot` +;; command. + +(coalton-toplevel + + ;; Consider adding to Standard Library. + + (declare mconcat! ((Monoid :a) => (Iterator :a) -> :a)) + (define (mconcat! iter) + (iter:fold! <> mempty iter)) + + (declare mconcatmap ((Foldable :a) (Monoid :b) => (:c -> :b) -> (:a :c) -> :b)) + (define (mconcatmap f xs) + (fold (fn (this that) (<> this (f that))) mempty xs)) + + (declare mconcatmap! ((Monoid :a) => (:b -> :a) -> (Iterator :b) -> :a)) + (define (mconcatmap! f iter) + (mconcat! (map f iter)))) + +(coalton-toplevel + + (declare graphviz-prelude (Graph -> String)) + (define (graphviz-prelude (Graph _ _ f a)) + "Populate the portion of the graphviz command which generates the terminating Frame and Assignment table." + (mconcat (make-list "F[label=\"" (into f) "\"] ; mu[label=\"" (into a) "\"]"))) + + (declare graphviz-define-nodes (Graph -> String)) + (define (graphviz-define-nodes (Graph _ node-map _ _)) + "Populate the portion of the graphviz command which generates the nodes." + (mconcatmap! + (fn ((Tuple node-index (Tuple n _))) + (mconcat (make-list "; " (into node-index) "[label=\"" (into n) "\"]"))) + (map:entries node-map))) + + (declare graphviz-draw-edges (Graph -> String)) + (define (graphviz-draw-edges (Graph _ node-map _ _)) + "Populate the portion of the graphviz command which connects the nodes." + (mconcatmap! + (fn ((Tuple node-index (Tuple _ (Tuple _ outs)))) + (mconcat (make-list " ; " (into node-index) " -> {" (mconcatmap (compose (<> " ") into) outs) " }"))) + (map:entries node-map))) + + (declare graphviz-command (Graph -> String -> String)) + (define (graphviz-command g pathname) + "Generate a command to use graphviz to display a graph." + (mconcat (make-list "echo '" + "digraph { fontname=\"Monospace:matrix=1 0 0 1\" ; rankdir=\"LR\" ; TBbalance=\"min\" ; " + (graphviz-prelude g) + (graphviz-define-nodes g) + (graphviz-draw-edges g) + " }" + "' | dot -Tsvg -Nshape=box -Gfontnames=svg -o " + pathname))) + + (declare graphviz (Graph -> String -> Unit)) + (define (graphviz g pathname) + "Given a graph and a pathname, store an .SVG graphviz of the graph." + (let ((command (graphviz-command g pathname))) + (lisp Unit (command) + (cl:progn (uiop:run-program command :force-shell cl:t) Unit))))) diff --git a/src/foust/node.lisp b/src/foust/node.lisp new file mode 100644 index 000000000..4b4bf55e4 --- /dev/null +++ b/src/foust/node.lisp @@ -0,0 +1,311 @@ +;;;; node.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/node + (:documentation + "This package represents `Node`s in a Foust `Graph`, which can be Rotations, Rotation2s, + +Preparations, Measurements, Frames, or Assignments.") + (:use + #:coalton + #:coalton-prelude) + (:use + #:cl-quil.foust/pauli + #:cl-quil.foust/frame + #:cl-quil.foust/assignments + #:cl-quil.foust/angle) + (:export + #:Angle + #:Angle + #:angle-order + #:angle->radians + #:Singlet + #:singlet->pauli + #:Factor + #:factor->pair + #:Rotation + #:Rotation2 + #:Preparation + #:Measurement + #:Node + #:FrameNode + #:AssignmentsNode + #:RotationNode + #:Rotation2Node + #:PreparationNode + #:MeasurementNode + #:clifford-node? + #:measurement-node? + #:frame-node-> + #:merge-nodes)) + +(in-package #:cl-quil.foust/node) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-class (Singlet :a) + "A class for representing node types which are defined by a single `Pauli`." + (singlet->pauli (:a -> Pauli))) + + (define-class (Factor :a) + "A class for representing node types which are defined by a pair of anticommuting `Pauli`s." + (factor->pair (:a -> (Tuple Pauli Pauli))))) + +(coalton-toplevel + + (define-type Rotation + "A `Rotation` represents `exp(-i(θ/2)*P)` where `θ` is the `Angle`, and `P` is the `Pauli`." + (Rotation Pauli Angle)) + + (define-instance (Singlet Rotation) + (define (singlet->pauli (Rotation p _)) p)) + + (define-instance (Into Rotation String) + (define (into (Rotation p theta)) + (mconcat (make-list "Rot[" (into p) ", " (into theta) "]")))) + + (define-type Rotation2 + "A `Rotation2` represents `exp[-i(θ/2)(cos(φ)P+sin(φ)Q)]` where `θ` and `φ` are the `Angle`s and `P` and `Q` are the `Pauli`s." + (Rotation2 Pauli Pauli Angle Angle)) + + (define-instance (Factor Rotation2) + (define (factor->pair (Rotation2 p q _ _)) (Tuple p q))) + + (define-instance (Into Rotation2 String) + (define (into (Rotation2 p q theta phi)) + (mconcat + (make-list + "Rot2[" (into p) ", " (into q) ", θ = " (into theta) ", φ = " (into phi) "]"))))) + +(coalton-toplevel + + (define-type Preparation + "A `Preparation` takes a state to an arbitary (+1 or -1) eigenstate of a `Pauli` and then applies the + +second `Pauli` as an operation, if necessary, to bring the state to the (+1) eigenstate of the first `Pauli`. + +This flexible representation of Preparations is convenient for stabilizer-based error correction." + (Preparation Pauli Pauli)) + + (define-instance (Factor Preparation) + (define (factor->pair (Preparation p q)) (Tuple p q))) + + (define-instance (Into Preparation String) + (define (into (Preparation p q)) + (mconcat (make-list "Prep[" (into p) ", " (into q) "]")))) + + (define-type Measurement + "A `Measurement` collapes the quantum state into an eigenstate of a `Pauli`, and stores 0 or 1 if the + +resulting state is the (+1) or (-1) eigenstate, respectively." + (Measurement Pauli UFix)) + + (define-instance (Singlet Measurement) + (define (singlet->pauli (Measurement p _)) p)) + + (define-instance (Into Measurement String) + (define (into (Measurement p v)) + (mconcat (make-list "Meas[" (into p) " -> c" (into v) "]"))))) + +(coalton-toplevel + + (define-type Node + (FrameNode Frame) + (AssignmentsNode Assignments) + (RotationNode Rotation) + (Rotation2Node Rotation2) + (PreparationNode Preparation) + (MeasurementNode Measurement)) + + (define-instance (Into Node String) + (define (into n) + (match n + ((FrameNode f) (into f)) + ((AssignmentsNode a) (into a)) + ((RotationNode rot) (into rot)) + ((Rotation2Node rot2) (into rot2)) + ((PreparationNode p) (into p)) + ((MeasurementNode m) (into m))))) + + (declare clifford-node? (Node -> Boolean)) + (define (clifford-node? n) + "Is `n` is a `FrameNode`?" + (match n + ((FrameNode _) True) + (_ False))) + + (declare measurement-node? (Node -> Boolean)) + (define (measurement-node? n) + "Is `n` is a `MeasurementNode`?" + (match n + ((MeasurementNode _) True) + (_ False)))) + +(coalton-toplevel + + (declare frame-node-> (Frame -> Node -> Node)) + (define (frame-node-> f n) + "Conjugate `n` by pushing a `f` downstream." + (match n + ((FrameNode f-prime) + ;; If `f` is U and `f-prime` is V, then we take (V)(U) -> + ;; (U)(V') = (U)[(U+)(V)(U)] so we return the equivalent of + ;; (U+)(V)(U). + (FrameNode (msum (make-list (frame-inverse f) f-prime f)))) + ((AssignmentsNode _) n) + ((RotationNode (Rotation p theta)) + (RotationNode (Rotation (frame-> f p) theta))) + ((Rotation2Node (Rotation2 p q theta phi)) + (Rotation2Node (Rotation2 (frame-> f p) (frame-> f q) theta phi))) + ((PreparationNode (Preparation p q)) + (PreparationNode (Preparation (frame-> f p) (frame-> f q)))) + ((MeasurementNode (Measurement p v)) + (MeasurementNode (Measurement (frame-> f p) v)))))) + +(coalton-toplevel + + (declare node-pauli-commute? (Node -> Pauli -> Boolean)) + (define (node-pauli-commute? n p) + "Does `n` commute with `p`?" + (match n + ((FrameNode f) + (== p (frame-> f p))) + ((AssignmentsNode _) True) + ((RotationNode (Rotation p-one _)) + (commute? p p-one)) + ((Rotation2Node (Rotation2 p-one q-one _ _)) + (all (commute? p) (make-list p-one q-one))) + ((PreparationNode (Preparation p-one q-one)) + (all (commute? p) (make-list p-one q-one))) + ((MeasurementNode (Measurement p-one _)) + (commute? p p-one)))) + + (define-instance (Commute Node) + (define (commute? n-one n-two) + (match (Tuple n-one n-two) + ;; Frame Nodes + ((Tuple (FrameNode f-one) (FrameNode f-two)) + (mcommute? f-one f-two)) + ((Tuple (FrameNode _) _) + (commute? n-two n-one)) + ;; Assignments Nodes + ((Tuple (AssignmentsNode a-one) (AssignmentsNode a-two)) + (mcommute? a-one a-two)) + ((Tuple (AssignmentsNode _) _) True) + ;; Pauli Nodes + ((Tuple (RotationNode (Rotation p _)) _) + (node-pauli-commute? n-two p)) + ((Tuple (Rotation2Node (Rotation2 p q _ _)) _) + (all (node-pauli-commute? n-two) (make-list p q))) + ((Tuple (PreparationNode (Preparation p q)) _) + (all (node-pauli-commute? n-two) (make-list p q))) + ((Tuple (MeasurementNode (Measurement p _)) _) + (node-pauli-commute? n-two p)))))) + +(coalton-toplevel + + (declare merge-nodes (Node -> Node -> (Optional (Tuple Node Assignments)))) + (define (merge-nodes n-one n-two) + "If `n-one` and `n-two` can be merged, merge them into a new `Node` and `Assignments`, otherwise return `None`." + (match (Tuple n-one n-two) + + ;; Compose frames. + ((Tuple (FrameNode f-one) (FrameNode f-two)) + (Some (Tuple (FrameNode (<> f-two f-one)) (default)))) + ;; Compose assignments. + ((Tuple (AssignmentsNode a-one) (AssignmentsNode a-two)) + (Some (Tuple (AssignmentsNode (<> a-two a-one)) (default)))) + ;; Compose rotations whose axes are the same. + ((Tuple (RotationNode (Rotation p-one theta-one)) + (RotationNode (Rotation p-two theta-two))) + (if (== (get-pauli-operator-map p-one) + (get-pauli-operator-map p-two)) + (let ((theta ((if (== (get-pauli-sign p-one) (get-pauli-sign p-two)) + -) theta-one theta-two))) + (Some (Tuple (match (angle-order theta) + ((Some order) (FrameNode (frame-from-npi2-rotation p-one order))) + ((None) (RotationNode (Rotation p-one theta)))) + (default)))) + None)) + ;; If the destabilizers are the same and the stabilizers comprise + ;; the same `PauliOperator`s then remove the first preparation. + ((Tuple (PreparationNode (Preparation p-one q-one)) + (PreparationNode (Preparation p-two q-two))) + (if (and (== q-one q-two) + (== (get-pauli-operator-map p-one) + (get-pauli-operator-map p-two))) + (Some (Tuple n-two (default))) + None)) + ;; Measuring the same stabilizer? remove the second measurement + ;; and resolve any sign discrepancy with an Assignments. + ((Tuple (MeasurementNode (Measurement p-one v-one)) + (MeasurementNode (Measurement p-two v-two))) + (if (== (get-pauli-operator-map p-one) + (get-pauli-operator-map p-two)) + (let ((e (ClassicalExpression (singleton v-one) (/= (get-pauli-sign p-one) + (get-pauli-sign p-two))))) + (Some (Tuple n-one (add-instruction (default) (Tuple v-two e))))) + None)) + ;; Compose Rotation2s which operate on the same axis. + ((Tuple (Rotation2Node (Rotation2 p-one q-one theta-one phi-one)) + (Rotation2Node (Rotation2 p-two q-two theta-two phi-two))) + (if (and (== (get-pauli-operator-map p-one) + (get-pauli-operator-map p-two)) + (== (get-pauli-operator-map q-one) + (get-pauli-operator-map q-two))) + (match (Tuple (== (get-pauli-sign p-one) (get-pauli-sign p-two)) + (== (get-pauli-sign q-one) (get-pauli-sign q-two))) + ((Tuple (True) (True)) + (cond + ((== phi-one phi-two) + (Some (Tuple (Rotation2Node (Rotation2 p-one q-one (+ theta-one theta-two) phi-one)) (default)))) + ((== phi-one (+ (Angle 1/2) phi-two)) + (Some (Tuple (Rotation2Node (Rotation2 p-one q-one (- theta-one theta-two) phi-one)) (default)))) + (True None))) + ((Tuple (True) (False)) + (cond + ((== phi-one (negate phi-two)) + (Some (Tuple (Rotation2Node (Rotation2 p-one q-one (+ theta-one theta-two) phi-one)) (default)))) + ((== phi-one (- (Angle 1/2) phi-two)) + (Some (Tuple (Rotation2Node (Rotation2 p-one q-one (- theta-one theta-two) phi-one)) (default)))) + (True None))) + ((Tuple (False) (True)) + (cond + ((== phi-one (negate phi-two)) + (Some (Tuple (Rotation2Node (Rotation2 p-one q-one (- theta-one theta-two) phi-one)) (default)))) + ((== phi-one (- (Angle 1/2) phi-two)) + (Some (Tuple (Rotation2Node (Rotation2 p-one q-one (+ theta-one theta-two) phi-one)) (default)))) + (True None))) + ((Tuple (False) (False)) + (cond + ((== phi-one phi-two) + (Some (Tuple (Rotation2Node (Rotation2 p-one q-one (- theta-one theta-two) phi-one)) (default)))) + ((== phi-one (+ (Angle 1/2) phi-two)) + (Some (Tuple (Rotation2Node (Rotation2 p-one q-one (+ theta-one theta-two) phi-one)) (default)))) + (True None)))) + None)) + + ;; A Rotation after a Preparation along the same axis will have + ;; no effect, so remove it. + ((Tuple (PreparationNode (Preparation p-one _)) + (RotationNode (Rotation p-two _))) + (if (== (get-pauli-operator-map p-one) (get-pauli-operator-map p-two)) + (Some (Tuple n-one (default))) + None)) + ;; A Measurement after a Preparation can be handled directly + ;; with an Assignments. + ((Tuple (PreparationNode (Preparation p-one _)) + (MeasurementNode (Measurement p-two v))) + (if (== (get-pauli-operator-map p-one) (get-pauli-operator-map p-two)) + (let ((b (ClassicalBit (/= (get-pauli-sign p-one) (get-pauli-sign p-two))))) + (Some (Tuple n-one (add-instruction (default) (Tuple v b))))) + None)) + ;; A rotation before a measurement will have no effect. + ((Tuple (RotationNode (Rotation p-one _)) + (MeasurementNode (Measurement p-two _))) + (if (== (get-pauli-operator-map p-one) (get-pauli-operator-map p-two)) + (Some (Tuple n-two (default))) + None)) + (_ None)))) diff --git a/src/foust/optimize.lisp b/src/foust/optimize.lisp new file mode 100644 index 000000000..f3596463b --- /dev/null +++ b/src/foust/optimize.lisp @@ -0,0 +1,194 @@ +;;;; optimize.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/optimize + (:documentation + "This package defines functions for compiling commuting multi-qubit measurements into single-qubit measurements, + +and (TODO:) for preparation-based optimizations applied before compiling a Graph to a Circuit.") + (:use + #:coalton + #:coalton-prelude) + (:use + #:cl-quil.foust/pauli + #:cl-quil.foust/frame + #:cl-quil.foust/assignments + #:cl-quil.foust/gate + #:cl-quil.foust/node + #:cl-quil.foust/circuit + #:cl-quil.foust/graph + #:cl-quil.foust/cost + #:cl-quil.foust/reduce) + (:local-nicknames + (#:iter #:coalton-library/iterator) + (#:list #:coalton-library/list)) + (:export + #:search-measurements + #:map-measurements + #:optimize-graph)) + +(in-package #:cl-quil.foust/optimize) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (declare pauli-agreement-at ((iter:IntoIterator :a Pauli) => UFix -> :a -> (Optional PauliOperator))) + (define (pauli-agreement-at qubit ps) + "Check if all `Pauli`s in a collection commute at a particular index, and return the nontrivial `PauliOperator` if so." + ;; Take all of the pauli operators at some index. + (let ((operators (map (get-pauli-operator-at qubit) (iter:into-iter ps)))) + ;; find the first non-identity operator. + (match (iter:next! (iter:filter! (/= I) operators)) + ;; if all remaining operators commute with the found operator + ;; then each is either identity or the same as that operator + ;; so that operator can be returned as the agreement of the + ;; `Pauli`s at the specified index. Otherwise, they do not + ;; agree. + ((Some p) (if (iter:every! (commute? p) operators) (Some p) None)) + ;; Otherwise, all `Pauli`s are identity on this qubit, so no + ;; non-trivial operator is agreed on. + ((None) None)))) + + (declare mask-support ((List UFix) -> Pauli -> (List UFix))) + (define (mask-support support p) + "Return the support of `p` which is also included in `support`." + (list:intersection support (get-pauli-support p)))) + +(coalton-toplevel + + (declare process-zero-cost-measurements ((Tuple4 (List Pauli) (List UFix) Frame Circuit) -> + (Tuple4 (List Pauli) (List UFix) Frame Circuit))) + (define (process-zero-cost-measurements tuple4-sqfc) + "Take all free `Measurement`s to `Meas`s in the `Circuit`." + (fold (fn ((Tuple4 ps support f c) p) + (match (mask-support support p) + ((Cons qubit (Nil)) + (Tuple4 (list:remove p ps) (list:remove qubit support) f + (pipe (Meas Plus (get-pauli-operator-at qubit p) qubit (get-circuit-next-fresh-index c)) + (add-gate c) + (map-circuit-assignments assignments-increment)))) + ((Cons _ _) (Tuple4 ps support f c)) + ((Nil) (Tuple4 (list:remove p ps) support f c)))) + tuple4-sqfc + (.first tuple4-sqfc))) + + (declare process-min-cost-measurement ((Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> (Tuple4 (List Pauli) (List UFix) Frame Circuit) + -> (Tuple4 (List Pauli) (List UFix) Frame Circuit))) + (define (process-min-cost-measurement clifford-costs then-swap?? (Tuple4 ps support f c)) + "Find the cheapest `Measurement` and reduce it's cost." + (match (iter:minimize-by! (compose length (mask-support support)) (iter:into-iter ps)) + ((Some p) + (if (== 0 (singlet-cost (subpauli support p))) + (process-zero-cost-measurements (Tuple4 ps support f c)) + (match (iter:minimize-by! (fn (g) (+ (clifford-costs g) (sum (map (delta-singlet-cost g) ps)))) + (reduce-singlet-node then-swap?? p)) + ((Some g) + (let ((f-prime (gate->frame (dagger-tqe g)))) + (Tuple4 (map (frame-> f-prime) ps) support (<> f-prime f) (add-gate c g)))) + ((None) (error "Unable to reduce Pauli."))))) + ((None) (Tuple4 ps support f c)))) + + (declare fold-measurements ((Gate -> IFix) + -> (UFix -> UFix -> Boolean) + -> (Tuple4 (List Pauli) (List UFix) Frame Circuit) + -> (Tuple4 (List Pauli) (List UFix) Frame Circuit))) + (define (fold-measurements clifford-costs then-swap?? tuple4-sqfc) + "Process all free `Measurement`s and then one cheap `Measurement`, and repeat until all `Measurement`s + +are processed into the `Circuit`." + (if (list:null? (.first tuple4-sqfc)) + tuple4-sqfc + (pipe tuple4-sqfc + process-zero-cost-measurements + (process-min-cost-measurement clifford-costs then-swap??) + (fold-measurements clifford-costs then-swap??)))) + + (declare fold-general ((Tuple4 (List Pauli) (List UFix) Frame Circuit) -> + (Tuple4 (List Pauli) (List UFix) Frame Circuit))) + (define (fold-general tuple4-sqfc) + "Implement all `PauliOperator`s which are agreed upon as single-qubit `Measurement`s." + (fold (fn ((Tuple4 ps support f c) qubit) + (match (pauli-agreement-at qubit ps) + ((Some p) + (Tuple4 ps (list:remove qubit support) f + (map-circuit-assignments + assignments-increment + (add-gate c (Meas Plus p qubit (get-circuit-next-fresh-index c)))))) + ((None) (Tuple4 ps support f c)))) + tuple4-sqfc + (.second tuple4-sqfc))) + + (declare search-measurements (Boolean -> (Gate -> IFix) -> (UFix -> UFix -> Boolean) + -> UFix -> (List Measurement) -> (Tuple Circuit Frame))) + (define (search-measurements general? clifford-costs then-swap?? fresh-index measurements) + "Collect a `List` of `Measurement`s as single-qubit `Measurement`s and `TQE`s in a `Circuit` and a `Frame` which + +encodes the `Assignments`." + (let ((ps (remove-duplicates (map singlet->pauli measurements)))) + (match (pipe (Tuple4 ps + (remove-duplicates (concatmap get-pauli-support ps)) + (default) + (set-circuit-assignments (default) (null-assignments fresh-index))) + (if general? fold-general id) + (fold-measurements clifford-costs then-swap??)) + ((Tuple4 _ _ f c) + (Tuple c (frame-inverse f))))))) + +(coalton-toplevel + + (declare get-measurement-pairs-from-measurements ((List Measurement) -> (List (Tuple Pauli UFix)))) + (define (get-measurement-pairs-from-measurements measurements) + "Get the `Measurement`s in a `List` as an `Iterator` of `Pauli`s and classical variable indices." + (map (fn ((Measurement p v)) (Tuple p v)) measurements)) + + (declare get-measurement-pairs-from-circuit (Circuit -> (List (Tuple Pauli UFix)))) + (define (get-measurement-pairs-from-circuit (Circuit gs _)) + "Get the `Meas` `Gate`s in a `Circuit` as an `Iterator` of `Pauli`s and classical variable indices." + (map (fn (measurement) + (match measurement + ((MeasurementNode (Measurement p v)) (Tuple p v)) + (_ (error "A `Node` that is not a `MeasurementNode` was missed by the filter.")))) + (filter measurement-node? (map gate->node gs)))) + + (declare map-single-measurement ((Tuple Pauli UFix) -> (List (Tuple Pauli UFix)) -> Frame -> + (Tuple UFix ClassicalExpression))) + (define (map-single-measurement (Tuple measurement-pauli v) measurement-pairs f) + "Recover a `Measurement` via a classical instruction, given a `Frame` from the `measurement-search` function." + (match (fold (fn (expression-assignment measurement-pair) + (match (get-pauli-support (fst measurement-pair)) + ((Cons qubit (Nil)) + (if (== (get-pauli-operator-at qubit measurement-pauli) + (get-pauli-operator-at qubit (frame-> f (fst measurement-pair)))) + (bimap (pauli-* (frame-> f (fst measurement-pair))) + (classical-xor (ClassicalVariable (snd measurement-pair))) + expression-assignment) + expression-assignment)) + (_ (error "Encountered non-single-qubit `Measurement`.")))) + (Tuple (default) (default)) + measurement-pairs) + ((Tuple p e) + (if (== (get-pauli-sign measurement-pauli) (get-pauli-sign p)) + (Tuple v e) + (Tuple v (classical-bit-flip e)))))) + + (declare map-measurements ((List Measurement) -> Circuit -> Frame -> Assignments)) + (define (map-measurements measurements c f) + "Given the output of the `measurement-search` function, provide the `Assignments` object that recovers + +the intended measurement statistics." + (let ((measurement-pairs (get-measurement-pairs-from-circuit c))) + (fold (fn (a measurement-pair) + (add-instruction a (map-single-measurement measurement-pair measurement-pairs f))) + (default) + (get-measurement-pairs-from-measurements measurements))))) + +(coalton-toplevel + + (declare optimize-graph (Boolean -> (Gate -> IFix) -> Graph -> Graph)) + (define (optimize-graph _preserve-state? _clifford-costs g) + "TODO: Add on-preparation intermediary optimization steps." + g)) diff --git a/src/foust/pauli-operator.lisp b/src/foust/pauli-operator.lisp new file mode 100644 index 000000000..2e8c9f95b --- /dev/null +++ b/src/foust/pauli-operator.lisp @@ -0,0 +1,160 @@ +;;;; pauli-operator-lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/pauli-operator + (:documentation + "This package represents Pauli Operators, I, X, Y, and Z.") + (:use + #:coalton + #:coalton-prelude) + (:export + #:Commute + #:commute? + #:mcommute? + #:PauliOperator + #:I + #:X + #:Y + #:Z + #:pauli-operator-* + #:next-pauli-operator + #:prev-pauli-operator + #:levi-civita)) + +(in-package #:cl-quil.foust/pauli-operator) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-class (Commute :a) + "A class of types whose objects may or may not commute with one another." + (commute? (:a -> :a -> Boolean))) + + (declare mcommute? ((Eq :a) (Semigroup :a) => :a -> :a -> Boolean)) + (define (mcommute? a b) + "Does (a,b) equal (b,a)?" + (== (<> a b) (<> b a)))) + +(coalton-toplevel + + (repr :enum) + (define-type PauliOperator + "This type represents the single-qubit Pauli Operators, I, X, Y, and Z, without storing their phases." + I X Y Z) + + (define-instance (Eq PauliOperator) + (define (== p q) + (match (Tuple p q) + ((Tuple (I) (I)) True) + ((Tuple (X) (X)) True) + ((Tuple (Y) (Y)) True) + ((Tuple (Z) (Z)) True) + (_ False)))) + + (define-instance (Default PauliOperator) + (define (default) I))) + +(coalton-toplevel + + (declare pauli-operator-* (PauliOperator -> PauliOperator -> PauliOperator)) + (define (pauli-operator-* p q) + "The product of two `PauliOperator`s, ignoring its phase." + (match (Tuple p q) + ((Tuple (I) _) q) + ((Tuple _ (I)) p) + ((Tuple (X) (X)) I) + ((Tuple (Y) (Y)) I) + ((Tuple (Z) (Z)) I) + ((Tuple (X) (Z)) Y) + ((Tuple (Z) (X)) Y) + ((Tuple (X) (Y)) Z) + ((Tuple (Y) (X)) Z) + ((Tuple (Y) (Z)) X) + ((Tuple (Z) (Y)) X))) + + (define-instance (Semigroup PauliOperator) + (define <> pauli-operator-*)) + + (define-instance (Monoid PauliOperator) + (define mempty I))) + +(coalton-toplevel + + (define-instance (Commute PauliOperator) + (define (commute? p q) + ;; Two `PauliOperator`s commute if and only if either at least + ;; one of them is `I` or if they are the same `PauliOperator`. + (match (Tuple p q) + ((Tuple (I) _) True) + ((Tuple _ (I)) True) + ((Tuple (X) (X)) True) + ((Tuple (Y) (Y)) True) + ((Tuple (Z) (Z)) True) + (_ False)))) + + (declare next-pauli-operator (PauliOperator -> PauliOperator)) + (define (next-pauli-operator p) + "Return the next `PauliOperator`, cyclically: `X` -> `Y` -> `Z`. `I` emits an error." + (match p + ((I) (error "`I` has no next pauli operator.")) + ((X) Y) + ((Y) Z) + ((Z) X))) + + (declare prev-pauli-operator (PauliOperator -> PauliOperator)) + (define (prev-pauli-operator p) + "Return the previous `PauliOperator`, cyclically: `X` <- `Y` <- `Z`. `I` emits an error." + (match p + ((I) (error "`I` has no previous pauli operator.")) + ((X) Z) + ((Y) X) + ((Z) Y))) + + (declare levi-civita (PauliOperator -> PauliOperator -> IFix)) + (define (levi-civita p q) + "Return 0 if `p` and `q` commute, 1 if they are cyclic, and -1 if they are anti-cyclic, + +according to the cycle `X` -> `Y` -> `Z`." + (match (Tuple p q) + ((Tuple (I) _) 0) + ((Tuple _ (I)) 0) + ((Tuple (X) (X)) 0) + ((Tuple (Y) (Y)) 0) + ((Tuple (Z) (Z)) 0) + ((Tuple (X) (Y)) 1) + ((Tuple (Y) (Z)) 1) + ((Tuple (Z) (X)) 1) + ((Tuple (Z) (Y)) -1) + ((Tuple (Y) (X)) -1) + ((Tuple (X) (Z)) -1)))) + +(coalton-toplevel + + (define-instance (Into PauliOperator Char) + (define (into p) + (match p + ((I) #\I) + ((X) #\X) + ((Y) #\Y) + ((Z) #\Z)))) + + (define-instance (Into PauliOperator String) + (define (into p) + (match p + ((I) "I") + ((X) "X") + ((Y) "Y") + ((Z) "Z")))) + + (define-instance (TryInto Char PauliOperator String) + (define (tryinto char) + (match char + (#\I (Ok I)) + (#\X (Ok X)) + (#\Y (Ok Y)) + (#\Z (Ok Z)) + (_ (Err (mconcat (make-list "`Char` #\\" (into char) " cannot be represented as a `PauliOperator`. + +Only the `Char`s #\\I, #\\X, #\\Y, and #\\Z can be represented as `PauliOperator`s.")))))))) diff --git a/src/foust/pauli.lisp b/src/foust/pauli.lisp new file mode 100644 index 000000000..5e2a96307 --- /dev/null +++ b/src/foust/pauli.lisp @@ -0,0 +1,210 @@ +;;;; pauli.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/pauli + (:documentation + "This package represents Hermitian Pauli Strings sparsely, as `Map`s with qubit <-> `PauliOperator` + +key <-> value pairs, and a `Sign` to indicate a phase of +1 or -1.") + (:use + #:coalton + #:coalton-prelude) + (:use + #:cl-quil.foust/sign + #:cl-quil.foust/pauli-operator) + (:local-nicknames + (#:iter #:coalton-library/iterator) + (#:list #:coalton-library/list) + (#:map #:coalton-library/ord-map)) + (:export + #:Commute + #:commute? + #:mcommute? + #:PauliOperator + #:I + #:X + #:Y + #:Z + #:pauli-operator-* + #:next-pauli-operator + #:prev-pauli-operator + #:levi-civita + #:Sign + #:Plus + #:Minus + #:sign-* + #:Pauli + #:Pauli + #:get-pauli-sign + #:get-pauli-operator-map + #:get-pauli-operator-at + #:get-pauli-support + #:subpauli + #:make-pauli-i + #:make-pauli-one + #:make-pauli-two + #:pauli-*)) + +(in-package #:cl-quil.foust/pauli) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (define-type Pauli (%Pauli Sign (map:Map UFix PauliOperator))) + + (declare Pauli ((iter:IntoIterator :collection (Tuple UFix PauliOperator)) => Sign -> :collection -> Pauli)) + (define (Pauli sign operator-map) + "Construct a `Pauli` from a `Sign` and a collection of qubit <-> `PauliOperator` pairs." + (%Pauli sign (iter:collect! (iter:filter! (compose (complement default?) snd) (iter:into-iter operator-map))))) + + (declare get-pauli-sign (Pauli -> Sign)) + (define (get-pauli-sign (%Pauli sign _)) sign) + + (declare get-pauli-operator-map (Pauli -> (map:Map UFix PauliOperator))) + (define (get-pauli-operator-map (%Pauli _ operator-map)) operator-map) + + (define-instance (Eq Pauli) + (define (== (%Pauli sign-one operator-map-one) (%Pauli sign-two operator-map-two)) + (and (== sign-one sign-two) (== operator-map-one operator-map-two)))) + + (define-instance (Default Pauli) + (define (default) (%Pauli Plus map:Empty)))) + +(coalton-toplevel + + (declare get-pauli-operator-at (UFix -> Pauli -> PauliOperator)) + (define (get-pauli-operator-at qubit (%Pauli _ operator-map)) + "Return the `PauliOperator` assigned to the qubit specified." + (defaulting-unwrap (map:lookup operator-map qubit))) + + (declare get-pauli-support (Pauli -> (List UFix))) + (define (get-pauli-support (%Pauli _ operator-map)) + "Return a `List` of the qubits to which a `Pauli` assigns non-identity operators." + (iter:collect! (map:keys operator-map))) + + (declare subpauli ((List UFix) -> Pauli -> Pauli)) + (define (subpauli qubits (%Pauli sign operator-map)) + "Create a `Pauli` which operates only on the qubits in `qubits`, + +with the `Sign` and `PauliOperator`s from the given `Pauli`." + (%Pauli sign (iter:collect! + (iter:filter! + (compose (flip list:member qubits) fst) + (map:entries operator-map)))))) + +(coalton-toplevel + + (define-instance (Commute Pauli) + (define (commute? p q) + ;; Two `Pauli`s commute if their respective `PauliOperator`s + ;; anti-commute at an even number of qubits. By folding with + ;; `boolean-xor`, the `Boolean` `True` will be flipped once for + ;; each anti-commuting pair of `PauliOperator`s. + (fold boolean-xor + True + (map (fn (qubit) + (not (commute? (get-pauli-operator-at qubit p) + (get-pauli-operator-at qubit q)))) + ;; We take the intersection of the supports because, + ;; to all other qubits, at least one of the two + ;; `Pauli`s necessarily associates the identity + ;; `PauliOperator`. + (list:intersection (get-pauli-support p) + (get-pauli-support q))))))) + +(coalton-toplevel + + (declare make-pauli-i (Sign -> Pauli)) + (define (make-pauli-i sign) + "If `sign` is `Plus`, make the universal stabilizer +I, otherwise the universal destabilizer -I." + (%Pauli sign map:Empty)) + + (declare make-pauli-one (PauliOperator -> UFix -> Sign -> Pauli)) + (define (make-pauli-one operator qubit sign) + "Make a `Pauli` that acts on a single qubit." + (Pauli sign (singleton (Tuple qubit operator)))) + + (declare make-pauli-two (PauliOperator -> PauliOperator -> UFix -> UFix -> Sign -> Pauli)) + (define (make-pauli-two operator-one operator-two qubit-one qubit-two sign) + "Make a `Pauli` that acts on two qubits." + (Pauli sign (make-list (Tuple qubit-one operator-one) (Tuple qubit-two operator-two))))) + +(coalton-toplevel + + (declare pauli-product-phase (Pauli -> Pauli -> IFix)) + (define (pauli-product-phase p q) + "Returns the phase of the product of two `Pauli`s. 1 -> 0, i -> 1, -1 -> 2, -i -> 3." + ((flip mod 4) + (sum + (cons (if (== (get-pauli-sign p) (get-pauli-sign q)) 0 2) + ;; Every anti-cyclic pair of `PauliOperator`s contributes + ;; -i to the phase, and every cyclic pair contributes i to + ;; the phase. + (map (fn (qubit) + (levi-civita (get-pauli-operator-at qubit p) + (get-pauli-operator-at qubit q))) + ;; Here, we take the intersection because at any + ;; qubit to which only either `p` or `q` assigns a + ;; `PauliOperator`, we are guaranteed at least one of + ;; the operands are identity, so the contribution to + ;; the product phase is 0. + (list:intersection (get-pauli-support p) + (get-pauli-support q))))))) + + (declare pauli-* (Pauli -> Pauli -> Pauli)) + (define (pauli-* p q) + "If Q and Q commute, return the PQ, otherwise, return -iPQ. + +This is the _Hermitian product_ which closes the group of Hermitian paulis." + (Pauli + ;; If P and Q commute, then the phase of PQ will be either +1 (0) + ;; or -1 (2). Otherwise, the phase will be either i (1) or -i + ;; (3). In the case that P and Q anticommute and PQ has a phase + ;; of i, the Hermitian product -iPQ will have a phase of -i*i=1. + (if (> 2 (pauli-product-phase p q)) Plus Minus) + (map (pair-with (fn (qubit) + (pauli-operator-* (get-pauli-operator-at qubit p) + (get-pauli-operator-at qubit q)))) + (list:union (get-pauli-support p) + (get-pauli-support q))))) + + (define-instance (Semigroup Pauli) + (define <> pauli-*)) + + (define-instance (Monoid Pauli) + (define mempty (default)))) + +(coalton-toplevel + + (define-instance (Into Pauli String) + (define (into (%Pauli sign operator-map)) + (if (== map:Empty operator-map) + (mconcat (make-list "(" (into sign) " I)")) + (mconcat (make-list + "(" + (into sign) + ((iter:fold! <> mempty) + (map (fn ((Tuple qubit operator)) + (mconcat (make-list " " (into operator) (into qubit)))) + (map:entries operator-map))) + ")"))))) + + (declare enumerate ((List :a) -> (List (Tuple UFix :a)))) + (define (enumerate xs) + (iter:collect! (iter:enumerate! (iter:into-iter xs)))) + + (define-instance (TryInto String Pauli String) + (define (tryinto string-p) + (let ((cs (iter:collect! (coalton-library/string:chars string-p))) + (bad-input-err (Err "Only `String`s in the form \"_sign_PPPPP..PPPP\" can be represented as `Pauli`s, + +e.g., \"+IIXZZIY\" for (+ X2 Z3 Z4 Y6), or \"-ZIX\" for (- Z0 X2)."))) + (match cs + ((Nil) bad-input-err) + ((Cons sign-c pauli-operators-cs) + (match (tryinto sign-c) + ((Err sign-err) (Err sign-err)) + ((Ok sign-s) + (Ok (Pauli sign-s (enumerate (map (compose unwrap tryinto) pauli-operators-cs)))))))))))) diff --git a/src/foust/reduce.lisp b/src/foust/reduce.lisp new file mode 100644 index 000000000..f50919c9b --- /dev/null +++ b/src/foust/reduce.lisp @@ -0,0 +1,205 @@ +;;;; reduce.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/reduce + (:documentation + "This package defines functions for producing `Iterator`s of `TQE` gates which, by conjugation, + +reduce the costs of various elements involved in a Foust.") + (:use + #:coalton + #:coalton-prelude) + (:use + #:cl-quil.foust/pauli + #:cl-quil.foust/frame + #:cl-quil.foust/node + #:cl-quil.foust/gate) + (:local-nicknames + (#:iter #:coalton-library/iterator) + (#:list #:coalton-library/list) + (#:map #:coalton-library/ord-map)) + (:export + #:reduce-singlet-node + #:reduce-node + #:reduce-row)) + +(in-package #:cl-quil.foust/reduce) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (declare permsof2 ((List :a) -> (List (Tuple :a :a)))) + (define (permsof2 l) + "Create a `List` of pairs of elements in `l`." + (match l + ((Nil) Nil) + ((Cons e es) + (mconcat + (make-list (map (Tuple e) es) + (map (flip Tuple e) es) + (permsof2 es)))))) + + (declare find-singlet-tqe ((UFix -> UFix -> Boolean) -> (Tuple UFix PauliOperator) -> (Tuple UFix PauliOperator) -> (Iterator Gate))) + (define (find-singlet-tqe then-swap?? (Tuple qubit-one operator-one) (Tuple qubit-two operator-two)) + "Given two non-identity `PauliOperator`s, return an `Iterator` of `TQE`s which will take the first `PauliOperator` to identity." + (let ((then-swap? (then-swap?? qubit-one qubit-two))) + (if (== qubit-one qubit-two) + iter:Empty + (map (fn (operator) (make-tqe operator-one operator qubit-one qubit-two then-swap?)) + (iter:into-iter (list:remove operator-two (make-list X Y Z))))))) + + (declare reduce-singlet-node ((UFix -> UFix -> Boolean) -> Pauli -> (Iterator Gate))) + (define (reduce-singlet-node then-swap?? p) + "Return `TQE`s which will reduce the support of a given `Pauli` by one." + (iter:flat-map! (uncurry (find-singlet-tqe then-swap??)) + (iter:into-iter + (permsof2 + (iter:collect! (map:entries (get-pauli-operator-map p)))))))) + +(coalton-toplevel + + (declare find-factor-tqe ((UFix -> UFix -> Boolean) + -> (Tuple UFix (Tuple PauliOperator PauliOperator)) + -> (Tuple UFix (Tuple PauliOperator PauliOperator)) + -> (Iterator Gate))) + (define (find-factor-tqe then-swap?? + (Tuple qubit-one (Tuple p-one q-one)) + (Tuple qubit-two (Tuple p-two q-two))) + "Given two pairs of `PauliOperator`s, return an iterator of `TQE`s which will reduce the cost contributed by the pairs." + (if (== qubit-one qubit-two) + iter:Empty + (let ((then-swap? (then-swap?? qubit-one qubit-two)) + (r-one (pauli-operator-* p-one q-one)) + (r-two (pauli-operator-* p-two q-two))) + (match (Tuple (not (commute? p-one q-one)) (not (commute? p-two q-two))) + ((Tuple (True) (True)) + ;; Case: {p1,q1}={p2,q2}=0 can be reduced to [p1,q1]=[p2,q2]=0 + (iter:into-iter + (make-list + (make-tqe p-one r-two qubit-one qubit-two then-swap?) + (make-tqe q-one r-two qubit-one qubit-two then-swap?) + (make-tqe p-one q-two qubit-one qubit-two then-swap?)))) + ((Tuple (True) (False)) + ;; Case: {p1,q1}=[p2,q2]=0 will be handled when i <-> j below. + iter:Empty) + ((Tuple (False) (True)) + ;; Case: [p1,q1]={p2,q2}=0 can be reduced to p1=q1=I, {p2,q2}=0 + (iter:once + (if (== I p-one) + (make-tqe q-one p-two qubit-one qubit-two then-swap?) + (make-tqe p-one (if (== I q-one) q-two r-two) qubit-one qubit-two then-swap?)))) + ((Tuple (False) (False)) + ;; Case: [p1,q1]=[p2,q2]=0 can be reduced to p1=q1=I, [p2,q2]=0 + ;; only if (p1,p2)=(q1,q2), or if either (p1,p2) or (q1,q2) = (I,I) + (cond + ((== (Tuple p-one p-two) (Tuple q-one q-two)) + (find-singlet-tqe then-swap?? (Tuple qubit-one p-one) (Tuple qubit-two p-two))) + ((disjoin (== (Tuple p-one p-two)) (== (Tuple q-one q-two)) (Tuple I I)) + (find-singlet-tqe then-swap?? (Tuple qubit-one r-one) (Tuple qubit-two r-two))) + (True iter:empty))))))) + + (declare reduce-factor-node ((UFix -> UFix -> Boolean) -> Pauli -> Pauli -> (Iterator Gate))) + (define (reduce-factor-node then-swap?? p q) + "Return `TQE`s which will reduce the cost of two anti-commuting `Pauli`s by one." + (iter:flat-map! (uncurry (find-factor-tqe then-swap??)) + (iter:into-iter + (permsof2 (map (pair-with (fn (qubit) + (Tuple (get-pauli-operator-at qubit p) + (get-pauli-operator-at qubit q)))) + (list:union (get-pauli-support p) + (get-pauli-support q)))))))) + +(coalton-toplevel + + (declare reduce-node ((UFix -> UFix -> Boolean) -> Node -> (Iterator Gate))) + (define (reduce-node then-swap?? n) + "Return `TQE`s which reduce the cost of a non-Clifford `node`." + (match n + ((FrameNode _) (error "Cannot reduce `FrameNode`.")) + ((AssignmentsNode _) (error "Cannot reduce `AssignmentsNode`.")) + ((RotationNode (Rotation p _)) (reduce-singlet-node then-swap?? p)) + ((Rotation2Node (Rotation2 p q _ _)) (reduce-factor-node then-swap?? p q)) + ((PreparationNode (Preparation p q)) (reduce-factor-node then-swap?? p q)) + ((MeasurementNode (Measurement p _)) (reduce-singlet-node then-swap?? p))))) + +(coalton-toplevel + + (declare reduce-canonical-entry-tqe ((UFix -> UFix -> Boolean) + -> (Tuple UFix (Tuple PauliOperator PauliOperator)) + -> (Tuple UFix (Tuple PauliOperator PauliOperator)) + -> (Iterator Gate))) + (define (reduce-canonical-entry-tqe then-swap?? canonical-entry extraneous-entry) + "Given a canonical entry, `PauliOperator` pair corresponding to qubit index = row index, and an extraneous entry, + +return `TQE`s which increases the support of the canonical entry and/or reduces the support of the extraneous entry." + (let ((operators (make-list X Y Z))) + (match (if (then-swap?? (fst canonical-entry) (fst extraneous-entry)) + (Tuple True (Tuple extraneous-entry canonical-entry)) + (Tuple False (Tuple canonical-entry extraneous-entry))) + ((Tuple then-swap? (Tuple (Tuple qubit-one (Tuple p-one q-one)) + (Tuple qubit-two (Tuple p-two q-two)))) + (cond + ((or (conjoin (== p-one) (== q-one) I) + (conjoin (== p-two) (== q-two) I)) + ;; Case: p1=q1=I can be raised to [p1,q1]=0 + (iter:into-iter + (do + (r-one <- operators) + (r-two <- (pipe operators (if (not (commute? p-two q-two)) id + (list:remove-if (disjoin (== p-two) (== q-two)))))) + (pure (make-tqe r-one r-two qubit-one qubit-two then-swap?))))) + ((or (conjoin (== p-one) (== p-two) I) + (conjoin (== q-one) (== q-two) I) + (== (Tuple p-one p-two) (Tuple q-one q-two))) + ;; Case: p1=p2=I or q1,q2=I or (p1p2)=(q1q2) can be reduced to p2=q2=I + (find-singlet-tqe (fn (_ _) then-swap?) + (Tuple qubit-two (if (== p-two I) q-two p-two)) + (Tuple qubit-one (if (== p-one I) q-one p-one)))) + ((and (commute? p-one q-one) (not (commute? p-two q-two))) + (if then-swap? + iter:Empty + (iter:into-iter + (do + (r-one <- (list:remove-if (disjoin (== p-one) (== q-one)) operators)) + (r-two <- (list:remove (pauli-operator-* (if (== p-one I) I q-two) + (if (== q-one I) I p-two)) + operators)) + (pure (make-tqe r-one r-two qubit-one qubit-two then-swap?)))))) + ((and (not (commute? p-one q-one)) (commute? p-two q-two)) + (if then-swap? + (iter:into-iter + (append (map (fn (r-two) + (make-tqe (pauli-operator-* (if (== p-two I) I q-one) + (if (== q-two I) I p-one)) + r-two qubit-one qubit-two then-swap?)) + operators) + (map (fn (r-one) + (make-tqe r-one (if (== p-two I) q-two p-two) qubit-one qubit-two then-swap?)) + (list:remove (pauli-operator-* (if (== p-two I) I q-one) + (if (== q-two I) I p-one)) + operators)))) + (iter:chain! + (find-factor-tqe (fn (_ _) then-swap?) + (Tuple qubit-one (Tuple p-one q-one)) + (Tuple qubit-two (Tuple p-two q-two))) + (find-factor-tqe (fn (_ _) then-swap?) + (Tuple qubit-two (Tuple p-two q-two)) + (Tuple qubit-one (Tuple p-one q-one)))))) + (True iter:Empty)))))) + + (declare reduce-row ((UFix -> UFix -> Boolean) -> (Tuple UFix (Tuple Pauli Pauli)) -> (Iterator Gate))) + (define (reduce-row then-swap?? (Tuple row-index (Tuple p q))) + "Return `TQE`s which will reduce the cost of a `Frame` row." + (let ((canonical-entry (Tuple row-index (Tuple (get-pauli-operator-at row-index p) + (get-pauli-operator-at row-index q)))) + (extraneous-entries (map (pair-with (fn (qubit) + (Tuple (get-pauli-operator-at qubit p) + (get-pauli-operator-at qubit q)))) + (list:remove row-index (list:union (get-pauli-support p) + (get-pauli-support q)))))) + (iter:chain! (iter:flat-map! (uncurry (find-factor-tqe then-swap??)) + (iter:into-iter (permsof2 extraneous-entries))) + (iter:flat-map! (reduce-canonical-entry-tqe then-swap?? canonical-entry) + (iter:into-iter extraneous-entries)))))) diff --git a/src/foust/sign.lisp b/src/foust/sign.lisp new file mode 100644 index 000000000..a601bfc9b --- /dev/null +++ b/src/foust/sign.lisp @@ -0,0 +1,70 @@ +;;;; sign.lisp +;;;; +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil.foust/sign + (:documentation + "This package represents signs, `+` and `-`.") + (:use + #:coalton + #:coalton-prelude) + (:export + #:Sign + #:Plus + #:Minus + #:sign-*)) + +(in-package #:cl-quil.foust/sign) + +(named-readtables:in-readtable coalton:coalton) + +(coalton-toplevel + + (repr :enum) + (define-type Sign Plus Minus) + + (define-instance (Eq Sign) + (define (== sign-one sign-two) + (match (Tuple sign-one sign-two) + ((Tuple (Plus) (Plus)) True) + ((Tuple (Minus) (Minus)) True) + (_ False)))) + + (define-instance (Default Sign) + (define (default) Plus))) + +(coalton-toplevel + + (declare sign-* (Sign -> Sign -> Sign)) + (define (sign-* sign-one sign-two) + "Returns `Plus` if `sign-one` and `sign-two` are equal, otherwise `Minus`." + (if (== sign-one sign-two) Plus Minus)) + + (define-instance (Semigroup Sign) + (define <> sign-*)) + + (define-instance (Monoid Sign) + (define mempty Plus))) + +(coalton-toplevel + + (define-instance (TryInto Char Sign String) + (define (tryinto char) + (match char + (#\+ (Ok Plus)) + (#\- (Ok Minus)) + (_ (Err (mconcat (make-list "`Char` #\\" (into char) " cannot be represented as a `Sign`. + +Only the `Char`s #\\+ and #\\- can be represented as `Sign`s."))))))) + + (define-instance (Into Sign Char) + (define (into sign-s) + (match sign-s + ((Plus) #\+) + ((Minus) #\-)))) + + (define-instance (Into Sign String) + (define (into sign-s) + (match sign-s + ((Plus) "+") + ((Minus) "-"))))) diff --git a/tests/foust/tests.lisp b/tests/foust/tests.lisp new file mode 100644 index 000000000..958418105 --- /dev/null +++ b/tests/foust/tests.lisp @@ -0,0 +1,748 @@ +;;;; Author: Yarin Heffes + +(defpackage #:cl-quil-tests/foust-tests + (:documentation + "This package defines a series of test to validate the stability of Foust in the event of + +any change to the repository.") + (:use #:coalton + #:coalton-prelude + #:coalton-testing) + (:use #:cl-quil.foust/pauli + #:cl-quil.foust/frame + #:cl-quil.foust/assignments + #:cl-quil.foust/node + #:cl-quil.foust/gate + #:cl-quil.foust/circuit + #:cl-quil.foust/graph + #:cl-quil.foust/cost + #:cl-quil.foust/reduce) + (:import-from + #:coalton-library/list + #:nth + #:combsof) + (:local-nicknames + (#:iter #:coalton-library/iterator) + (#:list #:coalton-library/list) + (#:map #:coalton-library/ord-map) + (#:result #:coalton-library/result)) + (:export #:run-tests)) + +(in-package #:cl-quil-tests/foust-tests) + +(named-readtables:in-readtable coalton:coalton) + +(fiasco:define-test-package #:cl-quil-tests.foust/fiasco-test-package) + +(coalton-fiasco-init #:cl-quil-tests.foust/fiasco-test-package) + +(cl:defun run-tests () + (fiasco:run-package-tests + :packages '(#:cl-quil-tests.foust/fiasco-test-package) + :interactive cl:t)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/sign` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-test test-sign-equals () + (is (/= Minus Plus)) + (is (/= Plus Minus)) + (is (== Plus Plus)) + (is (== Minus Minus)) + (is (== Plus (default)))) + +(define-test test-sign-* () + (is (== Plus (sign-* Minus Minus))) + (is (== Minus (sign-* Minus Plus))) + (is (== Minus (sign-* Plus Minus))) + (is (== Plus (sign-* Plus Plus))) + + (is (== Plus (msum (make-list Plus Minus Minus Minus Plus Minus)))) + (is (== Minus (msum (make-list Minus Plus Minus Minus Plus Plus))))) + +(define-test test-sign-into () + (is (== Plus (unwrap (tryinto #\+)))) + (is (== Minus (unwrap (tryinto #\-)))) + + (is (== #\+ (into Plus))) + (is (== #\- (into Minus))) + + (is (== "+" (into Plus))) + (is (== "-" (into Minus)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/pauli-operator` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(coalton-toplevel + + (define pauli-operators (make-list I X Y Z)) + + (define (both condition? this that) + (is (condition? this that)) + (is (condition? that this))) + + (define (bothf condition? func this that) + (is (condition? (func this that))) + (is (condition? (func that this))))) + +(define-test test-pauli-operator-equals () + (for p in pauli-operators + (is (== p p))) + + (for pq in (combsof 2 pauli-operators) + (both /= (nth 0 pq) (nth 1 pq)))) + +(define-test test-pauli-operator-commute () + (is (commute? I I)) + (for p in (unwrap (tail pauli-operators)) + (both commute? I p) + (is (commute? p p))) + + (for pq in (combsof 2 (list:cdr pauli-operators)) + (bothf not commute? (nth 0 pq) (nth 1 pq)))) + +(define-test test-pauli-operator-* () + (for p in pauli-operators + (is (== I (pauli-operator-* p p)))) + (bothf (== X) pauli-operator-* Y Z) + (bothf (== Y) pauli-operator-* Z X) + (bothf (== Z) pauli-operator-* X Y) + + (is (== X (msum (make-list X Y Z X Z Y X))))) + +(define-test test-pauli-operator-levi-civita () + (is (== Y (next-pauli-operator X))) + (is (== Z (next-pauli-operator Y))) + (is (== X (next-pauli-operator Z))) + (is (== Z (prev-pauli-operator X))) + (is (== X (prev-pauli-operator Y))) + (is (== Y (prev-pauli-operator Z))) + + (is (== 0 (levi-civita I I))) + (for p in (unwrap (tail pauli-operators)) + (bothf (== 0) levi-civita I p) + (is (== 0 (levi-civita p p)))) + + (is (== -1 (levi-civita Y X))) + (is (== +1 (levi-civita X Y))) + + (is (== -1 (levi-civita Z Y))) + (is (== +1 (levi-civita Y Z))) + + (is (== -1 (levi-civita X Z))) + (is (== +1 (levi-civita Z X)))) + +(define-test test-pauli-operator-into () + (is (== i (unwrap (tryinto #\I)))) + (is (== X (unwrap (tryinto #\X)))) + (is (== Y (unwrap (tryinto #\Y)))) + (is (== Z (unwrap (tryinto #\Z)))) + + (is (== #\I (into I))) + (is (== #\X (into X))) + (is (== #\Y (into Y))) + (is (== #\Z (into Z))) + + (is (== "I" (into I))) + (is (== "X" (into X))) + (is (== "Y" (into Y))) + (is (== "Z" (into Z)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/pauli` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(coalton-toplevel + + (define paulis (cons (Pauli Plus map:Empty) + (map (fn (p) (Pauli Plus (map:insert-or-replace map:Empty 0 p))) + (list:cdr pauli-operators))))) + +(define-test test-pauli-make-pauli () + (for pairing in (zip paulis pauli-operators) + (is (uncurry == (map-snd (fn (p) + (Pauli Plus (singleton (Tuple 0 p)))) + pairing)))) + + (is (== (Pauli Minus (make-list (Tuple 0 I) + (Tuple 1 X) + (Tuple 2 Z))) + (Pauli Minus (map:insert-or-replace (map:insert-or-replace map:empty 1 X) 2 Z))))) + +(define-test test-pauli-into () + (for pairing in (zip paulis (make-list "+I" "+X" "+Y" "+Z")) + (is (uncurry == (map-snd (compose unwrap tryinto) pairing)))) + + (is (== (Pauli Minus (map:insert-or-replace (map:insert-or-replace map:empty 1 X) 2 Z)) + (compose result:ok-or-error tryinto "-IXZ")))) + +(define-test test-pauli-commute () + (for pairing-one in (zip paulis pauli-operators) + (for pairing-two in (zip paulis pauli-operators) + (is (== (commute? (fst pairing-one) (fst pairing-two)) + (commute? (snd pairing-one) (snd pairing-two)))))) + + (is (commute? (Pauli Plus (make-list (Tuple 0 X) + (Tuple 1 Y) + (Tuple 2 X) + (Tuple 3 Z) + (Tuple 4 i))) + (Pauli Minus (make-list (Tuple 0 Y) + (Tuple 1 Y) + (Tuple 2 X) + (Tuple 3 X) + (Tuple 4 Z))))) + + (is (not (commute? (Pauli Plus (make-list (Tuple 0 X) + (Tuple 1 Y) + (Tuple 2 X) + (Tuple 3 Z) + (Tuple 4 i))) + (Pauli Minus (make-list (Tuple 0 Y) + (Tuple 1 Y) + (Tuple 2 Z) + (Tuple 3 X) + (Tuple 4 Z))))))) + +(define-test test-pauli-* () + (for p in paulis + (is (== (pauli-* p p) (default)))) + + (is (== (unwrap (tryinto "-YXYIIZZIZZY")) + (pauli-* (unwrap (tryinto "+XYIIXYZZXIX")) + (unwrap (tryinto "+ZZYIXXIZYZZ")))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/frame` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(coalton-toplevel + + (declare permsof (UFix -> (List :a) -> (List (List :a)))) + (define (permsof n l) + (concatmap list:perms (combsof n l))) + + (declare single-qubit-paulis (List Pauli)) + (define single-qubit-paulis (concatmap (fn (sign-s) + (map (fn (p) (make-pauli-one p 0 sign-s)) + (list:cdr pauli-operators))) + (make-list Minus Plus))) + + ;; 24 one-qubit Cliffords. + (declare single-qubit-frames (List Frame)) + (define single-qubit-frames (concatmap + (fn (pq) + (make-list (Frame (singleton (Tuple 0 (Tuple (nth 0 pq) (nth 1 pq))))) + (Frame (singleton (Tuple 0 (Tuple (nth 1 pq) (nth 0 pq))))))) + (filter (fn (pq) (not (commute? (nth 0 pq) (nth 1 pq)))) + (combsof 2 single-qubit-paulis)))) + + (declare two-qubit-paulis (List Pauli)) + (define two-qubit-paulis (concatmap + (fn (sign-s) + (concatmap + (fn (p) + (map + (fn (q) + (make-pauli-two p q 0 1 sign-s)) + pauli-operators)) + pauli-operators)) + (make-list Minus Plus))) + + ;; 11520 two-qubit Cliffords. + (declare two-qubit-frames (List Frame)) + (define two-qubit-frames (map (fn (pqpq) + (match pqpq + ((Cons p1 (Cons q1 (Cons p2 (Cons q2 (Nil))))) + (Frame (make-list (Tuple 0 (Tuple p1 q1)) + (Tuple 1 (Tuple p2 q2))))) + (_ (error "")))) + (filter (fn (pqpq) + (match pqpq + ((Cons p1 (Cons q1 (Cons p2 (Cons q2 (Nil))))) + (and (not (commute? p1 q1)) + (not (commute? p2 q2)) + (commute? p1 p2) + (commute? p1 q2) + (commute? q1 p2) + (commute? q1 q2))) + (_ (error "")))) + (permsof 4 two-qubit-paulis))))) + +(coalton-toplevel + + (declare random-from (UFix -> (List :a) -> (List :a))) + (define (random-from n xs) + (let ((l (length xs))) + (pipe (lisp (List UFix) (n l) + (cl:loop :repeat n :collect (cl:random l))) + (map (flip nth xs)))))) + +(define-test test-frame-><- () + (for frame-f in (random-from 288 two-qubit-frames) + (for p in (random-from 8 two-qubit-paulis) + (is (== p (frame-> frame-f (frame<- frame-f p)))) + (is (== p (frame<- frame-f (frame-> frame-f p)))) + (is (== (frame-> frame-f p) (frame<- (frame-inverse frame-f) p))) + (is (== (frame<- frame-f p) (frame-> (frame-inverse frame-f) p)))) + (is (== (default) (frame-compose frame-f (frame-inverse frame-f)))) + (is (== (default) (frame-compose (frame-inverse frame-f) frame-f))))) + +(define-test test-single-qubit-frames () + (for p in (list:cdr pauli-operators) + (is (== (frame-from-pauli-gate p 0) + (frame-inverse (frame-from-pauli-gate p 0)))) + (for sign-s in (make-list Minus Plus) + (is (== (frame-from-h sign-s p 0) (frame-inverse (frame-from-h sign-s p 0))))) + (is (== (frame-from-s False p 0) + (frame-inverse (frame-from-s True p 0)))) + (is (== (frame-from-s True p 0) + (frame-inverse (frame-from-s False p 0))))) + (for s-one in (make-list Plus Minus) + (for s-two in (make-list Plus Minus) + (for s-three in (make-list Plus Minus) + (is (== (frame-from-permute s-one s-two s-three 0) + (frame-inverse (frame-from-permute (sign-* Minus s-one) + (sign-* Minus s-two) + (sign-* Minus s-three) + 0)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/assignments` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-test test-classical-xor () + (let ((expr1 (ClassicalExpression (make-list 0 1 2 5 9 18 34) False)) + (expr2 (ClassicalExpression (make-list 0 2 5 7 18 22 ) True)) + (expr3 (classical-xor expr1 expr2))) + (is (== (make-list 1 7 9 22 34) (list:sort (get-classical-expression-variables expr3)))) + (is (== True (get-classical-expression-bit expr3))) + (is (== "c1 + c7 + c9 + c22 + c34 + 1" (into expr3))))) + +(define-test test-simplify-assignments () + (let ((mu1 (fold add-instruction + (null-assignments 4) + (make-list (Tuple 0 (ClassicalVariable 5)) + (Tuple 1 (ClassicalVariable 6)) + (Tuple 2 (ClassicalVariable 4)) + (Tuple 3 (ClassicalVariable 7)) + (Tuple 6 (fold classical-xor + (ClassicalBit True) + (map ClassicalVariable (make-list 4 5 7)))) + (Tuple 8 (classical-xor (ClassicalVariable 6) + (ClassicalVariable 5))) + (Tuple 7 (ClassicalBit True))))) + (mu2 (simplify-assignments mu1))) + (is (== (make-list (Tuple 0 (ClassicalVariable 5)) + (Tuple 1 (classical-xor (ClassicalVariable 4) + (ClassicalVariable 5))) + (Tuple 2 (ClassicalVariable 4)) + (Tuple 3 (ClassicalBit True))) + (get-assignments-instructions mu2))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/angle` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-test test-angle-equals () + (is (== (Angle 0/1) (default))) + (is (== (Angle 0/1) (Angle 1/1)))) + +(define-test test-make-angle () + (is (== (Angle 0/1) (Angle 1/1))) + (is (== (Angle 1/8) (Angle 9/8))) + (is (== (Angle 1/8) (Angle -7/8)))) + +(define-test test-angle-ops () + (is (== (Angle 0/1) (+ (Angle 7/4) (Angle -6/8)))) + (is (== (Angle 1/2) (- (Angle 2/3) (Angle 2/12)))) + (is (== (Angle 7/8) (negate (Angle 9/8))))) + +(define-test test-angle-order () + (is (== (Some 0) (angle-order (Angle 0/1)))) + (is (== (Some 0) (angle-order (Angle 7/7)))) + (is (== (Some 1) (angle-order (Angle 9/4)))) + (is (== (Some 2) (angle-order (Angle -4/8)))) + (is (== (Some 3) (angle-order (Angle 9/12)))) + (is (none? (angle-order (Angle 1/3)))) + (is (none? (angle-order (Angle 1/7))))) + +(define-test test-angle-into () + (is (== "0" (into (Angle 1/1)))) + (is (== "2π/3" (into (Angle 1/3)))) + (is (== "π/2" (into (Angle -3/4))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/node` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/gate` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(coalton-toplevel + (define +x (the Pauli (unwrap (tryinto "+X")))) + (define +y (the Pauli (unwrap (tryinto "+Y")))) + (define +z (the Pauli (unwrap (tryinto "+Z")))) + (define -x (the Pauli (unwrap (tryinto "-X")))) + (define -y (the Pauli (unwrap (tryinto "-Y")))) + (define -z (the Pauli (unwrap (tryinto "-Z"))))) + + +(define-test test-gate->frame () + (for p in (unwrap (tail pauli-operators)) + (is (== (gate->frame (PauliGate p 0)) + (frame-from-pauli-gate p 0))) + (for sign-s in (make-list Minus Plus) + (is (== (gate->frame (H sign-s p 0)) (frame-from-h sign-s p 0)))) + (is (== (gate->frame (S p 0)) + (frame-from-s False p 0))) + (is (== (gate->frame (Sdag p 0)) + (frame-from-s True p 0)))) + (for s-one in (make-list Plus Minus) + (for s-two in (make-list Plus Minus) + (for s-three in (make-list Plus Minus) + (is (== (gate->frame (Permute s-one s-two s-three 0)) + (frame-from-permute s-one s-two s-three 0))))))) + +(define-test test-row->gate () + (let ((test-row (fn (b p q gate-g) + (is (== (gate->frame gate-g) (gate->frame (row->gate b (Tuple 0 (Tuple p q))))))))) + + (test-row False +x +z (H Plus y 0)) + (test-row False -x -z (H Minus y 0)) + (test-row False +y -x (H Plus x 0)) + (test-row False -y -x (H Minus x 0)) + (test-row False -z +y (H Plus Z 0)) + (test-row False -z -y (H Minus Z 0)) + (test-row False +z -y (S Z 0)) + (test-row False +y +x (S x 0)) + (test-row False -x +z (S y 0)) + (test-row False +Z +y (SDag z 0)) + (test-row False -y +x (SDag x 0)) + (test-row False +x -z (SDag y 0)) + (test-row False -z +x (PauliGate x 0)) + (test-row False -z -x (PauliGate y 0)) + (test-row False +z -x (PauliGate Z 0)) + (test-row False +x +y (Permute Plus Plus Plus 0)) + (test-row False -y -z (Permute Plus Plus Minus 0)) + (test-row False -y +z (Permute Plus Minus Plus 0)) + (test-row False -x -y (Permute Plus Minus Minus 0)) + (test-row False +y -z (Permute Minus Plus Plus 0)) + (test-row False +x -y (Permute Minus Plus Minus 0)) + (test-row False -x +y (Permute Minus Minus Plus 0)) + (test-row False +y +z (Permute Minus Minus Minus 0)) + + (test-row True +x +z (H Plus y 0)) + (test-row True -x -z (H Minus y 0)) + (test-row True +y -x (H Plus x 0)) + (test-row True -y -x (H Minus x 0)) + (test-row True -z +y (H Plus Z 0)) + (test-row True -z -y (H Minus Z 0)) + (test-row True +z -y (SDag Z 0)) + (test-row True +y +x (SDag x 0)) + (test-row True -x +z (SDag y 0)) + (test-row True +z +y (S Z 0)) + (test-row True -y +x (S x 0)) + (test-row True +x -z (S y 0)) + (test-row True -z +x (PauliGate x 0)) + (test-row True -z -x (PauliGate y 0)) + (test-row True +z -x (PauliGate Z 0)) + (test-row True +x +y (Permute Minus Minus Minus 0)) + (test-row True -y -z (Permute Minus Minus Plus 0)) + (test-row True -y +z (Permute Minus Plus Minus 0)) + (test-row True -x -y (Permute Minus Plus Plus 0)) + (test-row True +y -z (Permute Plus Minus Minus 0)) + (test-row True +x -y (Permute Plus Minus Plus 0)) + (test-row True -x +y (Permute Plus Plus Minus 0)) + (test-row True +y +z (Permute Plus Plus Plus 0)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/circuit` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-test test-make-circuit () + + (let ((circuit-c (make-circuit + (make-list (R Z (Angle 1/3) 0) + (Controlled x 0 1) + (Meas Plus x 0 0) + (MeasMult -x 1) + (Meas Plus z 1 3))))) + (is (== 4 (get-assignments-next-fresh-index + (get-circuit-assignments + circuit-c)))) + (is (== 4 (get-assignments-first-fresh-index + (get-circuit-assignments + circuit-c)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/graph` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/cost` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(coalton-toplevel + + (declare single-qubit-cliffords (List (UFix -> Gate))) + (define single-qubit-cliffords + (make-list + (PauliGate X) + (PauliGate Y) + (PauliGate Z) + (S X) + (S Y) + (S Z) + (SDag X) + (SDag Y) + (SDag Z) + (H Plus X) + (H Plus Y) + (H Plus Z) + (H Minus X) + (H Minus Y) + (H Minus Z) + (Permute Plus Plus Plus) + (Permute Plus Plus Minus) + (Permute Plus Minus Plus) + (Permute Plus Minus Minus) + (Permute Minus Plus Plus) + (Permute Minus Plus Minus) + (Permute Minus Minus Plus) + (Permute Minus Minus Minus))) + + (declare random-boolean (Unit -> Boolean)) + (define (random-boolean) + (== 1 (lisp UFix () (cl:random 2)))) + + (declare randn (UFix -> UFix)) + (define (randn n) + (lisp UFix (n) (cl:random n))) + + (declare randt (UFix -> (Tuple UFix UFix))) + (define (randt n) + (match (Tuple (randn n) (randn n)) + ((Tuple n1 n2) (if (== n1 n2) + (randt n) + (Tuple n1 n2))))) + + (declare random-pauli-operator (Unit -> PauliOperator)) + (define (random-pauli-operator) + (list:car (random-from 1 (list:cdr pauli-operators)))) + + (declare tqes (UFix -> UFix -> Boolean -> (List Gate))) + (define (tqes min-index max-index then-swap?) + (do + (p1 <- (make-list x y Z)) + (p2 <- (make-list x y Z)) + (index-one <- (range min-index max-index)) + (index-two <- (filter (< index-one) (range min-index max-index))) + (pure (make-tqe p1 p2 index-one index-two then-swap?)))) + + (declare random-two-qubit-clifford (UFix -> UFix -> Frame)) + (define (random-two-qubit-clifford index-one index-two) + (match (random-from 2 single-qubit-cliffords) + ((Cons s1 (Cons s2 (Nil))) + (pipe (gate->frame (s1 index-one)) + (frame-compose (gate->frame (s2 index-two))) + (if (random-boolean) + (frame-compose + (gate->frame (make-tqe (random-pauli-operator) + (random-pauli-operator) + index-one + index-two + False))) + id) + (if (random-boolean) + (frame-compose (frame-from-swap index-one index-two)) + id))) + (_ (error "Unexpected error.")))) + + (declare random-n-qubit-clifford (UFix -> UFix -> Frame)) + (define (random-n-qubit-clifford m n) + (msum (map (fn (_) (uncurry random-two-qubit-clifford (randt n))) (range 0 (1- m))))) + + (declare random-npauli (UFix -> Pauli)) + (define (random-npauli n) + (let ((p (Pauli (list:car (random-from 1 (make-list Plus Minus))) + (zip (range 0 (1- n)) + (random-from n pauli-operators))))) + (if (== 0 (length (get-pauli-support p))) + (random-npauli n) + p))) + + (declare random-anticommuting-npauli (UFix -> (Tuple Pauli Pauli))) + (define (random-anticommuting-npauli n) + (let ((pq (Tuple (random-npauli n) (random-npauli n)))) + (if (uncurry commute? pq) + (random-anticommuting-npauli n) + pq))) + + (declare random-singlet-nodes (UFix -> UFix -> (List Node))) + (define (random-singlet-nodes num-nodes n) + (map (fn (p) + (if (list:car (random-from 1 (make-list True False))) + (MeasurementNode (Measurement p 0)) + (RotationNode (Rotation p (Angle 1/3))))) + (map (fn (_) (random-npauli n)) (range 0 (1- num-nodes))))) + + (declare random-factor-nodes (UFix -> UFix -> (List Node))) + (define (random-factor-nodes num-nodes n) + (map (fn (pq) + (match pq + ((Tuple p q) + (if (list:car (random-from 1 (make-list True False))) + (PreparationNode (Preparation p q)) + (Rotation2Node (Rotation2 p q (Angle 1/3) (Angle 2/3))))))) + (map (fn (_) (random-anticommuting-npauli n)) (range 0 (1- num-nodes)))))) + +(define-test test-delta-singlet-cost-no-swap () + (for n in (random-singlet-nodes 30 5) + (for t in (tqes 0 4 False) + (is (== (delta-node-cost t n) + (- (into (node-cost (frame-node-> (gate->frame (dagger-tqe t)) n))) + (into (node-cost n)))))))) + +(define-test test-delta-singlet-cost-with-swap () + (for n in (random-singlet-nodes 30 5) + (for t in (tqes 0 4 True) + (is (== (delta-node-cost t n) + (- (into (node-cost (frame-node-> (gate->frame (dagger-tqe t)) n))) + (into (node-cost n)))))))) + +(define-test test-delta-factor-cost-no-swap () + (for n in (random-factor-nodes 30 5) + (for t in (tqes 0 4 False) + (is (== (delta-node-cost t n) + (- (into (node-cost (frame-node-> (gate->frame (dagger-tqe t)) n))) + (into (node-cost n)))))))) + +(define-test test-delta-factor-cost-with-swap () + (for n in (random-factor-nodes 30 5) + (for t in (tqes 0 4 True) + (is (== (delta-node-cost t n) + (- (into (node-cost (frame-node-> (gate->frame (dagger-tqe t)) n))) + (into (node-cost n)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/reduce` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-test test-singlet-nodes-reduce-no-swap () + (for n in (random-singlet-nodes 30 5) + (if (positive? (node-cost n)) + (let ((reductions (the (List Frame) + (iter:collect! + (map gate->frame (reduce-node (fn (_ _) False) n))))) + (ts (tqes 0 4 False))) + (for t in ts + (is (== (list:member (gate->frame t) reductions) + (negative? (delta-node-cost t n)))))) + (continue)))) + +(define-test test-singlet-nodes-reduce-with-swap () + (for n in (random-singlet-nodes 30 5) + (if (positive? (node-cost n)) + (let ((reductions (the (List Frame) + (iter:collect! + (map gate->frame (reduce-node (fn (_ _) True) n))))) + (ts (tqes 0 4 True))) + (for t in ts + (is (== (list:member (gate->frame t) reductions) + (negative? (delta-node-cost t n)))))) + (continue)))) + +(define-test test-factor-nodes-reduce-no-swap () + (for n in (random-factor-nodes 30 5) + (if (positive? (node-cost n)) + (let ((reductions (the (List Frame) + (iter:collect! + (map gate->frame (reduce-node (fn (_ _) False) n))))) + (ts (tqes 0 4 False))) + (for t in ts + (is (== (list:member (gate->frame t) reductions) + (negative? (delta-node-cost t n)))))) + (continue)))) + +(define-test test-factor-nodes-reduce-with-swap () + (for n in (random-factor-nodes 30 5) + (if (positive? (node-cost n)) + (let ((reductions (the (List Frame) + (iter:collect! + (map gate->frame (reduce-node (fn (_ _) True) n))))) + (ts (tqes 0 4 True))) + (for t in ts + (is (== (list:member (gate->frame t) reductions) + (negative? (delta-node-cost t n)))))) + (continue)))) + +(define-test test-row-reduce-no-swap () + (for frame-f in (iter:take! 10 (iter:new (fn () (Some (random-n-qubit-clifford 40 4))))) + (for row-r in (map:entries (get-frame-row-map frame-f)) + (if (positive? (row-cost row-r)) + (let ((reductions (iter:collect! (map gate->frame (reduce-row (fn (_ _) False) row-r)))) + (ts (tqes 0 3 False))) + (for t in ts + (is (== (negative? (delta-row-cost t row-r)) + (list:member (gate->frame t) reductions))))) + (continue))))) + +(define-test test-row-reduce-with-swap () + (for frame-f in (iter:take! 10 (iter:new (fn () (Some (random-n-qubit-clifford 40 4))))) + (for row-r in (map:entries (get-frame-row-map frame-f)) + (if (positive? (row-cost row-r)) + (let ((reductions (iter:collect! (map gate->frame (reduce-row (fn (_ _) True) row-r)))) + (ts (tqes 0 3 True))) + (for t in ts + (is (== (negative? (delta-row-cost t row-r)) + (list:member (gate->frame t) reductions))))) + (continue))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/optimize` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/compile` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; `foust/foust-quil` +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;