Feature: "DEFEXPI"

cl-quil.asd

@@ -80,8 +80,9 @@
                              (:file "state-prep")
                              (:file "translators")
                              (:file "modifiers")
+                             (:file "linear-paulis")
+                             ;; attic'd files / pedagogical purposes only
                              (:file "optimal-2q")
-                             ;; attic'd file / pedagogical purposes only
                              (:static-file "cs-compile")))
                (:module "analysis"
                 :serial t

src/ast.lisp

@@ -386,6 +386,21 @@ 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 pauli-sum-gate-definition (gate-definition)
+  ((terms :initarg :terms
+          :reader pauli-sum-gate-definition-terms
+          :documentation "List of PAULI-TERMs comprising the sum.")
+   (parameters :initarg :parameters
+               :reader 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 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."))
+
+(defmethod gate-definition-qubits-needed ((gate pauli-sum-gate-definition))
+  (length (pauli-sum-gate-definition-arguments gate)))
+
 (defmethod gate-definition-qubits-needed ((gate permutation-gate-definition))
   (ilog2 (length (permutation-gate-definition-permutation gate))))
 
@@ -1528,7 +1543,26 @@ For example,
     (format stream ":~%")
     (print-instruction-sequence (circuit-definition-body defn)
                                 :stream stream
-                                :prefix "    ")))
+                                :prefix "    "))
+
+  (:method ((gate pauli-sum-gate-definition) (stream stream))
+    (format stream "DEFGATE ~A~@[(~{%~A~^, ~})~]~{ ~A~} AS PAULI-SUM:~%"
+            (gate-definition-name gate)
+            (mapcar #'string (pauli-sum-gate-definition-parameters gate))
+            (mapcar #'formal-name (pauli-sum-gate-definition-arguments gate)))
+    (dolist (pauli-term (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))
+          (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)

src/build-gate.lisp

@@ -54,16 +54,32 @@ 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)
+(defun anon-gate (operator-or-gate gate-or-parameters qubit &rest qubits)
   "Variant of BUILD-GATE for constructing anonymous gate applications."
-  (check-type operator string)
-  (check-type matrix magicl:matrix)
   (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
@@ -74,6 +90,8 @@ EXAMPLE: The Quil line \"CPHASE(pi) 2 3\" corresponds to the S-expression (build
   (apply #'build-gate (repeatedly-fork (named-operator roll-name) (length qubits))
          params qubit qubits))
 
+(defun pauli-gate (operator &rest pauli-))
+
 ;;; functions for dealing with mixed constant vs delayed-expression types
 
 (defun param-binary-op (op arg1 arg2)

src/chip/chip-specification.lisp

@@ -393,6 +393,8 @@ used to specify CHIP-SPEC."
         (constantly 'state-prep-4q-compiler)
         (constantly 'state-prep-trampolining-compiler)
         (constantly 'recognize-ucr)
+        (constantly 'parametric-pauli-compiler)
+        (constantly 'parametric-diagonal-compiler)
         (constantly 'nearest-circuit-of-depth-0)
         (lambda (chip-spec arch)
           (declare (ignore chip-spec))

src/compilers/linear-paulis.lisp

@@ -0,0 +1,252 @@
+;;;; 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
+;;;; 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 array-argmax (arr)
+  (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)))
+
+(define-compiler parametric-diagonal-compiler
+    ((instr _
+            :where (and (typep (gate-application-gate instr) 'pauli-sum-gate)
+                        (every (lambda (term) (every (lambda (letter) (or (eql letter #\Z) (eql letter #\I)))
+                                                     (pauli-term-pauli-word term)))
+                               (pauli-sum-gate-terms (gate-application-gate 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 a zero Zs / one Z: they're local gates
+      (dolist (term terms)
+        (multiple-value-bind (Z-count Z-position)
+            (loop :for letter :across (pauli-term-pauli-word term)
+                  :for j :from 0
+                  :with pos := 0
+                  :with count := 0
+                  :when (eql #\Z letter)
+                    :do (setf count (1+ count)
+                              pos j)
+                  :finally (return (values count pos)))
+          (case Z-count
+            (0
+             nil)
+            (1
+             (inst "RZ"
+                   (list (param-* 2.0d0
+                                  (tree-substitute (pauli-term-prefactor term)
+                                                   (mapcar (lambda (ep ap)
+                                                             (typecase ap
+                                                               (delayed-expression
+                                                                (cons ep (delayed-expression-expression ap)))
+                                                               (otherwise
+                                                                (cons ep ap))))
+                                                           parameters (application-parameters instr)))))
+                   (nth (position (nth Z-position (pauli-term-arguments term))
+                                  arguments :test #'equalp)
+                        (application-arguments instr))))
+            (otherwise
+             (push term nonlocal-terms)))))
+      (let ((votes (make-array (length arguments) :initial-element 0))
+            vote
+            control-qubit)
+        ;; 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.
+        (dolist (term nonlocal-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)))))
+        (setf vote (array-argmax votes)
+              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 nil) (Zs nil))
+          (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))))
+              (cond
+                (Z-pos
+                 (push (list term Z-pos) Zs))
+                (t
+                 (push term Is)))))
+          ;; emit the Is
+          (unless (endp Is)
+            (let ((I-gate (make-instance 'pauli-sum-gate
+                                         :arguments arguments
+                                         :parameters parameters
+                                         :arity arity
+                                         :dimension dimension
+                                         :name "Is"
+                                         :terms Is)))
+              (inst* I-gate
+                     (application-parameters instr)
+                     (application-arguments instr))))
+          ;; emit the Zs
+          (labels
+              ((collect-by-target (term-pairs)
+                 (when (endp term-pairs)
+                   (return-from collect-by-target nil))
+                 (let ((subvotes (make-array (length arguments))))
+                   (loop :for (term Z-pos) :in term-pairs
+                         :do (loop :for letter :across (pauli-term-pauli-word term)
+                                   :for j :from 0
+                                   :for arg :in (pauli-term-arguments term)
+                                   :when (and (not (eql j Z-pos))
+                                              (eql #\Z letter))
+                                     :do (incf (aref subvotes (position arg arguments :test #'equalp)))))
+                   (let* ((subvote-position (array-argmax subvotes))
+                          (subvote-formal (nth subvote-position arguments))
+                          (subvote-literal (nth subvote-position (application-arguments instr)))
+                          ZZs ZIs)
+                     (dolist (term-pair term-pairs)
+                       (let ((term (car term-pair)))
+                         (cond
+                           ((position subvote-formal (pauli-term-arguments term) :test #'equalp)
+                            (push term-pair ZZs))
+                           (t
+                            (push term-pair ZIs)))))
+                     (let* ((ZZ-terms
+                              (loop :for (term Z-pos) :in ZZs
+                                    :collect (make-pauli-term
+                                              :prefactor (pauli-term-prefactor term)
+                                              :arguments (pauli-term-arguments term)
+                                              :pauli-word (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))))
+                            (Z-gate (make-instance 'pauli-sum-gate
+                                                   :arguments arguments
+                                                   :parameters parameters
+                                                   :arity arity
+                                                   :dimension dimension
+                                                   :terms ZZ-terms
+                                                   :name "ZZ-GATE")))
+                       (inst "CNOT" () control-qubit subvote-literal)
+                       (inst* Z-gate
+                              (application-parameters instr)
+                              (application-arguments instr))
+                       (inst "CNOT" () control-qubit subvote-literal))
+                     (collect-by-target ZIs)))))
+            (collect-by-target Zs)))))))
+
+
+;; 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) '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
+
+      (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)
+          (let ((O (orthonormalize-matrix O)))
+            ;; 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 '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)))))))))

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)