diff --git a/cl-quil.asd b/cl-quil.asd index 75205657f..ef7bf63de 100644 --- a/cl-quil.asd +++ b/cl-quil.asd @@ -80,8 +80,9 @@ (:file "state-prep") (:file "translators") (:file "modifiers") - (:file "optimal-2q") - ;; attic'd file / pedagogical purposes only + (:file "linear-paulis") + ;; attic'd files / pedagogical purposes only + (:static-file "optimal-2q") (:static-file "cs-compile"))) (:module "analysis" :serial t diff --git a/src/ast.lisp b/src/ast.lisp index e6cb47728..e213673b5 100644 --- a/src/ast.lisp +++ b/src/ast.lisp @@ -386,6 +386,29 @@ If no exit rewiring is found, return NIL." :reader permutation-gate-definition-permutation)) (:documentation "A gate definition whose entries can be represented by a permutation of natural numbers.")) +(defclass exp-pauli-sum-gate-definition (gate-definition) + ((terms :initarg :terms + :reader exp-pauli-sum-gate-definition-terms + :documentation "List of PAULI-TERMs comprising the sum.") + (parameters :initarg :parameters + :reader exp-pauli-sum-gate-definition-parameters + :documentation "Ordered list of parameter names to be supplied to the definition, which can appear in arithmetical expressions weighting the definition's Pauli terms.") + (arguments :initarg :arguments + :reader exp-pauli-sum-gate-definition-arguments + :documentation "Ordered list of formal arguments appearing in the definition's Pauli terms.")) + (:documentation "Represents a gate definition as the exponential of a weighted sum of Pauli matrices.")) + +(defstruct (pauli-term) + "Records a word of Pauli operators, together with an ordered list of qubit formals on which they act, as well as a scalar prefix. This is part of the internal representation of a EXP-PAULI-SUM-GATE-DEFINITION and probably shouldn't be instantiated otherwise. + +This replicates some of the behavior of CL-QUIL.CLIFFORD::PAULI, but it extends it slightly: a Clifford Pauli is constrained to carry a phase which is a fourth root of unity, but the phase of a PAULI-TERM can be arbitrary (indeed, even a delayed expression). The reader looking for an embodiment of Pauli words is better off using that data structure without CAREFUL CONSIDERATION." + pauli-word + prefactor + arguments) + +(defmethod gate-definition-qubits-needed ((gate exp-pauli-sum-gate-definition)) + (length (exp-pauli-sum-gate-definition-arguments gate))) + (defmethod gate-definition-qubits-needed ((gate permutation-gate-definition)) (ilog2 (length (permutation-gate-definition-permutation gate)))) @@ -1528,7 +1551,26 @@ For example, (format stream ":~%") (print-instruction-sequence (circuit-definition-body defn) :stream stream - :prefix " "))) + :prefix " ")) + + (:method ((gate exp-pauli-sum-gate-definition) (stream stream)) + (format stream "DEFGATE ~A~@[(~{%~A~^, ~})~]~{ ~A~} AS PAULI-SUM:~%" + (gate-definition-name gate) + (mapcar #'string (exp-pauli-sum-gate-definition-parameters gate)) + (mapcar #'formal-name (exp-pauli-sum-gate-definition-arguments gate))) + (dolist (pauli-term (exp-pauli-sum-gate-definition-terms gate)) + (with-slots (pauli-word prefactor arguments) pauli-term + (format stream " ~a(" pauli-word) + (typecase prefactor + (number + (format stream "~a" prefactor)) + ((or symbol cons) + (print-instruction (make-delayed-expression nil nil prefactor) stream))) + (format stream ")") + (dolist (arg arguments) + (format stream " ") + (print-instruction arg stream)) + (terpri stream))))) (defmethod print-object ((object instruction) stream) (print-unreadable-object (object stream :type nil :identity nil) diff --git a/src/build-gate.lisp b/src/build-gate.lisp index e9ba3a05d..174b34fc3 100644 --- a/src/build-gate.lisp +++ b/src/build-gate.lisp @@ -54,16 +54,36 @@ EXAMPLE: The Quil line \"CPHASE(pi) 2 3\" corresponds to the S-expression (build (define-global-counter **anonymous-gate-counter** get-anonymous-gate-counter) -(defun anon-gate (operator matrix qubit &rest qubits) - "Variant of BUILD-GATE for constructing anonymous gate applications." - (check-type operator string) - (check-type matrix magicl:matrix) +(defun anon-gate (operator-or-gate gate-or-parameters qubit &rest qubits) + "Variant of BUILD-GATE for constructing anonymous gate applications. + +Comes in two flavors: + (1) (anon-gate string-name magicl-matrix &rest qubits) builds an anonymous gate application with human-readable name STRING-NAME, behavior indicated by MAGICL-MATRIX, and acting on QUBITS. + (2) (anon-gate gate-definition parameter-list &rest qubits) builds an anonymous gate application with definition set by GATE-DEFINITION, human-readable name inferred from the defintiion, PARAMETER-LIST fed to the definition, and acting on QUBITS." (push qubit qubits) - (let ((name (format nil "~A-~A" operator (get-anonymous-gate-counter)))) + (let* ((name + (etypecase operator-or-gate + (string + (format nil "~A-~A" operator-or-gate (get-anonymous-gate-counter))) + (gate + (format nil "~A-~A" (gate-name operator-or-gate) (get-anonymous-gate-counter))))) + (gate + (cond + ((typep operator-or-gate 'gate) + operator-or-gate) + ((typep gate-or-parameters 'magicl:matrix) + (make-instance 'simple-gate :matrix gate-or-parameters :name name)) + (t + (error "Cannot find gate definition.")))) + (parameters + (typecase gate-or-parameters + (cons gate-or-parameters) + (otherwise nil)))) (make-instance 'gate-application :operator (named-operator name) - :gate (make-instance 'simple-gate :matrix matrix :name name) - :arguments (mapcar #'%capture-arg qubits)))) + :gate gate + :arguments (mapcar #'%capture-arg qubits) + :parameters parameters))) (defun repeatedly-fork (op n) (loop :repeat n diff --git a/src/chip/chip-specification.lisp b/src/chip/chip-specification.lisp index 2ab285dda..d51c715cd 100644 --- a/src/chip/chip-specification.lisp +++ b/src/chip/chip-specification.lisp @@ -392,6 +392,8 @@ used to specify CHIP-SPEC." (constantly 'state-prep-2q-compiler) (constantly 'state-prep-4q-compiler) (constantly 'state-prep-trampolining-compiler) + (constantly 'parametric-diagonal-compiler) + (constantly 'parametric-pauli-compiler) (constantly 'recognize-ucr) (constantly 'nearest-circuit-of-depth-0) (lambda (chip-spec arch) diff --git a/src/compilers/linear-paulis.lisp b/src/compilers/linear-paulis.lisp new file mode 100644 index 000000000..1af9f08de --- /dev/null +++ b/src/compilers/linear-paulis.lisp @@ -0,0 +1,251 @@ +;;;; linear-paulis.lisp +;;;; +;;;; Author: Eric Peterson +;;;; +;;;; This file contains routines for the parametric compilation of gates defined +;;;; by time-independent Hamiltonians via expression as a +;;;; EXP-PAULI-SUM-GATE. + +(in-package #:cl-quil) + +;; WARNING: this consumes stack space like (* tree-depth fan-out) +(defun tree-substitute (big-tree substitution-table) + (cond + ((listp big-tree) + (mapcar (a:rcurry #'tree-substitute substitution-table) big-tree)) + ((delayed-expression-p big-tree) + (make-delayed-expression + (delayed-expression-params big-tree) + (delayed-expression-lambda-params big-tree) + (tree-substitute (delayed-expression-expression big-tree) substitution-table))) + ((assoc big-tree substitution-table) + (cdr (assoc big-tree substitution-table))) + (t + big-tree))) + +(defun term->count-and-last-Z-position (term) + "For TERM a PAULI-TERM, counts the number of Zs and returns the position of the last occuring Z." + (values (count #\Z (pauli-term-pauli-word term)) + (position #\Z (pauli-term-pauli-word term)))) + +(defun clone-exp-pauli-sum-gate (gate &key new-name new-terms) + (with-slots (arguments parameters arity dimension name terms) gate + (make-instance 'exp-pauli-sum-gate + :arguments arguments + :parameters parameters + :arity arity + :dimension dimension + :name (or new-name name) + :terms (or new-terms terms)))) + +(defun find-most-frequent-Z (terms arguments &key except) + (let ((votes (make-array (length arguments) :initial-element 0))) + (dolist (term terms) + (loop :for letter :across (pauli-term-pauli-word term) + :for argument :in (pauli-term-arguments term) + :when (eql #\Z letter) + :do (incf (aref votes (position argument arguments :test #'equalp))))) + (when except + (setf (aref votes except) 0)) + (vector-argmax votes))) + +(defun pauli-instr-of-all-Zs-or-Is-p (instr) + "Predicate: INSTR is a GATE-APPLICATION defined by a diagonal EXP-PAULI-SUM-GATE." + (and (typep (gate-application-gate instr) 'exp-pauli-sum-gate) + (every (lambda (term) (every (lambda (letter) (or (eql letter #\Z) (eql letter #\I))) + (pauli-term-pauli-word term))) + (exp-pauli-sum-gate-terms (gate-application-gate instr))))) + +(define-compiler parametric-diagonal-compiler + ((instr _ :where (pauli-instr-of-all-Zs-or-Is-p instr))) + "Decomposes a diagonal Pauli gate by a single step." + (with-slots (arguments parameters terms arity dimension) (gate-application-gate instr) + (let ((nonlocal-terms nil)) + ;; first, deal with the words with zero Zs / one Z: they're local gates. + ;; we'll want to evaluate the gate definition at whatever the gate application says. + (let ((substitution-table + (mapcar (lambda (ep ap) + (typecase ap + (delayed-expression + (cons ep (delayed-expression-expression ap))) + (otherwise + (cons ep ap)))) + parameters (application-parameters instr)))) + (dolist (term terms) + (multiple-value-bind (Z-count Z-position) + (term->count-and-last-Z-position term) + (case Z-count + (0 + nil) + (1 + (inst "RZ" + (list (param-* 2.0d0 + (tree-substitute (pauli-term-prefactor term) + substitution-table))) + (nth (position (nth Z-position (pauli-term-arguments term)) + arguments :test #'equalp) + (application-arguments instr)))) + (otherwise + (push term nonlocal-terms)))))) + ;; we can break nonlocal terms into two collections: those with Zs in + ;; some spot and those without Zs in that spot. the result will be to + ;; conjugate the first collection by CNOT, which flips those Zs to Is. + ;; since we can only emit local gates, almost all such Zs will have to + ;; be eliminated, and so we'll want to pick the position so that this + ;; group is as large as possible. + (let* ((vote (find-most-frequent-Z nonlocal-terms arguments)) + (control-qubit (nth vote (application-arguments instr)))) + ;; now we re-sort the nonlocal terms into two buckets: those with a Z in + ;; the voted-upon location, and those without + (let (Is Zs) + (dolist (term nonlocal-terms) + (let ((Z-pos (loop :for letter :across (pauli-term-pauli-word term) + :for arg :in (pauli-term-arguments term) + :for j :from 0 + :when (and (eql #\Z letter) + (eql vote (position arg arguments :test #'equalp))) + :do (return j)))) + (if Z-pos + (push (list term Z-pos) Zs) + (push term Is)))) + ;; emit the Is as-is + (when Is + (let ((I-gate (clone-exp-pauli-sum-gate (gate-application-gate instr) + :new-name "Is" :new-terms Is))) + (inst* I-gate + (application-parameters instr) + (application-arguments instr)))) + (unless Zs + (finish-compiler)) + ;; emit the Zs by reducing their Z-counts (for some of them). + ;; we reduce the Z-count by using the identity CNOT ZI CNOT = ZZ, so we seek + ;; a second qubit index with a lot of Zs to conjugate away all at once. + (let* ((subvote-position (find-most-frequent-Z (mapcar #'car Zs) arguments + :except vote)) + (subvote-formal (nth subvote-position arguments)) + (subvote-literal (nth subvote-position (application-arguments instr))) + ZZs ZIs) + ;; cleave the Zs into ZZs and ZIs. + (dolist (term-pair Zs) + (let ((term (car term-pair))) + (if (position subvote-formal (pauli-term-arguments term) :test #'equalp) + (push term-pair ZZs) + (push term ZIs)))) + ;; for the ZIs: emit them as-is. + (let ((ZI-gate (clone-exp-pauli-sum-gate (gate-application-gate instr) + :new-name "ZI-GATE" :new-terms ZIs))) + (when ZIs + (inst* ZI-gate + (application-parameters instr) + (application-arguments instr)))) + ;; for the ZZs: rewrite them as if they would be ZIs ... + (let* ((ZZs->ZIs + (mapcar (lambda (pair) + (destructuring-bind (term Z-pos) pair + (let ((new-term (copy-pauli-term term))) + (setf (pauli-term-pauli-word new-term) + (coerce (loop :for letter :across (pauli-term-pauli-word term) + :for j :from 0 + :if (eql j Z-pos) + :collect #\I + :else + :collect letter) + 'string)) + new-term))) + ZZs)) + (ZZ-gate (clone-exp-pauli-sum-gate (gate-application-gate instr) + :new-name "ZZ-GATE" :new-terms ZZs->ZIs))) + ;; ... then emit them in a CNOT sandwich. + (when ZZs + (inst "CNOT" () control-qubit subvote-literal) + (inst* ZZ-gate + (application-parameters instr) + (application-arguments instr)) + (inst "CNOT" () control-qubit subvote-literal))))))))) + + +;; TODO: also write an orthogonal gate compiler somewhere? approx.lisp will take +;; care of it in the 2Q case, at least. + +(define-compiler parametric-pauli-compiler + ((instr _ :where (and (typep (gate-application-gate instr) 'exp-pauli-sum-gate) + (= 1 (length (application-parameters instr))) + (not (typep (first (application-parameters instr)) 'constant))))) + "Decomposes a gate described by the exponential of a time-independent Hamiltonian into static orthogonal and parametric diagonal components." + (let ((gate (gate-application-gate instr))) + (with-slots (arguments parameters terms dimension) gate + + ;; make sure that all the pauli terms are all scalar multiples of the unknown parameter. + ;; we track this by making sure that the unknown parameter appears only once and that + ;; the surrounding expression takes a particularly nice form. + (labels ((crawl-parameter (p) + (typecase p + (list + (case (first p) + (- + (unless (= 2 (length p)) + (give-up-compilation)) + (crawl-parameter (second p))) + (* + (unless (= 3 (length p)) + (give-up-compilation)) + (let ((total (+ (crawl-parameter (second p)) + (crawl-parameter (third p))))) + (unless (<= total 1) + (give-up-compilation)) + total)) + (otherwise + (give-up-compilation)))) + (number + 0) + (symbol + 1) + (otherwise + (give-up-compilation))))) + (dolist (term terms) + (unless (= 1 (crawl-parameter (pauli-term-prefactor term))) + (give-up-compilation)))) + + ;; instantiate the Hamiltonian + (let ((H (magicl:make-zero-matrix dimension dimension))) + (dolist (term terms) + (setf H (m+ H (pauli-term->matrix term arguments (list 1d0) parameters)))) + ;; orthogonally diagonalize it: H = O D O^T + (multiple-value-bind (diagonal O) (magicl:hermitian-eig H) + ;; convert diagonal into a sum of Z paulis + (let ((pauli-prefactors (make-array dimension :initial-element 0d0)) + terms diagonal-gate) + (loop :for d :in diagonal + :for i :from 0 + :do (dotimes (j dimension) + (incf (aref pauli-prefactors j) + (if (evenp (logcount (logand i j))) + (/ d dimension) + (/ (- d) dimension))))) + (setf terms (loop :for prefactor :across pauli-prefactors + :for j :from 0 + :unless (double= 0d0 prefactor) + :collect (let ((term-arguments + (loop :for i :below (length arguments) + :for arg :in arguments + :when (logbitp (- (length arguments) i 1) j) + :collect arg))) + (make-pauli-term + :prefactor (param-* (realpart prefactor) + (make-delayed-expression + nil nil (first parameters))) + :arguments term-arguments + :pauli-word (coerce (make-array (length term-arguments) + :initial-element #\Z) + 'string)))) + diagonal-gate (make-instance 'exp-pauli-sum-gate + :arguments arguments + :parameters parameters + :terms terms + :arity 1 + :dimension dimension + :name (string (gensym "DIAG-PAULI-")))) + ;; emit the instructions + (inst* "RIGHT-O-T" (magicl:conjugate-transpose O) (application-arguments instr)) + (inst* diagonal-gate (application-parameters instr) (application-arguments instr)) + (inst* "LEFT-O" O (application-arguments instr)))))))) diff --git a/src/compilers/ucr-recognize.lisp b/src/compilers/ucr-recognize.lisp index b6d5f7629..27caff436 100644 --- a/src/compilers/ucr-recognize.lisp +++ b/src/compilers/ucr-recognize.lisp @@ -9,7 +9,10 @@ (define-compiler recognize-ucr ((instr :where (anonymous-gate-application-p instr))) "Checks whether an anonymous gate is a UCRY or UCRZ instruction, in which case it relabels it as such." - (let* ((matrix (gate-matrix instr)) + (let* ((matrix (handler-case (gate-matrix instr) + (unknown-gate-parameter (c) + (declare (ignore c)) + (give-up-compilation)))) (dimension (magicl:matrix-rows matrix)) (log-dimension (length (application-arguments instr))) angles) diff --git a/src/define-compiler.lisp b/src/define-compiler.lisp index f48954465..cb80f82e7 100644 --- a/src/define-compiler.lisp +++ b/src/define-compiler.lisp @@ -818,7 +818,8 @@ N.B.: This routine is somewhat fragile, and highly creative compiler authors wil (assert (listp source)) (multiple-value-bind (source options) (cleave-options source) (cond - ((endp (cdr source)) + ((or (endp (cdr source)) + (wildcard-pattern-p (second source))) (make-wildcard-binding :name (first source) :options options)) (t @@ -888,14 +889,15 @@ FINISH-COMPILER is a local macro usable within a compiler body." ((and (= 1 (length ,xs)) (typep (first ,xs) 'gate-application)) (setf ,x (first ,xs))) + ;; check for an anon-gate signature + ((and (<= 3 (length ,xs)) + (or (typep (cadr ,xs) 'magicl:matrix) + (typep (car ,xs) 'gate))) + (setf ,x (apply #'anon-gate ,xs))) ;; check for a build-gate signature ((and (<= 3 (length ,xs)) (typep (cadr ,xs) 'list)) (setf ,x (apply #'build-gate ,xs))) - ;; check for an anon-gate signature - ((and (<= 3 (length ,xs)) - (typep (cadr ,xs) 'magicl:matrix)) - (setf ,x (apply #'anon-gate ,xs))) (t (error "INST argument pattern not recognized: ~A" ,xs))) (rplacd ,tail (cons ,x nil)) diff --git a/src/gates.lisp b/src/gates.lisp index f33d56fb7..d158bfaa0 100644 --- a/src/gates.lisp +++ b/src/gates.lisp @@ -176,6 +176,7 @@ :documentation "The minimal dimension of the space the gate acts on.") (matrix-function :initarg :matrix-function :reader parameterized-gate-matrix-function + :writer (setf %parameterized-gate-matrix-function) :documentation "Function mapping ARITY complex numbers to a DIMENSION x DIMENSION MAGICL matrix.")) (:documentation "A gate parameterized by complex numbers.")) @@ -189,6 +190,30 @@ (defmethod gate-matrix ((gate parameterized-gate) &rest parameters) (apply (parameterized-gate-matrix-function gate) parameters)) +(defclass exp-pauli-sum-gate (parameterized-gate) + ((parameters :initarg :parameters + :reader exp-pauli-sum-gate-parameters) + (arguments :initarg :arguments + :reader exp-pauli-sum-gate-arguments) + (terms :initarg :terms + :reader exp-pauli-sum-gate-terms)) + (:documentation "A gate specified by the exponentiation of a weighted sum of Paulis. + +The Pauli sum is recorded as a list of PAULI-TERM objects, stored in the TERMS slot, each of which is made up of a phase factor, a string of Pauli symbols (I, X, Y, Z), and an ordered list of qubit formals to which these symbols are applied. The qubit formals are those appearing in the ARGUMENTS slot, which ultimately get substituted with the arguments appearing in a GATE-APPLICATION tagged with this gate definition. Similarly, PARAMETERS is populated with a list of formals on which the Pauli phases can depend, and these are ultimately substituted with the parameters appearing in a GATE-APPLICATION tagged with this gate definition.")) + +(defmethod initialize-instance :after ((gate exp-pauli-sum-gate) &key) + (with-slots (parameters arguments terms) gate + (let ((size (expt 2 (length arguments)))) + (flet ((matrix-function (&rest params) + (assert (= (length parameters) (length params))) + (matrix-expt (reduce (lambda (m term) + (m+ m (pauli-term->matrix term arguments params parameters))) + terms + :initial-value (magicl:make-zero-matrix size size)) + #C(0d0 -1d0) + :hermitian? t))) + (setf (%parameterized-gate-matrix-function gate) #'matrix-function))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;; Gate Operators ;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Controlled Gates @@ -357,6 +382,15 @@ :arity (length params) :matrix-function (compile nil (lambda-form params dim entries)))))) +(defmethod gate-definition-to-gate ((gate-def exp-pauli-sum-gate-definition)) + (with-slots (arguments parameters terms) gate-def + (make-instance 'exp-pauli-sum-gate + :arguments arguments + :parameters parameters + :terms terms + :dimension (expt 2 (length arguments)) + :arity (length arguments)))) + ;;;; some leftover stuff from standard-gates.lisp and elsewhere (defun apply-gate (m instr) diff --git a/src/matrix-operations.lisp b/src/matrix-operations.lisp index 7a9fad124..d55aca8d6 100644 --- a/src/matrix-operations.lisp +++ b/src/matrix-operations.lisp @@ -391,3 +391,35 @@ as needed so that they are the same size." (matrix-equality kroned-ref-mat (scale-out-matrix-phases kroned-mat kroned-ref-mat)))))) + +(defun matrix-expt (m s &key hermitian?) + "Computes EXP(M*S). Only works for unitarily diagonalizable matrices M." + (multiple-value-bind (d u) + (if hermitian? (magicl:hermitian-eig m) (magicl:eig m)) + (when *compress-carefully* + (assert (matrix-equality m + (m* u + (magicl:diag (length d) (length d) d) + (magicl:conjugate-transpose u))) + () + "MATRIX-EXPT failed to diagonalize its input.")) + (let* ((size (length d)) + (dd (magicl:diag size size + (mapcar (lambda (z) (exp (* z s))) d)))) + (m* u dd (magicl:conjugate-transpose u))))) + +(defun print-polar-matrix (m &optional (stream *standard-output*)) + (let ((*print-fractional-radians* nil) + (*print-polar-form* t) + (height (magicl::matrix-rows m)) + (width (magicl::matrix-cols m))) + (format stream "~&") + (dotimes (i height) + (dotimes (j width) + (let* ((z (magicl:ref m i j)) + (abs (if (double= 0d0 (abs z)) 0d0 (abs z))) + (phase (if (zerop abs) 0d0 (mod (phase z) (* 2 pi))))) + (format stream "~6,4F∠~6,4F" abs phase)) + (when (< j (1- width)) + (format stream ", "))) + (format stream "~%")))) diff --git a/src/parser.lisp b/src/parser.lisp index 4278d44ed..ea405f383 100644 --- a/src/parser.lisp +++ b/src/parser.lisp @@ -38,7 +38,7 @@ :LOAD :STORE :EQ :GT :GE :LT :LE :DEFGATE :DEFCIRCUIT :RESET :HALT :WAIT :LABEL :NOP :CONTROLLED :DAGGER :FORKED :DECLARE :SHARING :OFFSET :PRAGMA - :AS :MATRIX :PERMUTATION)) + :AS :MATRIX :PERMUTATION :PAULI-SUM)) (deftype token-type () '(or @@ -148,7 +148,7 @@ Each lexer extension is a function mapping strings to tokens. They are used to h (return (tok ':CONTROLLED))) ((eager #.(string #\OCR_FORK)) (return (tok ':FORKED))) - ("INCLUDE|DEFCIRCUIT|DEFGATE|MEASURE|LABEL|WAIT|NOP|HALT|RESET|JUMP\\-WHEN|JUMP\\-UNLESS|JUMP|PRAGMA|NOT|AND|IOR|MOVE|EXCHANGE|SHARING|DECLARE|OFFSET|XOR|NEG|LOAD|STORE|CONVERT|ADD|SUB|MUL|DIV|EQ|GT|GE|LT|LE|CONTROLLED|DAGGER|FORKED|AS|MATRIX|PERMUTATION" + ("INCLUDE|DEFCIRCUIT|DEFGATE|MEASURE|LABEL|WAIT|NOP|HALT|RESET|JUMP\\-WHEN|JUMP\\-UNLESS|JUMP|PRAGMA|NOT|AND|IOR|MOVE|EXCHANGE|SHARING|DECLARE|OFFSET|XOR|NEG|LOAD|STORE|CONVERT|ADD|SUB|MUL|DIV|EQ|GT|GE|LT|LE|CONTROLLED|DAGGER|FORKED|AS|MATRIX|PERMUTATION|PAULI-SUM" (return (tok (intern $@ :keyword)))) ((eager "(?{{IDENT}})\\[(?{{INT}})\\]") (assert (not (null $NAME))) @@ -870,21 +870,151 @@ If ENSURE-VALID is T, then a memory reference such as 'foo[0]' will result in an (setf name (token-payload (pop params-args))) (multiple-value-bind (params rest-line) (parse-parameters params-args) - (when (eql ':AS (token-type (first rest-line))) - (pop rest-line) - (let* ((parsed-gate-tok (first rest-line)) - (parsed-gate-type (token-type parsed-gate-tok))) - (unless (find parsed-gate-type '(:MATRIX :PERMUTATION)) - (quil-parse-error "Found unexpected gate type: ~A." (token-payload parsed-gate-tok))) - (setf gate-type parsed-gate-type))) - - (ecase gate-type - (:MATRIX - (parse-gate-entries-as-matrix body-lines params name :lexical-context op)) - (:PERMUTATION - (when params - (quil-parse-error "Permutation gate definitions do not support parameters.")) - (parse-gate-entries-as-permutation body-lines name :lexical-context op)))))))) + (multiple-value-bind (args rest-line) (parse-arguments rest-line) + (when (eql ':AS (token-type (first rest-line))) + (pop rest-line) + (let* ((parsed-gate-tok (first rest-line)) + (parsed-gate-type (token-type parsed-gate-tok))) + (unless (find parsed-gate-type '(:MATRIX :PERMUTATION :PAULI-SUM)) + (quil-parse-error "Found unexpected gate type: ~A." (token-payload parsed-gate-tok))) + (setf gate-type parsed-gate-type))) + + (ecase gate-type + (:MATRIX + (when args + (quil-parse-error "DEFGATE AS MATRIX cannot carry formal qubit arguments.")) + (parse-gate-entries-as-matrix body-lines params name :lexical-context op)) + (:PERMUTATION + (when args + (quil-parse-error "DEFGATE AS PERMUTATION cannot carry formal qubit arguments.")) + (when params + (quil-parse-error "Permutation gate definitions do not support parameters.")) + (parse-gate-entries-as-permutation body-lines name :lexical-context op)) + (:PAULI-SUM + (parse-gate-definition-body-into-pauli-sum body-lines name + :lexical-context op + :legal-arguments args + :legal-parameters params))))))))) + +(defun parse-gate-definition-body-into-pauli-sum (body-lines name &key lexical-context legal-arguments legal-parameters) + ;; is the immediate next line indented? if not, error. + (let ((*segment-encountered* nil) + (*arithmetic-parameters* nil)) + (multiple-value-bind (indented? modified-line) + (indented-line (first body-lines)) + (unless indented? + (quil-parse-error "Declaration DEFGATE ~a ... AS PAULI-SUM has empty body." + name)) + ;; strip off the indentation. + (setf body-lines (list* modified-line (rest body-lines))) + ;; otherwise, iterate til we hit a dedent token. + (loop :for line :in body-lines + :for rest-lines := (rest body-lines) :then (rest rest-lines) + :with parsed-entries := nil + :do (multiple-value-bind (dedented? modified-line) + (dedented-line-p line) + ;; if we're done, return the gate definition (and the rest of the lines) + (when dedented? + (return-from parse-gate-definition-body-into-pauli-sum + (values (make-instance 'exp-pauli-sum-gate-definition + :name name + :terms (nreverse parsed-entries) + :context lexical-context + :arguments legal-arguments + :parameters (mapcar (lambda (p) + (or (cadr (assoc p *arithmetic-parameters* :test #'equalp)) + (make-symbol (format nil "~a-UNUSED" (param-name p))))) + legal-parameters)) + (list* modified-line rest-lines)))) + ;; store this word/qubits pair as part of the gate definition + (setf parsed-entries (list* (parse-pauli-sum-line line + :lexical-context lexical-context + :legal-parameters legal-parameters + :legal-arguments legal-arguments) + parsed-entries))))))) + +(defun parse-pauli-sum-line (line &key lexical-context legal-arguments legal-parameters) + "Parses a line inside of a DEFGATE ... AS PAULI-SUM body." + (declare (ignore lexical-context legal-parameters)) + (let (pauli-word param qubit-list) + (when (null line) + (quil-parse-error "Empty line found in DEFGATE AS PAULI-SUM body.")) + ;; PAULI-WORD + (unless (eql ':NAME (token-type (first line))) + (quil-parse-error "DEFGATE AS PAULI-SUM body line begins with something other than a Pauli word: ~a" (first line))) + (setf pauli-word (token-payload (pop line))) + (unless (every (lambda (c) (member c '(#\I #\X #\Y #\Z))) pauli-word) + (quil-parse-error "DEFGATE AS PAULI-SUM body line contains Pauli word with letters other than I, X, Y, Z: ~a" + pauli-word)) + ;; LPAREN + (unless (eql ':LEFT-PAREN (token-type (first line))) + (quil-parse-error "Pauli term requires a parenthesized scalar factor, but found ~a instead of LPAREN" (first line))) + (pop line) + ;; PARAMETER + (multiple-value-bind (param-tokens line) + (take-until (lambda (x) + (pop line) + (eql ':RIGHT-PAREN (token-type x))) + line) + (when (null line) + (quil-parse-error "Pauli term has unmatched left-parenthesis.")) + (setf param (parse-arithmetic-tokens param-tokens :eval t)) + ;; RPAREN + (unless (eql ':RIGHT-PAREN (token-type (first line))) + (quil-parse-error "Expected a right parenthesis in parsing this Pauli term, but got ~a" (first line))) + (pop line) + ;; QUBIT ... QUBIT + (setf qubit-list (mapcar (lambda (tok) + (unless (eql ':NAME (token-type tok)) + (quil-parse-error "Expected a formal qubit argument, but got ~a" tok)) + (let ((ret (parse-argument tok))) + (unless (member ret legal-arguments :test #'equalp) + (quil-parse-error "Found formal qubit argument ~a not present in the argument list.")) + ret)) + line)) + ;; some further Sanity Chex: + ;; there are as many paulis as qubits + (unless (= (length qubit-list) (length pauli-word)) + (quil-parse-error "Pauli word ~a expected ~a qubit arguments, but got ~a: ~a" + pauli-word (length pauli-word) (length qubit-list) qubit-list)) + ;; the parameter body only refers to defined terms + ;; XXX + (make-pauli-term :pauli-word pauli-word + :prefactor param + :arguments qubit-list)))) + +(defun pauli-term->matrix (term arguments parameters parameter-names) + (let* ((prefactor-fn + (typecase (pauli-term-prefactor term) + (number + (lambda (&rest args) (declare (ignore args)) (pauli-term-prefactor term))) + ((or symbol cons) + (compile nil `(lambda ,parameter-names + (declare (ignorable ,@parameter-names)) + ,(pauli-term-prefactor term)))))) + (arg-count (length arguments)) + (size (expt 2 arg-count)) + (m (magicl:make-zero-matrix size size))) + (dotimes (col size) + (let ((row col) + (entry (apply prefactor-fn parameters))) + (loop :for letter :across (pauli-term-pauli-word term) + :for arg :in (pauli-term-arguments term) + :for arg-position := (- arg-count 1 (position arg arguments :test #'equalp)) + :for row-toggle := (ldb (byte 1 arg-position) col) + :do (ecase letter + (#\X + (setf row (dpb (- 1 row-toggle) (byte 1 arg-position) row)) + (setf entry (- entry))) + (#\Y + (setf row (dpb (- 1 row-toggle) (byte 1 arg-position) row)) + (setf entry (* entry (if (zerop row-toggle) #C(0 1) #C(0 -1))))) + (#\Z + (setf entry (* entry (if (zerop row-toggle) 1 -1)))) + (#\I + nil))) + (incf (magicl:ref m row col) entry))) + m)) (defun parse-gate-entries-as-permutation (body-lines name &key lexical-context) (multiple-value-bind (parsed-entries rest-lines) @@ -1411,6 +1541,26 @@ When ALLOW-EXPRESSIONS is set, we allow for general arithmetic expressions in a (values (mapcar parse-op entries) rest-line)))) +(defun parse-arguments (params-args) + ;; Parse out until we hit :AS or :COLON. + (multiple-value-bind (found-args rest-line) + (take-until (lambda (x) + (or (eql ':AS (token-type x)) + (eql ':COLON (token-type x)) + ;; do this pop last + (not (pop params-args)))) + params-args) + ;; Make sure we have tokens left over: the line can't end in this state. + (when (null rest-line) + (quil-parse-error "Unterminated argument list in DEFGATE.")) + + ;; All the intermediate tokens in found-args should be formal qubit names + (setf args (loop :for a :in found-args + :unless (eql ':NAME (token-type a)) + :do (quil-parse-error "Found something other than a formal qubit name in a DEFGATE argument list: ~A" a) + :collect (parse-argument a))) + (values args rest-line))) + ;;;;;;;;;;;;;;;;;;;;;;;;; Arithmetic Parser ;;;;;;;;;;;;;;;;;;;;;;;;;; (defun token-generator (toks) diff --git a/src/utilities.lisp b/src/utilities.lisp index a09144685..622e96aec 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -39,6 +39,17 @@ WARNING: The default will work for instances of \"idiomatic\" classes that aren' (defun (setf vnth) (val index vector) (setf (aref vector index) val)) +(defun vector-argmax (arr) + "Finds the position of the largest (using #'<) item in a nonempty vector." + (loop :with pos := 0 + :with current-max := (aref arr 0) + :for j :from 0 + :for item :across arr + :when (< current-max item) + :do (setf current-max item + pos j) + :finally (return pos))) + (defmacro dohash (((key val) hash &optional ret) &body body) `(loop :for ,key :being :the :hash-keys :of ,hash :using (hash-value ,val) diff --git a/tests/translator-tests.lisp b/tests/translator-tests.lisp index 65f463315..233854730 100644 --- a/tests/translator-tests.lisp +++ b/tests/translator-tests.lisp @@ -222,6 +222,43 @@ (format t "~& Tested ~2,2F% of all compilers." (* 100 hit-rate)) (is (< 1/10 hit-rate)))))) +(defun random-pauli-word (n) + (coerce (loop :for j :below n + :collect (case (random 4) + (0 #\X) + (1 #\Y) + (2 #\Z) + (3 #\I))) + 'string)) + +(deftest test-parametric-defexpi () + (let* ((qubit-count 3) + (string-count 6) + (pauli-strings (loop :for n :below string-count + :collect (format nil " ~a(~f*%t)~{ q~a~}" + (random-pauli-word qubit-count) (random pi) + (a:iota qubit-count)))) + (program (format nil " +PRAGMA INITIAL_REWIRING \"NAIVE\" +DECLARE time REAL +DEFGATE U(%t)~{ q~a~} AS PAULI-SUM: +~{~a~%~} + +U(time)~{ ~a~}" + (a:iota qubit-count) + pauli-strings + (a:iota qubit-count))) + (patch-table (alexandria:plist-hash-table (list "time" (random 2pi)) + :test #'equalp)) + (pp (parse-quil program)) + (original-output (quil::make-matrix-from-quil + (mapcar (a:rcurry #'%patch-mref-values patch-table) + (coerce (parsed-program-executable-code pp) 'list)))) + (cpp (compiler-hook pp (quil::build-nq-fully-connected-chip qubit-count))) + (compiled-output (quil::make-matrix-from-quil + (mapcar (a:rcurry #'%patch-mref-values patch-table) + (coerce (parsed-program-executable-code cpp) 'list))))) + (is (quil::matrix-equals-dwim original-output compiled-output)))) (defun random-permutation (list) (unless (null list)