diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,66 @@ +Contributors are listed here, in alphabetical order by last name. +Unless otherwise noted, the copyright for his or her contributions +rests with each individual author. For contributions by authors whose +name is marked (ACS), the copyright rests with Applied Communication +Sciences. + +Copyright (C) 2011-2019. All rights reserved. +Copyright (C) 2012-2013 Applied Communication Sciences. All rights +reserved. + +Richard Eisenberg +Alexander S. Green +Peter LeFanu Lumsdaine +Keith Kim (ACS) +Siun-Chuon Mau (ACS) +Baranidharan Mohan +Won Ng (ACS) +Joel Ravelomanantsoa-Ratsimihah +Neil J. Ross +Artur Scherer (ACS) +Peter Selinger +Benoît Valiron +Alexandr Virodov (ACS) +Stephan A. Zdancewic + +This research was supported by the Intelligence Advanced Research +Projects Activity (IARPA) via Department of Interior National Business +Center contract numbers D11PC20168 and D12PC00527. The U.S. Government +is authorized to reproduce and distribute reprints for Governmental +purposes notwithstanding any copyright annotation thereon. Disclaimer: +The views and conclusions contained herein are those of the authors +and should not be interpreted as necessarily representing the official +policies or endorsements, either expressed or implied, of IARPA, +DoI/NBC, or the U.S. Government. + +---------------------------------------------------------------------- +LICENSE + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +3. The name of the authors and copyright holders may not be used to + endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +---------------------------------------------------------------------- diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,76 @@ +December 29, 2019: Release 0.9.0.0 + + * Overhauled module structure: + + Old: New: + ==== ==== + + Quipper.XYZ Quipper.Internal.XYZ + QuipperLib.XYZ Quipper.Libraries.XYZ + Libraries.XYZ Quipper.Utils.XYZ + Algorithms.XYZ Quipper.Algorithms.XYZ + tests Quipper.Demos + Programs Quipper.Programs + + * Re-packaged Quipper as Cabal packages. Added executables quipper, + quipper-pp, quipperi, quipperdoc in lieu of shell scripts. + * Moved PDF Previewer to a separate library in Quipper.Utils.Preview + * Added a MonadFail instance to Circ, to keep ghc >= 7.4 happy + * Use type class synonyms to avoid warnings about simplifiable class. + * Compatibility: removed obsolete functoin Map.insertWith'. + * Added MultiControlledNot demo. + * Removed dependency on set-monad, which is broken upstream. + * Fixed some bugs in the stabilizer simulation. + * Moved QuantumIf from BF to Libraries. + * Added --help option to all Quipper tools. + * Removed Quipper.Utils.ShowAll + * Fixed some compiler errors and removed some unnecessary type class + assumptions. + +July 27, 2016: Release 0.8 + + * Portability: compatibility fixes for GHC 8.0. Note: GHC 7.10 is too + broken and will not be supported by Quipper. + * Added tests/SimulationTest + * Added QPrep and QUnPrep to the simulator + +October 14, 2014: Release 0.7 + + * Portability: compatibility fixes for GHC 7.8. + +January 16, 2014: Release 0.6 + + * Minor edits and documentation updates. + * Added a new gate gate_iX_inv + * Added "alternate" version of synthesis algorithm, using only + generators of determinant 1 if possible. + * Synthesis code is now in an external package "newsynth". + * Rendering code is now in an external package "easyrender". + * Updated for use with fixedprec-0.2.1.0. + +September 2, 2013: Release 0.5 + + * Portability: compatibility fixes for GHC 7.6.2. + * Portability: fixed Windows incompatibility bug. Handling of Ctrl-C + may or may not work on Windows, depending on console. + * Added quipperi script, analogous to ghci. + * New library QuipperLib.ClassicalOptim: algebraic optimization of + auto-generated classical circuits. Added "optimized" oracle to BWT + algorithm. + * QuipperLib.Decompose: Added decomposition into a "standard" gate + set, consisting of X, Y, Z, H, S, S-dagger, T, T-dagger, and CNOT. + Added KeepPhase flag to some transformers. + * QuipperLib.GateDecompositions: added more gates. + * New library Libraries.Synthesis.RotationDecomposition: implements a + variant of the algorithm from Nielsen and Chuang to decompose an + nxn unitary operator into one- and two-level rotations. + * New library QuipperLib.Unboxing: unboxing transformers. + * Updated ASCII output format; improved circuit parser efficiency. + * Miscellaneous bug fixes: malformed W-gates, qdata_of_qubits, + floorlog. + * Fixed handling of iterated subroutines in depth transformer. + * Documentation updates and minor refactoring. + +June 19, 2013: Release 0.4 + + * First public release. diff --git a/Quipper/Algorithms/BF/BooleanFormula.hs b/Quipper/Algorithms/BF/BooleanFormula.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/BF/BooleanFormula.hs @@ -0,0 +1,888 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This module contains the implementation of the various quantum circuits +-- that make up the boolean formula algorithm. Please see "Quipper.Algorithms.BF.Main" +-- for an overview of the boolean formula algorithm. + +module Quipper.Algorithms.BF.BooleanFormula where + +import Quipper +import Quipper.Internal +import Quipper.Algorithms.BF.Hex +import Quipper.Libraries.QFT +import Quipper.Libraries.QuantumIf +import Quipper.Libraries.Simulation +import Quipper.Libraries.Decompose + +import Quipper.Utils.Auxiliary (mmap) + +import Data.Typeable + +-- ---------------------------------------------------------------------- +-- * Classical data structures + +-- ** Oracle description + +-- $ We define a data structure to hold the various parameters that +-- are used to define an oracle. + +-- | The input to the BF Algorithm is the description of an oracle to +-- represent a given size of hex board, and a given size for the phase +-- estimation register. +data BooleanFormulaOracle = BFO { + oracle_x_max :: Int, -- ^ The /x/-dimension of hex board. + oracle_y_max :: Int, -- ^ The /y/-dimension of hex board. + oracle_t :: Int, -- ^ Size of phase estimation register. + + -- The number of moves remaining can + -- depend on the starting state of the HexBoard + oracle_s :: Int, -- ^ Number of moves remaining. + -- This should start as /x/⋅/y/, if no moves have been made. + oracle_m :: Int, -- ^ Size of the direction register, + -- i.e., size of labels on the BF tree. + -- This should be the ceiling of log(/x/⋅/y/). + + + start_board :: HexBoard, -- ^ A description of the starting state of the + -- board, and can be used to calculate /s/. + oracle_hex :: HexCircuit -- ^ An extra flag that we can use so that different + -- HEX circuits can be used instead of the full circuit. + +} + +-- | A type to define which Hex circuit to use. +data HexCircuit = Hex -- ^ The actual Hex circuit. + | Dummy -- ^ A Dummy Hex circuit. + | EmptyHex -- ^ Nothing. + +-- | Create an oracle description. This only requires /x/, /y/, and +-- /t/ to be specified, as the remaining values can be calculated. The number of +-- moves remaining, /s/, is calculated as the total number of squares on the board, +-- and /m/ is calculated as the number of bits required to represent /s/+1. +createOracle :: Int -> Int -> Int -> BooleanFormulaOracle +createOracle x y t = BFO { + oracle_x_max = x, + oracle_y_max = y, + oracle_t = t, + oracle_s = s, + oracle_m = m, + start_board = (empty,empty), + oracle_hex = Hex +} where s = x * y + m = ceiling (log (fromIntegral (s+1)) / log 2) + empty = replicate s False + +-- | A function to set the \"Dummy\" flag in the given oracle to the given +-- 'HexCircuit' value. +update_hex :: BooleanFormulaOracle -> HexCircuit -> BooleanFormulaOracle +update_hex bfo hex = bfo {oracle_hex = hex} + +-- | Update the 'start_board' in the given oracle, with the given 'HexBoard'. This +-- also updates the 'oracle_s' field of the oracle to be in line with +-- the new 'start_board'. +update_start_board :: BooleanFormulaOracle -> HexBoard -> BooleanFormulaOracle +update_start_board bfo start = bfo { + oracle_s = s, + start_board = start + } where + x = oracle_x_max bfo + y = oracle_y_max bfo + s = (x*y) - (moves_made start) + +-- | An oracle for a 9 by 7 Hex board, with the parameters: +-- /x/=9, /y/=7, /t/=189. The calculated values are: /s/=63, /m/=6. +full_oracle :: BooleanFormulaOracle +full_oracle = createOracle 9 7 189 + +-- | A smaller oracle for testing purposes. The numbers should be +-- chosen such that /x/⋅/y/ = 2[sup /n/]−1 for some /n/. Here, we set +-- /x/=3 and /y/=5, to give /x/⋅/y/=15. We arbitrarily set the size of +-- the phase estimation register to /t/=4. +test_oracle :: BooleanFormulaOracle +test_oracle = createOracle 5 3 4 + +-- ** Hex boards + +-- | A hex board is specified by a pair of lists of booleans. For a +-- board of size /x/ by /y/, each list should contain /x/⋅/y/ +-- elements. The first list is the \"blue\" bitmap, and the second is +-- the \"red\" maskmap. +type HexBoard = ([Bool],[Bool]) + +-- | A function to determine how many moves have been made on a given HexBoard. +-- This function assumes that the given 'HexBoard' is valid, in the sense that +-- no duplicate moves have been made. +moves_made :: HexBoard -> Int +moves_made (blue,red) = moves blue + moves red + where moves color = length (filter id color) + +-- | A function to determine which spaces are still empty in the given HexBoard. +-- This function assumes that the given 'HexBoard' is valid, in the sense that +-- no duplicate moves have been made. This function will return a list of all the +-- empty spaces remaining, in strictly increasing order. +empty_spaces :: HexBoard -> [Int] +empty_spaces (blue,red) = empty_spaces' blue red 0 + where + empty_spaces' [] [] _ = [] + empty_spaces' [] _ _ = error "empty_spaces: Red and Blue boards of different length" + empty_spaces' _ [] _ = error "empty_spaces: Red and Blue boards of different length" + empty_spaces' (b:bs) (r:rs) n = if (b || r) then rest else (n:rest) + where rest = empty_spaces' bs rs (n+1) + +-- ---------------------------------------------------------------------- +-- * Quantum data structures + +-- $ Some data structures to help in defining the algorithm. + +-- | The phase estimation register is a simple register of qubits. This is kept +-- separate from the rest of the 'BooleanFormulaRegister' as it is this register +-- which will be measured at the end of the algorithm. +type PhaseEstimationRegister = [Qubit] + +-- | The direction register is a simple register of qubits, +-- made explicit here so we can see that a \"position\" is a list of directions. +type GenericDirectionRegister a = [a] + +-- | A type synonym defined as the 'Qubit' instance of a +-- 'GenericDirectionRegister'. +type DirectionRegister = GenericDirectionRegister Qubit + +-- | The rest of the boolean formula algorithm requires a register which is +-- split into 3 main parts. +data GenericBooleanFormulaRegister a = BFR { + -- | The position register is split into two parts: + -- the leaf and paraleaf \"flags\". + position_flags :: (a,a), + -- | The current position, and how we got there, i.e., directions we followed. + -- Any position can be reached by at most /x/⋅/y/ directions. + position :: [GenericDirectionRegister a], + work_leaf :: a, + work_paraleaf :: a, + work_binary :: a, + work_height :: a, + work_r :: a, + work_rp :: a, + work_rpp :: a, -- ^ Seven flags that make up the work register. + direction :: GenericDirectionRegister a -- ^ The direction register. +} + deriving (Typeable, Show) + +-- | A type synonym defined as the 'Qubit' instantiation of a +-- 'GenericBooleanFormulaRegister'. +type BooleanFormulaRegister = GenericBooleanFormulaRegister Qubit + +-- | A function to add labels to the wires that make up a 'BooleanFormulaRegister'. +-- These labels correspond to the parts of the register. +labelBFR :: BooleanFormulaRegister -> Circ () +labelBFR reg = do + let tuple = toTuple reg + label tuple (("pos-leaf","pos-paraleaf"), + "pos", + ("leaf","paraleaf","binary","height","r","rp","rpp"), + "dir") + +-- | A type synonym defined as the 'Bool' instantiation of a +-- 'GenericBooleanFormulaRegister'. +type BoolRegister = GenericBooleanFormulaRegister Bool + +-- | Helper function to simplify the 'QCData' instance for 'BooleanFormulaRegister'. +-- Create a tuple from a 'GenericBooleanFormulaRegister'. +toTuple :: GenericBooleanFormulaRegister a -> ((a,a),[[a]],(a,a,a,a,a,a,a),[a]) +toTuple r = (position_flags r,position r,(work_leaf r,work_paraleaf r,work_binary r,work_height r,work_r r,work_rp r,work_rpp r),direction r) + +-- | Helper function to simplify the 'QCData' instance for 'BooleanFormulaRegister'. +-- Create a 'GenericBooleanFormulaRegister' from a tuple. +fromTuple :: ((a,a),[[a]],(a,a,a,a,a,a,a),[a]) -> GenericBooleanFormulaRegister a +fromTuple (pf,p,(wl,wp,wb,wh,wr,wrp,wrpp),d) = BFR { + position_flags = pf, + position = p, + work_leaf = wl, + work_paraleaf = wp, + work_binary = wb, + work_height = wh, + work_r = wr, + work_rp = wrp, + work_rpp = wrpp, + direction = d + } + +type instance QCType x y (GenericBooleanFormulaRegister a) = GenericBooleanFormulaRegister (QCType x y a) +type instance QTypeB (GenericBooleanFormulaRegister a) = GenericBooleanFormulaRegister (QTypeB a) +instance QCData a => QCData (GenericBooleanFormulaRegister a) where + qcdata_mapM s f g xs = mmap fromTuple $ qcdata_mapM (toTuple s) f g (toTuple xs) + qcdata_zip s q c q' c' xs ys e = fromTuple $ qcdata_zip (toTuple s) q c q' c' (toTuple xs) (toTuple ys) e + qcdata_promote a x s = fromTuple $ qcdata_promote (toTuple a) (toTuple x) s +instance (Labelable a String) => Labelable (GenericBooleanFormulaRegister a) String where + label_rec r s = do + label_rec (position_flags r) s `dotted_indexed` "posflag" + label_rec (position r) s `dotted_indexed` "pos" + label_rec (work_leaf r) s `dotted_indexed` "leaf" + label_rec (work_paraleaf r) s `dotted_indexed` "paraleaf" + label_rec (work_binary r) s `dotted_indexed` "binary" + label_rec (work_height r) s `dotted_indexed` "height" + label_rec (work_r r) s `dotted_indexed` "r" + label_rec (work_rp r) s `dotted_indexed` "rp" + label_rec (work_rpp r) s `dotted_indexed` "rpp" + label_rec (direction r) s `dotted_indexed` "dir" + +-- | Create an initial classical 'BooleanFormulaRegister' for a given oracle description. +-- The /position/ register is initialized in the /zero/ state that represents being +-- at label /zero/, or node /rpp/ in the tree. The work qubits are all initialized to +-- /zero/, as the first call to the /oracle/ circuit will set them accordingly for +-- the /position/ we are currently in. The /direction/ register is also set to /zero/ +-- as this is the direction in which the node /rp/ is in. The given +-- 'BooleanFormulaOracle' is used to make sure the registers are of the correct +-- size, i.e., number of qubits. +createRegister :: BooleanFormulaOracle -> BoolRegister +createRegister oracle = BFR { + position_flags = (False,False), + position = replicate s (replicate m False), + work_leaf = False, + work_paraleaf = False, + work_binary = False, + work_height = False, + work_r = False, + work_rp = False, + work_rpp = False, + direction = replicate m False + } where + s = oracle_s oracle + m = oracle_m oracle + +-- | Create a shape parameter for a 'BooleanFormulaRegister' of the +-- correct size. +registerShape :: BooleanFormulaOracle -> BooleanFormulaRegister +registerShape oracle = qshape (createRegister oracle) + +-- | Initialize a 'BooleanFormulaRegister' from a 'BooleanFormulaOracle'. +initializeRegister :: BooleanFormulaOracle -> Circ BooleanFormulaRegister +initializeRegister oracle = qinit (createRegister oracle) + +-- ====================================================================== +-- * Oracle implementation + +-- $ The functions in this implementation follow a separation of the boolean +-- formula algorithm into two parts. The first part corresponds to the +-- algorithms defined in this module. The second part consists of the +-- algorithms defined in "Quipper.Algorithms.BF.Hex". This separation relates to the +-- first part defining the quantum parts of the algorithm, including the +-- phase estimation, and the quantum walk, whereas the remaining four define +-- the classical implementation of the circuit for determining which player +-- has won a completed game of Hex, which is converted to a quantum circuit +-- using Quipper's \"build_circuit\" keyword. +-- +-- Note that the circuits for the algorithms in this module have been tested +-- for performing a quantum walk on the tree defined for a given oracle (but +-- with a dummy function taking the place of the call to HEX). + +-- | The overall Boolean Formula Algorithm. It initializes the +-- phase estimation register into an equal super-position of all 2[sup t] states, +-- and the other registers as defined previously. It then maps the exponentiated +-- version of the unitary /u/, as per phase estimation, before applying the +-- inverse QFT, and measuring the result. +qw_bf :: BooleanFormulaOracle -> Circ [Bit] +qw_bf oracle = do + -- initialize the phase estimation register, + -- and put it in an equal super-position + let t = oracle_t oracle + a <- qinit (replicate t False) + label a "a" + a <- mapUnary hadamard a + -- initialize the other boolean formula registers + b <- initializeRegister oracle + labelBFR b + -- we can use a separate recursive function to map the exp_u algorithm over a + let t = oracle_t oracle + map_exp_u oracle a b (t-1) + -- qft is defined, so we reverse it to get inverse qft + a <- (subroutine_inverse_qft oracle) a + -- we're only interested in the result of measuring a, + -- so we can discard all the qubits in the rest of the register + qdiscard b + measure a + +-- | The inverse quantum Fourier transform as a boxed subroutine. +subroutine_inverse_qft :: BooleanFormulaOracle -> [Qubit] -> Circ [Qubit] +subroutine_inverse_qft o = box "QFT*" (reverse_generic_endo qft_little_endian) + +-- | \"Map\" the application of the exponentiated unitary /u/ +-- over the phase estimation register. That is, each qubit in the phase estimation +-- register is used as a control over a call to the unitary /u/, exponentiated to +-- the appropriate power. +map_exp_u :: BooleanFormulaOracle -> [Qubit] -> BooleanFormulaRegister -> Int -> Circ () +map_exp_u _ [] _ _ = return () +map_exp_u o (a:as) b l = do + let x_max = oracle_x_max o + -- we can move the control out of the exp_u function + exp_u o (2^(l-(length as))) b `controlled` a + map_exp_u o as b l + +-- | Exponentiate the unitary /u/. In this implementation, this is +-- achieved by repeated application of /u/. +exp_u :: BooleanFormulaOracle -> Integer -> BooleanFormulaRegister -> Circ () +exp_u _ 0 _ = return () +exp_u o n_steps b = do + (subroutine_u o) b + exp_u o (n_steps-1) b + +-- | The unitary /u/ represents a single step in the walk on the NAND tree. A call +-- to the oracle determines what type of node we are at (so we know which directions +-- are valid to step to), the call to diffuse sets the direction register to be a +-- super-position of all valid directions, the call to walk performs the step, and then +-- the call to undo oracle has to clean up the work registers that were set by the +-- call to the oracle. Note that the undo oracle step is not simply the inverse of the +-- oracle, as we have walked since the oracle was called. +u :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +u o b = do + comment "U" + labelBFR b + (subroutine_oracle o) b + (subroutine_diffuse o) b + (subroutine_walk o) b + (subroutine_undo_oracle o) b + +-- | The circuit for 'u' as a boxed subroutine. +subroutine_u :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +subroutine_u o = box "U" (u o) + +-- | Call the oracle to determine some extra information about where +-- we are in the tree. Essentially, the special cases are when were are at one of +-- the three \"low height\" nodes, or when we are at a node representing a complete +-- game of Hex, and we need to determine if this is a leaf, by calling the hex circuit, +-- which determines whether the node represents a completed game of hex in which +-- the red player has won. +oracle :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +oracle o register = do + comment "ORACLE" + labelBFR register + let init = start_board o + let x_max = oracle_x_max o + let (is_leaf,is_paraleaf) = position_flags register + with_controls (is_leaf) + ( -- if is_leaf + -- we are at a leaf node, so set "leaf" + do + let leaf = work_leaf register + qnot_at leaf + ) + with_controls (is_leaf .==. False .&&. is_paraleaf .==. True) + ( -- else if is_paraleaf + -- we are at a paraleaf node, so set "paraleaf" + do + let paraleaf = work_paraleaf register + qnot_at paraleaf + let binary = work_binary register + qnot_at binary + let pos = position register + let hex_subroutine = case oracle_hex o of + Hex -> box "HEX" (hex_oracle init (oracle_s o) x_max) + Dummy -> hex_oracle_dummy + EmptyHex -> \x -> return x + -- hex sets "binary" flag depending on whether the paraleaf is attached to a + -- a leaf, i.e., whether red has won or lost the game of hex. + hex_subroutine (pos,binary) + return () + ) + with_controls (is_leaf .==. False .&&. is_paraleaf .==. False) + ( -- else + -- we're not at a leaf node, or paraleaf node + do + let pos = position register + -- are we at a "low height" node? + with_controls (controls is_paraleaf pos) + ( -- we're at a "low height" node + do + let pos'' = pos !! (length pos - 2) + let pos_m = last pos'' + with_controls pos_m + ( -- if pos_m == 1 + do + let height = work_height register + qnot_at height + ) + let pos' = last pos + let pos_1 = pos' !! (length pos' - 2) + with_controls (pos_m .==. False .&&. pos_1 .==. True) + ( -- else if pos_1 == 1 + do + let r = work_r register + qnot_at r + ) + let pos_0 = last pos' + with_controls (pos_m .==. False .&&. pos_1 .==. False .&&. pos_0 .==. True) + ( -- else if pos_0 == 1 + do + let rp = work_rp register + qnot_at rp + let binary = work_binary register + qnot_at binary + ) + with_controls (pos_m .==. False .&&. pos_1 .==. False .&&. pos_0 .==. False) + ( -- else + do + let rpp = work_rpp register + qnot_at rpp + ) + ) + ) + +-- | The circuit for the 'oracle' as a boxed subroutine. +subroutine_oracle :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +subroutine_oracle o = box "Oracle" (oracle o) + +-- | The controls to use, to see if we're at a \"low height\" node. +controls :: Qubit -> [DirectionRegister] -> [ControlList] +controls is_paraleaf pos = (is_paraleaf .==. False) : ctrls pos + where ctrls [] = [] + ctrls [p] = [] + ctrls [p,q] = [] + ctrls (p:ps) = (last p .==. False) : ctrls ps + +-- | Diffuse the direction register, to be a super-position of all valid +-- directions from the current node. Note, that this implementation of the boolean +-- formula algorithm does not applying the correct weighting scheme to the NAND graph, +-- which would require this function to diffuse with respect to the weighting scheme. +diffuse :: BooleanFormulaRegister -> Circ () +diffuse register = do + comment "DIFFUSE" + labelBFR register + let binary = work_binary register + let dir = direction register + with_controls binary + ( -- if binary == 1 + do + let dir_0 = last dir + hadamard_at dir_0 + ) + let leaf = work_leaf register + let rpp = work_rpp register + with_controls (binary .==. False .&&. leaf .==. False .&&. rpp .==. False) + ( -- else (controlled on binary == 0, leaf == 0, rpp == 0) + do + mapUnary hadamard dir + ) + return () + +-- | The circuit for 'diffuse' as a boxed subroutine. +subroutine_diffuse :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +subroutine_diffuse o = box "Diffuse" diffuse + +-- | A datatype to use instead of passing integers to 'toParent' and 'toChild' +-- to define what needs to be shifted. This is used as only three different +-- shift widths are ever used in the algorithm. +data Where = Width -- ^ corresponds to shifting all qubits. + | M -- ^ corresponds to shifting only /m/+1 qubits. + | M2 -- ^ corresponds to shifting only 2/m/+1 qubits. + deriving Eq + +-- | Define a step on the NAND graph, in the direction specified +-- by the direction register, and updates the direction register to be where +-- we have stepped from. +-- For this algorithm we have developed the 'if_then_elseQ' construct, which +-- gives us a nice way of constructing if/else statements acting on +-- boolean statements over qubits (see "Quipper.Libraries.QuantumIf"). +walk :: BooleanFormulaRegister -> Circ () +walk register = do + comment "WALK" + labelBFR register + let leaf = work_leaf register + let paraleaf = work_paraleaf register + let dir = direction register + let dir_0 = last dir + let (is_leaf,is_paraleaf) = position_flags register + let pos = position register + let pos_0 = last (last pos) + let pos_1 = last (init (last pos)) + let height_1 = work_height register + let rpp = work_rpp register + let rp = work_rp register + let r = work_r register + let dir_all_1 = foldr1 (\x y -> And x y) (map A dir) + let boolean_statement_in = Or (A leaf) (And (A paraleaf) (Not (A dir_0))) + let boolean_statement_out = Or (A leaf) (And (A paraleaf) (A is_leaf)) + if_then_elseQinv boolean_statement_in + ( -- if leaf == 1 or (paraleaf == 1 and dir_0 == 0) + do + qnot_at is_leaf + ) + ( -- else (leaf == 0 and (paraleaf == 0 or dir_0 == 1)) + do + let boolean_statement_in = And (A paraleaf) (A dir_0) + let boolean_statement_out = And (A paraleaf) (Not (dir_all_1)) + if_then_elseQinv boolean_statement_in + ( -- if paraleaf == 1 and dir_0 == 1 + toParent Width register + -- now, dir /= 1..1, so dir_0 could be either 0 or 1 + ) + ( -- else (paraleaf == 0 or dir_0 == 0) + do + let boolean_statement_in = Or (A rpp) (And (A rp) (A dir_0)) + let boolean_statement_out = Or (A rpp) (And (A rp) (Not (A dir_0))) + if_then_elseQinv boolean_statement_in + ( -- if rpp == 1 or (rp == 1 and dir_0 == 1 ) + do + qnot_at pos_0 + -- dir_0 should be changed, + -- as we're moving from rp to rpp, and rpp only has a child at 0 + -- or we're moving from rpp to rp, and dir_0 should be set to 1 as + -- we have come from a parent + qnot_at dir_0 + ) + ( -- else (rpp == 0 and (rp == 0 or dir_0 == 0)) + do + let boolean_statement_in = Or (And (A rp) (Not (A dir_0))) (And (A r) dir_all_1) + let pos_m = last (last (init pos)) + let boolean_statement_out = Or (And (A rp) dir_all_1) (And (A r) (And (Not dir_all_1) (Not (A pos_m)))) + if_then_elseQinv boolean_statement_in + ( -- if (rp == 1 and dir_0 == 0) or (r == 1 and dir == 1..1) + do + qnot_at pos_1 + -- we know that pos_m == 0 + -- dir is should be changed + -- when we move from rp to r, and when we move from r to rp + mapUnary qnot dir + return () + ) + ( -- else ((rp == 0 or dir_0 == 1) and (r == 0 or dir /= 1..1)) + do + let boolean_statement = A r + if_then_elseQ boolean_statement + ( -- if r == 1 + do + qnot_at pos_1 + toChild M register + -- now dir == 1..1 + -- we also know that pos_m == 1 + ) + ( -- else + do + let boolean_statement_in = And (A height_1) (dir_all_1) + let boolean_statement_out = And (A height_1) (Not dir_all_1) + if_then_elseQinv boolean_statement_in + ( -- if height_1 == 1 and dir == 1..1 + do + toParent M register + qnot_at pos_1 + -- now, dir /= 1..1 + ) + ( -- else height_1 == 0 or dir /= 1..1 + do + let boolean_statement = A height_1 + if_then_elseQ boolean_statement + ( -- if height_1 == 1 (and dir /= 1..1) + do + toChild M2 register + -- now dir == 1..1 + ) + ( -- else (if height_1 == 0) + do + let boolean_statement_in = dir_all_1 + let boolean_statement_out = Not dir_all_1 + if_then_elseQinv boolean_statement_in + ( -- if dir = 1..1 + do + toParent Width register + -- now dir /= 1..1 + ) + ( --else (dir /= 1..1) + do + toChild Width register + -- now dir == 1..1 + ) boolean_statement_out + ) + ) boolean_statement_out + ) + ) boolean_statement_out + ) boolean_statement_out + ) boolean_statement_out + ) boolean_statement_out + return () + +-- | The circuit for 'walk' as a boxed subroutine. +subroutine_walk :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +subroutine_walk o = box "Walk" walk + +-- | Uncompute the various flags that were set by the initial call +-- to the oracle. It has to uncompute the flags depending on where we were before +-- the walk step, so isn't just the inverse of the oracle. +undo_oracle :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +undo_oracle o register = do + comment "UNDO_ORACLE" + labelBFR register + let initHB = start_board o + let x_max = oracle_x_max o + let paraleaf = work_paraleaf register + let (is_leaf,is_paraleaf) = position_flags register + with_controls paraleaf + ( do + let binary = work_binary register + let pos = position register + let dir = direction register + let hex_subroutine = case oracle_hex o of + Hex -> box "HEX" (hex_oracle initHB (oracle_s o) x_max) + Dummy -> hex_oracle_dummy + EmptyHex -> \x -> return x + hex_subroutine (pos,binary) + return () + ) + let leaf = work_leaf register + let dir = direction register + let dir_0 = last dir + let boolean_statement = And (Not (A is_leaf)) (And (A is_paraleaf) (Not (A dir_0))) + if_then_elseQ boolean_statement + ( -- if is_leaf == 0 and is_paraleaf == 1 and dir_0 == 0 + -- we went from a leaf to a paraleaf, so we can unset leaf + do + qnot_at leaf + ) + ( -- else + do + let binary = work_binary register + let pos = position register + let pos_w_2_m = last (head pos) + let dir_all_1 = foldr1 (\x y -> And x y) (map A dir) + let boolean_statement = Or (A is_leaf) (And (Not (A is_leaf)) (And (Not (A is_paraleaf)) (And (A pos_w_2_m) (Not (dir_all_1))))) + if_then_elseQ boolean_statement + ( -- if is_leaf == 1 or (is_leaf == 0 and is_paraleaf == 0 and pos_w_2_m == 1 and dir /= 1..1) + -- we went from a paraleaf to a leaf, so unset binary and paraleaf + -- or we went from a paraleaf to its parent... + do + qnot_at binary + qnot_at paraleaf + ) + ( -- else + do + with_controls (init (controls is_paraleaf pos)) + ( -- if pos_sm,pos_(s-1)m,...,3. == 00...0 + do + let height = work_height register + let r = work_r register + let rp = work_rp register + let pos_0 = last (last pos) + let pos_1 = last (init (last pos)) + let pos_m = last (last (init pos)) + let pos_2m = last (last (init (init pos))) + let boolean_statement = dir_all_1 + if_then_elseQ boolean_statement + ( -- if dir = 1...1 + do + qnot_at height `controlled` pos_2m + qnot_at r `controlled` (pos_2m .==. False .&&. pos_m .==. True) + with_controls (pos_2m .==. False .&&. pos_m .==. False .&&. pos_1 .==. True) + ( + do + qnot_at rp + qnot_at binary + ) + ) + ( -- else + with_controls (pos_2m .==. False .&&. pos_m .==. False) + ( + do + let rpp = work_rpp register + qnot_at height `controlled` pos_1 + qnot_at rpp `controlled` (pos_1 .==. False .&&. dir_0 .==. True) + qnot_at r `controlled` (pos_1 .==. False .&&. dir_0 .==. False .&&. pos_0 .==. True) + with_controls (pos_1 .==. False .&&. dir_0 .==. False .&&. pos_0 .==. False) + ( + do + qnot_at rp + qnot_at binary + ) + ) + ) + ) -- end if + ) + ) + return () + +-- | The circuit for 'undo_oracle' as a boxed subroutine. +subroutine_undo_oracle :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +subroutine_undo_oracle o = box "Undo Oracle" (undo_oracle o) + +-- | Define the circuit that updates the position register to be the +-- parent node of the current position. +toParent :: Where -> BooleanFormulaRegister -> Circ () +toParent M2 _ = error "TOPARENT should never be called with 2m+1 as width" +toParent w register = do + let pos = position register :: [[Qubit]] -- of length x*y + let pos_firstM = last pos :: [Qubit] -- of length m + let pos_secondM = last (init pos) :: [Qubit] -- of length m + let pos_0 = last pos_firstM :: Qubit + let pos_m = last pos_secondM :: Qubit + let dir = direction register :: [Qubit] -- of length m + let (_,is_paraleaf) = position_flags register :: (Qubit,Qubit) + mapUnary qnot dir + mapBinary copy_from_to (reverse pos_firstM) (reverse dir) + if (w == Width) then + ( do -- width + -- we need to shift everything to the right by m + shift_right pos + -- we need to shift is_paraleaf to x*y*m + copy_from_to is_paraleaf (last (head pos)) + return () + ) else return () + if (w == M) then + ( do -- m+1 + -- we need to "shift" pos_m to pos_0 + copy_from_to pos_m pos_0 + return () + ) else return () + +-- | @'copy_from_to' a b@: Sets the state of qubit /b/ to be the state of qubit /a/, +-- (and the state of /a/ is lost in the process, so this is not cloning). +-- It falls short of swapping /a/ and /b/, as we're not interested in preserving /a/. +copy_from_to :: Qubit -> Qubit -> Circ (Qubit,Qubit) +copy_from_to from to = do + qnot_at to `controlled` from + qnot_at from `controlled` to + return (from,to) + +-- | Define the circuit that updates the position register to be the +-- child node of the current position. +toChild :: Where -> BooleanFormulaRegister -> Circ () +toChild w register = do + let pos = position register :: [[Qubit]] -- of length x*y + let pos_firstM = last pos :: [Qubit] -- of length m + let pos_secondM = last (init pos) :: [Qubit] -- of length m + let pos_thirdM = last (init (init pos)) :: [Qubit] -- of length m + let pos_0 = last pos_firstM :: Qubit + let pos_m = last pos_secondM :: Qubit + let pos_2m = last pos_thirdM :: Qubit + let dir = direction register :: [Qubit] -- of length m + let (_,is_paraleaf) = position_flags register :: (Qubit,Qubit) + if (w == Width) then + ( do -- width + -- we need to "shift" x*y*m to is_paraleaf + copy_from_to (last (head pos)) is_paraleaf + -- we need to "shift" everything to the left by "m" + shift_left pos + ) else return () + if (w == M2) then + ( do -- 2m+1 + -- we need to "shift" pos_m to pos_2m + copy_from_to pos_m pos_2m + -- we need to "shift" 0.. to m.. to + shift_left [pos_secondM,pos_firstM] + ) else return () + if (w == M) then + ( do + -- we need to "shift" pos_0 to pos_m + copy_from_to pos_0 pos_m + return () + ) else return () + mapBinary copy_from_to dir pos_firstM + mapUnary qnot dir + return () + +-- | Shift every qubit in a register to the left by one. +shift_left :: [DirectionRegister] -> Circ () +shift_left [] = return () +shift_left [d] = return () +shift_left (d:d':ds) = do + mapBinary copy_from_to d' d + shift_left (d':ds) + +-- | Shift every qubit in a register to the right by one. +shift_right :: [DirectionRegister] -> Circ () +shift_right [] = return () +shift_right [d] = return () +shift_right (d:d':ds) = do + shift_right (d':ds) + mapBinary copy_from_to (reverse d) (reverse d') + -- the arguments are reversed to give a nice symmetry to the circuits + -- and should be equivalent to if they're not reversed + return () + +-- ---------------------------------------------------------------------- +-- * Possible main functions + +-- $ The following functions define various \main\ functions that can be called +-- from an overall \main\ function to display various parts of the +-- overall Boolean Formula Algorithm. The Boolean +-- Formula Algorithm is split into 13 sub-algorithms, each of which can be +-- displayed separately, or in various combinations. + +-- | Displays the overall Boolean Formula circuit for a given oracle description. +main_circuit :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_circuit f g oracle = print_simple f (decompose_generic g (qw_bf oracle)) + +-- | Display just 1 time-step of the given oracle, +-- i.e., one iteration of the 'u' from 'exp_u', with no controls. +main_u :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_u f g o = print_generic f (decompose_generic g (u o)) (registerShape o) + +-- | Display just 1 time-step of the 'walk' algorithm for the given oracle, +-- i.e., one iteration of /walk/, with no controls. +main_walk :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_walk f g o = print_generic f (decompose_generic g walk) (registerShape o) + +-- | Display just 1 time-step of the 'diffuse' algorithm for the given oracle, +-- i.e., one iteration of /diffuse/, with no controls. +main_diffuse :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_diffuse f g o = print_generic f (decompose_generic g diffuse) (registerShape o) + +-- | Display just 1 time-step of the 'oracle' algorithm for the given oracle, +-- i.e., one iteration of /oracle/, with no controls. +main_oracle :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_oracle f g o = print_generic f (decompose_generic g (oracle o)) (registerShape o) + +-- | Display just 1 time-step of the 'undo_oracle' algorithm for the given oracle, +-- i.e., one iteration of /undo_oracle/, with no controls. +main_undo_oracle :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_undo_oracle f g o = print_generic f (decompose_generic g (undo_oracle o)) (registerShape o) + +-- | Display the circuit for the Hex algorithm, for the given oracle, +-- i.e., one iteration of 'hex_oracle', with no controls. +main_hex :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_hex f g o = print_generic f (decompose_generic g (hex_oracle init s x_max)) (pos,binary) + where + init = start_board o + s = oracle_s o + x_max = oracle_x_max o + reg = registerShape o + pos = position reg + binary = work_binary reg + +-- | Display the circuit for the Checkwin_red algorithm, for the given oracle, +-- i.e., one iteration of 'checkwin_red_circuit', with no controls. +main_checkwin_red :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_checkwin_red f g o = print_generic f (decompose_generic g (checkwin_red_circuit x_max)) (qshape redboard,qubit) + where + (redboard,_) = start_board o + x_max = oracle_x_max o + +-- ---------------------------------------------------------------------- +-- * Running the Boolean Formula Algorithm + +-- $ The following functions define the way that the Boolean Formula Algorithm +-- would be run, if we had access to a quantum computer. Indeed, the functions +-- here interface with the "QuantumSimulation" quantum simulator so that they +-- can be built. + +-- | Approximation of how the algorithm would be run if we had a quantum computer: +-- uses QuantumSimulation run_generic_io function. The output of the algorithm will +-- be all False only in the instance that the Blue player wins the game. +main_bf :: BooleanFormulaOracle -> IO Bool +main_bf oracle = do + output <- run_generic_io (undefined :: Double) (qw_bf oracle) + let result = if (or output) then True -- a /= 0 (Red Wins) + else False -- a == 0 (Blue Wins) + return result + +-- | Display the result of 'main_bf', +-- i.e., either \"Red Wins\", or \"Blue Wins\" is the output. +whoWins :: BooleanFormulaOracle -> IO () +whoWins oracle = do + result <- main_bf oracle + if result then putStrLn "Red Wins" + else putStrLn "Blue Wins" + +-- | Run 'whoWins' for the given oracle, and its \"initial\" board. +main_whoWins :: BooleanFormulaOracle -> IO () +main_whoWins o = whoWins o diff --git a/Quipper/Algorithms/BF/Hex.hs b/Quipper/Algorithms/BF/Hex.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/BF/Hex.hs @@ -0,0 +1,424 @@ +-- | This module contains the implementation of the circuits for determining which +-- player has won a completed game of Hex. Please see "Quipper.Algorithms.BF.Main" +-- for an overview of the boolean formula algorithm, or +-- "Quipper.Algorithms.BF.BooleanFormula" to see where these circuits are used in the +-- overall implementation of the boolean formula algorithm. +-- The functions defined in this module make heavy use of Quipper's \"build_circuit\" +-- keyword, to automatically generate quantum circuits. + +module Quipper.Algorithms.BF.Hex where + +import Quipper +import Quipper.Internal.CircLifting +import Quipper.Libraries.Qram +import Quipper.Libraries.Arith hiding (template_symb_plus_) + +import Prelude hiding (lookup) + +-- | A dummy gate, that when lifted will add a quantum trace to the circuit. +qtrace :: [Bool] -> [Bool] +qtrace bs = bs + +-- | A hand-lifted version of qtrace, adds a named \"trace\" gate to the circuit. +template_qtrace :: Circ ([Qubit] -> Circ [Qubit]) +template_qtrace = return $ \qs -> do + named_gate_at "trace" qs + return qs + +-- | A hand-lifted version of the Prelude 'show' function. +template_show :: Show a => Circ (a -> Circ String) +template_show = return $ \a -> return $ show a + +-- | A hand-lifted function to get the 'head' of a list. +template_head :: Circ ([a] -> Circ a) +template_head = return $ \q -> return (head q) + +-- | A hand-lifted function to get the 'tail' of a list. +template_tail :: Circ ([a] -> Circ [a]) +template_tail = return $ \q -> return (tail q) + +-- | A hand-lifted function to get the 'length' of a list. +template_length :: Circ ([a] -> Circ Int) +template_length = return $ \as -> return $ length as + +-- | A hand-lifted version of the 'take' function, specialized to lists of qubits. +template_take :: Circ (Int -> Circ ([Qubit] -> Circ [Qubit])) +template_take = return $ \n -> return $ \qs -> return (take n qs) + +-- | A hand-lifted version of the 'drop' function, specialized to lists of qubits. +template_drop :: Circ (Int -> Circ ([Qubit] -> Circ [Qubit])) +template_drop = return $ \n -> return $ \qs -> return (drop n qs) + +-- | A hand-lifted version of the 'replicate' function, specialized to create lists of 'BoolParam'. +template_replicate :: Circ (Int -> Circ (BoolParam -> Circ [BoolParam])) +template_replicate = return $ \n -> return $ \bp -> return (replicate n bp) + +-- | A hand-lifted version of the 'map' function. +template_map :: Circ ((a -> Circ a) -> Circ ([a] -> Circ [a])) +template_map = return $ \func -> return $ \qs -> mapM func qs + +-- | 'Int' is not changed along the conversion. +template_integer :: Int -> Circ Int +template_integer x = return x + +-- | A hand-lifted version of the '-' function, specialized to 'Int'. +template_symb_minus_ :: Circ (Int -> Circ (Int -> Circ Int)) +template_symb_minus_ = return $ \x -> return $ \y -> return (x - y) + +-- | A hand-lifted version of the '+' function, specialized to 'Int'. +template_symb_plus_ :: Circ (Int -> Circ (Int -> Circ Int)) +template_symb_plus_ = return $ \x -> return $ \y -> return (x + y) + +-- | A hand-lifted version of the '<' function, specialized to 'Int'. +template_symb_oangle_ :: Circ (Int -> Circ (Int -> Circ Bool)) +template_symb_oangle_ = return $ \x -> return $ \y -> return (x < y) + +-- | A hand-lifted version of the '<=' function, specialized to 'Int'. +template_symb_oangle_symb_equal_ :: Circ (Int -> Circ (Int -> Circ Bool)) +template_symb_oangle_symb_equal_ = return $ \x -> return $ \y -> return (x <= y) + +-- | A hand-lifted version of the 'div' function, specialized to 'Int'. +template_div :: Circ (Int -> Circ (Int -> Circ Int)) +template_div = return $ \x -> return $ \y -> return (x `div` y) + +-- | A function synonym for '&&'. +cand :: Bool -> Bool -> Bool +cand = (&&) + +-- | A hand-lifted version of the 'cand' function. +template_cand :: Circ (Bool -> Circ (Bool -> Circ Bool)) +template_cand = return $ \x -> return $ \y -> return (x && y) + +-- | A hand-lifted version of the '>' function, specialized to 'Int'. +template_symb_cangle_ :: Circ (Int -> Circ (Int -> Circ Bool)) +template_symb_cangle_ = return $ \x -> return $ \y -> return (x > y) + +-- | A hand-lifted version of the '!!' function. +template_symb_exclamation_symb_exclamation_ :: Circ ([a] -> Circ (Int -> Circ a)) +template_symb_exclamation_symb_exclamation_ = return $ \as -> return $ \i -> return (as !! i) + +-- | A hand-lifted version of the 'mod' function, specialized to 'Int'. +template_mod :: Circ (Int -> Circ (Int -> Circ Int)) +template_mod = return $ \x -> return $ \y -> return (x `mod` y) + +-- | A hand-lifted version of the 'zip' function, specialized to lists of qubits. +template_zip :: Circ ([Qubit] -> Circ ([Qubit] -> Circ [(Qubit,Qubit)])) +template_zip = return $ \as -> return $ \bs -> return $ zip as bs + +-- | A hand-lifted version of the 'unzip' function, specialized to a list of pairs of qubits. +template_unzip :: Circ ([(Qubit,Qubit)] -> Circ ([Qubit],[Qubit])) +template_unzip = return $ \abs -> return $ unzip abs + +-- | A hand-lifted version of the 'or' function, specialized to a list of qubits. +template_or :: Circ ([Qubit] -> Circ Qubit) +template_or = return $ \bs -> do + q <- qinit True + qnot q `controlled` [ b .==. 0 | b <- bs ] + +-- | The Hex board consists of boolean parameters. +type HexBoardParam = ([BoolParam],[BoolParam]) + +-- | Convert a list of boolean parameters into a list of boolean inputs. +newBools :: [BoolParam] -> [Bool] +newBools = map newBool + +-- | A hand-lifted function to convert a list of boolean parameters +-- into a list of qubits initialized as ancillas is the given states. +template_newBools :: Circ ([BoolParam] -> Circ [Qubit]) +template_newBools = return $ \bps -> do + let bs = map newBool bps + mapM qinit bs + +-- | Convert a little-endian list of booleans into an integer by +-- reversing the list and calling the big-endian conversion function +-- 'bools2int''. +bools2int :: [Bool] -> Int +bools2int bs = bools2int' (reverse bs) + +-- | Convert a big-endian list of booleans into an integer. This is +-- mainly used for displaying a \"position\" register. +bools2int' :: [Bool] -> Int +bools2int' [] = 0 +bools2int' (x:xs) = 2*(bools2int' xs) + (if x then 1 else 0) + +-- | Convert an integer into a little-endian list of booleans of length /n/ +-- by reversing the big-endian list created by the 'int2bools'' function. +int2bools :: Int -> Int -> [Bool] +int2bools n x = reverse (int2bools' n x) + +-- | Convert an integer into a big-endian list of booleans of length /n/. +-- | Note that the behavior when /x/ is greater than 2[sup /n/] - 1 is erroneous. +int2bools' :: Int -> Int -> [Bool] +int2bools' n x = take n (int2bools'' x ++ repeat False) + +-- | Convert an integer into a big-endian list of booleans of minimal length. +int2bools'' :: Int -> [Bool] +int2bools'' 0 = [False] +int2bools'' 1 = [True] +int2bools'' x = (odd x):(int2bools'' (x `div` 2)) + +-- | This function is a stub, because a hand lifted version is given +-- for creating the circuits. +lookup :: [Bool] -> [Bool] -> Bool +lookup board address = board !! (bools2int address) + +-- | Hand-lifted version of lookup that uses 'addressed_perform' to look up a qubit at the given address. +template_lookup :: Circ ([Qubit] -> Circ ([Qubit] -> Circ Qubit)) +template_lookup = return $ \board -> return $ \address -> do + addressed_perform board address $ \q -> do -- q is board[address] + anc <- qinit False + qnot_at anc `controlled` q + return anc + +-- | Update the board, by negating the boolean in board, at the given address. +update :: [Bool] -> [Bool] -> [Bool] +update board address = (take n board) ++ b:(drop (n+1) board) + where n = bools2int address + b = not (board !! n) + +-- | Hand-lifted version of update that uses 'addressed_perform' to negate a qubit at the given address. +template_update :: Circ ([Qubit] -> Circ ([Qubit] -> Circ [Qubit])) +template_update = return $ \board -> return $ \address -> do + addressed_perform board address $ \q -> do -- q is board[address] + qnot_at q + return board + +-- | An unencapsulated version of 'template_update', for testing purposes. +test_update :: [Qubit] -> [Qubit] -> Circ [Qubit] +test_update board address = do + qcqcq <- template_update + qqcq <- qcqcq board + qqcq address + +-- | Perform a given operation on a quantum-addressed element of an array of +-- quantum data. +addressed_perform :: QData qa => + [qa] -- ^ Array of quantum data. + -> [Qubit] -- ^ Index into the array. + -> (qa -> Circ b) -- ^ An operation to be performed. + -> Circ b +addressed_perform qs idx f = do + with_computed (indexed_access qs i) $ \x -> do + f x + where i = qdint_of_qulist_bh idx + +-- | Update the boolean value at the given position, to the given value. +build_circuit +update_pos :: Int -> [Bool] -> Bool -> [Bool] +update_pos n bs b = (take n bs) ++ b:(drop (n+1) bs) + +-- ====================================================================== +-- * Oracle implementation + +-- $ The functions in this implementation follow a separation of the boolean +-- formula algorithm into two parts. The first part consists of the +-- algorithms defined in "Quipper.Algorithms.BF.BooleanFormula". The second part +-- consists of the algorithms defined in this module. This separation relates +-- to the first part defining the quantum parts of the algorithm, including the +-- phase estimation, and the quantum walk, whereas the remaining four define +-- the classical implementation of the circuit for determining which player +-- has won a completed game of Hex, which is converted to a quantum circuit +-- using Quipper's \"build_circuit\" keyword. + +-- | A helper function, used by the 'flood_fill' function, that +-- checks whether a given board position is currently vacant. +build_circuit +testpos :: Int -> [Bool] -> [Bool] -> [Bool] -> Int -> [Bool] +testpos pos maskmap bitmap newmap xy_max = case (0 <= pos) `cand` (pos < xy_max) of + True -> if not (maskmap !! pos) && not (bitmap !! pos) && not (newmap !! pos) + then update_pos pos newmap True + else newmap + False -> newmap + +-- | Given a board position, this function will call +-- 'testpos' for each of its neighboring board positions. +build_circuit +test_positions :: Int -> Int -> Int -> [Bool] -> [Bool] -> [Bool] -> ([Bool],[Bool]) +test_positions ii x_max xy_max bitmap newmap maskmap = + let bitmap' = update_pos ii bitmap True in + let newmap' = testpos (ii + x_max) maskmap bitmap' newmap xy_max in + let newmap'' = testpos (ii - x_max) maskmap bitmap' newmap' xy_max in + let newmap''' = case (ii `mod` x_max > 0) of + True -> testpos (ii - 1) maskmap bitmap' newmap'' xy_max + False -> newmap'' + in + let newmap'''' = case (ii `mod` x_max > 0) of + True -> testpos (ii + x_max - 1) maskmap bitmap' newmap''' xy_max + False -> newmap''' + in + let newmap''''' = case (ii `mod` x_max < x_max - 1) of + True -> testpos (ii + 1) maskmap bitmap' newmap'''' xy_max + False -> newmap'''' + in + let newmap'''''' = case (ii `mod` x_max < x_max - 1) of + True -> testpos (ii - x_max + 1) maskmap bitmap' newmap''''' xy_max + False -> newmap''''' + in + let newmap''''''' = update_pos ii newmap'''''' False in + (newmap''''''',bitmap') + + + +-- | This function calls 'test_positions' for every board position in strictly +-- increasing order. +build_circuit +while_for :: Int -> Int -> Int -> [Bool] -> [Bool] -> [Bool] -> ([Bool],[Bool]) +while_for counter xy_max x_max bitmap newmap maskmap = case counter of + 0 -> let bitmap' = qtrace bitmap in + (bitmap',newmap) + n -> let ii = xy_max - n in + let (newmap',bitmap') = if newmap !! ii + then test_positions ii x_max xy_max bitmap newmap maskmap + else (newmap,bitmap) in + while_for (n-1) xy_max x_max bitmap' newmap' maskmap + +-- | This function is used by 'flood_fill' to perform an approximation of a while loop. +-- This starts with /newmap/ containing only the blue pieces from the top row of the +-- Hex board, and fills in all contiguous regions, i.e., areas bounded by red pieces. +-- The resulting bitmap will only have blue pieces in the bottom row of the Hex board, +-- if blue has won. The number of times the loop will repeat is bounded by the size of +-- the Hex board. +build_circuit +while :: Int -> Int -> [Bool] -> [Bool] -> [Bool] -> [Bool] +while counter x_max bitmap newmap maskmap = case counter of + 0 -> bitmap + n -> let counter' = length bitmap in + let (bitmap',newmap') = while_for counter' counter' x_max bitmap newmap maskmap in + while (n-1) x_max bitmap' newmap' maskmap + +-- | Swap the position of two boolean values within a pair. +swapBool :: (Bool,Bool) -> (Bool,Bool) +swapBool (a,b) = (b,a) + +-- | A hand-lifted version of the 'swapBool' function, which uses a 'swap' operation +-- to swap the state of two qubits within a pair. +template_swapBool :: Circ ((Qubit,Qubit) -> Circ (Qubit,Qubit)) +template_swapBool = return $ \(a,b) -> do + swap a b + return (a,b) + +-- | Implements a 'flood_fill' algorithm on a representation of a Hex +-- board. Returning the \"flooded\" version of the board. +build_circuit +flood_fill :: Int -> [Bool] -> [Bool] -> [Bool] +flood_fill x_max bitmap maskmap = + let newmap = newBools (replicate (length bitmap) PFalse) in + let (bitmap',newmap') = unzip (map (\(a,b) -> if a then swapBool (a,b) else (a,b)) (zip bitmap newmap)) in + let newmap'' = qtrace newmap' in + let counter = ((length bitmap) `div` 4) + 1 in + -- The worst case scenario in our case as we know only half the pieces + -- can be blue, and only half those can be left or above in a flood_fill path + while counter x_max bitmap' newmap'' maskmap + +-- | A sub-algorithm of the 'checkwin_red' algorithm, which is given the bottom row of +-- booleans after the 'flood_fill' algorithm has been run, and checks to see if any of +-- them are 'True'. +build_circuit +checkwin_red' :: [Bool] -> Bool +checkwin_red' bs = not (or bs) + +-- | Given a description of a valid Hex board, i.e., a board +-- that represents a finished game, with a single piece on each square, will return +-- a boolean value stating whether the red player has won. +build_circuit +checkwin_red :: Int -> [Bool] -> Bool +checkwin_red x_max redboard = + let begin_blueboard = map not (take x_max redboard) in + let n = length redboard - x_max in + let tail_blueboard = newBools (replicate n PFalse) in + let blueboard = begin_blueboard ++ tail_blueboard in + let blueboard' = flood_fill x_max blueboard redboard in + checkwin_red' (drop n blueboard') + +-- | An unencapsulated version of the 'checkwin_red' circuit. +checkwin_red_c :: Int -> [Qubit] -> Circ Qubit +checkwin_red_c i qs = do + icqscq <- template_checkwin_red + cqscq <- icqscq i + cqscq qs + +-- | A recursive sub-algorithm of 'hexT' that goes through each +-- direction in the position register and recursively updates the +-- ancilla register representing the /blueboard/ and /redboard/ +-- depending on which player's turn it is. If a position is already +-- set in one of the ancilla registers, then the current player has +-- played an invalid move, and therefore loses. If we pass through the +-- entire position register, then we have a valid description of a Hex +-- board split between the /redboard/ and /blueboard/ registers, which +-- can then be passed to 'checkwin_red' to see who has won (we +-- actually only pass the /redboard/ to 'checkwin_red' as every square +-- is now either a red piece or a blue piece, so no extra information +-- is held in the /blueboard/ register). +build_circuit +movesT :: Int -> [[Bool]] -> [Bool] -> [Bool] -> BoolParam -> Bool +movesT x_max pos redboard blueboard player = + case pos of + [] -> checkwin_red x_max redboard + (address:pos') -> + if lookup redboard address + then (newBool player) + else + ( if lookup blueboard address + then (newBool player) + else + ( case player of + PFalse -> movesT x_max pos' (update redboard address) blueboard PTrue -- Red played, so Blue is next + PTrue -> movesT x_max pos' redboard (update blueboard address) PFalse -- Blue played, so Red is next + ) + ) + +-- | The overall hex function. This initializes two ancilla registers +-- to represent the /redboard/ and the /blueboard/, and passes these +-- to the recursive 'movesT' function to determine which color has won +-- the game of Hex. +build_circuit +hexT :: HexBoardParam -> BoolParam -> Int -> [[Bool]] -> Bool +hexT (init_r,init_b) next_player x_max pos = + let redboard = newBools init_r in + let blueboard = newBools init_b in + let result = movesT x_max pos redboard blueboard next_player in + -- next_player: PFalse = Red, PTrue = Blue. + result + +-- | A function to convert a boolean to a boolean parameters +newBoolParam :: Bool -> BoolParam +newBoolParam x = if x then PTrue else PFalse + +-- | A function to convert a list of booleans to a list of boolean +-- parameters. +newBoolParams :: [Bool] -> [BoolParam] +newBoolParams = map newBoolParam + +-- | An interface to the lifted version of 'hexT' (i.e., +-- 'template_hexT'), which unbinds the inputs from the 'Circ' monad. +hex_oracle_c :: ([Bool],[Bool]) -> Int -> Int -> [[Qubit]] -> Circ Qubit +hex_oracle_c (init_r,init_b) s x_max pos = do + let params = (newBoolParams init_r,newBoolParams init_b) + let next_player = newBoolParam (even s) -- the size of the board is always 1 less + -- than an integer power of 2, therefore + -- an odd number. Red goes first, and + -- players alternate, so if the number of + -- moves remaining is odd, then the next + -- player is Red. + template_hexT_bp <- template_hexT + template_hexT_int <- template_hexT_bp params + template_hexT_int' <- template_hexT_int next_player + template_hexT_qs <- template_hexT_int' x_max + template_hexT_qs pos + +-- | An embedding of 'hex_oracle_c' into a reversible circuit, where all +-- ancillas are uncomputed automatically. +hex_oracle :: ([Bool],[Bool]) -> Int -> Int -> ([[Qubit]],Qubit) -> Circ ([[Qubit]],Qubit) +hex_oracle init s x_max pb = do + comment "HEX" + label pb ("pos","binary") + (classical_to_quantum . classical_to_reversible) (hex_oracle_c init s x_max) pb + +-- | A dummy oracle is just a gate named "HEX" applied to the input qubits. +hex_oracle_dummy :: ([[Qubit]],Qubit) -> Circ ([[Qubit]],Qubit) +hex_oracle_dummy qs = named_gate "HEX" qs + +-- | An embedding of 'checkwin_red_c' into a reversible circuit, where all +-- ancillas are uncomputed automatically. +checkwin_red_circuit :: Int -> ([Qubit],Qubit) -> Circ ([Qubit],Qubit) +checkwin_red_circuit x_max = (classical_to_quantum . classical_to_reversible) (checkwin_red_c x_max) diff --git a/Quipper/Algorithms/BF/HexBoard.hs b/Quipper/Algorithms/BF/HexBoard.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/BF/HexBoard.hs @@ -0,0 +1,163 @@ +-- | This module provides the code for drawing Hex boards in graphical +-- format. See "Quipper.Algorithms.BF.Main" for an overview of the boolean formula algorithm. + +module Quipper.Algorithms.BF.HexBoard +( + output_start_board, + output_HexBoards +) +where + +import Quipper + +import Quipper.Algorithms.BF.BooleanFormula +import Quipper.Algorithms.BF.Hex + +import Graphics.EasyRender +import Text.Printf + +-- ---------------------------------------------------------------------- +-- * Shared functions + +-- | An enumeration of the colors a cell on the Hex board can be +-- colored. +data HexColor = Empty | Red | Blue deriving (Eq,Show) + +-- | Convert a description of the pieces on a Hex board to a list of +-- the colors of the cells on the Hex board. Also check that the +-- hex boards are of the correct length. +hexboard_to_colorlist :: Int -> HexBoard -> [HexColor] +hexboard_to_colorlist xy_max (red,blue) = + if length red == xy_max && length blue == xy_max then + map color (zip red blue) + else + error "hexboard length mismatch" + where + color (_, True) = Blue + color (True, _) = Red + color (_, _) = Empty + +-- ---------------------------------------------------------------------- +-- * ASCII output + +-- | Output multiple HexBoards in ASCII, for the given oracle. +ascii_of_HexBoards :: BooleanFormulaOracle -> [HexBoard] -> String +ascii_of_HexBoards oracle boards = ascii_of_ColorBoards x_max y_max colorBoards + where + x_max = oracle_x_max oracle + y_max = oracle_y_max oracle + xy_max = x_max * y_max + colorBoards = map (hexboard_to_colorlist xy_max) boards + +-- | Output multiple lists of colors, that represent HexBoards, in ASCII, +-- for the given oracle. +ascii_of_ColorBoards :: Int -> Int -> [[HexColor]] -> String +ascii_of_ColorBoards x_max y_max cbs = concat (map (ascii_of_ColorBoard 1 x_max) cbs) + +-- | Output a single list of colors, that represents a HexBoard, in ASCII, +-- for the given oracle /x/ dimension. +ascii_of_ColorBoard :: Int -> Int -> [HexColor] -> String +ascii_of_ColorBoard _ _ [] = "\n" +ascii_of_ColorBoard spaces n cs = + show (map color_to_bash (take n cs)) ++ '\n':(replicate spaces ' ') + ++ ascii_of_ColorBoard (spaces+1) n (drop n cs) + +-- | An alternate enumeration of the colors a cell on the Hex board +-- can be colored, so we can use bash escape color codes in the ASCII +-- output. +data BashColor = BashEmpty | BashRed | BashBlue deriving Eq + +-- | A function to convert HexColor to BashColor +color_to_bash :: HexColor -> BashColor +color_to_bash Empty = BashEmpty +color_to_bash Red = BashRed +color_to_bash Blue = BashBlue + +-- | An instance of Show for BashColor, so the string for each color contains +-- the bash escape code for that color, and a single character. +instance Show BashColor where + show BashEmpty = " " + show BashRed = "\^[\ESC[1;31m\^]#\^[\ESC[0m\^]" + show BashBlue = "\^[\ESC[1;34m\^]*\^[\ESC[0m\^]" + +-- ---------------------------------------------------------------------- +-- * Graphical output + +-- | Given an oracle, and a list of Hex board descriptions of the +-- given size, output a graphical representation of the Hex boards, +-- one per page. +document_of_HexBoards :: BooleanFormulaOracle -> [HexBoard] -> Document () +document_of_HexBoards oracle boards = do + sequence_ [ drawPage w h b | b <- boards ] + where + w = oracle_x_max oracle + h = oracle_y_max oracle + +-- | Draw a Hex board of dimensions /w/ × /h/ on a page by itself. +-- The drawing takes place in the following user coordinate system: +-- +-- \[image hex-coord.png] +drawPage :: Int -> Int -> HexBoard -> Document () +drawPage w h board = do + newpage (width*sc) (height*sc) $ do + scale sc sc + translate 0.5 (height-1) + setlinewidth 0.05 + sequence_ [drawCell (i `mod` w) (i `div` w) color | (color, i) <- zip cboard [0..] ] + where + width = fromIntegral (2*w + h - 1) * sqrt 0.75 + 1 + height = 0.5 + 1.5 * fromIntegral h + 1 + cboard = hexboard_to_colorlist (w*h) board + sc = 18 -- each cell is 1/2 inch wide + +-- | Draw a single hex cell of the given color, at position /x/ \"over\" and /y/ \"across\". +drawCell :: Int -> Int -> HexColor -> Draw () +drawCell x y color = draw_subroutine alt $ do + block $ do + translate (s*x0) y0 + moveto 0 0 + lineto s (0.5) + lineto (2*s) 0 + lineto (2*s) (-1) + lineto s (-1.5) + lineto 0 (-1) + closepath + fillstroke (Color_RGB r g b) + where + x0 = fromIntegral (2*x+y) + y0 = (-1.5) * fromIntegral y + s = sqrt 0.75 + (r,g,b) = drawcolor color + drawcolor Red = (1, 0, 0) + drawcolor Blue = (0, 0, 1) + drawcolor Empty = (1, 1, 1) + alt = [custom_ps $ printf "%.0f %.0f %.0f %f %f hexagon\n" r g b x0 y0] + +-- | A version of 'print_of_document' that is enhanced with PostScript +-- definitions local to this module. +my_print_of_document :: Format -> Document a -> IO a +my_print_of_document = print_of_document_custom cust where + cust = custom { + ps_defs = "/hexagon { gsave exch s mul exch translate 0 0 moveto s .5 rlineto s -.5 rlineto 0 -1 rlineto s neg -.5 rlineto s neg .5 rlineto closepath gsave setrgbcolor fill grestore stroke grestore } bind def\n" ++ + "/s 0.75 sqrt def\n" + } + +-- ---------------------------------------------------------------------- +-- * Functions taking a Format parameter + +-- | Output the starting 'HexBoard' in the given format, for the given oracle. +output_start_board :: Format -> BooleanFormulaOracle -> IO () +output_start_board f o = output_HexBoards f o [board] + where board = start_board o + +-- | Output multiple 'HexBoard's in the given format, for the given oracle. +output_HexBoards :: Format -> BooleanFormulaOracle -> [HexBoard] -> IO () +output_HexBoards PS bfo hbs = my_print_of_document PS (document_of_HexBoards bfo hbs) +output_HexBoards PDF bfo hbs = my_print_of_document PDF (document_of_HexBoards bfo hbs) +output_HexBoards ASCII bfo hbs = Prelude.putStr (ascii_of_HexBoards bfo hbs) +output_HexBoards Preview bfo hbs = my_print_of_document Preview (document_of_HexBoards bfo hbs) +output_HexBoards GateCount _ _ = error "GateCount is not a valid format for displaying a Hex Board" +output_HexBoards EPS bfo hbs = output_HexBoards PS bfo hbs +output_HexBoards (CustomStyle _ ) _ _ = error "CustomStyle not currently supported" + +-- ---------------------------------------------------------------------- diff --git a/Quipper/Algorithms/BF/Main.hs b/Quipper/Algorithms/BF/Main.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/BF/Main.hs @@ -0,0 +1,371 @@ +-- | +-- Author: Alexander S. Green +-- +-- An implementation of the Boolean Formula algorithm, applied to +-- finding whether a winning strategy exists in a game of Hex. +-- +-- \[image hex1.png] +-- \[image hex2.png] +-- +-- The algorithm consists of eigenvalue analysis using phase estimation, +-- acting on an oracle that defines a quantum walk over the NAND graph +-- representation of a game of Hex, for a given size of board. +-- +-- The implementation defines the NAND graph of a game of Hex by adding a few +-- extra nodes to a graph representing pieces being played during a game of Hex. +-- An extra node is added to each leaf node that represents a completed game of +-- Hex, for which the red player has won, as well as two extra nodes being +-- added below the root node. +-- +-- The general form of the algorithm is described in: +-- +-- * A. Ambainis, A. M. Childs, B. W. Reichardt, R. Spalek, and +-- S. Zhang. \"Any AND-OR formula of size /N/ can be evaluated in +-- time /N/[sup 1\/2+/o/(1)] on a quantum computer.\" /SIAM J. Comput./, +-- 39:2513–2530, April 2010. See also +-- . +-- +-- * A. M. Childs, B. W. Reichardt, R. Spalek, and S. Zhang. +-- \"Every NAND formula of size /N/ can be evaluated in time +-- /N/[sup 1\/2+/o/(1)] on a quantum computer\" 2007. +-- . +-- +-- The present implementation is based on detailed algorithm and +-- oracle specifications that were provided to us by the IARPA QCS +-- program and written by Patrick Henry. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.BF.Main": Command line interface. +-- +-- * "Quipper.Algorithms.BF.BooleanFormula": Implementation of the various quantum +-- circuits that make up the boolean formula algorithm. +-- +-- * "Quipper.Algorithms.BF.Hex": Implementation of the circuits for determining which +-- player has won a completed game of Hex. +-- +-- * "Quipper.Algorithms.BF.HexBoard": Code for drawing Hex boards in graphical format. +-- +-- * "Quipper.Algorithms.BF.Testing": Testing facilities for the boolean +-- formula algorithm, and some auxiliary function definitions. + +module Quipper.Algorithms.BF.Main where + +import Quipper + +import Quipper.Libraries.Decompose + +import qualified Quipper.Algorithms.BF.BooleanFormula as BooleanFormula +import qualified Quipper.Algorithms.BF.Hex as Hex +import qualified Quipper.Algorithms.BF.Testing as Testing +import qualified Quipper.Algorithms.BF.HexBoard as HexBoard + +import Quipper.Utils.CommandLine +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Control.Monad +import Data.List +import Data.Char + +-- ---------------------------------------------------------------------- +-- * Command line interface + +-- $ This module provides a command line interface for the Boolean +-- Formula algorithm. This allows the user, for example, to plug in +-- different oracles, show different parts of the circuit, run a demo, +-- and select different output formats. + +-- ---------------------------------------------------------------------- +-- * Option processing + +-- | An enumeration type for determining the action that should be taken when +-- the executable is run. +data WhatToDo = + OutputCircuit -- ^ Output the circuit. + | Demo -- ^ Run a demo of the circuit, which is different for the + -- various parts of the algorithm. + | HexBoard -- ^ Output a representation of the moves already made for the + -- defined oracle, i.e. a partially filled Hex Board. + deriving Show + +-- | An enumeration type for determining what the main function should do. +data WhatPart = + WholeCircuit -- ^ The whole circuit. + | U -- ^ Only one iteration of the U from EXP_U circuit. + | Oracle -- ^ Only the Oracle circuit. + | Hex -- ^ Only the Hex circuit. + | Checkwin_Red -- ^ Only the Checkwin_Red circuit, i.e. including Flood_Fill. + | Diffuse -- ^ Only the Diffuse circuit. + | Walk -- ^ Only the Walk circuit. + | Undo_Oracle -- ^ Only the Undo_Oracle circuit. + deriving Show + +-- | An enumeration type for selecting an oracle size. +data OracleSize = + Full -- ^ The oracle for a 9 by 7 Hex board, + -- with a 189 qubit phase estimation register. + | Small -- ^ The oracle for a 5 by 3 Hex board, + -- with a 4 qubit phase estimation register + | Custom Int Int Int -- ^ A custom oracle. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + what :: WhatToDo, -- ^ What we want to do. + part :: WhatPart, -- ^ What part of the algorithm to use. + format :: Format, -- ^ The output format of a circuit. + oracle_size :: OracleSize, -- ^ Which size of oracle to use. + oracle_init :: [Int], -- ^ A list of moves already made, + -- which is used to define /s/ + hex :: BooleanFormula.HexCircuit, -- ^ A flag of which HEX circuit to use. + gatebase :: GateBase -- ^ What kind of gates to decompose into. +} + +-- | The default options, which correspond to a Preview of the entire circuit +-- for the small oracle. +defaultOptions :: Options +defaultOptions = Options + { what = OutputCircuit, + part = WholeCircuit, + format = Preview, + oracle_size = Small, + oracle_init = [], + hex = BooleanFormula.Hex, + gatebase = Logical + } + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = + [ Option ['C'] ["circuit"] (NoArg (what OutputCircuit)) "output the whole circuit (default)", + Option ['D'] ["demo"] (NoArg (what Demo)) "run a demo of the circuit", + Option ['H'] ["hexboard"] (NoArg (what HexBoard)) "output a representation of the initial state of the given oracle, i.e. the game played so far", + Option ['p'] ["part"] (ReqArg part "") "which part of the circuit to use (default: whole)", + Option ['o'] ["oracle"] (ReqArg oracle "") "which oracle to use (default: small)", + Option ['m'] ["moves"] (ReqArg oracle_init "") "which moves have already been made (default: [])", + Option ['f'] ["format"] (ReqArg format "") "output format for circuits (default: preview)", + Option ['d'] ["dummy"] (NoArg setDummy) "set to only use a dummy HEX gate instead of the full hex circuit", + Option ['h'] ["help"] (NoArg help) "print usage info and exit", + Option ['g'] ["gatebase"] (ReqArg gatebase "") "type of gates to decompose the output circuit into (default: logical)" + ] + where + help :: Options -> IO Options + help o = do + usage + exitSuccess + + what :: WhatToDo -> Options -> IO Options + what w o = return o { what = w } + + part :: String -> Options -> IO Options + part str opt = do + case match_enum part_enum str of + [(_, p)] -> return opt { part = p } + [] -> optfail ("Unknown part -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous part -- " ++ str ++ "\n") + + oracle :: String -> Options -> IO Options + oracle str opt = do + case match_enum oracle_enum str of + [(_, Just o)] -> return opt {oracle_size = o} + [] -> case getCustom str of + Just o -> return opt {oracle_size = o} + Nothing -> optfail ("Unknown oracle -- " ++ str ++ "\n") + _ -> case getCustom str of + Just o -> return opt {oracle_size = o} + Nothing -> optfail ("Ambiguous oracle -- " ++ str ++ "\n") + + oracle_init :: String -> Options -> IO Options + oracle_init str opt = case parse_list_int str of + Nothing -> error "moves should be given as a Haskell list of integers, e.g. [1,2,3,4,5]" + Just pos -> return opt {oracle_init = pos} + + format :: String -> Options -> IO Options + format str opt = do + case match_enum format_enum str of + [(_, f)] -> return opt { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + setDummy :: Options -> IO Options + setDummy o = return o {hex = BooleanFormula.Dummy} + + gatebase :: String -> Options -> IO Options + gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + +-- | An enumeration of available circuit parts and their names. +part_enum :: [(String, WhatPart)] +part_enum = [ + ("whole",WholeCircuit), + ("u",U), + ("oracle",Oracle), + ("hex",Hex), + ("checkwin_red",Checkwin_Red), + ("diffuse",Diffuse), + ("walk",Walk), + ("undo_oracle",Undo_Oracle) + ] + +-- | An enumeration of available oracles and their names. +oracle_enum :: [(String, Maybe OracleSize)] +oracle_enum = [ + ("9by7", Just Full), + ("small", Just Small), + ("custom x y t", Nothing) -- this is a dummy, to show in a help message + ] + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to 'stdout'. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "part" part_enum) + putStr (show_enum "oracle" oracle_enum) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + where header = "Usage: bf [OPTION...]" + +-- ---------------------------------------------------------------------- +-- * The BF main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO () +main = do + argv <- getArgs + options <- dopts argv + case check_options options of + Options { what = what, part = part, format = format, oracle_size = oracle_size, oracle_init = oracle_init, hex = hex, gatebase = gatebase } -> do + let bfo = getOracle oracle_size oracle_init + let bfo' = BooleanFormula.update_hex bfo hex + let bfo'' = BooleanFormula.update_start_board bfo' (Testing.moves_to_hex bfo' oracle_init) + case what of + OutputCircuit -> output_part part format gatebase bfo'' + Demo -> demo_part part format bfo'' + HexBoard -> do + let boards = map (Testing.moves_to_hex bfo') (inits oracle_init) + HexBoard.output_HexBoards format bfo' boards + +-- | Check that the given options are valid. This currently is only required to +-- check that the list of moves already made, is valid for the given size of oracle. +check_options :: Options -> Options +check_options opts = case length moves > xy of + True -> error "Too many moves have been given" + False -> case (filter (\pos -> pos >= xy || pos < 0) moves) of + [] -> case moves == nub moves of + True -> opts + False -> error "Duplicate moves made" + _ -> error "Move out of bounds" + where + moves = oracle_init opts + xy = x * y + (x,y) = case oracle_size opts of + Full -> (9,7) + Small -> (5,3) + (Custom x y t) -> (x,y) + +-- | Convert an OracleSize, and a list of played positions, into an actual oracle. +getOracle :: OracleSize -> [Int] -> BooleanFormula.BooleanFormulaOracle +getOracle Full _ = BooleanFormula.full_oracle +getOracle Small _ = BooleanFormula.test_oracle +getOracle (Custom x y t) _ = BooleanFormula.createOracle x y t + +-- | This function defines what should be output for each part of the circuit. +output_part :: WhatPart -> Format -> GateBase -> BooleanFormula.BooleanFormulaOracle -> IO () +output_part WholeCircuit f g o = BooleanFormula.main_circuit f g o +output_part U f g o = BooleanFormula.main_u f g o +output_part Oracle f g o = BooleanFormula.main_oracle f g o +output_part Hex f g o = BooleanFormula.main_hex f g o +output_part Checkwin_Red f g o = BooleanFormula.main_checkwin_red f g o +output_part Diffuse f g o = BooleanFormula.main_diffuse f g o +output_part Walk f g o = BooleanFormula.main_walk f g o +output_part Undo_Oracle f g o = BooleanFormula.main_undo_oracle f g o + +-- | This function defines what should be done for a demo of each part of the circuit. +demo_part :: WhatPart -> Format -> BooleanFormula.BooleanFormulaOracle -> IO () +demo_part WholeCircuit ASCII o = Testing.repeat_odwu_infinite (BooleanFormula.update_hex o BooleanFormula.EmptyHex) (BooleanFormula.createRegister o) +demo_part WholeCircuit f o = do + let n = (BooleanFormula.oracle_s o) * 2 + boards <- Testing.repeat_odwu_n n (BooleanFormula.update_hex o BooleanFormula.EmptyHex) (BooleanFormula.createRegister o) + HexBoard.output_HexBoards f o boards +demo_part Hex f o = do + let o_s = BooleanFormula.oracle_s o + case o_s of + 0 -> do + result <- Testing.run_hex_with_input o (BooleanFormula.createRegister o) + putStrLn ((if result then "Red" else "Blue") ++ " wins.") + _ -> error "Hex demo requires a moves input that leaves no moves remaining" +demo_part Checkwin_Red f o = do + let o_s = BooleanFormula.oracle_s o + case o_s of + 0 -> do + let (red_board,_) = BooleanFormula.start_board o + blue_boards <- Testing.checkwin_trace o + let boards = map (\x -> (red_board,x)) blue_boards + HexBoard.output_HexBoards f o boards + _ -> error "checkwin_red demo requires a moves input that leaves no moves remaining" +demo_part U f o = demo_part WholeCircuit f o +demo_part Oracle f o = demo_part WholeCircuit f o +demo_part Diffuse f o = demo_part WholeCircuit f o +demo_part Walk f o = demo_part WholeCircuit f o +demo_part Undo_Oracle f o = demo_part WholeCircuit f o + +----- Custom Sized Oracles ------- + +-- | An infinite list of all numbers that are one less than an integer power of 2. +valid_sizes :: [Int] +valid_sizes = map (\x -> (2^x) - 1) [1..] + +-- | Return True if the given number is one less than an integer power of 2. +valid_size :: Int -> Bool +valid_size s = valid_size' s valid_sizes + where + valid_size' s [] = error "Unreachable Error Occurred: valid_sizes is an infinite list" + valid_size' s (n:ns) = case compare s n of + LT -> False + EQ -> True + GT -> valid_size' s ns + +-- | Create a custom sized oracle, by checking the given /x/,/y/, and /t/ sizes are valid. +createCustom :: Int -> Int -> Int -> OracleSize +createCustom x y t = case (x >= y) of + False -> error "The x dimension must be at least as big as the y dimension" + True -> case valid_size (x*y) of + False -> error "The number of squares on the Hex Board (x*y), must be one less than an integer power of 2" + True -> case (t > 0) of + False -> error "The size of the phase estimation register must be greater than 0" + True -> Custom x y t + +-- | Parse a string defining a custom oracle size. +getCustom :: String -> Maybe OracleSize +getCustom s = + case tokens of + [] -> Nothing + (s:strs) -> case (isPrefixOf s "custom") of + False -> Nothing + True -> case strs of + [x_str,y_str,t_str] -> Just (createCustom x y t) + where + x = case (parse_int x_str) of + Just x -> x + Nothing -> error "error parsing x argument" + y = case (parse_int y_str) of + Just y -> y + Nothing -> error "error parsing y argument" + t = case (parse_int t_str) of + Just t -> t + Nothing -> error "error parsing y argument" + _ -> error "custom size requires x, y, and t arguments" + where tokens = words s diff --git a/Quipper/Algorithms/BF/Testing.hs b/Quipper/Algorithms/BF/Testing.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/BF/Testing.hs @@ -0,0 +1,194 @@ +-- | This module provides some testing facilities for the Boolean +-- Formula algorithm, as well as some auxiliary function definitions. +-- See "Quipper.Algorithms.BF.Main" for an overview of the boolean formula algorithm. +module Quipper.Algorithms.BF.Testing where + +import Quipper.Algorithms.BF.BooleanFormula +import Quipper.Algorithms.BF.Hex +import Quipper.Algorithms.BF.HexBoard +import Quipper +import Quipper.Libraries.Simulation +import Quipper.Libraries.Unboxing + +-- * Auxiliary definitions + +-- | Convert list of moves, into a 'HexBoard'. +moves_to_hex :: BooleanFormulaOracle -> [Int] -> HexBoard +moves_to_hex o moves = fromPos o pos + where pos = moves_to_pos o moves + +-- | Convert a list of moves, into a list of positions. +moves_to_pos :: BooleanFormulaOracle -> [Int] -> [[Bool]] +moves_to_pos o moves = map (int2bools (oracle_m o)) moves + +-- | Set the position in board, at the given address, to the given boolean. +set_bool :: [Bool] -> [Bool] -> Bool -> [Bool] +set_bool board address value = (take n board) ++ value:(drop (n+1) board) + where n = bools2int address + +-- | Create the description of a Hex board, from the given classical state +-- of a position register from the Boolean Formula algorithm. +fromPos :: BooleanFormulaOracle -> [[Bool]] -> HexBoard +fromPos o pos = fromPos' pos (start_board o) (odd (oracle_s o)) + where + fromPos' :: [[Bool]] -> HexBoard -> Bool -> HexBoard + fromPos' [] rb _ = rb + fromPos' (p:ps) (red,blue) is_red = fromPos' ps (if is_red then (set_bool red p True,set_bool blue p False) else (set_bool red p False,set_bool blue p True)) (not is_red) + +-- * Testing various circuits + +-- | A dummy value of type 'Double', to feed the type in the simulator. +double :: Double +double = undefined + +-- | Construct the oracle circuit, initialized with the given boolean inputs. +oracle_with_input :: BooleanFormulaOracle -> BoolRegister -> Circ BooleanFormulaRegister +oracle_with_input o input = do + reg <- qinit input + oracle o reg + return reg + +-- | Simulate the oracle circuit with the given boolean inputs, to +-- give boolean outputs. +run_oracle_with_input :: BooleanFormulaOracle -> BoolRegister -> IO BoolRegister +run_oracle_with_input oracle input = do + run_generic_io double (unbox (oracle_with_input oracle input)) + +-- | Return the diffuse circuit, initialized with the given boolean +-- inputs. +diffuse_with_input :: BoolRegister -> Circ BooleanFormulaRegister +diffuse_with_input input = do + reg <- qinit input + diffuse reg + return reg + +-- | Simulate the diffuse circuit with the given boolean inputs, +-- to give boolean outputs. +run_diffuse_with_input :: BoolRegister -> IO BoolRegister +run_diffuse_with_input input = do + run_generic_io double (diffuse_with_input input) + +-- | Return the walk circuit, initialized with the given boolean inputs. +walk_with_input :: BoolRegister -> Circ BooleanFormulaRegister +walk_with_input input = do + reg <- qinit input + walk reg + return reg + +-- | Simulate the walk circuit with the given boolean inputs, to give +-- boolean outputs. +run_walk_with_input :: BoolRegister -> IO BoolRegister +run_walk_with_input input = do + run_generic_io double (walk_with_input input) + +-- | Return the 'undo_oracle' circuit, initialized with the given +-- boolean inputs. +undo_oracle_with_input :: BooleanFormulaOracle -> BoolRegister -> Circ BooleanFormulaRegister +undo_oracle_with_input o input = do + reg <- qinit input + undo_oracle o reg + return reg + +-- | Simulate the 'undo_oracle' circuit with the given boolean inputs, +-- to give boolean outputs. +run_undo_oracle_with_input :: BooleanFormulaOracle -> BoolRegister -> IO BoolRegister +run_undo_oracle_with_input oracle input = do + run_generic_io double (unbox (undo_oracle_with_input oracle input)) + +-- * Oracle, diffuse, walk, and undo_oracle + +-- | Create a register from the given boolean inputs, +-- and then run the oracle circuit, followed by the diffusion step, +-- followed by the walk step, and finally the 'undo_oracle' circuit. +-- +-- This is really a test of all four parts. The return values when +-- running this step can be fed forward into the next iteration, and +-- the 'undo_oracle' step should have returned the eight work qubits +-- back to the initial 'False' states. +-- +-- We break the simulation into the four separate steps, so that we are +-- not trying to simulate the walk/undo_oracle steps over a quantum state, as +-- this gives us an overhead. +run_odwu_with_input :: BooleanFormulaOracle -> BoolRegister -> IO BoolRegister +run_odwu_with_input o input = do + oracle_output <- run_oracle_with_input o input + diffuse_output <- run_diffuse_with_input oracle_output + walk_output <- run_walk_with_input diffuse_output + run_undo_oracle_with_input o walk_output + +-- | Simulate the /odwu/ circuit, running it /n/ times and passing the +-- output of each iteration as inputs to the next iteration. +-- The overall return value is a representation of the HexBoard at each step of +-- the simulation. +repeat_odwu_n :: Int -> BooleanFormulaOracle -> BoolRegister -> IO [HexBoard] +repeat_odwu_n n oracle input = repeat_odwu_n' n oracle input [] + where + repeat_odwu_n' 0 _ _ accum = return (reverse accum) + repeat_odwu_n' n oracle input accum = do + output <- run_odwu_with_input oracle input + let flags = position_flags output + let pos = position output + let hexboard = start_board (update_start_board oracle (fromPos oracle (tidy flags pos))) + repeat_odwu_n' (n-1) oracle output (hexboard:accum) + +-- | Simulate the /odwu/ circuit, running it repeatedly and passing +-- the output of each iteration as inputs to the next iteration. +-- Outputs an ASCII representation of the position register/board after each step. +repeat_odwu_infinite :: BooleanFormulaOracle -> BoolRegister -> IO () +repeat_odwu_infinite oracle input = do + output <- run_odwu_with_input oracle input + let flags = position_flags output + let pos = position output + putStrLn "Position Register: " + putStr (show ((\(l,p) -> [if l then 'L' else ' ',if p then 'P' else ' ']) flags)) + putStr " : " + putStrLn (show (map bools2int pos)) + output_start_board ASCII (update_start_board oracle (fromPos oracle (tidy flags pos))) + repeat_odwu_infinite oracle output + +-- | Trim any leading zeroes from a pos register, +-- and a single leading 1, if we're not at a paraleaf, +-- and a 3, if we're at the root. +tidy :: (Bool,Bool) -> [[Bool]] -> [[Bool]] +tidy flags pos = if pos == (zeroes ++ [three]) then [] else tidy' flags pos + where + zeroes = replicate (length pos - 1) (replicate (length (head pos)) False) + three = (replicate (length (head pos) - 2) False) ++ [True,True] + tidy' _ [] = [] + tidy' (l,p) (a:as) = case (a == replicate (length a) False) of + True -> tidy' (l,p) as + False -> case (a == (replicate (length a - 1) False) ++ [True]) of + False -> a:as + True -> if p then (a:as) else as + +-- | Return the 'Hex' circuit, initialized for the given oracle, with the given +-- boolean inputs. +hex_with_input :: BooleanFormulaOracle -> BoolRegister -> Circ Qubit +hex_with_input oracle input = do + let init = start_board oracle + let s = oracle_s oracle + let x_max = oracle_x_max oracle + reg <- qinit input + let pos = position reg + let binary = work_binary reg + (_,binary') <- hex_oracle init s x_max (pos,binary) + return binary' + +-- | Simulate the running of the 'Hex' circuit, initialized for the given oracle, +-- with the given boolean inputs. +run_hex_with_input :: BooleanFormulaOracle -> BoolRegister -> IO Bool +run_hex_with_input oracle input = run_generic_io double (hex_with_input oracle input) + +-- | Simulate the running of the 'checkwin_red' subroutine for the +-- given oracle, and keep track of the state of certain \"traced\" qubits within that +-- subroutine, which represent the Hex board at each iteration of the while loop in +-- the 'flood_fill' algorithm. +checkwin_trace :: BooleanFormulaOracle -> IO [[Bool]] +checkwin_trace o = do + let circuit = hex_with_input o (createRegister o) + trace <- run_generic_trace_io double circuit + -- trace :: [QuantumTrace] = [Vector Double [Bool]] = [Vector [([Bool],Double)]] + let boards = map (\(Vector [(bs,_)]) -> bs) trace + return boards + + diff --git a/Quipper/Algorithms/BWT/Alternative.hs b/Quipper/Algorithms/BWT/Alternative.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/BWT/Alternative.hs @@ -0,0 +1,755 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Alternative implementations for the binary welded tree algorithm. +-- The purpose of these is to experiment with and potentially +-- illustrate a more functional programming style. + +module Quipper.Algorithms.BWT.Alternative where + +import Quipper + +import Quipper.Libraries.Qureg +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.BWT.Definitions + +-- import other Quipper stuff +import qualified Quipper.Algorithms.BWT.BWT as BWT + +import Quipper.Utils.Sampling +import Quipper.Utils.Auxiliary + +-- import other stuff +import Control.Monad +import Text.Printf +import Data.Bits (xor) +import Text.Printf + +import Data.Map (Map) +import qualified Data.Map as Map + + +-- ====================================================================== +-- * Oracle abstraction + +-- | This is a version of 'BWT.Oracle' that uses 'Qulist' instead of +-- 'Qureg'. An oracle provides the following information: the tree +-- depth /n/, the label length /m/, the number of edge colors /k/, +-- the entrance label /ENTRANCE/, and for each color 0 ≤ /c/ < /k/, +-- a reversible circuit /ORACLE[sub c](a,b,r)/. + +data Oracle = Oracle { + n :: Int, + m :: Int, + k :: Int, + entrance :: Boollist, + oraclefun :: Int -> (Qulist, Qulist, Qubit) -> Circ () +} + +-- | Convert a "Alternative".'Oracle' into a "BWT".'BWT.Oracle'. +convert_oracle :: Oracle -> BWT.Oracle +convert_oracle Oracle { n=n, m=m, k=k, entrance=e, oraclefun=f1 } = + BWT.Oracle { BWT.n=n, BWT.m=m, BWT.k=k, BWT.entrance=e, BWT.oraclefun=f2 } + where + f2 c (a, b, r) = f1 c (qulist_of_qureg_te a, qulist_of_qureg_te b, r) + +-- ====================================================================== +-- * Top-level algorithm + +-- | Do a quantum random walk on the binary welded tree given by the +-- oracle, for /s/ times steps of length /dt/. Return a bit list +-- corresponding to the probable exit label. This is a more +-- functional implementation of 'BWT.qrwbwt' from the module "BWT". +-- +-- Note: This implementation does not rely on the oracle being +-- self-inverse, and therefore only requires that +-- +-- > ORACLE[sub c](a, 0, 0) = (a, v[sub c](a), f[sub c](a)), +-- +-- rather than the more general property +-- +-- > ORACLE[sub c](a, b, r) = (a, b ⊕ v[sub c](a), r ⊕ f[sub c](a)). +-- +-- This gives us the freedom to build more efficient oracles, where +-- appropriate. +qrwbwt :: Oracle -> Timestep -> Int -> Circ Bitlist +qrwbwt oracle dt s = do + comment (printf "ENTER: qrwbwt (dt=%.3e, s=%d)" dt s) + -- Initialize a to the entrance label. + a <- qinit (entrance oracle) + + -- Run the Hamiltonian /s/ times for time step /dt/. + replicateM s $ hamiltonian dt oracle a + + -- Measure /a/. + exit <- measure a + comment_with_label "EXIT: qrwbwt" exit "exit" + return exit + +-- | Apply one round of the Hamiltonian for time step /dt/ to /a/. +hamiltonian :: Timestep -> Oracle -> Qulist -> Circ () +hamiltonian dt oracle a = do + comment_with_label "ENTER: hamiltonian" a "a" + for 0 ((k oracle)-1) 1 $ \c -> do + -- for c from 0 to k-1 + + -- create ancillas b and r + with_ancilla_list (length a) $ \b -> do + with_ancilla $ \r -> do + + -- perform computations + (oraclefun oracle) c (a,b,r) + time_step dt (a,b,r) + reverse_generic_imp ((oraclefun oracle) c) (a,b,r) + -- "reverse" here is not quite GFI + comment_with_label "EXIT: hamiltonian" a "a" + +-- | Apply the diffusion step to /(a,b,r)/. Here /a/ and /b/ must be +-- of equal length. +time_step :: Timestep -> (Qulist, Qulist, Qubit) -> Circ () +time_step dt (a,b,r) = do + comment_with_label "ENTER: time_step" (a,b,r) ("a","b","r") + with_ancilla $ \h -> do + basischange (a,b,h) + controlledExpGate (dt,r,h) + (reverse_generic_imp basischange) (a,b,h) + comment_with_label "EXIT: time_step" (a,b,r) ("a","b","r") + +-- | Apply the basis change from Figure 3 of \[Childs et al.\] to /a/, +-- /b/, and /h/. Here /a/ and /b/ must be of equal length. +basischange :: (Qulist, Qulist, Qubit) -> Circ () +basischange (a,b,h) = do + comment_with_label "ENTER: basischange" (a,b,h) ("a","b","h") + -- apply W gates + zipWithM_ gate_W a b + -- apply doubly-controlled not-gates + zipWithM_ (dc_not h) a b + comment_with_label "EXIT: basischange" (a,b,h) ("a","b","h") + where + dc_not h x y = qnot_at h `controlled` (x .==. 1 .&&. y .==. 0) + +-- | Compute the required number of iterations as a function of ε and +-- /dt/. +-- +-- Inputs: /n/ is the tree depth, ε is the desired precision, /dt/ is +-- the simulation time step. Intermediate values: /t/ is the +-- simulation time. Output: /s/, the upper bound on the number of +-- simulation time steps. +-- +-- Note: \[Childs et al\] specifies that /t/ should be chosen +-- uniformly at random within the interval 0 < /t/ ≤ /n/[sup 4]\/2ε. +-- Here, for simplicity, we just use /t/ = ⌊/n/[sup 4]\/2ε⌋. Also note +-- that this function is for information only, as it is not actually +-- used. Users should specify /s/ directly. +compute_steps :: Int -> Double -> Double -> Int +compute_steps n epsilon dt = + floor (t / dt) + where + t = fromIntegral (n * n * n * n) / (2.0 * epsilon) + +-- ====================================================================== +-- * Oracle implementations + +-- ** Blackbox oracle + +-- | A blackbox oracle for testing. This just produces a labelled box +-- in place of the actual oracle circuit. The argument is the tree +-- height. +oracle_blackbox :: Int -> Oracle +oracle_blackbox n = + let m = n+2 in + Oracle { + n = n, + m = m, + k = 4, + entrance = boollist_of_int_bh (n+2) 1, + oraclefun = \c (a, b, r) -> + do + named_gate_at ("O(" ++ show c ++ ")") (a ++ b ++ [r]) + return () + } + +-- ---------------------------------------------------------------------- +-- ** A simple \"exponential\" oracle. + +-- | This oracle, which works only for the fixed tree height 3, works +-- by explicitly listing all the edges. It serves only to illustrate +-- how the edge information is encoded. Listing all edges explicitly +-- obviously would not scale well to larger graphs. +oracle_simple :: Oracle +oracle_simple = + let n = 3 + m = 5 + k = 4 + + invalid = 0 -- also works correctly for invalid = 31 + invalid_vec = boollist_of_int_bh m invalid + + green = 0 + blue = 1 + red = 2 + black = 3 + + edges :: Int -> [(Int, Int)] + edges 0 = [(1,3), (2,5), (4,8), (6,12), (7,15), (9,17), (10,18), + (13,21), (19,25), (22,27), (24,28), (26,29)] + edges 1 = [(2,4), (3,6), (5,10), (7,14), (8,16), (11,19), (12,20), + (17,24), (21,26), (23,27), (25,28), (29,30)] + edges 2 = [(1,2), (3,7), (4,9), (5,11), (6,13), (14,22), (15,23), + (16,24), (18,25), (20,26), (27,29), (28,30)] + edges 3 = [(8,17), (9,18), (10,19), (11,20), (12,21), (13,22), + (14,23), (15,16)] + edges n = error ("oracle_simple: illegal color: " ++ show n) + + -- apply an (a,n1)-controlled not operation to (v,n2) + multi_controlled_multi_not :: Int -> (Qulist, Qulist) -> (Int, Int) -> Circ () + multi_controlled_multi_not m (a,v) (n1, n2) = do + let vec1 = boollist_of_int_bh m n1 + let vec2 = boollist_of_int_bh m n2 + bool_controlled_not v vec2 `controlled` a .==. vec1 + return () + + -- the O_c circuit + oracle_O :: Int -> (Qulist, Qulist) -> Circ () + oracle_O c (a,v) = do + let e = edges c + foreach e $ \(n1, n2) -> do + multi_controlled_multi_not m (a,v) (n1, invalid `xor` n2) + multi_controlled_multi_not m (a,v) (n2, invalid `xor` n1) + + -- the B_c circuit + oracle_B :: (Qulist, Qulist) -> Circ () + oracle_B (v,b) = + for 0 (m-1) 1 $ \i -> do + qnot_at (b !! i) `controlled` (v !! i) .==. 1 + + -- the R_c circuit + oracle_R :: (Qulist, Qubit) -> Circ () + oracle_R (v,r) = do + qnot_at r `controlled` v .==. invalid_vec + + -- the oracle circuit + oraclefun :: Int -> (Qulist, Qulist, Qubit) -> Circ () + oraclefun c (a,b,r) = do + comment_with_label "ENTER: oracle_simple" (a,b,r) ("a","b","r") + with_ancilla_init invalid_vec $ \v -> do + oracle_O c (a,v) + oracle_B (v,b) + oracle_R (v,r) + oracle_O c (a,v) + comment_with_label "EXIT: oracle_simple" (a,b,r) ("a","b","r") + + in + + -- return the oracle object + Oracle { n = n, + m = m, + k = k, + entrance = boollist_of_int_bh m 1, + oraclefun = oraclefun + } + +-- ====================================================================== +-- ** Alternate implementations of the \"orthodox\" oracle + +-- ---------------------------------------------------------------------- +-- *** Classical implementation + +-- $ In this section, we first implement the oracle function +-- /v[sub c](a)/ as a classical boolean function. This implementation +-- is just for reference, and attempts to be neither efficient nor +-- quantum. It can, however, be used as a specification to test the +-- actual quantum oracles against. +-- +-- Both the classical circuit implementation (below) and the Template +-- Haskell implementation (in the module "BWT.Template") were derived +-- from this. +-- +-- We start with several auxiliary functions. + +-- | The type of nodes: a pair of a tree bit and a node address. +type Node = (Bool, [Bool]) + +-- | Convert integers to nodes, mainly for testing. +node_of_int :: Int -> Int -> Node +node_of_int m a = node_of_boollist (boollist_of_int_bh m a) + +-- | Convert nodes to integers, mainly for testing. +int_of_node :: Node -> Int +int_of_node n = int_of_boollist_unsigned_bh (boollist_of_node n) + +-- | Convert a bit vector to a node. +node_of_boollist :: [Bool] -> Node +node_of_boollist (t:a) = (t,a) +node_of_boollist [] = error "node_of_boollist: empty boollist" + +-- | Convert a node to a bit vector. +boollist_of_node :: Node -> [Bool] +boollist_of_node (t,a) = t:a + +-- | Input a node /a/ and return the parent of /a/. We assume that /a/ +-- is not a root or invalid. +parent :: Node -> Node +parent (t, aa) = (t, False : init aa) + +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True', +-- respectively). Assumes that /a/ is not a leaf. +childintree :: Node -> Bool -> Node +childintree (t, h:aa) childbit = (t, aa ++ [childbit]) +childintree _ _ = error "childintree: invalid node" + +-- | @'bit_adder' 'False'@ is a one-bit adder, and @'bit_adder' 'True'@ is +-- a one-bit subtracter (i.e., add the 2's complement of /y/). +bit_adder :: Bool -> (Bool, Bool, Bool) -> (Bool, Bool) +bit_adder sign (carry, x, y) = (carry', z) + where + y' = y `bool_xor` sign + z = carry `bool_xor` x `bool_xor` y' + carry' = majority carry x y' + majority a b c = if a==b then a else c + +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit; /a/ +-- is the highest bit and /aa/ is the remaining /n/ bits) and a sign +-- /s/ (where 'True' = negative, 'False' = positive). Return +-- /a/:(/aa/ + /s/ * /f/). The first input is the /n/-bit welding +-- vector /f/ (a parameter to the oracle). Note that /f/ is a +-- parameter and /s/, /aa/ are inputs. +doweld1 :: Boollist -> Bool -> [Bool] -> [Bool] +doweld1 f s (a:aa) = a : aa' where + aa' = snd $ fold_right_zip (bit_adder s) (s, aa, f) +doweld1 f s [] = error "doweld1: invalid node" + +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit), and +-- return /a/:(/aa/ ⊕ /g/). The first input is the /n/-bit welding +-- vector /g/ (a parameter to the oracle). +doweld0 :: Boollist -> [Bool] -> [Bool] +doweld0 g (a:aa) = a : aa' where + aa' = g `boollist_xor` aa +doweld0 g [] = error "doweld0: invalid node" + +-- | Input a leaf node /a/ and return the left or right weld of /a/ in +-- the other tree (depending on whether the /weldbit/ is 'False' or +-- 'True'). Assumes that /a/ is a leaf. +weld :: Boollist -> Boollist -> Node -> Bool -> Node +weld f g (t, aa) weldbit = (not t, bb) + where + bb = if weldbit + then doweld1 g t aa + else doweld0 f aa + +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True'. This +-- works for leaf and non-leaf nodes. +child :: Boollist -> Boollist -> Node -> Bool -> Node +child f g (t, aa) childbit = + case aa of + True : _ -> -- This is a leaf + weld f g (t, aa) childbit + False : _ -> -- This is not a leaf + childintree (t, aa) childbit + _ -> error "child: invalid node" + +-- | Input a node address (without the tree bit) and return the parity +-- of the node level expressed as a boolean either 'False' or +-- 'True'. Leaves have parity 'False', and other levels have +-- alternating parities. In other words: count the number of leading +-- zeros modulo 2. +level_parity :: [Bool] -> Bool +level_parity [] = False +level_parity (h:t) = if h then False else not (level_parity t) + +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node address is invalid. In other words, return 'True' iff the +-- list consists of all 0's. +is_zero :: [Bool] -> Bool +is_zero [] = True +is_zero (h:t) = if h then False else is_zero t + +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node is a root or invalid. In other words, check whether all +-- digits but the last are 0's. +is_root :: [Bool] -> Bool +is_root [] = True +is_root (h:[]) = True +is_root (h:t) = if h then False else is_root t + +-- | @'v_function' f g c a@: returns /v/[sub /c/](/a/), the label of the +-- node connected to /a/ by an edge of color /c/, or 'Nothing' if +-- there is no such node. The parameters /f/ and /g/ encode the +-- welding functions, and are lists of length /n/. /c/ is a color in +-- the range 0..3, and /a/ is an (/n/+2)-bit node label. +v_function :: Boollist -> Boollist -> Int -> Node -> Maybe Node +v_function f g c a = + let (t,aa) = a + bc_hi = level_parity aa + z = is_zero aa + e = is_root aa + a1 = if last aa then True else False + [c_hi, c_lo] = boollist_of_int_bh 2 c + [cbc_hi, cbc_lo] = [c_hi `bool_xor` bc_hi, c_lo] + in + if not e && [cbc_hi, cbc_lo] == [True, a1] then Just(parent a) else + if not z && cbc_hi == False then Just(child f g a cbc_lo) else + Nothing + +-- ---------------------------------------------------------------------- +-- *** Auxiliary functions + +-- | The type of nodes: a pair of a tree bit and a node address. +type CNode = (Bit, Bitlist) + +-- | Like 'CNode', but uses qubits instead of classical bits. +type QNode = (Qubit, [Qubit]) + +-- | Convert a 'Qulist' to a 'QNode'. +qnode_of_qulist :: Qulist -> QNode +qnode_of_qulist (t:a) = (t,a) +qnode_of_qulist [] = error "qnode_of_qulist: empty list" + +-- | Convert a 'Bitlist' to a 'CNode'. +cnode_of_bitlist :: Bitlist -> CNode +cnode_of_bitlist (t:a) = (t,a) +cnode_of_bitlist [] = error "cnode_of_bitlist: empty list" + +-- | Exclusive or operation on bit vectors. +cboollist_xor :: Bitlist -> Bitlist -> Circ Bitlist +cboollist_xor = zipWithM (\x y -> cgate_xor [x,y]) + +-- ---------------------------------------------------------------------- +-- *** Classical circuit implementation + +-- $ We now implement the oracle function v[sub c](a) as a classical +-- circuit, with /c/ as a parameter. We don't try to be clever or +-- efficient yet. The implementation follows the \"classical +-- implementation\" above, but must be reformulated due to the need to +-- work within the 'Circ' monad. + +-- | Input a node /a/ and return the parent of /a/. We assume that /a/ +-- is not a root or invalid. +cparent :: CNode -> Circ CNode +cparent (t, aa_in) = do + comment_with_label "ENTER: cparent" (t, aa_in) ("t", "aa_in") + false <- cinit False + let aa_out = false : init aa_in + comment_with_label "EXIT: cparent" (t, aa_out) ("t", "aa_out") + return (t, aa_out) + +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True', +-- respectively). Assumes that /a/ is not a leaf. +cchildintree :: CNode -> Bit -> Circ CNode +cchildintree (t, node_in@(h:aa)) childbit = do + comment_with_label "ENTER: cchildintree" (t, node_in) ("t", "node_in") + let node_out = aa ++ [childbit] + comment_with_label "EXIT: cchildintree" (t, node_out) ("t", "node_out") + return (t, node_out) +cchildintree _ _ = error "cchildintree: invalid node" + +-- | @'bit_adder' 'False'@ is a one-bit adder, and @'bit_adder' 'True'@ is +-- a one-bit subtracter (i.e., add the 2's complement of /y/). +cbit_adder :: Bit -> (Bit, Bit, Bit) -> Circ (Bit, Bit) +cbit_adder sign (carry_in, x, y) = do + comment_with_label "ENTER: cbit_adder" (sign, carry_in, x, y) ("sign", "carry_in", "x", "y") + y' <- cgate_xor [y, sign] + z <- cgate_xor [carry_in, x, y'] + carry_out <- cmajority carry_in x y' + comment_with_label "EXIT: cbit_adder" (carry_out, z) ("carry_out", "z") + return (carry_out, z) + where + cmajority a b c = do + cond <- cgate_eq a b + cgate_if cond a c + +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit; /a/ +-- is the highest bit and /aa/ is the remaining /n/ bits) and a sign +-- /s/ (where 'True' = negative, 'False' = positive). Return +-- /a/:(/aa/ + /s/ * /f/). The first input is the /n/-bit welding +-- vector /f/ (a parameter to the oracle). Note that /f/ is a +-- parameter and /s/, /aa/ are inputs. +cdoweld1 :: Boollist -> Bit -> Bitlist -> Circ Bitlist +cdoweld1 f s node_in@(a:aa) = do + comment_with_label "ENTER: cdoweld1" (s, node_in) ("s", "node_in") + f' <- cinit f + (_,aa') <- fold_right_zipM (cbit_adder s) (s, aa, f') + let node_out = a : aa' + comment_with_label "EXIT: cdoweld1" node_out "node_out" + return node_out +cdoweld1 f s [] = error "cdoweld1: invalid node" + +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit), and +-- return /a/:(/aa/ ⊕ /g/). The first input is the /n/-bit welding +-- vector /g/ (a parameter to the oracle). +cdoweld0 :: Boollist -> Bitlist -> Circ Bitlist +cdoweld0 g node_in@(a:aa) = do + comment_with_label "ENTER: cdoweld0" node_in "node_in" + g' <- cinit g + aa' <- g' `cboollist_xor` aa + let node_out = a:aa' + comment_with_label "EXIT: cdoweld0" node_out "node_out" + return node_out +cdoweld0 g [] = error "cdoweld0: invalid node" + +-- | Input a leaf node /a/ and return the left or right weld of /a/ in +-- the other tree (depending on whether the /weldbit/ is 'False' or +-- 'True'). Assumes that /a/ is a leaf. +cweld :: Boollist -> Boollist -> CNode -> Bit -> Circ CNode +cweld f g node_in@(t, aa) weldbit = do + comment_with_label "ENTER: cweld" (node_in, weldbit) ("node_in", "weldbit") + bb <- circ_if weldbit ( + cdoweld1 g t aa + )( + cdoweld0 f aa + ) + t' <- cgate_not t + let node_out = (t', bb) + comment_with_label "EXIT: cweld" node_out "node_out" + return node_out + +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True'. This +-- works for leaf and non-leaf nodes. +cchild :: Boollist -> Boollist -> CNode -> Bit -> Circ CNode +cchild f g node_in@(t, a:aa) childbit = do + comment_with_label "ENTER: cchild" (node_in, childbit) ("node_in", "childbit") + node_out <- circ_if a ( + -- This is a leaf + cweld f g (t, a:aa) childbit + )( + -- This is not a leaf + cchildintree (t, a:aa) childbit + ) + comment_with_label "EXIT: cchild" node_out "node_out" + return node_out + +cchild f g (t, _) childbit = + error "cchild: invalid node" + +-- | Input a node address (without the tree bit) and return the parity +-- of the node level expressed as a boolean either 'False' or +-- 'True'. Leaves have parity 'False', and other levels have +-- alternating parities. In other words: count the number of leading +-- zeros modulo 2. +clevel_parity :: Bitlist -> Circ Bit +clevel_parity node = do + comment_with_label "ENTER: clevel_parity" node "node" + parity <- clevel_parity_rec node + comment_with_label "EXIT: clevel_parity" parity "parity" + return parity + + where + clevel_parity_rec :: Bitlist -> Circ Bit + clevel_parity_rec [] = cinit False + clevel_parity_rec (h:t) = do + r <- clevel_parity_rec t + circ_if h ( + cinit False + )( + cgate_not r + ) + +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node address is invalid. In other words, return 'True' iff the +-- list consists of all 0's. +cis_zero :: Bitlist -> Circ Bit +cis_zero node = do + comment_with_label "ENTER: cis_zero" node "node" + is_zero <- cis_zero_rec node + comment_with_label "EXIT: cis_zero" is_zero "is_zero" + return is_zero + + where + cis_zero_rec :: Bitlist -> Circ Bit + cis_zero_rec [] = cinit True + cis_zero_rec (h:t) = do + circ_if h ( + cinit False + )( + cis_zero_rec t + ) + +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node is a root or invalid. In other words, check whether all +-- digits but the last are 0's. +cis_root :: Bitlist -> Circ Bit +cis_root node = do + comment_with_label "ENTER: cis_root" node "node" + is_root <- cis_root_rec node + comment_with_label "EXIT: cis_root" is_root "is_root" + return is_root + + where + cis_root_rec :: Bitlist -> Circ Bit + cis_root_rec [] = cinit True + cis_root_rec (h:[]) = cinit True + cis_root_rec (h:t) = do + circ_if h ( + cinit False + )( + cis_root_rec t + ) + +-- | @'cv_function' f g c a@: returns /v/[sub /c/](/a/), the label of the +-- node connected to /a/ by an edge of color /c/, or 'Nothing' if +-- there is no such node. The parameters /f/ and /g/ encode the +-- welding functions, and are lists of length /n/. /c/ is a color in +-- the range 0..3, and /a/ is an (/n/+2)-bit node label. +-- +-- We currently implement @'Maybe' 'CNode'@ as an indexed union, and +-- specifically as @('CNode','Bit')@. When /Bit/='True', the value of +-- 'CNode' is undefined (doesn't matter); in particular, this value +-- may contain garbage. +cv_function :: Boollist -> Boollist -> Int -> CNode -> Circ (CNode,Bit) +cv_function f g color a = do + comment_with_label (printf "ENTER: cv_function (color=%d)" color) a "a" + let (t,aa) = a + bc_hi <- clevel_parity aa + z <- cis_zero aa + e <- cis_root aa + let a1 = last aa + let [c_hi', c_lo'] = boollist_of_int_bh 2 color + c_hi <- cinit c_hi' + c_lo <- cinit c_lo' + cbc_hi <- cgate_xor [c_hi, bc_hi] + let cbc_lo = c_lo + not_e <- cgate_not e + cbc_lo_eq_a1 <- cgate_eq cbc_lo a1 + cond1 <- cgate_and [not_e, cbc_hi, cbc_lo_eq_a1] + (b, invalid) <- circ_if cond1 ( + do + cparent_a <- cparent a + false <- cinit False + return (cparent_a, false) + )( + do + cchild_a_cbc_lo <- cchild f g a cbc_lo + not_z <- cgate_not z + cbc_hi_eq_false <- cgate_not cbc_hi + valid <- cgate_and [not_z, cbc_hi_eq_false] + not_valid <- cgate_not valid + -- a slight optimization here: we return garbage in the + -- first register if not_valid == True + return (cchild_a_cbc_lo, not_valid) + ) + comment_with_label (printf "EXIT: cv_function (color=%d)" color) (b, invalid) ("b", "invalid") + return (b, invalid) + +-- ====================================================================== +-- *** Oracle abstraction + +-- | The classical oracle implementation, packaged into the 'Oracle' +-- abstraction. This oracle has two parameters, namely the welding +-- vectors /f/ and /g/. Note: this oracle has not been optimized +-- whatsoever. +oracle_classical :: Boollist -> Boollist -> Oracle +oracle_classical f g = + Oracle { n = n, + m = m, + k = k, + entrance = entrance, + oraclefun = oraclefun + } where + n = length f + m = n+2 + k = 4 + entrance = boollist_of_int_bh m 1 + + oraclefun :: Int -> (Qulist, Qulist, Qubit) -> Circ () + oraclefun color (a,b,r) = do + let an = qnode_of_qulist a + let bn = qnode_of_qulist b + (classical_to_quantum . classical_to_reversible) (cv_function f g color) (an, (bn, r)) + return () + +-- ====================================================================== +-- * Testing functions + +-- | Output the list of colored edges as computed by the classical +-- 'v_function', for some arbitrary choice of /f/ and /g/ and /n/=3. +main_edges1 :: IO() +main_edges1 = mapM_ output (sample_all0 (127,3)) + where + f = take 5 (True : False : f) + g = take 5 (False : True : g) + + output :: (Int,Int) -> IO() + output (a,c) = + case v_function f g c (node_of_int 7 a) of + Nothing -> printf "%d ---%d---> None\n" a c + Just b -> printf "%d ---%d---> %d\n" a c (int_of_node b) + +-- | For debugging: 'circfun' is similar to 'v_function', except it +-- works by calling 'cv_function' to assemble the circuit, then +-- simulates it. This is for testing whether the assembled circuit is +-- correct. Returns @('Bool', 'Node')@ instead of @'Maybe' 'Node'@, so +-- that we can see any garbage that is output in case of an invalid +-- node. +circfun :: Boollist -> Boollist -> Int -> Node -> (Node, Bool) +circfun f g color nd = + run_classical_generic (cv_function f g color) nd + +-- | Output the list of colored edges as computed by simulating the +-- circuit 'cv_function', for some arbitrary choice of /f/ and /g/ and +-- /n/=3. This is like 'main_edges1', except it actually assembles and +-- simulates the classical circuit. +main_edges2 :: IO() +main_edges2 = mapM_ output (sample_all0 (127,3)) + where + f = take 5 (True : False : f) + g = take 5 (False : True : g) + output :: (Int,Int) -> IO() + output (a,c) = + case circfun f g c (node_of_int 7 a) of + (node, False) -> printf "%d ---%d---> %d\n" a c (int_of_node node) + (garbage, True) -> printf "%d ---%d---> None (%d)\n" a c (int_of_node garbage) + +-- | Graphically output the classical oracle circuit for color /c/, +-- using /n/ from the oracle data structure, and for some arbitrary +-- /f/ and /g/. +main_oraclec :: Format -> BWT.Oracle -> Int -> IO() +main_oraclec format oracle color = + print_generic format circuit cnode_shape + where + m' = BWT.m oracle + n' = BWT.n oracle + f = take n' (True : False : f) + g = take n' (False : True : g) + cnode_shape = cnode_of_bitlist (replicate m' bit) + circuit n = cv_function f g color n + +-- | Like 'main_oraclec', except it rewrites the classical circuit in +-- terms of Toffoli gates. +main_oracle2 :: Format -> BWT.Oracle -> Int -> IO() +main_oracle2 format oracle color = + print_generic format circuit cnode_shape + where + m' = BWT.m oracle + n' = BWT.n oracle + f = take n' (True : False : f) + g = take n' (False : True : g) + cnode_shape = cnode_of_bitlist (replicate m' bit) + circuit n = classical_to_cnot (cv_function f g color n) + +-- | Like 'main_oraclec', except it makes the classical circuit +-- reversible first. +main_oracle3 :: Format -> BWT.Oracle -> Int -> IO() +main_oracle3 format oracle color = + print_generic format circuit (cnode_shape, (cnode_shape, qubit)) + where + m' = BWT.m oracle + n' = BWT.n oracle + f = take n' (True : False : f) + g = take n' (False : True : g) + cnode_shape = qnode_of_qulist (replicate m' qubit) + circuit = (classical_to_quantum . classical_to_reversible) (cv_function f g color) + +-- | Output the top-level circuit for the binary welded tree algorithm +-- with the classical oracle, using some arbitrary welding vectors /f/ +-- and /g/, and /s/=1. +main_qrwbwt :: IO() +main_qrwbwt = + print_simple EPS (qrwbwt (oracle_classical f g) dt 1) + where + f = [False, False, True] + g = [True, False, True] + dt = pi/180 diff --git a/Quipper/Algorithms/BWT/BWT.hs b/Quipper/Algorithms/BWT/BWT.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/BWT/BWT.hs @@ -0,0 +1,600 @@ +-- | This module provides an implementation of the main binary welded +-- tree algorithm and oracle, using a more-or-less imperative +-- programming style. We abstract the oracle into a data type, so that +-- different oracles can be plugged into the main algorithm. + +module Quipper.Algorithms.BWT.BWT where + +-- import other Quipper stuff +import Quipper +import Quipper.Algorithms.BWT.Definitions + +import Quipper.Libraries.Qureg +import Quipper.Libraries.Decompose + +import Quipper.Utils.Auxiliary + +import Text.Printf + +-- ====================================================================== +-- * Oracle abstraction + +-- | A data structure to hold an oracle. The binary welded tree +-- algorithm is parametric on an oracle. An oracle encodes a graph, +-- and provides the following information: the tree depth /n/ (in the +-- above example: 3), the label length /m/ (in bits; 5 in the above +-- example), the number of edge colors /k/, the entrance label +-- /ENTRANCE/, and for each color 0 ≤ /c/ < /k/, a reversible circuit +-- /ORACLE/[sub /c/](/a/,/b/,/r/). On basis vectors, this circuit +-- encodes the edge information in the following sense: +-- +-- > ORACLE[sub c](a, b, r) = (a, b ⊕ v[sub c](a), r ⊕ f[sub c](a)), +-- +-- where /f/[sub /c/](/a/) is 1 if the node /a/ is connected to an +-- edge of color /c/, and 0 otherwise; and /v/[sub /c/](a) is the +-- node label connected to node /a/ along an edge of color /c/ (if +-- any), and arbitrary otherwise. +-- +-- Not all available node labels need to be used (for example, 0 and +-- 16 are unused in the graph in the above illustration). + +data Oracle = Oracle { + n :: Int, + m :: Int, + k :: Int, + entrance :: Boollist, + oraclefun :: Int -> (Qureg, Qureg, Qubit) -> Circ () +} + +-- ====================================================================== +-- * Top-level algorithm + +-- | The main loop of the binary welded tree algorithm. +-- +-- @qrwbwt oracle s dt@: Do a quantum random walk on the binary welded +-- tree given by the oracle /oracle/, for /s/ times steps of length +-- /dt/. Returns a bit list corresponding to the computed exit node +-- label. + +qrwbwt :: Oracle -> Int -> Timestep -> Circ [Bit] +qrwbwt oracle s dt = do + comment (printf "ENTER: qrwbwt (s=%d, dt=%.3e)" s dt) + -- initialize a to the entrance label + a <- qinit_register (entrance oracle) + with_ancilla_reg (m oracle) $ \b -> do + with_ancilla $ \r -> do + loopM_boxed_if (s > 1) "qrwbwt_loop" s (a,b,r) $ \(a,b,r) -> do + for 0 (k oracle-1) 1 $ \c -> do + (oraclefun oracle) c (a, b, r) + timestep (a, b, r, dt, m oracle) + (oraclefun oracle) c (a, b, r) + endfor + return (a,b,r) + endfor + exit <- qmeasure_register a + comment_with_label "EXIT: qrwbwt" exit "exit" + return exit + +-- | @timestep (a, b, r, dt, m)@: Perform a single time step /dt/ of +-- the quantum walk. This is done by iterating through each of the +-- available edge colors, and performing a diffusion step for each +-- color. Here, /a/ is an /m/-qubit registers holding (a superposition +-- of) the current node label. /b/ is an /m/-qubit ancilla register, +-- and /r/ is an ancilla qubit. Both /b/ and /r/ are expected to be +-- initialized to |0〉 by the caller, and will be returned in state +-- |0〉. +timestep :: (Qureg, Qureg, Qubit, Timestep, Int) -> Circ () +timestep (a, b, r, dt, m) = do + comment_with_label "ENTER: timestep" (a,b,r) ("a","b","r") + with_ancilla $ \h -> do + for 0 (m-1) 1 $ \i -> do + wGate (a.!(i), b.!(i)) + endfor + for 0 (m-1) 1 $ \i -> do + toffoliGate (a.!(i), b.!(i), h) + endfor + controlledExpGate (dt, r, h) + for (m-1) 0 (-1) $ \i -> do + toffoliGate (a.!(i), b.!(i), h) + endfor + for (m-1) 0 (-1) $ \i -> do + wGateInverse (a.!(i), b.!(i)) + endfor + comment_with_label "EXIT: timestep" (a,b,r) ("a","b","r") + return () + +-- ====================================================================== +-- * Oracle implementation + +-- $ The functions in this section implement a particular oracle for a +-- binary welded tree. The oracle is parametric on: +-- +-- * the tree depth /n/; +-- +-- * two \"welding vectors\" /f/ and /g/, specifying how the leaves of +-- the two binary trees are connected to each other. Specifically, /f/ +-- and /g/ encode the permutations of leaves given by a ↦ a ⊕ f and +-- a ↦ a + g, respectively, where \"⊕\" denotes bitwise exclusive or, +-- and \"+\" denotes binary addition. + +-- ---------------------------------------------------------------------- +-- ** Oracle subroutines + +-- | The top-level oracle circuit. The arguments are of the form (/a/, +-- /b/, /r/, /color/, /f/, /g/, /n/), where /a/, /b/ are quantum +-- registers of length /n/+2, /color/ is a boolean register of length +-- 2, and /f/ and /g/ are boolean registers of length /n/. +oracle :: (Qureg, Qureg, Qubit, Boolreg, Boolreg, Boolreg, Int) -> Circ () +oracle (a, b, r, color, f, g, n) = do + let c = int_of_boolreg_unsigned_le color :: Int + comment_with_label (printf "ENTER: oracle (color=%d)" c) (a,b,r) ("a","b","r") + with_ancilla $ \root -> do + with_ancilla $ \even -> do + with_ancilla $ \isparent -> do + with_ancilla $ \ischild -> do + with_ancilla $ \direction -> do + with_ancilla $ \ismatch -> do + parseNodeRoot (a, root, even, n) + parseNodeEven (a, even, n) + testIsParent (a, root, even, isparent, color, n, 1, ismatch) + testIsChild (even, ischild, direction, color, n) + setParent (a, b, isparent, n) + setChild (a, b, ischild, direction, f, g, n) + with_controls (isparent .==. 0 .&&. ischild .==. 0) $ do { + qnot_at r + } + testIsChild (even, ischild, direction, color, n) + testIsParent (a, root, even, isparent, color, n, 0, ismatch) + parseNodeEven (a, even, n) + parseNodeRoot (a, root, even, n) + comment_with_label (printf "EXIT: oracle (color=%d)" c) (a,b,r) ("a","b","r") + return () + +-- | Input a node label /a/ of length at least /n/+1. Negate both +-- /root/ and /even/ if /a/ is a root node. +parseNodeRoot :: (Qureg, Qubit, Qubit, Int) -> Circ () +parseNodeRoot (a, root, even, n) = do + comment_with_label "ENTER: parseNodeRoot" (a, root, even) ("a", "root", "even") + with_ancilla_reg (n+1) $ \scratch -> do + for n 1 (-1) $ \index -> do + with_controls (scratch.!(index) .==. 0 .&&. a.!(index) .==. 1) $ do { + qnot_at (scratch.!(index - 1)) + } + with_controls (scratch.!(index) .==. 1) $ do { + qnot_at (scratch.!(index - 1)) + } + endfor + with_controls (scratch.!(0) .==. 0) $ do { + qnot_at root; + qnot_at even + } + for 1 n 1 $ \index -> do + with_controls (scratch.!(index) .==. 1) $ do { + qnot_at (scratch.!(index - 1)) + } + with_controls (scratch.!(index) .==. 0 .&&. a.!(index) .==. 1) $ do { + qnot_at (scratch.!(index-1)) + } + endfor + comment_with_label "EXIT: parseNodeRoot" (a, root, even) ("a", "root", "even") + return () + +-- | Input a node label /a/ of length at least /n/+1. Negate /even/ +-- if the node /a/ occurs at an even height in the tree. +parseNodeEven :: (Qureg, Qubit, Int) -> Circ () +parseNodeEven (a, even, n) = do + comment_with_label "ENTER: parseNodeEven" (a, even) ("a", "even") + with_ancilla_reg (n+1) $ \scratch -> do + for n 1 (-1) $ \index -> do + with_controls (scratch.!(n) .==. 0 .&&. a.!(index) .==. 1) $ do { + qnot_at (scratch.!(index-1)); + with_controls (Prelude.even index) $ do { + qnot_at even + } + } + with_controls (scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(n)) + } + endfor + for 1 n 1 $ \index -> do + with_controls (scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(n)) + } + with_controls (scratch.!(n) .==. 0 .&&. a.!(index) .==. 1) $ do { + qnot_at (scratch.!(index-1)) + } + endfor + comment_with_label "EXIT: parseNodeEven" (a, even) ("a", "even") + return () + +-- | Input a node label /a/ of length at least 1, and flags /root/ +-- and /even/ describing whether /a/ is a root and at an even level, +-- respectively. Negate /isparent/ if /a/ has a parent of color +-- /color/ in the tree. +-- +-- The qubit /ismatch/ is an ancilla, and /really/ is either 0 or +-- 1. They are jointly used to control uncomputation, so that the +-- following sequence will compute and then uncompute 'testIsParent': +-- +-- > ismatch <- qinit 0 +-- > testIsParent (a, root, even, isparent, color, n, 1, ismatch) +-- > testIsParent (a, root, even, isparent, color, n, 0, ismatch) +-- > qterm 0 ismatch +testIsParent :: (Qureg, Qubit, Qubit, Qubit, Boolreg, Int, Int, Qubit) -> Circ () +testIsParent (a, root, even, isparent, color, n, really, ismatch) = do + let c = int_of_boolreg_unsigned_le color :: Int + comment_with_label (printf "ENTER: testIsParent (color=%d really=%d)" c really) (a, root, even, isparent, ismatch) ("a", "root", "even", "isparent", "ismatch") + with_controls (really == 0) $ do { + with_controls (root .==. 0 .&&. ismatch .==. 1) $ do { + qnot_at isparent + } + } + if color.!(1) == 1 + then + if color.!(0) == 1 then + with_controls (even .==. 1 .&&. a.!(0) .==. 1) $ do { + qnot_at ismatch + } + else + with_controls (even .==. 1 .&&. a.!(0) .==. 0) $ do { + qnot_at ismatch + } + else + if color.!(0) == 1 then + with_controls (even .==. 0 .&&. a.!(0) .==. 1) $ do { + qnot_at isparent + } + else + with_controls (even .==. 0 .&&. a.!(0) .==. 0) $ do { + qnot_at isparent + } + with_controls (root .==. 0 .&&. ismatch .==. 1) $ do { + qnot_at isparent + } + comment_with_label (printf "EXIT: testIsParent (color=%d really=%d)" c really) (a, root, even, isparent, ismatch) ("a", "root", "even", "isparent", "ismatch") + return () + +-- | Consider a node /a/, and negate /ischild/ if /a/ has a child +-- node of color /color/. Also set /direction/ to indicate whether +-- it is a \"left\" or \"right\" child. Here, /color/ is a boolean +-- register of length 2, representing a color. This function is +-- self-inverse. +testIsChild :: (Qubit, Qubit, Qubit, Boolreg, Int) -> Circ () +testIsChild (even, ischild, direction, color, n) = do + comment_with_label "ENTER: testIsChild" (even, ischild, direction) ("even", "ischild", "direction") + if color.!(1) == 1 + then + with_controls (even .==. 0) $ do { + qnot_at ischild + } + else + with_controls (even .==. 1) $ do { + qnot_at ischild + } + with_controls (color.!(0) == 1) $ do { + qnot_at direction + } + comment_with_label "EXIT: testIsChild" (even, ischild, direction) ("even", "ischild", "direction") + return () + +-- | Input a node label /a/ of length at least /n/+2, and a flag +-- /isparent/ that has been initialized accordingly. Also input a +-- register /b/ of length at least /n/+2, initialized to |0〉. If +-- /isparent/ is set, set /b/ to the node label of the parent of +-- /a/. This is self-inverse. +setParent :: (Qureg, Qureg, Qubit, Int) -> Circ () +setParent (a, b, isparent, n) = do + comment_with_label "ENTER: setParent" (a, b, isparent) ("a", "b", "isparent") + for 0 (n-1) 1 $ \index -> do + with_controls (isparent .==. 1 .&&. a.!(index+1) .==. 1) $ do { + qnot_at (b.!(index)) + } + endfor + with_controls (isparent .==. 1 .&&. a.!(n+1) .==. 1) $ do { + qnot_at (b.!(n+1)) + } + comment_with_label "EXIT: setParent" (a, b, isparent) ("a", "b", "isparent") + return () + +-- | Similar to 'setParent', but set /b/ to the node label of the +-- indicated child of /a/. Here /a/ and /b/ are quantum registers of +-- length at least /n/+2, and /f/ and /g/ are boolean registers of +-- length /n/. +setChild :: (Qureg, Qureg, Qubit, Qubit, Boolreg, Boolreg, Int) -> Circ () +setChild (a, b, ischild, direction, f, g, n) = do + comment_with_label "ENTER: setChild" (a, b, ischild, direction) ("a", "b", "ischild", "direction") + with_ancilla $ \childctrl -> do + with_controls (ischild .==. 1 .&&. a.!(n) .==. 1) $ do { + qnot_at childctrl + } + setWeld (a, b, childctrl, direction, f, g, n) + with_controls (ischild .==. 1) $ do { + qnot_at childctrl + } + setChildInTree (a, b, childctrl, direction, n) + with_controls (ischild .==. 1 .&&. a.!(n) .==. 0) $ do { + qnot_at childctrl + } + comment_with_label "EXIT: setChild" (a, b, ischild, direction) ("a", "b", "ischild", "direction") + return () + +-- | A special case of 'setChild', where the child is inside the same +-- binary tree (i.e., not via the welding). +setChildInTree :: (Qureg, Qureg, Qubit, Qubit, Int) -> Circ () +setChildInTree (a, b, childctrl, direction, n) = do + comment_with_label "ENTER: setChildInTree" (a, b, childctrl, direction) ("a", "b", "childctrl", "direction") + with_controls (childctrl .==. 1 .&&. direction .==. 1) $ do { + qnot_at (b.!(0)) + } + for 1 n 1 $ \index -> do + with_controls (childctrl .==. 1 .&&. a.!(index-1) .==. 1) $ do { + qnot_at (b.!(index)) + } + endfor + with_controls (childctrl .==. 1 .&&. a.!(n+1) .==. 1) $ do { + qnot_at (b.!(n+1)) + } + comment_with_label "EXIT: setChildInTree" (a, b, childctrl, direction) ("a", "b", "childctrl", "direction") + return () + +-- | A special case of 'setChild', where the child is in the opposite +-- binary tree, i.e., we follow one of the welding edges. +setWeld :: (Qureg, Qureg, Qubit, Qubit, Boolreg, Boolreg, Int) -> Circ () +setWeld (a, b, childctrl, direction, f, g, n) = do + comment_with_label "ENTER: setWeld" (a, b, childctrl, direction) ("a", "b", "childctrl", "direction") + with_ancilla $ \weldctrl -> do + with_controls (childctrl .==. 1 .&&. direction .==. 0) $ do { + qnot_at weldctrl + } + doWeld0 (a, b, weldctrl, f, n) + with_controls (childctrl .==. 1) $ do { + qnot_at weldctrl + } + doWeld1 (a, b, weldctrl, g, n) + with_controls (childctrl .==. 1 .&&. direction .==. 1) $ do { + qnot_at weldctrl + } + with_controls (childctrl .==. 1 .&&. a.!(n+1) .==. 1) $ do { + qnot_at (b.!(n+1)) + } + with_controls (childctrl .==. 1) $ do { + qnot_at (b.!(n)); + qnot_at (b.!(n+1)) + } + comment_with_label "EXIT: setWeld" (a, b, childctrl, direction) ("a", "b", "childctrl", "direction") + return () + +-- | Input a node label /a/, and a register /b/ initialized to +-- |0〉. If /weldctrl/ is set, set /b/ to the node connected to /a/ +-- by the welding function /f/. This is self-inverse. Here, /a/ and +-- /b/ are quantum registers of length at least /n/+2, and /f/ is a +-- boolean register of length /n/. +doWeld1 :: (Qureg, Qureg, Qubit, Boolreg, Int) -> Circ () +doWeld1 (a, b, weldctrl, g, n) = do + comment_with_label "ENTER: doWeld1" (a, b, weldctrl) ("a", "b", "weldctrl") + with_ancilla $ \addsub -> do + with_controls (weldctrl .==. 1 .&&. a.!(n+1) .==. 0) $ do { + qnot_at addsub + } + cAddNum (addsub, b, a, g, n) + with_controls (weldctrl .==. 1) $ do { + qnot_at addsub + } + cSubNum (addsub, b, a, g, n) + with_controls (weldctrl .==. 1 .&&. a.!(n+1) .==. 1) $ do { + qnot_at addsub + } + comment_with_label "EXIT: doWeld1" (a, b, weldctrl) ("a", "b", "weldctrl") + return () + +-- | Input a node label /a/, and a register /b/ initialized to +-- |0〉. If /weldctrl/ is set, set /b/ to the node connected to /a/ +-- by the welding function /g/. This is self-inverse. Here, /a/ and +-- /b/ are quantum registers of length at least /n/+2, and /g/ is a +-- boolean register of length /n/. +doWeld0 :: (Qureg, Qureg, Qubit, Boolreg, Int) -> Circ () +doWeld0 (a, b, weldctrl, f, n) = do + comment_with_label "ENTER: doWeld0" (a, b, weldctrl) ("a", "b", "weldctrl") + for 0 (n-1) 1 $ \index -> do + with_controls (weldctrl .==. 1) $ do { + qnot_at (b.!(index)) `controlled` a.!(index) ./=. f.!(index) + } + endfor + comment_with_label "EXIT: doWeld0" (a, b, weldctrl) ("a", "b", "weldctrl") + return () + +-- | This function implements integer addition. Input a quantum +-- register /input/ and a boolean register /num/, representing +-- integers, and a quantum register /out/ initialized to |0〉. If +-- /control/ is set, set /out/ to /input/ + /num/, otherwise do +-- nothing. Here /input/ and /out/ are quantum registers of length at +-- least /n/, /num/ is a boolean register of length /n/. +cAddNum :: (Qubit, Qureg, Qureg, Boolreg, Int) -> Circ () +cAddNum (control, out, input, num, n) = do + comment_with_label "ENTER: cAddNum" (control, out, input) ("control", "out", "input") + -- we represent mask as 1 << maskbit + with_ancilla_reg n $ \scratch -> do + let maskbit = 0 -- invariant: mask = 1 << maskbit + with_controls (control .==. 1 .&&. input.!(0) .==. 1) $ do { + qnot_at (out.!(0)) + } + with_controls (num.!(maskbit) /= 0) $ do { + with_controls (control .==. 1) $ do { + qnot_at (out.!(0)) + }; + with_controls (input.!(0) .==. 1) $ do { + qnot_at (scratch.!(0)) + } + } + for 1 (n-1) 1 $ \index -> do + let maskbit = index -- invariant: mask = 1 << maskbit + with_controls (control .==. 1 .&&. input.!(index) .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. control .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (control .==. 1 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. input.!(index) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (input.!(index) .==. 1 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + endfor + cAddNumClear (control, scratch, input, num, n) + comment_with_label "EXIT: cAddNum" (control, out, input) ("control", "out", "input") + return () + +-- | A helper function for clearing the scratch space used by 'cAddNum'. +cAddNumClear :: (Qubit, Qureg, Qureg, Boolreg, Int) -> Circ () +cAddNumClear (control, scratch, input, num, n) = do + comment_with_label "ENTER: cAddNumClear" (control, scratch, input) ("control", "scratch", "input") + -- we represent mask as 1 << maskbit + for (n-1) 1 (-1) $ \index -> do + let maskbit = index -- invariant: mask = 1 << maskbit + with_controls (num.!(maskbit) /= 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (input.!(index) .==. 1 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. input.!(index) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + endfor + let maskbit = 0 -- invariant: mask = 1 << maskbit + with_controls (num.!(maskbit) /= 0 .&&. input.!(0) .==. 1) $ do { + qnot_at (scratch.!(0)) + } + comment_with_label "EXIT: cAddNumClear" (control, scratch, input) ("control", "scratch", "input") + return () + +-- | Like 'cAddNum', except subtract instead of adding. +cSubNum :: (Qubit, Qureg, Qureg, Boolreg, Int) -> Circ () +cSubNum (control, out, input, num, n) = do + comment_with_label "ENTER: cSubNum" (control, out, input) ("control", "out", "input") + -- we represent mask as 1 << maskbit + with_ancilla_reg n $ \scratch -> do + let maskbit = 0 -- invariant: mask = 1 << maskbit + with_controls (control .==. 1 .&&. input.!(0) .==. 1) $ do { + qnot_at (out.!(0)) + } + with_controls (num.!(maskbit) /= 0) $ do { + with_controls (control .==. 1) $ do { + qnot_at (out.!(0)) + }; + with_controls (input.!(0) .==. 0) $ do { + qnot_at (scratch.!(0)) + } + } + for 1 (n-1) 1 $ \index -> do + let maskbit = index -- invariant: mask = 1 << maskbit + with_controls (control .==. 1 .&&. input.!(index) .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. control .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (control .==. 1 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. input.!(index) .==. 0) $ do { + qnot_at (scratch.!(index)) + } + with_controls (input.!(index) .==. 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + endfor + cSubNumClear (control, scratch, input, num, n) + comment_with_label "EXIT: cSubNum" (control, out, input) ("control", "out", "input") + return () + +-- | A helper function for clearing the scratch space used by 'cSubNum'. +cSubNumClear :: (Qubit, Qureg, Qureg, Boolreg, Int) -> Circ () +cSubNumClear (control, scratch, input, num, n) = do + comment_with_label "ENTER: cSubNumClear" (control, scratch, input) ("control", "scratch", "input") + -- we represent mask as 1 << maskbit + for (n-1) 1 (-1) $ \index -> do + let maskbit = index -- invariant: mask = 1 << maskbit + with_controls (num.!(maskbit) /= 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (input.!(index) .==. 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. input.!(index) .==. 0) $ do { + qnot_at (scratch.!(index)) + } + endfor + let maskbit = 0 -- invariant: mask = 1 << maskbit + with_controls (num.!(maskbit) /= 0 .&&. input.!(0) .==. 0) $ do { + qnot_at (scratch.!(0)) + } + comment_with_label "EXIT: cSubNumClear" (control, scratch, input) ("control", "scratch", "input") + return () + +-- ---------------------------------------------------------------------- +-- ** The oracle data structure + +-- | This function inputs two welding functions /f/ and /g/, and +-- returns the oracle defined by the preceding functions. +-- +-- We call this the \"orthodox\" oracle, because the implementation +-- follows its specification very closely. For example, it uses a very +-- \"imperative\" programming style. For alternative implementations +-- of this and other oracles, see the modules +-- "Quipper.Algorithms.BWT.Alternative" and "Quipper.Algorithms.BWT.Template". +oracle_orthodox :: Boollist -> Boollist -> Oracle +oracle_orthodox f g = + Oracle { n = n, + m = m, + k = k, + entrance = entrance, + oraclefun = oraclefun + } where + n = length f + m = n+2 + k = 4 + entrance = boollist_of_int_bh m 1 + f_reg = boolreg_of_boollist_te f + g_reg = boolreg_of_boollist_te g + + oraclefun :: Int -> (Qureg, Qureg, Qubit) -> Circ () + oraclefun c (a,b,r) = do + let color = boolreg_of_int_le 2 c + oracle (a, b, r, color, f_reg, g_reg, n) + return () + +-- ====================================================================== +-- * Main functions + +-- These functions are so that the user can output something. + +-- | Output the circuit for the quantum walk and a binary welded tree, +-- for the given 'Oracle' in the specified 'Format' and using the +-- specified 'GateBase'. Use /s/ time steps of length /dt/. +main_circuit :: Format -> GateBase -> Oracle -> Int -> Timestep -> IO() +main_circuit format base oracle s dt = + print_generic format (decompose_generic base circuit) + where + circuit = qrwbwt oracle s dt + +-- | Output the circuit for the given 'Oracle' and the given color +-- (specified as an 'Int'). Use the specified output 'Format' and +-- 'GateBase'. +main_oracle :: Format -> GateBase -> Oracle -> Int -> IO() +main_oracle format base oracle c = + let m' = m oracle + ofun = oraclefun oracle + circuit = (\(a,b,r) -> ofun c (qureg_of_qulist_te a, qureg_of_qulist_te b, r)) + in + print_generic format (decompose_generic base circuit) (replicate m' qubit, replicate m' qubit, qubit) diff --git a/Quipper/Algorithms/BWT/Definitions.hs b/Quipper/Algorithms/BWT/Definitions.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/BWT/Definitions.hs @@ -0,0 +1,35 @@ +-- | This module provides some convenient definitions for the Binary +-- Welded Tree algorithm implementation. + +module Quipper.Algorithms.BWT.Definitions where + +import Quipper + +-- ====================================================================== +-- * Some convenient gates + +-- | Apply the binary /W/-gate to a pair of qubits. The W-gate +-- diagonalizes the SWAP operation. +wGate :: (Qubit, Qubit) -> Circ () +wGate (a,b) = do + gate_W a b + return () + +-- | Apply the /inverse/ of the /W/-gate. Note: since the /W/-gate is +-- self-inverse, this is really the same as 'wGate'. However, we +-- define this as a separate function for clarity. +wGateInverse :: (Qubit, Qubit) -> Circ () +wGateInverse = wGate + +-- | Apply a doubly-controlled not gate to a triple of qubits (/a/, +-- /b/, /c/). Here the qubit /c/ is negated if /a/=1 and /b/=0. +toffoliGate :: (Qubit, Qubit, Qubit) -> Circ () +toffoliGate (a, b, c) = + qnot_at c `controlled` (a .==. 1 .&&. b .==. 0) + +-- | @controlledExpGate(t, r, h):@ +-- Apply the [exp −/iZt/] gate to the qubit /h/, provided that /r/=0. +controlledExpGate :: (Timestep, Qubit, Qubit) -> Circ () +controlledExpGate (t, r, h) = do + expZt t h `controlled` (r .==. 0) + return () diff --git a/Quipper/Algorithms/BWT/Main.hs b/Quipper/Algorithms/BWT/Main.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/BWT/Main.hs @@ -0,0 +1,294 @@ +-- | +-- Authors: Peter Selinger, Benoît Valiron +-- +-- An implementation of the Binary Welded Tree algorithm. This +-- algorithm inputs an oracle encoding a graph of the following form: +-- +-- \[image weldedtree.png] +-- +-- The graph consists of two binary trees whose leaves are connected +-- by two permutations as shown in the above illustration. Except for +-- the roots of the two trees, all nodes have degree 3. The edges +-- of the graph are colored with 4 different colors. The objective of +-- the algorithm is to find the exit node (17 in the above +-- illustration), given the entrance node (1 in the above +-- illustration). This is done by a Trotterized quantum walk on the +-- graph. +-- +-- The algorithm is described in: +-- +-- * A. M. Childs, R. Cleve, E. Deotto, E. Farhi, S. Gutmann, and +-- D. A. Spielman. \"Exponential algorithmic speedup by a quantum +-- walk.\" +-- /Proceedings of the 35th Annual ACM Symposium on Theory of Computing/, +-- pp. 59–68, 2003. See also . +-- +-- The present implementation is based on detailed algorithm and +-- oracle specifications that were provided to us by the IARPA QCS +-- program and written by Travis Humble. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.BWT.Main": Command line interface. +-- +-- * "Quipper.Algorithms.BWT.Definitions": Some general-purpose definitions. +-- +-- * "Quipper.Algorithms.BWT.BWT": The implementation of the main Binary +-- Welded Tree algorithm and oracle, using a more-or-less imperative +-- programming style. +-- +-- * "Quipper.Algorithms.BWT.Alternative": Alternate implementations of the +-- main algorithm and various oracles, using a more functional +-- programming style. +-- +-- * "Quipper.Algorithms.BWT.Template": Another oracle implementation, using +-- Quipper's \"build_circuit\" feature to automatically extract a +-- quantum circuit from a classical functional program. +-- +-- * "Quipper.Algorithms.BWT.Simulate": Functions for simulating, testing, and +-- debugging oracles. + +module Quipper.Algorithms.BWT.Main where + +import Quipper + +import Quipper.Libraries.Decompose + +import qualified Quipper.Algorithms.BWT.BWT as BWT +import qualified Quipper.Algorithms.BWT.Simulate as Simulate +import qualified Quipper.Algorithms.BWT.Alternative as Alternative +import qualified Quipper.Algorithms.BWT.Template as Template + +import Quipper.Utils.CommandLine + +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Control.Monad +import Data.List +import Data.Char + +-- ---------------------------------------------------------------------- +-- * Command line interface + +-- $ This module provides a command line interface for the Binary +-- Welded Tree algorithm. This allows the user, for example, to plug +-- in different oracles, show different parts of the circuit, select a +-- gate base, simulate, select parameters such as /n/ and /s/, and +-- select different output formats. + +-- ---------------------------------------------------------------------- +-- * Option processing + +-- | An enumeration type for determining what the main function should do. +data WhatToShow = + Circuit -- ^Show the whole circuit. + | Oracle -- ^Show only the oracle. + | Graph -- ^Show colored edges computed from oracle simulation. + | OracleC -- ^Show the \"classical\" oracle as a classical circuit. + | Simulate -- ^Run simulations of individual circuit fragments. + deriving Show + +-- | An enumeration type for selecting an oracle. +data OracleSelect = + Orthodox -- ^The \"orthodox\" oracle. + | Simple -- ^The \"simple\" oracle. + | Blackbox -- ^A blackbox oracle. + | Classical -- ^An oracle generated from classical program. + | Template -- ^An oracle automatically generated using Template Haskell. + | TemplateOptim -- ^An oracle automatically generated using Template Haskell, with peep-hole optimization. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + what :: WhatToShow, -- ^What kind of thing to output. + format :: Format, -- ^The output format. + gatebase :: GateBase, -- ^What kind of gates to decompose into. + oracle :: OracleSelect, -- ^Which kind of oracle to use. + n :: Int, -- ^The tree height. + c :: Int, -- ^The color to use with @--oracle@. + s :: Int, -- ^The parameter /s/ to use. + dt :: Timestep -- ^The parameter /dt/ to use. +} deriving Show + +-- | The default options. +defaultOptions :: Options +defaultOptions = Options + { what = Circuit, + format = Preview, + n = 5, + c = 0, + gatebase = Logical, + oracle = Orthodox, + s = 1, + dt = pi/180 + } + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = + [ Option ['h'] ["help"] (NoArg help) "print usage info and exit", + Option ['C'] ["circuit"] (NoArg (what Circuit)) "output the whole circuit (default)", + Option ['O'] ["oracle"] (NoArg (what Oracle)) "output only the oracle", + Option ['K'] ["oraclec"] (NoArg (what OracleC)) "output the \"classical\" oracle as a classical circuit", + Option ['G'] ["graph"] (NoArg (what Graph)) "print colored graph computed from oracle", + Option ['S'] ["simulate"] (NoArg (what Simulate)) "run simulations of some circuit fragments for tree height n", + Option ['f'] ["format"] (ReqArg format "") "output format for circuits (default: preview)", + Option ['g'] ["gatebase"] (ReqArg gatebase "") "type of gates to decompose into (default: logical)", + Option ['o'] [] (ReqArg oracle "") "select oracle to use (default: orthodox)", + Option ['n'] ["height"] (ReqArg height "") "set tree height (positive; default 5)", + Option ['c'] ["color"] (ReqArg color "") "color to use with --oracle (0..3, default 0)", + Option ['s'] ["repeats"] (ReqArg repeats "") "set parameter s (iteration count; default 1)", + Option ['l'] ["large"] (NoArg large) "set large problem size: n=300, s=336960", + Option ['t'] ["dt"] (ReqArg dt "
") "set parameter dt (simulation time step; default pi/180)" + ] + where + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + + height :: String -> Options -> IO Options + height string o = + case parse_int string of + Just n | n >= 1 -> return o { n = n } + _ -> optfail ("Invalid tree height -- " ++ string ++ "\n") + + color :: String -> Options -> IO Options + color string o = + case parse_int string of + Just c | c >= 0 && c < 4 -> return o { c = c } + _ -> optfail ("Invalid color -- " ++ string ++ "\n") + + repeats :: String -> Options -> IO Options + repeats string o = + case parse_int string of + Just s | s >= 0 -> return o { s = s } + _ -> optfail ("Invalid value for parameter s -- " ++ string ++ "\n") + + large :: Options -> IO Options + large o = return o { s = 336960, n = 300 } + + dt :: String -> Options -> IO Options + dt string o = + case parse_double string of + Just dt -> return o { dt = dt } + _ -> optfail ("Invalid value for parameter dt -- " ++ string ++ "\n") + + format :: String -> Options -> IO Options + format str o = do + case match_enum format_enum str of + [(_, f)] -> return o { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + gatebase :: String -> Options -> IO Options + gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + oracle :: String -> Options -> IO Options + oracle str o = do + case match_enum oracle_enum str of + [(_, f)] -> return o { oracle = f } + [] -> optfail ("Unknown oracle -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous oracle -- " ++ str ++ "\n") + + help :: Options -> IO Options + help o = do + usage + exitSuccess + + n_def = show (n defaultOptions) + c_def = show (c defaultOptions) + +-- | An enumeration of available oracles and their names. +oracle_enum :: [(String, OracleSelect)] +oracle_enum = [ + ("orthodox", Orthodox), + ("simple", Simple), + ("blackbox", Blackbox), + ("classical", Classical), + ("template", Template), + ("optimized", TemplateOptim) + ] + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to 'stdout'. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + putStr (show_enum "oracle" oracle_enum) + where header = "Usage: bwt [OPTION...]" + +-- ---------------------------------------------------------------------- +-- * The BWT main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO() +main = do + argv <- getArgs + options <- dopts argv + let oracle = oracle_of_options options + case options of + Options { what = Circuit, format = format, gatebase = gatebase, s = s, dt = dt } -> + BWT.main_circuit format gatebase oracle s dt + Options { what = Oracle, c = c, format = format, gatebase = gatebase } -> + BWT.main_oracle format gatebase oracle c + Options { what = OracleC, c = c, format = format } -> + Alternative.main_oraclec format oracle c + Options { what = Graph, format = ASCII, gatebase = gatebase } -> + Simulate.simulate_edges gatebase oracle + Options { what = Graph, format = format, oracle = Simple, gatebase = gatebase } -> do + -- special case: if Simple, change the node numbering + let doc = Simulate.render_oracle gatebase True oracle + print_of_document format doc + Options { what = Graph, format = format, gatebase = gatebase } -> do + let doc = Simulate.render_oracle gatebase False oracle + print_of_document format doc + Options { what = Simulate, n = n } -> do + Simulate.main_all n + +-- | Compute the appropriate 'Oracle' for the given options. +oracle_of_options :: Options -> BWT.Oracle + +oracle_of_options Options { oracle = Orthodox, n = n } = + BWT.oracle_orthodox f g + where + f = take n (True : False : f) + g = take n (False : True : g) + +oracle_of_options Options { oracle = Simple } = + Alternative.convert_oracle (Alternative.oracle_simple) + +oracle_of_options Options { oracle = Blackbox, n = n } = + Alternative.convert_oracle (Alternative.oracle_blackbox n) + +oracle_of_options Options { oracle = Classical, n = n } = + Alternative.convert_oracle (Alternative.oracle_classical f g) + where + f = take n (True : False : f) + g = take n (False : True : g) + +oracle_of_options Options { oracle = Template, n = n } = + Alternative.convert_oracle (Template.oracle_template f g) + where + f = take n (True : False : f) + g = take n (False : True : g) + +oracle_of_options Options { oracle = TemplateOptim, n = n } = + Alternative.convert_oracle (Template.oracle_template_optim f g) + where + f = take n (True : False : f) + g = take n (False : True : g) + diff --git a/Quipper/Algorithms/BWT/Simulate.hs b/Quipper/Algorithms/BWT/Simulate.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/BWT/Simulate.hs @@ -0,0 +1,598 @@ +-- | This module contains functions for simulating and debugging +-- BWT oracles. + +module Quipper.Algorithms.BWT.Simulate where + +import Quipper hiding (comment) + +import Quipper.Libraries.Qureg +import Quipper.Libraries.Simulation +import Quipper.Libraries.Decompose + +-- import other Quipper stuff +import Quipper.Algorithms.BWT.Definitions +import Quipper.Algorithms.BWT.BWT + +import Quipper.Utils.Sampling +import Quipper.Utils.Auxiliary + +-- import other stuff +import Graphics.EasyRender +import Text.Printf +import Data.Bits + +-- ====================================================================== +-- * Generic simulation + +-- | Inputs an oracle and prints out a list of colored edges in text +-- format. This is done by simulating the circuit for every possible +-- input, decomposed to the given 'GateBase'. +simulate_edges :: GateBase -> Oracle -> IO() +simulate_edges gb oracle = + mapM_ output (sample_all0 (2^m'-1, 3)) + where + m' = (m oracle) + ofun c (a, b, r) = do + let a_reg = qureg_of_qulist_te a + let b_reg = qureg_of_qulist_te b + (oraclefun oracle) c (a_reg, b_reg, r) + return (a, b, r) + + simulate :: (Int, Int) -> (Int, Bool) + simulate (c, a) = (b1, r1) where + + -- convert inputs to boollisttors + a_in = boollist_of_int_bh m' a + b_in = take m' $ repeat False + r_in = False + + (a_out, b_out, r_out) = run_classical_generic (decompose_generic gb (ofun c)) (a_in, b_in, r_in) + + -- convert outputs to integers + a1 = int_of_boollist_unsigned_bh a_out + b1 = int_of_boollist_unsigned_bh b_out + r1 = r_out + + output :: (Int, Int) -> IO() + output (a, c) = + case simulate (c, a) of + (b, False) -> printf "%d ---%d---> %d\n" a c b + (b, True) -> printf "%d ---%d---> None (%d)\n" a c b + +-- | Input an oracle and output the colored edges in graphical +-- format. This is done by simulating the circuit for every possible +-- input. The second parameter is a boolean which determines whether +-- the node numbering follows the schema of the orthodox oracle +-- ('True') or the simple oracle ('False'). +render_oracle :: GateBase -> Bool -> Oracle -> Document () +render_oracle gb node_style oracle = do + newpage (sc * width) (sc * height) $ do + scale sc sc + setlinewidth linewidth + sequence_ [ output a c | (a,c) <- sample_all0 (2^m'-1, 3) ] + setcolor (Color_Gray 0) + sequence_ [ label a | a <- sample_all0 (2^m'-1) ] + where + sc = 5.0 :: Double + labelfont = Font TimesRoman 0.8 + dotradius = 0.1 :: Double + linewidth = 0.04 :: Double + black = Color_Gray 0 + + m' = (m oracle) + n' = (n oracle) + nn = fromIntegral n' + ofun c (a, b, r) = do + let a_reg = qureg_of_qulist_te a + let b_reg = qureg_of_qulist_te b + (oraclefun oracle) c (a_reg, b_reg, r) + return (a, b, r) + + simulate :: (Int, Int) -> (Int, Bool) + simulate (c, a) = (b1, r1) where + + -- convert inputs to boollisttors + a_in = boollist_of_int_bh m' a + b_in = take m' $ repeat False + r_in = False + + (a_out, b_out, r_out) = run_classical_generic (decompose_generic gb (ofun c)) (a_in, b_in, r_in) + + -- convert outputs to integers + a1 = int_of_boollist_unsigned_bh a_out + b1 = int_of_boollist_unsigned_bh b_out + r1 = r_out + + width = 2.0^(n'+1) + height = (2.0*(nn)+4) * 2.0 + 2.0^n' + + -- coord: map a node id to a pair of coordinates + coord_simple :: Int -> (Double, Double) + coord_simple a = (x,y) where + t = (a .&. (2^(n'+1)) /= 0) -- tree bit + a' = a .&. (2^(n'+1)-1) -- node address + h = hibit a' -- logical height in subtree + w = a' .&. (2^(h-1)-1) -- logical position in row + hh = fromIntegral h + ww = fromIntegral w + h1 = 1 + 2 * hh -- physical height in subtree + y = if t then h1 else height - h1 + x = if h == 0 then 0.5 * width else (1+2*ww) * 2^(n'+1-h) + + -- coord_orthodox: same as coord, but use the layout of the orthodox oracle. + coord_orthodox :: Int -> (Double, Double) + coord_orthodox a | a >= 2^(n'+1) = (width - x,y) where + (x,y) = coord_simple (2^(n'+2)+2^(n'+1)-1-a) + coord_orthodox a = coord_simple a -- for the upper subtree, no difference + + coord :: Int -> (Double, Double) + coord = if node_style then coord_orthodox else coord_simple + + color :: Int -> Color + color 0 = Color_RGB 1 0 0 + color 1 = Color_RGB 0 1 0 + color 2 = Color_RGB 0 0 1 + color 3 = Color_RGB 1 1 0 + color n = error ("render_oracle: unknown color: " ++ show n) + + output :: Int -> Int -> Draw () + output a c = + case simulate (c, a) of + (b, False) -> do + comment (printf "%d ---%d---> %d" a c b) + moveto x0 y0 + lineto x2 y2 + setcolor (color c) + stroke + where + (x0,y0) = coord a + (x1,y1) = coord b + (x2,y2) = ((x0+x1)/2, (y0+y1)/2) + (b, True) -> do + comment (printf "%d ---%d---> None (%d)" a c b) + + label :: Int -> Draw () + label a = do + render_dot x y + textbox align_left labelfont black (x+0.1) y (x+1.9) y 0 (show a) + where + (x,y) = coord a + + render_dot :: X -> Y -> Draw () + render_dot x y = do + arc x y dotradius 0 360 + fill black + +-- ====================================================================== +-- * Testing of specific circuit fragments + +-- | Simulate 'parseNodeRoot' on all possible inputs for tree height /n/. +simulate_parseNodeRoot :: Int -> IO() +simulate_parseNodeRoot n = mapM_ output (sample_all0 (4*nn-1, True, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Bool,Bool) -> IO() + output (a, root, even) = + let + as = boollist_of_int_bh (n+2) a + (as',root',even') = run_classical_generic (runfun n) (as, root, even) + + runfun :: Int -> (Qulist,Qubit,Qubit) -> Circ (Qulist,Qubit,Qubit) + runfun n (as, root, even) = do + parseNodeRoot (qureg_of_qulist_te as, root, even, n) + return (as, root, even) + a' = int_of_boollist_unsigned_bh as' :: Integer + d_root = root `bool_xor` root' + d_even = even `bool_xor` even' + in do + printf "(a=%d, root=%s, even=%s) -> (a=%d, root=%s, even=%s)\n" a (show root) (show even) a' (show root') (show even') + if (a /= a' || d_root /= d_even) + then + error "Test failed (1)" + else if (d_root /= ((a .&. (2*nn-1)) <= 1)) then + error "Test failed (2)" + else + return () + +-- | Simulate 'parseNodeEven' on all possible inputs for tree height /n/. +simulate_parseNodeEven :: Int -> IO() +simulate_parseNodeEven n = mapM_ output (sample_all0 (4*nn-1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Bool) -> IO() + output (a, even) = + let + as = boollist_of_int_bh (n+2) a + (as',even') = run_classical_generic (runfun n) (as, even) + + runfun :: Int -> (Qulist,Qubit) -> Circ (Qulist,Qubit) + runfun n (as, even) = do + parseNodeEven (qureg_of_qulist_te as, even, n) + return (as, even) + a' = int_of_boollist_unsigned_bh as' :: Integer + d_even = even `bool_xor` even' + in do + printf "(a=%d, even=%s) -> (a=%d, even=%s)\n" a (show even) a' (show even') + if (a /= a') + then + error "Test failed (3)" + else if ((a .&. (2*nn-1)) <= 1) then + if (d_even) then + error "Test failed (4)" + else + return () + else if (d_even /= not (Prelude.even (hibit (a .&. (2*nn-1))))) then + error "Test failed (5)" + else + return () + +-- | Simulate 'testIsParent' on all possible inputs for tree height /n/. +simulate_testIsParent :: Int -> IO() +simulate_testIsParent n = mapM_ output (sample_all0 (1, True, True, True, 3, 1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer, Bool, Bool, Bool, Integer, Int, Bool) -> IO() + output (a, root, even, isparent, color, really, ismatch) = + let + as = boollist_of_int_bh 1 a + cs = boollist_of_int_bh 2 color + (as', root', even', isparent', ismatch') = run_classical_generic (runfun n cs really) (as, root, even, isparent, ismatch) + + runfun :: Int -> Boollist -> Int -> (Qulist,Qubit,Qubit,Qubit,Qubit) -> Circ (Qulist,Qubit,Qubit,Qubit,Qubit) + runfun n cs rs (as, root, even, isparent, ismatch) = do + testIsParent (qureg_of_qulist_te as, root, even, isparent, boolreg_of_boollist_te cs, n, really, ismatch) + return (as, root, even, isparent, ismatch) + + a' = int_of_boollist_unsigned_bh as' :: Integer + d_root = root `bool_xor` root' + d_even = even `bool_xor` even' + d_isparent = isparent `bool_xor` isparent' + d_ismatch = ismatch `bool_xor` ismatch' + in do + printf "(a=%d, root=%s, even=%s, isparent=%s, color=%d, really=%d, ismatch=%s) -> (a=%d, root=%s, even=%s, isparent=%s, ismatch=%s)\n" a (show root) (show even) (show isparent) color really (show ismatch) a' (show root') (show even') (show isparent') (show ismatch') + if (a /= a' || root /= root' || even /= even') + then + error "Test failed (6)" + else if (root == True && even == True) then + if d_isparent == False then + return () + else + error "Test failed (7)" + else if really == 1 && ismatch == False then + if d_isparent /= (color == (a .&. 1) .|. (if even then 2 else 0)) then + error "Test failed (8)" + else if d_ismatch /= (d_isparent && even) then + error "Test failed (9)" + else + return () + else -- really == 0 -- we don't write more test cases because the algorithm is so convoluted. + return () + +-- | Simulate 'testIsChild' on all possible inputs for tree height /n/. +simulate_testIsChild :: Int -> IO() +simulate_testIsChild n = mapM_ output (sample_all0 (True, True, True, 3)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Bool, Bool, Bool, Integer) -> IO() + output (even, ischild, direction, color) = + let + cs = boollist_of_int_bh 2 color + (even', ischild', direction') = run_classical_generic (runfun cs n) (even, ischild, direction) + + runfun :: Boollist -> Int -> (Qubit,Qubit,Qubit) -> Circ (Qubit,Qubit,Qubit) + runfun cs n (even, ischild, direction) = do + testIsChild (even, ischild, direction, boolreg_of_boollist_te cs, n) + return (even, ischild, direction) + d_ischild = ischild `bool_xor` ischild' + d_direction = direction `bool_xor` direction' + in do + printf "(even=%s, ischild=%s, direction=%s, color=%d) -> (even=%s, ischild=%s, direction=%s)\n" (show even) (show ischild) (show direction) color (show even') (show ischild') (show direction') + if (even /= even' || d_direction == (Prelude.even color)) + then + error "Test failed (10)" + else if even && (d_ischild /= (color <= 1)) then + error "Test failed (11)" + else if not even && (d_ischild /= (color >= 2)) then + error "Test failed (12)" + else + return () + +-- | Simulate 'setParent' on all possible inputs for tree height /n/. +simulate_setParent :: Int -> IO() +simulate_setParent n = mapM_ output (sample_all0 (4*nn-1, 4*nn-1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Integer,Bool) -> IO() + output (a,b,isparent) = + let + as = boollist_of_int_bh (n+2) a + bs = boollist_of_int_bh (n+2) b + (as',bs',isparent') = run_classical_generic (runfun n) (as, bs, isparent) + + runfun :: Int -> (Qulist,Qulist,Qubit) -> Circ (Qulist,Qulist,Qubit) + runfun n (as, bs, isparent) = do + setParent (qureg_of_qulist_te as, qureg_of_qulist_te bs, isparent, n) + return (as, bs, isparent) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + db = b `xor` b' + in do + printf "(a=%d, b=%d) -> (a=%d, b=%d) (db=%d) isparent=%s\n" a b a' b' db (show isparent) + if (a /= a' || isparent /= isparent') + then + error "Test failed (13)" + else if (isparent == False) then + if (b /= b') then + error "Test failed (14)" + else + return () + else if db /= ((a `div` 2) .&. (nn-1)) .|. (a .&. (2*nn)) then + error "Test failed (15)" + else + return () + +-- | Simulate 'setChild' on all possible inputs for tree height /n/. +simulate_setChild :: Int -> IO() +simulate_setChild n = mapM_ output (sample_all0 (4*nn-1, 4*nn-1, nn-1, nn-1, True, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Integer,Integer,Integer,Bool,Bool) -> IO() + output (a,b,f,g,ischild,direction) = + let + as = boollist_of_int_bh (n+2) a + bs = boollist_of_int_bh (n+2) b + fs = boollist_of_int_bh n f + gs = boollist_of_int_bh n g + (as',bs',ischild',direction') = run_classical_generic (runfun n fs gs) (as, bs, ischild, direction) + + runfun :: Int -> Boollist -> Boollist -> (Qulist,Qulist,Qubit,Qubit) -> Circ (Qulist,Qulist,Qubit,Qubit) + runfun n f g (as, bs, ischild, direction) = do + setChild (qureg_of_qulist_te as, qureg_of_qulist_te bs, ischild, direction, boolreg_of_boollist_te f, boolreg_of_boollist_te g, n) + return (as, bs, ischild, direction) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + db = b `xor` b' + in do + printf "(a=%d, b=%d, f=%d, g=%d) -> (a=%d, b=%d) (db=%d) ischild=%s direction=%s\n" a b f g a' b' db (show ischild) (show direction) + if (a /= a' || ischild /= ischild' || direction /= direction') + then + error "Test failed (16)" + else if (ischild == False) then + if (b /= b') then + error "Test failed (17)" + else + return () + else if a .&. nn /= 0 then + if direction == False && db /= (a `xor` f `xor` 2*nn) .|. nn then + error "Test failed (18)" + else if direction == True && a .&. (2*nn) /= 0 && db /= ((a - g) .&. (2*nn-1)) .|. nn then + error "Test failed (19)" + else if direction == True && a .&. (2*nn) == 0 && db /= (((a + g) .&. (2*nn-1)) .|. (2*nn) .|. nn) then + error "Test failed (20)" + else + return () + else + if db /= ((2*a) .&. (2*nn-1)) .|. (a .&. (2*nn)) .|. (if direction then 1 else 0) then + error "Test failed (21)" + else + return () + +-- | Simulate 'setChildInTree' on all possible inputs for tree height /n/. +simulate_setChildInTree :: Int -> IO() +simulate_setChildInTree n = mapM_ output (sample_all0 (4*nn-1, 4*nn-1, True, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Integer,Bool,Bool) -> IO() + output (a,b,childctrl,direction) = + let + as = boollist_of_int_bh (n+2) a + bs = boollist_of_int_bh (n+2) b + (as',bs',childctrl',direction') = run_classical_generic (runfun n) (as, bs, childctrl, direction) + + runfun :: Int -> (Qulist,Qulist,Qubit,Qubit) -> Circ (Qulist,Qulist,Qubit,Qubit) + runfun n (as, bs, childctrl, direction) = do + setChildInTree (qureg_of_qulist_te as, qureg_of_qulist_te bs, childctrl, direction, n) + return (as, bs, childctrl, direction) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + db = b `xor` b' + in do + printf "(a=%d, b=%d) -> (a=%d, b=%d) (db=%d) childctrl=%s direction=%s\n" a b a' b' db (show childctrl) (show direction) + if (a /= a' || childctrl /= childctrl' || direction /= direction') + then + error "Test failed (22)" + else if (childctrl == False) then + if (b /= b') then + error "Test failed (23)" + else + return () + else if db /= ((2*a) .&. (2*nn-1)) .|. (a .&. (2*nn)) .|. (if direction then 1 else 0) then + error "Test failed (24)" + else + return () + +-- | Simulate 'setWeld' on all possible inputs for tree height /n/. +simulate_setWeld :: Int -> IO() +simulate_setWeld n = mapM_ output (sample_all0 (4*nn-1, 4*nn-1, nn-1, nn-1, True, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Integer,Integer,Integer,Bool,Bool) -> IO() + output (a,b,f,g,childctrl,direction) = + let + as = boollist_of_int_bh (n+2) a + bs = boollist_of_int_bh (n+2) b + fs = boollist_of_int_bh n f + gs = boollist_of_int_bh n g + (as',bs',childctrl',direction') = run_classical_generic (runfun n fs gs) (as, bs, childctrl, direction) + + runfun :: Int -> Boollist -> Boollist -> (Qulist,Qulist,Qubit,Qubit) -> Circ (Qulist,Qulist,Qubit,Qubit) + runfun n f g (as, bs, childctrl, direction) = do + setWeld (qureg_of_qulist_te as, qureg_of_qulist_te bs, childctrl, direction, boolreg_of_boollist_te f, boolreg_of_boollist_te g, n) + return (as, bs, childctrl, direction) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + db = b `xor` b' + in do + printf "(a=%d, b=%d, f=%d, g=%d) -> (a=%d, b=%d) (db=%d) childctrl=%s direction=%s\n" a b f g a' b' db (show childctrl) (show direction) + if (a /= a' || childctrl /= childctrl' || direction /= direction') + then + error "Test failed (25)" + else if (childctrl == False) then + if (b /= b') then + error "Test failed (26)" + else + return () + else if direction == False && db /= (a `xor` f `xor` 2*nn) .|. nn then + error "Test failed (27)" + else if direction == True && a .&. (2*nn) /= 0 && db /= ((a - g) .&. (2*nn-1)) .|. nn then + error "Test failed (28)" + else if direction == True && a .&. (2*nn) == 0 && db /= (((a + g) .&. (2*nn-1)) .|. (2*nn) .|. nn) then + error "Test failed (29)" + else + return () + +-- | Simulate 'doWeld1' on all possible inputs for tree height /n/. +simulate_doWeld1 :: Int -> IO() +simulate_doWeld1 n = mapM_ output (sample_all0 (4*nn-1, 4*nn-1, nn-1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer, Integer, Integer, Bool) -> IO() + output (a,b,c,control) = + let + as = boollist_of_int_bh (n+2) a + bs = boollist_of_int_bh (n+2) b + cs = boollist_of_int_bh n c + (control', bs', as') = run_classical_generic (runfun n cs) (control, bs, as) + + runfun :: Int -> Boollist -> (Qubit, Qulist, Qulist) -> Circ (Qubit, Qulist, Qulist) + runfun n c (control, b, a) = do + doWeld1 (qureg_of_qulist_te a, qureg_of_qulist_te b, control, boolreg_of_boollist_te c, n) + return (control, b, a) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + in do + printf "(%d, %d, %d) -> (%d, %d) %s %s\n" a b c a' b' (show control) (show control') + if (control && a .&. (2*nn) /= 0 && a' == a && b' == (((a-c) .&. (nn-1)) `xor` b) && control' == control) + || (control && a .&. (2*nn) == 0 && a' == a && b' == (((a+c) .&. (nn-1)) `xor` b) && control' == control) + || (not control && a' == a && b' == b && control' == control) + then + return () -- assertion succeeds + else + error "Test failed (30)" + +-- | Simulate 'doWeld0' on all possible inputs for tree height /n/. +simulate_doWeld0 :: Int -> IO() +simulate_doWeld0 n = mapM_ output (sample_all0 (2*nn-1, 2*nn-1, nn-1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer, Integer, Integer, Bool) -> IO() + output (a,b,c,control) = + let + as = boollist_of_int_bh (n+1) a + bs = boollist_of_int_bh (n+1) b + cs = boollist_of_int_bh n c + (control', bs', as') = run_classical_generic (runfun n cs) (control, bs, as) + + runfun :: Int -> Boollist -> (Qubit, Qulist, Qulist) -> Circ (Qubit, Qulist, Qulist) + runfun n c (control, b, a) = do + doWeld0 (qureg_of_qulist_te a, qureg_of_qulist_te b, control, boolreg_of_boollist_te c, n) + return (control, b, a) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + in do + printf "(%d, %d, %d) -> (%d, %d) %s %s\n" a b c a' b' (show control) (show control') + if (control && a' == a && b' == (((a `xor` c) .&. (nn-1)) `xor` b) && control' == control) + || (not control && a' == a && b' == b && control' == control) + then + return () -- assertion succeeds + else + error "Test failed (31)" + +-- | Simulate 'cAddNum' (including 'cAddNumClear') on all possible inputs for tree height /n/. +simulate_cAddNum :: Int -> IO() +simulate_cAddNum n = mapM_ output (sample_all0 (nn-1, nn-1, nn-1, True)) + where + nn = 2^(toInteger n) :: Integer + output :: (Integer, Integer, Integer, Bool) -> IO() + output (a,b,c,control) = + let + as = boollist_of_int_bh n a + bs = boollist_of_int_bh n b + cs = boollist_of_int_bh n c + (control', bs', as') = run_classical_generic (runfun n cs) (control, bs, as) + + runfun :: Int -> Boollist -> (Qubit, Qulist, Qulist) -> Circ (Qubit, Qulist, Qulist) + runfun n c (control, b, a) = do + cAddNum (control, qureg_of_qulist_te b, qureg_of_qulist_te a, boolreg_of_boollist_te c, n) + return (control, b, a) + a' = int_of_boollist_unsigned_bh as' + b' = int_of_boollist_unsigned_bh bs' + in do + printf "(%d, %d, %d) -> (%d, %d) %s %s\n" a b c a' b' (show control) (show control') + if (control && a' == a && b' == (((a+c) `mod` (2^n)) `xor` b) && control' == control) + || (not control && a' == a && b' == b && control' == control) + then + return () -- assertion succeeds + else + error "Test failed (32)" + +-- | Simulate 'cSubNum' (including 'cSubNumClear') on all possible inputs for tree height /n/. +simulate_cSubNum :: Int -> IO() +simulate_cSubNum n = mapM_ output (sample_all0 (nn-1, nn-1, nn-1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer, Integer, Integer, Bool) -> IO() + output (a,b,c,control) = + let + as = boollist_of_int_bh n a + bs = boollist_of_int_bh n b + cs = boollist_of_int_bh n c + (control', bs', as') = run_classical_generic (runfun n cs) (control, bs, as) + + runfun :: Int -> Boollist -> (Qubit, Qulist, Qulist) -> Circ (Qubit, Qulist, Qulist) + runfun n c (control, b, a) = do + cSubNum (control, qureg_of_qulist_te b, qureg_of_qulist_te a, boolreg_of_boollist_te c, n) + return (control, b, a) + a' = int_of_boollist_unsigned_bh as' + b' = int_of_boollist_unsigned_bh bs' + in do + printf "(%d, %d, %d) -> (%d, %d) %s %s\n" a b c a' b' (show control) (show control') + if (control && a' == a && b' == (((a-c) `mod` nn) `xor` b) && control' == control) + || (not control && a' == a && b' == b && control' == control) + then + return () -- assertion succeeds + else + error "Test failed (33)" + +-- ====================================================================== +-- * Auxiliary functions + +-- | Return the smallest number of bits required to hold the given integer. +hibit :: Integral a => Integral b => a -> b +hibit n = + if n <= 0 then + 0 + else + 1 + hibit (n `div` 2) + +-- ====================================================================== +-- * Main functions + +-- | Run simulations of 'parseNodeRoot', 'parseNodeEven', +-- 'testIsParent', 'testIsChild', 'setParent', 'setChild', +-- 'setChildInTree', 'setWeld', 'doWeld0', 'doWeld1', 'cAddNum', and +-- 'cSubNum' for tree height /n/. +main_all :: Int -> IO() +main_all n = do + simulate_parseNodeRoot n + simulate_parseNodeEven n + simulate_testIsParent n + simulate_testIsChild n + simulate_setParent n + simulate_setChild n + simulate_setChildInTree n + simulate_setWeld n + simulate_doWeld0 n + simulate_doWeld1 n + simulate_cAddNum n + simulate_cSubNum n diff --git a/Quipper/Algorithms/BWT/Template.hs b/Quipper/Algorithms/BWT/Template.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/BWT/Template.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | The BWT Oracle, written in a classical, functional manner and +-- automatically transformed to a quantum circuit using Quipper's +-- \"build_circuit\" mechanism. +module Quipper.Algorithms.BWT.Template where + +import Quipper + +import Control.Monad (sequence) +import Quipper.Algorithms.BWT.Alternative (Oracle(..), Node, QNode) + +import Quipper.Utils.Auxiliary hiding (boollist_xor) +import Quipper.Libraries.ClassicalOptim + +-- ---------------------------------------------------------------------- +-- * Circuit building functions + +-- $BUILDING +-- +-- This section contains an implementation of the oracle as a +-- collection of ordinary functional programs. Each function in this +-- section is decorated with the @build_circuit@ keyword (see +-- "Quipper.Internal.CircLifting#build_circuit"). Therefore, circuits are +-- automatically generated; for example, the circuit corresponding to +-- the function 'v_function' is automatically built and given the name +-- 'template_v_function'. + +---------------------------------------------------------------------- +-- ** General operations on booleans + +-- | Exclusive /or/ operation on bit vectors. +build_circuit +boollist_xor :: [Bool] -> [Bool] -> [Bool] +boollist_xor x y = zipWith bool_xor x y + + +-- | 'bit_adder' 'False' is a one-bit adder, and 'bit_adder' 'True' is a +-- one-bit subtracter (i.e., add the 2's complement of /y/). +build_circuit +bit_adder :: Bool -> (Bool,Bool,Bool) -> (Bool,Bool) +bit_adder sign (carry, x,y) = + let majority a b c = + if (a `bool_xor` b) then c else a in + let y' = y `bool_xor` sign in + let z = carry `bool_xor` x `bool_xor` y' in + let carry' = majority carry x y' in + (carry', z) + + +---------------------------------------------------------------------- +-- ** Encoding the BWT oracle on booleans and lists of booleans + +-- | Input a node /a/ and return the parent of /a/. We assume that /a/ +-- is not a root or invalid. +build_circuit +parent :: Node -> Node +parent (x,y) = (x, False:(init y)) + +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True', +-- respectively). Assumes that /a/ is not a leaf. +build_circuit +childintree :: Node -> Bool -> Node +childintree (t,l) c = + case l of + [] -> error "childintree" + h:aa -> (t, aa ++ [c]) + + +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit; /a/ +-- is the highest bit and /aa/ is the remaining /n/ bits) and a sign +-- /s/ (where 'True' = negative, 'False' = positive). Return +-- /a/:(/aa/ + /s/ * /f/). The first input is the /n/-bit welding +-- vector /f/ (a parameter to the oracle). Note that /f/ is a +-- parameter and /s/, /aa/ are inputs. +build_circuit +doweld1 :: Boollist -> Bool -> [Bool] -> [Bool] +doweld1 f s l = + case l of + [] -> error "doweld1" + a:aa -> a : (snd (fold_right_zip (bit_adder s) (s, aa, f))) + + +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit), and +-- return /a/:(/aa/ ⊕ /g/). The first input is the /n/-bit welding +-- vector /g/ (a parameter to the oracle). +build_circuit +doweld0 :: Boollist -> [Bool] -> [Bool] +doweld0 g l = + case l of + [] -> error "doweld0" + a:aa -> a : (g `boollist_xor` aa) + + +-- | Input a leaf node /a/ and return the left or right weld of /a/ in +-- the other tree (depending on whether the /weldbit/ is 'False' or +-- 'True'). Assumes that /a/ is a leaf. +build_circuit +weld :: Boollist -> Boollist -> Node -> Bool -> Node +weld f g (t,aa) weldBit = + if weldBit then (not t, doweld1 g t aa) + else (not t, doweld0 f aa) + + +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True'. This +-- works for leaf and non-leaf nodes. +build_circuit +child :: Boollist -> Boollist -> Node -> Bool -> Node +child f g (t,aa) childBit = + case aa of + [] -> error "child" + h:tt -> if h then weld f g (t, aa) childBit + else childintree (t, aa) childBit + + +-- | Input a node address (without the tree bit) and return the parity +-- of the node level expressed as a boolean either 'False' or +-- 'True'. Leaves have parity 'False', and other levels have +-- alternating parities. In other words: count the number of leading +-- zeros modulo 2. +build_circuit +level_parity :: [Bool] -> Bool +level_parity l = foldl (\a b -> not (a || b)) False (reverse l) + + +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node address is invalid. In other words, return 'True' iff the +-- list consists of all 0's. +build_circuit +is_zero :: [Bool] -> Bool +is_zero l = foldl (\a b -> a && (not b)) True l + + +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node is a root or invalid. In other words, check whether all +-- digits but the last are 0's. +build_circuit +is_root :: [Bool] -> Bool +is_root l = case (reverse l) of + [] -> True + (h:t) -> is_zero t + + + +-- | @'v_function' f g c a@: returns /v/[sub /c/](/a/), the label of the +-- node connected to /a/ by an edge of color /c/, or 'Nothing' if +-- there is no such node. The parameters /f/ and /g/ encode the +-- welding functions, and are lists of length /n/. /c/ is a color in +-- the range 0..3, and /a/ is an (/n/+2)-bit node label. +build_circuit +v_function :: BoolParam -- ^First color bit. + -> BoolParam -- ^Second color bit. + -> Boollist -- ^Vector /f/ from Equation (26). + -> Boollist -- ^Vector /g/ from Equation (27). + -> Node -- ^Entry node /a/. + -> (Bool,Node) -- ^('True', exit node) or ('False', garbage). +v_function c_hi c_lo f g a = + let aa = snd a in + let cbc_hi = newBool c_hi `bool_xor` level_parity aa in + let cbc_lo = newBool c_lo in + if (not (is_root aa) && cbc_hi && not (cbc_lo `bool_xor` (last aa))) then + (False, parent a) + else + let res = child f g a cbc_lo in + (is_zero aa || cbc_hi, res) + +-- ---------------------------------------------------------------------- +-- * Wrapping it into the Oracle data type + +-- $PACKAGE The following functions package the circuit generated by +-- 'v_function' into a data structure of type 'Oracle'. + +-- ---------------------------------------------------------------------- +-- ** Colors + +-- | A color is a number between 0 and 3. +type Color = Int + +-- | Convert an integer representation of a color into the two-bit representation. +colorToBoolParam :: Color -> (BoolParam,BoolParam) +colorToBoolParam 0 = (PFalse,PFalse) +colorToBoolParam 1 = (PFalse,PTrue) +colorToBoolParam 2 = (PTrue,PFalse) +colorToBoolParam 3 = (PTrue,PTrue) +colorToBoolParam _ = error "color out of range" + +-- ---------------------------------------------------------------------- +-- ** Functions for using the generated oracle + +-- | This is the /irreversible/ classical circuit generated from +-- 'v_function'. This is basically the same as 'template_v_function', +-- except that excessive uses of 'Circ' are removed from the type, and +-- the inputs and outputs have been reorganized. +classical_BWT_oracle :: Color -- ^ The color. + -> ([Qubit],[Qubit], QNode) -- ^ The two welding vectors and a node /a/. + -> Circ (Qubit, QNode) -- ^ Output /(r,b)/. +classical_BWT_oracle col (f,g,xs) = + unpack template_v_function b1 b2 f g xs + where + (b1,b2) = colorToBoolParam col + +-- | This is the /reversible/ circuit automatically generated from 'classical_BWT_oracle'. +reversible_BWT_oracle :: + Color -- ^ Color. + -> (([Qubit], [Qubit], QNode), (Qubit, QNode)) -- ^ /(f, g, a, r, b)/. + -> Circ (([Qubit], [Qubit], QNode), (Qubit, QNode)) -- ^ Output /(f, g, a, r, b)/. +reversible_BWT_oracle color ((f, g, a), (r, b)) = do + comment_with_label "ENTER: reversible_BWT_oracle" ((f, g, a), (r, b)) (("f", "g", "a"), ("r", "b")) + ((f, g, a), (r, b)) <- classical_to_reversible (classical_BWT_oracle color) ((f, g, a), (r, b)) + comment_with_label "EXIT: reversible_BWT_oracle" ((f, g, a), (r, b)) (("f", "g", "a"), ("r", "b")) + return ((f, g, a), (r, b)) + +-- | This is the /reversible/ circuit automatically generated from 'classical_BWT_oracle', and optimized with peep-hole optimization. +reversible_BWT_oracle_optim :: + Color -- ^ Color. + -> (([Qubit], [Qubit], QNode), (Qubit, QNode)) -- ^ /(f, g, a, r, b)/. + -> Circ (([Qubit], [Qubit], QNode), (Qubit, QNode)) -- ^ Output /(f, g, a, r, b)/. +reversible_BWT_oracle_optim color ((f, g, a), (r, b)) = do + comment_with_label "ENTER: reversible_BWT_oracle" ((f, g, a), (r, b)) (("f", "g", "a"), ("r", "b")) + ((f, g, a), (r, b)) <- classical_to_reversible_optim (classical_BWT_oracle color) ((f, g, a), (r, b)) + comment_with_label "EXIT: reversible_BWT_oracle" ((f, g, a), (r, b)) (("f", "g", "a"), ("r", "b")) + return ((f, g, a), (r, b)) + + +-- | The template oracle, packaged into the 'Oracle' abstraction. Note +-- that this circuit is automatically generated from the classical +-- functions above, but is completely unoptimized. This oracle has two +-- parameters, namely the welding vectors /f/ and /g/. +oracle_template :: [Bool] -> [Bool] -> Oracle +oracle_template f g = + Oracle { + n = n, + m = m, + k = 4, + entrance = boollist_of_int_bh m 1, + oraclefun = \c (as,bs,r) -> do qf <- qinit f + qg <- qinit g + let (a:aa) = as + let (b:bb) = bs + reversible_BWT_oracle c ((qf, qg, (a,aa)), (r, (b,bb))) + qterm g qg + qterm f qf + } + where n = length f + m = n+2 + + +-- | The template oracle, optimized. +oracle_template_optim :: [Bool] -> [Bool] -> Oracle +oracle_template_optim f g = + Oracle { + n = n, + m = m, + k = 4, + entrance = boollist_of_int_bh m 1, + oraclefun = \c (as,bs,r) -> do qf <- qinit f + qg <- qinit g + let (a:aa) = as + let (b:bb) = bs + reversible_BWT_oracle_optim c ((qf, qg, (a,aa)), (r, (b,bb))) + qterm g qg + qterm f qf + } + where n = length f + m = n+2 + diff --git a/Quipper/Algorithms/CL/Auxiliary.hs b/Quipper/Algorithms/CL/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/CL/Auxiliary.hs @@ -0,0 +1,482 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | This module defines general-purpose functions not specific to the Class Number algorithm, but required by it. + +module Quipper.Algorithms.CL.Auxiliary where + +import Quipper +import Quipper.Libraries.Arith hiding (q_ext_euclid, q_add, q_mult, q_div_exact, + q_add_in_place, q_add_param_in_place, q_div, + q_mult_param, q_mod_unsigned, q_sub_in_place, + q_increment) +import qualified Quipper.Libraries.Arith as Arith +import Quipper.Libraries.FPReal + +-- Needed to define boxed arithmetic functions: +import Quipper.Internal + +import Data.Maybe +import Control.Monad + +-- ====================================================================== +-- * Classical functions + +-- ====================================================================== +-- ** Control + +-- | Assert that a condition is true, otherwise throwing an error with a given +-- error message, in a functional setting. +assert :: Bool -> String -> a -> a +assert condition error_message x = if condition then x else error error_message + +-- | Assert a condition, imperatively in a monad. +assertM :: (Monad m) => Bool -> String -> m () +assertM b errorstring = if b then return () else error errorstring + +-- | Given a list of monadic actions and a predicate on their results, +-- do the actions in sequence until one produces a result satisfying +-- the predicate; return this result. +sequence_until :: (Monad m) => (a -> Bool) -> [m a] -> m (Maybe a) +sequence_until _ [] = return Nothing +sequence_until p (m0:ms) = do + a0 <- m0 + if p a0 then return (Just a0) else sequence_until p ms + +-- | Test whether elements of a list are all equal +all_eq :: (Eq a) => [a] -> Bool +all_eq [] = True +all_eq [a] = True +all_eq (a:b:rest) = (a == b) && all_eq (b:rest) + +-- | Apply a function to data while condition holds true. For example: +-- +-- > while (not . isReduced . fst) rho ideal +-- +-- will apply the function /rho/ to an ideal-with-distance while it is +-- not yet reduced (until it is reduced). +while :: (a -> Bool) -> (a -> a) -> a -> a +while cond func x = if (cond x) then while cond func (func x) else x + +-- | Like 'while', but with a known bound on number of iterations. This +-- construct can be converted to a quantum circuit, while a general unbounded +-- 'while' cannot be lifted. +bounded_while :: (Integral int) => (a -> Bool) -> int -> (a -> a) -> a -> a +bounded_while cond bound func x + | bound < 0 = error "bounded_while: negative bound" + | bound == 0 && (not $ cond x) = x + | bound == 0 = error "bounded_while: last iteration doesn't satisfy condition" + | otherwise = + bounded_while cond (bound-1) func x' + where x' = if (cond x) then func x else x + +-- | A bounded version of Haskell 'iterate' function that produces an infinite +-- list. This function produces a finite bounded list. +bounded_iterate :: (Integral int) => int -> (a -> a) -> a -> [a] +bounded_iterate bound func x + | bound < 0 = error "negative bound in bounded_iterate" + | bound == 0 = [x] + | otherwise = + x : bounded_iterate (bound-1) (func) (func x) + +-- =========================================== +-- ** Mathematical functions + +-- | Generate primes using the Sieve of Eratosthenes. Straightforward +-- implementation - when a prime is found, filter all of its multiples +-- out of the already filtered list. This implementation may eventually blow +-- out of stack, but it should grow with the number of primes, which seems +-- to be O(log log n). +primes :: (Integral a) => [a] +primes = primesn (2 : [ k*2+1 | k <- [1..] ]) + where primesn (n:xs) = + n : (primesn (filter (\k -> k `mod` n /= 0) xs)) + primesn [] = undefined -- keep the compiler happy + +-- | Generate primes up to a given number. See implementation of 'primes' for +-- details. +primes_to :: (Integral a) => a -> [a] +primes_to k = takeWhile (<= k) primes + +-- | Check if a number is square-free (by brute force). +is_square_free :: (Integral a) => a -> Bool +is_square_free n = + (n /= 0) && + (not $ any (\p -> (p*p) `divides` n) $ takeWhile (\x -> x^2 <= (abs n)) [2..]) + +-- | Compute the Jacobi symbol. The definition and algorithm description is +-- taken from . +jacobi_symbol :: (Integral a, Num b) => a -> a -> b +jacobi_symbol a p = + jacobi_symbol' a p + where + -- The actual implementation of the algorithm. Splitted away to allow + -- logging. + jacobi_symbol' a p + | a == 0 = 0 + | a == 1 = 1 -- Rule 4 + | a == 2 = if (p `mod` 8 == 1 || p `mod` 8 == 7) then 1 else -1 -- Rule 8 + | a >= p = jacobi_symbol (a `mod` p) p -- Rule 2 + | 2 `divides` a = (jacobi_symbol (a `div` 2) p) * (jacobi_symbol 2 p) -- Rule 4 + | otherwise = (if p `mod` 4 == 3 && a `mod` 4 == 3 then -1 else 1) -- Rule 6 + * (jacobi_symbol p a) + +-- | @'mod_with_max' /x/ /y/ /max/@: reduce /x/ modulo /y/, returning the unique representative /x'/ in the range /max/ – /y/ < /x'/ ≤ /max/. +mod_with_max :: (Integral a) => a -> a -> a -> a +mod_with_max x y max = max - ((max - x) `mod` y) + +-- | Integer division with asserts making sure that the denominator +-- indeed divides the numerator. +divchk :: (Show a, Integral a) => a -> a -> a +divchk nom denom = + if (nom `mod` denom == 0) + then nom `div` denom + else error ("divchk: " ++ show denom ++ " does not divide " ++ show nom ++ "!") + +-- | @'extended_euclid' /a/ /b/@: return (/d/,/x/,/y/), +-- such that /d/ = gcd(/a/,/b/), and /ax/ + /by/ = /d/. +extended_euclid :: Integral a => a -> a -> (a, a, a) +extended_euclid a b = + if (b == 0) then (a, 1, 0) else (d, x, y) + where + (d', x', y') = extended_euclid b (a `mod` b) + (d, x, y ) = (d', y', x' - (a `div` b)*y') + +-- | @/a/ `divides` /b/@: return 'True' if /a/ divides /b/. +divides :: (Integral a) => a -> a -> Bool +divides denom nom = (nom `mod` denom == 0) + +-- | Test whether a real number is an integer. +is_int :: (RealFrac a, Eq a) => a -> Bool +is_int x = x == (fromIntegral $ round x) + +-- | Generate the list of integers describing the continued fraction of a given +-- rational number. Since the number is rational, the expansion is finite. +-- +-- Each rational number /q/ is equal to a unique expression of the form +-- +-- > [image contfrac.png] +-- +-- where /n/ ≥ 0, /a/[sub 0] is an integer, /a/[sub 1], …, /a/[sub /n/] are +-- positive integers, and /a/[sub /n/] ≠ 1 unless /n/=0. This is called the +-- (short) continued fraction expansion of /q/. The function 'continued_list' inputs +-- two integers /num/ and /denom/, computes the continued fraction expansion of +-- /q/ = /num/ \/ /denom/, and returns the non-empty sequence +-- [/a/[sub 0], …, /a/[sub /n/]]. +continued_list :: (Integral int) => int -> int -> [int] +continued_list _ 0 = [] +continued_list num denom = + int_part : continued_list denom num' + where + int_part = num `div` denom + num' = num - int_part*denom + +-- | Generate a list of convergents from a continued fraction (as described by +-- the non-empty list of integers of that fraction). +convergents :: (Integral int, Fractional a) => [int] -> [a] +convergents as = recursive (0,1) (1,0) as + where + recursive (h0, k0) (h1, k1) [] = [] + recursive (h0, k0) (h1, k1) (a2:as) = b2 : recursive (h1, k1) (h2, k2) as + where + h2 = a2 * h1 + h0 + k2 = a2 * k1 + k0 + b2 = (fromIntegral h2) / (fromIntegral k2) + +-- =========================================== +-- * Quantum functions +-- =========================================== + +-- =========================================== +-- ** Generic blackboxing + +-- | Unimplemented components need to be given as black boxes — like named gates, +-- except their types may not just be an endomorphism; like subroutines, except +-- with only a placeholder on the inside. +-- +-- For this module, black boxes are only needed for classical functional routines, +-- i.e. with type qa -> Circ (qa, qb) +blackbox :: (QData qa, QData qb) => String -> qb -> qa -> Circ (qa,qb) +blackbox n out_shape = box n $ \qx -> do + qy <- qinit $ qc_false out_shape + (qx,qy) <- named_gate n (qx,qy) + return (qx,qy) + +-- =========================================== +-- ** Boxed imported arithmetic + +-- $ To reduce the printed sizes of circuits, we box all imported arithmetic components. + +-- | Like 'box', but prepends \"Arith.\" to subroutine names, +-- as a crude form of namespace management. +arithbox :: (QCData qa, QCData qb, QCurry qa_qb qa qb) => String -> qa_qb -> qa_qb +arithbox n = box ("Arith." ++ n) + +-- | Boxed analogue of 'Arith.q_ext_euclid'. +q_ext_euclid :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt,QDInt,QDInt) +q_ext_euclid = arithbox "q_ext_euclid" Arith.q_ext_euclid + +-- | Boxed analogue of 'Arith.q_add'. +q_add :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt) +q_add = arithbox "q_add" Arith.q_add + +-- | Boxed analogue of 'Arith.q_mult'. +q_mult :: (QCData qa, QNum qa) + => qa -> qa -> Circ (qa,qa,qa) +q_mult = arithbox "q_mult" Arith.q_mult + +-- | Boxed analogue of 'Arith.q_div_exact'. +q_div_exact :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_div_exact = arithbox "q_div_exact" Arith.q_div_exact + +-- | Boxed analogue of 'Arith.q_add_in_place'. +q_add_in_place :: QDInt -> QDInt -> Circ (QDInt, QDInt) +q_add_in_place = arithbox "q_add_in_place" Arith.q_add_in_place + +-- | Boxed analogue of 'Arith.q_add_param_in_place'. +q_add_param_in_place ::IntM -> QDInt -> Circ QDInt +q_add_param_in_place = Arith.q_add_param_in_place +{- Currently doesn’t work: +q_add_param_in_place n = + arithbox ("q_add_param_in_place; n = " ++ show n ++ "; ") (Arith.q_add_param_in_place n) +-} + +-- | Boxed analogue of 'Arith.q_div'. +q_div :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_div = arithbox "q_div" Arith.q_div + +-- | Boxed analogue of 'Arith.q_mult_param'. +q_mult_param :: IntM -> QDInt -> Circ (QDInt, QDInt) +q_mult_param = Arith.q_mult_param +{- Currently doesn’t work: +q_mult_param n = + arithbox ("q_mult_param; n = " ++ show n ++ "; ") (Arith.q_mult_param n) +-} + +-- | Boxed analogue of 'Arith.q_mod_unsigned'. +q_mod_unsigned :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_mod_unsigned = arithbox "q_mod_unsigned" Arith.q_mod_unsigned + +-- | Boxed analogue of 'Arith.q_sub_in_place'. +q_sub_in_place :: QDInt -> QDInt -> Circ (QDInt, QDInt) +q_sub_in_place = arithbox "q_sub_in_place" Arith.q_sub_in_place + +-- | Boxed analogue of 'Arith.q_increment'. +q_increment :: QDInt -> Circ QDInt +q_increment = arithbox "q_increment" Arith.q_increment + +-- =========================================== +-- ** Other arithmetic functions + +-- | Turn a 'QDInt' into an 'FPRealQ', with shape specified by another 'FPRealQ' +fprealq_of_QDInt_with_shape :: FPRealQ -> QDInt -> Circ (QDInt, FPRealQ) +fprealq_of_QDInt_with_shape = blackbox "fprealq_of_QDInt_with_shape" + +-- | Divide a 'QDInt' by 2, in place. (Behavior on odd integers: so far, not required.) +-- As this is not required on odd integers, we can assume that the least significant +-- bit is 0, and use an operation equivalent to a right rotate, instead of a right +-- shift. This can be achieved by changing the list indices within the 'QDInt', and not +-- a quantum operation, but this operation is *NOT* controllable. +q_div2 :: QDInt -> Circ QDInt +q_div2 = return . qdint_of_qulist_bh . rotate . qulist_of_qdint_bh + where + rotate as = last as:init as + +-- | Square a 'QDInt'. This is achieved by creating a copy of the input, using the +-- out of place multiplier, and then uncopying the input. +q_square :: QDInt -> Circ (QDInt,QDInt) +q_square qx = do + qx' <- qc_copy qx + (qx,qx',qxqx) <- q_mult qx qx' + qx <- qc_uncopy_fun qx qx' + return (qx,qxqx) + +-- | Test whether a 'QDInt' is (strictly) greater than a parameter 'IntM'. +q_gt_param :: QDInt -> IntM -> Circ (QDInt,Qubit) +q_gt_param qx y = do + let y' = intm_promote y qx "q_gt_param: qx and y must be of the same length" + qy <- qinit y' + (qx, qy, qx_gt_y) <- q_gt qx qy + qterm y' qy + return (qx, qx_gt_y) + +-- | Test whether a 'QDInt' is greater than or equal to a parameter 'IntM'. +q_ge_param :: QDInt -> IntM -> Circ (QDInt,Qubit) +q_ge_param qx y = do + let y' = intm_promote y qx "q_ge_param: qx and y must be of the same length" + qy <- qinit y' + (qx, qy, qx_ge_y) <- q_ge qx qy + qterm y' qy + return (qx, qx_ge_y) + +-- | @'q_mod_semi_signed' /x/ /y/@: reduce /x/ modulo /y/. /x/ is +-- treated as signed, /y/ as unsigned. +-- +-- Note: not non-linear safe in /x/. +q_mod_semi_signed :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt) +q_mod_semi_signed = box "mod" $ \x y -> do +-- Approach: if x < 0, then (-1-x) >= 0, and +-- x `mod` y == (y-1) - ((-1-x) `mod` y) +-- +-- The (cheap) operations before and after 'q_mod_semi_signed' are +-- therefore conditioned on the sign of x; the (expensive) +-- 'q_mod_semi_signed' is performed just once, unconditionally. + x_mod_y <- with_computed + (do + sign_x <- case qdint_length x of + 0 -> qinit False + _ -> qc_copy $ head $ qulist_of_qdint_bh x + x <- q_negate_in_place x `controlled` sign_x + x <- q_decrement x `controlled` sign_x + (_, _, x') <- q_mod_unsigned x y + x' <- q_increment x' `controlled` sign_x + x' <- q_negate_in_place x' `controlled` sign_x + (y,x') <- q_add_in_place y x' `controlled` sign_x + return x') + qc_copy + return (x, y, x_mod_y) + +-- | @'q_mod_with_max' /x/ /y/ /m/@: reduce /x/ modulo /y/, into the range /max/ – /y/ < /x'/ ≤ /max/. (Compare 'mod_with_max'.) +q_mod_with_max :: QDInt -> QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt,QDInt) +q_mod_with_max x y m = do + -- Goal: max - ((max - x) `mod` y) + x_modmax_y <- with_computed + (do + (_, _, x') <- q_sub m x + (_, _, x'_mod_y) <- q_mod_semi_signed x' y + (_, _, x_modmax_y) <- q_sub m x'_mod_y + return x_modmax_y) + qc_copy + return (x, y, m, x_modmax_y) + + +-- | Obsolete function, retained for testing since it evokes a subtle bug in 'with_computed'. +q_mod_2times_buggy :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt) +q_mod_2times_buggy x a = do + x_mod_2a <- with_computed ( do + a' <- qc_copy a + (a,two_a) <- q_add_in_place a a' + x' <- qc_copy x + (x_mod_2a,two_a,x_div_2a) <- q_moddiv_unsigned_in_place x' two_a + return x_mod_2a + ) ( \x_mod_2a -> do + x_mod_2a' <- qc_copy x_mod_2a + return x_mod_2a' + ) + return (x,a,x_mod_2a) + +-- ====================================================================== +-- ** Looping combinators + +-- | Perform a bounded while loop, whose body may produce extra output. +q_bounded_while_with_garbage :: (QData qa, QCData qb) => + (qa -> Circ (qa,Qubit)) -- ^ the conditional test on the data + -> Int -- ^ a bound on the number of times the loop can run + -> qa -- ^ the starting value + -> (qa -> Circ (qa,qb)) -- ^ the body of the loop + -> Circ (qa,qa) -- ^ the initial and final values, and the produced data +q_bounded_while_with_garbage _ 0 x _ = qc_copy_fun x +q_bounded_while_with_garbage test bound x body = do + (x, x_really_out) <- with_computed_fun x + (\x -> do + x_out <- qinit $ qc_false x + failed_before <- qinit False + (x_final, x_out, failed_ever, loop_garbage) <- loopM bound (x, x_out, failed_before, []) + (\(x_cur, x_out, failed_before, garbage) -> do + (x_cur, good_now) <- test x_cur + -- If we fail now for the first time, copy the current value to the output value: + (x_out, x_cur) <- controlled_not x_out x_cur `controlled` good_now .==. 0 .&&. failed_before .==. 0 + -- Going forward, we’ve failed unless we’re good now *and* we’ve not failed before: + failed_now <- qinit True + failed_now <- qnot failed_now `controlled` good_now .==. 1 .&&. failed_before .==. 0 + -- In any case, apply the body again: + (x_cur, new_garbage) <- body x_cur + return (x_cur, x_out, failed_now, (good_now, failed_before, new_garbage):garbage)) + -- If the loop never finished, copy its last value to the output value: + (x_out, x_final) <- controlled_not x_out x_final `controlled` failed_ever .==. 0 + return (x_out, (x_final, failed_ever, loop_garbage))) + (\(x_out, garbage) -> do + (x_out, x_really_out) <- qc_copy_fun x_out + return ((x_out, garbage), x_really_out)) + return (x, x_really_out) + +-- | Perform a bounded-length while loop, with an endo-typed body. +-- +-- Note: uses /2 * bound/ ancillas. Can this be avoided? +q_bounded_while :: (QCData qa) => + (qa -> Circ (qa,Qubit)) -- ^ the conditional statement + -> Int -- ^ a bound on the number of times the loop can run + -> qa -- ^ the starting value + -> (qa -> Circ qa) -- ^ the body of the loop + -> Circ (qa,qa) -- ^ return the initial value, and the final post-loop value +q_bounded_while _ 0 x _ = qc_copy_fun x +q_bounded_while test bound x body = + with_computed_fun x + (\x -> do + (x,c) <- test x + x <- body x `controlled` c + return (x,c)) + + (\(x,c) -> bw_aux (bound-1) x c) + where +-- Auxiliary function: perform the loop with a running control qubit, +-- to avoid building up multi-ary controls: +-- bw_aux :: Int -> qa -> Qubit -> Circ ((qa,Qubit),qa) +-- Oddly, Haskell reads this type signature as generalising qa, +-- causing the following to fail to typecheck. + bw_aux 0 x c = do (x,x') <- qc_copy_fun x; return ((x,c),x') + bw_aux bound x c = do + with_computed_fun (x,c) + (\(x,c) -> do + (x,c') <- test x + c'' <- qinit False + c'' <- qnot c'' `controlled` [c,c'] + x <- body x `controlled` c'' + return (x,c,c',c'')) + (\(x,c,c',c'') -> do + ((x,c''),x') <- bw_aux (bound-1) x c'' + return ((x,c,c',c''),x')) + +-- | Perform a bounded while loop, whose body may produce extra output. +q_bounded_while_productive :: (QCData qa, QCData qb) => + (qa -> Circ (qa,Qubit)) -- ^ the conditional test on the data + -> Int -- ^ a bound on the number of times the loop can run + -> qa -- ^ the starting value + -> (qa -> Circ (qa,qb)) -- ^ the body of the loop + -> Circ (qa,qa,[qb]) -- ^ the initial and final values, and the produced data +q_bounded_while_productive test bound x body = do + ((x,[]),(x',ys)) <- + q_bounded_while + (\(x,ys) -> do (x,c) <- test x; return ((x,ys),c)) + bound + (x,[]) + (\(x,ys) -> do (x,y_new) <- body x; return (x,y_new:ys)) + return (x,x',ys) + +-- | Perform a bounded “do_until” loop. +q_do_until :: (QCData qa) => + Int -- ^ a bound on the number of times the loop can run + -> qa -- ^ the starting value + -> (qa -> Circ (qa,Qubit)) -- ^ the body of the loop, producing an input to the next iteration, plus a qubit to mark if we’re finished yet. + -> Circ (qa,qa) -- ^ return the initial and final values +q_do_until bound x body = do + with_computed_fun x body + (\(x,c) -> do_aux (bound-1) x c) + where +-- Auxiliary function: perform the loop with a running control qubit, +-- to avoid building up multi-ary controls: +-- do_aux :: Int -> qa -> Qubit -> Circ ((qa,Qubit),qa) +-- Oddly, Haskell reads this type signature as generalising qa, +-- causing the following to fail to typecheck. + do_aux 0 x c = do (x,x') <- qc_copy_fun x; return ((x,c),x') + do_aux bound x c = do + with_computed_fun (x,c) + (\(x,c) -> do + (x,c') <- body x `controlled` c + c'' <- qinit False + c'' <- qnot c'' `controlled` [c,c'] + return (x,c,c',c'')) + + (\(x,c,c',c'') -> do + ((x,c''),x') <- do_aux (bound-1) x c'' + return ((x,c,c',c''),x')) diff --git a/Quipper/Algorithms/CL/CL.hs b/Quipper/Algorithms/CL/CL.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/CL/CL.hs @@ -0,0 +1,473 @@ +-- | An implementation of the quantum algorithms, based on the works of Hallgren, to compute the class number of a real quadratic number field. + +module Quipper.Algorithms.CL.CL where + +import Quipper + +import Quipper.Libraries.QFT +import Quipper.Libraries.Arith +import Quipper.Libraries.FPReal +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.CL.Auxiliary +import Quipper.Algorithms.CL.Types +import Quipper.Algorithms.CL.RegulatorClassical +import Quipper.Algorithms.CL.RegulatorQuantum +import Quipper.Algorithms.CL.SmithReduction + +import Data.Ratio +import Data.Maybe +import Data.List +import System.Random + +-- ====================================================================== +-- * Stage 1 (quantum): Approximate regulator to low precision +-- ====================================================================== + +-- | Quantum part of the procedure to approximate the regulator /R/. +-- +-- Follows the procedure described in [Jozsa 2003], Sec. 10. An adapted +-- version of the Hidden Subgroup Problem (HSP) Algorithm is used to +-- estimate the (irrational) period of the function /f/ [sub /N/] +-- ('fN', 'q_fN'); this is the function /h/ of [Jozsa 2003], Sec. 9, +-- discretized with precision /N/ = 2 [super −/n/], and so has weak +-- period /S/ = /NR/. The precision /n/ is determined by 'n_of_bigD'. +-- +-- Inputs: Δ; /i/, an assumed bound such that /S/ ≤ 2[sup /i/]; +-- and a random “jitter” parameter. +approximate_regulator_circuit :: CLIntP -> Int -> CLIntP -> (Circ CInt) +approximate_regulator_circuit bigD i jitter = do + let n = n_of_bigD bigD + nn = 2^n + s_bound = 2^i + -- q is the register length, and Q = 2^q (qq in Haskell code) the number of states. + q = 2 + 2 * i -- So 2^q = 4 * (s_bound^2), the first power of 2 assumed to + qq = 2^q -- be above 3 S^2. + l = 4 + q + n -- Chosen to give: + ll = 2^l -- L = 16 Q N. + t = i + 2 * (ceiling $ logBase 2 $ sqrt $ fromIntegral bigD) + j_p = intm (4+q) jitter + + -- Step 1 - apply Hadamard transform to register 1 + reg1 <- qinit $ qc_false $ qshape $ intm q 0 + -- Note: the [qc_false $ qshape] is currently redundant, since 0 is encoded as |00…00>. + -- However, that is dependent on the specific representation of integers; + -- using qc_false specifies the all-0 state independently of the + -- representation of integers. + reg1 <- mapUnary hadamard reg1 + + -- Step 2 - Apply unitary transformation corresponding to f_N. (This automatically initialises reg2.) + (reg1,reg2) <- q_fN bigD n l reg1 j_p + + -- Step 3 - Discard contents of reg2. + reg2_c <- measure reg2 + cdiscard reg2_c + + -- Step 4 - apply QFT + reg1 <- qft_int reg1 + + -- Step 5 - measure register 1, and return the measurement. + reg1_c <- measure reg1 + return reg1_c + +-- | Attempt to approximate the regulator /R/, given an assumed +-- bound /i/ such that /S/ ≤ 2[sup /i/], using the probabilistic +-- quantum computation @approximate_regulator_circuit@ twice as +-- described in [Jozsa 2003], Sec. 10. +-- +-- Check the result for success; if it fails, return 'Nothing'. +-- +-- (The 'IO' monad is slight overkill here: it is just to make a +-- source of randomness available. A tighter approach could use e.g. a +-- monad transformer such as 'Control.Monad.Random.RandT', applied to +-- the 'Circ' monad.) +try_approximate_regulator :: CLIntP -> Int -> IO (Maybe CLReal) +try_approximate_regulator bigD i = do + let n = n_of_bigD bigD + q = 2 + 2 * i -- So 2^q = 4 * (s_bound^2), the first power of 2 assumed to + qq = 2^q -- be above 3 S^2. + + c_jitter <- getStdRandom $ randomR (0, 16*qq - 1) + c <- run_generic_io (undefined :: Double) $ approximate_regulator_circuit bigD i c_jitter + d_jitter <- getStdRandom $ randomR (0, 16*qq - 1) + d <- run_generic_io (undefined :: Double) $ approximate_regulator_circuit bigD i d_jitter + + -- Find the (possibly empty) list of m's that pass the verification + -- criteria. The candidate m's are constructed from the convergents of c/d + let candidate_ms = filter (verify_period_multiple bigD n) $ + map (\c_n -> round $ c_n * (fromIntegral qq) / (fromIntegral c)) $ + convergents $ continued_list (fromIntegral c) (fromIntegral d) + + return $ if (null candidate_ms) + then Nothing + else (Just (fprealx (-n) (head $ sort $ candidate_ms))) + +-- | @'verify_period_multiple' Δ /n/ /m/@: +-- check whether /m/ is within 1 of a multiple of the period /S/ of /f/[sub /N/]. +-- +-- Since for any ideal /I/, ρ(ρ(/I/)) is distance > ln 2 from /I/, it suffices +-- to check whether the unit ideal is within 4 steps either way of /f/[sub /N/](m). +verify_period_multiple :: CLIntP -> Int -> CLInt -> Bool +verify_period_multiple bigD n m = + let jj = fst $ fN m (2^n) 0 0 bigD + in (unit_ideal bigD) + `elem` ([jj] ++ (take 4 $ iterate rho jj) ++ (take 4 $ iterate rho_inv jj)) + +-- | Approximate the regulator for a given Δ (/bigD/). +-- +-- Repeatedly run @'try_approximate_regulator'@ enough times, with increasing +-- /i/, that it eventually succeeds with high probability. +approximate_regulator :: CLIntP -> IO CLReal +approximate_regulator bigD = + -- Create a (infinite and lazy) list of attempts to approximate the + -- regulator, assuming S ≤ 2^i for i = 1, 2, … + -- (For each value of /i/, make (36 * i) attempts.) + -- Run the attempts until one succeeds; return its answer. + fmap (fromJust . fromJust) $ sequence_until isJust $ concat + [ replicate (36*i) (try_approximate_regulator bigD i) | i <- [1..] ] + +-- ====================================================================== +-- * Stage 2 (classical): Compute the regulator more accurately. +-- ====================================================================== + +-- | Improve the precision of the initial estimate of the regulator /R/, for +-- a quadratic discriminant Δ. +-- +-- The implementation is essentially based on the proof of Theorem 5 of +-- [Jozsa 2003]. +improve_regulator_accuracy :: CLReal -> Integer -> CLReal +improve_regulator_accuracy bigR bigD = + fRefine dist idealNew + where + (dist, idealNew) = improve_regulator_accuracy' bigD + improve_regulator_accuracy' :: Integer -> (CLReal, IdDist) + improve_regulator_accuracy' bigd = refineR (head j') ideals + + -- ------------------------------------------------------------------------- + -- Step 3: So far we have computed ideals, I_i , I_i-1 , I_i-2 ,.., I_1. + -- Now, for I_i perform dot (*) operation with Ii-1, Ii-2, .., I_1 while + -- (I_i * I_k) < R is true. If (I_i *I_k) > R, then discard I_k and + -- continue with I_k-1. Finish when I_1 is reached. + -- At this point a reduced Ideal J* is produced to the left of R with + -- R - delta(J*). In parallel accumulate distances using fomula + -- delta(I,rho(I)) = ln |gamma| for I = Z +gammaZ and Proposition 34 + -- of [Jozsa 2003]. In the end apply repeatedly rho**2 to J* while + -- distance does not exeed R. + -- ------------------------------------------------------------------------ + fRefine :: CLReal -> IdDist -> CLReal + fRefine currDist reducedI = + -- fRefine currDist reducedI = if (newDist < bigR) + let + newReducedI = rho_d $ rho_d reducedI + newDist = delta newReducedI + in if (newDist < bigR) + then + fRefine newDist newReducedI + else + currDist + + refineR :: IdDist -> [IdDist] -> (CLReal, IdDist) + refineR currI (x:xs) = + -- repeat applying an Ideal to the reference Ideal until + -- the distance that is smaller than 'r' is found. + if (null xs) + then + case (distance > bigR) of + True -> (delta currI, currI) + False -> (distance, i') + else + if (distance > bigR) + then + refineR currI xs + else + refineR i' xs + where + distance = delta i' + i'' = currI `dot` x + i' = while (not . is_reduced . fst) rho_d i'' + + refineR _ [] = undefined -- keep the compiler happy + + -- -------------------------------------------------------------------- + -- Step 2: Compute the closest ideal I to the left of R along the cycle + -- of principal reduced ideals and its distance which is the closest + -- to real value. + -- At the end of this step an Ideal I_i and a list of ideals I_i-1, + -- I_i-2,.., In1, will be constructed. + -- -------------------------------------------------------------------- + -- The following function constructs a list of ideals I_i, I_i-1, I+i-2,..., I_1, + -- where delta(I_n) < bigR. + -- j' is an Ideal, I_i (or I_N of [Jozsa 2003], in first paragraph of p.24) + -- + -- @ideals@ contains the list of ideals so far collected, with the + -- the newest entry at the head. + (j', ideals) = splitAt 1 $ reverse $ refineR1 i0 + + refineR1 :: IdDist -> [IdDist] + refineR1 x + -- each time multiplication is done, reduce the Ideal and compute delta as well + -- rho function also computes the new accumulating distance each time + | (delta x) < bigR = x : refineR1 (reduceIdeal $ dot' x) + | otherwise = [] + where + -- reduce the ideal + reduceIdeal ::IdDist -> IdDist + reduceIdeal i = while (not . is_reduced . fst) rho_d i + + -- ---------------------------------------------------------------- + -- Step 1: Compute the initial Ideal I0 and its distance Delta(I0). + -- compute the initial Ideal + -- ---------------------------------------------------------------- + i0 = rho_d $ rho_d $ (unit_ideal bigD, 0) + +-- ====================================================================== +-- * Stage 3 (classical): Find generators of the class group. +-- ====================================================================== + +-- | A set of ideal classes generating /CL/(/K/). +-- +-- Implementation: assuming the Generalized Riemann Hypothesis, it is +-- enough to enumerate the non-principal prime ideals arising as +-- factors of (/p/), for primes /p/ ≤ 12(ln Δ)[super 2]. ([Haase and +-- Maier 2006], Prop. 4.4.) For each /p/, there are at most two such +-- prime ideals, and they are easily described. +compute_generators :: CLIntP -> [IdealRed] +compute_generators bigD = + map (reduce . ideal_from_generator) $ + concat [gens_from_prime p | p <- primes_to primes_bound, p >= 3] + where + primes_bound = (12*((floor $ log $ fromIntegral bigD)^2)) + d = d_of_bigD bigD + omega = omega_of_bigD bigD + omega_bar = conjugate omega + + -- the polynomial with roots omega, omega_bar + f = if (bigD `mod` 4 == 1) + then (\x -> x^2 - x - ((bigD - 1) `div` 4)) + else (\x -> x^2 - bigD) + + gens_from_prime 2 = case (d `mod` 8) of + 5 -> [] + 1 -> [(2, omega), (2, omega_bar)] + 3 -> [(2, AlgNum (-1) (1/2) bigD)] + 7 -> [(2, AlgNum (-1) (1/2) bigD)] + _ -> [(2, AlgNum 0 (1/2) bigD)] + gens_from_prime p = case (d `jacobi_symbol` p) of + 0 -> [(p, omega - c)] + 1 -> [(p, omega - c),(p, c - omega_bar)] + _ -> [] + where + c = fromIntegral $ head [ x | x <- [0..p-1], (f x) `mod` p == 0 ] + + -- give the standard form of the ideal generated by (p,x), + -- provided that x is of the form (b + √Δ)/2 + ideal_from_generator :: (CLIntP, AlgNum) -> Ideal + ideal_from_generator (p, w) = + let b = (2*w - (AlgNum 0 1 bigD)) + in assert (snd_AlgNum b == 0 && is_int (fst_AlgNum b)) + ("compute_generators: w = " ++ show w ++ " is not of expected form") + (Ideal bigD 1 1 (fromIntegral p) (truncate (fst_AlgNum b))) + +-- ====================================================================== +-- * Stage 4 (quantum): Find relations between generators. +-- +-- $ Notation is as in [Hallgren 2006, Section 5]. Note: Some +-- components are currently missing here, and are marked +-- \"incomplete\" in the code below. + +-- ====================================================================== + +-- | Compute the generators of /CL/(/K/), function /hI/. +hI :: IdDist -> CLInt -> CLInt -> CLInt -> CLIntP -> CLIntP -> (IdDist, CLInt) +hI ideal_I a b j n l = + (ideal_K'', floor (fromIntegral n * delta ideal_K'')) + where + bigD = bigD_of_Ideal (fst ideal_I) + ideal_J = ideal_I + ideal_K = (unit_ideal bigD, 0) + i = a + (i', ideal_J', ideal_K') = + bounded_while condition bound body (i, ideal_J, ideal_K) + where + bound = ceiling $ logBase 2 (fromIntegral a) + + body (i,j,k) = ( + floor ((fromIntegral i) / 2), + j `star` j, + if (i `mod` 2 /= 0) then k `star` j else k) + + condition (i,j,k) = (i /= 0) + + ideal_J'' = fst $ fN_d b j n l (bigD_of_Ideal $ fst ideal_I) + ideal_K'' = ideal_K' `star` ideal_J'' + +-- | Compute the ideals from the generators (ĝ function). +compute_ghat :: (Integral int) => [IdDist] -> [int] -> IdDist +compute_ghat gs is = + foldl1 (\g_i g_j -> g_i `star` g_j) $ + map (\(ik, gk) -> gk `power` ik) $ zip is gs + + where + power :: (Integral int) => IdDist -> int -> IdDist + power gk 0 = let (Ideal bigD m l a b, _) = gk in (unit_ideal bigD, 0) + power gk 1 = gk + power gk n = gk `star` (power gk (n-1)) + +-- | Compute /i/\//N/. Incomplete. +compute_i_N_at :: QDInt -> QDInt -> Circ() +compute_i_N_at reg_I reg_out = + error "incomplete" + + +-- | Compute register sizes for @structure_circuit@, given +-- Δ and a precise estimate of /R/. Return a 7-tuple +-- (/q/,1,2,3,4,5,6) where /q/ is the size of the first +-- /k/ registers, and 1…6 are the sizes of registers /k/+1…/k/+6. +register_sizes :: CLIntP -> CLReal -> (Int,Int,Int,Int,Int,Int,Int) +register_sizes bigD r = + (q, r1, r2, r3, r4, r5, r6) + where + q = clog2i bigD + r1 = 2 * clog2r sqrt_bigD + r2 = clog2i round_nr + r3 = 2 * clog2r sqrt_bigD + clog2i round_nr + r4 = clog2i (m * round_nr) + r5 = clog2i round_nr + r6 = 2 * clog2r sqrt_bigD + clog2i round_nr + + -- Algorithm constants + sqrt_bigD = sqrt $ fromIntegral bigD + round_nr = round nr + + m = ceiling $ 2*r+1 + b = ceiling $ 2 * sqrt_bigD + (p',q') = find_pq_satisfying_condition br m + n = q' * b + l = 16 * q * n + nr = fromIntegral n * r + br = fromIntegral b * r + + -- Find a pair (p,q) from the continued fraction expansion of BR such + -- that |BR - p\/q| <= 1/(4qM) + find_pq_satisfying_condition :: (Integral int, Show int) => CLReal -> int -> (int, int) + find_pq_satisfying_condition br m = + if (isJust found) + then (num, denom) + else error $ + "Could not find p/q such that |BR - p/q| <= 1/(4qM) for:\n" ++ + "br = " ++ (show br) ++ "\n" ++ + "m = " ++ (show m) ++ "\n" ++ + "convergents = " ++ (show convs) + where + num = fromIntegral $ numerator $ fromJust found + denom = fromIntegral $ denominator $ fromJust found + + found = find satisfies convs + + convs = convergents $ + continued_list + (numerator $ toRational $ br) + (denominator $ toRational $ br) + + satisfies :: Rational -> Bool + satisfies p_over_q = + abs (br - fromRational p_over_q) <= 1/(4*q*m') + where q = fromIntegral $ denominator p_over_q + m' = fromIntegral m + + -- Helper function - ceiling(log_2 val) + clog2r :: (RealFrac a, Floating a, Integral int) => a -> int + clog2r val = ceiling $ logBase 2 val + + clog2i :: (Integral int) => int -> Int + clog2i val = clog2r $ fromIntegral val + + +-- | The quantum circuit used in computing the structure of /CL/(/K/), +-- given Δ, a precise estimate of /R/, and a generating set for /CL/(/K/). +structure_circuit :: CLIntP -> CLReal -> [IdealRed] -> (Circ [CInt]) +structure_circuit bigD r gs = do + -- Apply H to first k registers of size 'q' each + reg_ks <- qinit [ intm q 0 | x <- gs ] + reg_ks <- mapUnary hadamard reg_ks + + -- Initialize the rest of the registers in state zero + -- note: fIN and fJN is the same thing. + reg_I <- qinit (intm reg_I_size 0) -- register 1 + reg_i <- qinit (intm reg_i_size 0) -- register 2 + reg_fIN <- qinit (intm reg_fIN_size 0) -- register 3 + reg_i_N <- qinit (intm reg_i_N_size 0) -- register 4 + + -- Apply U_g_hat +-- Incomplete: (q_compute_ghat gs) reg_ks reg_I + + -- Superposition of distances + reg_i <- mapUnary hadamard reg_i + + -- Evaluate f_I,N +-- Imcomplete: q_fJN reg_i reg_I reg_fIN + + -- Compute i/N + compute_i_N_at reg_I reg_i_N + + -- Erase reg_i +-- Incomplete: erase_at fJN reg_i reg_I reg_fIN + + -- Uncompute i/N +-- Incomplete: uncompute_i_N_at reg_I reg_i_N + + -- Uncompute I +-- Incomplete: q_compute_ghat gs reg_ks reg_I + + -- Measure and discard result (used to project the system) + result_discard <- measure reg_fIN + + -- Apply QFT + -- FIX: Looking at the definition: + -- Fq x Fq ... (|l1>...|lk>) = Fq|l1> x ... x Fq|lk> + -- it seems the QFT can can be applied on the per-register basis. Check. + -- FIX: Check if the endianness is correct + reg_ks <- sequence $ map qft_int reg_ks + + -- Measure the system + reg_ks_measured <- mapM measure reg_ks + return (reg_ks_measured) + + where + (q, + reg_I_size, reg_i_size, + reg_fIN_size, reg_i_N_size, + _, _) = register_sizes bigD r + +-- | Compute the relations between a given set of reduced generators. +compute_relations :: CLIntP -> CLReal -> [IdealRed] -> IO [CLInt] +compute_relations bigD r generators = do + result <- run_generic_io (undefined :: Double) $ structure_circuit bigD r generators + return (result) + +-- ====================================================================== +-- * Section 5 (classical): compute class number. +-- ====================================================================== + +-- | The full implementation of Hallgren’s algorithm. +-- +-- @class_number dd t@: computes the class number |/CL/(/K/)| for Δ = /dd/, +-- with success probability at least (1 - 1\/2[sup /t/]). +class_number :: CLIntP -> Int -> IO(CLInt) +class_number bigD t = do + -- Stage 1: Approximate regulator to low precision + approximate_regulator <- approximate_regulator bigD + + -- Stage 2 & 3: Classical algorithms + let regulator = improve_regulator_accuracy approximate_regulator bigD + generators = compute_generators bigD + + k = length generators + q = ceiling $ logBase 2 $ fromIntegral bigD + bigT = t + k * (ceiling $ logBase 10 $ fromIntegral q) + + -- Stage 4: Use HSP to compute set of relations + relations <- mapM (\_ -> compute_relations bigD regulator generators) [ 1 .. bigT ] + + -- Stage 5: Make canonical set and derive CL(K) from structure + return $ group_order_from_matrix $ matrix_from_list relations diff --git a/Quipper/Algorithms/CL/Main.hs b/Quipper/Algorithms/CL/Main.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/CL/Main.hs @@ -0,0 +1,395 @@ +-- | +-- Authors: Keith Kim, Peter LeFanu Lumsdaine, Alexandr Virodov +-- +-- An implementation of Hallgren’s Class Number algorithm. This algorithm computes various invariants of +-- a real quadratic number field /K/ = ℚ(√Δ), notably the class number and the structure of the class group /CL/(/K/). +-- The field /K/ is specified by its discriminant /Δ/, the main input to the algorithm. +-- +-- The algorithm may also be adapted to other problems from algebraic number theory, including Pell's equation (finding integer solutions to /x/ [sup 2] − /dy/ [sup 2] = 1, for non-square /d/) and the principal ideal problem (determining whether an ideal of a number field is principal, and finding a generator if so). +-- +-- The present implementation falls into five stages, which we will refer to throughout the documentation: +-- +-- 1. Approximate the regulator of /K/, to low precision, using a version of the the (quantum) HSP algorithm. +-- +-- 2. Classically, refine the approximation from part 1 to higher precision. +-- +-- 3. Classically compute a small generating set for the class group, using the value of the regulator from part 2. +-- +-- 4. Compute relations for these generators, again using a version of the HSP algorithm. +-- +-- 5. Classically compute from these the structure of the class group, and hence the class number. +-- +-- Further details are given in the documentation of individual modules. +-- +-- The algorithm and its mathematical background are described in: +-- +-- * Sean Hallgren, \"Polynomial-time quantum algorithms for Pell’s equation and the principal ideal problem\", +-- in /STOC ’02: Proceedings of the thirty-fourth annual ACM symposium on Theory of computing/, pp. 653–658, 2002. +-- (Also published in J. ACM, 54(1), 2007.) +-- +-- * Richard Jozsa, \"Quantum computation in algebraic number theory: Hallgren’s efficient quantum +-- algorithm for solving Pell’s equation.\" Annals of Physics, 306:241–279, February 2003; +-- also available as . All references in documentation +-- refer to arXiv version. +-- +-- * Daniel Haase and Helmut Maier, \"Quantum algorithms for number fields.\" Fortschr. Phys., +-- 54(8):866–881, 2006. +-- +-- The present implementation is based on a detailed algorithm specification that was provided to us by the IARPA QCS +-- program and written by Brian J. Matt, Durward McDonell, and David Zaret. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.CL.Main": Command line interface. +-- +-- * "Quipper.Algorithms.CL.Auxiliary": General-purpose functions required in Hallgren’s algorithm. +-- +-- * "Quipper.Algorithms.CL.Types": Specialized classical and quantum datatypes used in Hallgren’s algorithm, and basic functions on these types. +-- +-- * "Quipper.Algorithms.CL.CL": The high-level structure of Hallgren’s algorithm. +-- +-- * "Quipper.Algorithms.CL.RegulatorClassical": A classical implementation of the functions and operations of stages 1–4. +-- +-- * "Quipper.Algorithms.CL.RegulatorQuantum": A quantum implementation of the functions required for stages 1 and 4 +-- +-- * "Quipper.Algorithms.CL.SmithReduction": Matrices, and reduction to Smith Normal Form, for Stage 5. +-- +-- * "Quipper.Algorithms.CL.Test": Functions to test components of the present implementation, using classical computation. + +module Quipper.Algorithms.CL.Main where + +import Quipper +import Quipper.Utils.CommandLine +import Quipper.Libraries.Arith +import Quipper.Libraries.FPReal +import Quipper.Libraries.Decompose +import Quipper.Libraries.Unboxing + +import Quipper.Algorithms.CL.Auxiliary +import Quipper.Algorithms.CL.Types +import Quipper.Algorithms.CL.RegulatorClassical +import Quipper.Algorithms.CL.RegulatorQuantum +import Quipper.Algorithms.CL.CL +import Quipper.Algorithms.CL.Test + +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.Random +import Control.Monad +import Data.Bits +import Data.Maybe +import Data.List +import Data.Char + +-- ---------------------------------------------------------------------- +-- * Command line interface + +-- $ This module provides a command line interface for Hallgren’s Class +-- Number algorithm. This allows the user, for example, to print or simulate +-- the circuits used in quantum portions of the algorithm, or to run +-- small instances of the algorithm in a classical implementation. +-- +-- Sample invocations: +-- +-- >>> ./cl -R +-- +-- Compute, classically, the regulator of ℚ[√Δ], with Δ = 28 (default value). +-- +-- >>> ./cl -P -d 17 +-- +-- Compute, classically, the fundamental solution of Pell’s equation +-- /x/[super 2] − /d//y/[super 2] = 1 +-- with /d/ = /Δ/ = 17. +-- +-- >>> ./cl -S fn -d 5 -f eps > cl_fn_d5.eps +-- +-- Produce an .eps file of the quantum circuit implementing the +-- pseudo-periodic function /f/[sub /N/] used for regulator estimation, +-- for Δ = 5 +-- +-- >>> ./cl -S starprod -d 60 -f gatecount +-- +-- Give gate-count for the quantum circuit implementing the star-product +-- on ideals, for Δ = 17 +-- +-- >>> ./cl --help +-- +-- Print detailed usage information. + +-- ---------------------------------------------------------------------- +-- * Option processing +-- +-- | An enumeration type for determining what the main function should do. +data WhatToShow = + Stage1 -- ^Show the circuit for stage 1 of the algorithm + | Stage4 -- ^Show the circuit for stage 4 of the algorithm + | Sub -- ^Show the circuit for a specific quantum subroutine + | Regulator -- ^Classically, find the regulator + | FundamentalUnit -- ^Classically, find the fundamental unit + | PellSolution -- ^Classically, find the fundamental solution of Pell’s equation + deriving Show + +-- | An enumeration type for selecting a subroutine. +data Subroutine = + Rho + | RhoInv + | Normalize + | DotProd + | StarProd + | FN + deriving (Show, Enum, Bounded) + +-- | An enumeration of available subroutines. (Compare 'format_enum', 'gatebase_enum'.) +subroutine_enum :: [(String, Subroutine)] +subroutine_enum = map (\x -> (map toLower (show x),x)) [minBound..maxBound] + +-- | A data type to hold values set by command line options. +data Options = Options { + -- Main “what to do” type options: + what :: WhatToShow, -- ^What kind of thing to output. + format :: Format, -- ^The output format. + gatebase :: GateBase, -- ^What kind of gates to decompose into. + sub :: Subroutine, -- ^Which subroutine to output (if @'what' == 'Sub'@). + + -- Master problem parameter + cl_delta :: CLIntP, -- ^The discriminant Δ, specifying the problem. + + -- Inputs for stage 1 of the algorithm + cl_i :: Int, -- ^i, log_2 of the estimated bound 2^i for the weak period S. + + -- Inputs for stage 4 of the algorithm + cl_r :: CLReal, -- ^ The (good) approximation R of the period. + cl_q :: CLIntP, -- ^The parameter q for stage 4 of the algorithm. + cl_k :: CLIntP, -- ^The parameter k for stage 4 of the algorithm. + cl_n :: CLIntP, -- ^The parameter n for stage 4 of the algorithm. + cl_m :: CLIntP, -- ^The parameter m for stage 4 of the algorithm. + + cl_generators :: [IdealRed], -- ^A generating set for /CL/(/K/). + + -- Misc options + cl_seed :: Int -- ^The seed for the random generator (0 for seed from time) +} deriving (Show) + +-- | The default options. +default_options :: Options +default_options = Options { + what = Stage1, + format = ASCII, + gatebase = Logical, + sub = FN, + + cl_delta = 28, + + cl_i = 1, + + cl_r = 12.345, + cl_q = 4, + cl_k = 3, + cl_n = 3, + cl_m = 5, + + cl_generators = [], + + cl_seed = 1 +} + +-- | Show the default value of an option. +show_default :: (Show a) => (Options -> a) -> String +show_default func = show (func default_options) + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = [ +-- Generic options: + Option ['h'] ["help"] (NoArg help) $ "print usage info and exit", + Option ['f'] ["format"] (ReqArg read_format "") $ "output format for circuits (default: " ++ show_default format ++ ")", + Option ['g'] ["gatebase"] (ReqArg read_gatebase "") $ "gates to decompose into (default: " ++ show_default gatebase ++ ")", + +-- Select what to do: + Option ['1'] [] (NoArg (what Stage1)) $ "output the circuit for stage 1 of the algorithm (default)", + Option ['4'] [] (NoArg (what Stage4)) $ "output the circuit for stage 4 of the algorithm", + Option ['S'] ["sub"] (ReqArg read_subroutine "") $ "output the circuit for a specific subroutine", + Option ['R'] ["regulator"] (NoArg (what Regulator)) $ "classically, find the regulator, given Δ", + Option ['F'] [] (NoArg (what FundamentalUnit)) $ "classically, find the fundamental unit, given Δ", + Option ['P'] [] (NoArg (what PellSolution)) $ "classically, find the fundamental solution of Pell’s equation, given Δ", + +-- Input parameters + Option ['d'] ["delta"] (ReqArg read_delta "") $ "discriminant Δ (a.k.a. D) (default: " ++ show_default cl_delta ++ ")", + + Option ['s'] ["ss"] (ReqArg read_s "") $ "estimated bound on period S, for stage 1 (default: " ++ show (2^(cl_i default_options)) ++ ")", + Option ['i'] [] (ReqArg read_i "") $ "estimated bound on log_2 S, for stage 1 (default: " ++ show (cl_i default_options) ++ ")", + + Option ['r'] ["rr"] (ReqArg read_r "") $ "approximate regulator R, for stage 4 (default: " ++ show_default cl_r ++ ")", + Option ['q'] [] (ReqArg read_q "") $ "The parameter q, for stage 4 (default: " ++ show_default cl_q ++ ")", + Option ['k'] [] (ReqArg read_k "") $ "The parameter k, for stage 4 (default: " ++ show_default cl_k ++ ")", + Option ['n'] [] (ReqArg read_n "") $ "The parameter n, for stage 4 (default: " ++ show_default cl_n ++ ")", + Option ['m'] [] (ReqArg read_m "") $ "The parameter m, for stage 4 (default: " ++ show_default cl_m ++ ")", + +-- Miscellaneous options + Option [] ["seed"] (ReqArg read_seed "") $ "Random seed (0 for seed from time)(default: " ++ show_default cl_seed ++ ")" + ] + where + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + + read_format :: String -> Options -> IO Options + read_format str o = do + case match_enum format_enum str of + [(_, f)] -> return o { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + read_gatebase :: String -> Options -> IO Options + read_gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + read_subroutine :: String -> Options -> IO Options + read_subroutine str o = do + case match_enum subroutine_enum str of + [(_, f)] -> return o { sub = f, what = Sub } + [] -> optfail ("Unknown subroutine -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous subroutine -- " ++ str ++ "\n") + + read_delta = read_arg parse_int (>0) (\n o -> o { cl_delta = fromIntegral n }) "Invalid Δ" + read_seed = read_arg parse_int (>=0) (\n o -> o { cl_seed = fromIntegral n }) "Invalid seed" + read_i = read_arg parse_int (>=0) (\n o -> o { cl_i = fromIntegral n }) "Invalid i" + read_s = read_arg parse_int (>0) (\n o -> o { cl_i = ceiling $ logBase 2 $ fromIntegral n }) "Invalid s" + read_r = read_arg parse_double (>0) (\n o -> o { cl_r = fromRational $ toRational n }) "Invalid r" + read_q = read_arg parse_int (>0) (\n o -> o { cl_q = fromIntegral n }) "Invalid q" + read_k = read_arg parse_int (>0) (\n o -> o { cl_k = fromIntegral n }) "Invalid k" + read_n = read_arg parse_int (>0) (\n o -> o { cl_n = fromIntegral n }) "Invalid n" + read_m = read_arg parse_int (>0) (\n o -> o { cl_m = fromIntegral n }) "Invalid m" + + read_arg :: (String -> Maybe a) -> (a -> Bool) -> (a -> Options -> Options) -> String -> String -> Options -> IO Options + read_arg parse cond func err string o = + case parse string of + Just n | cond n -> return $ func n o + _ -> optfail (err ++ " -- " ++ string ++ "\n") + + help :: Options -> IO Options + help o = do + usage + exitSuccess + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) default_options o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to standard output. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + putStr (show_enum "subroutine" subroutine_enum) + where header = "Usage: cl [OPTION...]" + +-- ---------------------------------------------------------------------- +-- * The CL circuit generation main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO() +main = do + -- Read options. + argv <- getArgs + options <- dopts argv + + let bigD = cl_delta options + assertM (is_valid_bigD bigD) $ + "Δ = " ++ (show $ cl_delta options) ++ " not valid discriminant" + let d = d_of_bigD bigD + + case what options of + Stage1 -> main_stage1 options + Stage4 -> main_stage4 options + Sub -> main_sub options + Regulator -> do + putStrLn $ "Regulator (by classical period-finding):" + putStrLn $ "Δ = " ++ show bigD + putStrLn $ "d = " ++ show d + putStrLn $ "R = " ++ show (regulator bigD) + FundamentalUnit -> do + putStrLn $ "Fundamental unit (by classical period-finding):" + putStrLn $ "Δ = " ++ show bigD + putStrLn $ "d = " ++ show d + putStrLn $ "ε_0 = " ++ pretty_show_AlgNum (fundamental_unit bigD) + PellSolution -> do + putStrLn $ "Fundamental solution of Pell’s equation x^2 − d y^2 = 1 (by classical period-finding):" + let (x,y) = fundamental_solution d + putStrLn $ "Δ = " ++ show bigD + putStrLn $ "d = " ++ show d + putStrLn $ "x = " ++ show x + putStrLn $ "y = " ++ show y + +-- | Main function for outputting the circuit for stage 1 of Hallgren’s algorithm. +main_stage1 :: Options -> IO() +main_stage1 options = do + + -- Generate the main circuit. + let bigD = cl_delta options + assertM (is_valid_bigD bigD) $ + "Δ = " ++ (show $ cl_delta options) ++ " not valid discriminant" + let i = cl_i options + ss_bound = 2^i + q = 2 + 2 * i -- So 2^q = 4 * S_bound^2 is the first power of 2 above S_bound + t = 2 * (ceiling (logBase 2 (sqrt $ fromIntegral bigD))) + i + + putStrLn $ "Generating circuit for stage 1 with args: " + putStrLn $ show options + putStrLn $ "" + putStrLn $ "Computed values: " + putStrLn $ "Δ: " ++ show bigD + putStrLn $ "i: " ++ show i + putStrLn $ "S_bound: " ++ show ss_bound + putStrLn $ "q: " ++ show q + putStrLn $ "t: " ++ show t + + -- rand <- getStdRandom (random) + let rand = 0 -- Fix the random generator to get consistent circuits + let circuit = approximate_regulator_circuit bigD i rand + + -- Print it. + print_simple (format options) (decompose_generic (gatebase options) circuit) + + +-- | Main function for outputting the circuit for stage 4 of Hallgren’s algorithm. +main_stage4 :: Options -> IO() +main_stage4 options = do + putStrLn $ "Generating circuit for stage 4 with args: " ++ show options + + +-- | Main function for outputting the circuits for specific subroutines. +main_sub :: Options -> IO() +main_sub options = + let fmt = format options + gtb = gatebase options + bigD = cl_delta options + in case sub options of + Rho -> do + print_generic fmt (unbox q_rho_d) (sample_IdDistQ bigD) + RhoInv -> do + print_generic fmt (unbox q_rho_inv_d) (sample_IdDistQ bigD) + Normalize -> do + print_generic fmt (unbox q_normalize) (sample_IdDistQ bigD) + DotProd -> do + print_generic fmt (unbox q_dot_prod) iirq iirq + where iirq = sample_IdealRedQ bigD + StarProd -> do + print_generic fmt (unbox q_star_prod) iirdq iirdq + where iirdq = sample_IdRedDistQ bigD + FN -> do + print_generic fmt (unbox $ \qi -> q_fN bigD n 0 qi j) iq + where + i = cl_i options + q = 2 + 2 * i -- as used in Part 1 + n = n_of_bigD bigD + iq = qshape (intm q 0) + j = (intm (q + 4) 0) diff --git a/Quipper/Algorithms/CL/RegulatorClassical.hs b/Quipper/Algorithms/CL/RegulatorClassical.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/CL/RegulatorClassical.hs @@ -0,0 +1,417 @@ +-- | This module implements the classical operations on ideals used in Hallgren’s +-- algorithm (including also classical versions of the quantum operations required). + +module Quipper.Algorithms.CL.RegulatorClassical where + +import Data.Maybe + +import Quipper.Libraries.Arith +import Quipper.Libraries.FPReal + +import Quipper.Algorithms.CL.Auxiliary +import Quipper.Algorithms.CL.Types + +-- ====================================================================== +-- * Basic operations on ideals + +-- | @'unit_ideal' /bigD/ /l/@: the unit ideal /O/, for Δ = /bigD/, with the ideal’s coefficients given as /l/-bit integers. +-- ([Jozsa 2003], Prop. 14.) +unit_ideal :: CLIntP -> Ideal +unit_ideal = forget_reduced . unit_idealRed + +-- | Like 'unit_ideal', but considered as a reduced ideal. +unit_idealRed :: CLIntP -> IdealRed +unit_idealRed bigD = assert (is_valid_bigD bigD) ("unit_idealRed: " ++ show bigD ++ " not valid discriminant") + $ IdealRed bigD 1 (tau bigD (fromIntegral bigD) 1) + +-- | The integer constant /c/ of an ideal. +-- ([Jozsa 2003], page 14 bottom: \"Since 4/a/ divides /b/[sup 2]-/D/ +-- (cf. proposition 16) we introduce the integer /c/ = |/D/ − /b/[sup 2]|\/(4/a/)\") +c_of_ideal :: Ideal -> CLInt +c_of_ideal i@(Ideal bigD m l a b) = + if (num `mod` denom == 0) then num `div` denom + else error error_string + where num = abs ((fromIntegral bigD) - b*b) + denom = 4*a + error_string = "rho of ideal [" ++ show i ++ "] produces non-integer c" + +-- | γ(/I/) = (/b/+√Δ)\/(2/a/) for a given ideal /I/. +-- ([Jozsa 2003], Sec. 6.2.) +gamma_of_ideal :: Ideal -> AlgNum +gamma_of_ideal (Ideal bigD m l a b) = AlgNum a' b' bigD + where + a' = (fromIntegral b / fromIntegral (2*a)) :: CLRational + b' = (fromIntegral 1 / fromIntegral (2*a)) :: CLRational + -- Recall: @'AlgNum' u v bigD@ represents (u + v * √bigD). + +-- | The reduction function ρ on ideals. +-- ([Jozsa 2003], Sec. 6.2.) +rho :: Ideal -> Ideal +rho ii@(Ideal bigD m l a b) = (Ideal bigD m'' l'' a' b') + where + -- With little algebra, one can derive these: + m' = m * a + l' = l * a' + m'' = m' `div` (gcd m' l') + l'' = l' `div` (gcd m' l') + -- From [Jozsa 2003], p.15, equation (10) + a' = c_of_ideal ii + b' = tau bigD (-b) a' + +-- | The ρ[sup -1] function on ideals. Inverse to 'rho'. +-- ([Jozsa 2003], Sec. 6.4.) +rho_inv :: Ideal -> Ideal +rho_inv (Ideal bigD m l a b) = (Ideal bigD m'' l'' a'' b'') + where + -- Create m and l + m' = m * a + l' = l * a'' + -- Reduce them to have no common denominator + m'' = m' `div` (gcd m' l') + l'' = l' `div` (gcd m' l') + -- Calculate b* (b' below) + b' = tau bigD (-b) a + -- Calculate new a and b + a'' = ((fromIntegral bigD) - b'*b') `divchk` (4*a) + b'' = tau bigD b' a'' + +-- | The ρ operation on reduced ideals. +rho_red :: IdealRed -> IdealRed +rho_red = to_reduced . rho . forget_reduced + +-- | The ρ[sup –1] operation on reduced ideals. +rho_inv_red :: IdealRed -> IdealRed +rho_inv_red = to_reduced . rho_inv . forget_reduced + +-- | The ρ operation on ideals-with-distance. +rho_d :: IdDist -> IdDist +rho_d (ii, del) = (rho ii, del + del_change) + where + gamma = gamma_of_ideal ii + gamma_bar_by_gamma = (floating_of_AlgNum $ conjugate gamma) / (floating_of_AlgNum gamma) + del_change = (log $ abs gamma_bar_by_gamma) / 2 + +-- | The ρ[sup –1] operation on ideals-with-distance. +rho_inv_d :: IdDist -> IdDist +rho_inv_d (ii, del) = (ii', del - del_change) + where + ii' = rho_inv ii + gamma = gamma_of_ideal ii' + gamma_bar_by_gamma = (floating_of_AlgNum $ conjugate gamma) / (floating_of_AlgNum gamma) + del_change = (log $ abs gamma_bar_by_gamma) / 2 + +-- | The ρ operation on ideals-with-generator (i.e. pairs of an ideal /I/ and an 'AlgNum' /x/ such that /I/ is the principal ideal (/x/)). +rho_num :: (Ideal,AlgNum) -> (Ideal,AlgNum) +rho_num (ii, gen) = (rho ii, gen / (gamma_of_ideal ii)) + +-- | Apply ρ to an reduced-ideals-with-generator +rho_red_num :: (IdealRed,AlgNum) -> (IdealRed,AlgNum) +rho_red_num (ii, gen) = (rho_red ii, gen / (gamma_of_ideal $ forget_reduced ii)) + +-- ====================================================================== +-- * Ideal reductions (bounded) + +-- | Reduce an ideal, by repeatedly applying ρ. +reduce :: Ideal -> IdealRed +reduce ii = to_reduced $ while (not . is_reduced) rho ii + +-- | Reduce an ideal within a bounded loop. Applies the ρ function +-- until the ideal is reduced. Used in 'star' and 'fJN' algorithms. +bounded_reduce :: IdDist -> IdDist +bounded_reduce k@(ideal@(Ideal bigD m l a b),dist) = + fst $ bounded_while condition bound func (k,0) + where + -- NOTE: some uncertainty regarding loop bound. + bound = ceiling $ bound_log + 1 + bound_log = (logBase 2 ((fromIntegral bound_a) + / (sqrt $ fromIntegral $ bigD_of_Ideal $ ideal))) + bound_a = 2 ^ (fromJust (intm_length $ a)) + + condition (k,itr) = not $ is_reduced $ fst k + func (k,itr) = ((rho_d k),(itr+1)) + +-- | Apply a function (like ρ,ρ[sup -1],ρ[sup 2]) to an ideal, bounded +-- by 3*ln(Δ)\/2*ln(2). Execute while satisfies condition function. +bounded_step :: (IdDist -> Bool) -> (IdDist -> IdDist) -> IdDist -> IdDist +bounded_step condition step_function ideal = + -- Execute a bounded while loop + bounded_while condition bound step_function ideal + where + bound = ceiling $ (3 * (log $ fromIntegral $ bigD_of_Ideal $ fst ideal)) / (2 * log 2) + +-- | Like 'bounded_step', but the condition is checked against delta of the +-- current ideal. +bounded_step_delta :: (CLReal -> Bool) -> (IdDist -> IdDist) -> IdDist -> IdDist +bounded_step_delta condition step_function ideal = + bounded_step new_condition step_function ideal + where new_condition = (\k -> condition (delta k)) + +-- ====================================================================== +-- * Products of ideals + +-- | The ordinary (not necessarily reduced) product of two reduced fractional ideals. +-- +-- /I/⋅/J/ of [Jozsa 2003], Sec 7.1, following the description +-- given in Prop. 34. + +-- NOTE: assumes I, J reduced. Type should reflect this! +dot :: IdDist -> IdDist -> IdDist +dot i1@(Ideal bigD1 m1 l1 a1 b1, delta1) i2@(Ideal bigD2 m2 l2 a2 b2, delta2) = + assert_reduced (fst i1) $ + assert_reduced (fst i2) $ + (Ideal bigD1 m l a3 b3, del) + where + sqrtd :: CLReal + sqrtd = sqrt (fromIntegral bigD1) + (k', u', v') = extended_euclid a1 a2 + (k, x, w ) = extended_euclid k' ((b1 + b2) `divchk` 2) + a3 = (a1 * a2) `divchk` (k * k) + t1 = x * u' * a1 * b2 + t2 = x * v' * a2 * b1 + t3 = w*(b1 * b2 + (fromIntegral bigD1)) `divchk` 2 + t = (t1 + t2 + t3) `divchk` k + b3 = tau bigD1 t a3 + m = k + l = a3 + del = ((delta i1) + (delta i2)) + +-- | The dot-square /I/⋅/I/ of an ideal-with-distance /I/. +dot' :: IdDist -> IdDist +dot' i1@(Ideal bigD1 m1 l1 a1 b1, delta1) = + assert_reduced (fst i1) $ + (Ideal bigD1 m l a3 b3, del) + where + sqrtd :: CLReal + sqrtd = sqrt (fromIntegral bigD1) + (k, u, w) = extended_euclid (abs a1) (abs b1) + a3 = (a1 * a1) `divchk` (k * k) + t1 = u * a1 * b1 + t3 = w*(b1 * b1 + (fromIntegral bigD1)) `divchk` 2 + t = (t1 + t3) `divchk` k + b3 = tau bigD1 t a3 + m = k + -- l = a3 + l = 1 + del = ((delta i1) + (delta i1)) + +-- | The star-product of two ideals-with-distance. +-- +-- This is /I/*/J/ of [Jozsa 2003], Sec. 7.1, defined as the first reduced +-- ideal-with-distance following /I/⋅/J/. + +-- NOTE: assumes I, J reduced. Type should reflect this! +star :: IdDist -> IdDist -> IdDist +star i j = + if (delta k1 <= delta i_dot_j) + then bounded_step_delta (<= delta i_dot_j) rho_d k1 + else rho_d $ bounded_step_delta (>= delta i_dot_j) rho_inv_d k1 + where + i_dot_j = i `dot` j + -- FIX: Over bound (infinite loop) in reducing the following: + -- * + k1 = bounded_reduce i_dot_j + +-- ====================================================================== +-- * The function f[sub /N/], and variants + +-- | Compute the expression i\/N + j\/L. +compute_injl :: (Integral int) => CLInt -> int -> CLInt -> int -> CLReal +compute_injl i nn j ll = + (fromIntegral i)/(fromIntegral nn) + (fromIntegral j)/(fromIntegral ll) + +-- | @'fN' /i/ /j/ /n/ /l/ Δ@: find the minimal ideal-with-distance (/J/,δ[sub /J/]) such that δ[sub /J/] > /x/, where /x/ = /i/\//N/ + /j/\//L/, where /N/ = 2[sup /n/], /L/ = 2[sup /l/]. Return (/i/,/J/,δ[sub /J/]–/x/). Work under the assumption that /R/ < 2[sup /s/]. +-- +-- This is the function /h/ of [Jozsa 2003, Section 9], discretized with precision 1\//N/ = 2[sup −/n/], +-- and perturbed by the jitter parameter /j/\//L/. +fN :: (Integral int) => CLInt -> CLInt -> int -> int -> CLIntP -> (Ideal, CLInt) +fN i j nn ll bigD = + let ((ideal_J, _), diff) = fN_d i j nn ll bigD + in (ideal_J, diff) + +-- | Like 'fN', but returning an ideal-with-distance not just an ideal. +fN_d :: (Integral int) => CLInt -> CLInt -> int -> int -> CLIntP -> (IdDist, CLInt) +fN_d i j nn ll bigD = + (j_star_19, floor $ (fromIntegral nn) * (toRational $ injl - (snd j_star_19))) + where + -- Expression "i/N + j/L" used repeatedly + injl = compute_injl i nn j ll + + -- Generate J1 + j1 = rho_d $ rho_d $ (unit_ideal bigD, 0) + + -- Generate Jk's (make an infinite list and take only what is needed) + jks = takeWhile (\jk -> (delta jk) <= injl) $ + bounded_iterate bound_jks + (\jk -> jk `star` jk) j1 + where + -- Bound for jk generation + max_i = 2^(fromJust (intm_length $ i)) + bound_jks = ceiling $ + (log $ fromIntegral max_i) / + ((fromIntegral nn) * (delta j1)) + + -- Apply all Jk's to J* using '*' in reverse (remember that the last + -- element is J* itself) + j_star_14 = foldr1 applyJkIfConditionHolds jks + + -- Apply Jk to J* if a condition holds. + applyJkIfConditionHolds :: IdDist -> IdDist -> IdDist + applyJkIfConditionHolds jk jstar = + if (delta (jstar `star` jk) <= injl) then jstar `star` jk else jstar + + -- Go forward one step at a time as much as needed + j_star_17 = bounded_step_delta (< injl) (rho_d.rho_d) j_star_14 + + -- Go back one step if needed + j_star_19 = if (delta (rho_inv_d j_star_17) >= injl) + then rho_inv_d j_star_17 + else j_star_17 + +-- | Analogue of 'fN', working within the cycle determined by a given ideal /J/. +-- ([Hallgren 2006], Section 5.) +fJN :: IdDist -> CLInt -> CLInt -> CLInt -> CLInt -> CLIntP -> (Ideal, CLInt) +fJN ideal_J i j nn ll bigD = + let ((ideal_J', _), diff) = fJN_d ideal_J i j nn ll bigD + in (ideal_J', diff) + +-- | Like 'fJN', but returning an ideal-with-distance not just an ideal. +fJN_d :: IdDist -> CLInt -> CLInt -> CLInt -> CLInt -> CLIntP -> (IdDist, CLInt) +fJN_d ideal_J i j nn ll bigD = + (ideal_KFinal, floor $ (fromIntegral nn) * (injl - (delta ideal_KFinal))) + where + -- Expression "i/N + j/L" + injl = compute_injl i nn j ll + + -- Generate I and K + ideal_I = fst (fN_d i j nn ll bigD) + ideal_K = bounded_reduce (ideal_I `dot` ideal_J) + + -- Step forward/backward as much as needed + ideal_KFinal = + if (delta ideal_K <= injl) + then bounded_step_delta (< injl) (rho_d) ideal_K + else rho_d $ bounded_step_delta (>= injl) (rho_inv_d) ideal_K + +-- ====================================================================== +-- * Classical period-finding + +-- $ Functions for classically finding the regulator and fundamental unit of a field using the period of /f_N/. + +-- ====================================================================== +-- ** Auxiliary functions + +-- | Find the order of an endofunction on an argument. That is, @'order' /f/ /x/@ returns the first /n/ > 0 such that /f/[sup /n/](/x/) = /x/. +-- +-- Method: simple brute-force search/comparison. +order :: (Eq a) => (a -> a) -> a -> Int +order = order_with_projection id + +-- | Given a function /p/, an endofunction /f/, and an argument /x/, returns the first /n/ > 0 such that /p/(/f/[sup /n/](/x/)) = /p/(/x/). +-- +-- Method: simple brute-force search/comparison. +order_with_projection :: (Eq b) => (a -> b) -> (a -> a) -> a -> Int +order_with_projection p f x = 1 + (length $ takeWhile (\y -> p y /= p x) (tail $ iterate f x)) + +-- | Given a function /p/, an endofunction /f/, and an argument /x/, return /f/[sup /n/](/x/), for the first /n/ > 0 such that /p/(/f/[sup /n/](/x/)) = /p/(/x/). +-- +-- Method: simple brute-force search/comparison. +first_return_with_projection :: (Eq b) => (a -> b) -> (a -> a) -> a -> a +first_return_with_projection p f x = head $ dropWhile (\y -> p y /= p x) $ tail $ iterate f x + +-- | Given a bound /b/, a function /p/, an endofunction /f/, and an argument /x/, return /f/[sup /n/](/x/), for the first /n/ > 0 such that /p/(/f/[sup /n/](/x/)) = /p/(/x/), if there exists such an /n/ ≤ /b/. +-- +-- Method: simple brute-force search/comparison. +first_return_with_proj_bdd :: (Eq b) => Int -> (a -> b) -> (a -> a) -> a -> Maybe a +first_return_with_proj_bdd b p f x = listToMaybe $ dropWhile (\y -> p y /= p x) $ take b $ tail $ iterate f x + +-- | Find the period of a function on integers, assuming that it is periodic and injective on its period. That is, @'period' /f/@ returns the first /n/ > 0 such that /f/(/n/) = /f/(0). Method: simple brute-force search/comparison. +period :: (Eq a, Integral int) => (int -> a) -> int +period f = minimum [ n | n <- [1..], f n == f 0 ] + +-- ====================================================================== +-- ** Haskell native arithmetic + +-- $ The functions of this section use Haskell’s native integer and floating computation. + +-- | Find the regulator /R/ = log ε[sub 0] of a field, given the discriminant Δ, +-- by finding (classically) the order of ρ. +-- +-- Uses 'IdDist' and 'rho_d'. +regulator :: CLIntP -> FPReal +regulator bigD = snd $ head $ dropWhile (\(ii,_) -> ii /= calO) $ tail $ iterate rho_d $ (calO,0) + where calO = unit_ideal bigD + +-- | Find the fundamental unit ε[sub 0] of a field, given the discriminant Δ, +-- by finding (classically) the order of ρ. +-- +-- Uses '(Ideal,Number)' and 'rho_num'. +fundamental_unit :: CLIntP -> AlgNum +fundamental_unit bigD = maximum [eps, -eps, 1/eps, -1/eps] + where eps = snd $ first_return_with_projection fst rho_num (calO,1) + calO = unit_ideal bigD + +-- | Find the fundamental solution of Pell’s equation, given /d/. +-- +-- Solutions of Pell’s equations are integer pairs (/x/,/y/) such that +-- /x/,/y/ > 0, and (/x/ + /y/√d)(/x/ – /y/√d) = 1. +-- +-- In this situation, (/x/ + /y/√d) is a unit of the algebraic integers +-- of /K/, and is >1, so we simply search the powers of ε[sub 0] for a +-- unit of the desired form. +fundamental_solution :: CLIntP -> (Integer,Integer) +fundamental_solution d = head pell_solutions + where bigD = bigD_of_d d + eps0 = fundamental_unit bigD + pell_solutions = + [ (round x, round y) | n <- [1..], + let eps@(AlgNum a b _) = eps0^n, + a >= 0, b >= 0, + let x = a, + let y = if bigD == d then b else 2*b, + is_int x, is_int y, + eps * (conjugate eps) == 1] + +-- ====================================================================== +-- ** Fixed-precision arithmetic + +-- $ The functions of this section perform period-finding using fixed-precision arithmetic. +-- This should parallel closely (though at present not exactly, due to the implementations +-- of floating-point operations) the quantum circuit implementations, and hence allows +-- testing of whether the chosen precisions are accurate. + +-- | Find the regulator /R/ = log ε[sub 0] of a field, given the discriminant Δ, +-- by finding (classically) the order of ρ +-- using fixed-precision arithmetic: 'fix_sizes_Ideal' for 'Ideal's, +-- and given an assumed bound /b/ on log[sub 2] /R/. +-- +-- Uses 'IdDist' and 'rho_d'. +regulator_fixed_prec :: Int -> CLIntP -> Maybe FPReal +regulator_fixed_prec b bigD = fmap snd (first_return_with_proj_bdd b' fst rho_d (calO,zero)) + where calO = fix_sizes_Ideal $ unit_ideal bigD + n = n_of_bigD bigD + -- S = 2RN, so this /i/ gives an assumed bound on log_2 S: + i = 1 + b + n + -- Following precisions are as used in 'approximate_regulator_circuit', 'q_fN': + q = 2 + 2 * i + l = 4 + q + n + p = precision_for_fN bigD n l + zero = fprealx (-p) (intm (q - n + p) 0) + -- δ(I, ρ^2 (I)) ≥ √2 for any I, so the order of ρ is at most 2R / (√2 / 2): + b' = ceiling $ 2 * sqrt(2) * (fromIntegral 2^b) + + +{- +Waiting for 'AlgNum' to be rebased using 'IntM' instead of 'Integer'. + +-- | Find the fundamental unit ε[sub 0] of a field, given the discriminant Δ, +-- by finding (classically) the order of ρ, +-- using fixed-precision arithmetic: 'fix_sizes_Ideal' for 'Ideal's, +-- and a given /l/ for the 'AlgNum's generating them. +-- +-- Uses '(Ideal,Number)' and 'rho_num'. +fundamental_unit_with_fixed :: Int -> CLIntP -> AlgNum +fundamental_unit_with_fixed l bigD = maximum [eps, -eps, 1/eps, -1/eps] + where eps = snd $ head $ dropWhile (\(ii,_) -> ii /= calO) $ tail $ iterate rho_num $ (calO,one) + calO = fix_sizes_Ideal $ unit_ideal bigD + one = intm_with_length (Just l) 1 +-} diff --git a/Quipper/Algorithms/CL/RegulatorQuantum.hs b/Quipper/Algorithms/CL/RegulatorQuantum.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/CL/RegulatorQuantum.hs @@ -0,0 +1,504 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | This module implements the specialized quantum operations required in stages 1 and 4 of Hallgren’s algorithm. +-- +-- The key operation for stage 1 is 'q_fN', implementing /f/[sub /N/], the quasi-periodic +-- function used in approximating the regulator. This is the function /h/ of +-- [Jozsa 2003], Sec. 9, discretized with precision 1\//N/ and translated by a +-- specified jitter parameter. +-- +-- The key functions for stage 4 are not yet implemented. These essentially +-- consist of the functions /f/[sub /I/,/N/], analogues of /f/[sub /N/] operating +-- within the equivalence classes of possibly non-principal ideals /I/ (representing +-- other elements of the class group), as described in [Hallgren 2006, Section 5]. + +module Quipper.Algorithms.CL.RegulatorQuantum where + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Arith hiding (q_ext_euclid, q_add, q_mult, q_div_exact, + q_add_in_place, q_add_param_in_place, q_div, + q_mult_param, q_mod_unsigned, q_sub_in_place, + q_increment) +import qualified Quipper.Libraries.Arith as Arith +import Quipper.Libraries.FPReal + +import Quipper.Algorithms.CL.Auxiliary +import Quipper.Algorithms.CL.Types +import Quipper.Algorithms.CL.RegulatorClassical + +import Control.Monad (foldM) + +-- ====================================================================== +-- * Basic operations on ideals + +-- | Send /I/ = \ to /l/\//ka/ /I/ = \<1,/a/,/a/,/b/>. +-- +-- On distances, send δ[sub /I/] to δ[sub /I/] - log (/l/\//ka/). + +-- Implementation note: is it more efficient to multply/divide and then +-- take log, or take logs separately and then add/subtract? +q_normalize :: IdDistQ -> Circ (IdDistQ,IdDistQ) +q_normalize = box "q_normalize" $ \((Ideal bigD k l a b), dist) -> do + let k_bits = qulist_of_qdint_bh k + n = length k_bits + k' <- qinit (intm n 1) + (a,l') <- qc_copy_fun a + (a,a') <- qc_copy_fun a + (b,b') <- qc_copy_fun b + ((k,l,a,dist), dist') <- with_computed_fun + (k,l,a,dist) + (\(k,l,a,dist) -> do + (k,k_clreal) <- q_fromQDInt k + (l,l_clreal) <- q_fromQDInt l + (a,a_clreal) <- q_fromQDInt a + (k_clreal,log_k) <- fprealq_log_with_shape dist k_clreal + (l_clreal,log_l) <- fprealq_log_with_shape dist l_clreal + (a_clreal,log_a) <- fprealq_log_with_shape dist a_clreal + (log_k, dist) <- fprealq_sub_in_place log_k dist + (log_l, dist) <- fprealq_add_in_place log_l dist + (log_a, dist) <- fprealq_sub_in_place log_a dist + return (((k,l,a),(k_clreal,l_clreal,a_clreal),(log_k,log_l,log_a)), dist)) + (\(various, dist) -> do + (dist,dist') <- qc_copy_fun dist + return ((various,dist), dist')) + return ((Ideal bigD k l a b, dist), (Ideal bigD k' l' a' b', dist')) + +-- | Apply the function ρ to an 'IdealQ' together with a distance. +-- See [Jozsa 2003], Sect 6.2, preceding Prop. 21; compare 'rho_d'. + +-- Implementation note: not factored into q_rho plus action on distance, +-- since the two share a bit of computation (c_num). +q_rho_d :: IdDistQ -> Circ (IdDistQ,IdDistQ) +q_rho_d = box "rho" $ \iid@(Ideal bigD m l a b, del) -> do + rho_iid <- with_computed + (do + (_,_,b_sq) <- q_mult b b + b_sq' <- q_sub_param_in_place (fromIntegral bigD) b_sq + (_,c_num) <- q_abs b_sq' + (_,c_denom) <- q_mult_param 4 a + (_,_,c) <- q_div_exact c_num c_denom + let a' = c + (_,b_neg) <- q_negate b + (_,_,b') <- q_tau bigD b_neg a' + (_,_,m') <- q_mult m a + (_,_,l') <- q_mult l a' + (_,_,_,_,d) <- q_ext_euclid m' l' + (_,_,m'') <- q_div_exact m' d + (_,_,l'') <- q_div_exact l' d + let ii' = Ideal bigD a' b' m'' l'' + + -- By definition, del_change = log $ abs $ gamma_bar / 2 * gamma, + -- where gamma = b/2a + (1/2*a)*(sqrt bigD). + -- + -- A few lines of algebra gives: + -- del_change = log $ (b - (sqrt bigD))^2 / (abs $ b^2 - bigD) + -- = log (b - (sqrt bigD))^2 - log (abs $ b^2 - bigD) + (_,b_fp) <- fprealq_of_QDInt_with_shape del b + b_fp <- fprealq_add_param_in_place (negate $ sqrt $ fromIntegral bigD) b_fp + (_,_,b_fp_sq) <- q_mult b_fp b_fp + (_,del_change_1) <- fprealq_log_with_shape del b_fp_sq + (_,del_change_2) <- fprealq_log_with_shape del (fprealx 0 c_num) + del' <- qc_copy del + (_,del') <- fprealq_add_in_place del_change_1 del' + (_,del') <- fprealq_sub_in_place del_change_2 del' + return (ii', del')) + qc_copy + return (iid, rho_iid) + +-- | Apply the function ρ[sup –1] to an 'IdealQ' together with a distance. +-- See [Jozsa 2003], Sec 6.2, preceding Prop. 21, and Sec 6.4; compare 'rho_inv_d'. +q_rho_inv_d :: IdDistQ -> Circ (IdDistQ, IdDistQ) +q_rho_inv_d = box "rho_inv" $ \iid@(Ideal bigD m l a b, del) -> do + rho_inv_iid <- with_computed + (do + -- b' = τ(Δ,-b,a): + (_, b_neg) <- q_negate b + (_, _, b') <- q_tau bigD b_neg a + -- a'' = (Δ - b'^2) / (4*a): + (_, b'_sq) <- q_square b' + (_, a''_num) <- q_negate b'_sq + a''_num <- q_add_param_in_place (fromIntegral bigD) a''_num + (_, a''_denom) <- q_mult_param 4 a + (_, _, a'') <- q_div_exact a''_num a''_denom + (_, _, b'') <- q_tau bigD b' a'' + -- m''/l'' = m*a / l*a'', reduced to lowest terms: + (_, _, m') <- q_mult m a + (_, _, l') <- q_mult l a'' + (_,_,_,_, d) <- q_ext_euclid m' l' + (_, _, m'') <- q_div_exact m' d + (_, _, l'') <- q_div_exact l' d + let ii' = Ideal bigD a'' b'' m'' l'' + + -- Compute del_change as in 'q_rho_d', + -- but using coefficients from ii': + (_,b_fp) <- fprealq_of_QDInt_with_shape del b'' + b_fp <- fprealq_add_param_in_place (negate $ sqrt $ fromIntegral bigD) b_fp + (_,_,b_fp_sq) <- q_mult b_fp b_fp + (_,del_change_1) <- fprealq_log_with_shape del b_fp_sq + (_,_,b_sq) <- q_mult b'' b'' + b_sq' <- q_sub_param_in_place (fromIntegral bigD) b_sq + (_,c_num) <- q_abs b_sq' + (_,del_change_2) <- fprealq_log_with_shape del (fprealx 0 c_num) + del' <- qc_copy del + (_,del') <- fprealq_sub_in_place del_change_1 del' + (_,del') <- fprealq_add_in_place del_change_2 del' + return (ii', del')) + qc_copy + return (iid, rho_inv_iid) + +-- | As 'q_rho_d', but for reduced ideals. + +-- Implementation note: could be optimised a bit, since some of the algebra +-- needed for ρ in the general case is redundant for reduced ideals. +q_rho_red_d :: IdRedDistQ -> Circ (IdRedDistQ,IdRedDistQ) +q_rho_red_d (ii,del) = do + ii <- q_forget_reduced ii + ((ii,del), (ii',del')) <- q_rho_d (ii,del) + ii <- q_assert_reduced ii + ii' <- q_assert_reduced ii' + return ((ii,del), (ii',del')) + +-- | As 'q_rho_inv_d', but for reduced ideals. + +-- Implementation note: could be optimised, like 'q_rho_red_d'. +q_rho_inv_red_d :: IdRedDistQ -> Circ (IdRedDistQ,IdRedDistQ) +q_rho_inv_red_d (ii,del) = do + ii <- q_forget_reduced ii + ((ii,del), (ii',del')) <- q_rho_inv_d (ii,del) + ii <- q_assert_reduced ii + ii' <- q_assert_reduced ii' + return ((ii,del), (ii',del')) + +-- ====================================================================== +-- * Products of ideals + +-- | Compute the ordinary (not necessarily reduced) product of two reduced +-- fractional ideals. +-- +-- This is /I/⋅/J/ of [Jozsa 2003], Sec 7.1, following the description +-- given in Prop. 34. +q_dot_prod :: IdealRedQ -> IdealRedQ -> Circ (IdealRedQ,IdealRedQ,IdealQ) +q_dot_prod = box "q_dot_prod" $ \(IdealRed bigD1 a1 b1) (IdealRed bigD2 a2 b2) -> do + assertM (all_eq [bigD1,bigD2]) "Error: mismatched Δ’s in q_dot_prod." + let bigD = bigD1 + n = qdint_length a1 + + label (a1,b1,a2,b2) ("a1","b1","a2","b2") + ((a1,a2,b1,b2),(k,l,a3,b3)) <- with_computed_fun (a1,a2,b1,b2) + (\(a1,a2,b1,b2) -> do + comment "q_dot_prod, step 1: (khat,uhat,vhat) <- ExtendedEuclid(a1,a2)" + (a1,a2,khat,uhat,vhat) <- q_ext_euclid a1 a2 + label (khat,uhat,vhat) ("khat","uhat","vhat") + comment "q_dot_prod, step 2: (k,u,v) <- ExtendedEuclid(khat,(b1+b2)/2)" + (b1,b2,b1b2) <- q_add b1 b2 + b1b2 <- q_div2 b1b2 + label (b1b2) ("(b1 + b2)/2") + (khat,b1b2,k,x,w) <- q_ext_euclid khat b1b2 + label (k,x,w) ("k","x","w") + comment "q_dot_prod, step 3: a3 := a1a2/k^2. [This should always be an integer.]" + (a1,a2,a1a2) <- q_mult a1 a2 + label (a1a2) ("a1*a2") + (k,k_sq) <- q_square k + label (k_sq) ("k^2") + (a1a2,k_sq,a3) <- q_div_exact a1a2 k_sq + label (a1a2,k_sq,a3) ("a3") + comment "q_dot_prod, step 4: t = (long formula, requiring many intermediate calculations)" + (((a1,b1,a2,b2),(uhat,vhat,k,x,w)),t) <- with_computed_fun + ((a1,b1,a2,b2),(uhat,vhat,k,x,w)) + + (\((a1,b1,a2,b2),(uhat,vhat,k,x,w)) -> do + comment "q_dot_prod, step 4, first summand: x * uhat * a1 * b2" + (x,uhat,x_uhat) <- q_mult x uhat + label x_uhat "x * uhat" + (x_uhat,a1,x_uhat_a1) <- q_mult x_uhat a1 + label x_uhat_a1 "x * uhat * a1" + (x_uhat_a1,b2,x_uhat_a1_b2) <- q_mult x_uhat_a1 b2 + label x_uhat_a1_b2 "x * uhat * a1 * b2" + comment "q_dot_prod, step 4, second summand: x * vhat * a2 * b1" + (x,vhat,x_vhat) <- q_mult x vhat + label x_vhat "x * vhat" + (x_vhat,a2,x_vhat_a2) <- q_mult x_vhat a2 + label x_vhat_a2 "x * vhat * a2" + (x_vhat_a2,b1,x_vhat_a2_b1) <- q_mult x_vhat_a2 b1 + label x_vhat_a2_b1 "x * vhat * a2 * b1" + comment "q_dot_prod, step 4, third summand: w * (b1 * b2 + Delta) / 2" + (b1,b2,b1_b2) <- q_mult b1 b2 + label b1_b2 "b1 * b2" + b1_b2_D <- q_add_param_in_place (fromInteger $ toInteger bigD) b1_b2 + label b1_b2_D "b1 * b2 + Delta" + b1_b2_D_by2 <- q_div2 b1_b2_D + label b1_b2_D_by2 "(b1 * b2 + Delta) / 2" + (w,b1_b2_D_by2,w_b1_b2_D_by2) <- q_mult w b1_b2_D_by2 + label b1_b2_D_by2 "w * (b1 * b2 + Delta) / 2" + comment "q_dot_prod, step 4, sum of all summands:" + (x_uhat_a1_b2,x_vhat_a2_b1,s) <- q_add x_uhat_a1_b2 x_vhat_a2_b1 + (w_b1_b2_D_by2,s) <- q_add_in_place w_b1_b2_D_by2 s + label s "big sum from step 4" + return ((a1,b1,a2,b2), + (uhat,vhat,k,x,w), + (x_uhat,x_uhat_a1,x_uhat_a1_b2), + (x_vhat,x_vhat_a2,x_vhat_a2_b1), + (b1_b2_D_by2,w_b1_b2_D_by2), + s)) + + (\(inputs, (uhat,vhat,k,x,w), subterm1, subterm2, subterm3, s) -> do + comment "q_dot_prod, step 4, final division: t := (big sum) / k" + (s,k,t) <- q_div s k + label t "t" + return ((inputs, (uhat,vhat,k,x,w), subterm1, subterm2, subterm3, s), t)) + + comment "q_dot_prod, step 5: set b3 <- (t mod 2a3) - (a3 - 1)." + (a3,twice_a3) <- q_mult_param 2 a3 + (t,twice_a3,b3) <- q_mod_unsigned t twice_a3 + (a3,b3) <- q_sub_in_place a3 b3 + b3 <- q_increment b3 + label b3 "b3" + + comment "q_dot_prod, step 6: test if (a3 > root Delta), store result as case_a3" + (a3,case_a3) <- q_gt_param a3 (floor (sqrt (fromIntegral bigD))) + label case_a3 "case_a3" + + comment "q_dot_prod, step 7: if (a3 > root Delta), then b3 <- b3 + (floor root Delta) - a3" + b3 <- q_add_param_in_place + (floor (sqrt (fromIntegral bigD))) + b3 `controlled` case_a3 + (a3,b3) <- q_sub_in_place a3 b3 `controlled` case_a3 + + return ((a1,a2,b1,b2),(khat,uhat,vhat),(k,x,w),(a1a2,b1b2,k_sq,t,case_a3,twice_a3),(a3,b3))) + + (\(inputs,temp1,(k,x,w),temp3,(a3,b3)) -> do + comment "q_dot_prod, step 8: copy computed values into place for I3 = I1.I2" + (a3,a3_out) <- qc_copy_fun a3 + (b3,b3_out) <- qc_copy_fun b3 + (k,k_out) <- qc_copy_fun k + l_out <- qinit (intm n 1) + label (k_out,l_out,a3_out,b3_out) "I3" + comment "q_dot_prod: uncompute garbage." + return ((inputs,temp1,(k,x,w),temp3,(a3,b3)) + ,(k_out,l_out,a3_out,b3_out))) + + return (IdealRed bigD1 a1 b1, IdealRed bigD1 a2 b2, Ideal bigD1 k l a3 b3) + +-- | Compute the dot-product of two reduced fractional ideals, all with distance. +q_dot_prod_with_dist :: IdRedDistQ -> IdRedDistQ -> Circ (IdRedDistQ, IdRedDistQ, IdDistQ) +q_dot_prod_with_dist = box "q_dot_prod_with_dist" $ \(ii,dist_ii) (jj,dist_jj) -> do + (ii, jj, ii_jj) <- q_dot_prod ii jj + (dist_ii, dist_jj, dist_ii_jj) <- q_mult dist_ii dist_jj + return ( (ii,dist_ii), (jj,dist_jj), (ii_jj,dist_ii_jj) ) + +-- | Given two reduced ideals-with-distance, compute their star-product, with distance. +-- +-- This is /I/*/J/ of [Jozsa 2003], Sec. 7.1, defined as the first reduced +-- ideal-with-distance following /I/⋅/J/. +q_star_prod :: IdRedDistQ -> IdRedDistQ -> Circ (IdRedDistQ, IdRedDistQ, IdRedDistQ) +q_star_prod = box "q_star_prod" $ \iid jjd -> do + let bigD = bigD_of_IdealRed $ fst iid + + ((iid,jjd), kkd_out) <- with_computed_fun + (iid,jjd) + (\(iid,jjd) -> do + comment "q_star_prod, step 1: K <- 1/ka (I . J)" + label (iid,jjd) (("I","δ(I)"),("J","δ(J)")) + (iid,jjd,ii_jjd) <- q_dot_prod_with_dist iid jjd + label (ii_jjd) ("II.JJ") + (ii_jjd,kkd) <- q_normalize ii_jjd + label (kkd) ("1/ka (II.JJ)") + + comment "q_star_prod, step 2: while K not reduced, set K <- rho(K)" + (kkd_initial,kkd_reduced) <- q_bounded_while_with_garbage + (\(kk,dist) -> do + comment "q_star_prod, step 2, loop conditional: is K reduced yet?" + (kk,c) <- q_is_reduced kk + c <- qnot c + return ((kk,dist),c)) + ((ceiling $ (logBase 2 $ fromIntegral bigD) / 2) + 1) +-- Generally, reduction may require log_2 (a/√D) steps, +-- but here a is a_3 from the dot-product I.J, +-- so a = a_3 = (a1 * a2) / k^2 ≤ a1 * a2; +-- but now a1, a2 ≤ √D since they come from reduced ideals, +-- so a ≤ √D * √D = D, and the bound simplifies. + kkd + (\kkd_old -> do + comment "q_star_prod, step 2, loop body: compute ρ(Κ)" + (kkd_old,kkd_new) <- q_rho_d kkd_old + return (kkd_new,kkd_old)) + + let (ii_jj,dist_ij) = ii_jjd + (kk_reduced,dist_k) = kkd_reduced + + comment "q_star_prod, step 2c: assert that K is now reduced." + kk <- q_assert_reduced kk_reduced + + comment "q_star_prod, step 3: pull K backwards or forwards to be as close as possible to I.J" + -- NB: implementation of the conditional + whiles could almost certainly be improved. + + (dist_k, dist_ij, k_lt_ij) <- q_lt dist_k dist_ij + label k_lt_ij "Initially, δ(K) ≤ δ(I.J)?" + let ii_jjd = (ii_jj,dist_ij) + kkd = (kk,dist_k) + + comment "q_star_prod, step 3a: pull-forwards loop" + ((dist_ij, kkd), (dij', kkd_forwards)) <- q_bounded_while_with_garbage + (\(dist_ij,(kk,dist_k)) -> do + comment "q_star_prod, step 3a, loop condition: is δ(K) ≤ δ(II.JJ) still?" + (dist_k, dist_ij, k_lt_ij) <- q_lt dist_k dist_ij + return ((dist_ij,(kk,dist_k)),k_lt_ij)) + (ceiling $ 3 * (logBase 2 $ fromIntegral bigD) / 2) + (dist_ij,kkd) + (\(dij,kkd_old) -> do + comment "q_star_prod, step 3a, loop body: compute ρ(Κ)" + (kkd_old,kkd_new) <- q_rho_red_d kkd_old + return ((dij,kkd_new),kkd_old)) + + comment "q_star_prod, step 3b: pull-backwards loop" + ((dist_ij, kkd), (dij'', kkd_too_far_back)) <- q_bounded_while_with_garbage + (\(dist_ij,(kk,dist_k)) -> do + comment "q_star_prod, step 3b, loop condition: is δ(K) ≥ δ(II.JJ) still?" + (dist_k, dist_ij, k_gt_ij) <- q_gt dist_k dist_ij + return ((dist_ij,(kk,dist_k)),k_gt_ij)) + (ceiling $ 3 * (logBase 2 $ fromIntegral bigD) / 2) + (dist_ij,kkd) + (\(dij,kkd_old) -> do + comment "q_star_prod, step 3b, loop body: compute ρ^-1(Κ)" + (kkd_old,kkd_new) <- q_rho_inv_red_d kkd_old + return ((dij,kkd_new),kkd_old)) + comment "q_star_prod, step 3b, cleanup: apply ρ once to the output of this loop" + (kkd_too_far_back, kkd_back) <- q_rho_red_d kkd_too_far_back + + return ((iid, jjd, ii_jjd, kkd_initial, kkd, dij', dij'', kkd_too_far_back), k_lt_ij, kkd_forwards, kkd_back)) + + (\(stuff, k_lt_ij, kkd_forwards, kkd_back) -> do + comment "q_star_prod, step 4: Return the result of either first or second loop, depending on test." + kkd_out <- qinit $ qc_false kkd_forwards + (kkd_out,kkd_forwards) <- controlled_not kkd_out kkd_forwards `controlled` k_lt_ij .==. True + (kkd_out,kkd_backwards) <- controlled_not kkd_out kkd_back `controlled` k_lt_ij .==. False + label kkd_out "kkd_out" + return ((stuff, k_lt_ij, kkd_forwards, kkd_back),kkd_out)) + + return (iid, jjd, kkd_out) + +-- | Compute /I/ * /I/, where /I/ is a reduced ideal/distance pair. +q_star_square :: IdRedDistQ -> Circ (IdRedDistQ, IdRedDistQ) +q_star_square = \iid -> with_computed_fun iid qc_copy_fun + (\(iid, iid_copy) -> do + (iid, iid_copy, iid_square) <- q_star_prod iid iid_copy + return ((iid, iid_copy), iid_square)) + +-- ====================================================================== +-- * The function f[sub /N/] + +-- | @'q_fN' Δ /s/ /n/ /l/ /qi/ /j/@: find the minimal ideal-with-distance (/J/,δ[sub /J/]) such that δ[sub /J/] > /x/, where /x/ = /i/\//N/ + /j/\//L/, where /N/ = 2[sup /n/], /L/ = 2[sup /l/]. /qi/ is quantum; other inputs are classical parameters. Return (/i/,/J/,δ[sub /J/]–/x/). Work under the assumption that /R/ < 2[sup /s/]. +-- +-- This is the function /h/ of [Jozsa 2003], Sec. 9, discretized with precision 1\//N/ = 2[sup −/n/], +-- and perturbed by the jitter parameter /j/\//L/. +q_fN :: CLIntP -> Int -> Int -> QDInt -> IntM -> Circ (QDInt,(IdealRedQ,FPRealQ)) +q_fN bigD n l qi j = do + let p = precision_for_fN bigD n l + nn = 2^n + ll = 2^l + q = qdint_length qi +-- Need to figure out a bound /p/ on the precision of the real arithmetic required. +-- It’s tempting to take /p/ = max(/n/,/l/); but I [pll] think we need larger, since if +-- I understand correctly, we want the /final output/ with precision of 2^-n, which +-- requires higher precision in intermediate calculations. + + (qi, (jj, diff)) <- with_computed_fun + qi + (\qi -> do + comment "q_fN, step 1: Precompute x := i/N + j/L, as it used many times." + qi <- return $ fprealx (-n) qi + qj <- qinit (fprealx (-l) j) + (qi,qj,qx) <- fprealq_add_het (-p) (q - n + p) qi qj + label qx "x := i/N + j/L" + + comment "q_fN, step 2: J <- ρ^2(O)." + oo <- qinit $ fix_sizes_IdealRed $ unit_idealRed bigD + dist_o <- qinit $ (fprealx (-p) (intm (q - n + p) 0)) + let ood = (oo,dist_o) + label ood ("O", "δ_O = 0") + + (ood,jjd0) <- q_rho_red_d ood + label jjd0 ("J0", "δ_J0)") + (jjd0,jjd1) <- q_rho_red_d jjd0 + label jjd1 ("J1", "δ_J1)") + + comment "q_fN, step 3: compute the iterated squares of (J1,δ_J1)." + -- Note: quantumly, it is cheaper to compute them all unconditionally, rather than + -- using a conditional loop that stops early, as one might classically. + jjds <- loop_with_indexM + (ceiling $ (fromIntegral q) * (log 2) / (nn * + (snd $ rho_d $ rho_d $ (unit_ideal bigD, 0)))) + [jjd1] + (\i (jjd_prev:jjds_earlier) -> do + (jjd_prev,jjd_new) <- q_star_square jjd_prev + label jjd_new ("J_" ++ show (i+2), "δ_" ++ show (i+2)) + return (jjd_new:jjd_prev:jjds_earlier)) + + comment "q_fN, step 4: compute the greatest product of these ≤ x" + -- Again, it is quantumly cheaper to start at the maximum possible bound, instead of k = M. + + let jjd_star = ood + label jjd_star ("J_*, δ_*") + + (qx, jjd_star, garbage) <- foldM + (\(qx, jjd_star_old, garbage) jjd_k -> do + (jjd_star_old, jjd_k, jjd_star_candidate) <- q_star_prod jjd_star_old jjd_k + let (jj_star_candidate, dist_candidate) = jjd_star_candidate + (dist_candidate, qx, test) <- q_lt dist_candidate qx + let jjd_star_candidate = (jj_star_candidate, dist_candidate) + jjd_star_new <- qinit (qc_false jjd_star_old) + (jjd_star_new, jjd_star_candidate) <- + controlled_not jjd_star_new jjd_star_candidate `controlled` test .==. True + (jjd_star_new, jjd_star_old) <- + controlled_not jjd_star_new jjd_star_old `controlled` test .==. False + label jjd_star_new ("J_*, δ(J_*)") + return (qx, jjd_star_new, (jjd_star_old,jjd_star_candidate,jjd_k,test):garbage)) + (qx, jjd_star, []) + jjds + + label jjd_star ("J_*, δ_*)") + comment "q_fN: (J_*,δ_*) is now the greatest ideal/distance pair ≤ x constructible from the iterated star-squares (J_k,δ_k)." + + comment "q_fN, step 5: apply ρ^2 to (J_*,δ_*) as long as δ_* ≤ x." + ((jjd_star_initial, qx), (jjd_star, qx_copy)) <- q_bounded_while_with_garbage + -- conditional test: + (\((jj_star, dist_star), qx) -> do + (dist_star, qx, test) <- q_le dist_star qx + return (((jj_star, dist_star), qx), test)) + -- bound + (ceiling $ 3 * logBase 2 (fromIntegral bigD) / 2) + -- starting value + (jjd_star, qx) + -- body of loop + (\(jjd_star_old, qx) -> do + (jjd_star_old, rho_jjd_star_old) <- q_rho_red_d jjd_star_old + (rho_jjd_star_old, jjd_star_new) <- q_rho_red_d rho_jjd_star_old + return ((jjd_star_new, qx), (jjd_star_old, rho_jjd_star_old))) + qx <- qc_uncopy_fun qx qx_copy + + comment "q_fN, step 6: apply ρ^{-1} once more if necessary." + (jjd_star_candidate1, jjd_star_candidate2) <- q_rho_inv_red_d jjd_star + + let (jj_star_candidate1, dist_star_candidate1) = jjd_star_candidate1 + (dist_star_candidate1, qx, final_test) <- q_le dist_star_candidate1 qx + let jjd_star_candidate1 = (jj_star_candidate1, dist_star_candidate1) + + -- End of the computation part of the 'with_computed_fun'. + -- Pass on everything we’ve constructed, with the relevant stuff put first. + return (qx, jjd_star_candidate1, jjd_star_candidate2, final_test, + (qi, qj, garbage, jjd0, jjd1, jjd_star_initial, jjd_star_initial))) + + (\(qx, jjd_star_candidate1, jjd_star_candidate2, test, irrelevant) -> do + jjd_star_out <- qinit (qc_false jjd_star_candidate1) + (jjd_star_out, jjd_star_candidate1) <- controlled_not jjd_star_out jjd_star_candidate1 `controlled` test .==. False + (jjd_star_out, jjd_star_candidate1) <- controlled_not jjd_star_out jjd_star_candidate2 `controlled` test .==. True + + let (jj_out, dist_jj) = jjd_star_out + (qx,diff_out) <- fprealq_sub_in_place qx dist_jj + + return ((qx, jjd_star_candidate1, jjd_star_candidate2, test, irrelevant), + (jj_out, diff_out))) + + return (qi, (jj, diff)) diff --git a/Quipper/Algorithms/CL/RegulatorTemplate.hs b/Quipper/Algorithms/CL/RegulatorTemplate.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/CL/RegulatorTemplate.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +-- | An experimental adaptation of the code from "Quipper.Algorithms.CL.Types", "Quipper.Algorithms.CL.Math", etc. to build circuits automatically using Template Haskell and "Quipper.Internal.CircLifting". +-- +-- Extremely incomplete. + +module Quipper.Algorithms.CL.RegulatorTemplate where + +import Quipper +import Text.Printf +import Quipper.Libraries.FPReal +import Quipper.Algorithms.CL.Types +import Quipper.Libraries.Arith +import Control.Monad + +-- * Auxiliary functions specific to the Class Number algorithm + +d_of_ideal :: Ideal -> Integer +d_of_ideal (Ideal bigD m l a b) = d_of_bigD bigD + +d_of_idealQ :: IdealQ -> Integer +d_of_idealQ (Ideal bigD m l a b) = d_of_bigD bigD + +equal_d_of_ideals :: Ideal -> Ideal -> BoolParam +equal_d_of_ideals i j = if ((d_of_ideal i) == (d_of_ideal j)) then PTrue else PFalse + +equal_d_of_idealQs :: IdealQ -> IdealQ -> BoolParam +equal_d_of_idealQs i j = if ((d_of_idealQ i) == (d_of_idealQ j)) then PTrue else PFalse + +template_equal_d_of_ideals :: Circ (IdealQ -> Circ (IdealQ -> Circ BoolParam)) +template_equal_d_of_ideals = return $ \i -> return $ \j -> return (equal_d_of_idealQs i j) + +template_and :: Circ ([Qubit] -> Circ Qubit) +template_and = return $ \qs -> do + result_qubit <- qinit False + qnot result_qubit `controlled` qs + +m_of_ideal :: Ideal -> IntM +m_of_ideal (Ideal bigD m l a b) = m + +l_of_ideal :: Ideal -> IntM +l_of_ideal (Ideal bigD m l a b) = l + +a_of_ideal :: Ideal -> IntM +a_of_ideal (Ideal bigD m l a b) = a + +b_of_ideal :: Ideal -> IntM +b_of_ideal (Ideal bigD m l a b) = b + +template_m_of_ideal :: Circ (IdealQ -> Circ QDInt) +template_m_of_ideal = return $ \(Ideal bigD m l a b) -> return m + +template_l_of_ideal :: Circ (IdealQ -> Circ QDInt) +template_l_of_ideal = return $ \(Ideal bigD m l a b) -> return l + +template_a_of_ideal :: Circ (IdealQ -> Circ QDInt) +template_a_of_ideal = return $ \(Ideal bigD m l a b) -> return a + +template_b_of_ideal :: Circ (IdealQ -> Circ QDInt) +template_b_of_ideal = return $ \(Ideal bigD m l a b) -> return b + +one_of_size :: IntM -> IntM +one_of_size n = + case intm_length n of + Just m -> intm m 1 + Nothing -> error "one_of_size: indeterminate size" + +template_one_of_size :: Circ (QDInt -> Circ QDInt) +template_one_of_size = return (\qx -> qinit $ one_of_size $ qc_false qx) + +-- * Functions from "Quipper.Algorithms.CL.Types" + +-- | Return 'True' if the given ideal is reduced. +build_circuit +isReduced :: Ideal -> Bool +isReduced i = (m_of_ideal i == (one_of_size (m_of_ideal i)) && (l_of_ideal i == a_of_ideal i)) + +-- assertReduced can't really be implemented as a quantum circuit. The closest we could +-- define is an asserted termination, that would throw an error at circuit run-time if +-- the assertion doesn't hold. +-- | An assert function will throw an error if the assertion is False. +assert :: Bool -> a -> a +assert True a = a +assert False _ = error "False Assertion" + +-- | A hand-lifted version of assert, that will produce a circuit run-time error +-- if the assertion doesn't hold. This is done by using an asserted discard. +template_assert :: Circ (Qubit -> Circ (a -> Circ a)) +template_assert = return $ \assertion -> return $ \a -> do + qterm True assertion + return a + +-- | This will throw an error if the given ideal isn't reduced. +-- The corresponding circuit will use an asserted termination, that will throw an +-- error at circuit run-time if the assertion doesn't hold. +build_circuit +assertReduced :: Ideal -> a -> a +assertReduced i rest = + let assertion = isReduced i in + assert assertion rest + +-- | Check if a given ideal equals another ideal. +build_circuit +idealEquals :: Ideal -> Ideal -> Bool +idealEquals i j = case equal_d_of_ideals i j of + PFalse -> error "Comparing two ideals of different d" + PTrue -> and [(m_of_ideal i == m_of_ideal j), + (l_of_ideal i == l_of_ideal j), + (a_of_ideal i == a_of_ideal j), + (b_of_ideal i == b_of_ideal j)] + +-- * Functions from "Quipper.Algorithms.CL.CL" + +-- * Some dummy functions for testing + +data BoolPair = BoolPair Bool Bool + +data QubitPair = QubitPair Qubit Qubit + +boolPair = BoolPair +template_boolPair = return $ \x -> return $ \y -> return $ QubitPair x y +template_BoolPair = QubitPair + +build_circuit +truePair :: BoolPair +truePair = boolPair True True + +{- +build_circuit +myAnd :: BoolPair -> Bool +myAnd (BoolPair x y) = x && y +-} + +build_circuit +myPlus :: Int -> Int -> Int +myPlus x y = x + y + +-- * Some test functions +test_is_reduced :: IO () +test_is_reduced = let zero = qdint_shape 4 + ideal = Ideal 17 zero zero zero zero + in print_generic ASCII (unpack template_isReduced) ideal + +-- * A main function +main :: IO () +main = test_is_reduced + +{- +Notes: + +- it’s not quite clear to me what assumptions CircLifting makes about lingering arguments, linearity, etc. e.g.: should 'template_m_of_ideal' and the like return copies of the components, not the components themselves? Or is this kosher as currently written? + +- I guess at the moment, it *does* assume all input arguments are left lingering, and moreover unmodified (in the sense of the computational basis). A version not assuming this could be written by using the alternate type translation + +#(a -> b) = a -> Circ (a,#b) + +- linearity is much more of an issue! if we write something like + +build_circuit +twice x = x + x + +this may well (depending on implementation of 'template_symb_plus_') build to a non-linear circuit (so, runtime error). With a little more effort we can write examples which will *not* produce runtime errors, but *will* produce incorrect circuit behaviour. + +Solution? One can imagine writing safe circuits like + +add_safe qx qy = if (qd_disjoint qx qy) then add qx qy + else do + ((qx,qy),qz) <- with_computed_fun (qx,qy) + (\(qx,qy) -> do + (qx,qx') <- qc_copy_fun qx + (qy,qy') <- qc_copy_fun qy + return (qx,qy,qx',qy')) + (\(qx,qy,qx',qy') -> + (qx',qy',qz) <- add qx' qy' + return ((qx,qy,qx',qy'),qz)) + return (qx,qy,qz) + +One can even imagine doing this generically, so that add_safe = make_safe q_add. The necessary assumption is just, I think, that q_add leaves qx, qy unmodified. Given a QData method qd_disjoint, this would not I think be hard. + +This may be the wrong solution to the problem, though. Thoughts? + +- It would be really nice if the lifting could deal better with (a) pattern-matching; (b) numeric literals. (e.g. how to write an algebraic operation like (p x = 17*x + 5)? Can write this for 'IntM', but can’t translate it correctly. + +-} diff --git a/Quipper/Algorithms/CL/SmithReduction.hs b/Quipper/Algorithms/CL/SmithReduction.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/CL/SmithReduction.hs @@ -0,0 +1,165 @@ +-- | This module provides functions for reducing (non-square) matrices +-- towards Smith Normal Form, and hence for computing the structure of +-- finitely-presented Abelian groups. +-- +-- The SNF transformation is similar to Gaussian elimination, but over integer matrices, +-- (more generally, matrices over any principal ideal domain) +-- +-- For background on how this is used to compute the structure of Abelian groups, +-- see the MathOverflow question , +-- in particular Greg Kuperberg’s answer . +-- +-- We do not implement full SNF reduction here, but rather just as much as is +-- needed to compute the structure of finitely presented Abelian groups from +-- matrix presentations. + +module Quipper.Algorithms.CL.SmithReduction where + +import Data.Array +import Quipper.Algorithms.CL.Auxiliary + +-- * Matrix type and basic access functions. + +-- | A data type to hold an /m/×/n/ matrix (/M/[sub /ij/]), +-- with entries from an arbitrary type @a@. +-- +-- The fields are: integers /m/ and /n/; a flag /t/ to indicate that a matrix +-- should be considered formally transposed; and an /m/×/n/ array /M/ +-- containing the entries. When /t/ is 'False', /m/ is the number of rows, +-- and /n/ the number of columns; when /t/ is 'True', this is reversed. +-- +-- (The point of the flag is to allow efficient transposition, and hence to +-- allow operations on rows to be implemented in terms of the corresponding +-- operations on columns without loss of efficiency.) +data CLMatrix a = CLMatrix Int Int Bool (Array (Int, Int) a) deriving (Show) + +-- | The transpose of a matrix +transpose :: CLMatrix a -> CLMatrix a +transpose (CLMatrix m n t mtx) = CLMatrix m n (not t) mtx + +-- | The number of rows of a matrix +rows :: CLMatrix a -> Int +rows (CLMatrix m n t _) = if t then n else m + +-- | The number of columns of a matrix +cols :: CLMatrix a -> Int +cols (CLMatrix m n t _) = if t then m else n + +-- | The row indices of a matrix. +row_list :: CLMatrix a -> [Int] +row_list m = [0..((rows m)-1)] + +-- | The column indices of a matrix. +col_list :: CLMatrix a -> [Int] +col_list m = [0..((cols m)-1)] + +-- | An index tuple for a matrix, at a given row and column +idx :: CLMatrix a -> Int -> Int -> (Int, Int) +idx (CLMatrix _ _ t _) i j = if t then (j,i) else (i,j) + +infix 9 !!! + +-- | The matrix entry at a given row and column +(!!!) :: CLMatrix a -> (Int,Int) -> a +(!!!) mm@(CLMatrix m n t mtx) (i,j) = + if (i >= rows mm || j >= cols mm) + then error $ "Matrix entry lookup (!!!): bad index i=" ++ show i ++ ", j=" ++ show j + else mtx ! idx mm i j + +infixl 9 /// + +-- | Update a matrix by a list of (/i/,/j/,/m_i_j/) pairs +-- (all indexes assumed in range of original matrix). +(///) :: CLMatrix a -> [(Int,Int,a)] -> CLMatrix a +(///) mm@(CLMatrix m n t mtx) l = + CLMatrix m n t (mtx // [ (idx mm i j,e) | (i,j,e) <- l ]) + +-- | Construct an 'CLMatrix' from a list such as @[[1,0],[4,-5]]@. +-- +-- Assumes that all inner lists are the same length, +-- and that the overall list is of length ≥1. +matrix_from_list :: [[a]] -> CLMatrix a +matrix_from_list [] = error "matrixFromList: empty list" +matrix_from_list rs@(r0:_) = CLMatrix (length rs) (length r0) False $ + array ((0,0), (length rs - 1, length r0 - 1)) + [ ((i,j),x) | (ri,i) <- zip rs [0..], (x,j) <- zip ri [0..] ] + +-- | Delete a row of a matrix +delete_row :: Int -> CLMatrix a -> CLMatrix a +delete_row i0 mm@(CLMatrix m n t mtx) = + if 0 <= i0 && i0 < rows mm + then + if t then CLMatrix m (n-1) t $ ixmap ((0,0),(m-1,n-2)) (\(j,i) -> (j,f i)) mtx + else CLMatrix (m-1) n t $ ixmap ((0,0),(m-2,n-1)) (\(i,j) -> (f i,j)) mtx + else error "delete_row: row out of range" + where f i = if i < i0 then i else i+1 + +-- | Delete the first column of a matrix +delete_col :: Int -> CLMatrix a -> CLMatrix a +delete_col j0 = transpose . (delete_row j0) . transpose + +-- * Smith reduction + +-- | @'elim_entry_with_pivot' /M/ /i/ /j/ /j'/@: apply elementary column operations +-- to /M/ (equivalently, post-multiply by an invertible matrix) to +-- obtain /M'/ such that /M'/[sub /i/,/j/] is gcd(/M/[sub /i/,/j/], /M/[sub /i/,/j'/]) +-- and /M'/[sub /i/,/j'/] is 0. +elim_entry_with_pivot :: (Integral int) => CLMatrix int -> Int -> Int -> Int -> CLMatrix int +elim_entry_with_pivot m i0 j0 j1 = + let a = m !!! (i0,j0) + b = m !!! (i0,j1) + in if (a == 0 && b == 0) then m + else + let (d,x,y) = extended_euclid a b + a' = a `div` d + b' = b `div` d + -- know that [x a + y b == d] and [d /= 0], so the matrix [[x,y],[−b',a']] + -- is invertible; so premultiplication by it does not change the group + -- presentation (and indeed could be obtained as a combination of elementary + -- column operations). + in m /// [ (i,j0, (x * m !!! (i,j0)) + (y * m !!! (i,j1))) | i <- row_list m ] + /// [ (i,j1, (-b' * m !!! (i,j0)) + (a' * m !!! (i,j1))) | i <- row_list m] + +-- | Given a matrix, repeatedly use 'elim_entry_with_pivot' to put the +-- top row into clean form (/d/,0,…,0). +clean_first_row :: (Integral int) => CLMatrix int -> CLMatrix int +clean_first_row m0 = + foldl (\m j -> elim_entry_with_pivot m 0 0 j) m0 (tail $ col_list m0) + +-- | Dual to 'clean_first_row'. +clean_first_col :: (Integral int) => CLMatrix int -> CLMatrix int +clean_first_col = transpose . clean_first_row . transpose + +-- | Given a matrix, repeatedly apply 'clean_first_row' and its analogue +-- on columns until the first row and column are both in clean form. +clean_first_row_col :: (Integral int) => CLMatrix int -> CLMatrix int +clean_first_row_col m = + if not $ all (==0) [ m !!! (0,j) | j <- tail $ col_list m ] + then clean_first_row_col $ clean_first_row m + else if not $ all (==0) [ m !!! (i,0) | i <- tail $ row_list m ] + then clean_first_row_col $ clean_first_col m + else m + +-- * Structure of Abelian Groups + +-- | Given a matrix, taken as presenting an Abelian group (with generators +-- corresponding to columns of the matrix, and relations specified by the +-- rows), compute the structure constants of the group, not necessarily sorted. +-- +-- That is, return a list of natural numbers [/n/[sub 0],…,/n/[sub /s/]] +-- such that the group given by the input presentation is isomorphic to the +-- product of the cyclic groups ℤ\/(/n/[sub /i/]). +structure_constants_from_matrix :: (Show int, Integral int) => CLMatrix int -> [int] +structure_constants_from_matrix m = + if cols m == 0 then [] + else if rows m == 0 then (replicate (cols m) 0) + else let m' = clean_first_row_col m + in (abs $ m' !!! (0,0)) + : (structure_constants_from_matrix $ delete_row 0 $ delete_col 0 m') + +-- | Given a matrix, taken as presenting an Abelian group, +-- compute the order of the group. +-- +-- Returns 0 if the group is of infinite order. +group_order_from_matrix :: (Show int, Integral int) => CLMatrix int -> int +group_order_from_matrix = product . structure_constants_from_matrix diff --git a/Quipper/Algorithms/CL/Test.hs b/Quipper/Algorithms/CL/Test.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/CL/Test.hs @@ -0,0 +1,227 @@ +-- | Test the Class Number algorithm, and its components, using classical computation + +module Quipper.Algorithms.CL.Test where + +import Quipper +import Quipper.Libraries.Arith +import Quipper.Libraries.FPReal +import Quipper.Algorithms.CL.Auxiliary +import Quipper.Algorithms.CL.Types +import Quipper.Algorithms.CL.RegulatorClassical +import Quipper.Algorithms.CL.CL +import Quipper.Algorithms.CL.SmithReduction +import Data.Ratio +import Data.List + +-- * Sample data + +-- $ Some fairly arbitrarily chosen sample elements of various types, for convenience in testing functions. + +-- ** Matrices + +-- | A sample square matrix +sample_matrix :: CLMatrix Integer +sample_matrix = matrix_from_list [ + [ 8, 16, 16 ], + [ 32, 6, 12 ], + [ 8, -4, -16 ] + ] + +-- | A sample non-square matrix +sample_matrix_2 :: CLMatrix Integer +sample_matrix_2 = matrix_from_list [ + [ 5, 1, 5, 253, 15, -725, 1 ], + [ 253,2,1001,11,23,273,14079 ], + [ 1,-185861,-28,11,91,29,-2717 ], + [ -319,1,-19,11,3146,1,-1 ], + [ 19285,-493,145,25,-1482,1,6647] + ] + +-- | Another sample non-square matrix +sample_matrix_3 :: CLMatrix Integer +sample_matrix_3 = matrix_from_list [ + [ 4, 8, 4 ], + [ 8, 4, 8 ] + ] + +-- ** Ideals and related types + +-- | A sample 'CLReal'. +sample_CLReal :: Int -> FPReal +sample_CLReal l = (fprealx 0 (intm l 0)) + +-- | A sample 'Ideal'. +sample_Ideal :: CLIntP -> Ideal +sample_Ideal bigD = + let l = max (length_for_ab bigD) (length_for_ml bigD) + x = (intm l 0) + in (Ideal bigD x x x x) + +-- | A sample 'IdealQ'. +sample_IdealQ :: CLIntP -> IdealQ +sample_IdealQ = qshape . sample_Ideal + +-- | A sample 'IdealRed'. +sample_IdealRed :: CLIntP -> IdealRed +sample_IdealRed bigD = + let l = max (length_for_ab bigD) (length_for_ml bigD) + x = (intm l 0) + in (IdealRed bigD x x) + +-- | A sample 'IdealRedQ'. +sample_IdealRedQ :: CLIntP -> IdealRedQ +sample_IdealRedQ = qshape . sample_IdealRed + +-- | A sample 'IdDist'. +sample_IdDist :: CLIntP -> IdDist +sample_IdDist bigD = (sample_Ideal bigD, sample_CLReal (length_for_ab bigD)) + +-- | A sample 'IdDistQ'. +sample_IdDistQ :: CLIntP -> IdDistQ +sample_IdDistQ = qshape . sample_IdDist + +-- | A sample 'IdRedDist'. +sample_IdRedDist :: CLIntP -> IdRedDist +sample_IdRedDist bigD = (sample_IdealRed bigD, sample_CLReal (length_for_ab bigD)) + +-- | A sample 'IdRedDistQ'. +sample_IdRedDistQ :: CLIntP -> IdRedDistQ +sample_IdRedDistQ = qshape . sample_IdRedDist + +-- * Testing routines + +-- ** Smith reduction + +-- | Test the Smith Normal Form code. +test_SNF :: IO () +test_SNF = do + flip mapM_ [sample_matrix,sample_matrix_2,sample_matrix_3] $ \m -> do + putStrLn $ show $ m + putStrLn $ show $ structure_constants_from_matrix m + putStrLn $ show $ group_order_from_matrix m + putStrLn "" + +-- ** Class group functions + +-- | Classical period finding (just compare the \"next\" ideal to /O/ and see if +-- it is the same). Takes in the /O/ ideal with appropriate Δ, and returns +-- the circle length (sum δ(I)) and the list of ideals in the first iteration. +period_of_ideals :: (IdDist->IdDist) -> IdDist -> (CLReal, [IdDist]) +period_of_ideals func o = (delta $ last list, list) + where + list = takePeriod False (iterate (\i -> func i) o) + takePeriod :: Bool -> [IdDist] -> [IdDist] + takePeriod got_first_o [] = undefined -- not reached + takePeriod got_first_o (x:xs) = + if (fst x == fst o) then + if (got_first_o) then + [x] -- Have two O's, stop iterating here + else + x : takePeriod True xs -- This was first O, mark as such + else + x : takePeriod got_first_o xs + +-- | Show period string for a given Δ. +show_period_for_bigD :: CLIntP -> String +show_period_for_bigD bigD = + let (delta, ideals) = period_of_ideals rho_d $ (unit_ideal bigD, 0) + in "For bigD=" ++ (show bigD) ++ " the period has " + ++ (show $ (length ideals) - 1) ++ " ideals and sum delta is " + ++ (show delta) + +-- | Show the period for the first /n/ valid Δ's. +show_period_for_many_bigDs :: Int -> IO() +show_period_for_many_bigDs n = do + putStrLn $ unlines $ map (\bigD -> show_period_for_bigD bigD) $ sort $ take n all_bigDs + +-- | Show period string and the list of ideals for a given Δ. +show_period_for_some_bigD :: CLIntP -> IO() +show_period_for_some_bigD bigD = do + putStrLn $ show_period_for_bigD bigD + putStrLn "Fwd rho_d:" + putStrLn $ unlines $ map printIdeal ideals + putStrLn "Inv rho_d:" + putStrLn $ unlines $ map printIdeal invideals + where + (delta, ideals) = period_of_ideals rho_d $ (unit_ideal bigD, 0) + (invdelta, invideals) = period_of_ideals rho_inv_d $ (unit_ideal bigD, 0) + printIdeal ideal = + (show ideal) + ++ " Reduced: " + ++ if (is_reduced $ fst ideal) then "true" else "false" + +-- | Show a list of valid Δ's. +show_bigDs :: Int -> IO() +show_bigDs n = do + putStrLn $ show $ take n all_bigDs + +-- | Explicitly compute first few ideals for some Δ. +first_few :: IO() +first_few = do + putStrLn $ "O :" ++ show j_0 + putStrLn $ "j1/2:" ++ show j_05 + putStrLn $ "j1 :" ++ show j_1 + where + bigD = 17 + j_0 = (unit_ideal bigD, 0) + j_05 = rho_d j_0 + j_1 = rho_d j_05 + +-- | Perform an operation on all ideal pairs that are generated by Δ. +op_all_ideals :: (IdDist -> IdDist -> IdDist) -> String -> CLIntP -> IO() +op_all_ideals op opString bigD = do + putStrLn $ unlines $ [ doOp i j | i <- ideals, j <- ideals ] + where + (delta, ideals_with_o) = period_of_ideals rho_d $ (unit_ideal bigD, 0) + ideals = init ideals_with_o + doOp i j = "(" ++ (show i) ++ ")" ++ opString ++ "(" ++ (show j) ++ ") = " + ++ (show (i_op_j)) + ++ " Reduced:" + ++ (if (is_reduced $ fst i_op_j) then "true" else "false") +-- ++ " rho_d of:" ++ (show $ rho_d i_op_j) + where i_op_j = i `op` j + +-- | The the product of all pairs of ideals for a given Δ. +dot_all_ideals :: CLIntP -> IO() +dot_all_ideals bigD = op_all_ideals dot "." bigD + +-- | Take the star product of all pairs of ideals for a given Δ. +star_all_ideals :: CLIntP -> IO() +star_all_ideals bigD = op_all_ideals star "*" bigD + +-- | Test the 'bounded_while' functionality. +test_bounded_while :: (Show int, Integral int) => int -> int -> IO() +test_bounded_while bound start = do + putStrLn $ show $ + bounded_while (\k -> k > 0) bound + (\k -> k-1) start + +-- | Run classical tests for Class Number algorithm. +main :: IO() +main = do +-- test_bounded_while 10 5 +-- putStrLn $ "a=23, b=-41, bigD=28, tau =" ++ show (tau (-41) 23 28) +-- putStrLn $ "a=23, b=-41, bigD=28, itau=" ++ show (itau (-41) 23 28) +-- putStrLn $ unlines $ testTauForDelta 28 tau +-- first_few +-- showDs 50 +-- showPeriodForManyBigDs 400 +-- show_period_for_some_bigD 28 +-- dot_all_ideals 28 + star_all_ideals 28 +-- putStrLn $ show $ rho_d $ (Ideal 28 1 1 9 8, 0) + +-- putStrLn $ show $ take 100 all_small_ds +-- putStrLn $ show $ sort $ take 100 all_bigDs + +-- For bigD=2524 the period has 48 ideals and sum delta is 41.3199021281136 + +-- putStrLn $ show $ continued_list 649 200 +-- putStrLn $ show $ convergents $ continued_list 649 200 + +-- | Test the primes code. +test_primes :: IO () +test_primes = do +-- putStrLn $ show $ jacobi_symbol 1001 9907 +-- putStrLn $ show $ jacobi_symbol 14 7 + putStrLn $ show $ primes_to 8000 diff --git a/Quipper/Algorithms/CL/Types.hs b/Quipper/Algorithms/CL/Types.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/CL/Types.hs @@ -0,0 +1,639 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This module defines the specialized datatypes of the Class Number algorithm, and basic utility functions on these types. +module Quipper.Algorithms.CL.Types where + +import Quipper +import Quipper.Internal +import Data.Typeable +import Data.Ratio + +import Quipper.Libraries.Arith hiding (q_mult_param) +import Quipper.Libraries.FPReal +import Quipper.Algorithms.CL.Auxiliary + +-- =========================================== +-- * Type synonyms + +-- $ First, we define some type synonyms for arithmetic types, selecting which will be used in the functions for the Class Number algorithm. +-- +-- We use three different integer types. For interfacing with quantum computation, we use 'CLInt' := 'IntM'. For efficient classical (i.e. circuit-generation time) computation on potentially large integers, we use 'CLIntP' := 'Integer', Haskell’s arbitrary-precision integers. (Δ, for instance, is taken to be a 'CLIntP'). For small classical integers (typically for register sizes), we use 'Int', Haskell’s bounded-precision integers. +-- +-- For the first two of these, we define type synonyms, so that they can be swapped out to other types if desired (they are to a large extent modular). For 'Int' we do not, since we make un-coerced use of built-in Haskell functions like 'length' which give it specifically. +-- +-- Where not dictated by these conventions, integer types are generalized, i.e., @(Integral a) =>@ … +-- +-- Rational and real numbers have not yet been similarly stratified. + +-- | Integers that may be passed into or received out of quantum computations. +type CLInt = IntM + +-- | Integers that will be used for parameter computation only, potentially large. +type CLIntP = Integer + +-- | Rational numbers for the Class Number code. +type CLRational = Rational + +-- | Real numbers for the Class Number code. +type CLReal = FPReal + +-- =========================================== +-- * Algebraic number fields + +-- =========================================== +-- ** Discriminants + +-- $ The functions of this subsection are needed only for circuit-generation-time classical computation, not for quantum circuit computation. + +-- | Compute Δ, given /d/. +-- (See [Jozsa 2003], Prop. 6 et seq. We use Δ, or in code /bigD/, +-- where Jozsa uses /D/.) +bigD_of_d :: Integral a => a -> a +bigD_of_d d = case (d `mod` 4) of + 1 -> d + _ -> 4*d + +-- | Compute /d/, given Δ. +-- (Again, see [Jozsa 2003], Prop. 6 et seq.) +d_of_bigD :: Integral a => a -> a +d_of_bigD bigD = case (bigD `mod` 4) of + 0 -> bigD `div` 4 + _ -> bigD + +-- | Check if /d/ is a valid input to Hallgren’s algorithm, +-- i.e. correctly defines a real quadratic number field. +is_valid_d :: (Integral a) => a -> Bool +is_valid_d d = d > 1 && is_square_free d + +-- | Check if /Δ/ is a valid input to Hallgren’s algorithm, +-- i.e. is the discriminant of a real quadratic number field. +-- (Cf. ) +is_valid_bigD :: (Integral a) => a -> Bool +is_valid_bigD bigD = bigD > 1 && case (bigD `mod` 4) of + 1 -> is_square_free bigD + 0 -> (d `mod` 4 == 2 || d `mod` 4 == 3) && is_square_free d + where d = bigD `div` 4 + _ -> False + +-- | The (infinite, lazy) list of all valid inputs /d/, +-- i.e. of all square-free integers above 2. +all_small_ds :: (Integral int) => [int] +all_small_ds = filter (\n -> is_valid_d n) [2..] + +-- | The (infinite, lazy) list of all valid inputs Δ, +-- i.e. of all discriminants of real quadratic number fields. +all_bigDs :: (Integral int) => [int] +all_bigDs = map bigD_of_d all_small_ds + +-- =========================================== +-- ** Field elements + +-- | A data type describing a number in the algebraic number field K = +-- ℚ[√Δ]: @'AlgNum' /a/ /b/ Δ@ represents /a/ + /b/√Δ. +-- +-- In general, the type of coefficients may be any type of (classical +-- or quantum) numbers, i.e. an instance of the 'Num' or 'QNum' class. +-- Given this, the algebraic numbers with a fixed Δ will in turn be an +-- instance of 'Num' or 'QNum'. +-- +-- A value @/a/ :: /x/@ may also be used as an @'AlgNumGen' /x/@, with +-- no Δ specified, to represent simply /a/ + 0√Δ; this can be +-- considered polymorphic over all possible values of Δ. +-- +-- This is similar to the use of 'IntM's or 'FPReal's of indeterminate +-- size, although unlike for them, we do not restrict this to the +-- classical case. However, the question of whether an 'AlgNum' has +-- specified √Δ is (like e.g. the length of a list) is a parameter +-- property, known at circuit generation time, not a purely quantum +-- property. +data AlgNumGen a = AlgNum a a CLIntP | AlgNum_indet a deriving (Show) + +-- | The specific instance of 'AlgNumGen' used for classical +-- (parameter) computation. +type AlgNum = AlgNumGen CLRational + +-- | Extract the first co-ordinate of an 'AlgNumGen' +fst_AlgNum :: AlgNumGen a -> a +fst_AlgNum (AlgNum u _ _) = u +fst_AlgNum (AlgNum_indet u) = u + +-- | Extract the second co-ordinate of an 'AlgNumGen' +snd_AlgNum :: (Num a) => AlgNumGen a -> a +snd_AlgNum (AlgNum _ v _) = v +snd_AlgNum (AlgNum_indet _) = 0 + +instance (Eq a, Num a) => Eq (AlgNumGen a) where + (AlgNum a b bigD) == (AlgNum a' b' bigD') = + if bigD == bigD' then a == a' && b == b' + else error "Operation = on AlgNum: operands must have same Δ." + (AlgNum a b bigD) == (AlgNum_indet a') = (AlgNum a b bigD) == (AlgNum a' 0 bigD) + (AlgNum_indet a) == (AlgNum a' b' bigD') = (AlgNum a 0 bigD') == (AlgNum a' b' bigD') + (AlgNum_indet a) == (AlgNum_indet a') = a == a' + +-- | Print an algebraic number in human-readable (though not +-- Haskell-readable) format, as e.g. /a/ + /b/√Δ. +pretty_show_AlgNum :: Show a => AlgNumGen a -> String +pretty_show_AlgNum (AlgNum a b bigD) = (show a) ++ " + " ++ (show b) ++ " √" ++ show bigD +pretty_show_AlgNum (AlgNum_indet a) = show a + +-- | Realize an algebraic number as a real number (of any 'Floating' type). +floating_of_AlgNum :: (Real a, Floating b) => AlgNumGen a -> b +floating_of_AlgNum (AlgNum a b bigD) = (realToFrac a) + (realToFrac b) * (sqrt $ fromIntegral bigD) +floating_of_AlgNum (AlgNum_indet a) = (realToFrac a) + +-- | Coerce one algebraic number into the field of a second, if possible. If not possible (i.e. if their Δ’s mismatch), throw an error. +number_promote :: Num a => AlgNumGen a -> AlgNumGen b -> ErrMsg -> AlgNumGen a +number_promote (AlgNum a b bigD) (AlgNum _ _ bigD') e = + if bigD == bigD' then AlgNum a b bigD + else error $ e "mismatched Δ." +number_promote (AlgNum_indet a) (AlgNum _ _ bigD') _ = AlgNum a 0 bigD' +number_promote n (AlgNum_indet _) _ = n + +instance (Ord a, Num a) => Ord (AlgNumGen a) where + compare (AlgNum a b bigD) (AlgNum a' b' bigD') = + if bigD == bigD' then + case (compare a a', compare b b') of + (EQ,y) -> y + (x,EQ) -> x + (GT,GT) -> GT + (LT,LT) -> LT + (GT,LT) -> compare ((a-a')^2) ((b-b')^2 * fromInteger bigD) + (LT,GT) -> compare ((b-b')^2 * fromInteger bigD) ((a-a')^2) + else + error "compare // AlgNumGen: mismatched Δ." + compare (AlgNum a b bigD) (AlgNum_indet a') = compare (AlgNum a b bigD) (AlgNum a' 0 bigD) + compare (AlgNum_indet a) (AlgNum a' b' bigD') = compare (AlgNum a 0 bigD') (AlgNum a' b' bigD') + compare (AlgNum_indet a) (AlgNum_indet a') = compare a a' + +instance (Ord a, Num a) => Num (AlgNumGen a) where + (AlgNum a b bigD) + (AlgNum a' b' bigD') = + if bigD == bigD' then AlgNum (a+a') (b+b') bigD + else error "Operation + on AlgNum: operands must have same Δ." + (AlgNum a b bigD) + (AlgNum_indet a') = (AlgNum a b bigD) + (AlgNum a' 0 bigD) + (AlgNum_indet a) + (AlgNum a' b' bigD') = (AlgNum a 0 bigD') + (AlgNum a' b' bigD') + (AlgNum_indet a) + (AlgNum_indet a') = (AlgNum_indet (a + a')) + + (AlgNum a b bigD) * (AlgNum a' b' bigD') = + if bigD == bigD' then AlgNum (a*a' + b*b'*(fromIntegral bigD)) (a*b' + a'*b) bigD + else error "Operation * on AlgNum: operands must have same Δ." + (AlgNum a b bigD) * (AlgNum_indet a') = (AlgNum a b bigD) * (AlgNum a' 0 bigD) + (AlgNum_indet a) * (AlgNum a' b' bigD') = (AlgNum a 0 bigD') * (AlgNum a' b' bigD') + (AlgNum_indet a) * (AlgNum_indet a') = (AlgNum_indet (a * a')) + + (AlgNum a b bigD) - (AlgNum a' b' bigD') = + if bigD == bigD' then AlgNum (a-a') (b-b') bigD + else error "Operation - on AlgNum: operands must have same Δ." + (AlgNum a b bigD) - (AlgNum_indet a') = (AlgNum a b bigD) - (AlgNum a' 0 bigD) + (AlgNum_indet a) - (AlgNum a' b' bigD') = (AlgNum a 0 bigD') - (AlgNum a' b' bigD') + (AlgNum_indet a) - (AlgNum_indet a') = (AlgNum_indet (a - a')) + + abs n = if (n >= 0) then n else -n + signum n = number_promote (if n > 0 then 1 else if n == 0 then 0 else (-1)) n + (const "CL.Types: internal error (signum // AlgNum)") + fromInteger = AlgNum_indet . fromInteger + +instance (Real a) => Real (AlgNumGen a) where + toRational = toRational . floating_of_AlgNum + +instance (Ord a, Fractional a) => Fractional (AlgNumGen a) where + fromRational = AlgNum_indet . fromRational + + recip (AlgNum a b bigD) = + let c = (a^2) - (b^2 * (fromIntegral bigD)) + in assert (c /= 0) (if (a == 0 && b == 0) then "CL.Types: divide-by-zero error" + else if is_valid_bigD bigD then "CL.Types: internal error (AlgNum // recip)" + else error "CL.Types: " ++ show bigD ++ " not a valid discriminant") + (AlgNum (a/c) (-b/c) bigD) + recip (AlgNum_indet a) = AlgNum_indet $ recip a + +instance (RealFrac a) => RealFrac (AlgNumGen a) where + properFraction x = (x',x - fromIntegral x') + where x' = truncate $ floating_of_AlgNum x + +-- | The algebraic conjugate: sends /a/ + /b/ √Δ to /a/ - /b/ √Δ. +conjugate :: (Num a) => AlgNumGen a -> AlgNumGen a +conjugate (AlgNum a b bigD) = (AlgNum a (-b) bigD) +conjugate (AlgNum_indet a) = (AlgNum_indet a) + +-- | Test whether an algebraic number is an algebraic integer. +-- +-- (A number is an algebraic integer iff it can be written in the form /m/ + /n/(Δ + √Δ)\/2, where /m/, /n/ are integers. +-- See [Jozsa 2003], proof of Prop. 14.) +is_alg_int :: (Ord a, RealFrac a) => AlgNumGen a -> Bool +is_alg_int (AlgNum a b bigD) = is_int n && is_int m + where +-- solve for m, n in the equation [a + b √D = m + n(Δ + √Δ)/2] + n = 2 * b + m = a - b * fromIntegral bigD +is_alg_int (AlgNum_indet a) = is_int a + +-- | Test whether an algebraic number is a unit of the ring of algebraic integers. +is_unit :: (Ord a, RealFrac a) => AlgNumGen a -> Bool +is_unit n = if n == 0 then False else (is_alg_int n) && (is_alg_int (recip n)) + +-- | The number ω associated to the field /K/. +omega_of_bigD :: CLIntP -> AlgNum +omega_of_bigD bigD = + if (bigD `mod` 4 == 1) + then (AlgNum (1/2) (1/2) bigD) + else (AlgNum 0 1 bigD) + +-- =========================================== +-- * Ideals + +-- | Data specifying an ideal in an algebraic number field. An ideal is described by a tuple +-- (Δ,/m/,/l/,/a/,/b/), representing the ideal +-- +-- /m/\//l/ (/aZ/ + (/b/+√Δ)\/2 /Z/), +-- +-- where moreover we assume and ensure always that the ideal is in /standard form/ ([Jozsa 2003], p.11, Prop. 16). Specifically, +-- +-- * /a/,/k/,/l/ > 0; +-- +-- * 4/a/ | /b/[sup 2] – Δ; +-- +-- * /b/ = τ(/a/,/b/); +-- +-- * gcd(/k/,/l/) = 1 +-- +-- In particular, this gives us bounds on the size of /a/ and /b/, +-- and hence tells us the sizes needed for these registers (see 'length_for_ab' below). +data IdealX x = Ideal CLIntP (XInt x) (XInt x) (XInt x) (XInt x) + deriving (Show, Eq, Typeable) + +-- | Classical parameter specifying an ideal. +type Ideal = IdealX Bool + +-- | Quantum circuit-type counterpart of 'Ideal'. +type IdealQ = IdealX Qubit + +-- | Classical circuit-type counterpart of 'Ideal'. +type IdealC = IdealX Bit + +type instance QCType x y (IdealX z) = IdealX (QCType x y z) +type instance QTypeB Ideal = IdealQ + +instance Show Ideal where + show (Ideal bigD m l a b) = + "Ideal " + ++ show bigD ++ " " + ++ show m ++ " " + ++ show l ++ " " + ++ show a ++ " " + ++ show b + +instance QCLeaf x => QCData (IdealX x) where + + qcdata_mapM ~(Ideal _ msh lsh ash bsh) f g (Ideal bigD m l a b) = do + m' <- qcdata_mapM msh f g m + l' <- qcdata_mapM lsh f g l + a' <- qcdata_mapM ash f g a + b' <- qcdata_mapM bsh f g b + return (Ideal bigD m' l' a' b') + + qcdata_zip ~(Ideal _ msh lsh ash bsh) q c q' c' (Ideal bigD m l a b) (Ideal bigD' m' l' a' b') e + | bigD /= bigD' + = error (e "Ideal exponent mismatch") + | otherwise + = (Ideal bigD m'' l'' a'' b'') + where + m'' = qcdata_zip msh q c q' c' m m' errmsg + l'' = qcdata_zip lsh q c q' c' l l' errmsg + a'' = qcdata_zip ash q c q' c' a a' errmsg + b'' = qcdata_zip bsh q c q' c' b b' errmsg + errmsg x = e ("in Ideal: " ++ x) + + qcdata_promote (Ideal bigD m l a b) (Ideal bigD' m' l' a' b') e + | bigD /= bigD' + = error (e "Ideal exponent mismatch") + | otherwise + = (Ideal bigD m'' l'' a'' b'') + where + m'' = qcdata_promote m m' errmsg + l'' = qcdata_promote l l' errmsg + a'' = qcdata_promote a a' errmsg + b'' = qcdata_promote b b' errmsg + errmsg x = e ("in Ideal: " ++ x) + +-- Labeling of IdealQ is (m,l,a,b). +instance QCLeaf x => Labelable (IdealX x) String where + label_rec (Ideal _ qm ql qa qb) s = do + label_rec qm s `dotted_indexed` "m" + label_rec ql s `dotted_indexed` "l" + label_rec qa s `dotted_indexed` "a" + label_rec qb s `dotted_indexed` "b" + +-- We also provide an alternate labeling by a 4-tuple of strings, in +-- case this is ever useful (maybe for an ideal where the components +-- are called something other than /m/, /l/, /a/, and /b/). +instance Labelable IdealQ (String, String, String, String) where + label_rec (Ideal _ qm ql qa qb) (sm, sl, sa, sb) = do + label_rec qm sm + label_rec ql sl + label_rec qa sa + label_rec qb sb + +instance Eq Ideal where + i1@(Ideal bigD m l a b) == i2@(Ideal bigD' m' l' a' b') + = if (bigD /= bigD') + then error error_string + else (m == m' && l' == l' && a == a' && b == b') + where error_string = "Comparing two ideals of different Δ: " ++ (show i1) ++ "," ++ (show i2) + +-- | Data specifying a reduced ideal, by a tuple (Δ,/a/,/b/); this +-- corresponds to the ideal specified by (Δ,1,/a/,/a/,/b/), i.e., +-- /Z/ + (/b/+√Δ)\/2/a/ /Z/. +data IdealRedX x = IdealRed CLIntP (XInt x) (XInt x) + deriving (Show, Typeable) + +-- | Classical parameter specifying a reduced ideal. +type IdealRed = IdealRedX Bool + +-- | Quantum circuit-type counterpart of 'IdealRed'. +type IdealRedQ = IdealRedX Qubit + +-- | Classical circuit-type counterpart of 'IdealRed'. +type IdealRedC = IdealRedX Bit + +instance Show IdealRed where + show (IdealRed bigD a b) = + "IdealRed " + ++ show bigD ++ " " + ++ show a ++ " " + ++ show b + +instance Eq IdealRed where + i1@(IdealRed bigD a b) == i2@(IdealRed bigD' a' b') + = if (bigD /= bigD') + then error error_string + else (a == a' && b == b') + where error_string = "Comparing two reduced ideals of different Δ: " + ++ (show i1) ++ "," ++ (show i2) + +type instance QCType x y (IdealRedX z) = IdealRedX (QCType x y z) +type instance QTypeB IdealRed = IdealRedQ + +instance QCLeaf x => QCData (IdealRedX x) where + + qcdata_mapM ~(IdealRed _ ash bsh) f g (IdealRed bigD a b) = do + a' <- qcdata_mapM ash f g a + b' <- qcdata_mapM bsh f g b + return (IdealRed bigD a' b') + + qcdata_zip ~(IdealRed _ ash bsh) q c q' c' (IdealRed bigD a b) (IdealRed bigD' a' b') e + | bigD /= bigD' + = error (e "IdealRed exponent mismatch") + | otherwise + = (IdealRed bigD a'' b'') + where + a'' = qcdata_zip ash q c q' c' a a' errmsg + b'' = qcdata_zip bsh q c q' c' b b' errmsg + errmsg x = e ("in IdealRed: " ++ x) + + qcdata_promote (IdealRed bigD a b) (IdealRed bigD' a' b') e + | bigD /= bigD' + = error (e "IdealRed exponent mismatch") + | otherwise + = (IdealRed bigD a'' b'') + where + a'' = qcdata_promote a a' errmsg + b'' = qcdata_promote b b' errmsg + errmsg x = e ("in IdealRed: " ++ x) + +-- Labeling of IdealRedQ is (a,b). +instance QCLeaf x => Labelable (IdealRedX x) String where + label_rec (IdealRed _ qa qb) s = do + label_rec qa s `dotted_indexed` "a" + label_rec qb s `dotted_indexed` "b" + +-- We also provide an alternate labeling by a pair of strings, in case +-- this is ever useful (maybe for an ideal where the two components +-- are called something other than /a/ and /b/). +instance QCLeaf x => Labelable (IdealRedX x) (String, String) where + label_rec (IdealRed _ qa qb) (sa, sb) = do + label_rec qa sa + label_rec qb sb + +-- | An ideal /I/, together with a distance δ for it — that is, /some/ representative, mod /R/, for δ(/I/) as defined on /G/ p.4. +-- Most functions described as acting on ideals need in fact to be seen as a pair of an ideal and a distance for it. +type IdDist = (Ideal,FPReal) + +-- | Quantum analogue of 'IdDist'. +type IdDistQ = (IdealQ,FPRealQ) + +-- | A reduced ideal /I/, together with a distance δ for it. +type IdRedDist = (IdealRed,FPReal) + +-- | Quantum analogue of 'IdRedDist'. +type IdRedDistQ = (IdealRedQ,FPRealQ) + +-- =========================================== +-- ** Trivial access functions + +-- | Extract the /d/ component from an 'IdealQ'. +d_of_Ideal :: IdealX a -> CLIntP +d_of_Ideal (Ideal bigD _ _ _ _) = d_of_bigD bigD + +-- | Extract the /d/ component from an 'IdealRedQ'. +d_of_IdealRed :: IdealRedX a -> CLIntP +d_of_IdealRed (IdealRed bigD _ _) = d_of_bigD bigD + +-- | Extract Δ from an 'IdealQ'. +bigD_of_Ideal :: IdealX a -> CLIntP +bigD_of_Ideal (Ideal bigD _ _ _ _) = bigD + +-- | Extract Δ from an 'IdealRedQ'. +bigD_of_IdealRed :: IdealRedX a -> CLIntP +bigD_of_IdealRed (IdealRed bigD _ _) = bigD + +-- | Extract the delta part from an ideal/distance pair. +delta :: IdDist -> CLReal +delta (Ideal _ _ _ _ _, del) = del + +-- =========================================== +-- ** Assertions, coercions + +-- $ Elements of the types 'Ideal', 'IdealRed', etc are assumed to +-- satisfy certain extra conditions. This section includes functions +-- for checking that these conditions are satisfied, and for safely +-- coercing between these types. + +-- | @'tau' Δ /b/ /a/@: the function τ(/b/,/a/). Gives the representative for /b/ mod /2a/, in a range dependent on /a/ and √Δ. +-- +-- (This doesn't quite belong here, but is included as a prerequisite of the assertions). +tau :: (Integral int, Integral int') => int' -> int -> int -> int +tau bigD b a = mod_with_max b (2*a) max + where + max = if a > root_bigD then a else root_bigD + root_bigD = floor $ sqrt $ fromIntegral bigD + +-- | Return 'True' if the given ideal is in standard form. (Functions should /always/ keep ideals in standard form). +is_standard :: Ideal -> Bool +is_standard (Ideal bigD m l a b) = + (a > 0) && (l > 0) && (m > 0) + && ((bigD - (fromIntegral b)^2) `mod` (4 * (fromIntegral a)) == 0) + && b == tau bigD b a + +-- | Test whether an 'Ideal' is reduced. (An ideal \ is reduced iff /m/ = 1, /l/ = /a/, /b/ ≥ 0 and /b/ + √Δ > 2/a/ ([Jozsa 2003], Prop. 20)). +is_reduced :: Ideal -> Bool +is_reduced (Ideal bigD m l a b) = (m == 1) && (l == a) && (b >= 0) && (b + root_bigD > 2 * a) + where root_bigD = ceiling $ sqrt $ fromIntegral bigD + +-- | Test whether an 'IdealRed' is really reduced. (An ideal \<1,/a/,/a/,/b/> is reduced iff /b/ ≥ 0 and /b/ + √Δ > 2/a/ ([Jozsa 2003], Prop. 20)). +is_really_reduced :: IdealRed -> Bool +is_really_reduced (IdealRed bigD a b) = (b >= 0) && (b + root_bigD > 2 * a) + where root_bigD = ceiling $ sqrt $ fromIntegral bigD + +-- | Coerce an 'IdealRed' to an 'Ideal'. +forget_reduced :: IdealRed -> Ideal +forget_reduced (IdealRed bigD a b) = (Ideal bigD 1 a a b) + +-- | Coerce an 'Ideal' to an 'IdealRed', if it is reduced, or throw an error otherwise. Cf. [Jozsa 2003], Prop. 20. +to_reduced :: Ideal -> IdealRed +to_reduced ii@(Ideal bigD m l a b) = + if is_reduced ii then (IdealRed bigD a b) + else error $ "to_reduced: (" ++ (show ii) ++ ") is not reduced." + +-- | Throw an error if an 'Ideal' is not reduced; otherwise, the identity function. +assert_reduced :: Ideal -> a -> a +assert_reduced ii = + assert (is_reduced ii) ("assert_reduced: (" ++ (show ii) ++ ") is not reduced.") + +-- | Throw an error if an 'IdealRed' is not really reduced; otherwise, the identity function. +assert_really_reduced :: IdealRed -> a -> a +assert_really_reduced ii = + assert (is_really_reduced ii) ("assert_really_reduced: (" ++ (show ii) ++ ") is not reduced.") + +-- | Quantum analogue of 'tau'. @'q_tau' Δ /qb/ /qa/@: compute the representative for /qb/ mod 2/qa/, in a range dependent on /qa/ and √Δ. +q_tau :: CLIntP -> QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_tau bigD = box ("tau, Δ = " ++ show bigD) $ \a b -> do + let root_bigD = floor $ sqrt $ fromIntegral bigD + t <- with_computed + (do + (_, a_gt_rtD) <- q_gt_param a root_bigD + max <- qinit $ qc_false a + (max, _) <- controlled_not max a `controlled` a_gt_rtD + max <- bool_controlled_not max (intm_promote root_bigD max "q_tau: internal error") `controlled` (a_gt_rtD .==. False) + (_, twice_a) <- q_mult_param 2 a + (_, _, _, t) <- q_mod_with_max b twice_a max + return t) + qc_copy + return (a,b,t) + +-- | Test whether a given 'IdealQ' is reduced. \ is reduced iff /m/ = 1, /l/ = /a/, /b/ ≥ 0 and /b/ + √Δ > 2/a/ ([Jozsa 2003], Prop. 20). +q_is_reduced :: IdealQ -> Circ (IdealQ,Qubit) +q_is_reduced = box "is_reduced" $ \qii -> + let bigD = bigD_of_Ideal qii in + with_computed_fun qii + (\(Ideal bigD qm ql qa qb) -> do + test1 <- qinit False + test1 <- qnot test1 `controlled` qm .==. 1 + (ql,qa,test2) <- q_is_equal ql qa + (qb,test3) <- q_ge_param qb 0 + (qa, q2a) <- q_mult_param 2 qa + qx <- q_sub_param_in_place (ceiling $ sqrt $ fromIntegral bigD) q2a + (qb, qx, test4) <- q_gt qb qx + return ([test1,test2,test3,test4], (qm,ql,qa,qb,qx))) + (\(tests, rest) -> do + test_out <- qinit False + test_out <- qnot test_out `controlled` tests + return ((tests, rest), test_out)) + +-- | Test whether a given 'IdealQ' is really reduced (as it should always be, if code is written correctly). An ideal \<1,/a/,/a/,/b/> is reduced iff /b/ ≥ 0 and /b/ + √Δ > 2/a/ ([Jozsa 2003], Prop. 20). +q_is_really_reduced :: IdealRedQ -> Circ (IdealRedQ,Qubit) +q_is_really_reduced = box "is_really_reduced" $ \qii -> + let bigD = bigD_of_IdealRed qii in + with_computed_fun qii + (\(IdealRed bigD qa qb) -> do + (qb,test1) <- q_ge_param qb 0 + (qa, q2a) <- q_mult_param 2 qa + qx <- q_sub_param_in_place (ceiling $ sqrt $ fromIntegral bigD) q2a + (qb, qx, test2) <- q_gt qb qx + return ([test1,test2], (qa,qb,qx))) + (\(tests, rest) -> do + test_out <- qinit False + test_out <- qnot test_out `controlled` tests + return ((tests, rest), test_out)) + +-- | Coerce an 'IdealRedQ' to an 'IdealQ', initializing the extra components appropriately. +q_forget_reduced :: IdealRedQ -> Circ IdealQ +q_forget_reduced = box "forget_reduced" $ \(IdealRed bigD a b) -> do + let a_bits = qulist_of_qdint_bh a + n = length a_bits + m <- qinit (intm n 1) + (a,l) <- qc_copy_fun a + return (Ideal bigD m l a b) + +-- | Coerce an 'IdealQ' to an 'IdealRedQ', assertively terminating the extra components +-- (and hence throwing an error at quantum runtime if the input is not reduced). +q_assert_reduced :: IdealQ -> Circ IdealRedQ +q_assert_reduced = box "assert_reduced" $ \x@(Ideal bigD m l a b) -> do + x_red <- reverse_generic q_forget_reduced (IdealRed bigD a b) x + q_assert_really_reduced x_red + +-- | Throw a (quantum-runtime) error if an 'IdealRedQ' is not really reduced; otherwise, do nothing. +-- +-- Compare 'assert_reduced', 'q_is_really_reduced' in "Quipper.Algorithms.CL.RegulatorQuantum", and [Jozsa 2003] Prop. 20. +q_assert_really_reduced :: IdealRedQ -> Circ IdealRedQ +q_assert_really_reduced = box "assert_really_reduced" $ \ii -> do + (ii,test) <- q_is_really_reduced ii + qterm True test + return ii + +-- ====================================================================== +-- ** Bounds on coefficient sizes + +-- $ Given Δ, how much space should be allocated for the coefficients of ideals? Most of these bounds are currently missing or uncertain, as documented below. Note these bounds are intended to be sufficient for the calculations occurring in this algorithm, /not/ for representing arbitrary ideals. + +-- | Given Δ, return the size of integers to be used for the coefficients /a/, /b/ of reduced ideals. +-- +-- Note: can we bound this more carefully? In reduced ideals, we always have 0 ≤ /a/,/b/ ≤ √Δ (see notes on 'is_standard', 'is_reduced'), and the outputs of ρ, ρ[sup –1] and dot-products of reduced ideals always keep |/a/| ≤ Δ. However, intermediate calculations may involve larger values, so we allocate a little more space. For now, this padding is a seat-of-the-pants estimate. +length_for_ab :: CLIntP -> Int +length_for_ab bigD = 3 + (ceiling $ logBase 2 $ fromIntegral bigD) + +-- | Given Δ, return the size of integers to be used for the coefficients /m/, /l/ of general ideals. +-- +-- TODO: bound this! Neither Hallgren nor [Jozsa 2003] discusses bounds on the values of /m/ and /l/ that will appear, and we do not yet have a bound. For now we use the same length as for /a/ and /b/, for convenience; this should be considered a dummy bound, quite possibly not sufficient in general. +length_for_ml :: CLIntP -> Int +length_for_ml = length_for_ab + +-- | Given Δ, return the precision /n/ = log[sub 2]/N/ to be used for +-- discretizing the quasi-periodic function /f/ to /f/[sub /N/]. +-- +-- (“Precision” here means the number of binary digits after the point). +-- +-- Taken to ensure 1\//N/ < 3/(32 Δ log Δ). (Cf. [Jozsa 2003], Prop. 36 (iii).) +n_of_bigD :: (Integral int) => CLIntP -> int +n_of_bigD bigD = + ceiling $ logBase 2 $ 32 * (fromIntegral bigD) * (log $ fromIntegral bigD) / 3 + +-- | Given Δ, /n/, /l/ (as for +-- 'Quipper.Algorithms.CL.RegulatorClassical.fN', +-- 'Quipper.Algorithms.CL.RegulatorQuantum.q_fN'), return the +-- precision required for intermediate distance calculations during +-- the computation of /f/[sub /N/]. +-- +-- TODO: bound this more carefully. [Jozsa 2003] asks for the final output to be precision /n/, but does not discuss intermediate precision, and we have not yet got a confident answer. For now, just a back-of-the-envelope estimate, which should be sufficient and /O/(correct), but is almost certainly rather larger than necessary. +precision_for_fN :: CLIntP -> Int -> Int -> Int +precision_for_fN _ n l = 2 * (n + l) + +-- | Set the 'IntM' coefficients of an 'Ideal' to the standard lengths, if they are not already fixed incompatibly. The standard lengths are determined by 'length_for_ml', 'length_for_ab'. (Compare 'intm_promote', etc.) +fix_sizes_Ideal :: Ideal -> Ideal +fix_sizes_Ideal (Ideal bigD m l a b) = (Ideal bigD (f m) (f l) (f a) (f b)) + where + f x = intm_promote x (intm n 0) "set_sizes_Ideal: lengths already fixed incompatibly" + n = max (length_for_ml bigD) (length_for_ab bigD) + +-- | Set the 'IntM' coefficients of an 'IdealRed' to the standard lengths, if they are not already fixed incompatibly. The standard lengths are determined by 'length_for_ml', 'length_for_ab'. (Compare 'intm_promote', etc.) +fix_sizes_IdealRed :: IdealRed -> IdealRed +fix_sizes_IdealRed (IdealRed bigD a b) = (IdealRed bigD (f a) (f b)) + where + f x = intm_promote x (intm n 0) "set_sizes_Ideal: lengths already fixed incompatibly" + n = max (length_for_ml bigD) (length_for_ab bigD) diff --git a/Quipper/Algorithms/GSE/GSE.hs b/Quipper/Algorithms/GSE/GSE.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/GSE/GSE.hs @@ -0,0 +1,166 @@ +-- | This module provides the main circuit for the GSE algorithm. +-- This circuit consists of a state preparation, followed by a large +-- number of Hamiltonian simulation terms for small time steps, +-- followed by an inverse Quantum Fourier Transform and a final +-- measurement. + +module Quipper.Algorithms.GSE.GSE where + +import Quipper +import Quipper.Libraries.QFT +import Quipper.Algorithms.GSE.GSEData +import Quipper.Algorithms.GSE.JordanWigner + +import Control.Monad +import Text.Printf + +-- ---------------------------------------------------------------------- +-- * Basic time step + +-- $ These functions provide one- and two-electron operators for an +-- individual Trotter time step θ. Each operator consists of a large +-- number of individual Hamiltonian terms. + +-- | Apply the one-electron operator [exp -/i/θ/H/], where +-- /H/ = /h/[sub /pq/] /a/[sub /p/][sup †]/a/[sub /q/] if /p/ = /q/ and +-- /H/ = /h/[sub /pq/] (/a/[sub /p/][sup †]/a/[sub /q/] +-- + /a/[sub /q/][sup †]/a/[sub /p/]) otherwise, to every pair of +-- qubits /p/≥/q/ in a register |ψ〉. The inputs are Hamiltonian data +-- /h/, the angle θ, the register |ψ〉, and a control qubit. +exp_pq :: ((Int,Int) -> Double) -> Double -> [Qubit] -> Qubit -> Circ() +exp_pq h theta psi ctl = do + comment_with_label (printf "ENTER: exp_pq (theta=%.3e)" theta) (psi, ctl) ("psi", "ctl") + + for 0 (m-1) 1 $ \p -> do + for 0 (m-1) 1 $ \q -> do + when (p >= q) $ do + one_electron_circuit (theta * h (p,q)) p q psi [ctl] + comment_with_label "EXIT: exp_pq" (psi, ctl) ("psi", "ctl") + where + m = length psi + +-- | Apply the two-electron operator [exp -/i/θ/H/], where +-- /H/ = /h/[sub /pqrs/] +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] if +-- (/p/,/q/) = (/s/,/r/) and /H/ = +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] + +-- /a/[sub /s/][sup †]/a/[sub /r/][sup †]/a/[sub /q/]/a/[sub /p/] +-- otherwise, to every quadruple (/p/, /q/, /r/, /s/) of qubits in a +-- register |ψ〉. To ensure that terms are enumerated exactly once, we +-- only consider indices where (/p/, /q/) ≥ (/s/, /r/) in the +-- lexicographic order (i.e., /p/>/s/ or (/p/=/s/ and /q/≥/r/). The +-- inputs are Hamiltonian data /h/, the angle θ, the register |ψ〉, +-- and a control qubit. +exp_pqrs :: ((Int,Int,Int,Int) -> Double) -> Double -> [Qubit] -> Qubit -> Circ() +exp_pqrs h theta psi ctl = do + comment_with_label (printf "ENTER: exp_pqrs (theta=%.3e)" theta) (psi, ctl) ("psi", "ctl") + + for 0 (m-1) 1 $ \p -> do + for 0 p 1 $ \s -> do -- constraint p >= s built into the loop for efficiency + for 0 (m-1) 1 $ \q -> do + for 0 (m-1) 1 $ \r -> do + when (p > s || (p == s && q >= r)) $ do + two_electron_circuit (0.5 * theta * h(p,q,r,s)) p q r s psi [ctl] + comment_with_label "EXIT: exp_pqrs" (psi, ctl) ("psi", "ctl") + where + m = length psi + +-- | Like 'exp_pqrs', but use the \"orthodox\" circuit template for +-- the Coulomb operator. +exp_pqrs_orthodox :: ((Int,Int,Int,Int) -> Double) -> Double -> [Qubit] -> Qubit -> Circ() +exp_pqrs_orthodox h theta psi ctl = do + comment_with_label (printf "ENTER: exp_pqrs_orthodox (theta=%.3e)" theta) (psi, ctl) ("psi", "ctl") + + for 0 (m-1) 1 $ \p -> do + for 0 p 1 $ \s -> do -- constraint p >= s built into the loop for efficiency + for 0 (m-1) 1 $ \q -> do + for 0 (m-1) 1 $ \r -> do + when (p > s || (p == s && q >= r)) $ do + two_electron_circuit_orthodox (0.5 * theta * h(p,q,r,s)) p q r s psi [ctl] + comment_with_label "EXIT: exp_pqrs_orthodox" (psi, ctl) ("psi", "ctl") + where + m = length psi + +-- ---------------------------------------------------------------------- +-- * Iteration + +-- $ The following function iterates the basic Trotter timestep +-- /N/[sub /k/] times, and also normalizes the maximum energy +-- /E/[sub max]. + +-- | Apply the operator Û[sub k] ≈ +-- [exp /iE/[sub max]τ2[sup /k/]][exp -/iH/τ2[sup /k/]] to |ψ〉. +unitary_hat_at :: GSEData -- ^ The integral data /h/[sub pq] and /h/[sub pqrs]. + -> Int -- ^ The Trotter iteration count /N/[sub /k/]. + -> Double -- ^ The Hamiltonian scaling parameter τ. + -> Double -- ^ The maximum energy /E/[sub max]. + -> Bool -- ^ Use the \"orthodox\" Coulomb operator? + -> Int -- ^ The control qubit index /k/. + -> [Qubit] -- ^ The state |ψ〉. + -> Qubit -- ^ The control qubit /b/[sub /k/]. + -> Circ() +unitary_hat_at gse_data nk tau e_max orth k psi ctl = do + comment_with_label (printf "ENTER: unitary_hat_at (k=%d, nk=%d)" k nk) (psi, ctl) ("psi", "ctl") + -- abbreviate tau 2^k: + let tau2k = tau * 2**(fromIntegral k) + + -- multiply by exp(i E_max tau 2^k) + gse_T_at (-e_max * tau2k) ctl + + let theta = tau2k / (fromIntegral nk) + for 1 nk 1 $ \j -> do + exp_pq h1 theta psi ctl + if orth + then exp_pqrs_orthodox h2 theta psi ctl + else exp_pqrs h2 theta psi ctl + + comment_with_label "EXIT: unitary_hat_at" (psi, ctl) ("psi", "ctl") + + where + h1 = gse_data_h1 gse_data + h2 = gse_data_h2 gse_data + +-- ---------------------------------------------------------------------- +-- * Main circuit + +-- $ The main circuit for the GSE Algorithm. This consists of the +-- initial state preparation, the Trotterized phase estimation +-- circuit, the Quantum Fourier Transform, and the final measurement. + +-- | The main circuit for the GSE Algorithm. +gse :: Int -- ^ The number of precision qubits /b/. + -> Int -- ^ The number of basis functions /M/. + -> Int -- ^ The number of occupied orbitals /N/. + -> GSEData -- ^ The integral data /h/[sub pq] and /h/[sub pqrs]. + -> Double -- ^ The Hamiltonian scaling parameter τ. + -> Double -- ^ The maximum energy /E/[sub max]. + -> (Int -> Int) -- ^ The function /k/ ↦ /N/[sub /k/]. + -> Bool -- ^ Use the \"orthodox\" Coulomb operator? + -> Circ([Bit]) +gse b m o gse_data tau e_max nfun orth = do + comment "ENTER: gse" + + -- set up the state for b and psi + bstate <- qinit (take b (repeat False)) + psi <- qinit (take m (repeat False)) + + -- apply X gate to the first o 'occupied' qubits of psi + sequence_ [ gate_X_at q | q <- take o psi ] + + -- put the b register into superposition + bstate <- mapUnary hadamard bstate + + -- add the U-hat controlled on b + for 0 (b-1) 1 $ \k -> do + let nk = nfun k + unitary_hat_at gse_data nk tau e_max orth k psi (bstate !! k) + + -- apply inverse QFT + bstate <- (reverse_generic_endo qft_little_endian) bstate + + -- perform measurement + mk <- measure bstate + qdiscard psi + + comment_with_label "EXIT: gse" mk "mk" + return mk diff --git a/Quipper/Algorithms/GSE/GSEData.hs b/Quipper/Algorithms/GSE/GSEData.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/GSE/GSEData.hs @@ -0,0 +1,270 @@ +-- | This module contains functions for reading the GSE one- and +-- two-electron integral data from a file, converting this data from +-- spatial to spin indices, and accessing the data. +-- +-- The external interface consists of the type 'GSEData' and the +-- function 'load_gse_data'. +-- +-- The Quipper distribution contains example data files +-- \"@h_1e_ascii@\" and \"@h_2e_ascii@\". These files contain enough +-- data for /M/ = 32 spin orbitals (corresponding to /M/\/2 = 16 +-- spatial orbitals). Note that the example data was randomly +-- generated and is only a mock-up. In actual applications, physically +-- meaningful data should be substituted. + +module Quipper.Algorithms.GSE.GSEData where + +import Data.Array +import Data.Bits +import Data.Char + +-- * Data abstraction + +-- | A data structure describing the GSE Data - the number +-- of integrals and the functions to access the data by index. +data GSEData = GSEData { + + -- | The number of spin orbitals /M/. + gse_data_M :: Int, + + -- | 1-electron integrals /h/[sub p,q] in spin coordinates. + gse_data_h1 :: (Int,Int) -> Double, + + -- | 2-electron integrals /h/[sub p,q,r,s] in spin coordinates. + -- Follows the physics convention for the ordering of indices. + gse_data_h2 :: (Int,Int,Int,Int) -> Double + + } + +instance Show (GSEData) where + show a = "GSEData { size = " ++ show (gse_data_M a) ++ " }" + +-- ---------------------------------------------------------------------- +-- * Reading GSE data from files + +-- $ This section provides function for reading one- and two-electron +-- GSE data from files. The file formats are as follows. The file for +-- the one-electron data consists of lines of the form: +-- +-- > ((i, j), h) +-- +-- where /i/ and /j/ are integer indices in the range from /0/ to +-- /M/−1, and /h/ = /h/[sub i,j] is a real floating point number. +-- Please note that the file contains data for (/i/, /j/) and +-- (/j/, /i/), and that the indices /i/ and /j/ are in /spatial/ +-- coordinates. The file data is sorted in order of increasing /i/, +-- then /j/. +-- +-- The file for the two-electron data consists of lines of the form: +-- +-- > ((i, j, k, l), h) +-- +-- where /i/, /j/, /k/, and /l/ are integer indices in the range from +-- /0/ to /M/−1, and /h/ = /h/[sub i,k,l,j] is a real floating point +-- number. Please note that the indices /i/, /j/, /k/, and /l/ are in +-- /spatial/ coordinates, and the ordering of indices in the file +-- follows the /chemists'/ convention. Also, to save storage space, +-- the file only contains data for /i/ ≥ /j/, /k/ ≥ /l/, and either +-- /i/ > /k/, or /i/ = /k/ and /j/ ≥ /l/. The remaining data must be +-- inferred from symmetries. The file data is sorted in order of +-- increasing /i/, then /j/, then /k/, then /l/. +-- +-- We also note that the data files, and the functions of this module +-- where noted, are the /only/ places where we use Chemists' notation +-- and spatial orbitals. The remainder of our implementation uses +-- physicists' notation and spin orbitals throughout. + +-- | Read the 'GSEData' from two files. The first argument is /M/, the +-- number of spin orbitals. The second and third argument are the +-- filenames for the one-electron and two-electron data, respectively. +-- +-- If the file contains data for more than /M/ spin orbitals, ignore +-- the excess data (this is useful for generating smaller problem +-- sizes for testing). In this case, only the necessary portion of the +-- file is read. If the file contains data for fewer than /M/ spin +-- orbitals, this is silently ignored, but will lead to an +-- \"undefined\" error later. +load_gse_data :: Int -> String -> String -> IO GSEData +load_gse_data size filename1 filename2 = do + content1 <- readFile filename1 + content2 <- readFile filename2 + let spatial_size = (size + 1) `div` 2 + let spacial_data1 = parsefile1 spatial_size content1 + let spacial_data2 = parsefile2 spatial_size content2 + return (GSEData { + gse_data_M = size, + gse_data_h1 = spin1 $ access_1e spacial_data1, + gse_data_h2 = spin2 $ access_2e spacial_data2 + }) + +-- ---------------------------------------------------------------------- +-- * Low-level access functions + +-- | Access 1-electron integral data. The indices are spatial, i.e., +-- they run from 0 to /M/\/2 − 1. +access_1e :: Array (Int, Int) e -> (Int, Int) -> e +access_1e arr tuple = arr ! tuple + +-- | Access 2-electron integral data. The input array is sparse (i.e., +-- contains only one representative of each equivalence class), and +-- uses chemists' conventions. The output uses physicists' +-- conventions. The indices in both input and output are spatial, +-- i.e., they run from 0 to /M/\/2 − 1. +access_2e :: Array (Int, Int, Int, Int) e -> (Int, Int, Int, Int) -> e +access_2e arr (i,k,l,j) = + -- The indices are not in correct order on purpose. We + -- need to express the fact that h_prsq = h[pq|rs] = h[p,q,r,s] = h[i,j,k,l] + arr ! (swap_ijkl $ swap_kl $ swap_ij (i,j,k,l)) + + -- Note that because of symmetries, we have + -- h2(i,j,k,l) = h2(j,i,k,l) + -- h2(i,j,k,l) = h2(i,j,l,k) + -- h2(i,j,k,l) = h2(k,l,i,j) + -- For this reason, and to save space, the file only contains one + -- representative of each equivalence class. + where + swap_ij (i,j,k,l) = if (i < j) then (j,i,k,l) else (i,j,k,l) + swap_kl (i,j,k,l) = if (k < l) then (i,j,l,k) else (i,j,k,l) + swap_ijkl (i,j,k,l) = if ((i < k) || ((i == k) && (j < l))) then (k,l,i,j) else (i,j,k,l) + +-- ---------------------------------------------------------------------- +-- * Low-level parsing functions + +-- | Decide whether a string is a comment. A comment is a line with +-- only whitespace characters, or where the first non-whitespace +-- character is \'\#\'. +is_comment :: String -> Bool +is_comment [] = True +is_comment ('#':t) = True +is_comment (h:t) + | isSpace h = is_comment t + | otherwise = False + +-- | Extract an array from the one-electron file data. We do this +-- lazily, i.e., we stop reading as soon as enough data is found. +-- The resulting array uses spatial indices. +parsefile1 :: Int -> String -> Array (Int, Int) Double +parsefile1 size content = + array ((0,0), (n, n)) list3 + where + n = size-1 + list1 = [ read_line_h1 s | s <- lines content, not (is_comment s) ] + list2 = takeWhile (\((i,j),h) -> i ((Int,Int), Double) + read_line_h1 s = case reads s of + [(x, "")] -> x + _ -> error ("Illegal line: " ++ s ++ " -- expected format ((int, int), double)") + +-- | Extract an array from the two-electron file data. We do this +-- lazily, i.e., we stop reading as soon as enough data is found. The +-- resulting array uses spatial indices in chemists' notation. Also, +-- the output array is sparse; it only contains as much data as the +-- file itself. +parsefile2 :: Int -> String -> Array (Int, Int, Int, Int) Double +parsefile2 size content = + array ((0,0,0,0), (n,n,n,n)) list3 + where + n = size-1 + list1 = [ read_line_h2 s | s <- lines content, not (is_comment s) ] + list2 = takeWhile (\((i,j,k,l),h) -> i ((Int,Int,Int,Int), Double) + read_line_h2 s = case reads s of + [(x, "")] -> x + _ -> error ("Illegal line: " ++ s ++ " -- expected format ((int, int, int, int), double)") + +-- ---------------------------------------------------------------------- +-- * Conversion of spin to spatial indices + +-- | In the molecule we have twice as many orbitals (spin orbitals) +-- than data in the integral file (spatial orbitals). This function +-- converts /h[sub 1]/ from spatial-orbitals (/M/\/2 = 104) to spin +-- orbitals (/M/ = 208). +-- +-- Spin orbitals are indexed by /p/=(/i/, σ/[sub i]/), where /i/ is a spatial +-- index and σ/[sub i]/ is a spin (up or down). For two spin indices +-- /p/=(/i/, σ/[sub i]/) and /q/=(/j/, σ/[sub j]/), the transition integral +-- h[sub pq] is given by the following formula: +-- +-- \[image spin1.png] +-- +-- The Hamiltonian vanishes for σ/[sub i]/ ≠ σ/[sub j]/ because we +-- assume that there is no spin orbital coupling. +-- +-- Given /M/\/2 spatial orbitals, we re-map the spin orbitals to +-- integers from 0 to /M/−1 using the formula /p/ = 2/i/+σ/[sub i]/, +-- where σ[sub i] is 0 or 1. +-- +-- The function 'spin1' inputs (/h[sub ij]/), the table of 1-electron +-- integrals for /M/\/2 spatial orbitals, and outputs the +-- corresponding table (/h[sub pq]/) for /M/ spin orbitals. + +spin1 :: ((Int,Int) -> Double) -> ((Int,Int) -> Double) +spin1 h1 (p,q) = + if sigma_i == sigma_j + then h1 (i,j) + else 0.0 + where + sigma_i = p .&. 1 + i = p `div` 2 + sigma_j = q .&. 1 + j = q `div` 2 + +-- | Like 'spin1', but for 2-electron integrals. Here, the transition +-- integrals in spin coordinates are given by: +-- +-- \[image spin2.png] +-- +-- The Hamiltonian vanishes for σ/[sub i]/ ≠ σ/[sub l]/ or σ/[sub j]/ +-- ≠ σ/[sub k]/ because we assume that there is no spin orbital +-- coupling. +-- +-- The function 'spin2' inputs (/h[sub ijkl]/), the table of +-- 2-electron transition amplitudes for /M/\/2 spatial orbitals, and +-- outputs the corresponding table (/h[sub pqrs]/) for /M/ spin +-- orbitals. Index ordering follows the physicists' convention. + +spin2 :: ((Int, Int, Int, Int) -> Double) -> ((Int, Int, Int, Int) -> Double) +spin2 h2 (p,q,r,s) = + if sigma_i == sigma_l && sigma_j == sigma_k + then h2 (i,j,k,l) + else 0.0 + where + sigma_i = p .&. 1 + i = p `div` 2 + sigma_j = q .&. 1 + j = q `div` 2 + sigma_k = r .&. 1 + k = r `div` 2 + sigma_l = s .&. 1 + l = s `div` 2 + +-- * Testing + +-- | Print the /h/[sub 1] data for 1-electron integrals. +print_1e :: GSEData -> String +print_1e gse_data = unlines $ [ inner_print i j | i <- list, j <- list] + where list = [0..m-1] + inner_print i j = show (i,j) ++ " : " ++ show (h1 (i, j)) + m = gse_data_M gse_data + h1 = gse_data_h1 gse_data + +-- | Print the /h/[sub 2] data for 2-electron integrals. +print_2e :: GSEData -> String +print_2e gse_data = unlines $ [ inner_print i j k l | i <- list, j <- list, k <- list, l <- list] + where list = [0..m-1] + inner_print i j k l = show (i,j,k,l) ++" : " ++ show (h2 (i, j, k, l)) + m = gse_data_M gse_data + h2 = gse_data_h2 gse_data + +-- | A main function to test the GSEData module. +gse_data_test :: Int -> IO () +gse_data_test n = do + gse_data <- load_gse_data n "h_1e_ascii" "h_2e_ascii" + putStr $ print_1e gse_data + putStr $ print_2e gse_data diff --git a/Quipper/Algorithms/GSE/JordanWigner.hs b/Quipper/Algorithms/GSE/JordanWigner.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/GSE/JordanWigner.hs @@ -0,0 +1,692 @@ +-- | This module provides the Jordan-Wigner transformation and +-- symbolic derivation of circuit templates for second quantized +-- interaction terms. It is essentially a fully automated version of +-- the calculations from +-- +-- * James D. Whitfield, Jacob Biamonte, and Alán +-- Aspuru-Guzik. \"Simulation of electronic structure Hamiltonians +-- using quantum computers.\" +-- /Molecular Physics/ 109(5):735–750, 2011. +-- See also . + + +module Quipper.Algorithms.GSE.JordanWigner where + +import Quipper + +import Quipper.Libraries.Decompose + +import Data.Complex +import qualified Data.Map as Map +import Data.Map (Map) + +import Quipper.Utils.Auxiliary (sequence_right_) + +import Text.Printf + +-- ---------------------------------------------------------------------- +-- * Overview + +-- $ For a given tuple of orbital indices, (/p/,/q/) in case of +-- one-electron interactions, or (/p/,/q/,/r/,/s/) in case of two-electron +-- interactions, we first calculate the Jordan-Wigner transformation +-- of the second quantized hermitian interaction terms +-- +-- /a/[sub /p/][sup †]/a/[sub /p/], +-- +-- /a/[sub /p/][sup †]/a/[sub /q/] + /a/[sub /q/][sup †]/a/[sub /p/], +-- +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /q/]/a/[sub /p/], +-- +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] + +-- /a/[sub /s/][sup †]/a/[sub /r/][sup †]/a/[sub /q/]/a/[sub /p/]. +-- +-- Next, we decompose each operator into a linear combination /H/ = +-- λ[sub 1]/M/[sub 1] + ... + λ[sub /n/]/M/[sub /n/] of mutually +-- commuting hermitian tensors. At this point, each summand /M/[sub /j/] +-- in the linear combination will be a tensor product of the following +-- operators (not necessarily in this order): +-- +-- * an even number (possibly zero) of Pauli /X/ operators; +-- +-- * an even number (possibly zero) of Pauli /Y/ operators; +-- +-- * zero or more Pauli /Z/ operators, and +-- +-- * zero or more /D/ operators, where /D/ = σ[sup −]σ[sup +] = (/I/−/Z/)\/2. +-- +-- Note that there may be zero terms in the summation; this happens, +-- for example, for +-- /a/[sub /p/][sup †]/a/[sub /p/][sup †]/a/[sub /r/]/a/[sub /s/], +-- because two electrons cannot occupy the same spin orbital due to +-- their fermionic nature. In this case, /H/ = 0 and [exp -/i/θ/H/] = /I/. +-- +-- Next, we calculate [exp -/i/θ/H/]. Because the summands /M/[sub /j/] +-- commute, we can exponentiate each summand separately, using the formula +-- [exp -/i/θ/H/] = [exp -/i/θλ[sub 1]/M/[sub 1]]⋯[exp -/i/θλ[sub /n/]/M/[sub /n/]]. +-- +-- We then generate the circuit for [exp -/i/θλ[sub /j/]/M/[sub /j/]] +-- by applying a sequence of basis changes until the problem is +-- reduced to a controlled rotation. The basis changes are, in this +-- order: +-- +-- 1. Change each Pauli /X/ operator in /M/[sub /j/] to a Pauli /Z/ +-- operator, and apply a Hadamard basis change to the corresponding +-- qubit. This uses the relation /HXH/ = /Z/. +-- +-- 2. Change each Pauli /Y/ operator in /M/[sub /j/] to a Pauli /Z/ +-- operator, and apply a [bold Y] basis change to the corresponding +-- qubit. Note: the [bold Y] basis change operator is defined in +-- [Whitfield et al.] as /R/[sub /x/](-π\/2) = (/I/+/iX/)\/√2, or +-- equivalently [bold Y] = /SHS/, and satisfies [bold Y][super †]/Y/[bold Y] = +-- /Z/. It should not be confused with the Pauli /Y/ operator. +-- +-- 3. If the operator /M/[sub /j/] contains one or more Pauli /Z/ operators +-- (including those obtained in steps 1 and 2), then do a basis change +-- by a cascade of controlled-not gates to reduce this to a single /Z/ +-- operator. This uses the relation /CNot/ (/Z/⊗/Z/) /CNot/ = /I/⊗/Z/. +-- +-- After these basis changes, the operator /M/[sub /j/] consists of +-- exactly zero or one Pauli /Z/ operator, together with zero or more +-- /D/ operators. To see how to translate this into a controlled +-- rotation, note that for any operator /A/, we have +-- +-- \[image expDA.png] +-- +-- Therefore, each /D/ operator in /M/[sub /j/] turns into a control +-- after exponentiation. The final rotation is then computed by +-- distinguishing two cases: +-- +-- * If /M/[sub /j/] contains a Pauli /Z/ operator, then use the +-- relation [exp -/i/θ/Z/] = /R/[sub /z/](2θ). In this case, the circuit +-- for [exp -/i/θ/M/[sub /j/]] is a controlled /R/[sub /z/](2θ) gate in +-- the position of the /Z/ operator, with zero or more controls in the +-- positions of any /D/ operators. +-- +-- * If /M/[sub /j/] does not contain a Pauli /Z/ operator, then the +-- operation to be performed is a phase change [exp -/i/θ], controlled +-- by the qubits in the positions of the /D/ operators. Note that +-- there must be at least one /D/ operator in this case. Also note +-- that a controlled [exp -/i/θ] gate is identical to a /T/(θ) gate. + +-- ---------------------------------------------------------------------- +-- * Correctness of the templates + +-- $ As outlined above, the functions in this module generate each +-- circuit from first principles, based on the Jordan-Wigner +-- representation of operators and on algebraic transformations. They +-- do not rely on pre-fabricated circuit templates. +-- +-- Based on the automated calculations provided by this module, we +-- have found small typos in the 5 templates provided by [Whitfield +-- et al.] (Table 3, or Table A1 in the arXiv version). +-- +-- * The template for the number-excitation operator is missing a +-- control on its rotation gate. +-- +-- * In the template for the Coulomb operator, the angles are wrong. +-- Moreover, this program finds a simpler template. +-- +-- * In the template for the double excitation operator, the angles +-- are wrong; they should be ±θ\/4 instead of θ. +-- +-- The corrected templates generated by our code are as follows: +-- +-- * Number operator /h/[sub /pp/] /a/[sub /p/][sup †]/a/[sub /p/]. +-- +-- > [image b0-template.png] +-- +-- * Excitation operator /h/[sub /pq/] /a/[sub /p/][sup †]/a/[sub /q/]. +-- +-- > [image b1-template.png] +-- +-- * Coulomb and exchange operators /h/[sub /pqqp/] +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /q/]/a/[sub /p/]. +-- +-- > [image b2-template.png] +-- +-- * Number-excitation operator /h/[sub /pqqr/] +-- (/a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /q/]/a/[sub /r/] + +-- /a/[sub /r/][sup †]/a/[sub /q/][sup †]/a/[sub /q/]/a/[sub /p/]). +-- The sign of ±θ depends on the relative ordering of the indices /p,q,r/. +-- +-- > [image b3-template.png] +-- +-- * Double excitation operator +-- /h/[sub /pqrs/] +-- (/a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] + +-- /a/[sub /s/][sup †]/a/[sub /r/][sup †]/a/[sub /q/]/a/[sub /p/]). +-- The sign of ±θ\/4 in each of the eight terms depends on the relative ordering of the indices /p,q,r,s/. +-- +-- > [image b4-template.png] + +-- ---------------------------------------------------------------------- +-- * Alternate Coulomb templates + +-- $ As noted above, our algorithm found the following template for the +-- Coulomb operator +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /q/]/a/[sub /p/]: +-- +-- > [image b2-template.png] +-- +-- This is simpler than the template given in [Whitfield et al.], even +-- after one accounts for the cost of decomposing the additional +-- controlled /T/(θ) gate into elementary gates. However, an +-- equivalent circuit can also be given that is more similar to the +-- one in [Whitfield et al.] (but with corrected rotation angles): +-- +-- > [image b2-orthodox.png] +-- +-- We call this the \"orthodox\" template, because it is closer to the +-- one specified by Whitfield et al. The program will use the orthodox +-- template if the command line option @--orthodox@ is given, and it +-- will use the simplified template otherwise. + +-- ---------------------------------------------------------------------- +-- * General-purpose auxiliary functions + +-- | Construct a list consisting of /n/ repetitions of some element. +power :: Int -> a -> [a] +power n x = take n $ repeat x + +-- | Extract a list of /n/-1 consecutive pairs from an /n/-element list: +-- +-- > consecutive_pairs [] = [] +-- > consecutive_pairs [1] = [] +-- > consecutive_pairs [1,2] = [(1,2)] +-- > consecutive_pairs [1,2,3] = [(1,2),(2,3)] +-- > consecutive_pairs [1,2,3,4] = [(1,2),(2,3),(3,4)] +consecutive_pairs :: [a] -> [(a,a)] +consecutive_pairs [] = [] +consecutive_pairs [h] = [] +consecutive_pairs (h1:h2:t) = (h1,h2) : consecutive_pairs (h2:t) + +-- ---------------------------------------------------------------------- +-- * Scalars + +-- | The type of complex numbers. Here, we use a floating point +-- representation, although a symbolic representation would also be +-- possible. Since for the purpose of this algorithm, all denominators +-- are powers of 2, the floating point representation is in fact exact. +type Scalar = Complex Double + +-- | The complex number /i/. +i :: Scalar +i = 0 :+ 1 + +-- ---------------------------------------------------------------------- +-- * Basic Gates + +-- | Apply a /R/[sub z](θ)=[exp -/i/θ/Z/\/2] gate. The parameter θ is a +-- Bloch sphere angle. +-- +-- \[image Rz.png] +rotZ_at :: Double -> Qubit -> Circ () +rotZ_at theta q = named_rotation_at "Rz(%)" theta q + +-- | Apply a /G/(θ) gate. This is a global phase change of [exp -/i/θ], +-- so this gate only \"does\" something when it is controlled. +-- Although it is logically a 0-ary gate, we give it a qubit argument +-- to specify where the gate can be drawn in circuit diagrams. +-- +-- \[image G.png] +gse_G_at :: Double -> Qubit -> Circ () +gse_G_at theta q = named_rotation_at "G(%)" theta q + +-- | Apply a /T/(θ) gate. This is a /Z/-rotation, but differs +-- from /R/[sub z](-θ) by a global phase. +-- +-- \[image T.png] +gse_T_at :: Double -> Qubit -> Circ () +gse_T_at theta q = named_rotation_at "T(%)" theta q + +-- | Apply a [bold Y] basis change gate. This is defined as [bold Y] = /SHS/, +-- or equivalently, +-- +-- \[image Y.png] +-- +-- This should not be confused with the Pauli /Y/ gate. +gse_Y_at :: Qubit -> Circ () +gse_Y_at q = named_gate_at "YY" q + +-- ---------------------------------------------------------------------- +-- * Basic operators + +-- | This type provides a symbolic representation of certain +-- operators, generated by the Pauli operators, /P/ = σ[sup +], and +-- /M/ = σ[sup −]. For lack of a better term, we call these the +-- \"basic\" operators. Note that apart from /P/ and /M/, all of these +-- are hermitian. +data Op = + I -- ^ Identity operator. + | X -- ^ Pauli /X/ operator. + | Y -- ^ Pauli /Y/ operator. + | Z -- ^ Pauli /Z/ operator. + | P -- ^ σ[sup +] operator = (0,1;0,0). + | M -- ^ σ[sup −] operator = (0,0;1,0). + | A -- ^ σ[sup +]σ[sup −] operator = (1,0;0,0). + | D -- ^ σ[sup −]σ[sup +] operator = (0,0;0,1). + deriving (Show, Eq, Ord) + +-- | A type to represent scalar multiples. An element of ('Scaled' +-- /a/) is a pair (λ, /x/) of a complex scalar λ and an element /x/ ∈ +-- /a/. +data Scaled a = Scaled Scalar a + +-- | Multiplication of basic operators. Note that the product of two +-- basic operators is not usually itself a basic operator, but a +-- scalar multiple thereof. This multiplication encodes the algebraic +-- laws of basic operators in symbolic form. + +-- Implementation note: the multiplication laws are currently +-- implemented as a long case distinction. Perhaps it could be done +-- more cleverly. +mult :: Op -> Op -> Scaled Op + +-- The Pauli group +mult I x = Scaled 1 x +mult x I = Scaled 1 x + +mult X X = Scaled 1 I +mult X Y = Scaled i Z +mult X Z = Scaled (-i) Y + +mult Y X = Scaled (-i) Z +mult Y Y = Scaled 1 I +mult Y Z = Scaled i X + +mult Z X = Scaled i Y +mult Z Y = Scaled (-i) X +mult Z Z = Scaled 1 I + +-- P, M, D, and A +mult X P = Scaled 1 D +mult X M = Scaled 1 A +mult X A = Scaled 1 M +mult X D = Scaled 1 P + +mult Y P = Scaled i D +mult Y M = Scaled (-i) A +mult Y A = Scaled i M +mult Y D = Scaled (-i) P + +mult Z P = Scaled 1 P +mult Z M = Scaled (-1) M +mult Z A = Scaled 1 A +mult Z D = Scaled (-1) D + +mult P X = Scaled 1 A +mult M X = Scaled 1 D +mult A X = Scaled 1 P +mult D X = Scaled 1 A + +mult P Y = Scaled i A +mult M Y = Scaled (-i) D +mult A Y = Scaled (-i) P +mult D Y = Scaled i M + +mult P Z = Scaled (-1) P +mult M Z = Scaled 1 M +mult A Z = Scaled 1 A +mult D Z = Scaled (-1) D + +mult P P = Scaled 0 I +mult P M = Scaled 1 A +mult P A = Scaled 0 I +mult P D = Scaled 1 P + +mult M P = Scaled 1 D +mult M M = Scaled 0 I +mult M A = Scaled 1 M +mult M D = Scaled 0 I + +mult A P = Scaled 1 P +mult A M = Scaled 0 I +mult A A = Scaled 1 A +mult A D = Scaled 0 I + +mult D P = Scaled 0 I +mult D M = Scaled 1 M +mult D A = Scaled 0 I +mult D D = Scaled 1 D + +-- ---------------------------------------------------------------------- +-- * Tensors of basic operators + +-- | We use a list of basic operators to represent a tensor +-- product. The convention is that infinitely many identity operators +-- are implicitly appended at the end of the list. +type Tensor = [Op] + +-- | Normalize a tensor, by stripping away trailing identities. +normalize_tensor :: Tensor -> Tensor +normalize_tensor [] = [] +normalize_tensor (h:t) = + if h == I && null n + then [] + else (h:n) + where n = normalize_tensor t + +-- | The identity tensor. +tensor_id :: Tensor +tensor_id = [] + +-- | Multiply two tensors. This returns a scaled tensor. +mult_tensor :: Tensor -> Tensor -> Scaled Tensor +mult_tensor [] bs = Scaled 1 bs +mult_tensor as [] = Scaled 1 as +mult_tensor (a:as) (b:bs) = Scaled (x*y) (c:cs) where + Scaled x c = mult a b + Scaled y cs = mult_tensor as bs + +-- | Multiply two scaled tensors. +mult_scaled_tensor :: Scaled Tensor -> Scaled Tensor -> Scaled Tensor +mult_scaled_tensor (Scaled x a) (Scaled y b) = Scaled (x*y*z) c where + Scaled z c = a `mult_tensor` b + +-- ---------------------------------------------------------------------- +-- * Linear combinations of tensors + +-- | A type to represent complex linear combinations of tensors. +type TensorLC = Map Tensor Scalar + +-- | The origin. +lc_zero :: TensorLC +lc_zero = Map.empty + +-- | Add a tensor to a linear combination. +lc_insert :: TensorLC -> Scaled Tensor -> TensorLC +lc_insert lc (Scaled lambda t) = + if newvalue == 0 + then + Map.delete m lc + else + Map.insert m newvalue lc + where + m = normalize_tensor t + newvalue = case Map.lookup m lc of + Nothing -> lambda + Just x -> lambda + x + +-- | Turn a list of scaled tensors into a 'TensorLC'. +lc_from_list :: [Scaled Tensor] -> TensorLC +lc_from_list = foldl lc_insert lc_zero + +-- | Turn a 'TensorLC' into a list of scaled tensors. +lc_to_list :: TensorLC -> [Scaled Tensor] +lc_to_list lc = [Scaled x y | (y,x) <- Map.toList lc] + +-- ---------------------------------------------------------------------- +-- * Jordan-Wigner representation + +-- $ The next two functions provide the Jordan-Wigner representation of +-- (Fock-space) annihilation and creation operators. + +-- | Construct the Jordan-Wigner annihilation operator /a/[sub /p/] = +-- /IIIIPZZZZZ.../ for spin-orbital index /p/. The first parameter is +-- /p/, and the second one is /M/ (the number of spin-orbitals). +-- Precondition: 0 ≤ /p/ < /M/. +jw :: Int -> Int -> Scaled Tensor +jw p m = Scaled 1 (power p I ++ [P] ++ power (m-p-1) Z) + +-- | Construct the Jordan-Wigner creation operator /a/[sub /p/][sup †] +-- = /IIIIMZZZZ.../ for spin-orbital index /p/. The first parameter +-- is /p/, and the second one is /M/ (the number of spin-orbitals). +-- Precondition: 0 ≤ /p/ < /M/. +jw_dagger :: Int -> Int -> Scaled Tensor +jw_dagger p m = Scaled 1 (power p I ++ [M] ++ power (m-p-1) Z) + +-- ---------------------------------------------------------------------- +-- * Second quantized interaction terms + +-- ** Simple interaction terms + +-- | Construct the one-electron second quantized non-hermitianized +-- interaction term /a/[sub /p/][sup †]/a/[sub /q/]. The parameters +-- are /p,q/. +one_electron_operator_simple :: Int -> Int -> Scaled Tensor +one_electron_operator_simple p q = ap * aq + where + ap = jw_dagger p m + aq = jw q m + m = maximum [p,q] + 1 + (*) = mult_scaled_tensor + +-- | Construct the two-electron second quantized non-hermitianized +-- interaction term +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/]. +-- The parameters are /p,q,r,s/. +two_electron_operator_simple :: Int -> Int -> Int -> Int -> Scaled Tensor +two_electron_operator_simple p q r s = ap * aq * ar * as + where + ap = jw_dagger p m + aq = jw_dagger q m + ar = jw r m + as = jw s m + m = maximum [p,q,r,s] + 1 + (*) = mult_scaled_tensor + +-- ** Hermitian interaction terms + +-- | Construct +-- /a/[sub /p/][sup †]/a/[sub /q/] +-- if /p/ = /q/, and +-- /a/[sub /p/][sup †]/a/[sub /q/] + /a/[sub /q/][sup †]/a/[sub /p/] +-- otherwise. +one_electron_operator :: Int -> Int -> TensorLC +one_electron_operator p q = + if p == q + then lc_from_list [a_pq] + else lc_from_list [a_pq, a_qp] + where + a_pq = one_electron_operator_simple p q + a_qp = one_electron_operator_simple q p + +-- | Construct +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] +-- if (/p/,/q/) = (/s/,/r/), and +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] + +-- /a/[sub /s/][sup †]/a/[sub /r/][sup †]/a/[sub /q/]/a/[sub /p/] +-- otherwise. +two_electron_operator :: Int -> Int -> Int -> Int -> TensorLC +two_electron_operator p q r s = + if (p,q) == (s,r) + then lc_from_list [a_pqrs] + else lc_from_list [a_pqrs, a_srqp] + where + a_pqrs = two_electron_operator_simple p q r s + a_srqp = two_electron_operator_simple s r q p + +-- ---------------------------------------------------------------------- +-- * /XYZD/ decomposition + +-- | Decompose a basic operator into linear combinations of hermitian basic operators. +-- This uses the relations /P/ = 1\/2 /X/ + /i/\/2 /Y/ and +-- /M/ = 1\/2 /X/ - /i/\/2 /Y/. +decompose_basis :: Op -> [Scaled Op] +decompose_basis P = [Scaled (1/2) X, Scaled (i/2) Y] +decompose_basis M = [Scaled (1/2) X, Scaled (-i/2) Y] +decompose_basis x = [Scaled 1 x] -- default case: the remaining operators are already hermitian + +-- | Decompose a tensor into a linear combination of hermitian +-- tensors. Due to sign alternation, the individual tensors all come +-- out to commute with each other. +decompose_tensor :: Tensor -> TensorLC +decompose_tensor [] = lc_from_list [Scaled 1 tensor_id] +decompose_tensor (h:t) = + lc_from_list [Scaled (x*y) (g:gs) | + Scaled x g <- decompose_basis h, + Scaled y gs <- lc_to_list (decompose_tensor t)] + +-- | Decompose a linear combination of tensors into a linear +-- combination of hermitian tensors. +decompose_tensor_lc :: TensorLC -> TensorLC +decompose_tensor_lc lc = + lc_from_list [ Scaled (x*y) g | + Scaled x gs <- lc_to_list lc, + Scaled y g <- lc_to_list (decompose_tensor gs)] + +-- ---------------------------------------------------------------------- +-- * Exponentiation and circuit generation + +-- | Given a simple hermitian tensor /H/ and an angle θ, generate a +-- circuit for [exp -/i/θ/H/]. The given list of input qubits is in +-- the same order as the operators in /H/. Precondition: /H/ is made +-- up of zero or more identity operators and one or more of the +-- operators /X/, /Y/, /Z/, and /D/. The last parameter is a list of +-- additional controls. + +exponentiate_simple :: Scaled Tensor -> Double -> [Qubit] -> [Qubit] -> Circ () +exponentiate_simple (Scaled s ms) theta qs ctl = do + -- First analyze the tensor: + let + -- Find all X positions + xs = [ i | (m, i) <- zip ms [0,1..], m == X ] + -- Find all Y positions + ys = [ i | (m, i) <- zip ms [0,1..], m == Y ] + -- Find all X, Y, Z positions + zs = [ i | (m, i) <- zip ms [0,1..], m `elem` [X, Y, Z] ] + -- Find all D positions + ds = [ i | (m, i) <- zip ms [0,1..], m == D ] + basischange xs ys zs qs + rotation alpha ds zs `controlled` ctl + reverse_generic_imp (basischange xs ys zs) qs + where + alpha = theta * realPart s + basischange :: [Int] -> [Int] -> [Int] -> [Qubit] -> Circ () + basischange xs ys zs qs = do + -- for every X or Y in the operator, apply the appropriate basis + -- change to change it to Z. + sequence_ [ hadamard_at (qs !! i) | i <- xs ] + sequence_ [ gse_Y_at (qs !! i) | i <- ys ] + -- apply a cascade of c-not operators to all X, Y, or Z in the + -- operator + sequence_right_ [ qnot_at (qs !! i0) `controlled` (qs !! i1) | (i0,i1) <- consecutive_pairs zs] + rotation :: Timestep -> [Int] -> [Int] -> Circ () + rotation alpha ds zs = do + case zs of + [] -> -- if there are no Z operators, produce a controlled + -- e^{-iα} gate. + case ds of + [] -> error "exponentiate_simple: precondition violated" + d:ds' -> gse_T_at alpha (qs !! d) `controlled` [qs !! d' | d' <- ds'] + z:zs' -> -- if there are Z operators, produce a controlled + -- e^{-iαZ} gate. + rotZ_at (2*alpha) (qs !! z) `controlled` [qs !! d | d <- ds] + +-- | Given a tensor /H/ (already decomposed into commuting simple +-- tensors) and an angle θ, generate a circuit for [exp -/i/θ/H/]. +-- The given list of input qubits is in the same order as the +-- operators in /H/. +exponentiate :: TensorLC -> Double -> [Qubit] -> [Qubit] -> Circ () +exponentiate lc theta qs ctl = + sequence_ [ exponentiate_simple a theta qs ctl | a <- lc_to_list lc ] + +-- ---------------------------------------------------------------------- +-- * Generate top-level templates + +-- | @'one_electron_circuit' theta p q@: Generate the circuit for the +-- hermitianized one-electron interaction with spin-orbital indices +-- /p/, /q/. More precisely, generate [exp -/i/θ/H/], where +-- /H/ = /a/[sub /p/][sup †]/a/[sub /q/] if /p/ = /q/ and +-- /H/ = /a/[sub /p/][sup †]/a/[sub /q/] +-- + /a/[sub /q/][sup †]/a/[sub /p/] otherwise. +-- +-- This function recognizes an important special case: if θ=0.0, don't +-- generate any gates at all. The case θ=0.0 frequently arises because +-- of the conversion from spatial orbitals to spin orbitals. +one_electron_circuit :: Double -> Int -> Int -> [Qubit] -> [Qubit] -> Circ () +one_electron_circuit 0.0 p q qs ctl = return () +one_electron_circuit theta p q qs ctl = do + comment_with_label (printf "ENTER: one_electron_circuit (theta=%.3e, p=%d, q=%d)" theta p q) (qs,ctl) ("qs","ctl") + exponentiate op theta qs ctl + comment_with_label "EXIT: one_electron_circuit" (qs,ctl) ("qs","ctl") + where + op = decompose_tensor_lc (one_electron_operator p q) + +-- | @'two_electron_circuit' theta p q r s@: +-- Generate the circuit for the hermitianized two-electron interaction +-- with spin-orbital indices /p/, /q/, /r/, /s/. More precisely, generate +-- [exp -/i/θ/H/], where +-- /H/ = /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] if +-- (/p/,/q/) = (/s/,/r/) and /H/ = +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] + +-- /a/[sub /s/][sup †]/a/[sub /r/][sup †]/a/[sub /q/]/a/[sub /p/] +-- otherwise. +-- +-- This function recognizes an important special case: if θ=0.0, don't +-- generate any gates at all. The case θ=0.0 frequently arises because +-- of the conversion from spatial orbitals to spin orbitals. +two_electron_circuit :: Double -> Int -> Int -> Int -> Int -> [Qubit] -> [Qubit] -> Circ () +two_electron_circuit 0.0 p q r s qs ctl = return () +two_electron_circuit theta p q r s qs ctl = do + comment_with_label (printf "ENTER: two_electron_circuit (theta=%.3e, p=%d, q=%d, r=%d, s=%d)" theta p q r s) (qs,ctl) ("qs","ctl") + exponentiate op theta qs ctl + comment_with_label "EXIT: two_electron_circuit" (qs,ctl) ("qs","ctl") + where + op = decompose_tensor_lc (two_electron_operator p q r s) + +-- | Like 'two_electron_circuit', but use the \"orthodox\" circuit +-- template for the Coulomb operator /a/[sub /p/][sup †]/a/[sub +-- /q/][sup †]/a/[sub /q/]/a/[sub /p/]. This generates a circuit using +-- three rotations, similar to [Whitfield et al.], but with corrected +-- angles, +-- +-- > [image b2-orthodox.png] +-- +-- instead of the simpler circuit that 'two_electron_circuit' would +-- normally generate: +-- +-- > [image b2-template.png] + +two_electron_circuit_orthodox :: Double -> Int -> Int -> Int -> Int -> [Qubit] -> [Qubit] -> Circ () +two_electron_circuit_orthodox 0.0 p q r s qs ctl = return () +two_electron_circuit_orthodox theta p q r s qs ctl | q==r && p==s && p/=q = do + comment_with_label (printf "ENTER: two_electron_circuit_orthodox(theta=%.3e, p=%d, q=%d, r=%d, s=%d)" theta p q r s) (qs,ctl) ("qs","ctl") + let pp = qs !! p + qq = qs !! q + gse_G_at (theta/4) pp `controlled` ctl + rotZ_at (-theta/2) pp `controlled` ctl + rotZ_at (-theta/2) qq `controlled` ctl + qnot_at qq `controlled` pp -- control ctl is not needed + rotZ_at (theta/2) qq `controlled` ctl + qnot_at qq `controlled` pp -- control ctl is not needed + comment_with_label "EXIT: two_electron_circuit_orthodox" (qs,ctl) ("qs","ctl") + +-- all other cases aren't Coulomb operators, so fall back to +-- two_electron_circuit. +two_electron_circuit_orthodox theta p q r s qs ctl = do + two_electron_circuit theta p q r s qs ctl + +-- ---------------------------------------------------------------------- +-- * Testing + +-- $ We provide two functions, accessible via command line options, +-- that allow the user to display individual templates. + +-- | Display the circuit for the hermitianized one-electron interaction, +-- with θ=1. +show_one_electron :: Format -> GateBase -> Int -> Int -> IO () +show_one_electron format gatebase p q = + print_generic format (decompose_generic gatebase circuit) (replicate (n-m) qubit) where + circuit qs = one_electron_circuit 1.0 (p-m) (q-m) qs [] + n = maximum [p,q] + 1 + m = minimum [p,q] + +-- | Display the circuit for the hermitianized two-electron interaction, +-- with θ=1. +show_two_electron :: Format -> GateBase -> Int -> Int -> Int -> Int -> IO () +show_two_electron format gatebase p q r s = + print_generic format (decompose_generic gatebase circuit) (replicate (n-m) qubit) where + circuit qs = two_electron_circuit 1.0 (p-m) (q-m) (r-m) (s-m) qs [] + n = maximum [p,q,r,s] + 1 + m = minimum [p,q,r,s] + +-- | Like 'show_two_electron', but use the \"orthodox\" template for +-- the Coulomb operator. +show_two_electron_orthodox :: Format -> GateBase -> Int -> Int -> Int -> Int -> IO () +show_two_electron_orthodox format gatebase p q r s = + print_generic format (decompose_generic gatebase circuit) (replicate (n-m) qubit) where + circuit qs = two_electron_circuit_orthodox 1.0 (p-m) (q-m) (r-m) (s-m) qs [] + n = maximum [p,q,r,s] + 1 + m = minimum [p,q,r,s] diff --git a/Quipper/Algorithms/GSE/Main.hs b/Quipper/Algorithms/GSE/Main.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/GSE/Main.hs @@ -0,0 +1,329 @@ +-- | +-- Authors: Alexander S. Green, Artur Scherer, Peter Selinger, +-- Alexandr Virodov +-- +-- An implementation of the Ground State Estimation algorithm. The +-- purpose of this algorithm is to determine the ground state energy +-- of a quantum molecular system. The algorithm depends on a table of +-- one- and two-electron transition integrals, which must be +-- separately pre-computed and supplied in a pair of data files. From +-- this integral data, the molecular electronic Hamiltonian is derived +-- using the Jordan-Wigner transformation. To simulate this +-- Hamiltonian by a quantum circuit, it is first broken into small +-- time steps using Trotterization. The second quantized local +-- Hamiltonian interaction terms can be divided into a small number of +-- cases (number operators, excitation operators, Coulomb and exchange +-- operators, number-excitation operators, and double excitation +-- operators). Each interaction term is synthesized into a piece of +-- quantum circuit following one of a small number of patterns (called +-- \"circuit templates\"). Finally, the quantum phase estimation +-- algorithm is applied to the resulting circuit to obtain the ground +-- state energy. +-- +-- The algorithm is described in: +-- +-- * James D. Whitfield, Jacob Biamonte, and Alán +-- Aspuru-Guzik. \"Simulation of electronic structure Hamiltonians +-- using quantum computers.\" +-- /Molecular Physics/ 109(5):735–750, 2011. +-- See also . +-- +-- The present implementation is based on a detailed algorithm +-- specification that was provided to us by the IARPA QCS program and +-- written by Anargyros Papageorgiou, James Whitfield, Joseph Traub, +-- and Alán Aspuru-Guzik. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.GSE.Main": Command line interface. +-- +-- * "Quipper.Algorithms.GSE.JordanWigner": The Jordan-Wigner transformation +-- and automated symbolic derivation of circuit templates for second +-- quantized interaction terms. +-- +-- * "Quipper.Algorithms.GSE.GSE": The main circuit for the GSE Algorithm. +-- +-- * "Quipper.Algorithms.GSE.GSEData": Functions for reading the one- and +-- two-electron integral data from a pair of data files. + +module Quipper.Algorithms.GSE.Main where + +import Quipper + +import Quipper.Libraries.Decompose + +import Quipper.Algorithms.GSE.GSE +import Quipper.Algorithms.GSE.GSEData +import Quipper.Algorithms.GSE.JordanWigner +import Quipper.Utils.CommandLine + +-- import other stuff +import System.Console.GetOpt +import System.Environment +import System.Exit +import Control.Monad +import Data.Bits +import qualified System.FilePath as FilePath + +-- ---------------------------------------------------------------------- +-- * Documentation + +-- $ This module provides a command line interface for the Ground +-- State Estimation algorithm. This allows the user to set a number of +-- parameters, such as /b/ (the number of precision qubits), /M/ (the +-- number of spin orbitals), /N/ (the number of occupied spin orbitals +-- in the prepared approximate ground state), and /E/[sub min] and +-- /E/[sub max] (the energy range). Command line options are also +-- provided to specify the filenames for the Hamiltonian integral +-- data, and to specify the output format and gate base. + +-- ---------------------------------------------------------------------- +-- * Option processing + +-- | An enumeration type for determining what the main function should do. +data WhatToShow = + Circuit -- ^Show the whole circuit (default). + | Template [Int] -- ^Show a particular template. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + what :: WhatToShow, -- ^What kind of thing to output. + format :: Format, -- ^The output format. + gatebase :: GateBase, -- ^What kind of gates to decompose into. + gse_orthodox :: Bool, -- ^Use the Coulomb operator of Whitman et al. + + gse_b :: Int, -- ^The number of precision qubits /b/. + gse_m :: Int, -- ^The number of basis functions /M/. + gse_occupied :: Int, -- ^The number of occupied orbitals. + gse_delta_e :: Double, -- ^Energy range Δ/E/ = /E/[sub max] - /E/[sub min]. + gse_e_max :: Double, -- ^Energy range /E/[sub max]. + gse_nfun :: Int -> Int, -- ^The function /k/ ↦ /N/[sub /k/]. + + gse_h1_file :: String, -- ^Filename for one-electron data. + gse_h2_file :: String, -- ^Filename for two-electron data. + gse_datadir :: String -- ^Directory for data files. + } + +-- | The default options. +defaultOptions :: Options +defaultOptions = Options { + what = Circuit, + format = Preview, + gatebase = Logical, + gse_orthodox = False, + + gse_b = 3, + gse_m = 4, + gse_occupied = 2, + gse_delta_e = 6.5536, + gse_e_max = -3876.941, + gse_nfun = (\k -> 1), -- by default, we skip the repetition + + gse_h1_file = "h_1e_ascii", + gse_h2_file = "h_2e_ascii", + gse_datadir = "." + } + +-- | Show the default value of an option. +showDefault :: (Show a) => (Options -> a) -> String +showDefault func = show (func defaultOptions) + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = [ + Option ['h'] ["help"] (NoArg help) $ "print usage info and exit", + Option ['C'] ["circuit"] (NoArg (what Circuit)) $ "output the whole circuit (default)", + Option ['T'] ["template"] (ReqArg read_template "") $ "output a particular circuit template", + Option ['f'] ["format"] (ReqArg read_format "") $ "output format for circuits (default: " ++ showDefault format ++ ")", + Option ['g'] ["gatebase"] (ReqArg read_gatebase "") $ "gates to decompose into (default: " ++ showDefault gatebase ++ ")", + Option ['m'] ["orbitals"] (ReqArg read_m "") $ "number of orbitals (default: " ++ showDefault gse_m ++ ")", + Option ['o'] ["occupied"] (ReqArg read_occupied "") $ "number of occupied orbitals (default: " ++ showDefault gse_occupied ++ ")", + Option ['b'] ["precision"] (ReqArg read_b "") $ "number of precision qubits (default: " ++ showDefault gse_b ++ ")", + Option ['D'] ["delta_e"] (ReqArg read_delta_e "") $ "energy range (default: " ++ showDefault gse_delta_e ++ ")", + Option ['E'] ["e_max"] (ReqArg read_e_max "") $ "maximum energy (default: " ++ showDefault gse_e_max ++ ")", + Option [] ["n0"] (ReqArg read_n0 "") $ "use N_k = n0 * 2^k (default: N_k = 1)", + Option ['l'] ["large"] (NoArg large_parameters) $ "set large problem size (m=208, o=84, b=12, n0=100)", + Option ['x'] ["orthodox"] (NoArg orthodox) $ "use the Coulomb operator of Whitman et al.", + Option [] ["h1"] (ReqArg read_h1 "") $ "filename for one-electron data (default: " ++ showDefault gse_h1_file ++ ")", + Option [] ["h2"] (ReqArg read_h2 "") $ "filename for two-electron data (default: " ++ showDefault gse_h2_file ++ ")", + Option ['d'] ["datadir"] (ReqArg read_datadir "") $ "directory for one- and two-electron data (default: current)" + ] + where + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + + large_parameters o = + return o { + gse_b = 12, + gse_m = 208, + gse_delta_e = 6.5536, + gse_e_max = -3876.941, + gse_occupied = 84, + gse_nfun = (\k -> 100 * (1 `shift` k)) + } + + orthodox o = return o {gse_orthodox = True } + + read_format :: String -> Options -> IO Options + read_format str o = do + case match_enum format_enum str of + [(_, f)] -> return o { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + read_gatebase :: String -> Options -> IO Options + read_gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + read_b :: String -> Options -> IO Options + read_b string o = + case parse_int string of + Just n | n > 0 -> return o { gse_b = n } + _ -> optfail ("Invalid b (precision) -- " ++ string ++ "\n") + + read_m :: String -> Options -> IO Options + read_m string o = + case parse_int string of + Just n | n > 0 -> return o { gse_m = n } + _ -> optfail ("Invalid m (orbitals) -- " ++ string ++ "\n") + + read_n0 :: String -> Options -> IO Options + read_n0 string o = + case parse_int string of + Just n | n > 0 -> return o { gse_nfun = (\k -> n * (1 `shift` k)) } + _ -> optfail ("Invalid n0 -- " ++ string ++ "\n") + + read_occupied :: String -> Options -> IO Options + read_occupied string o = + case parse_int string of + Just n | n > 0 -> return o { gse_occupied = n } + _ -> optfail ("Invalid o (occupied) -- " ++ string ++ "\n") + + read_delta_e :: String -> Options -> IO Options + read_delta_e string o = + case parse_double string of + Just n | n >= 0 -> return o { gse_delta_e = n } + _ -> optfail ("Invalid Delta E -- " ++ string ++ "\n") + + read_e_max :: String -> Options -> IO Options + read_e_max string o = + case parse_double string of + Just n | n >= 0 -> return o { gse_e_max = n } + _ -> optfail ("Invalid E_max -- " ++ string ++ "\n") + + read_h1 :: String -> Options -> IO Options + read_h1 string o = return o { gse_h1_file = string } + + read_h2 :: String -> Options -> IO Options + read_h2 string o = return o { gse_h2_file = string } + + read_datadir :: String -> Options -> IO Options + read_datadir string o = return o { gse_datadir = string } + + read_template :: String -> Options -> IO Options + read_template string o = do + ps <- sequence [ convert p | p <- split ',' string ] + let len = length ps + if len == 2 || len == 4 then + return o { what = Template ps } + else + optfail ("Must give 2 or 4 indices, not " ++ (show len) ++ "\n") + where + split c as = case break (== c) as of + (h,_:t) -> h : (split c t) + (h,[]) -> [h] + convert p = case parse_int p of + Just n | n >= 0 -> return n + _ -> optfail ("Invalid index -- '" ++ p ++ "'\n") + + help :: Options -> IO Options + help o = do + usage + exitSuccess + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to standard output. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + putStr ("Indices can be specified as p,q or p,q,r,s (with no spaces)\n") + where header = "Usage: gse [OPTION...]" + +-- ---------------------------------------------------------------------- +-- * The GSE main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO() +main = do + -- Read options. + argv <- getArgs + options <- dopts argv + + case what options of + Circuit -> main_circuit options + Template qs -> main_template options qs + +-- | Main function for outputting the GSE circuit. +main_circuit :: Options -> IO() +main_circuit options = do + + -- Read parameters. + let b = gse_b options + m = gse_m options + o = gse_occupied options + dE = gse_delta_e options + e_max = gse_e_max options + datadir = gse_datadir options + file1 = gse_h1_file options + file2 = gse_h2_file options + nfun = gse_nfun options + orth = gse_orthodox options + + -- Calculate derived parameters. + let tau = 2*pi / dE + + path1 = FilePath.combine datadir file1 + path2 = FilePath.combine datadir file2 + + -- Load data from file. + gse_data <- load_gse_data m path1 path2 + + -- Generate the main circuit. + let circuit = gse b m o gse_data tau e_max nfun orth + + -- Print it. + print_simple (format options) (decompose_generic (gatebase options) circuit) + + -- Of course, if we had a quantum computer, we would run it instead. + {- + ms <- run_simple circuit + let e0 = e_max - dE * (int_from_bitlist mk) / (2**b) + return e0 + -} + +-- | Main function for outputting a particular template. +main_template :: Options -> [Int] -> IO() +main_template options [p,q] = do + show_one_electron (format options) (gatebase options) p q + +main_template options [p,q,r,s] = do + if gse_orthodox options + then show_two_electron_orthodox (format options) (gatebase options) p q r s + else show_two_electron (format options) (gatebase options) p q r s + +main_template options qs = + error "main_template: wrong number of indices given" + diff --git a/Quipper/Algorithms/QLS/CircLiftingImport.hs b/Quipper/Algorithms/QLS/CircLiftingImport.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/QLS/CircLiftingImport.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +-- | This module contains definitions to work with Template Haskell. All +-- the definitions in this module are used by Template Haskell in +-- "Quipper.Algorithms.QLS.TemplateOracle" and "Quipper.Algorithms.QLS.RealFunc". +module Quipper.Algorithms.QLS.CircLiftingImport where + +import Data.Typeable + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Arith +import Quipper.Libraries.Decompose + +import Quipper.Algorithms.QLS.QDouble +import Quipper.Algorithms.QLS.QSignedInt +import Quipper.Algorithms.QLS.Utils + +-- * Utility function + +-- | @'grepn' /regexp/ /list/@: Counts how many times /regexp/ is a +-- sublist of /list/. +grepn :: (Eq a) => [a] -> [a] -> Int +grepn regexp l = + if (length regexp > length l) then 0 + else if ((take (length regexp) l) == regexp) then 1 + (grepn regexp $ tail l) + else grepn regexp $ tail l + + + + +-- * Lifting of ordering operators. + + +-- | Template version of '/='. +template_symb_slash_symb_equal_ :: (Typeable qa, QOrd qa) => Circ (qa -> Circ (qa -> Circ Qubit)) +template_symb_slash_symb_equal_ = return $ \x -> return $ \y -> do + (_,_,r) <- box "/=" (decompose_generic Toffoli $ uncurry q_is_not_equal) (x,y) + return r + +-- | Template version of '<'. +template_symb_oangle_ :: (Typeable qa, QOrd qa) => Circ (qa -> Circ (qa -> Circ Qubit)) +template_symb_oangle_ = return $ \x -> return $ \y -> box "<" (uncurry q_less) (x,y) + +-- | Template version of '<='. +template_symb_oangle_symb_equal_ :: (Typeable qa, QOrd qa) => Circ (qa -> Circ (qa -> Circ Qubit)) +template_symb_oangle_symb_equal_ = return $ \x -> return $ \y -> box "<=" (uncurry q_leq) (x,y) + +-- | Template version of '>'. +template_symb_cangle_ :: (Typeable qa, QOrd qa) => Circ (qa -> Circ (qa -> Circ Qubit)) +template_symb_cangle_ = return $ \x -> return $ \y -> box ">" (uncurry q_greater) (x,y) + +-- | Template version of '>='. +template_symb_cangle_symb_equal_ :: (Typeable qa, QOrd qa) => Circ (qa -> Circ (qa -> Circ Qubit)) +template_symb_cangle_symb_equal_ = return $ \x -> return $ \y -> box ">=" (uncurry q_geq) (x,y) + + + + +-- * Lifting of arithmetic operators + +-- | Template version of '-'. +template_symb_minus_ :: (Typeable qa, QNum qa) => Circ (qa -> Circ (qa -> Circ qa)) +template_symb_minus_ = return $ \qx -> return $ \qy -> do (qx,qy,qz) <- box "-" (uncurry q_sub) (qx,qy); return qz + +-- | Template version of '+'. +template_symb_plus_ :: (Typeable qa, QNum qa) => Circ (qa -> Circ (qa -> Circ qa)) +template_symb_plus_ = return $ \qx -> return $ \qy -> do (qx,qy,qz) <- box "+" (uncurry q_add) (qx,qy); return qz + +-- | Template version of '*'. +template_symb_star_ :: (Typeable qa, QNum qa) => Circ (qa -> Circ (qa -> Circ qa)) +template_symb_star_ = return $ \qx -> return $ \qy -> do (qx,qy,qz) <- box "*" (uncurry q_mult) (qx,qy); return qz + +-- | Template version of 'negate'. +template_negate :: (Typeable qa, QNum qa) => Circ (qa -> Circ qa) +template_negate = return $ \qx -> do (_,qz) <- box "neg" q_negate qx; return qz + +-- | Template version of 'abs'. +template_abs :: (Typeable qa, QNum qa) => Circ (qa -> Circ qa) +template_abs = return $ \x -> do + (_,r) <- box "abs" q_abs x + return r + +-- | Template version of 'mod' +template_mod :: Circ (QSignedInt -> Circ (QSignedInt -> Circ QSignedInt)) +template_mod = return $ \x -> return $ \y -> box "mod" (decompose_generic Toffoli $ uncurry q_mod) (x,y) + + +-- * Operations on 'QDouble' + +-- | Template version of '/' on 'Fractional'. +template_symb_slash_:: Circ (QDouble -> Circ (QDouble -> Circ QDouble)) +template_symb_slash_ = return $ \x -> return $ \y -> box "/" (decompose_generic Toffoli $ uncurry q_div_real) (x,y) + +-- | The constant 'pi' as an 'FDouble'. +local_pi :: FDouble +local_pi = fdouble pi + +-- | Template version of 'local_pi'. +template_local_pi :: Circ QDouble +template_local_pi = qinit (fdouble pi) + +-- | The identity function of type 'FDouble'. This is used to help the +-- type checker work around a problem in GHC 8.0, where types of +-- overloaded operations sometimes require disambiguation. +id_fdouble :: FDouble -> FDouble +id_fdouble x = x + +-- | Template version of 'id_fdouble'. +template_id_fdouble :: Circ (QDouble -> Circ QDouble) +template_id_fdouble = return $ \x -> return x + +-- * Relation between 'QDouble' and 'QSignedInt'. + +-- | Template version of 'floor'. +template_floor :: Circ (QDouble -> Circ QSignedInt) +template_floor = return $ \(XDouble k (SInt x b)) -> + return $ SInt (reverse . drop k . reverse $ x) b + +-- | Template version of 'ceiling'. +template_ceiling :: Circ (QDouble -> Circ QSignedInt) +template_ceiling = return $ \x -> q_ceiling x + +-- | Template version of 'fromIntegral'. +template_fromIntegral :: Circ (QSignedInt -> Circ QDouble) +template_fromIntegral = return $ \x -> q_fromIntegral x + + + +-- * Dealing with parameters. + + +-- | Lift a real number to 'QDouble'. +template_rational :: Double -> Circ QDouble +template_rational x = qinit $ fdouble x + +-- | Lift an integer to 'QSignedInt'. +template_integer :: Int -> Circ QSignedInt +template_integer x = qinit $ fromIntegral x + + +-- | Make a parameter 'Int' as a regular 'Int' that can be lifted. +getIntFromParam :: Int -> Int +getIntFromParam x = fromIntegral x + +-- | Template version of 'getIntFromParam'. +template_getIntFromParam :: Circ (Int -> Circ QSignedInt) +template_getIntFromParam = return $ \x -> qinit $ fromIntegral x + +-- | Parameter integer of value '0'. +paramZero :: Int +paramZero = 0 + +-- | Template version of 'paramZero'. +template_paramZero :: Circ Int +template_paramZero = return 0 + +-- | Parameter integer of value '10'. +paramTen :: Int +paramTen = 10 + +-- | Template version of 'paramTen'. +template_paramTen :: Circ Int +template_paramTen = return paramTen + +-- | Successor function acting on parameter 'Int'. +paramSucc :: Int -> Int +paramSucc x = x+1 + +-- | Template version of 'paramSucc'. +template_paramSucc :: Circ (Int -> Circ Int) +template_paramSucc = return $ \x -> return (x+1) + +-- | Predecessor function acting on parameter 'Int'. +paramPred :: Int -> Int +paramPred x = x - 1 + +-- | Template version of 'paramPred'. +template_paramPred :: Circ (Int -> Circ Int) +template_paramPred = return $ \x -> return (x-1) + + + +-- | Subtraction of parameter integers. +paramMinus :: Int -> Int -> Int +paramMinus x y = x - y + +-- | Template version of 'paramMinus'. +template_paramMinus :: Circ (Int -> Circ (Int -> Circ Int)) +template_paramMinus = return $ \x -> return $ \y -> return (x-y) + + + +-- * Miscellaneous operations. + +-- | Lifted version of @'length'@. +template_length :: Circ ([a] -> Circ QSignedInt) +template_length = return $ \l -> qinit $ fromIntegral $ length l + +-- | Return the first half of the input list. +take_half :: [a] -> [a] +take_half l = take (1 + (length l) `div` 2) l + +-- | Lifted version of @'take_half'@. +template_take_half :: Circ ([a] -> Circ [a]) +template_take_half = return $ \l -> return $ take_half l + diff --git a/Quipper/Algorithms/QLS/Main.hs b/Quipper/Algorithms/QLS/Main.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/QLS/Main.hs @@ -0,0 +1,268 @@ +-- | +-- Authors: Artur Scherer, Siun-Chuon Mau, Benoît Valiron +-- +-- An implementation of the quantum linear system algorithm. The +-- algorithm finds the solution to a sparse system of linear equations +-- /Ax/=/b/, with a scaling exponentially better than the best known +-- classical algorithms. Here, /A/ is an /N/ × /N/ sparse matrix, /b/ +-- an /N/ × 1 vector of known values, and /x/ is the solution. +-- +-- Huge sparse linear systems are common in applied sciences and +-- engineering, such as those resulting from solving partial +-- differential equations by means of Finite Element Method (FEM). +-- +-- The example analyzed in this program is the scattering of +-- electromagnetic waves off a 2D metallic region, where the FEM +-- allows to convert Maxwell’s equations into a sparse linear system. +-- +-- The QLS algorithm is based on two main techniques: +-- +-- * Quantum Phase Estimation, which uses the Quantum Fourier +-- Transform and Hamiltonian Simulation, which makes frequent queries +-- to the oracle for matrix /A/; +-- +-- * Quantum Amplitude Estimation, based on Grover’s search technique. +-- +-- +-- The algorithm is described in: +-- +-- * Aram W. Harrow, Avinatan Hassidim, Seth Lloyd. Quantum algorithm +-- for solving linear systems of equations. /Phys. Rev. Lett./ vol. 15, +-- no. 103, pp. 150502 (2009). +-- +-- * B. D. Clader, B. C. Jacobs, C. R. Sprouse. Quantum algorithm to +-- calculate electromagnetic scattering cross +-- sections. . +-- +-- The present implementation is based on detailed algorithm and +-- oracle specifications that were provided to us by the IARPA QCS +-- program and written by B. David Clader and Bryan C. Jacobs. +-- +-- +-- Modules: +-- +-- * "Quipper.Algorithms.QLS.Main": Command line interface. +-- +-- * "Quipper.Algorithms.QLS.QSignedInt": An implementation of signed +-- integers. +-- +-- * "Quipper.Algorithms.QLS.QSignedIntAux": Helper module. +-- +-- * "Quipper.Algorithms.QLS.QDouble": An implementation of real numbers, +-- using fixed-point notation. +-- +-- * "Quipper.Algorithms.QLS.RealFunc": Implementation of various analytic +-- functions, for use with the automated circuit generation tool. +-- +-- * "Quipper.Algorithms.QLS.Utils": Helper module. +-- +-- * "Quipper.Algorithms.QLS.QLS": The implementation of the main algorithm. +-- +-- * "Quipper.Algorithms.QLS.CircLiftingImport": Helper module. +-- +-- * "Quipper.Algorithms.QLS.TemplateOracle": Implementation of the oracle, +-- in regular Haskell, together with the \"build_circuit\" keyword to +-- allow automated circuit generation. + +module Quipper.Algorithms.QLS.Main where + +import Quipper + +import Quipper.Libraries.Arith +import Quipper.Libraries.Decompose +import Quipper.Libraries.Unboxing + +import qualified Quipper.Algorithms.QLS.QLS as QLS +import Quipper.Algorithms.QLS.Utils +import Quipper.Algorithms.QLS.QDouble as QDouble +import Quipper.Algorithms.QLS.RealFunc as QReal +import Quipper.Algorithms.QLS.QSignedInt as QSInt +import Quipper.Algorithms.QLS.TemplateOracle + +import Quipper.Utils.CommandLine + +-- import other stuff +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Control.Monad +import Data.List +import Data.Char +import Data.Ratio as Ratio + +-- ---------------------------------------------------------------------- +-- * Command line interface + +-- $ This module provides a command line interface for the Quantum +-- Linear System algorithm. This allows the user, for example, to plug +-- in different oracles, select a gate base, control boxing of +-- subcircuits, and select different output formats. + +-- ---------------------------------------------------------------------- +-- * Option processing + +-- | An enumeration type for determining what the main function should do. +data WhatToShow = + Circuit -- ^Show the whole circuit. + | Oracle -- ^Show only an oracle. + deriving Show + +-- | An enumeration type for selecting an oracle implementation. +data OracleSelect = + Matlab -- ^The oracle, implemented with Template Haskell. + | Blackbox -- ^A blackbox oracle. + deriving Show + +-- | An enumeration type for selecting an oracle to print. +data WhichOracle = + OracleR -- ^Oracle r. + | OracleB -- ^Oracle b. + | OracleA Int Bool -- ^Oracle A, with selected band and boolean parameter. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + what :: WhatToShow, -- ^What kind of thing to output. + format :: Format, -- ^The output format. + gatebase :: GateBase, -- ^What kind of gates to decompose into. + oracle :: OracleSelect, -- ^Which oracle implementation to use. + whichoracle :: WhichOracle, -- ^Which oracle to output. + param :: QLS.RunTimeParam, -- ^Run time parameters. + peel :: Int -- ^number of layers of subroutines to peel away. +} deriving Show + +-- | The default options. +defaultOptions :: Options +defaultOptions = Options + { what = Circuit, + format = GateCount, + gatebase = Logical, + oracle = Blackbox, + whichoracle = OracleR, + param = QLS.dummy_RT_param, + peel = 0 + } + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = + [ Option ['h'] ["help"] (NoArg help) "print usage info and exit", + Option ['C'] ["circuit"] (NoArg (what Circuit)) "output the whole circuit (default)", + Option ['O'] ["oracle"] (ReqArg whichoracle "") "output only the oracle (default: r) ", + Option ['f'] ["format"] (ReqArg format "") "output format for circuits (default: gatecount)", + Option ['g'] ["gatebase"] (ReqArg gatebase "") "type of gates to decompose into (default: logical)", + Option ['o'] [] (ReqArg oracle "") "select oracle implementation to use (default: blackbox)", + Option ['p'] ["param"] (ReqArg param "") "choose a set of parameters (default: dummy).", + Option ['P'] ["peel"] (ReqArg peel "") "peel layers of boxed subroutines (default: 0)." + ] + where + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + + peel :: String -> Options -> IO Options + peel string o = case (parse_int string) of + Just i -> return o { peel = i } + Nothing -> optfail ("peel requires a argument number.") + + param :: String -> Options -> IO Options + param string o = + case string of + "large" -> return o { param = QLS.large_RT_param } + "dummy" -> return o { param = QLS.dummy_RT_param } + "small" -> return o { param = QLS.small_RT_param } + _ -> let (p,v) = break ((==) '=') string in + case p of + _ -> optfail ("Parameter not implemented -- " ++ string ++ "\n") + + whichoracle :: String -> Options -> IO Options + whichoracle string o = + case (toLower $ head string) of + 'r' -> return o { whichoracle = OracleR, what = Oracle } + 'b' -> return o { whichoracle = OracleB, what = Oracle } + 'a' -> let b = parse_int [string !! 1] in + let a = toLower (string !! 2) in + case (b,a) of + (Just i, 't') -> return o { whichoracle = OracleA i True, what = Oracle } + (Just i, 'f') -> return o { whichoracle = OracleA i False, what = Oracle } + _ -> error ("Band " ++ (show (string !! 1)) ++ " or boolean " ++ (show a) ++ " not valid.") + _ -> error ("Oracle " ++ (show (string !! 0)) ++ " not valid.") + + + format :: String -> Options -> IO Options + format str o = do + case match_enum format_enum str of + [(_, GateCount)] -> return o { format = GateCount } + [(_, ASCII)] -> return o { format = ASCII } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + gatebase :: String -> Options -> IO Options + gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + oracle :: String -> Options -> IO Options + oracle str o = do + case match_enum oracle_enum str of + [(_, f)] -> return o { oracle = f } + [] -> optfail ("Unknown oracle -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous oracle -- " ++ str ++ "\n") + + help :: Options -> IO Options + help o = do + usage + exitSuccess + +-- | An enumeration of available oracles and their names. +oracle_enum :: [(String, OracleSelect)] +oracle_enum = [ + ("matlab", Matlab), + ("blackbox", Blackbox) + ] + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to 'stdout'. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" [("ascii", ASCII),("gatecount",GateCount)]) + putStr (show_enum "gatebase" gatebase_enum) + putStr (show_enum "oracle implementation" oracle_enum) + putStrLn "Possible values for param are: dummy, small, large." + putStrLn "Possible values for oracle are: r, b, A[band][t|f]. E.g. \"-OA1t\" asks for band 1 with boolean argument True. For all three oracles, the factors are set up to 1.0." + where header = "Usage: qls [OPTION...]" + + +-- ---------------------------------------------------------------------- +-- * The QLS main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO() +main = do + argv <- getArgs + options <- dopts argv + case options of + Options { what = Circuit, format = format, gatebase = gatebase, oracle = oracle, param = param, peel = peel} -> + let o = case oracle of {Blackbox -> QLS.dummy_oracle; Matlab -> QLS.inline_oracle} in + print_simple format $ decompose_generic gatebase $ ncompose peel unbox $ do QLS.qlsa_FEM_main param o; return () + Options { what = Oracle, format = format, gatebase = gatebase, param = param, whichoracle = whichoracle, peel = peel } -> + let n2_blist = replicate (QLS.n2 param) qubit in + let n4_blist = replicate (QLS.n4 param) qubit in + let (oracle, list_of_inputs) = + case whichoracle of + OracleR -> (QLS.inline_oracle_r param 1.0 1.0, (n2_blist, n4_blist, n4_blist)) + OracleB -> (QLS.inline_oracle_b param 1.0 1.0, (n2_blist, n4_blist, n4_blist)) + OracleA i b -> (QLS.inline_oracle_A param 1.0 i b, (n2_blist, n2_blist, n4_blist)) + in do + print_generic format (decompose_generic gatebase $ ncompose peel unbox $ oracle) list_of_inputs + diff --git a/Quipper/Algorithms/QLS/QDouble.hs b/Quipper/Algorithms/QLS/QDouble.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/QLS/QDouble.hs @@ -0,0 +1,558 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This modules implements a library for fixed-points real numbers. +module Quipper.Algorithms.QLS.QDouble where + +import qualified Data.Ratio as Ratio + +import Data.Typeable + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Arith +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.QLS.Utils +import Quipper.Algorithms.QLS.QSignedInt + +import Quipper.Utils.Auxiliary (getId, mmap) + +-- * Signed fixed point type + +-- | Data type for fixed point arithmetic. +-- +-- 'XDouble' /k/ /n/ represents the number /n/⋅2[sup -/k/], where /n/ +-- is a signed integer and /k/ is an integer parameter. +-- +-- We refer to /k/ as the /exponent/ of the fixed point number. When +-- we speak of the /length/, we mean the total number of digits +-- (excluding the sign), i.e., the length, in binary digits, of the +-- underlying /n/. +data XDouble x = XDouble Int (SignedInt x) + deriving (Show, Typeable) + +-- | The parameter type of fixed-point numbers. +type FDouble = XDouble Bool + +-- | The quantum type of fixed-point numbers. +type QDouble = XDouble Qubit + +-- | The classical type of fixed-point numbers. +type CDouble = XDouble Bit + +-- ---------------------------------------------------------------------- +-- * Auxiliary definitions + +-- | Compute the power of an integer by a non-negative integer. +integer_power :: Int -> Int -> Integer +integer_power x y = (fromIntegral x) ^ y + +-- | Compute the power of an integer by another, possibly negative one. +double_power :: Int -> Int -> Double +double_power x y + | y >= 0 = (fromIntegral x) ^ y + | otherwise = 1 / ((fromIntegral x) ^ (-y)) + +-- | Divide one integer by another, and round the result to the closest +-- integer. If the result is half way between two integers, round to +-- the even one (this is the same behavior as Haskell's 'round' +-- function). This function has unlimited precision. +div_round :: Integer -> Integer -> Integer +div_round x y = round (x Ratio.% y) + +-- ---------------------------------------------------------------------- +-- * Operation for length and exponent + +-- ---------------------------------------------------------------------- +-- ** Generic functions for XDouble + +-- | Return the exponent /k/ of an 'XDouble'. +xdouble_exponent :: XDouble x -> Int +xdouble_exponent (XDouble k _) = k + +-- | Return the length /m/ of an 'XDouble'. +xdouble_length :: XDouble x -> Int +xdouble_length (XDouble _ n) = sint_length n + +-- | Return the \"extent\" of an 'XDouble'. The extent of a fixed-point +-- number /x/ is, by definition, the pair (/hi/,/lo/) of integers such +-- that the most significant bit of /x/ has positional index /hi/-1 +-- (in other words, the value of this bit is 2[sup /hi/-1]), and the +-- least significant bit of /x/ has positional index /lo/ (in other +-- words, the value of this bit is 2[sup /lo/]. Typically, but not +-- necessarily, /hi/ ≥ 0 and /lo/ ≤ 0. In this case, one can also +-- think of /hi/ as \"the number of digits before the radix point\" +-- and −/lo/ as \"the number of digits after the radix point\". +-- +-- The exponent /k/, length /m/, and extent (/hi/,/lo/) are related by +-- /k/=-/lo/ and /m/=/hi/−/lo/. +-- +-- Examples: +-- +-- * a number represented in the form /xxxx.yyy/ has extent (4,-3), +-- exponent 3, and length 7. +-- +-- * a number represented in the form /xxxx000./ has extent (7,3), +-- exponent -3, and length 4. +-- +-- * a number represented in the form /.000xxxx/ has extent (-3,-7), +-- exponent 7, and length 4. +-- +-- If we regard extents as intervals, ordered by inclusion, then it is +-- always possible to losslessly cast a fixed-point number from a +-- smaller to a larger extent. +xdouble_extent :: XDouble x -> (Int, Int) +xdouble_extent x = (m-k, -k) where + m = xdouble_length x + k = xdouble_exponent x + +-- | Add /n/ zeros to the high bits of the 'XDouble'. This sends +-- /xxx.yyy/ to 000/xxx.yyy/. This increases the length without changing +-- the exponent or value. +xdouble_pad_left :: (Monad m) => m x -> Int -> XDouble x -> m (XDouble x) +xdouble_pad_left zero n (XDouble k (SInt digits s)) = do + pad <- sequence $ replicate n zero + let digits' = pad ++ digits + return $ XDouble k (SInt (digits') s) + +-- | Add /n/ zeros to the low bits of the 'XDouble'. This sends +-- /xxx.yyy/ to /xxx.yyy000/. This increases the length and the +-- exponent without changing the value. +xdouble_pad_right :: (Monad m) => m x -> Int -> XDouble x -> m (XDouble x) +xdouble_pad_right zero n (XDouble k (SInt digits s)) = do + pad <- sequence $ replicate n zero + let digits' = digits ++ pad + return $ XDouble (k+n) (SInt (digits') s) + +-- | Pad an 'XDouble' on both sides to reach the desired extent. This +-- increases the length and exponent without changing the value (it is +-- a lossless operation). It is an error to call this function if the +-- selected extent does not contain the extent of the input 'XDouble'. +xdouble_pad_to_extent :: (Monad m) => m x -> (Int, Int) -> XDouble x -> m (XDouble x) +xdouble_pad_to_extent zero (hi, lo) x + | lo <= lo_x && hi_x <= hi + = xdouble_pad_left zero (hi - hi_x) =<< xdouble_pad_right zero (lo_x - lo) x + | otherwise + = error "qdouble_pad_to_extent: bad extent" + where + (hi_x, lo_x) = xdouble_extent x + +-- | Remove the /n/ low bits of an 'XDouble'. This sends /xxx.yyyzzz/ +-- to /xxx.yyy/. It is an error to call this function when the +-- 'XDouble' has fewer than /n/ digits. +xdouble_truncate_right :: Int -> QDouble -> QDouble +xdouble_truncate_right n (XDouble k (SInt digits s)) = (XDouble k' (SInt digits' s)) + where + k' = k - n + digits' | length digits >= n = reverse $ drop n $ reverse digits + | otherwise = error "xdouble_truncate_right" + +-- | Convert a 'SignedInt' to an 'XDouble' with exponent 0. +xdouble_of_sint :: SignedInt x -> XDouble x +xdouble_of_sint n = XDouble 0 n + +-- ---------------------------------------------------------------------- +-- ** Special cases for QDouble + +-- | Add /n/ zeros to the high bits of the 'QDouble'. This sends +-- /xxx.yyy/ to 000/xxx.yyy/. This increases the length without +-- changing the exponent or value. This function does not return a +-- fresh copy; it reuses part of its input. +qdouble_pad_left :: Int -> QDouble -> Circ QDouble +qdouble_pad_left = xdouble_pad_left (qinit False) + +-- | Add /n/ zeros to the low bits of the 'QDouble'. This sends +-- /xxx.yyy/ to /xxx.yyy000/. This increases the length and the +-- exponent without changing the value. This function does not return +-- a fresh copy; it reuses part of its input. +qdouble_pad_right :: Int -> QDouble -> Circ QDouble +qdouble_pad_right = xdouble_pad_right (qinit False) + +-- | Pad a 'QDouble' on both sides to reach the desired extent. This +-- increases the length and exponent without changing the value (it is +-- a lossless operation). It is an error to call this function if the +-- selected extent does not contain the extent of the input +-- 'QDouble'. This function does not return a fresh copy; it reuses +-- part of its input. +qdouble_pad_to_extent :: (Int, Int) -> QDouble -> Circ QDouble +qdouble_pad_to_extent = xdouble_pad_to_extent (qinit False) + +-- | Remove the /n/ low bits of a 'QDouble'. This sends /xxx.yyyzzz/ +-- to /xxx.yyy/. Note that the /n/ low qubits are not terminated and +-- become garbage. It is an error to call this function when the +-- 'QDouble' has fewer than /n/ digits. +qdouble_truncate_right :: Int -> QDouble -> QDouble +qdouble_truncate_right = xdouble_truncate_right + +-- ---------------------------------------------------------------------- +-- ** Special cases for FDouble + +-- | Add /n/ zeros to the low bits of the 'FDouble'. This sends +-- /xxx.yyy/ to /xxx.yyy000/. This increases the length and the +-- exponent without changing the value. +fdouble_pad_right :: Int -> FDouble -> FDouble +fdouble_pad_right k x = getId $ xdouble_pad_right (return False) k x + +-- | Pad a 'FDouble' on both sides to reach the desired extent. This +-- increases the length and exponent without changing the value (it is +-- a lossless operation). It is an error to call this function if the +-- selected extent does not contain the extent of the input 'FDouble'. +fdouble_pad_to_extent :: (Int, Int) -> FDouble -> FDouble +fdouble_pad_to_extent extent x = getId $ xdouble_pad_to_extent (return False) extent x + +-- ---------------------------------------------------------------------- +-- * Operations for FDouble + +-- ---------------------------------------------------------------------- +-- ** Casts + +-- | @'fdouble_of_double' /k/ /m/ /x/@: Convert /x/ to an 'FDouble' of +-- exponent /k/ and length /m/ ≥ 0. Note that the exponent does not +-- need to be between 0 and /m/; it can even be negative. +fdouble_of_double :: Int -> Int -> Double -> FDouble +fdouble_of_double k m x + | abs n >= integer_power 2 m + = error "fdouble_of_double: number too large" + | otherwise + = XDouble k (fsint_of_integer m n) + where + d = double_power 2 k + n = round (d * x) + +-- | Convert an 'FDouble' to a 'Double'. +double_of_fdouble :: FDouble -> Double +double_of_fdouble (XDouble k n) = (fromIntegral x) / (double_power 2 k) + where + x = integer_of_fsint n + +-- | Convert an 'FSignedInt' to an 'FDouble' with exponent 0. +fdouble_of_fsint :: FSignedInt -> FDouble +fdouble_of_fsint = xdouble_of_sint + +-- | Make an 'FDouble' value of exponent /k/, length /m/, and value /a/2[sup /-k/]. +fdouble_of_integer :: Int -> Int -> Integer -> FDouble +fdouble_of_integer k m a = XDouble k (fsint_of_integer m a) + +-- | Construct a 'Double' from an 'FDouble', using some arbitrary +-- method to guess the length and exponent. +fdouble :: Double -> FDouble +fdouble x = fromRational $ toRational x + +-- | Convert an 'FDouble' to a string in human-readable form. +show_fdouble :: FDouble -> String +show_fdouble x@(XDouble k (SInt digits s)) = sign ++ binary ++ " (" ++ (show float) ++ ")" + where + float = double_of_fdouble x + sign = if s then "-" else "+" + m = length digits + binary_full = [ if h then '1' else '0' | h <- digits ] + binary | k < 0 = binary_full ++ "e" ++ show (-k) + | k > m = "." ++ binary_full ++ "e" ++ show (m-k) + | otherwise = binary1 ++ "." ++ binary2 + (binary1,binary2) = splitAt ((fromIntegral m) - k) binary_full + +-- ---------------------------------------------------------------------- +-- ** Type class instances + +-- $ We make 'FDouble' an instance of 'Eq', 'Ord', 'Real', 'Num', +-- 'Fractional', and 'RealFrac'. See the source code for details. + +-- Note: none of the arithmetic operations pass via the native +-- 'Double' type, and therefore they are not subject to arbitrary +-- precision limits. However, most operations set the precision of the +-- result to the maximum precision of the inputs. + + +-- | Express a pair of 'FDouble' values as a pair of 'FSignedInt's with a +-- common exponent. +fdouble_align :: FDouble -> FDouble -> (Int, FSignedInt, FSignedInt) +fdouble_align (XDouble h m) (XDouble k n) + | h <= k = (k, fsint_shift (k-h) m, n) + | otherwise = (h, m, fsint_shift (h-k) n) + +instance Eq FDouble where + x == y = m == n where (k,m,n) = fdouble_align x y + +instance Ord FDouble where + compare x y = compare m n where (k,m,n) = fdouble_align x y + +instance Real FDouble where + toRational (XDouble h n) + | h >= 0 = (Ratio.%) nx (integer_power 2 h) + | otherwise = fromInteger (nx * integer_power 2 (-h)) + where + nx = integer_of_fsint n + +instance Num FDouble where + -- Additive operations set the exponent to the maximum of the two + -- exponents, and extend the length if necessary. Signum keeps the + -- length but resets the exponent to 0. + x + y = XDouble k (m + n) where (k,m,n) = fdouble_align x y + x - y = XDouble k (m - n) where (k,m,n) = fdouble_align x y + abs x = XDouble k (abs m) where XDouble k m = x + signum x = fdouble_of_fsint (signum m) where XDouble k m = x + + -- fromInteger uses the fixed exponent 'after_radix_length'. + fromInteger = fdouble_pad_right after_radix_length . fdouble_of_fsint . fromInteger + + -- Multiplication sets the extent to the maximum of the two extents. + x * y | k >= 0 = fdouble_of_integer k len (a*b `div_round` integer_power 2 k) + | otherwise = fdouble_of_integer k len (a*b * integer_power 2 (-k)) + where + (k,m,n) = fdouble_align x y + a = integer_of_fsint m + b = integer_of_fsint n + len = max (sint_length m) (sint_length n) + +instance Fractional FDouble where + -- Division sets the extent to the maximum of the two extents. + x / y | k >= 0 = fdouble_of_integer k len ((a * integer_power 2 k) `div_round` b) + | otherwise = fdouble_of_integer k len (a `div_round` (b * integer_power 2 (-k))) + where + (k,m,n) = fdouble_align x y + a = integer_of_fsint m + b = integer_of_fsint n + len = max (sint_length m) (sint_length n) + + fromRational x = fdouble_of_double before_radix_length (before_radix_length+after_radix_length) ((fromInteger $ Ratio.numerator x) / (fromInteger $ Ratio.denominator x)) + +instance RealFrac FDouble where + properFraction x + | k <= 0 = (0, x) + | otherwise = (fromInteger q, fdouble_of_integer k len r) + where + XDouble k m = x + a = integer_of_fsint m + len = sint_length m + (q, r) = a `quotRem` integer_power 2 k + +-- ---------------------------------------------------------------------- +-- Operations for QDouble + +-- ---------------------------------------------------------------------- +-- QCData instance + +type instance QCType x y (XDouble z) = XDouble (QCType x y z) +type instance QTypeB FDouble = QDouble + +instance QCLeaf x => QCData (XDouble x) where + qcdata_mapM ~(XDouble _ shape) f g (XDouble n xs) = + mmap (XDouble n) $ qcdata_mapM shape f g xs + qcdata_zip ~(XDouble _ shape) q c q' c' (XDouble n xs) (XDouble m ys) e + | n == m + = XDouble n $ qcdata_zip shape q c q' c' xs ys (const $ e "XDouble length mismatch") + | otherwise + = error (e "XDouble exponent mismatch") + qcdata_promote (XDouble n b) (XDouble m q) e + | n == m + = XDouble n $ qcdata_promote b q (const $ e "XDouble length mismatch") + | otherwise + = error (e "XDouble exponent mismatch") + +-- Labeling of QDouble is s.sign, s[hi-1], ..., s[lo], where lo = -k. +instance QCLeaf x => Labelable (XDouble x) String where + label_rec (XDouble k (SInt digits sign)) s = do + label_rec sign s `dotted_indexed` "sign" + sequence_ [ label_rec d s `indexed` show i | (d,i) <- zip rdigits [-k,-k+1..] ] + where + rdigits = reverse digits + +instance CircLiftingUnpack (Circ QDouble) (Circ QDouble) where + pack x = x + unpack x = x + +-- ---------------------------------------------------------------------- +-- * Casts + +-- | Convert a 'QSignedInt' to a 'QDouble' with exponent 0. This +-- function does not return a fresh copy; instead, it uses the input +-- qubits. +qdouble_of_qsint :: QSignedInt -> Circ QDouble +qdouble_of_qsint x = do + (_,y) <- qc_copy_fun x + return $ xdouble_of_sint y + +-- ---------------------------------------------------------------------- +-- ** Type class instances + +-- $ We make 'QDouble' an instance of 'QOrd'. + +instance QOrd QDouble where + q_less x y | kx < ky = do + x <- qdouble_pad_right (ky-kx) x + compare_right x y + | kx > ky = do + y <- qdouble_pad_right (kx-ky) y + compare_right x y + | otherwise = compare_right x y + where + kx = xdouble_exponent x + ky = xdouble_exponent y + + -- compare_right assumes matching exponent, i.e., both bit strings + -- are right-aligned. + compare_right :: QDouble -> QDouble -> Circ Qubit + compare_right (XDouble _ n) (XDouble _ m) = q_less n m + +-- | Express a pair of 'QDouble' values as a pair of 'QSignedInt's with a +-- common exponent. +qdouble_align :: QDouble -> QDouble -> Circ (Int, QSignedInt, QSignedInt) +qdouble_align (XDouble h m) (XDouble k n) + | h <= k = do + m <- qsint_shift (k-h) m + return (k, m, n) + | otherwise = do + n <- qsint_shift (h-k) n + return (k, m, n) + + +instance QNum QDouble where + -- Additive operations set the exponent to the maximum of the two + -- exponents, and extend the length if necessary. Signum keeps the + -- length but resets the exponent to 0. + q_add x y = do + (k,m,n) <- qdouble_align x y + (_, _, r) <- q_add m n + return (x, y, XDouble k r) + q_sub x y = do + (k,m,n) <- qdouble_align x y + (_, _, r) <- q_sub m n + return (x, y, XDouble k r) + q_abs x = do + let XDouble k m = x + (_, r) <- q_abs m + return (x, XDouble k r) + q_negate x = do + let XDouble k m = x + (_, r) <- q_negate m + return (x, XDouble k r) + q_signum x = do + let XDouble k m = x + (_, r) <- q_signum m + y <- qdouble_of_qsint r + return (x, y) + q_fromQDInt x = do + (_,y) <- q_fromQDInt x + z <- qdouble_of_qsint y + w <- qdouble_pad_right after_radix_length z + return (x,w) + -- 'q_mult' currently does not work with negative exponents. + q_mult x y = let m = max (xdouble_exponent x) (xdouble_exponent y) in + let s = (xdouble_exponent x) + (xdouble_exponent y) in + do + ext_x <- qdouble_pad_left m x + ext_y <- qdouble_pad_left m y + let XDouble kx nx = ext_x + let XDouble ky ny = ext_y + (_,_,nz) <- q_mult nx ny + let z = XDouble s nz + return (x,y,qdouble_truncate_right (s-m) z) + + +-- ---------------------------------------------------------------------- +-- * Other functions + + + +-- Developer note: the following instances are to be able to use +-- named_gate_safe, which is probably not at all safe. Also, it +-- requires us to define an Eq instance for every type where this is +-- used. The instances are defined as follows, and are considered a +-- temporary hack. + +-- Textual equality for 'QDouble'. +instance Eq QDouble where + XDouble a b == XDouble a' b' = (a,b) == (a',b') + +-- Textual equality for 'QSignedInt'. +instance Eq QSignedInt where + (SInt b c) == (SInt b' c') = (b,c) == (b',c') + + +-- | Coercion from 'QSignedInt' to 'QDouble'. +q_fromIntegral :: QSignedInt -> Circ QDouble +q_fromIntegral x = do + x' <- qsint_shift after_radix_length x + return $ XDouble after_radix_length x' + +-- | QDouble of 'ceiling': coercion from 'QDouble' to 'QSignedInt'. + +-- Note: This rounds to 0 and not to infinity. +q_ceiling :: QDouble -> Circ QSignedInt +q_ceiling (XDouble k (SInt x b)) = return $ SInt (reverse . drop k . reverse $ x) b + + +-- | Real division with 'QDouble'. +q_div_real :: QDouble -> QDouble -> Circ QDouble +q_div_real (XDouble kx (SInt x bx)) (XDouble ky (SInt y by)) = + if (kx /= ky) then error "q_div_real" + else + let k = kx in do + pad_x <- qinit (replicate k False) + pad_y <- qinit (replicate k False) + let ext_x = x ++ pad_x + let ext_y = pad_y ++ y + (_,_,ext_z) <- q_quot (qdint_of_qulist_bh ext_x) + (qdint_of_qulist_bh ext_y) + let z = reverse $ drop k $ reverse $ qulist_of_qdint_bh ext_z + bz <- qinit False + qnot_at bz `controlled` bx + qnot_at bz `controlled` by + return (XDouble k (SInt z bz)) + + + + +my_test = let x = fromRational $ toRational (12345.34) in + let y = fromRational $ toRational (323.1) in + let last (x,y,z) = z in + do + putStrLn $ show_fdouble x + putStrLn $ show_fdouble y + putStrLn $ show_fdouble $ snd $ run_classical_generic q_negate x + + + + + + +instance Num (FDouble,FDouble) where + x + y = undefined + x * y = undefined + x - y = undefined + fromInteger x = undefined + abs x = undefined + signum x = undefined + + +instance QNum (QDouble,QDouble) where + q_add (x1,x2) (y1,y2) = do + (_,_,z1) <- q_add x1 y1 + (_,_,z2) <- q_add x2 y2 + return ((x1,x2),(y1,y2),(z1,z2)) + + q_mult (x1,x2) (y1,y2) = do + (_,_,a) <- q_mult x1 y1 + (_,_,b) <- q_mult x2 y2 + (_,_,z1) <- q_sub a b + (_,_,c) <- q_mult x1 y2 + (_,_,d) <- q_mult x2 y1 + (_,_,z2) <- q_add c d + return ((x1,x2),(y1,y2),(z1,z2)) + + q_sub (x1,x2) (y1,y2) = do + (_,_,z1) <- q_sub x1 y1 + (_,_,z2) <- q_sub x2 y2 + return ((x1,x2),(y1,y2),(z1,z2)) + + q_abs x = do z <- qinit $ qc_false x; named_gate "abs" (x,z) + q_negate x = do z <- qinit $ qc_false x; named_gate "neg" (x,z) + q_signum x = do z <- qinit $ qc_false x; named_gate "sigNum" (x,z) + q_fromQDInt x = undefined diff --git a/Quipper/Algorithms/QLS/QLS.hs b/Quipper/Algorithms/QLS/QLS.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/QLS/QLS.hs @@ -0,0 +1,972 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 + {-# OPTIONS -fcontext-stack=50 #-} +#else + {-# OPTIONS -freduction-depth=50 #-} +#endif + +-- | This module contains the Quipper implementation of the Quantum +-- Linear Systems Algorithm. +-- +-- The algorithm estimates the radar cross section for a FEM +-- scattering problem by using amplitude estimation to calculate +-- probability amplitudes. +-- +-- The notations are based on the paper +-- +-- * B. D. Clader, B. C. Jacobs, C. R. Sprouse. Quantum algorithm to +-- calculate electromagnetic scattering cross +-- sections. . +module Quipper.Algorithms.QLS.QLS where + +import Quipper + +import Quipper.Libraries.QFT +import Quipper.Libraries.Arith +import Quipper.Libraries.Decompose + +import Data.Complex +import qualified Data.Map as Map + +import qualified Quipper.Algorithms.QLS.TemplateOracle as Template +import Quipper.Algorithms.QLS.QDouble +import Quipper.Algorithms.QLS.QSignedInt +import Quipper.Algorithms.QLS.CircLiftingImport +import Quipper.Algorithms.QLS.Utils + +import Quipper.Utils.Auxiliary(boollist_of_int_bh) + + +-- | The type of 'oracle_A' input arguments during runtime. +type OracleARunTime = Double -- ^Value resolution. + -> Int -- ^Band. + -> Bool -- ^Argflag. + -> ([Qubit],[Qubit],[Qubit]) -- ^(x=index,y+node,z+value). + -> Circ ([Qubit],[Qubit],[Qubit]) + +-- | The type of 'oracle_b' and 'oracle_r' input arguments during runtime. +type OracleBRRunTime = Double -- ^Magnitude resolution. + -> Double -- ^Phase resolution. + -> ([Qubit],[Qubit],[Qubit]) -- ^(x=index,m+magnitude,p+phase). + -> Circ ([Qubit],[Qubit],[Qubit]) + + +-- | A type to encapsulate all three oracles. +data Oracle = Oracle { + oracle_A :: RunTimeParam -> OracleARunTime, + oracle_b :: RunTimeParam -> OracleBRRunTime, + oracle_r :: RunTimeParam -> OracleBRRunTime +} + + +-- | A set of oracles using only blackboxes. +dummy_oracle :: Oracle +dummy_oracle = Oracle { + oracle_A = \d r i b x -> named_gate "Oracle A" x, + oracle_b = \d1 d2 r x -> named_gate "Oracle b" x, + oracle_r = \d1 d2 r x -> named_gate "Oracle r" x +} + + + +-- | A type to hold the runtime parameters. +data RunTimeParam = RT_param { + k :: Double, -- ^ Wave number. + theta :: Double, -- ^ Incident wave angle. + phi :: Double, -- ^ Direction of desired far field radiation pattern. + e0 :: Double, -- ^ Incident wave amplitude. + lambda :: Double, -- ^ Wavelength. + xlength :: Double, -- ^ /x/-length of square scattering region. + ylength :: Double, -- ^ /y/-length of square scattering region. + + scatteringnodes :: [(Int,Int)], -- ^ Metallic region. + + nx :: Int, + ny :: Int, + lx :: Double, + ly :: Double, + + kappa :: Double, + epsilon :: Double, + t0 :: Double, + r :: Double, + b_max :: Double, + r_max :: Double, + d :: Int, + nb :: Int, + p2 :: Double, + n0 :: Int, + n1 :: Int, + n2 :: Int, + n4 :: Int, + + -- argflags for oracle_A + magnitudeArgflag :: Bool, + phaseArgflag :: Bool +} deriving (Show) + + +-- | A convenient set of runtime parameters for testing. +dummy_RT_param :: RunTimeParam +dummy_RT_param = RT_param { + + k = 2.0*pi*1.0, + theta = 0.0*pi/4.0, + phi = 0.0, + e0 = 1.0, + lambda = (k dummy_RT_param)/(2.0*pi), + xlength = 2.0*(lambda dummy_RT_param), + ylength = 2.0*(lambda dummy_RT_param), + + scatteringnodes = + let rt = dummy_RT_param in + let xul = round((fromIntegral $ nx rt)/2) + - round((xlength rt)/(2.0*(lx rt))) in -- Upper left x index + let yul = round((fromIntegral $ ny rt)/2) + - round((ylength rt)/(2.0*(ly rt))) in -- Upper left y index + let xlr = round((fromIntegral $ nx rt)/2) + + round((xlength rt)/(2.0*(lx rt))) in -- Lower right x index + let ylr = round((fromIntegral $ ny rt)/2) + + round((ylength rt)/(2.0*(ly rt))) in -- Lower right y in + [(xul, yul), (xlr, ylr)], + + nx = 12885, + ny = 12885, + lx = 0.1, + ly = 0.1, + + kappa = 1.0, + epsilon = 1.0, + t0 = 1.0, + r = 1.0, + b_max = 1.0, + r_max = 1.0, + d = 3, + nb = 2, + p2 = 3, + n0 = 3, + n1 = 3, + n2 = 3, + n4 = 3, + + -- argflags for oracle_A + magnitudeArgflag = False, + phaseArgflag = True +} + + +-- | A set of larger values, for testing scalability. +large_RT_param :: RunTimeParam +large_RT_param = RT_param { + + k = 2.0*pi*1.0, + theta = 0.0*pi/4.0, + phi = 0.0, + e0 = 1.0, + lambda = (k large_RT_param)/(2.0*pi), + xlength = 2.0*(lambda large_RT_param), + ylength = 2.0*(lambda large_RT_param), + + scatteringnodes = + let rt = large_RT_param in + let xul = round((fromIntegral $ nx rt)/2) + - round((xlength rt)/(2.0*(lx rt))) in -- Upper left x index + let yul = round((fromIntegral $ ny rt)/2) + - round((ylength rt)/(2.0*(ly rt))) in -- Upper left y index + let xlr = round((fromIntegral $ nx rt)/2) + + round((xlength rt)/(2.0*(lx rt))) in -- Lower right x index + let ylr = round((fromIntegral $ ny rt)/2) + + round((ylength rt)/(2.0*(ly rt))) in -- Lower right y in + [(xul, yul), (xlr, ylr)], + + nx = 12885, + ny = 12885, + lx = 0.1, + ly = 0.1, + + kappa = 1e4, + epsilon = 0.01, + t0 = 7.0e6, + r = 2.5e12, + b_max = 5.0, + r_max = 1.01, + d = 7, + nb = 9, + p2 = ( 1.0 / (4-(4**(1/3))) ), + n0 = 14, + n1 = 24, + n2 = 30, + n4 = 65, + + -- argflags for oracle_A + magnitudeArgflag = False, + phaseArgflag = True +} + + +-- | A set of smaller values, for manageable yet meaningful output. +small_RT_param :: RunTimeParam +small_RT_param = RT_param { + + k = 2.0*pi*1.0, + theta = 0.0*pi/4.0, + phi = 0.0, + e0 = 1.0, + lambda = (k small_RT_param)/(2.0*pi), + xlength = 2.0*(lambda small_RT_param), + ylength = 2.0*(lambda small_RT_param), + + scatteringnodes = + let xul = 2 in + let yul = 2 in + let xlr = 3 in + let ylr = 3 in + [(xul, yul), (xlr, ylr)], + + nx = 4, + ny = 4, + lx = 0.1, + ly = 0.1, + + kappa = 1e4, + epsilon = 0.01, + t0 = 7.0e6, + r = 2.5e12, + b_max = 5.0, + r_max = 1.01, + d = 7, + nb = 9, + p2 = ( 1.0 / (4-(4**(1/3))) ), + n0 = 14, + n1 = 24, + n2 = 6, + n4 = 65, + + -- argflags for oracle_A + magnitudeArgflag = False, + phaseArgflag = True +} + + + +-- | Apply an [exp −/iYt/] gate. The timestep /t/ is a parameter. +expYt :: Timestep -> Qubit -> Circ Qubit +expYt = named_rotation "exp(-i%Y)" + + +-- | Apply an [exp −/iYt/] gate. The timestep /t/ is a parameter. +expYt_at :: Timestep -> Qubit -> Circ () +expYt_at = named_rotation_at "exp(-i%Y)" + + +-- | Read a list of bits and make it into a 'Double', by multiplying +-- its integer value by the provided factor. +dynamic_lift_double :: Double -> [Bit] -> Circ Double +dynamic_lift_double factor cl = do + cdiscard cl + +-- Implementation note: removed dynamic_lift as for now it breaks all +-- output formats except ASCII. + +-- bl <- dynamic_lift cl + let sign = 1 -- if (head $ reverse bl) then 1 else -1 + let unsigned_value = 1 -- integer_of_intm_unsigned $ + -- intm_of_boollist_bh (tail $ reverse bl) + return (sign * factor * (fromIntegral unsigned_value)) + + +-- | A black box gate to stand in as a replacement for QFT. +qft_for_show :: [Qubit] -> Circ [Qubit] +qft_for_show qs = named_gate "QFT" qs + + + +-- | Main function: for estimating the radar cross section for a FEM +-- scattering problem. The problem can be reduced to the calculation +-- of four angles: φ[sub /b/], φ[sub /bx/], φ[sub /r/1] and φ[sub /r/0]. +qlsa_FEM_main :: RunTimeParam -> Oracle -> Circ Double +qlsa_FEM_main param oracle = do + comment "FEM_main" + phi_b <- qlsa_AmpEst_phi_b param oracle + phi_bx <- qlsa_AmpEst_phi_bx param oracle + phi_r1 <- qlsa_AmpEst_phi_bxr param oracle True + phi_r0 <- qlsa_AmpEst_phi_bxr param oracle False + let sigma = ((((fromIntegral $ nb param) ^ 2) * ((b_max param) ^ 2) * ((r_max param) ^ 2) * ((sin phi_b) ^ 2)) / ( 4 * pi)) + comment "FEM_main" + return sigma + + + + +-- * Amplitude Estimation Functions + +-- | Estimates φ[sub /b/], related to the probability of success for the +-- preparation of the known state /b/, using amplitude amplification. +qlsa_AmpEst_phi_b :: RunTimeParam -> Oracle -> Circ Double +qlsa_AmpEst_phi_b param oracle = do + g <- qinit $ replicate (n0 param) False + with_ancilla_init (replicate (n2 param) False) $ \x -> do + label (g,x) ("g","x") + with_ancilla $ \a -> do + label (a) ("anc. a") + with_ancilla $ \b -> do + label (b) ("anc. b") + g <- map_hadamard g + u_b (x,b) + loop g u_g (x,b,a) + return () + return () + g' <- qft_big_endian g -- QFT : Is it really big-endian? + value_bits <- measure g' + value_double <- dynamic_lift_double 1.0 value_bits + return (pi * value_double / (2 ** (fromIntegral $ n0 param))) + where + loop :: [Qubit] -> (a -> Circ ()) -> a -> Circ () + loop [] f x = return () + loop (h:t) f x = do + f x `controlled` h + loop t f' x; + where + f' x = do f x; f x + + u_b :: ([Qubit],Qubit) -> Circ () + u_b xb = qlsa_StatePrep param xb (oracle_b oracle param) (1.0/(b_max param)) + + + u_g :: ([Qubit],Qubit,Qubit) -> Circ () + u_g (x,b,a) = do + comment "U_g starts" + gate_Z_at b + -- For unitrary linear transformation, adjoint == inverse, hence reverse_... + (reverse_generic_imp u_b) (x,b) + qnot_at a `controlled` x .==. (map (\x -> False) x) + gate_X_at a + gate_Z_at a + gate_X_at a + qnot_at a `controlled` x .==. (map (\x -> False) x) + u_b (x,b) + comment "U_g ends" + return () + + + +-- | Testing function for 'qlsa_AmpEst_phi_b'. +test_qlsa_AmpEst_phi_b :: Bool -> IO () +test_qlsa_AmpEst_phi_b dummyRTParamFlag = do + let param = if dummyRTParamFlag then dummy_RT_param else large_RT_param + print_simple GateCount (qlsa_AmpEst_phi_b param dummy_oracle) + print_simple Preview (qlsa_AmpEst_phi_b param dummy_oracle) + + +-- | Estimates φ[sub /bx/], related to the probability of success in +-- computing solution value /x/. +qlsa_AmpEst_phi_bx :: RunTimeParam -> Oracle -> Circ Double +qlsa_AmpEst_phi_bx param oracle = do + g <- qinit (take (n0 param) (repeat False)) + with_ancilla_init (take (n2 param) (repeat False)) $ \x -> do + with_ancilla $ \a -> do + with_ancilla $ \b -> do + with_ancilla $ \s -> do + g <- map_hadamard g + u_bx (x,b,s) + loop g u_g (x,b,s,a) + return () + return () + return () + g' <- qft_big_endian g -- QFT : Is it really big-endian? + value_bits <- measure g' + value_double <- dynamic_lift_double 1.0 value_bits + return (pi * value_double / (2 ** (fromIntegral $ n0 param))) + where + loop :: [Qubit] -> (a -> Circ ()) -> a -> Circ () + loop [] f x = return () + loop (h:t) f x = do + f x `controlled` h + loop t f' x + where + f' x = do f x; f x + + u_bx :: ([Qubit],Qubit,Qubit) -> Circ () + u_bx (x,b,s) = do + qlsa_StatePrep param (x,b) (oracle_b oracle param) (1.0/(b_max param)) + qlsa_Solve_x param (x,s) oracle + return () + + u_g :: ([Qubit],Qubit,Qubit,Qubit) -> Circ () + u_g (x,b,s,a) = do --named_gate_at "Ug_phi_bx" (x,b,s,a) + qnot_at a `controlled` b .&&. s + gate_Z_at a + qnot_at a `controlled` b .&&. s + (reverse_generic_imp u_bx) (x,b,s) + qnot_at a `controlled` [ q .==. 0 | q <- x ] .&&. b .==. 0 .&&. s .==. 0 + gate_X_at a + gate_Z_at a + gate_X_at a + qnot_at a `controlled` [ q .==. 0 | q <- x ] .&&. b .==. 0 .&&. s .==. 0 + u_bx (x,b,s) + return () + + + + +-- | Estimates φ[sub /r/0] and φ[sub /r/1] (depending on the boolean +-- parameter), related to the overlap of the solution with the +-- arbitrary state /r/. +qlsa_AmpEst_phi_bxr :: RunTimeParam -> Oracle -> Bool -> Circ Double +qlsa_AmpEst_phi_bxr param oracle target = do + g <- qinit (take (n0 param) (repeat False)) + with_ancilla_init (take (n2 param) (repeat False)) $ \x -> do + with_ancilla_init (take (n2 param) (repeat False)) $ \y -> do + with_ancilla $ \a -> do + with_ancilla $ \b -> do + with_ancilla $ \s -> do + with_ancilla $ \r -> do + with_ancilla $ \c -> do + g <- map_hadamard g + u_r (x,y,b,s,r,c) + loop g u_g (x,y,b,s,r,c,a) + return () + return () + return () + return () + return () + g' <- qft_big_endian g -- QFT : Is it really big-endian? + value_bits <- measure g' + value_double <- dynamic_lift_double 1.0 value_bits + return (pi * value_double / (2 ** (fromIntegral $ n0 param))) + where + loop :: [Qubit] -> (a -> Circ ()) -> a -> Circ () + loop [] f x = return () + loop (h:t) f x = do + f x `controlled` h + loop t f' x + where + f' x = do f x; f x + + u_r :: ([Qubit],[Qubit],Qubit,Qubit,Qubit,Qubit) -> Circ () + u_r (x,y,b,s,r,c) = do + qlsa_Solve_xr param (x,y,b,s,r,c) oracle + return () + + u_g :: ([Qubit],[Qubit],Qubit,Qubit,Qubit,Qubit,Qubit) -> Circ () + u_g (x,y,b,s,r,c,a) = do --named_gate_at "Ug_phi_bxr" (x,y,b,s,r,c,a) + qnot_at a `controlled` (b .==. 1 .&&. s .==. 1 .&&. r .==. 1 .&&. c .==. target) + gate_Z_at a + qnot_at a `controlled` (b .==. 1 .&&. s .==. 1 .&&. r .==. 1 .&&. c .==. target) + (reverse_generic_imp u_r) (x,y,b,s,r,c) + qnot_at a `controlled` [ q .==. 0 | q <- x ] .&&. [ q .==. 0 | q <- y ] .&&. b .==. 0 .&&. s .==. 0 .&&. r .==. 0 .&&. c .==. 0 + gate_X_at a + gate_Z_at a + gate_X_at a + qnot_at a `controlled` [ q .==. 0 | q <- x ] .&&. [ q .==. 0 | q <- y ] .&&. b .==. 0 .&&. s .==. 0 .&&. r .==. 0 .&&. c .==. 0 + u_r (x,y,b,s,r,c) + return () + + +-- * State Preparation. + +-- | Prepares a quantum state /x/, as specified by an oracle function, +-- entangled with a single qubit flag /q/ marking the desired state. +qlsa_StatePrep :: + RunTimeParam + -> ([Qubit], Qubit) -- x & qare handles to wires to be changed by StatePrep + -> OracleBRRunTime -- Common type of (oracle_b oracle) and (oracle_r oracle), if oracle is typed Oracle + -> Double + -> Circ () +qlsa_StatePrep param (x, q) oracle phi0 = do + _ <- (flip $ box ("qlsa_StatePrep_" ++ (show phi0))) (x,q) $ \(x,q) -> do + -- comment "StatePrep starts" + label (x,q) ("x", "q") + with_ancilla_list (n4 param) $ \m -> do + label (m) ("anc. m") + with_ancilla_list (n4 param) $ \p -> do + label (p) ("anc. p") + x <- map_hadamard x + (x, m, p) <- oracle phi0 (epsilon param) (x, m, p) + qlsa_ControlledPhase p (epsilon param) False + qlsa_ControlledRotation (m, q) phi0 False + (x, m, p) <- oracle phi0 (epsilon param) (x, m, p) + return (x,q) + -- comment "StatePrep ends" + return () + + +-- | Testing function for 'qlsa_StatePrep'. +test_qlsa_StatePrep :: Bool -> IO () +test_qlsa_StatePrep dummyRTParamFlag = do + let param = if dummyRTParamFlag then dummy_RT_param else large_RT_param + let oraclebRunTime = (oracle_b dummy_oracle param) + let testCirc = do + x <- qinit $ replicate (n2 param) False + q <- qinit False + qlsa_StatePrep param (x,q) oraclebRunTime 1.0 + print_simple GateCount testCirc + print_simple Preview testCirc + + + + +-- * Linear System Solver Functions + +-- | Implements the QLSA procedure to generate the solution state |/x/〉. +qlsa_Solve_x :: RunTimeParam ->([Qubit],Qubit) -> Oracle -> Circ () +qlsa_Solve_x param (x,s) oracle = do + _ <- (flip $ box "qlsa_Solve_x") (x,s) $ \(x,s) -> do + with_ancilla_list (n1 param) $ \t -> do + with_ancilla_list (length t) $ \f -> do + let phi0 = 2 * pi / (2 ** (fromIntegral $ n1 param) - (epsilon param)) + t <- map_hadamard t + u_hs (t,x) + t <- qft_big_endian t + integer_inverse (t,f) + qlsa_ControlledRotation (f,s) phi0 False + integer_inverse (t,f) + (reverse_generic_endo qft_big_endian) t + (reverse_generic_imp u_hs) (t,x) + t <- map_hadamard t + return() + return () + return (x,s) + return () + where + u_hs :: ([Qubit],[Qubit]) -> Circ () + u_hs (t,x) = do + qlsa_HamiltonianSimulation param (t,x) (oracle_A oracle param) + return () + + +-- | Implementation of the integer division. The two registers are +-- supposed to be of the same size and represent little-headian +-- unsigned integers, i.e., the head of the list holds the least +-- significant bit. +integer_inverse :: ([Qubit],[Qubit]) -> Circ () +integer_inverse (t,f) = do + _ <- (flip $ box "integer_inverse") (t,f) $ \(t,f) -> do + -- sanity check + if (length t /= length f) + then error "integer_inverse: registers of distinct sizes" + else return () + -- initialize an unsigned integer to 2^(length t) - 1 + with_ancilla_init (map (\_ -> True) t) $ \num -> do + -- perform the division (encapsulated in a subroutine) + let d = classical_to_reversible $ \(t,num) -> do + let x = ((qdint_of_qulist_lh num),(qdint_of_qulist_lh t)) + (_,_,f') <- uncurry q_div_unsigned x + return $ qulist_of_qdint_lh f' + d ((t,num),f) + return (t,f) + return () + + + + + +-- | Implements the complete QLSA procedure to find the +-- solution state |/x/〉 and then implements the swap protocol +-- required for estimation of 〈/x/|/r/〉. +qlsa_Solve_xr :: RunTimeParam ->([Qubit],[Qubit],Qubit,Qubit,Qubit,Qubit) -> Oracle -> Circ () +-- qlsa_Solve_xr param (x,y,b,s,r,c) oracle = named_gate_at "Solve_xr" (x,y,b,s,r,c) +qlsa_Solve_xr param (x,y,b,s,r,c) oracle = do + _ <- (flip $ box "qlsa_Solve_xr") (x,y,b,s,r,c) $ \(x,y,b,s,r,c) -> do + qlsa_StatePrep param (x,b) (oracle_b oracle param) (1.0/(b_max param)) + qlsa_Solve_x param (x,s) oracle + qlsa_StatePrep param (y,r) (oracle_r oracle param) (1.0/(r_max param)) + hadamard_at c + swap_at y x `controlled` c + hadamard_at c + return (x,y,b,s,r,c) + return () + + +-- * Hamiltonian Simulation Functions. + +-- | Uses a quantum register |/t/〉 to control the +-- implementation of the Suzuki method for simulating a Hamiltonian +-- specified by an oracle function. +qlsa_HamiltonianSimulation :: + RunTimeParam + -> ([Qubit], [Qubit]) + -> OracleARunTime + -> Circ () +qlsa_HamiltonianSimulation param (t, x) oracleA = do + _ <- (flip $ box "qlsa_HamiltonianSimulation") (t,x) $ \(t,x) -> do + -- Code the first line in a way that depends on the length of t rather + -- explicitly on (n1 param) which is supposed to be the length of t + -- Hence replaced the line below by the line after it. + -- let denom = 2 * (r param) * (fromIntegral ((n1 param) - 1)) + let denom = 2 * (r param) * ( 2^((length t) - 1) ) + let t1 = (p2 param) * (t0 param) / denom + let t2 = (1.0 - 4.0 * (p2 param)) * (t0 param) / denom + (t,x) <- box_loopM "TrotterLoop" (round $ r param) (t,x) (hs_loop t1 t2) + return (t,x) + return () + where + hs_loop :: Double -> Double -> ([Qubit], [Qubit]) -> Circ ([Qubit], [Qubit]) + hs_loop t1 t2 (t,x) = do + u_z_at (t,x) t1 + u_z_at (t,x) t1 + u_z_at (t,x) t2 + u_z_at (t,x) t1 + u_z_at (t,x) t1 + return (t,x) + + u_z_at :: ([Qubit], [Qubit]) -> Double -> Circ () + u_z_at (t, x) timeStep = do + for (nb param) 1 (-1) $ \jj -> do + qlsa_HsimKernel param (t, x) jj timeStep oracleA + endfor + for 1 (nb param) 1 $ \jj -> do + qlsa_HsimKernel param (t, x) jj timeStep oracleA + endfor + return () + +-- | Testing function for 'qlsa_HamiltonianSimulation'. +test_qlsa_HamiltonianSimulation :: Bool -> IO () +test_qlsa_HamiltonianSimulation dummyRTParamFlag = do + let param = if dummyRTParamFlag then dummy_RT_param else large_RT_param + let oracleARunTime = (oracle_A dummy_oracle param) + let testCirc = do + t <- qinit (take (n0 param) (repeat False)) + x <- qinit (take (n4 param) (repeat False)) + label(t,x) ("t", "x") + qlsa_HamiltonianSimulation param (t,x) oracleARunTime + print_simple GateCount testCirc +-- print_simple Preview testCirc + + + +-- | Uses an oracle function and timestep control register (/t/) to +-- apply 1-sparse Hamiltonian to the input state |/t/, /x/〉. +qlsa_HsimKernel :: + RunTimeParam + -> ([Qubit], [Qubit]) + -> Int + -> Double + -> OracleARunTime + -> Circ () +-- qlsa_HsimKernel param tx band timeStep oracleA = named_gate_at "HsimKernel" tx + +qlsa_HsimKernel param (t, x) band timeStep oracleA = do + _ <- (flip $ box ("qlsa_HsimKernel" ++ (show band) ++ (show timeStep))) (t,x) $ \(t,x) -> do + let phiP = (epsilon param) + with_ancilla_list (n2 param) $ \y -> do + with_ancilla_list (n4 param) $ \m -> do + with_ancilla_list (n4 param) $ \p -> do + label (y,m,p) ("y","m","p") + -- phases + oracleA phiP band (phaseArgflag param) (x,y,p) + qlsa_ControlledPhase p phiP False + oracleA phiP band (phaseArgflag param) (x,y,p) + -- magnitudes + let phiMag = 2 ** (negate $ fromIntegral $ after_radix_length) + oracleA phiMag band (magnitudeArgflag param) (x,y,m) + for 0 ((length t) - 1) 1 $ \ii -> do + let phi_mt = timeStep * phiMag * (2^ii) + qlsa_ApplyHmag param (x,y,m) phi_mt `controlled` (t !! ii) + endfor + oracleA phiMag band (magnitudeArgflag param) (x,y,m) + -- phases again + oracleA phiP band (phaseArgflag param) (x,y,p) + qlsa_ControlledPhase p phiP True + oracleA phiP band (phaseArgflag param) (x,y,p) + return () + return () + return () + return (t,x) + return () + +-- | Testing function for 'qlsa_HsimKernel'. +test_qlsa_HsimKernel :: Bool -> IO () +test_qlsa_HsimKernel dummyRTParamFlag = do + let param = if dummyRTParamFlag then dummy_RT_param else large_RT_param + let oracleARunTime = (oracle_A dummy_oracle param) + let testCirc = do + t <- qinit (take (n0 param) (repeat False)) + x <- qinit (take (n4 param) (repeat False)) + label(t,x) ("t", "x") + qlsa_HsimKernel param (t,x) 1 0.1 oracleARunTime + print_simple GateCount testCirc +-- print_simple Preview testCirc + + +-- | Applies the magnitude component of coupling elements in a +-- 1-sparse Hamiltonian. +qlsa_ApplyHmag :: RunTimeParam -> ([Qubit], [Qubit], [Qubit]) -> Double -> Circ () +qlsa_ApplyHmag param (x,y,m) phi0 = do + _ <- (flip $ box ("qlsa_ApplyHmag " ++ (show phi0))) (x,y,m) $ \(x,y,m) -> do + let (onOne, onZero) = (True, False) + with_ancilla $ \a -> do -- Assume initialized to False (0) + label (a) ("anc. a") + if (length x /= length y) + then error "qlsa_ApplyHmag: Input registers x and y have different lengths." + else return () + let length_xy = length x + for 0 (length_xy - 1) 1 $ \ii -> do + let (xi, yi) = (x !! ii, y !! ii) + w (xi, yi) + qnot_at a `controlled` (xi .==. onOne .&&. yi .==. onZero) + endfor + qlsa_ControlledPhase (m ++ [a]) phi0 False + for (length_xy - 1) 0 (-1) $ \ii -> do + let (xi, yi) = (x !! ii, y !! ii) + qnot_at a `controlled` (xi .==. onOne .&&. yi .==. onZero) + w (xi, yi) + endfor + return () + return (x,y,m) + return () + + +-- | Testing function for 'qlsa_ApplyHmag'. +test_qlsa_ApplyHmag :: Bool -> IO () +test_qlsa_ApplyHmag dummyRTParamFlag = do + let param = if dummyRTParamFlag then dummy_RT_param else large_RT_param + let testCirc = do + x <- qinit (take (n2 param) (repeat False)) + y <- qinit (take (n2 param) (repeat False)) + m <- qinit (take (n4 param) (repeat False)) + label(x,y,m) ("x", "y", "m") + qlsa_ApplyHmag param (x,y,m) 0.1 + print_simple GateCount testCirc + print_simple Preview testCirc + + + + + +-- | Auxiliary function: the /W/-gate. +w :: (Qubit, Qubit) -> Circ () +-- w xy = named_gate_at "W" xy +w (xi,yi) = do + _ <- box "w" (\(xi, yi) -> do + label (xi,yi) ("x[i]","y[i]") + gate_X_at xi `controlled` yi + gate_X_at yi `controlled` xi + hadamard_at yi `controlled` xi + gate_X_at yi `controlled` xi + gate_X_at xi `controlled` yi + return (xi,yi)) (xi,yi) + return () + +-- | Testing function for 'w'. +test_w :: IO () +test_w = do + let testCirc = do + xi <- qinit False + yi <- qinit False + w (xi, yi) + print_simple GateCount testCirc + print_simple Preview testCirc + + +-- * Controlled Logic Operations + + +-- | Applies a phase shift of φ\/2 to the signed input register |φ〉. + +-- For c, bit locations are counted starting from 0 (least significant) to (length c - 2) (most significant) +-- last c (or c !! (n-1)) is the sign bit +qlsa_ControlledPhase :: [Qubit] -> Double -> Bool -> Circ () +-- qlsa_ControlledPhase c phi0 f = named_gate_at "CPhase" c +qlsa_ControlledPhase c phi0 f = do + _ <- (flip $ box ("qlsa_ControlledPhase " ++ (show phi0) ++ " " ++ (show f))) c $ \c -> do + with_ancilla $ \a -> do -- ancilla is initialized to False + if f then (qnot_at a) else return () + let signQubit = last c + qnot_at a `controlled` signQubit + for 0 (length c - 2) 1 $ \ii -> do + let theta = ( (2.0^(ii)) * phi0 / 2.0) -- Note the divide by 2 + -- The following three lines are equivalent + expZt_at theta a `controlled` (c !! ii) + -- a <- expZt theta a `controlled` (c !! ii); return () + -- qlsa_ControlledU (c !! ii, a) (expZt theta) False + endfor + qnot_at a `controlled` signQubit + return c + return () + + +-- | Applies a rotation of φ\/2 to the signed input register |φ〉. +qlsa_ControlledRotation :: ([Qubit], Qubit) -> Double -> Bool -> Circ () +-- qlsa_ControlledRotation ct phi0 f = named_gate_at "CRotate" ct +qlsa_ControlledRotation (c, t) phi0 f = do + _ <- (flip $ box ("qlsa_ControlledRotation " ++ (show phi0) ++ " " ++ (show f))) (c,t) $ \(c,t) -> do + if f then (qnot_at t) else return () + let signQubit = last c + qnot_at t `controlled` signQubit + for 0 (length c - 2) 1 $ \ii -> do + let theta = (2.0^(ii)) * phi0 / 2.0 + expYt_at theta t `controlled` (c !! ii) + endfor + qnot_at t `controlled` signQubit + if f then (qnot_at t) else return () + return (c,t) + return () + + +---------------------------------------------------------------------- +-- * Oracles + +-- | Map a 'QDouble' into an integer, understood as being scaled by +-- the given factor. Take the factor and the size of the output +-- register as parameter. +make_factor_rep :: Double -> Int -> QDouble -> Circ [Qubit] +make_factor_rep factor size p = do + -- number of high bits of p + let p_int_size = (xdouble_length p) - (xdouble_exponent p) + -- get the required number of bits for doing the encoding + let auxsize = max (size - 1) p_int_size + -- do the operation: + -- (1) build a QDouble from the factor: need (size-1) bits of integer part + qfactor <- qinit $ fdouble_of_double (xdouble_exponent p) + (auxsize + xdouble_exponent p) factor + -- (2) scale p + p_large <- qdouble_pad_to_extent (auxsize,- (xdouble_exponent p)) p + -- (3) divide p by factor + qreal_multiples <- unpack template_symb_slash_ p_large qfactor + -- (4) get the floor of the result + q_floor <- template_floor + qmultiples <- q_floor qreal_multiples + -- (5) set them in the right format (it has size elements) + let (SInt tp bp) = qmultiples + let new_p = (take (size - 1) $ reverse tp) ++ [bp] + return new_p + + + +-- | Implements the oracle for the arbitrary state |/r/〉, using the +-- Template Haskell implementation of 'Template.calcRweights'. +inline_oracle_r :: RunTimeParam -> Double -> Double -> ([Qubit],[Qubit],[Qubit]) -> Circ ([Qubit],[Qubit],[Qubit]) +inline_oracle_r rt factor_m factor_p = box ("Or " ++ (show factor_m) ++ " " ++ (show factor_p)) $ decompose_generic Toffoli $ \(x',m',p') -> + with_ancilla_init (fromIntegral $ nx rt :: FSignedInt) $ \qnx -> + with_ancilla_init (fromIntegral $ ny rt :: FSignedInt) $ \qny -> + with_ancilla_init (fdouble $ lx rt) $ \qlx -> + with_ancilla_init (fdouble $ ly rt) $ \qly -> + with_ancilla_init (fdouble $ k rt) $ \qk -> + with_ancilla_init (fdouble $ theta rt) $ \qtheta -> + with_ancilla_init (fdouble $ phi rt) $ \qphi -> + -- the x register is smaller than the size of a QSInt, + -- and x is an unsigned integer: make up a positive + -- sign and a pad + + with_ancilla_init False $ \bx -> do + with_ancilla_init (replicate (fixed_int_register_length - (n2 rt)) + False) $ \pad_x -> do + + let x = SInt (pad_x ++ (reverse x')) bx + let f = classical_to_reversible $ + \(x,nx,ny,lx,ly,k,theta,phi) -> do + (m,p) <- unpack Template.template_calcRweights + x nx ny lx ly k theta phi + new_p <- make_factor_rep factor_p (n4 rt) p + new_m <- make_factor_rep factor_m (n4 rt) m + return (new_m, new_p) + f ((x,qnx,qny,qlx,qly,qk,qtheta,qphi),(m',p')) + return (x',m',p') + + + + + +-- | Implements the oracle for the known state |/b/〉, using the +-- Template Haskell implementation of 'Template.getKnownWeights'. +inline_oracle_b :: RunTimeParam -> Double -> Double -> ([Qubit],[Qubit],[Qubit]) -> Circ ([Qubit],[Qubit],[Qubit]) +inline_oracle_b rt factor_m factor_p = box ("Ob " ++ (show factor_m) ++ " " ++ (show factor_p)) $ decompose_generic Toffoli $ \(x',m',p') -> + -- Make ancillas for constant values + + with_ancilla_init (listpair_fmap fromIntegral $ scatteringnodes rt :: [(FDouble,FDouble)]) $ \qscatteringnodes -> + with_ancilla_init (fromIntegral $ ny rt :: FSignedInt) $ \qny -> + with_ancilla_init (fdouble $ lx rt) $ \qlx -> + with_ancilla_init (fdouble $ ly rt) $ \qly -> + with_ancilla_init (fdouble $ k rt) $ \qk -> + with_ancilla_init (fdouble $ theta rt) $ \qtheta -> + with_ancilla_init (fdouble $ e0 rt) $ \qe0 -> + with_ancilla_init (fromIntegral $ nx rt :: FSignedInt) $ \qnx -> do + + -- the x register is smaller than the size of a QSInt, + -- and x is an unsigned integer: make up a positive + -- sign and a pad + + with_ancilla_init False $ \bx -> do + with_ancilla_init (replicate (fixed_int_register_length - (n2 rt)) + False) $ \pad_x -> do + + let x = SInt (pad_x ++ (reverse x')) bx + + let f = classical_to_reversible $ + \(y,nx,ny,scatteringnodes,lx,ly,k,theta,e0) -> do + -- get some QSInt and QDouble + (m,p) <- unpack Template.template_getKnownWeights + y nx ny scatteringnodes lx ly k theta e0 7 + new_p <- make_factor_rep factor_p (n4 rt) p + new_m <- make_factor_rep factor_m (n4 rt) m + + return (new_m, new_p) + + f ((x,qnx,qny,qscatteringnodes,qlx,qly,qk,qtheta,qe0),(m',p')) + return (x',m',p') + + +-- | Implementation of the oracle calculating the matrix /A/ +-- corresponding to the discretization of the scattering problem, +-- using the Template Haskell implementation of +-- 'Template.getNodeValuesMoreOutputs'. +inline_oracle_A :: RunTimeParam -> Double -> Int -> Bool -> ([Qubit],[Qubit],[Qubit]) -> Circ ([Qubit],[Qubit],[Qubit]) +inline_oracle_A rt factor band argflag = box ("OA " ++ (show band) ++ " " ++ (show argflag)) $ decompose_generic Toffoli $ \(x',y',p') -> do + + let argflag' = if argflag then PTrue else PFalse + + -- Make ancillas for constant values + + with_ancilla_init (listpair_fmap fromIntegral $ scatteringnodes rt :: [(FDouble, FDouble)]) $ \qscatteringnodes -> + with_ancilla_init (fromIntegral $ ny rt :: FSignedInt) $ \qny -> + with_ancilla_init (fromRational $ toRational $ lx rt) $ \qlx -> + with_ancilla_init (fromRational $ toRational $ ly rt) $ \qly -> + with_ancilla_init (fromRational $ toRational $ k rt) $ \qk -> + with_ancilla_init (fromIntegral $ nx rt :: FSignedInt) $ \qnx -> do + + -- the x register is smaller than the size of a QSInt, + -- and x is an unsigned integer: make up a positive + -- sign and a pad + + with_ancilla_init False $ \bx -> do + with_ancilla_init (replicate (fixed_int_register_length - (n2 rt)) + False) $ \pad_x -> do + + let x = SInt (pad_x ++ (reverse x')) bx + + let f = classical_to_reversible $ + \(v,nx,ny,scatteringnodes,lx,ly,k) -> do + -- get some QSInt and QDouble + (y,p) <- unpack Template.template_getNodeValuesMoreOutputs + v band nx ny scatteringnodes lx ly k argflag' 7 + + new_p <- make_factor_rep factor (n4 rt) p + + -- set y in the correct format (it has n2 elements) + -- we can assume that the sign is positive. + -- we also assume that n2 < size of QSInt register + let (SInt ty _) = y + let new_y = (take (n2 rt) $ reverse ty) + + -- return the values in the right format. + return (new_y,new_p) + + f ((x,qnx,qny,qscatteringnodes,qlx,qly,qk),(y',p')) + + return (x',y',p') + + +-- | Encapsulate the inline oracles in Template Haskell into an object +-- of type 'Oracle'. +inline_oracle :: Oracle +inline_oracle = Oracle { + oracle_A = inline_oracle_A, + oracle_b = inline_oracle_b, + oracle_r = inline_oracle_r +} diff --git a/Quipper/Algorithms/QLS/QSignedInt.hs b/Quipper/Algorithms/QLS/QSignedInt.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/QLS/QSignedInt.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A module implementing signed quantum integers. We piggy-back on +-- the type 'IntM', considering it as a type of unsigned quantum +-- integers. +module Quipper.Algorithms.QLS.QSignedInt where + +import Data.Typeable + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Arith +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.QLS.Utils +import Quipper.Algorithms.QLS.QSignedIntAux + +import Quipper.Utils.Auxiliary + +-- ---------------------------------------------------------------------- +-- * Signed integer type + +-- | Data type for signed integers. Note that this particular variant +-- does not use two's complement to represent negative numbers, but an +-- explicit sign bit. In particular, there are two different +-- representations of 0 (however, the arithmetic operations always +-- produce +0). +-- +-- This is the generic type, where /x/ represents a bit. An integer is +-- represented as 'SInt' /digits/ /sign/, where /digits/ is a +-- big-headian list of digits (i.e., the most significant bit occupies +-- the head of the list), and /sign/ is the sign, with 'False' +-- representing plus and 'True' representing minus. +-- +-- When we speak of the \"length\" of a 'SignedInt', we mean the +-- number of digits excluding the sign. +data SignedInt x = SInt [x] x + deriving (Show, Typeable) + +-- | The parameter type of signed integers. +type FSignedInt = SignedInt Bool + +-- | The quantum type of signed integers. +type QSignedInt = SignedInt Qubit + +-- | The classical type of signed integers. +type CSignedInt = SignedInt Bit + +-- ---------------------------------------------------------------------- +-- * Conversions for 'FSignedInt' + +-- | Take a length and an integer, and return a 'FSignedInt' of the +-- given length. +fsint_of_integer :: Int -> Integer -> FSignedInt +fsint_of_integer m x = SInt digits sign where + digits = boollist_of_int_bh m (abs x) + sign = (x < 0) + +-- | Convert an 'FSignedInt' to an integer. +integer_of_fsint :: FSignedInt -> Integer +integer_of_fsint (SInt digits sign) = if sign then -a else a where + a = int_of_boollist_unsigned_bh digits + +-- | Get the length of a 'SignedInt'. +sint_length :: SignedInt x -> Int +sint_length (SInt digits sign) = length digits + +instance Enum FSignedInt where + succ x = fsint_of_integer m . succ . integer_of_fsint $ x + where m = sint_length x + pred x = fsint_of_integer m . pred . integer_of_fsint $ x + where m = sint_length x + toEnum x = fsint_of_integer m (fromIntegral x) + where m = (+) 1 $ ceiling $ logBase 2 $ fromIntegral x + fromEnum x = fromIntegral . integer_of_fsint $ x + +-- QCData instance + +type instance QCType x y (SignedInt z) = SignedInt (QCType x y z) +type instance QTypeB FSignedInt = QSignedInt + +instance QCLeaf x => QCData (SignedInt x) where + qcdata_mapM (shape :: SignedInt x) f g (SInt digits sign) = do + digits' <- qcdata_mapM [dummy :: x] f g digits + sign' <- qcdata_mapM (dummy :: x) f g sign + return (SInt digits' sign') + + qcdata_zip (shape :: SignedInt x) q c q' c' (SInt digits sign) (SInt digits' sign') e + = (SInt digits'' sign'') + where + digits'' = qcdata_zip [dummy :: x] q c q' c' digits digits' errmsg + sign'' = qcdata_zip (dummy :: x) q c q' c' sign sign' e + errmsg x = e "SignedInt length mismatch" + + qcdata_promote (SInt digits sign) (SInt digits' sign') e + | length digits /= length digits' + = error (e "SignedInt length mismatch") + | otherwise + = (SInt digits'' sign'') + where + digits'' = qcdata_promote digits digits' e + sign'' = sign + +-- Labeling of QSignedInt is s.sign, s[m-1], ..., s[0] +instance QCLeaf x => Labelable (SignedInt x) String where + label_rec (SInt digits sign) s = do + label_rec (reverse digits) s + label_rec sign s `dotted_indexed` "sign" + +-- * Operations + +-- | Make two qubit lists be of the same length, by prepending qubits +-- initialized to 'False' to the head of the shorter of the two lists. +left_pad_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit]) +left_pad_qulist l1 l2 = if (length l1 == length l2) then return (l1,l2) + else do + let m = abs (length l1 - length l2) + pad <- qinit (replicate m False) + if (length l1 > length l2) + then return (l1,pad ++ l2) + else return (pad ++ l1, l2) + +-- | Shift an 'FSignedInt' by /k/ digits to the left. In other words, +-- multiply it by 2[sup /k/], while simultaneously increasing the +-- length by /k/. +fsint_shift :: Int -> FSignedInt -> FSignedInt +fsint_shift k (SInt digits sign) = (SInt digits' sign) + where + digits' = digits ++ replicate k False + + +-- | One half of an isomorphism between 'QSignedInt' and ('Qubit', 'QDInt'). +s_qdint_of_qsint :: QSignedInt -> (Qubit, QDInt) +s_qdint_of_qsint (SInt q b) = (b, qdint_of_qulist_bh q) + +-- | The other half of an isomorphism between 'QSignedInt' and +-- ('Qubit', 'QDInt'). +qsint_of_s_qdint :: (Qubit, QDInt) -> QSignedInt +qsint_of_s_qdint (b, q) = SInt (qulist_of_qdint_bh q) b + +-- | Shift a 'QSignedInt' by /k/ digits to the left. In other words, +-- multiply it by 2[sup /k/], while simultaneously increasing the +-- length by /k/. +qsint_shift :: Int -> QSignedInt -> Circ QSignedInt +qsint_shift k (SInt digits sign) = do + pad <- qinit (replicate k False) + let digits' = digits ++ pad + return (SInt digits' sign) + + + + +-- Ordering on QSignedInt. If two operands are to be compared, it is +-- not necessarily assumed that they are of the same length, and this +-- feature is actually exploited by the QOrd QDouble instance. +-- However, note that the default implementations of 'max' and 'min' +-- do assume equal length. +instance QOrd QSignedInt where + q_less (SInt x' b) (SInt y' c) = do + (x,y) <- left_pad_qulist x' y' + unpack template_be_signed_boollist_less (b, x) (c, y) + + +instance Eq FSignedInt where + x == y = (integer_of_fsint x) == (integer_of_fsint y) + + +instance Ord FSignedInt where + compare x y = compare (integer_of_fsint x) (integer_of_fsint y) + + +instance Num FSignedInt where + x + y = fsint_of_integer m $ (integer_of_fsint x) + (integer_of_fsint y) + where + m = max (sint_length x) (sint_length y) + x * y = fsint_of_integer m $ (integer_of_fsint x) * (integer_of_fsint y) + where + m = max (sint_length x) (sint_length y) + x - y = fsint_of_integer m $ (integer_of_fsint x) - (integer_of_fsint y) + where + m = max (sint_length x) (sint_length y) + fromInteger x = fsint_of_integer fixed_int_register_length x + abs x = fsint_of_integer m . abs . integer_of_fsint $ x + where + m = sint_length x + signum x = fsint_of_integer m . signum . integer_of_fsint $ x + where + m = sint_length x + + +instance Real FSignedInt where + toRational = toRational . integer_of_fsint + +instance Integral FSignedInt where + quotRem x y = (fsint_of_integer m q, fsint_of_integer m r) where + m = max (sint_length x) (sint_length y) + (q,r) = quotRem (integer_of_fsint x) (integer_of_fsint y) + toInteger = integer_of_fsint + + +instance QNum QSignedInt where + q_add (SInt x' b) (SInt y' c) = do + (x,y) <- left_pad_qulist x' y' + (d,z) <- unpack template_be_signed_boollist_add (b,x) (c,y) + return (SInt x' b, SInt y' c, SInt z d) + + q_mult (SInt x' b) (SInt y' c) = do + (x,y) <- left_pad_qulist x' y' + (_, _, z') <- q_mult (qdint_of_qulist_bh x) (qdint_of_qulist_bh y) + (_, _, d') <- q_add (qdint_of_qulist_bh [b]) (qdint_of_qulist_bh [c]) + let z = qulist_of_qdint_bh z' + let d = qulist_of_qdint_bh d' + return (SInt x' b, SInt y' c, SInt z $ head d) + + q_sub x y = do + (y,z) <- q_negate y + (x,z,t) <- q_add x z + return (x,y,t) + + q_abs (SInt l s) = do + l' <- qinit $ qc_false l; + s' <- qinit False + controlled_not_at l' l + return (SInt l s, SInt l' s') + + q_negate (SInt l s) = do + l' <- qinit $ qc_false l; + s' <- qinit False + controlled_not_at l' l + qnot_at s' `controlled` s .==. 0 + return (SInt l s, SInt l' s') + + q_signum (SInt l s) = do + l' <- qinit $ qc_false l; + s' <- qinit False + qnot s' `controlled` s + return (SInt l s, SInt l' s') + + q_fromQDInt l1 = do + let l = qulist_of_qdint_bh l1 + l' <- qinit $ qc_false l; + controlled_not_at l' l + s' <- qinit False + return (qdint_of_qulist_bh l, SInt l' s') + + + +-- | The modulo operation on 'QSignedInt'. +q_mod :: QSignedInt -> QSignedInt -> Circ QSignedInt +q_mod x y = do + let (x_b, x') = s_qdint_of_qsint x + let (y_b, y') = s_qdint_of_qsint y + (_,_,z1) <- q_quot x' y' + (_,_,z2) <- q_mult y' z1 + (_,_,z3) <- q_sub x' z2 + z_b <- qinit False + qnot_at z_b `controlled` x_b + qnot_at z_b `controlled` y_b -- XXXXXXXXXX TO CHECK + let z = qsint_of_s_qdint (z_b,z3) + return z + + + +my_test = let x = fsint_of_integer 50 1595713 in + let y = fsint_of_integer 30 547137 in + let last (x,y,z) = z in + do + putStrLn $ show (x < y) + putStrLn $ show $ last $ run_classical_generic q_add x y + putStrLn $ show (x - y) + putStrLn $ show $ last $ run_classical_generic q_sub x y + putStrLn $ show $ run_classical_generic q_less x y + putStrLn $ show $ run_classical_generic q_less y x + print_simple GateCount $ do + a <- qinit x + b <- qinit y + b <- q_less a b + return () + + diff --git a/Quipper/Algorithms/QLS/QSignedIntAux.hs b/Quipper/Algorithms/QLS/QSignedIntAux.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/QLS/QSignedIntAux.hs @@ -0,0 +1,93 @@ +-- | Helper module for "Quipper.Algorithms.QLS.QSignedInt": some functions +-- defined with Template Haskell. +module Quipper.Algorithms.QLS.QSignedIntAux where + +import Quipper +import Quipper.Libraries.Arith + + + +-- | Subtraction on lists of booleans, understood as big-headian, +-- unsigned integers. + +-- void definition for now +be_boollist_sub :: [Bool] -> [Bool] -> [Bool] +be_boollist_sub = error "be_boollist_sub yet undefined." + + +-- Template version of 'be_boollist_sub'. + +-- Right now, call to q_sub. +-- template_be_boollist_sub :: Circ ([Qubit] -> Circ ([Qubit] -> Circ [Qubit])) +template_be_boollist_sub = return $ \x -> return $ \y -> do + let x' = qdint_of_qulist_bh x + let y' = qdint_of_qulist_bh y + (_,_,z) <- q_sub x' y' + return $ qulist_of_qdint_bh z + + +-- | Addition on lists of booleans, understood as big-headian, unsigned +-- integers. + +-- void definition for now. +be_boollist_add :: [Bool] -> [Bool] -> [Bool] +be_boollist_add = error "be_boollist_add yet undefined." + + + +-- Template version of 'be_boollist_add' + +-- Right now, call q_add +-- template_be_boollist_add :: Circ ([Qubit] -> Circ ([Qubit] -> Circ [Qubit])) +template_be_boollist_add = return $ \x -> return $ \y -> do + let x' = qdint_of_qulist_bh x + let y' = qdint_of_qulist_bh y + (_,_,z) <- q_add x' y' + return $ qulist_of_qdint_bh z + + + +-- | Strict ordering on lists of booleans, understood as big-headian +-- unsigned integers. If the lists are not of equal length, the +-- shorter list is treated as if its tail were padded with zeros. +build_circuit +be_boollist_less :: [Bool] -> [Bool] -> Bool +be_boollist_less l1 l2 = + case (l1,l2) of + (a,[]) -> False + ([],a) -> be_boollist_less [False] a + (h1:t1, h2:t2) -> + let parity = if h1 then h2 else not h2 in + if parity then be_boollist_less t1 t2 + else h2 + + +-- | Strict ordering on lists of booleans, understood as big-headian +-- signed integers: the 'Bool' in the pair stands for the sign: 'False' +-- is positive, 'True' is negative. +build_circuit +be_signed_boollist_less :: (Bool,[Bool]) -> (Bool,[Bool]) -> Bool +be_signed_boollist_less (b1,l1) (b2,l2) = + if b1 then (if b2 then be_boollist_less l2 l1 else True) + else (if b2 then False else be_boollist_less l1 l2) + + +-- | Test whether all elements of a list are 'False'. +build_circuit +boollist_is_zero :: [Bool] -> Bool +boollist_is_zero l = + case l of + [] -> True + (h:t) -> if h then boollist_is_zero t else False + + +-- | Addition on signed integers, encoded as big-headian lists of +-- booleans. +build_circuit +be_signed_boollist_add :: (Bool,[Bool]) -> (Bool,[Bool]) -> (Bool,[Bool]) +be_signed_boollist_add (b,x) (c,y) = + let parity = if b then c else not c in + let (d,z) = if parity then (b, be_boollist_add x y) + else if (be_boollist_less x y) then (c, be_boollist_sub y x) + else (b, be_boollist_sub x y) + in if (boollist_is_zero z) then (False,z) else (d,z) diff --git a/Quipper/Algorithms/QLS/RealFunc.hs b/Quipper/Algorithms/QLS/RealFunc.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/QLS/RealFunc.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + + +-- | Define various analytic functions for 'FDouble' and 'QDouble'. +module Quipper.Algorithms.QLS.RealFunc where + +import Data.List(mapAccumL) +import Quipper +import Quipper.Algorithms.QLS.CircLiftingImport +import Quipper.Algorithms.QLS.QSignedInt +import Quipper.Algorithms.QLS.QDouble +import Quipper.Algorithms.QLS.Utils + + +-- * Some analytic functions on 'FDouble'. + +-- | Approximation of the sine function using Taylor series. +build_circuit +approx_sin :: FDouble -> FDouble +approx_sin x = let x2 = x * x in + let x3 = x2 * x in + let x4 = x2 * x2 in + let x5 = x4 * x in + let x7 = x2 * x5 in + let x9 = x2 * x7 in + let x11 = x2 * x9 in + x - (x3 / 6.0) + + (x5 / 120.0) + - (x7 / 5040.0) + + (x9 / 362880.0) + - (x11 / 39916800.0) + + +-- | Implementation of the sine function valid on the whole domain of +-- 'FDouble'. +build_circuit +local_sin :: FDouble -> FDouble +local_sin x = let n = fromIntegral $ floor (x/(2.0*local_pi)) in + let y = x - 2.0*local_pi*n in + if (y < local_pi/2.0) then approx_sin y + else if (y > 3.0*local_pi/2.0) then approx_sin (y - 2.0*local_pi) + else approx_sin (local_pi - y) + + +-- | Implementation of the cosine function valid on the whole domain +-- of 'FDouble'. +build_circuit +local_cos :: FDouble -> FDouble +local_cos x = local_sin (x + local_pi/2.0) + + + + +-- listAngle :: [Double] +listAngle = snd $ mapAccumL (\a x -> (a+1, x / (2 ** a))) 3.0 (replicate after_radix_length pi) + +-- template_listAngle :: Circ [QDouble] +template_listAngle = mapM (\x -> qinit $ fdouble x) listAngle + +-- listCos :: [Double] +listCos = map cos listAngle + +-- template_listCos :: Circ [QDouble] +template_listCos = mapM (\x -> qinit $ fdouble x) listCos + +-- listSin :: [Double] +listSin = map sin listAngle + +-- template_listSin :: Circ [QDouble] +template_listSin = mapM (\x -> qinit $ fdouble x) listCos + + + +-- list_values :: [(FDouble,FDouble,FDouble)] +list_values = map (\(x,y,z) -> (fdouble x, fdouble y, fdouble z)) $ + zip3 listAngle listCos listSin + +template_list_values = mapM (\(x,y,z) -> do + x' <- qinit $ fdouble x + y' <- qinit $ fdouble y + z' <- qinit $ fdouble z + return (x',y',z')) $ zip3 listAngle listCos listSin + + +-- | Auxiliary function for 'local_sqrt'. +build_circuit +approx_sqrt :: Int -> FDouble -> FDouble +approx_sqrt n x = case n of + 0 -> x + n -> let s = approx_sqrt (paramPred n) x in (s + x/s)/2.0 + +-- | Approximation of the square root using iterative means. +build_circuit +local_sqrt :: FDouble -> FDouble +local_sqrt x = approx_sqrt paramTen x + + +-- | The function 'Data.Complex.magnitude' defined for +-- 'FDouble'. Calculate the non-negative magnitude of a complex number. +build_circuit +local_mag :: FDouble -> FDouble -> FDouble +local_mag x y = local_sqrt (x * x + y * y) + + +-- | Apply the matrix +-- +-- > ( a b ) +-- > ( c d ) +-- +-- to the column vector (/x/,/y/). +build_circuit +rotate :: FDouble -> FDouble -> FDouble -> FDouble -> FDouble -> FDouble -> (FDouble,FDouble) +rotate a b c d x y = (a * x + b * y, c * x + d * y) + where + -- To help the GHC 8.0 typechecker + dummy = id_fdouble x + + +-- | Auxiliary function for 'approx_atan2'. +build_circuit +approx_atan2_aux :: FDouble -> FDouble -> (FDouble,FDouble, FDouble) -> (FDouble, FDouble, FDouble) + -> (FDouble,FDouble,FDouble) +approx_atan2_aux x y (angle, x', y') (r, cn, sn) = + let (a,(b,c)) = if (y' > y) then (angle - r, rotate cn sn (-sn) cn x' y') + else (angle + r, rotate cn (-sn) sn cn x' y') + in (a,b,c) + where + -- To help the GHC 8.0 typechecker + dummy_r = id_fdouble r + +-- | Definition of 'atan2' using a CORDIC method. Assume (/x/,/y/) is +-- in first quadrant and that /x/ > /y/. +build_circuit +approx_atan2 :: FDouble -> FDouble -> FDouble +approx_atan2 y x = + let list = list_values in + let (a,_,_) = foldl (approx_atan2_aux x y) (0.0, local_mag x y, 0.0) list in a + +-- | Definition of 'atan2' using a CORDIC method. /x/ and /y/ can be any 'FDouble'. +build_circuit +local_atan2 :: FDouble -> FDouble -> FDouble +local_atan2 y' x' = + let (x,y,(pad,sign)) = if (x' >= 0.0 && y' >= 0.0) then ( x', y', (0.0, 1.0)) + else if (x' >= 0.0 && y' < 0.0) then ( x', -y', (0.0, -1.0)) + else if (x' < 0.0 && y' < 0.0) then (-x', -y', (-local_pi, 1.0)) + else (-x', y', (local_pi, -1.0)) + in + let angle = if (x > y) then approx_atan2 y x + else local_pi/2.0 - approx_atan2 x y + in sign * angle + pad + + +-- | The function 'Data.Complex.mkPolar' defined for 'FDouble'. Form a +-- complex number from polar components of magnitude and phase. +build_circuit +local_mkPolar :: FDouble -> FDouble -> (FDouble,FDouble) +local_mkPolar p t = (p * local_cos t, p * local_sin t) + + + + + + +instance Floating FDouble where + pi = fromRational $ toRational pi + sin x = local_sin x + cos x = local_cos x + + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x - exp (-x)) / 2 + + asinh x = error "asinh not defined for FDouble" + acosh x = error "acosh not defined for FDouble" + atanh x = error "atanh not defined for FDouble" + + exp x = undefined + log x = undefined + + asin x = error "asin not defined for FDouble" + acos x = error "acos not defined for FDouble" + atan x = atan2 x 1 + + +instance RealFloat FDouble where + floatRadix _ = 2 + floatDigits x = xdouble_length x + floatRange _ = (0,0) + decodeFloat (XDouble k n) = (integer_of_fsint n, -k) + encodeFloat x k = XDouble (-k) (fromInteger x) + isNaN _ = False + isInfinite _ = False + isDenormalized _ = False + isNegativeZero _ = False + isIEEE _ = False + atan2 y x = local_atan2 y x + + + + +-- | A type class for quantum floating-point numbers. +class QFloating a where + -- | Quantum implementation of the sine function. + q_sin :: a -> Circ a + -- | Quantum implementation of the cosine function. + q_cos :: a -> Circ a + +instance QFloating QDouble where + q_sin x = (unpack template_local_sin) x + q_cos x = (unpack template_local_cos) x + + +-- | Quantum implementation of 'atan2' on 'QDouble'. +q_atan2 :: QDouble -> QDouble -> Circ QDouble +q_atan2 = unpack template_local_atan2 + +-- | Quantum implementation of 'Data.Complex.magnitude' on 'QDouble'. +q_magnitude :: (QDouble, QDouble) -> Circ QDouble +q_magnitude = Prelude.uncurry $ unpack template_local_mag + + +-- | Quantum implementation of 'Data.Complex.mkPolar' on 'QDouble'. +q_mkPolar :: QDouble -> QDouble -> Circ (QDouble,QDouble) +q_mkPolar = unpack template_local_mkPolar + + +-- | Quantum implementation of 'Data.Complex.realPart' on 'QDouble': +-- return the real part of a complex number. A quantum complex is a +-- pair of two 'QDouble's. +q_Re :: (QDouble,QDouble) -> Circ QDouble +q_Re (x,y) = return x + +-- | Quantum implementation of 'Data.Complex.imagPart' on 'QDouble': +-- return the imaginary part of a copmlex number. A quantum complex is +-- a pair of two 'QDouble's. +q_Im :: (QDouble,QDouble) -> Circ QDouble +q_Im (x,y) = return y + + + +my_test_fdouble = do + for 0 37 1 $ \i -> do + let x = fromIntegral i + let a1 = fromRational $ toRational (sin(x * pi/37)) + let a2 = fromRational $ toRational (cos(x * pi/37)) + let z1 = local_atan2 a1 a2 + let z2 = fromRational $ toRational $ atan2 (sin(x * pi/37)) (cos(x * pi/37)) + putStrLn $ show_fdouble $ abs (z1 - z2) + + + + +-- * Template subroutines of analytic functions. + +-- | Template version of 'sin'. +template_sin :: Circ (QDouble -> Circ QDouble) +template_sin = return $ \x -> box "sin" q_sin x + +-- | Template version of 'cos'. +template_cos :: Circ (QDouble -> Circ QDouble) +template_cos = return $ \x -> box "cos" q_cos x + +-- | Template version of 'atan2'. +template_atan2 :: Circ (QDouble -> Circ (QDouble -> Circ QDouble)) +template_atan2 = return $ \x -> return $ \y -> box "atan" (uncurry q_atan2) (x,y) + + + + + + +-- * Template subroutines for dealing with quantum complex number encoded as pairs of 'QDouble'. + +-- | Template version of 'Data.Complex.mkPolar'. +template_mkPolar :: Circ (QDouble -> Circ (QDouble -> Circ (QDouble,QDouble))) +template_mkPolar = return $ \x -> return $ \y -> box "mkPolar" (uncurry q_mkPolar) (x,y) + +-- | Template version of the constructor 'Data.Copmlex.:+' of +-- 'Data.Complex.Complex'. +template_symb_colon_symb_plus_ :: Circ (QDouble -> Circ (QDouble -> Circ (QDouble,QDouble))) +template_symb_colon_symb_plus_ = return $ \x -> return $ \y -> return (x,y) + + +-- | Template version of 'Data.Complex.magnitude'. +template_magnitude :: Circ ((QDouble,QDouble) -> Circ QDouble) +template_magnitude = return $ \p -> box "mag" q_magnitude p + +-- | Template version of 'Data.Complex.realPart'. +template_realPart :: Circ ((QDouble,QDouble) -> Circ QDouble) +template_realPart = return $ \(x,y) -> return x + +-- | Template version of 'Data.Complex.imagPart'. +template_imagPart :: Circ ((QDouble,QDouble) -> Circ QDouble) +template_imagPart = return $ \(x,y) -> return y + diff --git a/Quipper/Algorithms/QLS/TemplateOracle.hs b/Quipper/Algorithms/QLS/TemplateOracle.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/QLS/TemplateOracle.hs @@ -0,0 +1,550 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} + + +-- | This module contains an implementation of the oracle and its +-- automatic lifting to quantum circuits using Template Haskell. +module Quipper.Algorithms.QLS.TemplateOracle where + +import Data.Complex +import Quipper.Utils.Auxiliary + +import Control.Monad + +import Quipper.Libraries.Arith hiding (template_symb_plus_) +import Quipper.Algorithms.QLS.Utils +import Quipper.Algorithms.QLS.QDouble +import Quipper.Algorithms.QLS.RealFunc +import Quipper.Algorithms.QLS.QSignedInt +import Quipper.Algorithms.QLS.CircLiftingImport + +import Quipper +import Quipper.Internal.CircLifting + +-- | Lifted version of @'any'@ (local version). +build_circuit +local_any :: (a -> Bool) -> [a] -> Bool +local_any f l = case l of + [] -> False + (h:t) -> if (f h) then True else local_any f t + + + +-- | Auxiliary function. +build_circuit +itoxy :: Int -> Int -> Int -> (Int, Int) +itoxy i nx ny = + if (i <= 0) then (0,0) + else if (i > (nx-1)*ny + nx*(ny-1)) then (0,0) + else ((mod (i - 1) (2*nx - 1)) + 1, ceiling ((fromIntegral i)/(2.0*(fromIntegral nx)-1.0))) + + +-- | The function sin /x/ \/ /x/. +build_circuit +sinc :: Double -> Double +sinc x = if (x /= 0.0) then (sin x) / x else 1.0 + + +-- | Auxiliary function. +build_circuit +edgetoxy :: Int -> Int -> Int -> (Double, Double) +edgetoxy e nx ny = + let (ex,ey) = itoxy e nx ny in + if (ex < nx) then ((fromIntegral ex) + 0.5, fromIntegral ey) + else (fromIntegral (ex - nx + 1), (fromIntegral ey) + 0.5) + + +-- | Auxiliary function. The inputs are: +-- +-- * /y1/ :: 'Int' - Global edge index of row index of desired matrix element; +-- +-- * /y2/ :: 'Int' - Global edge index of column index of desired matrix element; +-- +-- * /nx/ :: 'Int' - Number of vertices left to right; +-- +-- * /ny/ :: 'Int' - Number of vertices top to bottom; +-- +-- * /lx/ :: 'Double' - Length of horizontal edges (distance between vertices in /x/ direction); +-- +-- * /ly/ :: 'Double' - Length of vertical edges (distance between vertices in /y/ direction); +-- +-- * /k/ :: 'Double' - Plane wave wavenumber. +-- +-- The output is the matrix element /A/(/y1/, /y2/). +build_circuit +calcmatrixelement :: -- + -- Inputs + Int -- int y1 - Global edge index of row index of desired matrix element + -> Int -- int y2 - Global edge index of column index of desired matrix element + -> Int -- int nx - Number of vertices left to right + -> Int -- int ny - Number of vertices top to bottom + -> Double -- float lx - Length of horizontal edges (distance between vertices in x direction) + -> Double -- float ly - Length of vertical edges (distance between vertices in y direction) + -> Double -- float k - Plane wave wavenumber + -- Outputs + -> Complex Double -- float A - Matrix element A(y1,y2) +calcmatrixelement y1 y2 nx ny lx ly k = + let (xg1, yg1) = itoxy y1 nx ny in + let (xg2, yg2) = itoxy y2 nx ny in + let b = if ( (y1==y2) && (xg1 >= nx) ) then ly/lx - k*k*lx*ly/3.0 + -- B11 and B22 + else if ( (y1==y2) && (xg1=nx) ) then -ly/lx + k*k*lx*ly/12.0 + -- B13 + else if ( (yg1==(yg2+1)) && (xg1==(xg2-nx+1)) && (xg2>=nx) ) then -1.0 + -- B31 + else if ( (yg2==(yg1+1)) && (xg2==(xg1-nx+1)) && (xg1>=nx) ) then -1.0 + -- B14 + else if ( (yg1==(yg2+1)) && (xg1==(xg2-nx)) && (xg1=nx) ) then -1.0 + -- B24 + else if ( (yg2==yg1) && (xg2==(xg1+nx)) && (xg2>=nx) ) then -1.0 + -- B32 + else if ( (yg1==yg2) && (xg1==(xg2+nx-1)) && (xg2 [] + (x:tt) -> case tt of + [] -> [] + (y:t) -> (x,y):(get_edges (y:t)) + +-- | Auxiliary function. +build_circuit +checkedge :: Int -> [(Double,Double)] -> Int -> Int -> Bool +checkedge e scatteringnodes nx ny = + let (xi,yi) = edgetoxy e nx ny in + let test_elt ((x1,y1),(x2, y2)) = xi >= x1 && yi >= y1 && xi <= x2 && yi <= y2 in + let half = take_half scatteringnodes in + let test_list = local_any test_elt (get_edges half) in (not test_list) + + + + +-- | Oracle /r/. +build_circuit +calcRweights :: Int -> Int -> Int -> Double -> Double -> Double -> Double -> Double -> Complex Double +calcRweights y nx ny lx ly k theta phi = + let (xc',yc') = edgetoxy y nx ny in + let xc = (xc'-1.0)*lx - ((fromIntegral nx)-1.0)*lx/2.0 in + let yc = (yc'-1.0)*ly - ((fromIntegral ny)-1.0)*ly/2.0 in + let (xg,yg) = itoxy y nx ny in + + if (xg == nx) then + + let i = (mkPolar ly (k*xc*(cos phi)))* + (mkPolar 1.0 (k*yc*(sin phi)))* + ((sinc (k*ly*(sin phi)/2.0)) :+ 0.0) in + + let r = ( cos(phi) :+ k*lx )*((cos (theta - phi))/lx :+ 0.0) in i * r + + else if (xg==2*nx-1) then + + let i = (mkPolar ly (k*xc*cos(phi)))* + (mkPolar 1.0 (k*yc*sin(phi)))* + ((sinc (k*ly*sin(phi)/2.0)) :+ 0.0) in + + let r = ( cos(phi) :+ (- k*lx))*((cos (theta - phi))/lx :+ 0.0) in i * r + + + else if ( (yg==1) && (xg Int -> Int -> Int -> Int +convertband y b nx ny = + let nedges = (nx - 1)*ny + nx*(ny - 1) in + let (ex,ey) = itoxy y nx ny in + let x = if ( (ex < nx) && (ey /= 1) ) then + case b of + 1 -> y-2*nx+1 + 2 -> y-nx + 3 -> y-nx+1 + 5 -> y + 7 -> y+nx-1 + 8 -> y+nx + 9 -> y+2*nx-1 + _ -> -1 + else if ( (ex < nx) && (ey == 1) ) then + case b of + 5 -> y + 7 -> y+nx-1 + 8 -> y+nx + 9 -> y+2*nx-1 + _ -> -1 + else if ( (ex >= nx) && (ex /= nx) && (ex /= 2*nx-1) ) then + case b of + 2 -> y-nx + 3 -> y-nx+1 + 4 -> y-1 + 5 -> y + 6 -> y+1 + 7 -> y+nx-1 + 8 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == nx) ) then + case b of + 3 -> y-nx+1 + 5 -> y + 6 -> y+1 + 8 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == 2*nx-1) ) then + case b of + 2 -> y-nx + 4 -> y-1 + 5 -> y + 7 -> y+nx-1 + _ -> -1 + else -1 + in if ( (x < 1) || (x > nedges) ) then -1 else x + + + + +-- | Oracle /A/. It is equivalent to the Matlab function +-- /getBandNodeValues/. +-- +-- 'getNodeValuesMoreOutputs' /v/ /b/ ... outputs the node of the +-- edge connected to vertex /v/ in band /b/, and a real number +-- parameterized by the 'BoolParam' parameter: the magnitude +-- ('PFalse') or the phase ('PTrue') of the complex value at the +-- corresponding place in the matrix /A/. +build_circuit +getNodeValuesMoreOutputs :: + Int -> Int -> Int -> Int -> [(Double,Double)] -> Double -> Double -> Double -> BoolParam + -> Int -> (Int, Double) +getNodeValuesMoreOutputs v' b' nx ny scatteringnodes lx ly k argflag maxConnectivity = + let maxC = getIntFromParam maxConnectivity in + let b = getIntFromParam b' in + let nedges = (nx - 1)*ny + nx*(ny - 1) in + let flag = v' <= nedges in + let v = (if flag then v' else (v' - nedges)) in + let nodeDefault = (if flag then v + nedges else v) in + let valueDefault = 0.0 in + let indicesDefault = (-1, -1) in + let isvalid = checkedge v scatteringnodes nx ny + in + if ( (not isvalid) && b == 5 ) then + + let indices = (if flag then (v, v + nedges) else (v + nedges, v)) in + case argflag of + PTrue -> (nodeDefault, valueDefault) + PFalse -> (nodeDefault, 1.0) + + else if ( (not isvalid) && b /= 5) then (nodeDefault, valueDefault) + + else if ((b > maxC + 2) || (b <= 0)) then (nodeDefault, valueDefault) + + else + + let x = convertband v b' nx ny in + + if (x == -1) then (nodeDefault, valueDefault) + else + + let isvalid = checkedge x scatteringnodes nx ny in + + if isvalid then + + let ax = calcmatrixelement v x nx ny lx ly k in + let (node, indices) = if flag then (x + nedges, (v, x + nedges)) + else (x, (v+nedges,x)) in + let value = case argflag of + PTrue -> atan2 (imagPart ax) (realPart ax) + PFalse -> magnitude ax + in (node, value) + + else + (nodeDefault, valueDefault) + + + + +-- | Auxiliary function for oracle /b/. The inputs are: +-- +-- * /y/ :: 'Int' - Global edge index. Note this is the unmarked /y/ +-- coordinate, i.e. the coordinate without scattering regions removed; +-- +-- * /nx/ :: 'Int' - Number of vertices left to right; +-- +-- * /ny/ :: 'Int' - Number of vertices top to bottom; +-- +-- * /lx/ :: 'Double' - Length of horizontal edges (distance between vertices in /x/ direction); +-- +-- * /ly/ :: 'Double' - Length of vertical edges (distance between vertices in /y/ direction); +-- +-- * /k/ :: 'Double' - Plane wave wavenumber; +-- +-- * θ :: 'Double' - Direction of wave propagation; +-- +-- * /E0/ :: 'Double' - Magnitude of incident plane wave. +-- +-- The output is the magnitude of the electric field on edge /y/. +build_circuit +calcincidentfield :: -- + -- Inputs + Int -- int y - Global edge index. Note this is the unmarked y coordinate, + -- i.e. the coordinate without scattering regions removed. + -> Int -- int nx - Number of vertices left to right + -> Int -- int ny - Number of vertices top to bottom + -> Double -- float lx - Length of horizontal edges (distance between vertices in x direction) + -> Double -- float ly - Length of vertical edges (distance between vertices in y direction) + -> Double -- float k - Plane wave wavenumber + -> Double -- float theta - Direction of wave propagation + -> Double -- float E0 - Magnitude of incident plane wave + -- Outputs + -> Complex Double -- complex float e - Magnitude of electric field on edge y +calcincidentfield y nx ny lx ly k theta e0 = + let (xg, yg) = itoxy y nx ny in + --Determine whether edge is horizontal or vertical + let isvertical = xg >= nx in + let (xvalueTmp, yvalueTmp) = edgetoxy y nx ny in + let xvalue = xvalueTmp * lx in + let yvalue = yvalueTmp * ly in + -- Convert x and y edge coordinates to x and y values and caluculate field + if isvertical then + mkPolar (-cos(theta)*e0) ( -k*(xvalue*cos(theta)+yvalue*sin(theta))) + else + mkPolar (sin(theta)*e0) ( -k*(xvalue*cos(theta)+yvalue*sin(theta))) + + +-- | Auxiliary function for oracle /b/. +build_circuit +getconnection :: Int -> Int -> Int -> Int -> Int -> Int +getconnection y i' nx ny maxConnectivity = + let i = getIntFromParam i' in + let maxC = getIntFromParam maxConnectivity in + let (ex,ey) = itoxy y nx ny in + let x = if ( (ex < nx) && (ey /= 1) ) then + case i' of + 1 -> y-2*nx+1 + 2 -> y-nx + 3 -> y-nx+1 + 4 -> y + 5 -> y+nx-1 + 6 -> y+nx + 7 -> y+2*nx-1 + _ -> -1 + else if ( (ex < nx) && (ey == 1) ) then + case i' of + 1 -> y + 2 -> y+nx-1 + 3 -> y+nx + 4 -> y+2*nx-1 + _ -> -1 + else if ( (ex >= nx) && (ex /= nx) && (ex /= 2*nx-1) ) then + case i' of + 1 -> y-nx + 2 -> y-nx+1 + 3 -> y-1 + 4 -> y + 5 -> y+1 + 6 -> y+nx-1 + 7 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == nx) ) then + case i' of + 1 -> y-nx+1 + 2 -> y + 3 -> y+1 + 4 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == 2*nx-1) ) then + case i' of + 1 -> y-nx + 2 -> y-1 + 3 -> y + 4 -> y+nx-1 + _ -> -1 + else -1 + in + if (i > maxC) then -1 + else if (x > nx*(ny-1)+ny*(nx-1)) then -1 + else x + + + +-- | Auxiliary function to @'template_paramZero'@. +build_circuit +local_loop_with_index_aux :: Int -> Int -> t -> (Int -> t -> t) -> t +local_loop_with_index_aux i n x f = + case paramMinus n i of + 0 -> x + _ -> local_loop_with_index_aux (paramSucc i) n (f i x) f + + +-- | Local version of @'loop_with_index'@, for lifting. +build_circuit +local_loop_with_index :: Int -> t -> (Int -> t -> t) -> t +local_loop_with_index n x f = local_loop_with_index_aux paramZero n x f + + +-- | Oracle /b/. +build_circuit +getKnownWeights :: Int -> Int -> Int -> [(Double,Double)] -> Double -> Double -> Double -> Double -> Double -> Int -> Complex Double +getKnownWeights y nx ny scatteringnodes lx ly k theta e0 maxConnectivity = + let makeConnections i connections = let x = getconnection y (paramSucc i) nx ny maxConnectivity in + let t = not $ checkedge x scatteringnodes nx ny in + (x,t):connections + in + let calcTang b (c,t) = if t + then let matElt = calcmatrixelement y c nx ny lx ly k in + let incField = calcincidentfield c nx ny lx ly k theta e0 + in b - matElt * incField + else b + in + let connections = local_loop_with_index maxConnectivity [] makeConnections in + if (not $ checkedge y scatteringnodes nx ny) then 0.0 :+ 0.0 + else foldl calcTang (0.0 :+ 0.0) connections + + + + + +---------------------------------------------------------------------- +---------------------------------------------------------------------- +-- Testing functions + +test_template_sinc = do + f <- template_sinc + r <- qinit (0 :: FDouble) + f r + return () + +test_template_itoxy = do + f <- template_itoxy + x <- qinit (0 :: FSignedInt) + y <- qinit (0 :: FSignedInt) + z <- qinit (0 :: FSignedInt) + g <- f x + h <- g y + k <- h z + return () + +test_template_edgetoxy = do + f <- template_edgetoxy + x <- qinit (0 :: FSignedInt) + y <- qinit (0 :: FSignedInt) + z <- qinit (0 :: FSignedInt) + g <- f x + h <- g y + k <- h z + return () + +test_template_calcRweights = do + f <- template_calcRweights + n1 <- qinit (0 :: FSignedInt) + n2 <- qinit (0 :: FSignedInt) + n3 <- qinit (0 :: FSignedInt) + x1 <- qinit (0 :: FDouble) + x2 <- qinit (0 :: FDouble) + x3 <- qinit (0 :: FDouble) + x4 <- qinit (0 :: FDouble) + x5 <- qinit (0 :: FDouble) + f1 <- f n1 + f2 <- f1 n2 + f3 <- f2 n3 + g1 <- f3 x1 + g2 <- g1 x2 + g3 <- g2 x3 + g4 <- g3 x4 + g5 <- g4 x5 + return () + +test_template_calcincidentfield = do + y' <- qinit (0 :: FSignedInt) + nx' <- qinit (0 :: FSignedInt) + ny' <- qinit (0 :: FSignedInt) + lx' <- qinit (0 :: FDouble) + ly' <- qinit (0 :: FDouble) + k' <- qinit (0 :: FDouble) + theta' <- qinit (0 :: FDouble) + e0' <- qinit (0 :: FDouble) + f <- template_calcincidentfield + f1 <- f y' + f2 <- f1 nx' + f3 <- f2 ny' + f4 <- f3 lx' + f5 <- f4 ly' + f6 <- f5 k' + f7 <- f6 theta' + f8 <- f7 e0' + return () + +test_template_calcmatrixelement = do + y1 <- qinit (0 :: FSignedInt) + y2 <- qinit (0 :: FSignedInt) + nx <- qinit (0 :: FSignedInt) + ny <- qinit (0 :: FSignedInt) + lx <- qinit (0 :: FDouble) + ly <- qinit (0 :: FDouble) + k <- qinit (0 :: FDouble) + f <- template_calcmatrixelement + f1 <- f y1 + f2 <- f1 y2 + f3 <- f2 nx + f4 <- f3 ny + f5 <- f4 lx + f6 <- f5 ly + f7 <- f6 k + return () + +test_template_getconnection = do + y <- qinit (0 :: FSignedInt) + nx <- qinit (0 :: FSignedInt) + ny <- qinit (0 :: FSignedInt) + f <- template_getconnection + f1 <- f y + f2 <- f1 6 + f3 <- f2 nx + f4 <- f3 ny + f5 <- f4 7 + return () + +test_template_checkedge = do + y <- qinit (0 :: FSignedInt) + nx <- qinit (0 :: FSignedInt) + ny <- qinit (0 :: FSignedInt) + s <- qinit [(0 :: FDouble,0 :: FDouble),(0 :: FDouble,0 :: FDouble)] + f <- template_checkedge + f1 <- f y + f2 <- f1 s + f3 <- f2 nx + f4 <- f3 ny + return () + diff --git a/Quipper/Algorithms/QLS/Utils.hs b/Quipper/Algorithms/QLS/Utils.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/QLS/Utils.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + + +-- | This module defines some auxiliary machinery required for the QLS algorithm. +module Quipper.Algorithms.QLS.Utils where + +import Quipper +import Control.Monad +import Data.List + +import Quipper.Internal.Control + +import qualified Data.Map as Map + + +-- * Hard-coded default sizes for quantum numbers + +-- | Default size of a register +-- 'Quipper.Algorithms.QLS.QSignedInt.QSignedInt' (not counting the +-- sign). +fixed_int_register_length :: Int +fixed_int_register_length = 32 + +-- | Default size for the /xxx/ part of the +-- 'Quipper.Algorithms.QLS.QDouble.QDouble' /xxx.yyy/. +before_radix_length :: Int +before_radix_length = 32 + +-- | Default size for the /yyy/ part of the +-- 'Quipper.Algorithms.QLS.QDouble.QDouble' /xxx.yyy/. +after_radix_length :: Int +after_radix_length = 32 + + + +-- * Miscellaneous utilities + +-- | Compose a function with itself /n/ times. +ncompose :: Int -> (a -> a) -> a -> a +ncompose 0 f x = x +ncompose n f x = ncompose (n-1) f (f x) + +-- | Specialized 'map' for lists of pairs. +listpair_fmap :: (a -> b) -> [(a,a)] -> [(b,b)] +listpair_fmap f t = map (\(x,y) -> (f x,f y)) t + + diff --git a/Quipper/Algorithms/TF/Alternatives.hs b/Quipper/Algorithms/TF/Alternatives.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/TF/Alternatives.hs @@ -0,0 +1,143 @@ +-- | This module contains various supplementary functions related +-- to the Triangle Finding algorithm: alternatives to and/or +-- generalizations of the various routines in +-- 'Quipper.Algorithms.TF.Oracle' and 'Quipper.Algorithms.TF.QWTFP'. + +module Quipper.Algorithms.TF.Alternatives where + +import Quipper +import Quipper.Algorithms.TF.Definitions +import Quipper.Libraries.Qram +import Quipper.Libraries.Arith + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + +-- ====================================================================== +-- * Arithmetic functions + +-- | Increment a 'QIntTF' (i.e., little-endian, mod 2[sup /l/] – 1) +-- in place. +-- +-- This and 'decrement_TF' assume as precondition that the input is never +-- 11…11, and preserve this condition, by fixing 11…11. This means these +-- are /not/ correct if 'IntTF' is treated as a formal quotient of +-- 2[sup /l/] ; with that approach, incrementing/decrementing in place +-- cannot be a quantum operation (since it must map 00…00 and 11…11 both +-- to 00…01, so would have nonzero kernel). These are however correct if +-- 'IntTF' is considered as a formal /subspace/ of 2[sup /l/] (in which +-- case the other arithmetic routines are unsound, since they may break +-- the precondition). +increment_TF :: QIntTF -> Circ QIntTF +increment_TF l1 = do + let l = qulist_of_qinttf_lh l1 + -- mark whether /l/ is initially in forbidden state “all true”: + is_bad <- qinit False + is_bad <- qnot is_bad `controlled` [ q .==. 1 | q <- l ] + -- now, increment /l/ treating it mod 2^/n/: + l' <- increment_big (reverse l) + l <- return $ reverse l' + -- now mark if the /incremented/ /l/ is “all true”: + needs_rollover <- qinit False + needs_rollover <- qnot needs_rollover `controlled` [ q .==. 1 | q <- l ] + -- if it’s now “all true”, roll it over; or if it initially was, roll it back: + l <- mapM (\q -> do + q <- qnot q `controlled` is_bad + q <- qnot q `controlled` needs_rollover + return q) + l + -- finally, uncompute the ancillas: + needs_rollover <- qnot needs_rollover `controlled` [ q .==. 0 | q <- l ] + qterm False needs_rollover + is_bad <- qnot is_bad `controlled` [ q .==. 1 | q <- l ] + qterm False is_bad + return (qinttf_of_qulist_lh l) + + +-- | Decrement a 'QIntTF' in place. +decrement_TF :: QIntTF -> Circ QIntTF +decrement_TF l1 = do + let l = qulist_of_qinttf_lh l1 + -- mark whether /l/ is initially in forbidden state “all true”: + with_ancilla $ \is_bad -> do + is_bad <- qnot is_bad `controlled` [ q .==. 1 | q <- l ] + -- also mark if /l/ is “all false”: + l <- with_ancilla $ \needs_rollover -> do + needs_rollover <- qnot needs_rollover `controlled` [ q .==. 0 | q <- l ] + -- exchange these two states: + l <- mapM (\q -> do + q <- qnot q `controlled` is_bad + q <- qnot q `controlled` needs_rollover + return q) + l + -- uncompute @needs_rollover@ + needs_rollover <- qnot needs_rollover `controlled` [ q .==. 1 | q <- l ] + return l + -- now, decrement /l/ treating it mod 2^/n/: + l' <- decrement_big (reverse l) + -- finally, uncompute is_bad: + is_bad <- qnot is_bad `controlled` [ q .==. 1 | q <- l' ] + return (qinttf_of_qulist_lh (reverse l')) + +-- | An alternative to 'Quipper.Algorithms.TF.Oracle.o5_MOD3' for +-- reducing mod-3, conceptually simpler and not size-limited: uses the +-- fact that 2-bit 'QIntTF's give us true mod-3 arithmetic. +-- +-- Has same complexity /O(l)/ as +-- 'Quipper.Algorithms.TF.Oracle.o5_MOD3', with (probably) a slightly +-- higher leading coefficient, due to difference in size between +-- 'increment_TF' and 'increment_little'. +o5_MOD3_alt :: QIntTF -> Circ (QIntTF,QIntTF) +o5_MOD3_alt x1 = do + let x = qulist_of_qinttf_lh x1 + let l = length x + + m <- qinit (inttf 2 0) + (x,m) <- loop_with_indexM l (x,m) (\i (x,m) -> do + m <- if (even i) + then increment_TF m `controlled` (x !! i) + else decrement_TF m `controlled` (x !! i) + return (x,m)) + return (qinttf_of_qulist_lh x, m) + +-- ====================================================================== +-- * Efficient qRAM + +-- $ We provide an efficient qRAM implementation in "Quipper.Libraries.Qram". +-- The following turns it into a 'Qram' object for the Triangle +-- Finding algorithm. + +-- | Efficient qRAM \"fetch\" operation. @'indexed_fetch' /i/ /m/ /q/@ +-- performs the operation /q/ ⊕= /m/[/i/]. +indexed_fetch :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +indexed_fetch i m q = do + indexed_fetch_at qs i q + return (i,m,q) + where + qs = IntMap.elems m + +-- | Efficient qRAM \"store\" operation. @'indexed_store' /i/ /m/ /q/@ +-- performs the operation /m/[/i/] ⊕= /q/. +indexed_store :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +indexed_store i m q = do + indexed_store_at qs i q + return (i,m,q) + where + qs = IntMap.elems m + +-- | Efficient qRAM \"swap\" operation. @'indexed_swap' /i/ /m/ /q/@ +-- swaps /q/ and /m/[/i/]. +indexed_swap :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +indexed_swap i m q = do + indexed_swap_at qs i q + return (i,m,q) + where + qs = IntMap.elems m + +-- | Our efficient qRAM implementation wrapped in a 'Qram' object. +alt_qram :: Qram +alt_qram = Qram { + qram_fetch = indexed_fetch, + qram_store = indexed_store, + qram_swap = indexed_swap +} diff --git a/Quipper/Algorithms/TF/Definitions.hs b/Quipper/Algorithms/TF/Definitions.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/TF/Definitions.hs @@ -0,0 +1,390 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE IncoherentInstances #-} + +-- | This module provides global definitions for the Triangle Finding Algorithm. + +module Quipper.Algorithms.TF.Definitions where + +import Prelude hiding (mapM, mapM_) +import qualified Data.Map as Map +import Data.IntMap (IntMap, Key) +import qualified Data.IntMap as IntMap +import Data.Traversable (mapM) +import Data.Foldable (mapM_) +import Data.Typeable (Typeable) + +import Quipper +import Quipper.Internal +import Quipper.Libraries.Arith + +import Quipper.Utils.Auxiliary (mmap) + +-- ====================================================================== +-- * Qram abstraction + +-- | A data structure to hold a Qram implementation. This provides +-- operations for fetching and storing quantum data from a quantum +-- array, addressed by a quantum integer. One implementation is given +-- by algorithms 'Quipper.Algorithms.TF.QWTFP.a8_FetchT', +-- 'Quipper.Algorithms.TF.QWTFP.a9_StoreT' and +-- 'Quipper.Algorithms.TF.QWTFP.a10_FetchStoreT'. + +data Qram = Qram { + qram_fetch :: forall qa.(QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa), + qram_store :: forall qa.(QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa), + qram_swap :: forall qa.(QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +} + +-- ====================================================================== +-- * Types for the Triangle Finding Algorithm + +-- As synonyms, these first few types are all automatically instances of QCData. + +-- | A node of the graph (classical circuit type). +type CNode = [Bit] + +-- | A node of the graph (quantum circuit type). +type QNode = [Qubit] + +-- | The type of problem specifications for the Triangle Finding Problem. A problem +-- specification consists of: +-- +-- * an integer /n/ which determines the number /N=//2/[sup /n/] of nodes of the graph, +-- +-- * an integer /r/ which determines the size /R=//2/[sup /r/] of tuples in the Hamming +-- graph, +-- +-- * a function /edge_oracle/ which inputs two graph nodes and a qubit and flips the qubit +-- if the nodes are connected by an edge and +-- +-- * additional options, for selecting, e.g., which qRAM implementation should be used. +type QWTFP_spec = (Int, Int, QNode -> QNode -> Qubit -> Circ Qubit, Qram) + +-- ====================================================================== +-- * TF integers + +-- ---------------------------------------------------------------------- +-- ** Types + +-- $ We define a 'QData' family of integer datatypes ('QIntTF', +-- 'CIntTF', 'IntTF'). These are similar to ('QDInt', 'CInt', 'IntM'), +-- except that the integers are considered to be mod 2[sup /m/]-1 instead +-- of 2[sup /m/]. +-- +-- In general, functions on these types should be able to handle both 00…00 and 11…11, +-- and should treat them equally, essentially regarding 'IntTF', 'CIntTF', and the +-- computational basis of 'QIntTF' as formal quotients. +-- Some operations are not perfect. One should keep in mind, for example, that specifying +-- a control on a 'QIntTF' of the form @/q/ .==. 0@ will compare the bitwise representation +-- to 0, and not the logical quotient. + +-- | All three types 'QIntTF', 'CIntTF', and 'IntTF' are special cases +-- of a more general type 'XIntTF' /x/, parameterized by a type /x/ of +-- bits. It is an abstract type, and details of its implementation is +-- not exposed to user-level code. +data XIntTF x = XIntTF (XInt x) + deriving (Show, Typeable) + +-- | The type of fixed-length /m/-qubit quantum integers, regarded +-- modulo 2[sup /m/]-1. +type QIntTF = XIntTF Qubit + +-- | The type of fixed-length /m/-bit classical integers, regarded +-- modulo 2[sup /m/]-1. +type CIntTF = XIntTF Bit + +-- | The type of fixed-length /m/-bit integer parameters, regarded +-- modulo 2[sup /m/]-1. A value of type 'IntTF' may have indeterminate +-- length, similarly to 'IntM'. +type IntTF = XIntTF Bool + +-- ---------------------------------------------------------------------- +-- ** Operations for IntTF + +-- | Convert an 'IntTF' of length /m/ to an 'Integer' in the range {0, +-- …, 2[sup /m/]-2}. If the 'IntTF' has indeterminate length, return +-- the original 'Integer'. +integer_of_inttf :: IntTF -> Integer +integer_of_inttf (XIntTF x) = + case intm_length x of + Just m -> (integer_of_intm_unsigned x) `mod` (2^m - 1) + Nothing -> integer_of_intm_unsigned x + +-- | Convert an 'Integer' to an 'IntTF' of indeterminate length. +inttf_of_integer :: Integer -> IntTF +inttf_of_integer n = XIntTF (intm_of_integer n) + +-- | Convert an 'Integer' to an 'IntTF' of length /m/. +inttf :: Int -> Integer -> IntTF +inttf m n = XIntTF (intm m n') + where + n' = n `mod` (2^m-1) + +-- | Return the length of an 'IntTF', or 'Nothing' if indeterminate. +inttf_length :: IntTF -> Maybe Int +inttf_length = intm_length . xint_of_xinttf + +instance Eq IntTF where + x == y = + case inttf_length x' of + Just m -> (integer_of_inttf x') `mod` (2^m - 1) == (integer_of_inttf y') `mod` (2^m - 1) + Nothing -> x' == y' + where + x' = inttf_promote x y errstr + y' = inttf_promote y x errstr + errstr = "Equality test on IntTF: operands must be of equal length" + +-- | Set the length of an 'IntTF' to /m/ ≥ 0. This operation is only +-- legal if the input (a) has indeterminate length or (b) has +-- determinate length already equal to /m/. In particular, it cannot +-- be used to change the length from anything other than from +-- indeterminate to determinate. +-- +-- If both arguments already have determinate lengths, and they do not +-- coincide, throw an error. The 'String' argument is used as an error +-- message in that case. +inttf_set_length :: Int -> IntTF -> String -> IntTF +inttf_set_length m (XIntTF x) errmsg | m < 0 = + error "inttf_set_length: negative length not permitted" +inttf_set_length m (XIntTF x) errmsg = + case intm_length x of + Just n | m==n -> (XIntTF x) + | otherwise -> error errmsg + Nothing -> XIntTF (intm m n) + where + -- Here "unsigned" or "signed" doesn't matter, since this is + -- the indeterminate case, where the original integer is + -- returned. + n = integer_of_intm_unsigned x `mod` (2^m - 1) + +-- | Try to set the length of an 'IntTF' to that of another 'XIntTF' +-- value (which could be a 'QIntTF', a 'CIntTF', or another 'IntTF'). This +-- will fail with an error if both numbers already have determinate +-- lengths that don't coincide. In this case, the string argument is +-- used as an error message. The promotion is done modulo 2[sup /m/]-1. +inttf_promote :: IntTF -> XIntTF x -> String -> IntTF +inttf_promote b (XIntTF x) errmsg = + case xint_maybe_length x of + Nothing -> b + Just m -> inttf_set_length m b errmsg + +-- | Convert an 'IntTF' to human readable form. We show the bit value, +-- i.e., 0 and 2[sup /m/]-1 are shown as different values. +show_inttf :: IntTF -> String +show_inttf x = + case inttf_length x of + Nothing -> "IntTF -- " ++ show (integer_of_inttf x) + Just m -> "IntTF " ++ show m ++ " " ++ show (integer_of_intm_unsigned (xint_of_xinttf x)) + +-- make 'IntTF' an (overlapping) instance of 'Show': +instance Show IntTF where + show = show_inttf + +-- ---------------------------------------------------------------------- +-- ** Operations for QIntTF + +-- | Convert a 'QIntTF' to a list of qubits. The conversion is +-- little-headian, i.e., the head of the list holds the least +-- significant digit. +qulist_of_qinttf_lh :: QIntTF -> [Qubit] +qulist_of_qinttf_lh = reverse . qulist_of_qdint_bh . xint_of_xinttf + +-- | Convert a list of qubits to a 'QIntTF'. The conversion is +-- little-headian, i.e., the head of the list holds the least +-- significant digit. +qinttf_of_qulist_lh :: [Qubit] -> QIntTF +qinttf_of_qulist_lh = xinttf_of_xint . qdint_of_qulist_bh . reverse + +-- | Return a piece of shape data to represent an /m/-qubit +-- 'QIntTF'. Please note that the data can only be used as shape; it +-- will be undefined at the leaves. +qinttf_shape :: Int -> QIntTF +qinttf_shape = xinttf_of_xint . qdint_shape + +-- ---------------------------------------------------------------------- +-- ** Auxiliary functions + +-- | The low-level isomorphism from 'XInt' /x/ to 'XIntTF' /x/. Note +-- that \"isomorphism\" is between the underlying raw types, and does not +-- respect the arithmetic operations. +xinttf_of_xint :: XInt x -> XIntTF x +xinttf_of_xint = XIntTF + +-- | The low-level isomorphism from 'XIntTF' /x/ to 'XInt' /x/. Note +-- that \"isomorphism\" is between the underlying raw types, and does not +-- respect the arithmetic operations. +xint_of_xinttf :: XIntTF x -> XInt x +xint_of_xinttf (XIntTF x) = x + +-- | Like 'xint_of_xinttf', but first try to promote the length of the +-- 'IntTF' to that of the given 'XIntTF'. +xint_with_promote :: XIntTF y -> IntTF -> IntM +xint_with_promote x b = xint_of_xinttf b' where + b' = inttf_promote b x "xint_with_promote: length change not permitted" + +-- ---------------------------------------------------------------------- +-- The QCData instance + +type instance QCType x y (XIntTF z) = XIntTF (QCType x y z) +type instance QTypeB IntTF = QIntTF + +instance QCLeaf x => QCData (XIntTF x) where + qcdata_mapM shape f g xs = + mmap xinttf_of_xint $ qcdata_mapM (xint_of_xinttf shape) f g (xint_of_xinttf xs) + qcdata_zip shape q c q' c' xs ys e = + xinttf_of_xint $ qcdata_zip (xint_of_xinttf shape) q c q' c' (xint_of_xinttf xs) (xint_of_xinttf ys) errmsg + where + errmsg x = e "QDInt length mismatch" + qcdata_promote b q e = inttf_promote b q errmsg + where + errmsg = e "IntM length mismatch" + +-- Labeling of QIntTF is s[m-1], ..., s[0], with the least significant +-- bit at index 0. +instance QCLeaf x => Labelable (XIntTF x) String where + label_rec qa = label_rec (xint_of_xinttf qa) + +-- ====================================================================== +-- * Miscellaneous circuit-building functions + + +-- | Controlled phase flip of -1. +phaseFlipIf :: (ControlSource ctrl) => ctrl -> Circ () +phaseFlipIf ctrl = do + -- why would one do an uncontrolled phase flip? Because it could be + -- part of a subroutine that will later get controlled. + global_phase 1.0 `controlled` ctrl + +-- | Variant of 'phaseFlipIf' that performs a phase flip /unless/ all +-- controls are in the given state. +phaseFlipUnless :: (ControlSource ctrl) => ctrl -> Circ () +phaseFlipUnless ctrls = do + global_phase 1.0 + global_phase 1.0 `controlled` ctrls + +-- | @qor q c@: Applies \"not\" to /q/, if /any/ of the control qubits +-- in /c/ is in specified state. +qor :: Qubit -> [(Qubit,Bool)] -> Circ Qubit +qor q cs = do + q <- qnot q + q <- qnot q `controlled` (map (\(p,b) -> (p .==. not b)) cs) + return q + +-- ====================================================================== +-- * Arithmetic functions + +-- | Increment a standard 'QDInt' (i.e. big-endian, mod 2[sup ℓ]). +increment :: QDInt -> Circ QDInt +increment x = do + comment_with_label "ENTER: increment" x "x" + x <- mmap qdint_of_qulist_bh . increment_big . qulist_of_qdint_bh $ x + comment_with_label "EXIT: increment" x "x" + return x + +-- | Decrement a standard 'QDInt' (i.e. big-endian, mod 2[sup ℓ]). +decrement :: QDInt -> Circ QDInt +decrement x = do + comment_with_label "ENTER: decrement" x "x" + x <- mmap qdint_of_qulist_bh . decrement_big . qulist_of_qdint_bh $ x + comment_with_label "EXIT: decrement" x "x" + return x + +-- | Increment a bit-string, considered as a big-endian integer mod 2[sup ℓ]. +increment_big :: [Qubit] -> Circ [Qubit] +increment_big [] = return [] +increment_big (i_high:i_lower) = do + i_high <- qnot i_high `controlled` i_lower + i_lower <- increment_big i_lower + return (i_high:i_lower) + +-- | Decrement a bit-string, considered as a big-endian integer mod 2[sup ℓ]. +decrement_big :: [Qubit] -> Circ [Qubit] +decrement_big [] = return [] +decrement_big (i_high:i_lower) = do + i_lower <- decrement_big i_lower + i_high <- qnot i_high `controlled` i_lower + return (i_high:i_lower) + +-- | Increment a bit-string, considered as a little-endian integer mod 2[sup ℓ]. +increment_little :: [Qubit] -> Circ [Qubit] +increment_little [] = return [] +increment_little (i_low:i_higher) = do + i_higher <- increment_little i_higher `controlled` i_low + i_low <- qnot i_low + return (i_low:i_higher) + +-- | Decrement a bit-string, considered as a little-endian integer mod 2[sup ℓ]. +decrement_little :: [Qubit] -> Circ [Qubit] +decrement_little [] = return [] +decrement_little (i_low:i_higher) = do + i_low <- qnot i_low + i_higher <- decrement_little i_higher `controlled` i_low + return (i_low:i_higher) + +-- | The standard “combinations” function “/n/ choose /k/”. +choose :: (Integral a) => a -> a -> a +choose n 0 = 1 +choose 0 k = 0 +choose n k = ((choose (n-1) (k-1)) * n) `div` k + +-- ====================================================================== +-- * IntMaps as QData + +-- | Replace an 'IntMap' /f/ with the 'IntMap' mapping each key /k/ to (/k/,/f(k)/). An auxiliary function for defining 'mapWithKeyM', etc. +addKeys :: IntMap a -> IntMap (Key,a) +addKeys = IntMap.mapWithKey (\k x -> (k,x)) + +-- | Analogous to 'mapM', but allows the function to use the key. Particularly useful for mapping in parallel over two (or more) 'IntMap's assumed to have the same domain. +mapWithKeyM :: (Monad m) => (IntMap.Key -> a -> m b) -> IntMap a -> m (IntMap b) +mapWithKeyM f as = mapM (\(k,x) -> f k x) (addKeys as) + +-- | Analogous to 'mapM_', but allows the function to use the key. +mapWithKeyM_ :: (Monad m) => (IntMap.Key -> a -> m b) -> IntMap a -> m () +mapWithKeyM_ f as = mapM_ (\(k,x) -> f k x) (addKeys as) + +-- | Analogous to 'replicate' on lists. +intMap_replicate :: Int -> a -> IntMap a +intMap_replicate n x = IntMap.fromList [(i,x) | i <- [0..n-1]] + +infixl 9 ! + +-- | Convenient syntax for accessing elements of an 'IntMap'. Left associative, and binds very strongly, like '(!!)'. +(!) :: IntMap a -> IntMap.Key -> a +xs ! k = let (Just x) = IntMap.lookup k xs in x + +type instance QCType x y (IntMap a) = IntMap (QCType x y a) +type instance QTypeB (IntMap a) = IntMap (QTypeB a) + +instance QCData a => QCData (IntMap a) where + qcdata_mapM a f g xs = + intmap_mapM (qcdata_mapM a' f g) xs + where a' = shape $ a IntMap.! 0 + + qcdata_zip a q c q' c' xs ys e = + intmap_map (\(x,y) -> qcdata_zip a' q c q' c' x y e) (intmap_zip_errmsg xs ys errmsg) + where + a' = shape $ a IntMap.! 0 + errmsg = e "IntMap domains do not agree" + + qcdata_promote as xs e + | IntMap.keys as /= IntMap.keys xs = error errmsg + | otherwise = + intmap_map (\(a,x) -> qcdata_promote a x e) (intmap_zip_errmsg as xs errmsg) + where + errmsg = e "IntMap domains do not agree" + +instance (Labelable a String) => Labelable (IntMap a) String where + label_rec xs s = do + sequence_ [ label_rec x s `indexed` show i | (i,x) <- IntMap.toList xs ] + +instance (Labelable a s) => Labelable (IntMap a) (IntMap s) where + label_rec xs ss = do + sequence_ [ label_rec x s | (i,x) <- IntMap.toList xs, IntMap.member i ss, let s = ss IntMap.! i ] diff --git a/Quipper/Algorithms/TF/Main.hs b/Quipper/Algorithms/TF/Main.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/TF/Main.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 + {-# OPTIONS -fcontext-stack=50 #-} +#else + {-# OPTIONS -freduction-depth=50 #-} +#endif + +-- | +-- Authors: Peter LeFanu Lumsdaine, Neil Julien Ross +-- +-- An implementation of the Triangle Finding Algorithm. The +-- Triangle Finding Problem is given by an undirected dense +-- simple graph /G/ containing exactly one triangle ∆. The +-- graph is given by an oracle function /f/ , such that, for +-- any two nodes /v/, /w/ of /G/, /f/(/v/,/w/)=1 if (/v/,/w/) +-- is an edge of /G/ and /f/(/v/,/w/)=0 otherwise. To solve +-- such an instance of the problem is to find the set of +-- vertices {/e/[sub 1] , /e/[sub 2] , /e/[sub 3]} forming +-- ∆ by querying /f/. +-- +-- The algorithm works by performing a Grover-based quantum +-- walk on a larger graph /H/, called the Hamming graph +-- associated to /G/. It is designed to find ∆ with high +-- probability. The algorithm is parametric on an oracle +-- defining the graph /G/. In our implementation, the +-- oracle is a changeable part, but we have also +-- implemented a particular predefined oracle. +-- +-- The algorithm is described in: +-- +-- * A. Childs and R. Kothari. \"Quantum query complexity of +-- minor-closed graph properties.\" In +-- /Proceedings of the 28th Symposium on Theoretical Aspects of Computer Science/, +-- pages 661–672, 2011. +-- +-- * F. Magniez, M. Santha, and M. Szegedy. \"Quantum +-- algorithms for the triangle problem.\" In +-- /Proceedings of the 16th Annual ACM-SIAM Symposium on Discrete Algorithms/, +-- pages 1109–1117, 2005. +-- +-- The present implementation is based on detailed +-- algorithm and oracle specifications that were provided to +-- us by the IARPA QCS program and written by Richard +-- Wisniewski. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.TF.Main": Command line interface. +-- +-- * "Quipper.Algorithms.TF.Definitions": Some general purpose +-- definitions. +-- +-- * "Quipper.Algorithms.TF.QWTFP": The implementation of the main +-- Triangle Finding algorithm. +-- +-- * "Quipper.Algorithms.TF.Oracle": The implementation of the +-- oracle for the Triangle Finding algorithm. +-- +-- * "Quipper.Algorithms.TF.Alternatives": Some alternative +-- implementations of some of the subroutines. +-- +-- * "Quipper.Algorithms.TF.Simulate": Functions for simulating, +-- testing, and debugging oracles. + +module Quipper.Algorithms.TF.Main where + +import Quipper + +import Quipper.Libraries.Arith +import Quipper.Libraries.Decompose + +import Quipper.Algorithms.TF.Definitions +import Quipper.Algorithms.TF.Oracle +import Quipper.Algorithms.TF.QWTFP +import Quipper.Algorithms.TF.Simulate +import Quipper.Algorithms.TF.Alternatives + +import Quipper.Utils.CommandLine + +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Control.Monad +import Data.List +import Data.Char +import qualified Data.IntMap as IntMap + +---------------------------------------------------------------------- +-- * Documentation + +-- $ This module provides a command line interface for the +-- Triangle Finding Algorithm. This allows the user, for +-- example, to plug in different oracles, show different +-- parts of the circuit, select a gate base, simulate, +-- and select various parameters. +-- +-- * Example invocations: +-- +-- @./tf@ +-- +-- Default options: the full 'a1_QWTFP' circuit, with +-- (l,n,r) = (4,3,2), and a black-box oracle. +-- +-- @./tf --oracle -o "Orthodox" -l 3 -n 2 -r 2@ +-- +-- A manageable size to inspect the orthodox oracle. +-- +-- @./tf -s mult -l 4@ +-- +-- The multiplier, for 4-bit integers mod 15. +-- +-- @./tf --help@ +-- +-- Print detailed usage info (accepted options, etc.). +-- +-- * Parameters: +-- +-- /l/: the length of integers used in the oracle. +-- (Default value: 4.) +-- +-- /n/: the size of nodes in the graph. +-- (Default value: 3.) +-- +-- /r/: log[sub 2] of the tuple size of the Hamming graph. +-- (Default value: 2.) + +-- +-- * Option processing +-- +-- | An enumeration type for determining what the main function should do. +data WhatToShow = + Circuit -- ^Show the whole circuit. + | Oracle -- ^Show only the oracle. + | Sub -- ^Show a specific subroutine. + | Arith -- ^Run simulation tests of the arithmetic subroutines. + | OTest -- ^Run simulation tests of the oracle. + deriving Show + +-- | An enumeration type for selecting an oracle. +data OracleSelect = + Orthodox -- ^The default oracle. + | Blackbox -- ^A blackbox oracle. + deriving Show + +-- | A datatype for selecting a qRAM implementation. +data QRamSelect = + Standard_QRam -- ^ The default qRAM. + | Alt_QRam -- ^ A slightly more efficient implementation. + deriving Show + +-- | An enumeration type for selecting a subroutine. +data Subroutine = + A2 -- ^Algorithm 2: Zero. + | A3 -- ^Algorithm 3: Initialize. + | A4 -- ^Algorithm 4: Hadamard. + | A5 -- ^Algorithm 5: Setup. + | A6 -- ^Algorithm 6: QWSH. + | A7 -- ^Algorithm 7: Diffuse. + | A8 -- ^Algorithm 8: FetchT. + | A9 -- ^Algorithm 9: StoreT. + | A10 -- ^Algorithm 10: FetchStoreT. + | A11 -- ^Algorithm 11: FetchE. + | A12 -- ^Algorithm 12: FetchStoreE. + | A13 -- ^Algorithm 13: Update. + | A14 -- ^Algorithm 14: SWAP. + | A15 -- ^Algorithm 15: TestTriangleEdges (inner quantum walk). + | A16 -- ^Algorithm 16: TriangleTestT. + | A17 -- ^Algorithm 17: TriangleTestTw. + | A18 -- ^Algorithm 18: TriangleEdgeSearch. + | A19 -- ^Algorithm 19: GCQWalk. + | A20 -- ^Algorithm 20: GCQWStep. + | O2 -- ^Algorithm O2: ConvertNODE. + | O3 -- ^Algorithm O3: TestEqual. + | O4 -- ^Algorithm O4: Pow17. + | O5 -- ^Algorithm O5: Mod3. + | O6 -- ^Algorithm O6: Sub. + | O7 -- ^Algorithm O7: Add. + | O8 -- ^Algorithm O8: Mul. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + what :: WhatToShow, -- ^What kind of thing to output. + s :: Subroutine, -- ^What specific subroutine to output. + format :: Format, -- ^The output format. + gatebase :: GateBase, -- ^What kind of gates to decompose into. + oracle :: OracleSelect, -- ^Which kind of oracle to use. + qram :: QRamSelect, -- ^Which qram implementation to use. + l :: Int, -- ^Parameter 'l'. + n :: Int, -- ^Parameter 'n'. + r :: Int -- ^Parameter 'r'. +} deriving Show + + +-- | The default options. +defaultOptions :: Options +defaultOptions = Options + { what = Circuit, + s = O7, + format = Preview, + gatebase = Logical, + oracle = Blackbox, + qram = Standard_QRam, + l = 4, + n = 3, + r = 2 + } + + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = + [ +-- Generic options + Option ['h'] ["help"] (NoArg help) "print usage info and exit", + Option ['f'] ["format"] (ReqArg format "") "output format for circuits (default: preview)", + Option ['g'] ["gatebase"] (ReqArg gatebase "") "type of gates to decompose into (default: logical)", +-- Triangle finding parameters + Option ['l'] ["l"] (ReqArg lll "") "parameter l (default: 4)", + Option ['n'] ["n"] (ReqArg nnn "") "parameter n (default: 3)", + Option ['r'] ["r"] (ReqArg rrr "") "parameter r (default: 2)", +-- Main circuits + Option ['C'] ["QWTFP"] (NoArg (what Circuit)) "output the whole circuit (default)", + Option ['O'] ["oracle"] (NoArg (what Oracle)) "output only the oracle", +-- Subroutine option + Option ['s'] ["subroutine"] (ReqArg sub "") "output the chosen subroutine (default: adder)", +-- QRAM option + Option ['Q'] [] (NoArg (qram Alt_QRam)) "use alternative qRAM implementation", +-- Oracle option + Option ['o'] [] (ReqArg oracle "") "select oracle to use (default: blackbox)", +-- Testing options + Option ['A'] ["arith"] (NoArg (what Arith)) "test/simulate the arithmetic routines", + Option ['T'] ["oracletest"] (NoArg (what OTest)) "test/simulate the oracle" + ] + where + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + + sub :: String -> Options -> IO Options + sub str o = do + case match_enum subroutine_enum str of + [(_, f)] -> return o { what = Sub, s = f } + [] -> optfail ("Unknown subroutine -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous subroutine -- " ++ str ++ "\n") + + qram :: QRamSelect -> Options -> IO Options + qram q o = return o { qram = q } + + lll :: String -> Options -> IO Options + lll string o = + case parse_int string of + Just l | l >= 1 -> return o { l = l } + _ -> optfail ("Invalid value for parameter l -- " ++ string ++ "\n") + + nnn :: String -> Options -> IO Options + nnn string o = + case parse_int string of + Just n | n >= 1 -> return o { n = n } + _ -> optfail ("Invalid value for parameter n -- " ++ string ++ "\n") + + rrr :: String -> Options -> IO Options + rrr string o = + case parse_int string of + Just r | r >= 1 -> return o { r = r } + _ -> optfail ("Invalid value for parameter r -- " ++ string ++ "\n") + + format :: String -> Options -> IO Options + format str o = do + case match_enum format_enum str of + [(_, f)] -> return o { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + gatebase :: String -> Options -> IO Options + gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + oracle :: String -> Options -> IO Options + oracle str o = do + case match_enum oracle_enum str of + [(_, f)] -> return o { oracle = f } + [] -> optfail ("Unknown oracle -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous oracle -- " ++ str ++ "\n") + + help :: Options -> IO Options + help o = do + usage + exitSuccess + +-- | An enumeration of available oracles and their names. +oracle_enum :: [(String, OracleSelect)] +oracle_enum = [ + ("orthodox", Orthodox), + ("blackbox", Blackbox) + ] + +-- | An enumeration of available subroutines and their names. +subroutine_enum :: [(String, Subroutine)] +subroutine_enum = [ + ("zero", A2), + ("initialize", A3), + ("hadamard", A4), + ("setup", A5), + ("qwsh", A6), + ("diffuse", A7), + ("fetcht", A8), + ("storet", A9), + ("fetchstoret", A10), + ("fetche", A11), + ("fetchstoree", A12), + ("update", A13), + ("swap", A14), + ("a15", A15), + ("a16", A16), + ("a17", A17), + ("a18", A18), + ("gcqwalk", A19), + ("gcqwstep", A20), + ("convertnode", O2), + ("testequal", O3), + ("pow17", O4), + ("mod3", O5), + ("sub", O6), + ("add", O7), + ("mult", O8) + ] + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to 'stdout'. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + putStr (show_enum "oracle" oracle_enum) + putStr (show_enum "subroutine" subroutine_enum) + where header = "Usage: tf [OPTION...]" + +-- ---------------------------------------------------------------------- +-- * The Triangle Finding Algorithm main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO() +main = do + argv <- getArgs + options <- dopts argv + let spec = spec_of_options options + let p = ceiling (logBase 2 (fromIntegral (2^9 `choose` 3))) + case options of + + Options { oracle = oracle, what = what, format = format, gatebase = gatebase, n = n, r = r, l = l, s = s} -> + + case what of + Circuit -> print_generic format $ decompose_generic gatebase $ a1_QWTFP spec + Oracle -> print_generic format (decompose_generic gatebase $ proj3 spec) node_shape node_shape qubit + Arith -> arithmetic_tests l + OTest -> oracle_tests n l + Sub -> case s of + A2 -> print_generic format (decompose_generic gatebase $ a2_ZERO (replicate n False)) + A3 -> print_generic format (decompose_generic gatebase $ a3_INITIALIZE (replicate n False)) + A4 -> print_generic format (decompose_generic gatebase $ a4_HADAMARD) (replicate n qubit) + A5 -> print_generic format (decompose_generic gatebase $ a5_SETUP spec) tt_shape + A6 -> print_generic format (decompose_generic gatebase $ a6_QWSH spec) + tt_shape (qdint_shape r) node_shape ee_shape + A7 -> print_generic format (decompose_generic gatebase $ a7_DIFFUSE) node_shape + A8 -> print_generic format (decompose_generic gatebase $ a8_FetchT) + (qdint_shape r) tt_shape node_shape + A9-> print_generic format (decompose_generic gatebase $ a9_StoreT) + (qdint_shape r) tt_shape node_shape + A10-> print_generic format (decompose_generic gatebase $ a10_FetchStoreT) + (qdint_shape r) tt_shape node_shape + A11-> print_generic format (decompose_generic gatebase $ a11_FetchE) + (qdint_shape r) ee_shape eed_shape + A12-> print_generic format (decompose_generic gatebase $ a12_FetchStoreE) + (qdint_shape r) ee_shape eed_shape + A13-> print_generic format (decompose_generic gatebase $ a13_UPDATE spec) + tt_shape node_shape eed_shape + A14-> print_generic format (decompose_generic gatebase $ a14_SWAP) + node_shape node_shape + A15 -> print_generic format (decompose_generic gatebase $ a15_TestTriangleEdges spec) + tt_shape ee_shape + A16 -> print_generic format (decompose_generic gatebase $ a16_TriangleTestT) + ee_shape + A17 -> print_generic format (decompose_generic gatebase $ a17_TriangleTestTw spec) + tt_shape ee_shape node_shape + A18 -> print_generic format (decompose_generic gatebase $ a18_TriangleEdgeSearch spec) + tt_shape ee_shape qubit + A19 -> print_generic format (decompose_generic gatebase $ a19_GCQWalk spec) + tt_shape ee_shape node_shape qubit + A20 -> print_generic format (decompose_generic gatebase $ a20_GCQWStep spec) + tt_shape ee_shape node_shape gcqw_shape + O2 -> print_generic format (decompose_generic gatebase $ \u -> o2_ConvertNode l u (2^(n-1))) node_shape + O3 -> print_generic format (decompose_generic gatebase $ o3_TestEqual) (qinttf_shape l) (qinttf_shape l) + O4 -> print_generic format (decompose_generic gatebase $ o4_POW17) (qinttf_shape l) + O5 -> print_generic format (decompose_generic gatebase $ o5_MOD3) (qinttf_shape l) + O6 -> print_generic format (decompose_generic gatebase $ \u -> o6_SUB u (2^(n-1))) (qinttf_shape l) + O7 -> print_generic format (decompose_generic gatebase $ o7_ADD) (qinttf_shape l) (qinttf_shape l) + O8 -> print_generic format (decompose_generic gatebase $ o8_MUL) (qinttf_shape l) (qinttf_shape l) + + where + rbar = max ((2 * r) `div` 3) 1 + proj3 (a,b,c,d) = c + node_shape = (replicate n qubit) + tt_shape = (intMap_replicate (2^r) node_shape) + ee_shape = (IntMap.fromList [(j,intMap_replicate j qubit) | j <- [0..((2^r)-1)]]) + eed_shape = (intMap_replicate (2^r) qubit) + gcqw_shape = (intMap_replicate (2^rbar) (qdint_shape r), + (qdint_shape rbar), + (qdint_shape r), + (intMap_replicate (2^rbar) qubit), + (qdint_shape (2*rbar - 1)), + qubit) + + +-- | Compute the appropriate problem specification for the given options. +spec_of_options :: Options -> QWTFP_spec +spec_of_options Options { oracle = Orthodox, n = n, r = r, l = l, qram = qram} = + (n,r, + (\u v edge -> do (u,v,edge) <- o1_ORACLE l u v edge; return edge), + qram_select qram) +spec_of_options Options { oracle = Blackbox, n = n, r = r, qram = qram} = + (n,r,placeholder_oracle,qram_select qram) + +-- | Maps a 'QRamSelect' element to the corresponding 'Qram' object. +qram_select :: QRamSelect -> Qram +qram_select Standard_QRam = standard_qram +qram_select Alt_QRam = alt_qram diff --git a/Quipper/Algorithms/TF/Oracle.hs b/Quipper/Algorithms/TF/Oracle.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/TF/Oracle.hs @@ -0,0 +1,467 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | This module provides implementations of an oracle for the +-- Triangle Finding Algorithm. +-- +-- This oracle injects the graph /G/ into the space +-- {0, 1, . . . , 2/l/ − 1} of /l/-bit integers, and each oracle +-- call requires the extensive use of modular arithmetic. +-- +-- The circuits produced by running this \"orthodox\" oracle are +-- very big. We therefore also provide a \"blackbox\" oracle, +-- which is simply a placeholder for an actual oracle call, +-- to replace the orthodox oracle when running subroutines and +-- for resource estimation. The oracle circuit is the same every +-- time it is used, so for resource estimation purposes, it only +-- needs to be generated once, rather than inlined at every use site. + +module Quipper.Algorithms.TF.Oracle where + +import Quipper + +import Quipper.Algorithms.TF.Definitions + +import Quipper.Utils.Auxiliary + +-- ====================================================================== + +-- * Orthodox oracle + +-- | Algorithm O-1. The two 'QNode' inputs /u/ and +-- /v/ are assumed to be of equal length. +o1_ORACLE :: Int -> QNode -> QNode -> Qubit -> Circ (QNode,QNode,Qubit) +o1_ORACLE l = box "o1" $ \u v edge -> do + comment_with_label "ENTER: o1_ORACLE" (u,v,edge) ("u","v","edge") + let n = length u + hn = 2^(n-1) + + ((u,v),e) <- with_computed_fun (u,v) + (o1_ORACLE_aux l hn) + (\((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) -> do + edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 1 .&&. vF .==. 1) + edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 1 .&&. vF .==. 0 .&&. t_u3v3 .==. 1) + edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 0 .&&. vF .==. 1 .&&. t_u3v3 .==. 1) + edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 0 .&&. vF .==. 0 .&&. t_u3v3 .==. 0 .&&. t_uHvH .==. 0) + return (((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)),edge)) + + comment_with_label "EXIT: o1_ORACLE" (u,v,edge) ("u","v","edge") + return (u,v,edge) + +-- | Compute the various auxiliary data for 'o1_ORACLE'. +o1_ORACLE_aux :: Int -> Int -> (QNode, QNode) -> Circ ((QNode, QNode), (QIntTF, QIntTF, QIntTF, QIntTF, QIntTF, QIntTF), (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit)) +o1_ORACLE_aux l hn = box "o1_aux" $ \(u,v) -> do + comment_with_label "ENTER: o1_ORACLE_aux" (u,v) ("u","v") + (u,uint) <- o2_ConvertNode l u hn + (v,vint) <- o2_ConvertNode l v hn + (uint,vint,t_uv) <- o3_TestEqual uint vint + {- Since we don’t have “quantum control”, we can’t say “if t == True… return” here; + instead we just add a “control on t_uv == False” to the later flips of ‘edge’. -} + + (uint,u17) <- o4_POW17 uint + (uint,u17,uF) <- o3_TestEqual uint u17 + (vint,v17) <- o4_POW17 vint + (vint,v17,vF) <- o3_TestEqual vint v17 + + let uint_bits = qulist_of_qinttf_lh uint + let vint_bits = qulist_of_qinttf_lh vint + uH <- qinit False + uH <- qnot uH `controlled` (uint_bits !! (l-1)) + vH <- qinit False + vH <- qnot vH `controlled` (vint_bits !! (l-1)) +-- Would like to say ”t_uHvH <- qd_testequal uH vH t_uHvH”, if testequal were generic. + t_uHvH <- qinit True + t_uHvH <- qnot t_uHvH `controlled` uH + t_uHvH <- qnot t_uHvH `controlled` vH + + (u17,u3) <- o5_MOD3 u17 + (v17,v3) <- o5_MOD3 v17 + (u3,v3,t_u3v3) <- o3_TestEqual u3 v3 + + comment_with_label "EXIT: o1_ORACLE_aux" ((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) (("u","v"),("uint","vint","u17","v17","u3","v3"),("uF","vF","uH","vH","t_uv","t_uHvH","t_u3v3")) + return ((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) + +-- | Algorithm O-2. Convert a 'QNode' into a freshly assigned 'QIntTF', +o2_ConvertNode :: Int -> QNode -> Int -> Circ (QNode,QIntTF) +o2_ConvertNode l u hn = ($ u) $ box "o2" $ \u -> do + comment_with_label "ENTER: o2_ConvertNode" u "u" + let n = if (length u < l) then (length u) else (error ("ConvertNode: requires n < l. n = " ++ (show (length u)) ++ ", l = " ++ (show l) ++ ".")) + + (u, uint) <- with_computed_fun u + (\u -> do + (u,w_low) <- qc_copy_fun u + w_high <- qinit (replicate (l-n) False) + return (u,qinttf_of_qulist_lh (w_low ++ w_high))) + + (\(u,w) -> do + (w,uint) <- o6_SUB w hn + return ((u,w),uint)) + comment_with_label "EXIT: o2_ConvertNode" (u, uint) ("u", "uint") + return (u, uint) + +-- | Algorithm O-3. Compare if two QIntTF’s are equal; +-- return the result in a fresh Qubit. +-- +-- This function is in general iffy: 00…00 and 11…11 do /not/ test as equal, as they should. +-- However, that case does not arise in the oracle: on the one hand, both 00…00 and 11…11 +-- are literal fixed points of 'o4_POW17', and on the other, 'o5_MOD3' never outputs 00. +o3_TestEqual :: QIntTF -> QIntTF-> Circ (QIntTF,QIntTF,Qubit) +o3_TestEqual = box "o3" $ \x y -> do + comment_with_label "ENTER: o3_TestEqual" (x,y) ("x", "y") + let x_bits = qulist_of_qinttf_lh x + let y_bits = qulist_of_qinttf_lh y + y_bits <- mapM (\(p,q) -> qnot q `controlled` p) (zip x_bits y_bits) + t <- qinit False + t <- qnot t `controlled` [ q .==. 0 | q <- y_bits ] + y_bits <- mapM (\(p,q) -> qnot q `controlled` p) (zip x_bits y_bits) + let x = qinttf_of_qulist_lh x_bits + let y = qinttf_of_qulist_lh y_bits + comment_with_label "EXIT: o3_TestEqual" (x, y, t) ("x", "y", "t") + return (x, y, t) + +-- | Algorithm O-4. Compute 17th power of a 31-bit 'QIntTF' /x/, into a +-- freshly 31-bit /QIntTF/. +o4_POW17 :: QIntTF -> Circ (QIntTF,QIntTF) +o4_POW17 = box "o4" $ \x -> do + comment_with_label "ENTER: o4_POW17" x "x" + (x, x17) <- with_computed_fun x + (\x -> do + (x,x2) <- square x + (x2,x4) <- square x2 + (x4,x8) <- square x4 + (x8,x16) <- square x8 + return (x,x2,x4,x8,x16)) + + (\(x,x2,x4,x8,x16) -> do + (x,x16,x17) <- o8_MUL x x16 + return ((x,x2,x4,x8,x16),x17)) + comment_with_label "EXIT: o4_POW17" (x, x17) ("x", "x17") + return (x, x17) + +{- Alternative coding style: +o4_POW17 x = do + (x,x17) <- with_computed_fun square x (\(x,x2) -> do + (x2,(x,x17)) <- with_computed_fun square x2 (\(x2,x4) -> do + (x4,(x,x17)) <- with_computed_fun square x4 (\(x4,x8) -> do + (x8,(x,x17)) <- with_computed_fun square x8 (\(x8,x16) -> do + (x,x16,x17) <- o8_MUL x x16 + return ((x8,x16),(x,x17))) + return ((x4,x8),(x,x17))) + return ((x2,x4),(x,x17))) + return ((x,x2),x17)) + return (x,x17) +-} + +-- | Map a QIntTF /x/ to (/x/,/x/^2). +-- +-- A subroutine factored out of @'o4_POW17'@. +square :: QIntTF -> Circ (QIntTF,QIntTF) +square x = do +-- comment_with_label "ENTER: square" x "x" + (x, x2) <- with_computed_fun x qc_copy_fun + (\(x,x') -> do + (x,x',x2) <- o8_MUL x x' + return ((x,x'),x2)) +-- comment_with_label "EXIT: square" (x, x2) ("x", "x2") + return (x, x2) + +-- | Algorithm O-5. Compute residue modulo 3 of the lower-order bits of a +-- 'QIntTF', into a fresh 2-bit 'QIntTF'. +-- +-- This algorithm is size-limited — works for up to 31-bit integers, but not beyond. +-- +-- This also currently is mismatched with our specification of QIntTF, since it +-- produces output in the range 1–3, rather than 0–2. However, output of this +-- algorithm is only used via '03_TestEqual', so this is not a problem in practice. +o5_MOD3 :: QIntTF -> Circ (QIntTF,QIntTF) +o5_MOD3 = box "o5" $ \x -> do + comment_with_label "ENTER: o5_MOD3" x "x" + let x_bits = qulist_of_qinttf_lh x + let l = length x_bits + l' = if (l <= 31) then (l `div` 2) + else error "o5_MOD3: requires l <= 31" + (x_bits, m_bits) <- with_computed_fun x_bits + (\x_bits -> do + s5 <- mmap qulist_of_qinttf_lh $ qinit (inttf 5 15) + + (x_bits,s5) <- loop_with_indexM l' (x_bits,s5) (\i (x_bits,s5) -> do + s5 <- increment_little s5 `controlled` (x_bits !! (2*i)) + s5 <- if (2*i + 1 <= l - 2) -- in case l is even, skip this step on the last iteration. + then decrement_little s5 `controlled` (x_bits !! (2*i + 1)) + else return s5 + return (x_bits,s5)) + + s3 <- mmap qulist_of_qinttf_lh $ qinit (inttf 3 3) + + (s5,s3) <- loop_with_indexM 2 (s5,s3) (\i (s5,s3) -> do + s3 <- increment_little s3 `controlled` (s5 !! (2*i)) + s3 <- decrement_little s3 `controlled` (s5 !! (2*i + 1)) + return (s5,s3)) + s3 <- increment_little s3 `controlled` (s5 !! 4) + + let s3_high = last s3 + s2 = init s3 + s2 <- increment_little s2 `controlled` s3_high + + return (x_bits,s5,s3_high,s2)) + + (\(x_bits,s5,s3_high,s2) -> do + (s2,m_bits) <- qc_copy_fun s2 + return ((x_bits,s5,s3_high,s2), m_bits)) + let x = qinttf_of_qulist_lh x_bits + let m = qinttf_of_qulist_lh m_bits + comment_with_label "EXIT: o5_MOD3" (x, m) ("x", "m") + return (x, m) + +-- | Algorithm O-6. Subtract an integer parameter from a 'QIntTF'. +-- Return the result as a second, freshly assigned 'QIntTF'. +o6_SUB :: QIntTF -> Int -> Circ (QIntTF,QIntTF) +o6_SUB x y = ($ x) $ box "o6" $ \x -> do + comment_with_label "ENTER: o6_SUB" x "x" + (x, d_out) <- with_computed_fun x + (\x1 -> do + let x = qulist_of_qinttf_lh x1 + let l = length x + let y_bits = reverse (boollist_of_int_bh l y) -- the little-endian binary rep of /y/ + + d <- qinit (replicate l False) -- will be [the list of bits of] the eventual answer + d1 <- qinit (replicate l False) -- will hold an intermediate version of the + -- subtraction, not “corrected” modulo (2^l – 1). + c1 <- qinit (replicate (l+1) False) + + (c1,d1,x) <- loop_with_indexM l (c1,d1,x) (\j (c1,d1,x) -> do + let c1_j1 = c1 !! (j+1) + let d1_j = d1 !! j + c1_j1 <- if y_bits !! j + then return c1_j1 + else qnot c1_j1 `controlled` (x !! j) + c1_j1 <- qnot c1_j1 `controlled` (x !! j) .&&. (c1 !! j) + c1_j1 <- if y_bits !! j + then return c1_j1 + else qnot c1_j1 `controlled` (c1!!j) + d1_j <- qnot d1_j `controlled` (x !! j) + d1_j <- if y_bits !! j + then return d1_j + else qnot d1_j + d1_j <- qnot d1_j `controlled` (c1 !! j) + c1 <- return $ overwriteAt (j+1) c1_j1 c1 + d1 <- return $ overwriteAt j d1_j d1 + return (c1,d1,x)) + + c2 <- qinit (replicate (l+1) False) + c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l) + c2 <- return $ overwriteAt 0 c2_0 c2 + + (d,d1,c2) <- loop_with_indexM l (d,d1,c2) (\j (d,d1,c2) -> do + let c2_j1 = c2 !! (j+1) + let dj = d !! j + c2_j1 <- qnot c2_j1 `controlled` (d1 !! j) .&&. (c2 !! j) + dj <- qnot dj `controlled` (d1 !! j) + dj <- qnot dj `controlled` (c2 !! j) + c2 <- return $ overwriteAt (j+1) c2_j1 c2 + d <- return $ overwriteAt j dj d + return (d,d1,c2)) + + d_0 <- qnot (d !! 0) `controlled` (c2 !! l) + d <- return $ overwriteAt 0 d_0 d + return (x,d,d1,c1,c2)) + -- Having computed the difference /d/ along with much auxiliary data, we save a + -- copy of /d/ before undoing all the computation: + (\(x,d,d1,c1,c2) -> do + (d,d_out) <- qc_copy_fun d + return ((x,d,d1,c1,c2),qinttf_of_qulist_lh d_out)) + comment_with_label "EXIT: o6_SUB" (x, d_out) ("x", "d_out") + return (x, d_out) + +-- | Algorithm O-7. Add two 'QIntTF's. Return the result as a third, freshly assigned 'QIntTF'. +o7_ADD :: QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF) +o7_ADD = box "o7" $ \x y -> do + comment_with_label "ENTER: o7_ADD" (x, y) ("x", "y") + let x_bits = qulist_of_qinttf_lh x + let y_bits = qulist_of_qinttf_lh y + let l = length x_bits + + ((x_bits,y_bits),s_out) <- with_computed_fun (x_bits,y_bits) + (\(x_bits,y_bits) -> do + s <- qinit (replicate l False) -- holds the eventual sum + s1 <- qinit (replicate l False) -- holds the uncorrected sum + c1 <- qinit (replicate (l+1) False) -- holds the carries + + (c1,s1,x_bits,y_bits) <- loop_with_indexM l (c1,s1,x_bits,y_bits) (\j (c1,s1,x_bits,y_bits) -> do + let c1_j1 = c1 !! (j+1) + let s1_j = s1 !! j + c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (y_bits!!j) + c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (c1!!j) + c1_j1 <- qnot c1_j1 `controlled` (y_bits!!j) .&&. (c1!!j) + s1_j <- qnot s1_j `controlled` (x_bits !! j) + s1_j <- qnot s1_j `controlled` (y_bits !! j) + s1_j <- qnot s1_j `controlled` (c1 !! j) + c1 <- return $ overwriteAt (j+1) c1_j1 c1 + s1 <- return $ overwriteAt j s1_j s1 + return (c1,s1,x_bits,y_bits)) + + c2 <- qinit (replicate (l+1) False) + c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l) + c2 <- return $ overwriteAt 0 c2_0 c2 + + (s,s1,c2) <- loop_with_indexM l (s,s1,c2) (\j (s,s1,c2) -> do + let c2_j1 = c2 !! (j+1) + let sj = s !! j + c2_j1 <- qnot c2_j1 `controlled` (s1 !! j) .&&. (c2 !! j) + sj <- qnot sj `controlled` (s1 !! j) + sj <- qnot sj `controlled` (c2 !! j) + c2 <- return $ overwriteAt (j+1) c2_j1 c2 + s <- return $ overwriteAt j sj s + return (s,s1,c2)) + + s_0 <- qnot (s !! 0) `controlled` (c2 !! l) + s <- return $ overwriteAt 0 s_0 s + + return (x_bits,y_bits,s,s1,c1,c2)) + + (\(x_bits,y_bits,s,s1,c1,c2) -> do + (s,s_out) <- qc_copy_fun s + return ((x_bits,y_bits,s,s1,c1,c2), s_out)) + let x = qinttf_of_qulist_lh x_bits + let y = qinttf_of_qulist_lh y_bits + let s = qinttf_of_qulist_lh s_out + comment_with_label "EXIT: o7_ADD" (x, y, s) ("x", "y", "s") + return (x, y, s) + +-- | Controlled version of 'o7_ADD'. Returns either a copy of the first +-- input (if controls are “off”) or the sum of the inputs +-- (if controls are “on”). +-- +-- We make this version explicitly, rather than just using 'controlled', +-- because the controls only need to be applied to a very few selected +-- gates in the routine. +o7_ADD_controlled :: (ControlSource ctrl, Labelable ctrl String) + => ctrl -> QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF) +o7_ADD_controlled controls x y = do + comment_with_label "ENTER: o7_ADD_controlled" (controls,x,y) ("ctrl","x","y") + let x_bits = qulist_of_qinttf_lh x + let y_bits = qulist_of_qinttf_lh y + let l = length x_bits + + ((x_bits,y_bits),s_out) <- with_computed_fun (x_bits,y_bits) + (\(x_bits,y_bits) -> do + s <- qinit (replicate l False) -- holds the eventual sum + s1 <- qinit (replicate l False) -- holds the uncorrected sum + c1 <- qinit (replicate (l+1) False) -- holds the carries + + (c1,s1,x_bits,y_bits) <- loop_with_indexM l (c1,s1,x_bits,y_bits) (\j (c1,s1,x_bits,y_bits) -> do + let c1_j1 = c1 !! (j+1) + let s1_j = s1 !! j + c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (y_bits!!j) + c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (c1!!j) + c1_j1 <- qnot c1_j1 `controlled` (y_bits!!j) .&&. (c1!!j) + s1_j <- qnot s1_j `controlled` (x_bits !! j) + s1_j <- qnot s1_j `controlled` (y_bits !! j) + s1_j <- qnot s1_j `controlled` (c1 !! j) + c1 <- return $ overwriteAt (j+1) c1_j1 c1 + s1 <- return $ overwriteAt j s1_j s1 + return (c1,s1,x_bits,y_bits)) + + c2 <- qinit (replicate (l+1) False) + c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l) + c2 <- return $ overwriteAt 0 c2_0 c2 + + (s,s1,c2) <- loop_with_indexM l (s,s1,c2) (\j (s,s1,c2) -> do + let c2_j1 = c2 !! (j+1) + let sj = s !! j + c2_j1 <- qnot c2_j1 `controlled` (s1 !! j) .&&. (c2 !! j) + sj <- qnot sj `controlled` (s1 !! j) + sj <- qnot sj `controlled` (c2 !! j) + c2 <- return $ overwriteAt (j+1) c2_j1 c2 + s <- return $ overwriteAt j sj s + return (s,s1,c2)) + + s_0 <- qnot (s !! 0) `controlled` (c2 !! l) + s <- return $ overwriteAt 0 s_0 s + + return (x_bits,y_bits,s,s1,c1,c2)) + + (\(x_bits,y_bits,s,s1,c1,c2) -> do + -- Prepare a qubit holding the value of the controls, + -- since we want to control also on their negation. + -- /Can’t/ include this in “with_computed_fun”: controls can’t be bound + -- as QData, and including it unbound yields rather interesting bug. + temp_control <- qinit False + temp_control <- qnot temp_control `controlled` controls + s_out <- qinit (replicate l False) + (x_bits,s_out) <- mapBinary + (\q q' -> do + q' <- qnot q' `controlled` (q .&&. (temp_control .==. 0)) + return (q,q')) + x_bits s_out + (s,s_out) <- mapBinary + (\q q' -> do + q' <- qnot q' `controlled` (q .&&. (temp_control .==. 1)) + return (q,q')) + s s_out + temp_control <- qnot temp_control `controlled` controls + qterm False temp_control + return ((x_bits,y_bits,s,s1,c1,c2), s_out)) + let x = qinttf_of_qulist_lh x_bits + let y = qinttf_of_qulist_lh y_bits + let s = qinttf_of_qulist_lh s_out + comment_with_label "EXIT: o7_ADD_controlled" (x,y,s) ("x","y","s") + return (x, y, s) + + +-- | Algorithm O-8. Multiply two 'QIntTF's; return the +-- result as a third, freshly assigned 'QIntTF'. +o8_MUL :: QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF) +o8_MUL = box "o8" $ \x y -> do +-- comment_with_label "ENTER: o8_MUL" (x,y) ("x","y") + let x_bits = qulist_of_qinttf_lh x + let l = length x_bits + + ((x,y),p) <- with_computed_fun (x,y) + (\(x, y) -> do + let x_bits = qulist_of_qinttf_lh x + -- We will build up a register of partial products, each obtained from the previous + -- by adding (2^i * y) if the ith bit of x is set. + -- For this, we make a copy of y, to be repeatedly doubled as we go. + (y,tmp_y) <- qc_copy_fun y + wrk0 <- qinit (inttf l 0) + (tmp_y,wrks) <- loop_with_indexM l (tmp_y,[wrk0]) + (\k (tmp_y,(wrk_prev:wrks_older)) -> do + (wrk_prev,tmp_y,wrk_new) + <- o7_ADD_controlled (x_bits !! k) wrk_prev tmp_y + tmp_y <- double_TF tmp_y + return (tmp_y,(wrk_new:wrk_prev:wrks_older))) + return ((qinttf_of_qulist_lh x_bits),y,tmp_y,wrks)) + + (\(x,y,tmp_y,(wrks_head:wrks_rest)) -> do + (wrks_head,p) <- qc_copy_fun wrks_head + return ((x,y,tmp_y,(wrks_head:wrks_rest)), p)) + +-- comment_with_label "EXIT: o8_MUL" (x,y,p) ("x","y","p") + return (x,y,p) + +-- | Double a 'QIntTF' in place. +-- +-- A subroutine factored out of 'o8_MUL'. +double_TF :: QIntTF -> Circ QIntTF +double_TF x = do + comment_with_label "ENTER: double_TF" x "x" + x <- case qulist_of_qinttf_lh x of + [] -> return (qinttf_of_qulist_lh []) + x_bits -> return (qinttf_of_qulist_lh ((last x_bits):(init x_bits))) + comment_with_label "EXIT: double_TF" x "x" + return x + +-- ====================================================================== + +-- * Blackbox oracle + +-- | A black-box oracle for testing. Produces a labelled black-box gate in +-- place of the actual oracle circuit. + +placeholder_oracle :: QNode -> QNode -> Qubit -> Circ Qubit +placeholder_oracle node1 node2 outp_bit = do + comment_with_label "placeholder_oracle" (node1, node2, outp_bit) ("node1", "node2", "outp_bit") + extended_named_gate_at "OC" [outp_bit] (node1 ++ node2) + return outp_bit + + diff --git a/Quipper/Algorithms/TF/QWTFP.hs b/Quipper/Algorithms/TF/QWTFP.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/TF/QWTFP.hs @@ -0,0 +1,648 @@ +{-# LANGUAGE FlexibleContexts #-} + +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 + {-# OPTIONS -fcontext-stack=50 #-} +#else + {-# OPTIONS -freduction-depth=50 #-} +#endif + +-- | This module provides an implementation of the Quantum Walk for +-- the Triangle Finding Problem. +-- +-- The algorithm works by performing a Grover-based quantum walk on +-- a larger graph /H/, called the Hamming graph associated to /G/. +-- We refer to this part of the algorithm as the /outer/ walk. +-- The subroutine used to check whether a triangle has been found +-- is itself a quantum walk, the /inner/ walk. +-- +-- The overall algorithm is parameterized on integers /l/, /n/ and /r/ +-- specifying respectively the length /l/ of the integers used by the +-- oracle, the number 2[sup /n/] of nodes of /G/ and the size 2[sup /r/] +-- of Hamming graph tuples. + +module Quipper.Algorithms.TF.QWTFP where + +import Prelude hiding (mapM, mapM_) + +import Quipper +import Quipper.Internal (BType) +import Quipper.Libraries.Arith +import Quipper.Algorithms.TF.Definitions + +import Data.IntMap (IntMap, adjust, insert, size) +import qualified Data.IntMap as IntMap +import Data.Traversable (mapM) +import Data.Foldable (mapM_) +import Control.Monad (foldM) + + +-- ====================================================================== +-- * Main TF algorithm + +-- | Algorithm 1. Do a quantum walk on the Hamming graph associated with /G/. +-- Returns a quadruple /(testTMeasure, wMeasure, TMeasure, EMeasure)/ +-- where /wMeasure/ contains a node of the triangle with the +-- other two nodes in /TMeasure/. +a1_QWTFP :: QWTFP_spec -> Circ (Bit,CNode,IntMap CNode,IntMap (IntMap Bit)) +a1_QWTFP oracle@(n,r,edgeOracle,_) = do + comment "ENTER: a1_QWTFP" + let nn = 2^n + let rr = 2^r + let rbar = max ((2 * r) `div` 3) 1 + let rrbar = 2^rbar + let tm = 2^(n - r) + let tw = floor $ sqrt $ fromIntegral rr + + testTEdge <- a2_ZERO False + tt <- a3_INITIALIZE (intMap_replicate rr (replicate n False)) + i <- a3_INITIALIZE (intm r 0) + v <- a3_INITIALIZE (replicate n False) + + (tt, ee) <- a5_SETUP oracle tt + + (tt,i,v,ee) <- box_loopM "a1_loop1" tm (tt,i,v,ee) + (\(tt,i,v,ee) -> do + + ((tt,ee),_) <- with_computed_fun (tt,ee) + + (\(tt,ee) -> a15_TestTriangleEdges oracle tt ee) + + (\(tt,ee,w,triTestT,triTestTw) -> do + phaseFlipUnless (triTestT .==. 0 .&&. triTestTw .==. 0) + return ((tt,ee,w,triTestT,triTestTw),())) + + (tt,i,v,ee) <- box_loopM "a1_loop2" tw (tt,i,v,ee) (\(a,b,c,d) -> a6_QWSH oracle a b c d) + return (tt,i,v,ee)) + + (tt,ee,w,triTestT,triTestTw) <- a15_TestTriangleEdges oracle tt ee + + testTEdge <- qor testTEdge [(triTestT, True), (triTestTw, True)] + + testTMeasure <- measure testTEdge + wMeasure <- measure w + ttMeasure <- measure tt + eeMeasure <- measure ee + qdiscard (i,v,triTestT,triTestTw) + comment_with_label "EXIT: a1_QWTFP" (testTMeasure, wMeasure, ttMeasure, eeMeasure) ("testTMeasure", "wMeasure", "ttMeasure", "eeMeasure") + return (testTMeasure, wMeasure, ttMeasure, eeMeasure) + + +-- ====================================================================== +-- *Utility subroutines + +-- | Algorithm 2. +-- Initialize the qubits in a register to a specified state. +-- Defined using the more generic 'qinit'. +a2_ZERO :: QShape a qa ca => a -> Circ qa +a2_ZERO b = do + comment "ENTER: a2_ZERO" + q <- qinit b + comment_with_label "EXIT: a2_ZERO" q "q" + return q + +-- | Algorithm 3. +-- Initialize to a specified state then apply a Hadamard gate to +-- the qubits in a register. +a3_INITIALIZE :: QShape a qa ca => a -> Circ qa +a3_INITIALIZE reg = do + comment "ENTER: a3_INITIALIZE" + zreg <- a2_ZERO reg + hzreg <- a4_HADAMARD zreg + comment_with_label "EXIT: a3_INITIALIZE" hzreg "hzreg" + return hzreg + +-- | Algorithm 4. +-- Apply a Hadamard gate to every qubit in the given quantum data. +-- Defined using the more generic 'map_hadamard'. +a4_HADAMARD :: QData qa => qa -> Circ qa +a4_HADAMARD q = do + comment_with_label "ENTER: a4_HADAMARD" q "q" + q <- map_hadamard q + comment_with_label "EXIT: a4_HADAMARD" q "q" + return q + +-- | Algorithm 5. +-- Set up the register /ee/ with the edge information +-- for the nodes contained in /tt/. +a5_SETUP :: QWTFP_spec -> (IntMap QNode) -> Circ (IntMap QNode, IntMap (IntMap Qubit)) +a5_SETUP oracle@(n,r,edgeOracle,_) = box "a5" $ \tt -> do + comment_with_label "ENTER: a5_SETUP" tt "tt" + let rr = 2^r + ee <- qinit $ IntMap.fromList [(j,(intMap_replicate j False)) | j <- [0..(rr-1)]] + ee <- loop_with_indexM (rr) ee (\k ee -> + loop_with_indexM k ee (\j ee -> do + edgejk <- edgeOracle (tt ! j) (tt ! k) (ee ! k ! j) + ee <- return $ adjust (insert j edgejk) k ee + return ee)) + comment_with_label "EXIT: a5_SETUP" (tt,ee) ("tt","ee") + return (tt, ee) + + +-- ====================================================================== +-- ** The outer quantum walk and the standard Qram + +-- | Algorithm 6. +-- Do a quantum walk step on the Hamming graph. +a6_QWSH :: QWTFP_spec -> (IntMap QNode) -> QDInt -> QNode -> (IntMap (IntMap Qubit)) + -> Circ (IntMap QNode, QDInt, QNode, IntMap (IntMap Qubit)) +a6_QWSH oracle@(n,r,edgeOracle,qram) = box "a6" $ \tt i v ee -> do + comment_with_label "ENTER: a6_QWSH" (tt, i, v, ee) ("tt", "i", "v", "ee") + with_ancilla_init (replicate n False) $ \ttd -> do + with_ancilla_init (intMap_replicate (2^r) False) $ \eed -> do + (i,v) <- a7_DIFFUSE (i,v) + + ((tt,i,v,ee,ttd,eed),_) <- with_computed_fun (tt,i,v,ee,ttd,eed) + + (\(tt,i,v,ee,ttd,eed) -> do + (i,tt,ttd) <- qram_fetch qram i tt ttd + (i,ee,eed) <- a12_FetchStoreE i ee eed + (tt,ttd,eed) <- a13_UPDATE oracle tt ttd eed + (i,tt,ttd) <- qram_store qram i tt ttd + return (tt,i,v,ee,ttd,eed)) + + (\(tt,i,v,ee,ttd,eed) -> do + (ttd,v) <- a14_SWAP ttd v + return ((tt,i,v,ee,ttd,eed),())) + + comment_with_label "EXIT: a6_QWSH" (tt, i, v, ee) ("tt", "i", "v", "ee") + return (tt,i,v,ee) + +-- | Algorithm 7. +-- Diffuse a piece of quantum data, in the Grover search sense of +-- reflecting about the average. +-- +-- Note: relies on @'qshape' q@ corresponding to the “all false” state. +a7_DIFFUSE :: (QData qa) => qa -> Circ qa +a7_DIFFUSE = box "a7" $ \q -> do + comment_with_label "ENTER: a7_DIFFUSE" q "q" + q <- a4_HADAMARD q + phaseFlipUnless $ q .==. qc_false q + q <- a4_HADAMARD q + comment_with_label "EXIT: a7_DIFFUSE" q "q" + return q + +-- | Algorithm 8. +-- Perform a quantum-addressed fetch operation. +-- This fetches the /i/-th element from /tt/ into /ttd/. +-- Precondition: /ttd/ = 0. +-- +-- This could be implemented more efficiently using the qRAM implementation +-- in "Alternatives". +a8_FetchT :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +a8_FetchT = box "a8" $ \i tt ttd -> do + comment_with_label "ENTER: a8_FetchT" (i,tt,ttd) ("i","tt","ttd") + let r = qdint_length i + (i,tt,ttd) <- loop_with_indexM (2^r) (i,tt,ttd) + (\j (i,tt,ttd) -> do + let ttj = tt ! j + (ttj,ttd) <- mapBinary + (\q p -> do + p <- qnot p `controlled` q .&&. i .==. (fromIntegral j) + return (q,p)) + (tt ! j) ttd + return (i, insert j ttj tt, ttd)) + comment_with_label "EXIT: a8_FetchT" (i,tt,ttd) ("i","tt","ttd") + return (i,tt,ttd) + +-- | Algorithm 9. +-- Perform a quantum-addressed store operation: +-- store /ttd/ into the /i/-th element from /tt/. +-- Analogous to 'a8_FetchT'. +a9_StoreT :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +a9_StoreT = box "a9" $ \i tt ttd -> do + comment_with_label "ENTER: a9_StoreT" (i,tt,ttd) ("i","tt","ttd") + let r = qdint_length i + (i,tt,ttd) <- loop_with_indexM (2^r) (i,tt,ttd) + (\j (i,tt,ttd) -> do + (ttj,ttd) <- mapBinary + (\q p -> do + q <- qnot q `controlled` p .&&. i .==. (fromIntegral j) + return (q,p)) + (tt ! j) ttd + return (i, insert j ttj tt, ttd)) + comment_with_label "EXIT: a9_StoreT" (i,tt,ttd) ("i","tt","ttd") + return (i,tt,ttd) + + +-- | Algorithm 10. +-- Perform a quantum-addressed swap: +-- swap /ttd/ with the /i/-th element of /tt/. +-- Analogous to 'a8_FetchT' and 'a9_StoreT'. +a10_FetchStoreT :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +a10_FetchStoreT = box "a10" $ \i tt ttd -> do + comment_with_label "ENTER: a10_FetchStoreT" (i,tt,ttd) ("i","tt","ttd") + let r = qdint_length i + (i,tt,ttd) <- loop_with_indexM (2^r) (i,tt,ttd) + (\j (i,tt,ttd) -> do + (qq,ttd) <- a14_SWAP (tt ! j) ttd + `controlled` i .==. (fromIntegral j) + return (i,(insert j qq tt), ttd)) + comment_with_label "EXIT: a10_FetchStoreT" (i,tt,ttd) ("i","tt","ttd") + return (i,tt,ttd) + + +-- | Algorithm 11. Perform a quantum-addressed fetch operation. This +-- is a somewhat specialized addressed fetching operation. +a11_FetchE :: QDInt -> IntMap (IntMap Qubit) -> IntMap Qubit + -> Circ (QDInt, IntMap (IntMap Qubit), IntMap Qubit) +a11_FetchE = box "a11" $ \i qs ps -> do + comment_with_label "ENTER: a11_FetchE" (i, qs, ps) ("i", "qs", "ps") + let r = qdint_length i + (i,qs,ps) <- loop_with_indexM (2^r) (i,qs,ps) (\j (i,qs,ps) -> + loop_with_indexM j (i,qs,ps) (\k (i,qs,ps) -> do + pk <- qnot (ps ! k) `controlled` + (qs ! j ! k) .&&. i .==. (fromIntegral j) + ps <- return $ insert k pk ps + pj <- qnot (ps ! j) `controlled` + (qs ! j ! k) .&&. i .==. (fromIntegral k) + ps <- return $ insert j pj ps + return (i,qs,ps))) + comment_with_label "EXIT: a11_FetchE" (i, qs, ps) ("i", "qs", "ps") + return (i,qs,ps) + +-- | Algorithm 12. +-- Perform a quantum-addressed swap. Analogous to 'a11_FetchE'. +a12_FetchStoreE :: QDInt -> IntMap (IntMap Qubit) -> IntMap Qubit + -> Circ (QDInt, IntMap (IntMap Qubit), IntMap Qubit) +a12_FetchStoreE = box "a12" $ \i qs ps -> do + comment_with_label "ENTER: a12_FetchStoreE" (i, qs, ps) ("i", "qs", "ps") + let r = qdint_length i + (i,qs,ps) <- loop_with_indexM (2^r) (i,qs,ps) (\j (i,qs, ps) -> + loop_with_indexM j (i,qs, ps) (\k (i,qs, ps) -> do + (q,p) <- a14_SWAP (qs ! j ! k) (ps ! k) + `controlled` i .==. (fromIntegral j) + (qs,ps) <- return (adjust (insert k q) j qs, insert k p ps) + (q,p) <- a14_SWAP (qs ! j ! k) (ps ! j) + `controlled` i .==. (fromIntegral k) + (qs,ps) <- return (adjust (insert k q) j qs, insert j p ps) + return (i,qs,ps))) + comment_with_label "EXIT: a12_FetchStoreE" (i, qs, ps) ("i", "qs", "ps") + return (i,qs,ps) + +-- | Algorithm 13. +-- Given a list of nodes /tt/, a distinguished node /ttd/, +-- and a list of bits /eed/, either: +-- +-- * store the edge information for /(ttd,tt)/ into /eed/, if /eed/ is initially 0; or +-- +-- * zero /eed/, if it initially holds the edge information. +a13_UPDATE :: QWTFP_spec -> IntMap QNode -> QNode -> IntMap Qubit + -> Circ (IntMap QNode, QNode, IntMap Qubit) +a13_UPDATE oracle@(n,r,edgeOracle,_) = box "a13" $ \tt ttd eed -> do + comment_with_label "ENTER: a13_UPDATE" (tt,ttd,eed) ("tt","ttd","eed") + (tt,ttd,eed) <- loop_with_indexM (2^r) (tt,ttd,eed) (\j (tt,ttd,eed) -> do + e <- edgeOracle (tt ! j) ttd (eed ! j) + return (tt,ttd,insert j e eed)) + comment_with_label "EXIT: a13_UPDATE" (tt,ttd,eed) ("tt","ttd","eed") + return (tt,ttd,eed) + +-- | Algorithm 14. Swap two registers of equal size. This is a +-- generic function and works for any quantum data type. +a14_SWAP :: QCData qa => qa -> qa -> Circ (qa, qa) +a14_SWAP q r = do + comment_with_label "ENTER: a14_SWAP" (q,r) ("q", "r") + (q,r) <- swap q r + comment_with_label "EXIT: a14_SWAP" (q,r) ("q", "r") + return (q,r) + +-- | The qRAM operations from Algorithms 8–10 wrapped into a 'Qram' object. +standard_qram :: Qram +standard_qram = Qram { + qram_fetch = a8_FetchT, + qram_store = a9_StoreT, + qram_swap = a10_FetchStoreT +} + +-- ====================================================================== +-- ** The inner quantum walk + +-- | A type to hold the Graph Collision Quantum Walk Registers +-- /(tau, iota, sigma, eew, cTri, triTestT)/, used in 'a20_GCQWStep'. +type GCQWRegs = (IntMap QDInt, QDInt, QDInt, IntMap Qubit, QDInt, Qubit) + +-- | Algorithm 15: /TestTriangleEdges/. +-- Test whether the nodes /tt/ contain a pair that can be extended to a +-- triangle in the graph. Used as the test function in the outer quantum +-- walk. Seeks triangles in two different ways: +-- +-- 1. Entirely within the nodes /tt/. If found, set qubit /triTestT/. +-- +-- 2. With two vertices from /tt/, a third anywhere in the graph. If found, +-- set qubit /triTestTw/, and return the third vertex as /w/. This is +-- implemented using an “inner quantum walk” to seek /w/. +a15_TestTriangleEdges :: + QWTFP_spec -- ^ The ambient oracle. + -> IntMap QNode -- ^ /tt/, an /R/-tuple of nodes. + -> IntMap (IntMap Qubit) -- ^ /ee/, a cache of the edge information between nodes in /tt/. + -> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit,Qubit) -- ^ Return /(tt, ee, w, triTestT,triTestTw)/. +a15_TestTriangleEdges oracle = box "a15" $ \tt ee -> do + comment_with_label "ENTER: a15_TestTriangleEdges" (tt,ee) ("tt","ee") + (ee,triTestT) <- a16_TriangleTestT ee + (tt,ee,w,triTestT) <- a18_TriangleEdgeSearch oracle tt ee triTestT + (tt,ee,w,triTestTw) <- a17_TriangleTestTw oracle tt ee w + comment_with_label "EXIT: a15_TestTriangleEdges" (tt,ee,w,triTestT,triTestTw) ("tt","ee","w","triTestT","triTestTw") + return (tt,ee,w,triTestT,triTestTw) + +-- | Algorithm 16: /TriangleTestT ee triTestT/. +-- Search exhaustively over the array /ee/ of edge data, seeking a triangle. +-- Whenever one is found, flip the qubit /triTestT/. +a16_TriangleTestT :: IntMap (IntMap Qubit) -> Circ (IntMap (IntMap Qubit), Qubit) +a16_TriangleTestT = box "a16" $ \ee -> do + comment_with_label "ENTER: a16_TriangleTestT" ee "ee" + let rr = size ee + (ee,triTestT) <- with_computed_fun ee + + (\ee -> do + cTri <- qinit (intm (ceiling (logBase 2 (fromIntegral (rr `choose` 3)))) 0) + cTri <- foldM (\cTri (i,j,k) -> do + cTri <- increment cTri `controlled` (ee ! j ! i) .&&. (ee ! k ! i) .&&. (ee ! k ! j) + return cTri) + cTri [(i,j,k) | i <- [0..rr-1], j <- [i+1..rr-1], k <- [j+1..rr-1]] + return (ee,cTri)) + + (\(ee,cTri) -> do + triTestT <- qinit True + triTestT <- qnot triTestT `controlled` cTri .==. 0 + return ((ee,cTri),triTestT)) + + comment_with_label "EXIT: a16_TriangleTestT" (ee,triTestT) ("ee","triTestT") + return (ee,triTestT) + +{-Alternative implementation, using (a lot of) extra ancillas instead of a counter: +a16_TriangleTestT :: [[Qubit]] -> Qubit -> Circ ([[Qubit]], Qubit) +a16_TriangleTestT ee triTestT = do + let rr = length ee + ((ee,triTestT),_) <- with_computed_fun + + (\(ee,triTestT) -> do + tests <- mapM (\(i,j,k) -> do + t <- a2_ZERO False + t <- qnot t `controlled` + [(ee !! j !! i),(ee !! k !! i),(ee !! k !! j)] + return(t)) + [(i,j,k) | i <- [0..rr-1], j <- [i+1..rr-1], k <- [j+1..rr-1]] + return (ee,triTestT,tests)) + + (ee,triTestT) + + (\(ee,triTestT,tests) -> do + triTestT <- qor triTestT (map (\p -> (p,True)) tests) + return ((ee,triTestT,tests),())) + + return (ee,triTestT)-} + + +-- | Algorithm 17: /TriangleTestTw ee triTestTw/. +-- Search exhaustively for a pair of nodes in /tt/ that form a triangle with /w/. +-- Whenever a triangle found, flip qubit /triTestTw/. +a17_TriangleTestTw :: QWTFP_spec -- ^ The ambient oracle. + -> IntMap QNode -- ^ /tt/, an /R/-tuple of nodes. + -> IntMap (IntMap Qubit) -- ^ /ee/, a cache of the edge data for /T/. + -> QNode -- ^ /w/, another node. + -> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit) -- ^ return /(tt,ee,w,triTestTw)/. +a17_TriangleTestTw oracle@(n,r,edgeOracle,_) = box "a17" $ \tt ee w -> do + comment_with_label "ENTER: a17_TriangleTestTw" (tt,ee,w) ("tt","ee","w") + let rr = size ee + with_ancilla_init (intMap_replicate rr False) $ \eed -> do + ((tt,ee,w,eed),triTestTw) <- with_computed_fun (tt,ee,w,eed) + + (\(tt,ee,w,eed) -> do + eed <- mapWithKeyM (\k e -> do + e <- edgeOracle (tt ! k) w e + return e) + eed + cTri <- qinit (intm (ceiling (logBase 2 (fromIntegral (rr `choose` 2)))) 0) + cTri <- foldM + (\cTri (i,j) -> + increment cTri `controlled` (ee ! j ! i) .&&. (eed ! i) .&&. (eed ! j)) + cTri + [(i,j) | i <- [0..rr-1], j <- [i+1..rr-1]] + return (tt,ee,w,eed,cTri)) + + (\(tt,ee,w,eed,cTri) -> do + triTestTw <- qinit True + triTestTw <- qnot triTestTw `controlled` cTri .==. 0 + return ((tt,ee,w,eed,cTri),triTestTw)) + + comment_with_label "EXIT: a17_TriangleTestTw" (tt,ee,w,triTestTw) ("tt","ee","w","triTestTw") + return (tt,ee,w,triTestTw) + +{-Alternative implementation, using (a lot of) extra ancillas instead of a counter: +a17_TriangleTestTw oracle@(n,r,edgeOracle) tt ee w triTestTw = do + let rr = length ee + with_ancilla_list rr $ \eed -> do + ((tt,ee,w,triTestTw,eed),_) <- with_computed_fun + + (\(tt,ee,w,triTestTw,eed) -> do + eed <- mapM (\(b,a) -> do + b <- edgeOracle (tt !! a) w b + return (b)) + (zip (eed) [0..rr-1]) + tests <- mapM (\(i,j) -> do + t <- a2_ZERO False + t <- qnot t `controlled` (ee !! j !! i) .&&. (eed !! i) .&&. (eed !! j) + return(t)) + [(i,j) | i <- [0..rr-1], j <- [i+1..rr-1]] + return (tt,ee,w,triTestTw,eed,tests)) + + (tt,ee,w,triTestTw,eed) + + (\(tt,ee,w,triTestTw,eed,tests) -> do + triTestTw <- qor triTestTw (map (\p -> (p,True)) tests) + return ((tt,ee,w,triTestTw,eed,tests),())) + + return (tt,ee,w,triTestTw)-} + + +-- | Algorithm 18: /TriangleEdgeSearch/. +-- Use Grover search to seek a node /w/ that forms a triangle with some pair of +-- nodes in /tt/, unless a triangle has already been found (recorded in /triTestT/), +-- in which case do nothing. +a18_TriangleEdgeSearch :: QWTFP_spec -- ^ The ambient oracle. + -> IntMap QNode -- ^ /tt/, an /R/-tuple of nodes. + -> IntMap (IntMap Qubit) -- ^ /ee/, a cache of edge data for /R/. + -> Qubit -- ^ /triTestT/, test qubit recording if a triangle has already been found. + -> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit) -- ^ Return /(tt, ee, w, regs)/. +a18_TriangleEdgeSearch oracle@(n,r,edgeOracle,_) = box "a18" $ \tt ee triTestT -> do + comment_with_label "ENTER: a18_TriangleEdgeSearch" (tt,ee,triTestT) ("tt","ee","triTestT") + let nn = 2^n + tG = floor (pi/4 *( sqrt ( fromIntegral nn))) + + w <- a2_ZERO (replicate n False) + w <- a4_HADAMARD w + + box_loopM "a18_loop" tG (tt,ee,w,triTestT) (\(tt,ee,w,triTestT) -> do + ((tt,ee,w,triTestT),()) <- with_computed_fun (tt,ee,w,triTestT) + + (\(tt,ee,w,triTestT) -> do + (tt,ee,w,triTestT,cTri) <- a19_GCQWalk oracle tt ee w triTestT + + cTri_nonzero <- qinit True + cTri_nonzero <- qnot cTri_nonzero `controlled` cTri .==. 0 + + return (tt,ee,w,triTestT,cTri,cTri_nonzero)) + + (\(tt,ee,w,triTestT,cTri,cTri_nonzero) -> do + phaseFlipIf $ (triTestT .==. 0) .&&. cTri_nonzero + return ((tt,ee,w,triTestT,cTri,cTri_nonzero),())) + + w <- a7_DIFFUSE w + return (tt,ee,w,triTestT)) + comment_with_label "EXIT: a18_TriangleEdgeSearch" (tt,ee,w,triTestT) ("tt","ee","w","triTestT") + return (tt,ee,w,triTestT) + +-- | Algorithm 19: /GCQWalk/ (“Graph Collision Quantum Walk”) +-- +-- Perform graph collision on the /R/-tuple /tt/ and the node /w/, to determine +-- (with high probability) whether /w/ forms a triangle with some pair of nodes +-- in /tt/. +a19_GCQWalk :: QWTFP_spec -- ^ The ambient oracle. + -> IntMap QNode -- ^ /tt/, an /R/-tuple of nodes. + -> IntMap (IntMap Qubit) -- ^ /ee/, a cache of the edge data for /tt/. + -> QNode -- ^ /w/, a node. + -> Qubit -- ^ /triTestT/, test qubit to record if a triangle has already been found. + -> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit, QDInt) -- ^ Return /(tt,ee,w,triTestT,cTri)/. +a19_GCQWalk oracle@(n,r,edgeOracle,qram) = box "a19" $ \tt ee w triTestT -> do + comment_with_label "ENTER: a19_GCQWalk" (tt,ee,w,triTestT) ("tt","ee","w","triTestT") + let nn = 2^n + rr = 2^r + rbar = max ((2 * r) `div` 3) 1 + rrbar = 2^rbar + tbarm = max (rr `div` rrbar) 1 + tbarw = floor $ sqrt $ fromIntegral rrbar + + cTri <- qinit (intm (2*rbar - 1) 0) + + with_ancilla_init + ((intMap_replicate rrbar (intm r 0)), + (intm rbar 0), + (intm r 0), + (intMap_replicate rrbar False)) + $ \(tau,iota,sigma,eew) -> do + + tau <- a4_HADAMARD tau + iota <- a4_HADAMARD iota + sigma <- a4_HADAMARD sigma + + eew <- mapWithKeyM (\j eew_j -> do + let taub = tau ! j + ttd <- qinit (replicate n False) + (taub, tt, ttd) <- qram_fetch qram taub tt ttd + eew_j <- edgeOracle ttd w eew_j + (taub, tt, ttd) <- qram_fetch qram taub tt ttd + qterm (replicate n False) ttd + return eew_j) + eew + + cTri <- foldM (\cTri j -> do + let tau_j = tau ! j + eed <- qinit (intMap_replicate rr False) + (taub,ee,eed) <- a11_FetchE tau_j ee eed + cTri <- foldM (\cTri k -> do + let tau_k = tau ! k + -- Note: the Fetch to eedd_k seems redundant here; why not control on (eedd !! k) directly? + eedd_k <- qinit False + (tauc, eed, eedd_k) <- qram_fetch qram tau_k eed eedd_k + cTri <- increment cTri `controlled` eedd_k .&&. (eew ! j) .&&. (eew ! k) + (tauc, eed, eedd_k) <- qram_fetch qram tau_k eed eedd_k + qterm False eedd_k + return cTri) + cTri [j+1..rrbar-1] + (taub,ee,eed) <- a11_FetchE tau_j ee eed + qterm (intMap_replicate rr False) eed + return cTri) + cTri [0..rrbar-1] + + (tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT)) <- box_loopM "a19_loop1" tbarm + (tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT)) + + (\(tt,ee,w,(e1,e2,e3,e4,cTri,triTestT)) -> do + ((cTri,triTestT),()) <- with_computed_fun (cTri,triTestT) + + (\(cTri,triTestT) -> do + cTri_nonzero <- qinit True + cTri_nonzero <- qnot cTri_nonzero `controlled` cTri .==. 0 + return (cTri,triTestT,cTri_nonzero)) + + (\(cTri,triTestT,cTri_nonzero) -> do + phaseFlipIf $ (triTestT .==. 0) .&&. cTri_nonzero + return ((cTri,triTestT,cTri_nonzero),())) + + box_loopM "a19_loop2" tbarw (tt,ee,w,(e1,e2,e3,e4,cTri,triTestT)) (\(b,c,d,e) -> a20_GCQWStep oracle b c d e)) + + comment_with_label "EXIT: a19_GCQWalk" (tt,ee,w,triTestT,cTri) ("tt","ee","w","triTestT","cTri") + return (tt,ee,w,triTestT,cTri) + + +-- | Algorithm 20: /GCQWStep/ +-- Take one step in the graph collision walk (used in 'a19_GCQWalk' above). +-- Uses many auxiliary registers. +-- The arguments are, in this order: +-- +-- * The ambient oracle. +-- +-- * /tt/, an /R/-tuple of nodes. +-- +-- * /ee/, a cache of the edge data for /tt/. +-- +-- * /w/, a node. +-- +-- * /regs/, various workspace\/output registers. +-- +-- * /ttd/, /eed/, /taud/, /eewd/, and /eedd/, local ancillas. +-- +-- The function returns /(tt, ee, w, regs)/. +a20_GCQWStep :: QWTFP_spec + -> IntMap QNode + -> IntMap (IntMap Qubit) + -> QNode + -> GCQWRegs + -> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, GCQWRegs) +a20_GCQWStep oracle@(n,r,edgeOracle,qram) = box "a20" $ + \tt ee w gcqwRegs@(tau,iota,sigma,eew,cTri,triTestT) -> do + comment_with_label "ENTER: a20_GCQWStep" (tt,ee,w,tau,iota,sigma,eew,cTri,triTestT) ("tt","ee","w","tau","iota","sigma","eew","cTri","triTestT") + let rr = 2^r + rbar = max ((2 * r) `div` 3) 1 + rrbar = 2^rbar + + (iota, sigma) <- a7_DIFFUSE (iota, sigma) + + ((tt,ee,w,gcqwRegs),_) <- with_computed_fun (tt,ee,w,gcqwRegs) + + (\(tt,ee,w,gcqwRegs@(tau,iota,sigma,eew,cTri,triTestT)) -> do + ttd <- qinit (replicate n False) + eed <- qinit (intMap_replicate rr False) + taud <- qinit (intm r 0) + eewd <- qinit False + eedd <- qinit (intMap_replicate rrbar False) + + (iota, tau, taud) <- qram_fetch qram iota tau taud + (taud, tt, ttd) <- qram_fetch qram taud tt ttd + (iota,eew,eewd) <- qram_swap qram iota eew eewd + (taud,ee,eed) <- a11_FetchE taud ee eed + eedd <- mapWithKeyM (\k eeddb -> do + let taub = tau ! k + (taub, eed, eeddb) <- qram_fetch qram taub eed eeddb + return eeddb) + eedd + cTri <- loop_with_indexM (rrbar-1) cTri (\a cTri -> do + decrement cTri `controlled` (eedd ! a) .&&. (eewd) .&&. (eew ! a)) + eewd <- edgeOracle ttd w eewd + eedd <- mapWithKeyM (\k e -> do + let taub = tau ! k + let eeddb = eedd ! k + (taub, eed, eeddb) <- qram_fetch qram taub eed eeddb + return e) + eedd + (taud,ee,eed) <- a11_FetchE taud ee eed + (taud,tt,ttd) <- qram_fetch qram taud tt ttd + (iota,tau,taud) <- qram_store qram iota tau taud + return (tt,ee,w,gcqwRegs,ttd,eed,taud,eewd,eedd)) + + (\(tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT),ttd,eed,taud,eewd,eedd) -> do + (taud,sigma) <- a14_SWAP taud sigma + return ((tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT),ttd,eed,taud,eewd,eedd),())) + + comment_with_label "ENTER: a20_GCQWStep" (tt,ee,w,gcqwRegs) ("tt","ee","w",("tau","iota","sigma","eew","cTri","triTestT")) + return (tt,ee,w,gcqwRegs) diff --git a/Quipper/Algorithms/TF/Simulate.hs b/Quipper/Algorithms/TF/Simulate.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/TF/Simulate.hs @@ -0,0 +1,443 @@ +-- | This module contains functions for simulating and debugging +-- the Triangle Finding Oracle and its subroutines. + +module Quipper.Algorithms.TF.Simulate where + +import Quipper + +import Quipper.Libraries.Arith +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.TF.Definitions +import Quipper.Algorithms.TF.Oracle +import Quipper.Algorithms.TF.Alternatives + +import Data.Maybe + +import Quipper.Utils.Sampling +import Quipper.Utils.Auxiliary (boollist_of_int_bh) + +-- ====================================================================== +-- * Native and simulated arithmetic functions + +-- $ For each arithmetic routine implemented in the Triangle Finding +-- Oracle, we give two parallel implementations: one using Haskell’s +-- arithmetic, and one by simulating the circuit execution. +-- +-- These can then be cross-checked against each other for correctness. + +-- | Increment an /m/-bit Quipper integer (mod 2[sup /m/]). Native Haskell. +increment_haskell :: IntM -> IntM +increment_haskell = succ + +-- | Increment an /m/-bit Quipper integer (mod 2[sup /m/]). Simulated from +-- 'increment'. +increment_simulate :: IntM -> IntM +increment_simulate = run_classical_generic increment + +-- | Increment an /m/-bit Triangle Finding integer (mod 2[sup /m/]–1). +-- Native Haskell. +incrementTF_haskell :: IntTF -> IntTF +incrementTF_haskell x1 = (inttf m ((x+1) `mod` (2^m - 1))) + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + +-- | Increment an /m/-bit TF integer (mod 2[sup /m/]–1). Simulated from +-- 'increment_TF'. +incrementTF_simulate :: IntTF -> IntTF +incrementTF_simulate = run_classical_generic increment_TF + +-- | Double an /m/-bit TF integer (mod 2[sup /m/]–1). Native Haskell. +doubleTF_haskell :: IntTF -> IntTF +doubleTF_haskell x1 = (inttf m ((2*x) `mod` (2^m - 1))) + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + +-- | Double an /m/-bit TF integer (mod 2[sup /m/]–1). Simulated from +-- 'double_TF'. +doubleTF_simulate :: IntTF -> IntTF +doubleTF_simulate = run_classical_generic double_TF + +-- | Add two 'IntTF's. Native Haskell. +addTF_haskell :: IntTF -> IntTF -> IntTF +addTF_haskell x1 y1 = + if (m == n) then (inttf m $ (x + y) `mod` (2^m - 1)) + else error "addTF_haskell: Cannot add IntTF’s with different moduli." + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + n = fromJust (inttf_length y1) + y = integer_of_inttf y1 + +-- | Add two 'IntTF's. Simulated from 'o7_ADD'. +addTF_simulate :: IntTF -> IntTF -> IntTF +addTF_simulate = + run_classical_generic (\x y -> do + (_,_,z) <- o7_ADD x y + return z) + +-- | Multiply two 'IntTF's. Native Haskell. +multTF_haskell :: IntTF -> IntTF -> IntTF +multTF_haskell x1 y1 = + if (m == n) then (inttf m $ (x * y) `mod` (2^m - 1)) + else error "multTF_haskell: Cannot multiply IntTF’s with different moduli." + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + n = fromJust (inttf_length y1) + y = integer_of_inttf y1 + +-- | Multiply two 'IntTF's. Simulated from 'o8_MUL'. +multTF_simulate :: IntTF -> IntTF -> IntTF +multTF_simulate = + run_classical_generic (\x y -> do + (_,_,z) <- o8_MUL x y + return z) + +-- | Raise an 'IntTF' to the 17th power. Native Haskell. +pow17_haskell :: IntTF -> IntTF +pow17_haskell x1 = inttf m ((x^17) `mod` (2^m - 1)) + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + +-- | Raise an 'IntTF' to the 17th power. Simulated from 'o4_POW17'. +pow17_simulate :: IntTF -> IntTF +pow17_simulate = + run_classical_generic (\x -> do + (_,z) <- o4_POW17 x + return z) + +-- | Compute the reduction, mod 3, of lower-order bits of an 'IntTF'. +-- Native Haskell. +mod3_haskell :: IntTF -> IntTF +mod3_haskell x1 = inttf 2 ((x `mod` (2^(m-1))) `mod` 3) + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + +-- | Compute the reduction, mod 3, of lower-order bits of an 'IntTF'. +-- Simulated from 'o5_MOD3'. +mod3_simulate :: IntTF -> IntTF +mod3_simulate = + run_classical_generic (\x -> do + (_,z) <- o5_MOD3 x + return z) + +-- | Compute the reduction, mod 3, of lower-order bits of an 'IntTF'. +-- Simulated from 'o5_MOD3_alt'. +mod3_alt_simulate :: IntTF -> IntTF +mod3_alt_simulate = + run_classical_generic (\x -> do + (_,z) <- o5_MOD3_alt x + return z) + +-- ====================================================================== +-- * Native and simulated oracle functions + +-- | Oracle: compute the edge information between two nodes. +-- Native Haskell. +oracle_haskell :: Int -> [Bool] -> [Bool] -> Bool +oracle_haskell l u v + | n /= length v = error "oracle_haskell: bad input size: length of v and u must be the same" + | n >= l = error "oracle_haskell: bad input size: n must be less than l" + | otherwise = + if uint == vint then False + else if (u17 == uint) && (v17 == vint) then True + else if (u17 /= uint) && (v17 /= vint) then + (uH /= vH) && (u3 /= v3) + else (u3 == v3) + where + modup z n = ((z-1) `mod` n) + 1 + n = length u :: Int + hn = 2^(n-1) + incl :: [Bool] -> Integer + incl x = + ((sum [ if b then 2^i else 0 | (b,i) <- zip x [0..]]) - hn) + `modup` (2^l - 1) + uint = incl u + vint = incl v + u17 = (uint^17) `modup` (2^l - 1) + v17 = (vint^17) `modup` (2^l - 1) + u3 = (u17 `mod` 2^(l-1)) `modup` 3 + v3 = (v17 `mod` 2^(l-1)) `modup` 3 + uF = u17 == uint + vF = v17 == vint + uH = (uint >= 2^(l-1)) + vH = (vint >= 2^(l-1)) + +-- | Oracle: compute the edge information between two nodes. +-- Simulated from 'o1_ORACLE'. +oracle_simulate :: Int -> [Bool] -> [Bool] -> Bool +oracle_simulate l = + run_classical_generic (\u v -> do + e <- qinit False + (u,v,e) <- o1_ORACLE l u v e + return e) + + +-- | Oracle auxiliary information. Native Haskell. +oracle_aux_haskell :: Int -> [Bool] -> [Bool] -> + (([Bool], [Bool]), + (IntTF, IntTF, IntTF, IntTF, IntTF, IntTF), + (Bool, Bool, Bool, Bool, Bool, Bool, Bool)) +oracle_aux_haskell l u v + | n /= length v = error "oracle_aux_haskell: bad input size: length of v and u must be the same" + | n >= l = error "oracle_aux_haskell: bad input size: n must be less than l" + | otherwise = + ((u,v),(inttf l uint,inttf l vint,inttf l u17,inttf l v17,inttf 2 u3,inttf 2 v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) + where + modup z n = ((z-1) `mod` n) + 1 + n = length u :: Int + hn = 2^(n-1) + incl :: [Bool] -> Integer + incl x = + ((sum [ if b then 2^i else 0 | (b,i) <- zip x [0..]]) - hn) + `modup` (2^l - 1) + uint = incl u + vint = incl v + u17 = (uint^17) `modup` (2^l - 1) + v17 = (vint^17) `modup` (2^l - 1) + u3 = (u17 `mod` 2^(l-1)) `modup` 3 + v3 = (v17 `mod` 2^(l-1)) `modup` 3 + uF = u17 == uint + vF = v17 == vint + uH = (uint >= 2^(l-1)) + vH = (vint >= 2^(l-1)) + t_uv = uint == vint + t_uHvH = uH == vH + t_u3v3 = u3 == v3 + + +-- | Oracle auxiliary information. Simulated from 'o1_ORACLE_aux'. +oracle_aux_simulate :: Int -> [Bool] -> [Bool] -> + (([Bool], [Bool]), + (IntTF, IntTF, IntTF, IntTF, IntTF, IntTF), + (Bool, Bool, Bool, Bool, Bool, Bool, Bool)) +oracle_aux_simulate l = + run_classical_generic (\u v -> o1_ORACLE_aux l (2^((length u)-1)) (u,v)) + +-- | A specialized 'show' for oracle auxiliary data. +show_oracle_details :: Show a => (([Bool], [Bool]), + (a,a,a,a,a,a), + (Bool, Bool, Bool, Bool, Bool, Bool, Bool)) + -> String +show_oracle_details ((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) + = (showBits u) ++ " " ++ (showBits v) ++ " " ++ + showBits [uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3] ++ " " ++ + show [uint,vint,u17,v17,u3,v3] + where + showBits :: [Bool] -> String + showBits [] = "[]" + showBits bs = map (\b -> if b then '1' else '0') bs + +-- | Conversion of a node to an integer. Native Haskell. +convertNode_haskell :: Int -> [Bool] -> IntTF +convertNode_haskell l u = inttf l (incl u) + where + incl :: [Bool] -> Integer + incl u = + ((sum [ if b then 2^i else 0 | (b,i) <- zip u [0..]]) - (2^((length u)-1))) + `mod` (2^l - 1) + +-- | Conversion of a node to an integer. Simulated from 'o2_ConvertNode'. +convertNode_simulate :: Int -> [Bool] -> IntTF +convertNode_simulate l = run_classical_generic (\u -> do + (u,uint) <- o2_ConvertNode l u (2^((length u)-1)) + return uint) + +-- ====================================================================== +-- * Testing functions + +-- $ Various small test suites, checking the simulated circuit arithmetic +-- functions against their Haskell equivalents. + +-- | Give full table of values for 'increment' functions. +increment_table :: Int -> [String] +increment_table l = [ "increment table for l = " ++ (show l) ++ ":" + , "" + , "x x+H x+Q "] + ++ + [ (show x) ++ " " ++ (show x_h) ++ " " ++ (show x_q) ++ flag + | x <- [0..(2^l - 1)] + , let x_h = integer_of_intm_unsigned $ increment_haskell (intm l x) + , let x_q = integer_of_intm_unsigned $ increment_simulate (intm l x) + , let flag = if x_h /= x_q then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the 'increment_TF' functions. +incrementTF_table :: Int -> [String] +incrementTF_table l = [ "incrementTF table for l = " ++ (show l) ++ ":" + , "" + , "x x+H x+Q "] + ++ + [ (show x) ++ " " ++ (show x_h) ++ " " ++ (show x_q) ++ flag + | x <- [0..(2^l - 2)] + , let x_h = incrementTF_haskell (inttf l x) + , let x_q = incrementTF_simulate (inttf l x) + , let flag = if x_h /= x_q then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the 'double_TF' functions. +doubleTF_table :: Int -> [String] +doubleTF_table l = [ "doubleTF table for l = " ++ (show l) ++ ":" + , "" + , "x 2xH 2xQ "] + ++ + [ (show x) ++ " " ++ (show x_h) ++ " " ++ (show x_q) ++ flag + | x <- [0..(2^l - 2)] + , let x_h = doubleTF_haskell (inttf l x) + , let x_q = doubleTF_simulate (inttf l x) + , let flag = if x_h /= x_q then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the TF addition ('o7_ADD') +-- functions. +addTF_table :: Int -> [String] +addTF_table l = [ "addTF table for l = " ++ (show l) ++ ":" + , "" + , "x y x+yH x+yQ "] + ++ + [ (show x) ++ " " ++ (show y) ++ " " + ++ (show xyh) ++ " " ++ (show xyq) + ++ flag + | x <- [0..(2^l - 1)] , y <- [0..(2^l - 1)] + , let xyh = addTF_haskell (inttf l x) (inttf l y) + , let xyq = addTF_simulate (inttf l x) (inttf l y) + , let flag = if xyh /= xyq then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the TF multiplication ('o8_MUL') +-- functions. +multTF_table :: Int -> [String] +multTF_table l = [ "multTF table for l = " ++ (show l) ++ ":" + , "" + , "x y x*yH x*yQ "] + ++ + [ (show x) ++ " " ++ (show y) ++ " " + ++ (show xyh) ++ " " ++ (show xyq) + ++ flag + | x <- [0..(2^l - 1)] , y <- [0..(2^l - 1)] + , let xyh = multTF_haskell (inttf l x) (inttf l y) + , let xyq = multTF_simulate (inttf l x) (inttf l y) + , let flag = if xyh /= xyq then " **MISMATCH**" else ""] + ++ + ["",""] + + +-- | Give full table of values for the \'pow17\' functions. +pow17_table :: Int -> [String] +pow17_table l = [ "pow17 table for l = " ++ (show l) ++ ":" + , "" + , "x x17H x17Q "] + ++ + [ (show x) ++ " " ++ (show x_h) ++ " " ++ (show x_q) ++ flag + | x <- [0..(2^l - 1)] + , let x_h = pow17_haskell (inttf l x) + , let x_q = pow17_simulate (inttf l x) + , let flag = if x_h /= x_q then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the \'mod3\' functions. +mod3_table :: Int -> [String] +mod3_table l = [ "mod3 table for l = " ++ (show l) ++ ":" + , "" + , "x Haskell o5_MOD3 o5_MOD3_alt"] + ++ + [ (show x) ++ " " ++ (show x_h) ++ " " + ++ (show x_q) ++ flag + | x <- [0..(2^l - 1)] + , let x_h = mod3_haskell (inttf l x) + , let x_q = mod3_simulate (inttf l x) + , let x_q' = mod3_alt_simulate (inttf l x) + , let flag = if x_h /= x_q then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the oracle. +oracle_table :: Int -> Int -> [String] +oracle_table n l = [ "oracle table for l = " ++ (show l) ++ ", n = " ++ (show n) ++ ":" + , "" + , "u v E_H E_Q"] + ++ + [ (showBits u) ++ " " ++ (showBits v) ++ " " + ++ (show e_h) ++ " " ++ (show e_q) ++ flag + | uint <- [0..(2^n - 1)], let u = boollist_of_int_bh n uint + , vint <- [0..(2^n - 1)], let v = boollist_of_int_bh n vint + , let e_h = oracle_haskell l u v + , let e_q = oracle_simulate l u v + , let flag = if e_h /= e_q then " **MISMATCH**" else ""] + ++ + ["",""] + where + showBits :: [Bool] -> String + showBits [] = "[]" + showBits bs = map (\b -> if b then '1' else '0') bs + +-- | Give a full table of values for 'o1_ORACLE_aux'. +oracle_table_detailed :: Int -> Int -> [String] +oracle_table_detailed n l = [ "oracle_aux table for l = " ++ (show l) ++ ", n = " ++ (show n) ++ ":" + , "" + , "((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3))"] + ++ + (concat + [ [show_oracle_details od_h,show_oracle_details od_q] + | uint <- [0..(2^n - 1)], let u = boollist_of_int_bh n uint + , vint <- [0..(2^n - 1)], let v = boollist_of_int_bh n vint + , let od_h = oracle_aux_haskell l u v + , let od_q = oracle_aux_simulate l u v + , let flag = if od_h /= od_q then " **MISMATCH**" else "" + ]) + ++ + ["",""] + where + showBits :: [Bool] -> String + showBits [] = "[]" + showBits bs = map (\b -> if b then '1' else '0') bs + + +-- | Give full table of values for the \'convertNode\' functions. +convertNode_table :: Int -> Int -> [String] +convertNode_table l n = [ "convertNode table for l = " ++ (show l) ++ ", n = " ++ (show n) ++ ":" + , "" + , "u uint_H uint_Q"] + ++ + [ (showBits u) ++ " " ++ (show u_h) ++ " " ++ (show u_q) ++ flag + | uint <- [0..(2^n - 1)], let u = boollist_of_int_bh n uint + , let u_h = convertNode_haskell l u + , let u_q = convertNode_simulate l u + , let flag = if u_h /= u_q then " **MISMATCH**" else ""] + ++ + ["",""] + where + showBits :: [Bool] -> String + showBits [] = "[]" + showBits bs = map (\b -> if b then '1' else '0') bs + +-- | A compilation of the various tests above, to be called by +-- 'Quipper.Algorithms.TF.Main'. +arithmetic_tests :: Int -> IO () +arithmetic_tests l = do + mapM putStrLn $ increment_table l + mapM putStrLn $ incrementTF_table l + mapM putStrLn $ doubleTF_table l + mapM putStrLn $ addTF_table l + mapM putStrLn $ multTF_table l + mapM putStrLn $ pow17_table l + mapM putStrLn $ mod3_table l + return () + +-- | A suite of tests for the oracle, to be called by +-- 'Quipper.Algorithms.TF.Main'. +oracle_tests :: Int -> Int -> IO () +oracle_tests n l = do + mapM_ putStrLn $ oracle_table n l + mapM_ putStrLn $ oracle_table_detailed n l + mapM_ putStrLn $ convertNode_table l n diff --git a/Quipper/Algorithms/USV/Definitions.hs b/Quipper/Algorithms/USV/Definitions.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/USV/Definitions.hs @@ -0,0 +1,296 @@ +-- | This module provides global definitions for +-- the Unique Shortest Vector algorithm. + +module Quipper.Algorithms.USV.Definitions where + +import Quipper +import Quipper.Libraries.Arith + +import Control.Monad (foldM, zipWithM, replicateM) +import qualified Math.Lattices.LLL +import Data.Array +import Data.List (mapAccumL) +import Data.Numbers.Primes +import System.Random +import qualified Data.Map as Map +import Data.Map (Map) + + +-- ============================================================== +-- * Types for the Unique Shortest Vector algorithm + +-- | An input to 'Quipper.Algorithms.USV.USV.tPP': a pair of a 'Qubit' +-- and a list of 'QDInt's. Holds a superposition of two vectors with +-- an unknown fixed difference. +type TwoPoint = (Qubit, [QDInt]) + +-- | An input to 'Quipper.Algorithms.USV.USV.dCP': a pair of a 'Qubit' +-- and a 'QDInt'. Holds a superposition of two numbers with an unknown +-- fixed difference. +type CosetState = (Qubit, QDInt) + +-- | An input to 'Quipper.Algorithms.USV.USV.sieving': a pair of a +-- 'Qubit' and an integer. Holds a state of the form: +-- +-- \[image CosetState.png] +-- +-- together with the integer /k/. +type Psi_k = (Qubit, Int) + + +-- ============================================================== +-- * General purpose functions + +-- | Concatenate two pairs of lists componentwise. +concat_pair :: ([a],[b]) -> ([a],[b]) -> ([a],[b]) +concat_pair (i,j) (k,l) = (i ++ k, j ++ l) + +-- | Construct a list of random number generators. +multi_split :: StdGen -> [StdGen] +multi_split gen = gen1 : multi_split gen2 where + (gen1, gen2) = split gen + +-- | Given a list /l/, a predicate /p/ and an error message /msg/, +-- return a pair (/a/,/l'/) where /a/ is the first element +-- of /l/ satisfying /p/ and /l'/ is the remaining list. +-- If no such element exists, raise an error and display /msg/. +find :: [a] -> (a -> Bool) -> String -> (a, [a]) +find [] condition msg = error msg +find (a:as) condition msg = + if (condition a) then (a,as) + else (b,(a:bs)) + where + (b,bs) = find as condition msg + +-- | Given a list /l/ and a predicate /p/, return a pair +-- (/l1/, /l2/) where /l1/ contains the elements of /l/ +-- satisfying /p/ and /l2/ the others. +separate :: [a] -> (a -> Bool) -> ([a], [a]) +separate [] condition = ([],[]) +separate (h:t) condition = + if (condition h) then concat_pair ([h],[]) (separate t condition) + else concat_pair ([],[h]) (separate t condition) + +-- | Given integers /m/ and /n/, compute the +-- big-endian expansion of /m/ in base /n/. +expand :: Integer -> Integer -> [Integer] +expand _ n | n <= 1 = error ("Cannot expand a number in base " ++ show n ++ ".") +expand 0 n = [0] +expand m n = reverse $ expand_aux m n [] + where + expand_aux 0 n l = l + expand_aux m n l = (m-s) : expand_aux r n l where + r = m `div` n + s = n*r + +-- | Discard a list of 'Psi_k's +qdiscard_psi_ks :: [Psi_k] -> Circ () +qdiscard_psi_ks l = do + mapM (\(q,n) -> do + qdiscard q + return ()) l + return () + +-- | Given a list of people, and a function assigning a religion to +-- each person, divide the people into couples of the same religion. +-- Some people will remain single if there isn't a suitable +-- partner. Return a list of couples and a list of single people. +-- +-- The algorithm proceeds as follows. We have a room for each +-- religion. Initially the rooms are empty. As each person arrives, +-- they go to their room. If the room is empty, they stay there. If +-- the room is occupied, they marry the occupant and join the list +-- of couples. At the end, all single people are retrieved from +-- their rooms. +-- +-- This function is lazy, i.e., couples are formed as they are +-- found. Only the singles have to wait until the end of the list. +-- +-- Running time is O(/n/ log /n/). +find_partners :: (Ord b) => (a -> b) -> [a] -> ([(a,a)], [a]) +find_partners f = find_partners_in_rooms Map.empty + where + --find_partners_in_rooms :: Map b a -> [a] -> ([(a,a)], [a]) + find_partners_in_rooms rooms [] = ([], Map.elems rooms) + find_partners_in_rooms rooms (a:as) = + case Map.lookup (f a) rooms of + Just c -> ((a,c):pairs, singles) + where (pairs, singles) = find_partners_in_rooms rooms' as + rooms' = Map.delete (f a) rooms + Nothing -> find_partners_in_rooms rooms' as + where rooms' = Map.insert (f a) a rooms + + +-- ============================================================== +-- * Linear algebra + +-- | Compute the Euclidean norm of a vector. +norm :: [Integer] -> Float +norm v = sqrt $ fromIntegral $ foldl (+) 0 $ map (\x -> x^2) v + +-- | Compute the sum of two vectors. +vector_add :: Num a => [a] -> [a] -> [a] +vector_add u v = zipWith (+) u v + +-- | Quantum version of 'vector_add'. +q_vector_add :: [QDInt] -> [QDInt] -> Circ [QDInt] +q_vector_add u v = do + w <- zipWithM q_add u v + return (map (\(_,_,z) -> z) w) + +-- | Compute the multiplication of a scalar with a vector. +scalar_mult :: Num a => a -> [a] -> [a] +scalar_mult n v = map (\x -> n*x) v + +-- | Quantum version of 'scalar_mult'. +q_scalar_mult :: QDInt -> [QDInt] -> Circ [QDInt] +q_scalar_mult a v = do + v' <- mapM (\u -> do + (_,_,z) <- q_mult a u + return z) v + return v' + +-- | Multiply an /n/×/m/-matrix by an /m/-dimensional column +-- vector to obtain an /n/-dimensional column vector. The +-- matrix is represented as a list of /m/ columns. +-- +-- Precondition: /m/ > 0. +-- +-- Example: +-- +-- > matrix_mult [[1,2,3],[1,0,0]] [1,1] = [2,2,3] +matrix_mult :: [[Integer]] -> [Integer] -> [Integer] +matrix_mult m a = foldl vector_add zero $ zipWith scalar_mult a m + where + zero = replicate (length (head m)) 0 + +-- | Quantum version of 'matrix_mult'. +q_matrix_mult :: [[QDInt]] -> [QDInt] -> Circ [QDInt] +q_matrix_mult m a = do + let l1 = length (head m) + l2 = qdint_length (head a) + zero <- qinit (replicate l1 (intm l2 0)) + m <- zipWithM q_scalar_mult a m + result <- foldM q_vector_add zero m + return result + +-- | Check whether a vector is 0. +is_zero_vector :: [Integer] -> Bool +is_zero_vector = all (== 0) + + +-- ============================================================== +-- * Euclid's algorithm + +-- | The extended Euclidean algorithm. 'ext_euclid' /a/ /b/ returns +-- (/x/, /y/, /z/, /w/, /d/) such that: +-- +-- * 0 ≤ /d/ = gcd(/a/, /b/), the greatest common divisor of /a/ and +-- /b/; +-- +-- * /ax/ + /by/ = /d/; +-- +-- * /az/ + /bw/ = 0; +-- +-- * the determinant /xw/ - /yz/ = 1. +ext_euclid :: Integer -> Integer -> (Integer, Integer, Integer, Integer, Integer) +ext_euclid a b = ext_euclid_rec 1 0 0 1 a b 1 where + + -- the invariants for ext_euclid_rec are: + -- + -- [ x y ] [ a ] = [ r ] + -- [ z w ] [ b ] [ s ] + -- + -- and det [[x y] [z w]] = t = ±1. + + ext_euclid_rec x y z w r s t | r < 0 = + ext_euclid_rec (-x) (-y) z w (-r) s (-t) + ext_euclid_rec x y z w r s t | s < 0 = + ext_euclid_rec x y (-z) (-w) r (-s) (-t) + ext_euclid_rec x y z w r s t | r < s = + ext_euclid_rec z w x y s r (-t) + ext_euclid_rec x y z w r s t | 0 < s = + ext_euclid_rec z w (x-q*z) (y-q*w) s (r-q*s) (-t) + where q = r `div` s + ext_euclid_rec x y z w r s t = -- Note: s = 0, r ≥ 0. + (x, y, t*z, t*w, r) + + +-- ============================================================== +-- * Classical subroutines + +-- | Reduce a basis using the Lenstra-Lenstra-Lováscz algorithm. +-- +-- Uses the corresponding Haskell library. +lll :: [[Integer]] -> [[Integer]] +lll bb = bb_reduced_integral + where + bb_rational = map (\v -> map toRational v) bb + bb_reduced = Math.Lattices.LLL.lll bb_rational + bb_reduced_integral = map (\v -> map ceiling v) (elems bb_reduced) + +-- | Given an integer /m/, find the smallest prime /p/ such that /m/ ≤ +-- /p/ ≤ 2/m/. +-- +-- Uses preexisting 'isPrime' algorithm. +find_prime :: Int -> Int +find_prime m = head $ filter isPrime [(m)..(2*m)] + +-- | Given a vector /u/ and a basis /bb/ = [/b/[sub 0], …, +-- /b/[sub /n/-1]], determine whether /u/ belongs to the lattice +-- generated by /bb/, i.e., whether there exist integers /a/[sub 0], +-- …, /a/[sub /n/-1] such that /u/ = /a/[sub 0]/b/[sub 0] + … + +-- /a/[sub /n/-1]/b/[sub /n/-1]. +-- +-- Precondition: /u/ and /b/[sub 0], …, /b/[sub /n/-1] must all be +-- of the same dimension. +-- +-- The algorithm proceeds as follows: first, do invertible integer +-- column operations on /b/[sub 0], …, /b/[sub /n/-1] until the top +-- entries of /b/[sub 1], …, /b/[sub /n/-1] are 0. This can be done +-- efficiently by using the extended Euclidean algorithm for two +-- columns at a time. Then check whether the top entry of /b/[sub 0] +-- divides the top entry of /u/. If no, output 'False'. Otherwise, if +-- the top entry of /b/[sub 0] is 0, drop the top row and continue +-- recursively. Otherwise, subtract an appropriate multiple of +-- /b/[sub 0] from /u/, drop /b/[sub 0], drop the top row, and +-- continue recursively. Trivial base cases occur when the number of +-- rows or columns reaches 0. +is_in_lattice :: [Integer] -> [[Integer]] -> Bool +is_in_lattice [] bb = True +is_in_lattice u [] = is_zero_vector u +is_in_lattice (u0:us) (b0:bs) = + let (c00:c0s, cs) = mapAccumL column_op b0 bs in + if c00 == 0 + then if u0 /= 0 + then False + else is_in_lattice us (c0s:cs) + else if u0 `mod` c00 /= 0 + then False + else + let q = u0 `div` c00 + us' = us `vector_add` ((-q) `scalar_mult` c0s) + in is_in_lattice us' cs + +-- | Given a basis /bb/ = [/b/[sub 0], …, /b/[sub /n/-1]], find +-- another equivalent basis whose elements are linearly independent. +reduce_lattice :: [[Integer]] -> [[Integer]] +reduce_lattice [] = [] +reduce_lattice ([]:bs) = [] +reduce_lattice (b0:bs) = + let (c0, cs) = mapAccumL column_op b0 bs in + case c0 of + 0 : c0s -> [ 0:x | x <- reduce_lattice (c0s:cs) ] + _ -> c0 : [ 0:x | x <- reduce_lattice cs ] + +-- | Perform a reversible column operation on two integer vectors, +-- creating (and then dropping) a leading zero in the second vector. +column_op :: [Integer] -> [Integer] -> ([Integer], [Integer]) +column_op (m:ms) (n:ns) = (m':ms', ns') where + (x, y, z, w, d) = ext_euclid m n + m' = x*m + y*n -- m' == d by extended Euclid's algorithm + n' = z*m + w*n -- n' == 0 by extended Euclid's algorithm + ms' = (x `scalar_mult` ms) `vector_add` (y `scalar_mult` ns) + ns' = (z `scalar_mult` ms) `vector_add` (w `scalar_mult` ns) +column_op _ _ = error "is_in_lattice: dimension mismatch" + diff --git a/Quipper/Algorithms/USV/Main.hs b/Quipper/Algorithms/USV/Main.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/USV/Main.hs @@ -0,0 +1,301 @@ +-- | +-- Author: Neil Julien Ross +-- +-- An implementation of the Unique Shortest Vector (USV) +-- algorithm. The input to the Unique Shortest Vector +-- problem is an /n/×/n/ integer matrix /B/ with +-- the property that the lattice /L(B)/ spanned by /B/ +-- contains a unique vector /u/ such that that any +-- other non-parallel vector /v/ in the lattice is +-- longer then /u/ by a factor of /n/[sup 3]. The +-- output is the vector /u/. +-- +-- The algorithm proceeds in two steps: first it uses +-- Regev’s method to reduce the USV to the Two +-- Point problem (TPP) and then to the Dihedral +-- Coset problem (DCP), second it uses Kuperberg’s +-- algorithm to solve the DCP. The first step +-- transforms the input matrix into a set of coset +-- states by partitioning the space into hypercubes +-- containing at most two lattice points, and then +-- collapsing the space onto one such cube. The second +-- step uses a sieving method on the obtained set of +-- coset states to extract the shortest vector. +-- +-- These algorithms are described in: +-- +-- * G. Kuperberg, \"A subexponential-time quantum +-- algorithm for the dihedral hidden subgroup problem.\" +-- /SIAM J. Comput./ 35(1):170-188,2005. +-- +-- * O. Regev, \"Quantum computation and lattice problems.\" +-- In Danielle C. Martin, editor, +-- /Proceedings of the 43rd IEEE Symposium on Foundations of Computer Science/, +-- pp. 520-529, Nov. 16-19, Vancouver, BC, Canada, 2002. IEEE, IEEE +-- Press, Los Alamitos, CA. +-- +-- The present implementation is based on a detailed algorithm +-- specification that was provided to us by the IARPA QCS +-- program and written by Andrew J. Landahl. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.USV.Main": Command line interface. +-- +-- * "Quipper.Algorithms.USV.Definitions": Some general-purpose +-- definitions. +-- +-- * "Quipper.Algorithms.USV.USV": The implementation of the +-- main Unique Shortest Vector algorithm. +-- +-- * "Quipper.Algorithms.USV.Simulate": Functions for testing +-- and debugging certain subroutines. + +module Quipper.Algorithms.USV.Main where + +import Quipper + +import Quipper.Libraries.Arith +import Quipper.Libraries.Decompose + +import Quipper.Algorithms.USV.Definitions +import Quipper.Algorithms.USV.USV +import Quipper.Algorithms.USV.Simulate + +import Quipper.Utils.CommandLine +import Quipper.Utils.Sampling + +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import System.Random +import Control.Monad +import Data.List +import Data.Char + +-- ---------------------------------------------------------------------- +-- * Command line interface + +-- $ This module provides a command line interface for the Unique +-- Shortest Vector algorithm. This allows the user, for example, to +-- show different parts of the circuit, select a gate base, +-- select parameters such as /n/ and /b/, and select different output +-- formats. +-- +-- [Example invocations:] +-- +-- > ./usv +-- +-- Default options: the 'sieving' algorithm with +-- /n/=5 and ASCII output format. Because the 'sieving' +-- algorithm uses the 'dynamic_lift' function, the user +-- will be prompted to provide values corresponding to +-- a hypothetical measurement outcome (0 or 1) . +-- +-- > ./usv -F -f gatecount +-- +-- The gate count for 'f_quantum'. +-- +-- [Options and parameters:] +-- +-- * /b/ is the lattice basis (Default value: a 5×5 +-- matrix with entries set to 1). +-- +-- * /n/ is the dimension of the lattice +-- (Default value: 5). +-- +-- * /s/ is the seed for the random number generator +-- (Default value: 1). +-- +-- [Restrictions:] +-- +-- The 'sieving' algorithm uses the 'dynamic_lift' function. +-- The only output format that currently supports such a +-- functionality is ASCII. All algorithms that call +-- 'sieving' must therefore be run with the default +-- (ASCII) output format. These are: 'sieving', 'dCP', 'tPP', +-- 'algorithm_Q' and 'uSVP'. + +-- ============================================================== + +-- * Option processing + +-- | An enumeration type for determining what the main function +-- should do. +data WhatToShow = + F -- ^Show 'f_quantum'. Depends on input /b/. + | G -- ^Show 'g_quantum'. Depends on input /b/. + | H -- ^Show 'h_quantum'. Depends on input /n/. + | USVP -- ^Run 'uSVP'. Depends on input /b/. + | Q -- ^Run 'algorithm_Q'. Depends on input /b/. + | R -- ^Show 'algorithm_R'. Depends on input /b/. + | TPP -- ^Run 'tPP'. Depends on input /n/. + | Sieve -- ^Run 'sieving'. Depends on input /n/. + | DCP -- ^Run 'dCP'. Depends on input /n/. + | Test -- ^Run Simulation test for 'h_quantum'. Depends on input /n/. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + s :: Int, -- ^Parameter /s/ (seed for random number generator). + n :: Int, -- ^Parameter /n/ (lattice dimension). + b :: [[Integer]], -- ^Parameter /b/ (lattice basis). + what :: WhatToShow, -- ^What kind of thing to output. + format :: Format, -- ^The output format. + gatebase :: GateBase -- ^What kind of gates to decompose into. +} deriving Show + +-- | The default options. +defaultOptions :: Options +defaultOptions = Options + { s = 1, + n = 5, + b = (replicate 5 (replicate 5 1)), + what = Sieve, + format = ASCII, + gatebase = Logical + } + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = + [ +-- Generic options + Option ['h'] ["help"] (NoArg help) "print usage info and exit", + Option ['f'] ["format"] (ReqArg format "") "output format for circuits (default: eps)", + Option ['g'] ["gatebase"] (ReqArg gatebase "") "type of gates to decompose into (default: logical)", +-- Algorithm parameter + Option ['n'] ["n"] (ReqArg nnn "") "parameter n (default: 5)", + Option ['b'] ["b"] (ReqArg bbb "") "parameter b (default: 5X5 with entries = 1)", + Option ['s'] ["s"] (ReqArg sss "") "Random number generator seed s (default: 1)", +-- Algorithm specific options + Option ['F'] [] (NoArg (what F)) "output subroutine f (depends on b).", + Option ['G'] [] (NoArg (what G)) "output subroutine g (depends on b).", + Option ['H'] [] (NoArg (what H)) "output subroutine h (depends on n).", + Option ['U'] [] (NoArg (what USVP)) "output algorithm 1 (depends on b).", + Option ['Q'] [] (NoArg (what Q)) "output algorithm 2 (depends on b).", + Option ['R'] [] (NoArg (what R)) "output algorithm 3 (depends on b).", + Option ['T'] [] (NoArg (what TPP)) "output algorithm 4 (depends on n).", + Option ['S'] [] (NoArg (what Sieve)) "output sieving subroutine (depends on n).", + Option ['D'] [] (NoArg (what DCP)) "output algorithm 5 (depends on n).", +-- Testing options + Option ['t'] [] (NoArg (what Test)) "test subroutine h (depends on n)." + ] + where + help :: Options -> IO Options + help o = do + usage + exitSuccess + + format :: String -> Options -> IO Options + format str o = do + case match_enum format_enum str of + [(_, f)] -> return o { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + gatebase :: String -> Options -> IO Options + gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + nnn :: String -> Options -> IO Options + nnn string o = + case parse_int string of + Just n | n >= 1 -> return o { n = n } + _ -> optfail ("Invalid value for parameter n -- " ++ string ++ "\n") + + bbb :: String -> Options -> IO Options + bbb string o = + case parse_list_basis string of + Just b -> if (all is_zero_vector b) + then optfail ("0 is an invalid value for parameter b " ++ "\n") + else return o { b = b } + _ -> optfail ("Invalid value for parameter b -- " ++ string ++ "\n") + + sss :: String -> Options -> IO Options + sss string o = + case parse_int string of + Just s -> return o { s = s } + _ -> optfail ("Invalid value for parameter s -- " ++ string ++ "\n") + + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to 'stdout'. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + where header = "Usage: usv [OPTION...]" + +-- | Parse a string to a list of integers, or return 'Nothing' on failure. +parse_list_basis :: String -> Maybe [[Integer]] +parse_list_basis s = case reads s of + [(ns, "")] -> Just ns + _ -> Nothing + +-- ============================================================== +-- * Main function + +-- | The main function for the Unique Shortest Vector problem: read +-- options, then execute the appropriate task. +main :: IO() +main = do + argv <- getArgs + options <- dopts argv + case options of + + Options { what = what, format = format, gatebase = gatebase, n = n, b = b, s = s} -> + case what of + F -> print_generic format (decompose_generic gatebase (f_quantum b p m i0)) twopoint_from_b + G -> print_generic format (decompose_generic gatebase (g_quantum (toInteger n) ws)) vector_from_b + H -> print_generic format (decompose_generic gatebase h_quantum) vector_from_n + USVP -> print_generic format (decompose_generic gatebase (uSVP b)) + Q -> print_generic format (decompose_generic gatebase (algorithm_Q b (l, m, i0, p) randomgen)) + R -> print_generic format (decompose_generic gatebase (algorithm_R b l m i0 p randomgen)) + TPP -> print_generic format (decompose_generic gatebase (tPP n)) (replicate (4*n^2+n) twopoint_from_n) + Sieve -> print_generic format (decompose_generic gatebase (\l -> sieving n 2 (zip l [0..]))) (replicate (2^n-1) qubit) + DCP -> print_generic format (decompose_generic gatebase (dCP n 0 0)) (replicate (8^n) cosetstate) + Test -> h_test n + + where + randomgen = mkStdGen s + -- To reduce the number of inputs to be provided by the user, + -- inputs other than n and b are derived. + -- + -- Some inputs are therefore hardwired to arbitrary values. + -- Moreover, some subroutines are parameterized by b while + -- others are parameterized by n. Subroutines H, TPP, Sieve, Test + -- and DCP depend on n. The remaining subroutines depend on b. + -- + -- Inputs derived from b: + -- + n_from_b = length b + l = ceiling $ norm $ head b + p = find_prime ((n_from_b)^3) + m = p-1 -- In fact, m ranges from 1 to (p-1). + i0 = 0 -- In fact, i_0 ranges from 0 to (n-1). + max_b = maximum (map maximum b) + s = ceiling (logBase 2 (fromIntegral max_b)) + 5*n + twopoint_from_b = (qubit, (replicate n_from_b (qdint_shape (4*n_from_b)))) + vector_from_b = (replicate n_from_b (qdint_shape s)) + -- + -- Inputs derived from n: + -- + vector_from_n = (replicate n (qdint_shape (4*n))) + twopoint_from_n = (qubit, vector_from_n) + cosetstate = (qubit, (qdint_shape n)) + ws = take n $ sample_random0 randomgen 1 diff --git a/Quipper/Algorithms/USV/Simulate.hs b/Quipper/Algorithms/USV/Simulate.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/USV/Simulate.hs @@ -0,0 +1,48 @@ +-- | This module contains functions for simulating and +-- debugging the USV algorithm and some of its subroutines. + +module Quipper.Algorithms.USV.Simulate where + +import Quipper + +import Quipper.Libraries.Arith +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.USV.USV +import Quipper.Algorithms.USV.Definitions + +import Quipper.Utils.Sampling + +-- $ For the coherent arithmetic subroutines defined +-- in "Quipper.Algorithms.USV.USV", compare the classical +-- implementation (implemented using Haskell +-- functions) and the quantum one (simulated). + + +-- ===================================================================================== +-- * Testing for subroutine /h/ + +-- | Given an integer /n/, print the table comparing the output values +-- of the functions 'h_classical' and 'h_quantum' on every possible +-- vector in (ℤ[sub 2[sup 4/n/]])[sup /n/]. +h_test :: Int -> IO () +h_test n = do + +-- Compute a table containing: +-- Intput | Output of h_classical | Output of (simulated) h_quantum + let h_table_n = [ "h table for n = " ++ (show n) ++ ":" + , "" + , "v h(v)_C h(v)_Q "] + ++ + [ (show (map integer_of_intm_unsigned w)) ++ " " ++ (show y) ++ " " ++ (show z) ++ flag + | w <- (sample_all0 (replicate n (intm (4*n) (2^(4*n)-1)))) + , let y = integer_of_intm_unsigned $ h_classical w + , let z = integer_of_intm_unsigned $ (run_classical_generic h_quantum) w + , let flag = if y /= z then " **MISMATCH**" else ""] + ++ + ["",""] + +--Print the table + mapM putStrLn $ h_table_n + return () + diff --git a/Quipper/Algorithms/USV/USV.hs b/Quipper/Algorithms/USV/USV.hs new file mode 100644 --- /dev/null +++ b/Quipper/Algorithms/USV/USV.hs @@ -0,0 +1,499 @@ +-- | This module provides an implementation of the +-- main Unique Shortest Vector algorithm. + +module Quipper.Algorithms.USV.USV where + +import Quipper +import Quipper.Libraries.QFT +import Quipper.Libraries.Arith +import Quipper.Utils.Sampling + +import Quipper.Algorithms.USV.Definitions + +import Control.Monad (foldM, zipWithM, replicateM) +import Data.Maybe +import System.Random +import Text.Printf + +import Quipper.Utils.Auxiliary + + +-- ============================================================== +-- * Coherent arithmetic + +-- $ Some arithmetic functions used in the reductions of the /USV/ to +-- the /TPP/ and of the /TPP/ to the /DCP/. + +-- | Compute the function /f/, that selects a subset +-- of lattice points. It is defined as: +-- +-- \[image def_f.png] +-- +-- The arguments are: +-- +-- * /bb_bar/, an /n/-dimensional matrix; +-- +-- * /p/, a prime such that /n/ ≤ /p/ ≤ 2/n/; +-- +-- * /m/, an integer such that /1/ ≤ /m/ ≤ /p-1/; +-- +-- * /i0/, an integer index such that /0/ ≤ /i0/ ≤ /n-1/; +-- +-- * /t/, an integer (either /0/ or /1/); +-- +-- * /a/=(/a/[sub 1],...,/a/[sub /n/]), an integer vector. +f_classical :: [[Integer]] -> Int -> Int -> Int -> (Int,[Int]) -> [Integer] +f_classical bb p m i0 (t,a) = matrix_mult bb a' + where + a' = map toInteger $ applyAt i0 (\x -> x*p + t*m) a + +-- | Quantum version of 'f_classical'. +f_quantum :: [[Integer]] -> Int -> Int -> Int -> TwoPoint -> Circ [QDInt] +f_quantum bb p m i0 = box "f" $ \(t,a) -> do + comment_with_label "ENTER: f_quantum" (t,a) ("t","a") + let n = (length . head) bb + b = maximum (map maximum bb) + s = ceiling (logBase 2 (fromIntegral b)) + 5*n + + qp <- qinit (intm s (toInteger p)) + qm <- qinit (intm s (toInteger m)) + qbb <- qinit (map (\vs -> (map (\v -> (intm s v)) vs)) bb) + a <- mapM (\x -> qdint_extend_signed s x) a + + let ai0 = a !! i0 + (_,_,x) <- q_mult ai0 qp + q_add_in_place x qm `controlled` t + let a' = overwriteAt i0 x a + + result <- q_matrix_mult qbb a' + comment_with_label "EXIT: f_quantum" (qp,qm,qbb,t,a) ("qp","qm","qbb","t","a") + return result + + +-- | Compute the function /g/ defined as: +-- +-- \[image def_g1.png] +-- +-- The arguments are: +-- +-- * /l/, an integer (in principle, a real number, but the +-- GFI only uses integer values); +-- +-- * /w/, a real number in the interval [0,1); +-- +-- * /v/, an integer. +-- +-- We note that in the quantum version of this function, /l/ +-- and /w/ will be parameters, and /v/ will be a quantum +-- input. We implement this operation using only integer +-- division, using the following property: for all integers +-- /v/, /m/ and real numbers /w/, +-- +-- \[image floor2.png] +g1_classical :: Integer -> Double -> Integer -> Integer +g1_classical l w v = + let m = 128 * l + c = ceiling (fromIntegral m * w) + in + (v - c) `div` m + +-- | Compute the function /g/. The function /g/ +-- partitions the space into hypercubes of size +-- 128/l/ at a random offset /w/. It is defined as: +-- +-- \[image def_g.png] +-- +-- This is just the componentwise application of 'g1_classical'. +g_classical :: Integer -> [Double] -> [Integer] -> [Integer] +g_classical l w v = zipWith (g1_classical l) w v + +-- | Quantum version of 'g1_classical'. +g1_quantum :: Integer -> Double -> QDInt -> Circ QDInt +g1_quantum l w = box "g_1" $ \v -> do + comment_with_label "ENTER: g1_quantum" v "v" + let m = fromIntegral (128 * l) + c = ceiling (fromIntegral m * w) + l' = qdint_length v + c' <- qinit (intm l' c) + (_, _, n) <- q_sub v c' + m' <- qinit (intm l' m) + (_, _, q) <- q_div n m' + comment_with_label "EXIT: g1_quantum" (v,c',m',n,q) ("v","c'","m'","n","q") + return q + +-- | Quantum version of 'g_classical'. +g_quantum :: Integer -> [Double] -> [QDInt] -> Circ [QDInt] +g_quantum l w = box "g" $ \v -> do + zipWithM (g1_quantum l) w v + + +-- | Compute the function /h/, defined as: +-- +-- \[image def_h.png] +-- +-- The function /h/ transforms a vector /a/=(/a/[sub 1],...,/a/[sub n]) +-- of 4/n/-bit integers into a 4/n/[super 2]+/n/-bit integer by +-- inserting a 0 between each component of /a/. +h_classical :: [IntM] -> IntM +h_classical v = (intm (4*n^2+n) w) + where + n = length v + m = 4*n + 1 + mm = 2^m + v' = map integer_of_intm_unsigned v + w = foldl (+) 0 $ zipWith (*) v' [mm^k | k <- [0..(n-1)]] + +-- | Quantum version of 'h_classical'. +h_quantum :: [QDInt] -> Circ QDInt +h_quantum a = do + comment_with_label "ENTER: h_quantum" a "a" + a <- mapM (extend . qulist_of_qdint_bh) (reverse a) + comment_with_label "EXIT: h_quantum" a "a" + return (qdint_of_qulist_bh (concat a)) + where + -- | Prepend a qubit in state |0> to a list of qubits. + extend :: [Qubit] -> Circ [Qubit] + extend x = do + z <- qinit False + return (z : x) + + +-- ============================================================== +-- * Algorithm 1: \"uSVP\" + +-- | Find the shortest vector. The argument, /bb/, is an +-- /n/-dimensional integer matrix. The algorithm first uses +-- /bb/ to generate a list of parameter tuples and then +-- recursively goes through this list by calling 'algorithm_Q' +-- on each tuple until it either finds the shortest vector +-- or exhausts the list and fails by returning 0. +-- +-- Remark: +-- +-- * Argument /n/ is redundant, it can be inferred from /bb/. +uSVP :: [[Integer]] -> Circ [Integer] +uSVP bb = do + + ----------------------------------------------------------------- + -- Prepare the list of parameter values, + -- and a random number generator. + ----------------------------------------------------------------- + comment "ENTER: algorithm_uSVP" + let n = length bb + randomgen = mkStdGen n + p = find_prime (n^3) + bb_bar = (lll . reduce_lattice) bb + b1 = head bb_bar + l1 = norm b1 + k = ceiling $ fromIntegral $ (n - 1) `div` 2 + ls = [ceiling (l1 / (2^s)) | s <- [0..k] ] + parameters = [(l, m, i0, p) | l <- ls, + m <- [1..(p-1)], + i0 <- [0..(n-1)]] + + ----------------------------------------------------------------- + -- Conditional recursion over the list of parameters + -- using the function 'usvp_aux'. + ----------------------------------------------------------------- + v <- usvp_aux n bb_bar parameters randomgen + comment "EXIT: algorithm_uSVP" + return v + +----------------------------------------------------------------- +-- | For each tuple of parameters, call 'algorithm_Q' and +-- then test whether the returned vector is the shortest vector +-- in the lattice. If it is, return it. If not, move on to +-- the next tuple. If the end of the list is reached, return 0. +-- +-- Remark: +-- +-- * The algorithm takes as additional argument a random number +-- generator. At each iteration, a new seed is extracted and used +-- by the next iteration's generator. +----------------------------------------------------------------- +usvp_aux :: Int -> [[Integer]] -> [(Int, Int, Int, Int)] -> StdGen -> Circ [Integer] +usvp_aux n b [] randomgen = return (replicate n 0) +usvp_aux n b (h:t) randomgen = do + let (g1,g2) = split randomgen + u <- algorithm_Q b h g1 + if (is_in_lattice u b) then return u + else usvp_aux n b t g2 + + +-- ============================================================== +-- * Algorithm 2: \"Q\" + +-- | Compute 'algorithm_Q'. The arguments are: +-- +-- * /bb_bar/, an /n/-dimensional LLL-reduced basis; +-- +-- * (/l/,/m/,/i0/,/p/), a 4-tuple of integer parameters; +-- +-- * /randomgen/, a random number generator. +-- +-- The algorithm first calls algorithm 'algorithm_R' to prepare +-- a list of 'TwoPoint's parameterized on (/l/,/m/,/i0/,/p/) and +-- then calls 'tPP' on this list. With high probability, the +-- returned vector is the shortest vector in the lattice up to +-- one component. +-- +-- Remark: +-- +-- * Argument /n/ is redundant, it can be inferred +-- from /bb_bar/. +algorithm_Q :: [[Integer]] -> (Int, Int, Int, Int) -> StdGen -> Circ [Integer] +algorithm_Q bb_bar (l, m, i0, p) randomgen = do + ----------------------------------------------------------------- + -- Extract (4*n^2+n) random number generators + ----------------------------------------------------------------- + comment "ENTER: algorithm_Q" + let n = length bb_bar + generators = take (4*n^2+n) $ multi_split randomgen + + ----------------------------------------------------------------- + -- Call algorithm 'r' to prepare a list of 'TwoPoint's + -- using the given parameters and a random number generator. + ----------------------------------------------------------------- + states <- sequence [algorithm_R bb_bar l m i0 p g | g <- generators] + + ----------------------------------------------------------------- + -- Run tpp to get the shortest vector up to i0-th component. + ----------------------------------------------------------------- + u <- tPP n states + + ----------------------------------------------------------------- + -- Adjust i0-th component and return the vector. + ----------------------------------------------------------------- + comment "EXIT: algorithm_Q" + return $ applyAt i0 (\x -> x*(toInteger p) + (toInteger m)) u + + +-- ============================================================== +-- * Algorithm 3: \"R\" + +-- | Compute 'algorithm_R'. The arguments are: +-- +-- * /bb_bar/, an /n/-dimensional LLL-reduced basis, +-- +-- * /l/, an integer approximation of the length of the +-- shortest vector, +-- +-- * /p/, a prime such that /n/ ≤ /n/ ≤ 2/n/, +-- +-- * /m/, an integer such that /1/ ≤ /m/ ≤ /p-1/, +-- +-- * /i0/, an integer index such that /0/ ≤ /i0/ ≤ /n-1/ and +-- +-- * /randomgen/, a random number generator. +-- +-- The algorithm first calls the functions 'f_quantum' and +-- 'g_quantum' to prepare a superposition of hypercubes +-- containing at most two lattice points, whose difference +-- is the shortest vector. It then measures the output to +-- collapses the state to a 'TwoPoint'. +algorithm_R :: [[Integer]] -> Int -> Int -> Int -> Int -> StdGen -> Circ TwoPoint +algorithm_R bb_bar l m i0 p randomgen = do + comment "ENTER: algorithm_R" + let n = length bb_bar + b = maximum (map maximum bb_bar) + s = ceiling (logBase 2 (fromIntegral b)) + 5*n + ws = take n $ sample_random randomgen 0 1 + + ----------------------------------------------------------------- + -- Use functions 'f_quantum' and 'g_quantum' to partition + -- the space into hypercubes containing two points whose + -- difference is the shortest vector. + ----------------------------------------------------------------- + t <- qinit False + a <- qinit $ replicate n (intm (4*n) 0) + r <- qinit $ replicate n (intm s 0) + (t,a) <- map_hadamard (t,a) + + ((t,a),r) <- classical_to_reversible (\(t,a) -> do + result <- f_quantum bb_bar p m i0 (t,a) + result <- g_quantum (toInteger l) ws r + return result) ((t,a),r) + + ----------------------------------------------------------------- + -- Collapse the space onto one such cube to create a 'TwoPoint'. + ----------------------------------------------------------------- + r_measured <- measure r + cdiscard r_measured + + comment "EXIT: algorithm_R" + return (t,a) + + +-- ============================================================== +-- * Algorithm 4: \"TPP\" + +-- | Perform Regev's reduction of the /TPP/ to the /DCP/ and then +-- call 'dCP'. The arguments are: +-- +-- * /n/, an integer and +-- +-- * /states/, a list of 'TwoPoint's. +-- +-- The algorithm transforms the 'TwoPoint's in /states/ into +-- 'CosetState's using the function 'h_quantum', then calls +-- 'dCP' on this modified list to find the shortest vector. +tPP :: Int -> [TwoPoint] -> Circ [Integer] +tPP n states = do + comment_with_label "ENTER: algorithm_TPP" states "states" + let m = 2^(4*n) + ms = foldl (+) 0 [m*(2*m)^k | k <- [0..(n-1)]] + + ----------------------------------------------------------------- + -- Use the function h to transform 'TPP' inputs (i.e. 'TwoPoint's) + -- into 'DCP' inputs (i.e. 'CosetState's). + ----------------------------------------------------------------- + states <- mapM (\(t,a) -> do + a <- h_quantum a + return (t,a)) states + + ----------------------------------------------------------------- + -- Call 'DCP' to find the difference between. + ----------------------------------------------------------------- + d <- dCP n 0 0 states + + ----------------------------------------------------------------- + -- Convert the integer output of 'dcp' back to a vector. + ----------------------------------------------------------------- + comment "EXIT: algorithm_TPP" + return $ map (\x -> x-m) $ expand (d + ms) (2*m) + + +-- ============================================================== +-- * Algorithm 5: \"DCP\" + +-- | Given integers /m/ and /n/ and a 'Psi_k' /(q,k)/ +-- compute the last /n/ bits of the binary expansion +-- of /k/ on /m/ bits. +n_low_bits :: Int -> Int -> Psi_k -> [Bool] +n_low_bits m n p = take n $ boollist_of_int_lh m (toInteger(snd p)) + +-- | Given integers /m/ and /n/ and a list /l/ of 'Psi_k's, group the +-- elements of /l/ into pairs /(psi_p, psi_q)/ where +-- /p/ and /q/ share /n/ low bits. Return the list of all such +-- pairs together with the list of unpaired elements of /l/. +pairing :: Int -> Int -> [Psi_k] -> ([(Psi_k, Psi_k)], [Psi_k]) +pairing m n l = find_partners (\p -> n_low_bits m n p) l + +-- | Perform Kuperberg's sieve. The arguments are: +-- +-- * /n/, an integer, +-- +-- * /m/, an integer and +-- +-- * /l/, a list of 'Psi_k's. +-- +-- The algorithm recursively combines and sieves the +-- elements of /l/ until it reaches a list whose +-- elements have /m/[sup 2] trailing zeros. +-- At each step, the list of remaining 'Psi_k's are +-- paired and each pair +-- ((/q/[sub 1], /k/[sub 1]), (/q/[sub 2], /k/[sub 2])) +-- is combined into a new 'Psi_k' /(q, k)/ with +-- /k/= /k/[sub 1] ± /k/[sub 2]. +-- If /k/= /k/[sub 1] - /k/[sub 2], the 'Psi_k' is preserved, +-- otherwise it is discarded. +-- +-- Remark: +-- +-- * Uses 'dynamic_lift' to determine whether +-- to keep a discard a 'Psi_k'. +sieving :: Int -> Int -> [Psi_k] -> Circ [Psi_k] +sieving n m l = do + comment "ENTER: sieving" + l <- loop_with_indexM m l (\j l -> do + -- Pair the states sharing m+m*j low bits. + comment "ENTER: Pairing" + let mmj = m + m*j + (pairs, unpaired) = pairing n mmj l + -- Discard the states that haven't been paired. + qdiscard_psi_ks unpaired + comment "EXIT: Pairing" + -- Combine pairs (Psi_k, Psi_l) to get Psi_k±l. + -- If the measurement outcome ('sign') is 0, then the + -- associated state is of the form Psi_k-l. + combined_states <- mapM (\((q,k),(q',l)) -> do + comment "ENTER: Combining" + q <- qnot q `controlled` q' + q <- measure q + sign <- dynamic_lift q + comment "EXIT: Combining" + return (sign, (q', (k-l)))) pairs + -- Separate the states according to the value of 'sign'. + -- Discard the states of the form Psi_k+l and + -- return the ones of the form Psi_k-l. + let (plus, minus) = separate combined_states fst + qdiscard_psi_ks $ map snd plus + return $ map snd minus) + comment "EXIT: sieving" + return l + +-- | Perform Kuperberg's algorithm solving the Dihedral +-- Coset problem. The arguments are: +-- +-- * /n/, an integer measuring the length of the output, +-- +-- * /d/, an integer to hold the output initially set to 0, +-- +-- * /s/, an integer counter initially set to 0 and +-- +-- * /states/, a list of 'CosetState's. +-- +-- The algorithm proceeds recursively. At each iteration it +-- uses Kuperberg's sieve on the first /n/ elements of /states/ +-- to compute the /s/-th bit of the output and updates /d/ with +-- the result. Then it increments /s/ and repeats until /states/ is +-- exhausted. +-- +-- Remark: +-- +-- * The function 'dynamic_lift' used in this algorithm is presumably +-- very expensive in terms of resources. In this implementation +-- it is used profusely but there is room for optimization. +dCP :: Int -> Integer -> Int -> [CosetState] -> Circ Integer +dCP n d s states = if s == n then return d else do + comment (printf "ENTER algorithm_DCP: n=%d d=%d s=%d" n d s) + let nn = 2^n + r = exp $ -( 2*pi*(fromIntegral d / fromIntegral(nn)) ) + m = ceiling $ sqrt $ fromIntegral $ n-s-1 + (l1, l2) = splitAt n states + + ----------------------------------------------------------------- + -- Transform the first n coset states + -- into states of the form Psi_k. + ----------------------------------------------------------------- + comment "ENTER: TO_Psi_k" + l <- mapM (\(t,a) -> do + a <- qft_int a + ca <- measure a + k <- mmap fromIntegral $ dynamic_lift ca + t <- named_rotation "R" (r*(fromIntegral k)) t + return (t, k)) l1 + comment "EXIT: To_Psi_k" + + ----------------------------------------------------------------- + -- Sieve the Psi_k's to get Psi_2^{n-s-1}. + ----------------------------------------------------------------- + l <- sieving n m l + ----------------------------------------------------------------- + -- Extract the s-th bit of d by finding in l a state of the + -- form Psi_2^{n-s-1} and measuring it in the +/- basis. The + -- remaining states in l are discarded. + ----------------------------------------------------------------- + let ((q,k),psis) = find l (\x -> ((snd x) == 2^(n-s-1))) "The sieving process failed to produce a state of the form 2^k." + --let ((q,k),psis) = ((head l),(tail l)) + q <- map_hadamard q + q <- measure q + q <- dynamic_lift q + qdiscard_psi_ks psis + let d_lsb = int_of_boollist_unsigned_bh [q] + + ----------------------------------------------------------------- + -- Update d_low and iterate on the remaining list. + ----------------------------------------------------------------- + comment "EXIT: algorithm_DCP" + dCP n (d + (2^s)*d_lsb) (s+1) l2 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,254 @@ +Running the included algorithms +=============================== + +Each algorithm builds an executable file, which can be run with +various command line parameters to do different things. Run each +command with option --help to see a summary of the usage information. + +In the following, we describe the set of options for the algorithms +that were implemented. + + +Running the bwt program +======================= + +Usage for Binary Welded Tree algorithm: +--------------------------------------- + +Usage: bwt [OPTION...] + -h --help print usage info and exit + -C --circuit output the whole circuit (default) + -O --oracle output only the oracle + -K --oraclec output the "classical" oracle as a classical circuit + -G --graph print colored graph computed from oracle + -S --simulate run simulations of some circuit fragments for tree height n + -f --format= output format for circuits (default: preview) + -g --gatebase= type of gates to decompose into (default: logical) + -o select oracle to use (default: orthodox) + -n --height= set tree height (positive; default 5) + -c --color= color to use with --oracle (0..3, default 0) + -s --repeats= set parameter s (iteration count; default 1) + -l --large set large problem size: n=300, s=336960 + -t
--dt=
set parameter dt (simulation time step; default pi/180) +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. +Possible values for oracle are: orthodox, simple, blackbox, classical, template, optimized. + +Examples of command line options: +--------------------------------- + +* Show the complete circuit for the BWT algorithm using the + "orthodox" (official GFI) oracle, with n=5 and s=1: + + ./bwt -C -o orthodox -n 5 -s 1 + + (One can point out the different parts of the algorithm: 8 oracle + calls, and 4 very short diffusion steps). + +* Show the same, using the "Template Haskell" oracle: this oracle is + much larger, but automatically generated from classical code (and + completely unoptimized): + + ./bwt -C -o template -n 5 -s 1 + + The "template oracle" is defined in BWT/Template.hs. See the + documentation of the module Quipper/CircLifting for how it works. + +* Show the graph of the BWT algorithm, which is obtained by + simulating the orthodox oracle (and therefore offers some evidence + for the correctness of the oracle implementation): + + ./bwt -G -o orthodox -n 5 + +* Show the orthodox oracle for n=300. Note that this will result in a + big file. One has to zoom in substantially to see gates. + + ./bwt -O -o orthodox -n 300 + +* Show the complete circuit for the BWT algorithm, but decompose + everything into binary gates: + + ./bwt -C -o orthodox -n 5 -s 1 -g binary + +* Show the oracle from Figure 1a (alternate oracle). + + ./bwt -C -o figure1a + +* The same, decomposed into binary+Toffoli gates, or binary gates + only, respectively: + + ./bwt -C -o figure1a -g toffoli + ./bwt -C -o figure1a -g binary + +* Show gate counts for BWT algorithm with n=300 and s=1, using + "orthodox" oracle: + + ./bwt -C -o orthodox -n 300 -s 1 -f gatecount + +* Show gate counts for same, after decomposition to binary gates: + + ./bwt -C -o orthodox -n 300 -s 1 -f gatecount -g binary + +Obviously, most other combinations of command line options are also +possible, for example: decompose to toffoli gates and then simulate +and show the graph. Some other combinations are not legal: for +example, decomposing to binary gates and then simulating. (The +classical simulator will complain that the circuit is not boolean; it +contains "V" gates). + +* Similarly, one can run demos for the triangle finding + algorithm using various command line options. + +Note that the triangle finding algorithm is not a deliverable; it is a +work in progress. The only implemented algorithm that is officially a +deliverable is the "orthodox" BWT implementation in BWT.BWT. + +Running the bf program +====================== + +Usage for the Boolean Formula algorithm: +---------------------------------------- + +Usage: bf [OPTION...] + -C --circuit output the whole circuit (default) + -D --demo run a demo of the circuit + -H --hexboard output a representation of the initial state of the given oracle, i.e. the game played so far + -p --part= which part of the circuit to use (default: whole) + -o --oracle= which oracle to use (default: small) + -m --moves= which moves have already been made (default: []) + -f --format= output format for circuits (default: _preview) + -d --dummy set to only use a dummy HEX gate instead of the full hex circuit + -h --help print usage info and exit + -g --gatebase= type of gates to decompose the output circuit into (default: logical) +Possible values for part are: whole, u, oracle, hex, checkwin_red, diffuse, walk, undo_oracle. +Possible values for oracle are: 9by7, small, custom x y t. +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. + +Running the cl program +====================== + +Usage for the Class Number algorithm: +------------------------------------- + +Usage: cl [OPTION...] + -h --help print usage info and exit + -f --format= output format for circuits (default: ASCII) + -g --gatebase= gates to decompose into (default: Logical) + -1 output the circuit for stage 1 of the algorithm (default) + -4 output the circuit for stage 4 of the algorithm + -S --sub= output the circuit for a specific subroutine + -R --regulator classically, find the regulator, given Δ + -F classically, find the fundamental unit, given Δ + -P classically, find the fundamental solution of Pell’s equation, given Δ + -d --delta= discriminant Δ (a.k.a. D) (default: 28) + -s --ss= estimated bound on period S, for stage 1 (default: 2) + -i estimated bound on log_2 S, for stage 1 (default: 1) + -r --rr= approximate regulator R, for stage 4 (default: 12.345) + -q The parameter q, for stage 4 (default: 4) + -k The parameter k, for stage 4 (default: 3) + -n The parameter n, for stage 4 (default: 3) + -m The parameter m, for stage 4 (default: 5) + --seed= Random seed (0 for seed from time)(default: 1) +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. +Possible values for subroutine are: rho, rhoinv, normalize, dotprod, starprod, fn. + +Running the gse program +======================= + +Usage for Ground State Estimation algorithm: +-------------------------------------------- + +Usage: gse [OPTION...] + -h --help print usage info and exit + -C --circuit output the whole circuit (default) + -T --template= output a particular circuit template + -f --format= output format for circuits (default: Preview) + -g --gatebase= gates to decompose into (default: Logical) + -m --orbitals= number of orbitals (default: 4) + -o --occupied= number of occupied orbitals (default: 2) + -b --precision= number of precision qubits (default: 3) + -D --delta_e= energy range (default: 6.5536) + -E --e_max= maximum energy (default: -3876.941) + --n0= use N_k = n0 * 2^k (default: N_k = 1) + -l --large set large problem size (m=208, o=84, b=12, n0=100) + -x --orthodox use the Coulomb operator of Whitman et al. + --h1= filename for one-electron data (default: "h_1e_ascii") + --h2= filename for two-electron data (default: "h_2e_ascii") + -d --datadir= directory for one- and two-electron data (default: current) +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. +Indices can be specified as p,q or p,q,r,s (with no spaces) + +Running the qls program +======================= + +Usage for Quantum Linear Systems algorithm: +------------------------------------------- + +Usage: qls [OPTION...] + -h --help print usage info and exit + -C --circuit output the whole circuit (default) + -O --oracle= output only the oracle (default: r) + -f --format= output format for circuits (default: gatecount) + -g --gatebase= type of gates to decompose into (default: logical) + -o select oracle implementation to use (default: blackbox) + -p --param= choose a set of parameters (default: dummy). + -P --peel= peel layers of boxed subroutines (default: 0). +Possible values for format are: ascii, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. +Possible values for oracle implementation are: matlab, blackbox. +Possible values for param are: dummy, small, large. +Possible values for oracle are: r, b, A[band][t|f]. E.g. "-OA1t" asks for band 1 with boolean argument True. For all three oracles, the factors are set up to 1.0. + +Running the tf program +====================== + +Usage for Triangle Finding algorithm: +------------------------------------- + +Usage: tf [OPTION...] + -h --help print usage info and exit + -f --format= output format for circuits (default: preview) + -g --gatebase= type of gates to decompose into (default: logical) + -l --l= parameter l (default: 4) + -n --n= parameter n (default: 3) + -r --r= parameter r (default: 2) + -C --QWTFP output the whole circuit (default) + -O --oracle output only the oracle + -s --subroutine= output the chosen subroutine (default: adder) + -Q use alternative qRAM implementation + -o select oracle to use (default: blackbox) + -A --arith test/simulate the arithmetic routines + -T --oracletest test/simulate the oracle +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. +Possible values for oracle are: orthodox, blackbox. +Possible values for subroutine are: zero, initialize, hadamard, setup, qwsh, diffuse, fetcht, storet, fetchstoret, fetche, fetchstoree, update, swap, a15, a16, a17, a18, gcqwalk, gcqwstep, convertnode, testequal, pow17, mod3, sub, add, mult. + +Running the usv program +======================= + +Usage for Unique Shortest Vector algorithm: +------------------------------------------- + +Usage: usv [OPTION...] + -h --help print usage info and exit + -f --format= output format for circuits (default: eps) + -g --gatebase= type of gates to decompose into (default: logical) + -n --n= parameter n (default: 5) + -b --b= parameter b (default: 5X5 with entries = 1) + -s --s= Random number generator seed s (default: 1) + -F output subroutine f (depends on b). + -G output subroutine g (depends on b). + -H output subroutine h (depends on n). + -U output algorithm 1 (depends on b). + -Q output algorithm 2 (depends on b). + -R output algorithm 3 (depends on b). + -T output algorithm 4 (depends on n). + -S output sieving subroutine (depends on n). + -D output algorithm 5 (depends on n). + -t test subroutine h (depends on n). +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} + +import Distribution.Simple +import Distribution.Superdoc +import Quipper.Distribution.Preprocessor + +-- The following is needed because of an incompatible change in Cabal 2. +#if MIN_VERSION_Cabal(2,0,0) +wrap x = \_ _ _ -> x +#else +wrap x = \_ _ -> x +#endif + +main = defaultMainWithHooks superdocHooks { + hookedPreProcessors = [("hs", wrap ppQuipper)] + } diff --git a/dist/build/Quipper/Algorithms/BF/BooleanFormula.hs b/dist/build/Quipper/Algorithms/BF/BooleanFormula.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/BF/BooleanFormula.hs @@ -0,0 +1,892 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/BF/BooleanFormula.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This module contains the implementation of the various quantum circuits +-- that make up the boolean formula algorithm. Please see "Quipper.Algorithms.BF.Main" +-- for an overview of the boolean formula algorithm. + +module Quipper.Algorithms.BF.BooleanFormula where + +import Quipper +import Quipper.Internal +import Quipper.Algorithms.BF.Hex +import Quipper.Libraries.QFT +import Quipper.Libraries.QuantumIf +import Quipper.Libraries.Simulation +import Quipper.Libraries.Decompose + +import Quipper.Utils.Auxiliary (mmap) + +import Data.Typeable + +-- ---------------------------------------------------------------------- +-- * Classical data structures + +-- ** Oracle description + +-- $ We define a data structure to hold the various parameters that +-- are used to define an oracle. + +-- | The input to the BF Algorithm is the description of an oracle to +-- represent a given size of hex board, and a given size for the phase +-- estimation register. +data BooleanFormulaOracle = BFO { + oracle_x_max :: Int, -- ^ The /x/-dimension of hex board. + oracle_y_max :: Int, -- ^ The /y/-dimension of hex board. + oracle_t :: Int, -- ^ Size of phase estimation register. + + -- The number of moves remaining can + -- depend on the starting state of the HexBoard + oracle_s :: Int, -- ^ Number of moves remaining. + -- This should start as /x/⋅/y/, if no moves have been made. + oracle_m :: Int, -- ^ Size of the direction register, + -- i.e., size of labels on the BF tree. + -- This should be the ceiling of log(/x/⋅/y/). + + + start_board :: HexBoard, -- ^ A description of the starting state of the + -- board, and can be used to calculate /s/. + oracle_hex :: HexCircuit -- ^ An extra flag that we can use so that different + -- HEX circuits can be used instead of the full circuit. + +} + +-- | A type to define which Hex circuit to use. +data HexCircuit = Hex -- ^ The actual Hex circuit. + | Dummy -- ^ A Dummy Hex circuit. + | EmptyHex -- ^ Nothing. + +-- | Create an oracle description. This only requires /x/, /y/, and +-- /t/ to be specified, as the remaining values can be calculated. The number of +-- moves remaining, /s/, is calculated as the total number of squares on the board, +-- and /m/ is calculated as the number of bits required to represent /s/+1. +createOracle :: Int -> Int -> Int -> BooleanFormulaOracle +createOracle x y t = BFO { + oracle_x_max = x, + oracle_y_max = y, + oracle_t = t, + oracle_s = s, + oracle_m = m, + start_board = (empty,empty), + oracle_hex = Hex +} where s = x * y + m = ceiling (log (fromIntegral (s+1)) / log 2) + empty = replicate s False + +-- | A function to set the \"Dummy\" flag in the given oracle to the given +-- 'HexCircuit' value. +update_hex :: BooleanFormulaOracle -> HexCircuit -> BooleanFormulaOracle +update_hex bfo hex = bfo {oracle_hex = hex} + +-- | Update the 'start_board' in the given oracle, with the given 'HexBoard'. This +-- also updates the 'oracle_s' field of the oracle to be in line with +-- the new 'start_board'. +update_start_board :: BooleanFormulaOracle -> HexBoard -> BooleanFormulaOracle +update_start_board bfo start = bfo { + oracle_s = s, + start_board = start + } where + x = oracle_x_max bfo + y = oracle_y_max bfo + s = (x*y) - (moves_made start) + +-- | An oracle for a 9 by 7 Hex board, with the parameters: +-- /x/=9, /y/=7, /t/=189. The calculated values are: /s/=63, /m/=6. +full_oracle :: BooleanFormulaOracle +full_oracle = createOracle 9 7 189 + +-- | A smaller oracle for testing purposes. The numbers should be +-- chosen such that /x/⋅/y/ = 2[sup /n/]−1 for some /n/. Here, we set +-- /x/=3 and /y/=5, to give /x/⋅/y/=15. We arbitrarily set the size of +-- the phase estimation register to /t/=4. +test_oracle :: BooleanFormulaOracle +test_oracle = createOracle 5 3 4 + +-- ** Hex boards + +-- | A hex board is specified by a pair of lists of booleans. For a +-- board of size /x/ by /y/, each list should contain /x/⋅/y/ +-- elements. The first list is the \"blue\" bitmap, and the second is +-- the \"red\" maskmap. +type HexBoard = ([Bool],[Bool]) + +-- | A function to determine how many moves have been made on a given HexBoard. +-- This function assumes that the given 'HexBoard' is valid, in the sense that +-- no duplicate moves have been made. +moves_made :: HexBoard -> Int +moves_made (blue,red) = moves blue + moves red + where moves color = length (filter id color) + +-- | A function to determine which spaces are still empty in the given HexBoard. +-- This function assumes that the given 'HexBoard' is valid, in the sense that +-- no duplicate moves have been made. This function will return a list of all the +-- empty spaces remaining, in strictly increasing order. +empty_spaces :: HexBoard -> [Int] +empty_spaces (blue,red) = empty_spaces' blue red 0 + where + empty_spaces' [] [] _ = [] + empty_spaces' [] _ _ = error "empty_spaces: Red and Blue boards of different length" + empty_spaces' _ [] _ = error "empty_spaces: Red and Blue boards of different length" + empty_spaces' (b:bs) (r:rs) n = if (b || r) then rest else (n:rest) + where rest = empty_spaces' bs rs (n+1) + +-- ---------------------------------------------------------------------- +-- * Quantum data structures + +-- $ Some data structures to help in defining the algorithm. + +-- | The phase estimation register is a simple register of qubits. This is kept +-- separate from the rest of the 'BooleanFormulaRegister' as it is this register +-- which will be measured at the end of the algorithm. +type PhaseEstimationRegister = [Qubit] + +-- | The direction register is a simple register of qubits, +-- made explicit here so we can see that a \"position\" is a list of directions. +type GenericDirectionRegister a = [a] + +-- | A type synonym defined as the 'Qubit' instance of a +-- 'GenericDirectionRegister'. +type DirectionRegister = GenericDirectionRegister Qubit + +-- | The rest of the boolean formula algorithm requires a register which is +-- split into 3 main parts. +data GenericBooleanFormulaRegister a = BFR { + -- | The position register is split into two parts: + -- the leaf and paraleaf \"flags\". + position_flags :: (a,a), + -- | The current position, and how we got there, i.e., directions we followed. + -- Any position can be reached by at most /x/⋅/y/ directions. + position :: [GenericDirectionRegister a], + work_leaf :: a, + work_paraleaf :: a, + work_binary :: a, + work_height :: a, + work_r :: a, + work_rp :: a, + work_rpp :: a, -- ^ Seven flags that make up the work register. + direction :: GenericDirectionRegister a -- ^ The direction register. +} + deriving (Typeable, Show) + +-- | A type synonym defined as the 'Qubit' instantiation of a +-- 'GenericBooleanFormulaRegister'. +type BooleanFormulaRegister = GenericBooleanFormulaRegister Qubit + +-- | A function to add labels to the wires that make up a 'BooleanFormulaRegister'. +-- These labels correspond to the parts of the register. +labelBFR :: BooleanFormulaRegister -> Circ () +labelBFR reg = do + let tuple = toTuple reg + label tuple (("pos-leaf","pos-paraleaf"), + "pos", + ("leaf","paraleaf","binary","height","r","rp","rpp"), + "dir") + +-- | A type synonym defined as the 'Bool' instantiation of a +-- 'GenericBooleanFormulaRegister'. +type BoolRegister = GenericBooleanFormulaRegister Bool + +-- | Helper function to simplify the 'QCData' instance for 'BooleanFormulaRegister'. +-- Create a tuple from a 'GenericBooleanFormulaRegister'. +toTuple :: GenericBooleanFormulaRegister a -> ((a,a),[[a]],(a,a,a,a,a,a,a),[a]) +toTuple r = (position_flags r,position r,(work_leaf r,work_paraleaf r,work_binary r,work_height r,work_r r,work_rp r,work_rpp r),direction r) + +-- | Helper function to simplify the 'QCData' instance for 'BooleanFormulaRegister'. +-- Create a 'GenericBooleanFormulaRegister' from a tuple. +fromTuple :: ((a,a),[[a]],(a,a,a,a,a,a,a),[a]) -> GenericBooleanFormulaRegister a +fromTuple (pf,p,(wl,wp,wb,wh,wr,wrp,wrpp),d) = BFR { + position_flags = pf, + position = p, + work_leaf = wl, + work_paraleaf = wp, + work_binary = wb, + work_height = wh, + work_r = wr, + work_rp = wrp, + work_rpp = wrpp, + direction = d + } + +type instance QCType x y (GenericBooleanFormulaRegister a) = GenericBooleanFormulaRegister (QCType x y a) +type instance QTypeB (GenericBooleanFormulaRegister a) = GenericBooleanFormulaRegister (QTypeB a) +instance QCData a => QCData (GenericBooleanFormulaRegister a) where + qcdata_mapM s f g xs = mmap fromTuple $ qcdata_mapM (toTuple s) f g (toTuple xs) + qcdata_zip s q c q' c' xs ys e = fromTuple $ qcdata_zip (toTuple s) q c q' c' (toTuple xs) (toTuple ys) e + qcdata_promote a x s = fromTuple $ qcdata_promote (toTuple a) (toTuple x) s +instance (Labelable a String) => Labelable (GenericBooleanFormulaRegister a) String where + label_rec r s = do + label_rec (position_flags r) s `dotted_indexed` "posflag" + label_rec (position r) s `dotted_indexed` "pos" + label_rec (work_leaf r) s `dotted_indexed` "leaf" + label_rec (work_paraleaf r) s `dotted_indexed` "paraleaf" + label_rec (work_binary r) s `dotted_indexed` "binary" + label_rec (work_height r) s `dotted_indexed` "height" + label_rec (work_r r) s `dotted_indexed` "r" + label_rec (work_rp r) s `dotted_indexed` "rp" + label_rec (work_rpp r) s `dotted_indexed` "rpp" + label_rec (direction r) s `dotted_indexed` "dir" + +-- | Create an initial classical 'BooleanFormulaRegister' for a given oracle description. +-- The /position/ register is initialized in the /zero/ state that represents being +-- at label /zero/, or node /rpp/ in the tree. The work qubits are all initialized to +-- /zero/, as the first call to the /oracle/ circuit will set them accordingly for +-- the /position/ we are currently in. The /direction/ register is also set to /zero/ +-- as this is the direction in which the node /rp/ is in. The given +-- 'BooleanFormulaOracle' is used to make sure the registers are of the correct +-- size, i.e., number of qubits. +createRegister :: BooleanFormulaOracle -> BoolRegister +createRegister oracle = BFR { + position_flags = (False,False), + position = replicate s (replicate m False), + work_leaf = False, + work_paraleaf = False, + work_binary = False, + work_height = False, + work_r = False, + work_rp = False, + work_rpp = False, + direction = replicate m False + } where + s = oracle_s oracle + m = oracle_m oracle + +-- | Create a shape parameter for a 'BooleanFormulaRegister' of the +-- correct size. +registerShape :: BooleanFormulaOracle -> BooleanFormulaRegister +registerShape oracle = qshape (createRegister oracle) + +-- | Initialize a 'BooleanFormulaRegister' from a 'BooleanFormulaOracle'. +initializeRegister :: BooleanFormulaOracle -> Circ BooleanFormulaRegister +initializeRegister oracle = qinit (createRegister oracle) + +-- ====================================================================== +-- * Oracle implementation + +-- $ The functions in this implementation follow a separation of the boolean +-- formula algorithm into two parts. The first part corresponds to the +-- algorithms defined in this module. The second part consists of the +-- algorithms defined in "Quipper.Algorithms.BF.Hex". This separation relates to the +-- first part defining the quantum parts of the algorithm, including the +-- phase estimation, and the quantum walk, whereas the remaining four define +-- the classical implementation of the circuit for determining which player +-- has won a completed game of Hex, which is converted to a quantum circuit +-- using Quipper's \"build_circuit\" keyword. +-- +-- Note that the circuits for the algorithms in this module have been tested +-- for performing a quantum walk on the tree defined for a given oracle (but +-- with a dummy function taking the place of the call to HEX). + +-- | The overall Boolean Formula Algorithm. It initializes the +-- phase estimation register into an equal super-position of all 2[sup t] states, +-- and the other registers as defined previously. It then maps the exponentiated +-- version of the unitary /u/, as per phase estimation, before applying the +-- inverse QFT, and measuring the result. +qw_bf :: BooleanFormulaOracle -> Circ [Bit] +qw_bf oracle = do + -- initialize the phase estimation register, + -- and put it in an equal super-position + let t = oracle_t oracle + a <- qinit (replicate t False) + label a "a" + a <- mapUnary hadamard a + -- initialize the other boolean formula registers + b <- initializeRegister oracle + labelBFR b + -- we can use a separate recursive function to map the exp_u algorithm over a + let t = oracle_t oracle + map_exp_u oracle a b (t-1) + -- qft is defined, so we reverse it to get inverse qft + a <- (subroutine_inverse_qft oracle) a + -- we're only interested in the result of measuring a, + -- so we can discard all the qubits in the rest of the register + qdiscard b + measure a + +-- | The inverse quantum Fourier transform as a boxed subroutine. +subroutine_inverse_qft :: BooleanFormulaOracle -> [Qubit] -> Circ [Qubit] +subroutine_inverse_qft o = box "QFT*" (reverse_generic_endo qft_little_endian) + +-- | \"Map\" the application of the exponentiated unitary /u/ +-- over the phase estimation register. That is, each qubit in the phase estimation +-- register is used as a control over a call to the unitary /u/, exponentiated to +-- the appropriate power. +map_exp_u :: BooleanFormulaOracle -> [Qubit] -> BooleanFormulaRegister -> Int -> Circ () +map_exp_u _ [] _ _ = return () +map_exp_u o (a:as) b l = do + let x_max = oracle_x_max o + -- we can move the control out of the exp_u function + exp_u o (2^(l-(length as))) b `controlled` a + map_exp_u o as b l + +-- | Exponentiate the unitary /u/. In this implementation, this is +-- achieved by repeated application of /u/. +exp_u :: BooleanFormulaOracle -> Integer -> BooleanFormulaRegister -> Circ () +exp_u _ 0 _ = return () +exp_u o n_steps b = do + (subroutine_u o) b + exp_u o (n_steps-1) b + +-- | The unitary /u/ represents a single step in the walk on the NAND tree. A call +-- to the oracle determines what type of node we are at (so we know which directions +-- are valid to step to), the call to diffuse sets the direction register to be a +-- super-position of all valid directions, the call to walk performs the step, and then +-- the call to undo oracle has to clean up the work registers that were set by the +-- call to the oracle. Note that the undo oracle step is not simply the inverse of the +-- oracle, as we have walked since the oracle was called. +u :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +u o b = do + comment "U" + labelBFR b + (subroutine_oracle o) b + (subroutine_diffuse o) b + (subroutine_walk o) b + (subroutine_undo_oracle o) b + +-- | The circuit for 'u' as a boxed subroutine. +subroutine_u :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +subroutine_u o = box "U" (u o) + +-- | Call the oracle to determine some extra information about where +-- we are in the tree. Essentially, the special cases are when were are at one of +-- the three \"low height\" nodes, or when we are at a node representing a complete +-- game of Hex, and we need to determine if this is a leaf, by calling the hex circuit, +-- which determines whether the node represents a completed game of hex in which +-- the red player has won. +oracle :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +oracle o register = do + comment "ORACLE" + labelBFR register + let init = start_board o + let x_max = oracle_x_max o + let (is_leaf,is_paraleaf) = position_flags register + with_controls (is_leaf) + ( -- if is_leaf + -- we are at a leaf node, so set "leaf" + do + let leaf = work_leaf register + qnot_at leaf + ) + with_controls (is_leaf .==. False .&&. is_paraleaf .==. True) + ( -- else if is_paraleaf + -- we are at a paraleaf node, so set "paraleaf" + do + let paraleaf = work_paraleaf register + qnot_at paraleaf + let binary = work_binary register + qnot_at binary + let pos = position register + let hex_subroutine = case oracle_hex o of + Hex -> box "HEX" (hex_oracle init (oracle_s o) x_max) + Dummy -> hex_oracle_dummy + EmptyHex -> \x -> return x + -- hex sets "binary" flag depending on whether the paraleaf is attached to a + -- a leaf, i.e., whether red has won or lost the game of hex. + hex_subroutine (pos,binary) + return () + ) + with_controls (is_leaf .==. False .&&. is_paraleaf .==. False) + ( -- else + -- we're not at a leaf node, or paraleaf node + do + let pos = position register + -- are we at a "low height" node? + with_controls (controls is_paraleaf pos) + ( -- we're at a "low height" node + do + let pos'' = pos !! (length pos - 2) + let pos_m = last pos'' + with_controls pos_m + ( -- if pos_m == 1 + do + let height = work_height register + qnot_at height + ) + let pos' = last pos + let pos_1 = pos' !! (length pos' - 2) + with_controls (pos_m .==. False .&&. pos_1 .==. True) + ( -- else if pos_1 == 1 + do + let r = work_r register + qnot_at r + ) + let pos_0 = last pos' + with_controls (pos_m .==. False .&&. pos_1 .==. False .&&. pos_0 .==. True) + ( -- else if pos_0 == 1 + do + let rp = work_rp register + qnot_at rp + let binary = work_binary register + qnot_at binary + ) + with_controls (pos_m .==. False .&&. pos_1 .==. False .&&. pos_0 .==. False) + ( -- else + do + let rpp = work_rpp register + qnot_at rpp + ) + ) + ) + +-- | The circuit for the 'oracle' as a boxed subroutine. +subroutine_oracle :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +subroutine_oracle o = box "Oracle" (oracle o) + +-- | The controls to use, to see if we're at a \"low height\" node. +controls :: Qubit -> [DirectionRegister] -> [ControlList] +controls is_paraleaf pos = (is_paraleaf .==. False) : ctrls pos + where ctrls [] = [] + ctrls [p] = [] + ctrls [p,q] = [] + ctrls (p:ps) = (last p .==. False) : ctrls ps + +-- | Diffuse the direction register, to be a super-position of all valid +-- directions from the current node. Note, that this implementation of the boolean +-- formula algorithm does not applying the correct weighting scheme to the NAND graph, +-- which would require this function to diffuse with respect to the weighting scheme. +diffuse :: BooleanFormulaRegister -> Circ () +diffuse register = do + comment "DIFFUSE" + labelBFR register + let binary = work_binary register + let dir = direction register + with_controls binary + ( -- if binary == 1 + do + let dir_0 = last dir + hadamard_at dir_0 + ) + let leaf = work_leaf register + let rpp = work_rpp register + with_controls (binary .==. False .&&. leaf .==. False .&&. rpp .==. False) + ( -- else (controlled on binary == 0, leaf == 0, rpp == 0) + do + mapUnary hadamard dir + ) + return () + +-- | The circuit for 'diffuse' as a boxed subroutine. +subroutine_diffuse :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +subroutine_diffuse o = box "Diffuse" diffuse + +-- | A datatype to use instead of passing integers to 'toParent' and 'toChild' +-- to define what needs to be shifted. This is used as only three different +-- shift widths are ever used in the algorithm. +data Where = Width -- ^ corresponds to shifting all qubits. + | M -- ^ corresponds to shifting only /m/+1 qubits. + | M2 -- ^ corresponds to shifting only 2/m/+1 qubits. + deriving Eq + +-- | Define a step on the NAND graph, in the direction specified +-- by the direction register, and updates the direction register to be where +-- we have stepped from. +-- For this algorithm we have developed the 'if_then_elseQ' construct, which +-- gives us a nice way of constructing if/else statements acting on +-- boolean statements over qubits (see "Quipper.Libraries.QuantumIf"). +walk :: BooleanFormulaRegister -> Circ () +walk register = do + comment "WALK" + labelBFR register + let leaf = work_leaf register + let paraleaf = work_paraleaf register + let dir = direction register + let dir_0 = last dir + let (is_leaf,is_paraleaf) = position_flags register + let pos = position register + let pos_0 = last (last pos) + let pos_1 = last (init (last pos)) + let height_1 = work_height register + let rpp = work_rpp register + let rp = work_rp register + let r = work_r register + let dir_all_1 = foldr1 (\x y -> And x y) (map A dir) + let boolean_statement_in = Or (A leaf) (And (A paraleaf) (Not (A dir_0))) + let boolean_statement_out = Or (A leaf) (And (A paraleaf) (A is_leaf)) + if_then_elseQinv boolean_statement_in + ( -- if leaf == 1 or (paraleaf == 1 and dir_0 == 0) + do + qnot_at is_leaf + ) + ( -- else (leaf == 0 and (paraleaf == 0 or dir_0 == 1)) + do + let boolean_statement_in = And (A paraleaf) (A dir_0) + let boolean_statement_out = And (A paraleaf) (Not (dir_all_1)) + if_then_elseQinv boolean_statement_in + ( -- if paraleaf == 1 and dir_0 == 1 + toParent Width register + -- now, dir /= 1..1, so dir_0 could be either 0 or 1 + ) + ( -- else (paraleaf == 0 or dir_0 == 0) + do + let boolean_statement_in = Or (A rpp) (And (A rp) (A dir_0)) + let boolean_statement_out = Or (A rpp) (And (A rp) (Not (A dir_0))) + if_then_elseQinv boolean_statement_in + ( -- if rpp == 1 or (rp == 1 and dir_0 == 1 ) + do + qnot_at pos_0 + -- dir_0 should be changed, + -- as we're moving from rp to rpp, and rpp only has a child at 0 + -- or we're moving from rpp to rp, and dir_0 should be set to 1 as + -- we have come from a parent + qnot_at dir_0 + ) + ( -- else (rpp == 0 and (rp == 0 or dir_0 == 0)) + do + let boolean_statement_in = Or (And (A rp) (Not (A dir_0))) (And (A r) dir_all_1) + let pos_m = last (last (init pos)) + let boolean_statement_out = Or (And (A rp) dir_all_1) (And (A r) (And (Not dir_all_1) (Not (A pos_m)))) + if_then_elseQinv boolean_statement_in + ( -- if (rp == 1 and dir_0 == 0) or (r == 1 and dir == 1..1) + do + qnot_at pos_1 + -- we know that pos_m == 0 + -- dir is should be changed + -- when we move from rp to r, and when we move from r to rp + mapUnary qnot dir + return () + ) + ( -- else ((rp == 0 or dir_0 == 1) and (r == 0 or dir /= 1..1)) + do + let boolean_statement = A r + if_then_elseQ boolean_statement + ( -- if r == 1 + do + qnot_at pos_1 + toChild M register + -- now dir == 1..1 + -- we also know that pos_m == 1 + ) + ( -- else + do + let boolean_statement_in = And (A height_1) (dir_all_1) + let boolean_statement_out = And (A height_1) (Not dir_all_1) + if_then_elseQinv boolean_statement_in + ( -- if height_1 == 1 and dir == 1..1 + do + toParent M register + qnot_at pos_1 + -- now, dir /= 1..1 + ) + ( -- else height_1 == 0 or dir /= 1..1 + do + let boolean_statement = A height_1 + if_then_elseQ boolean_statement + ( -- if height_1 == 1 (and dir /= 1..1) + do + toChild M2 register + -- now dir == 1..1 + ) + ( -- else (if height_1 == 0) + do + let boolean_statement_in = dir_all_1 + let boolean_statement_out = Not dir_all_1 + if_then_elseQinv boolean_statement_in + ( -- if dir = 1..1 + do + toParent Width register + -- now dir /= 1..1 + ) + ( --else (dir /= 1..1) + do + toChild Width register + -- now dir == 1..1 + ) boolean_statement_out + ) + ) boolean_statement_out + ) + ) boolean_statement_out + ) boolean_statement_out + ) boolean_statement_out + ) boolean_statement_out + return () + +-- | The circuit for 'walk' as a boxed subroutine. +subroutine_walk :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +subroutine_walk o = box "Walk" walk + +-- | Uncompute the various flags that were set by the initial call +-- to the oracle. It has to uncompute the flags depending on where we were before +-- the walk step, so isn't just the inverse of the oracle. +undo_oracle :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +undo_oracle o register = do + comment "UNDO_ORACLE" + labelBFR register + let initHB = start_board o + let x_max = oracle_x_max o + let paraleaf = work_paraleaf register + let (is_leaf,is_paraleaf) = position_flags register + with_controls paraleaf + ( do + let binary = work_binary register + let pos = position register + let dir = direction register + let hex_subroutine = case oracle_hex o of + Hex -> box "HEX" (hex_oracle initHB (oracle_s o) x_max) + Dummy -> hex_oracle_dummy + EmptyHex -> \x -> return x + hex_subroutine (pos,binary) + return () + ) + let leaf = work_leaf register + let dir = direction register + let dir_0 = last dir + let boolean_statement = And (Not (A is_leaf)) (And (A is_paraleaf) (Not (A dir_0))) + if_then_elseQ boolean_statement + ( -- if is_leaf == 0 and is_paraleaf == 1 and dir_0 == 0 + -- we went from a leaf to a paraleaf, so we can unset leaf + do + qnot_at leaf + ) + ( -- else + do + let binary = work_binary register + let pos = position register + let pos_w_2_m = last (head pos) + let dir_all_1 = foldr1 (\x y -> And x y) (map A dir) + let boolean_statement = Or (A is_leaf) (And (Not (A is_leaf)) (And (Not (A is_paraleaf)) (And (A pos_w_2_m) (Not (dir_all_1))))) + if_then_elseQ boolean_statement + ( -- if is_leaf == 1 or (is_leaf == 0 and is_paraleaf == 0 and pos_w_2_m == 1 and dir /= 1..1) + -- we went from a paraleaf to a leaf, so unset binary and paraleaf + -- or we went from a paraleaf to its parent... + do + qnot_at binary + qnot_at paraleaf + ) + ( -- else + do + with_controls (init (controls is_paraleaf pos)) + ( -- if pos_sm,pos_(s-1)m,...,3. == 00...0 + do + let height = work_height register + let r = work_r register + let rp = work_rp register + let pos_0 = last (last pos) + let pos_1 = last (init (last pos)) + let pos_m = last (last (init pos)) + let pos_2m = last (last (init (init pos))) + let boolean_statement = dir_all_1 + if_then_elseQ boolean_statement + ( -- if dir = 1...1 + do + qnot_at height `controlled` pos_2m + qnot_at r `controlled` (pos_2m .==. False .&&. pos_m .==. True) + with_controls (pos_2m .==. False .&&. pos_m .==. False .&&. pos_1 .==. True) + ( + do + qnot_at rp + qnot_at binary + ) + ) + ( -- else + with_controls (pos_2m .==. False .&&. pos_m .==. False) + ( + do + let rpp = work_rpp register + qnot_at height `controlled` pos_1 + qnot_at rpp `controlled` (pos_1 .==. False .&&. dir_0 .==. True) + qnot_at r `controlled` (pos_1 .==. False .&&. dir_0 .==. False .&&. pos_0 .==. True) + with_controls (pos_1 .==. False .&&. dir_0 .==. False .&&. pos_0 .==. False) + ( + do + qnot_at rp + qnot_at binary + ) + ) + ) + ) -- end if + ) + ) + return () + +-- | The circuit for 'undo_oracle' as a boxed subroutine. +subroutine_undo_oracle :: BooleanFormulaOracle -> BooleanFormulaRegister -> Circ () +subroutine_undo_oracle o = box "Undo Oracle" (undo_oracle o) + +-- | Define the circuit that updates the position register to be the +-- parent node of the current position. +toParent :: Where -> BooleanFormulaRegister -> Circ () +toParent M2 _ = error "TOPARENT should never be called with 2m+1 as width" +toParent w register = do + let pos = position register :: [[Qubit]] -- of length x*y + let pos_firstM = last pos :: [Qubit] -- of length m + let pos_secondM = last (init pos) :: [Qubit] -- of length m + let pos_0 = last pos_firstM :: Qubit + let pos_m = last pos_secondM :: Qubit + let dir = direction register :: [Qubit] -- of length m + let (_,is_paraleaf) = position_flags register :: (Qubit,Qubit) + mapUnary qnot dir + mapBinary copy_from_to (reverse pos_firstM) (reverse dir) + if (w == Width) then + ( do -- width + -- we need to shift everything to the right by m + shift_right pos + -- we need to shift is_paraleaf to x*y*m + copy_from_to is_paraleaf (last (head pos)) + return () + ) else return () + if (w == M) then + ( do -- m+1 + -- we need to "shift" pos_m to pos_0 + copy_from_to pos_m pos_0 + return () + ) else return () + +-- | @'copy_from_to' a b@: Sets the state of qubit /b/ to be the state of qubit /a/, +-- (and the state of /a/ is lost in the process, so this is not cloning). +-- It falls short of swapping /a/ and /b/, as we're not interested in preserving /a/. +copy_from_to :: Qubit -> Qubit -> Circ (Qubit,Qubit) +copy_from_to from to = do + qnot_at to `controlled` from + qnot_at from `controlled` to + return (from,to) + +-- | Define the circuit that updates the position register to be the +-- child node of the current position. +toChild :: Where -> BooleanFormulaRegister -> Circ () +toChild w register = do + let pos = position register :: [[Qubit]] -- of length x*y + let pos_firstM = last pos :: [Qubit] -- of length m + let pos_secondM = last (init pos) :: [Qubit] -- of length m + let pos_thirdM = last (init (init pos)) :: [Qubit] -- of length m + let pos_0 = last pos_firstM :: Qubit + let pos_m = last pos_secondM :: Qubit + let pos_2m = last pos_thirdM :: Qubit + let dir = direction register :: [Qubit] -- of length m + let (_,is_paraleaf) = position_flags register :: (Qubit,Qubit) + if (w == Width) then + ( do -- width + -- we need to "shift" x*y*m to is_paraleaf + copy_from_to (last (head pos)) is_paraleaf + -- we need to "shift" everything to the left by "m" + shift_left pos + ) else return () + if (w == M2) then + ( do -- 2m+1 + -- we need to "shift" pos_m to pos_2m + copy_from_to pos_m pos_2m + -- we need to "shift" 0.. to m.. to + shift_left [pos_secondM,pos_firstM] + ) else return () + if (w == M) then + ( do + -- we need to "shift" pos_0 to pos_m + copy_from_to pos_0 pos_m + return () + ) else return () + mapBinary copy_from_to dir pos_firstM + mapUnary qnot dir + return () + +-- | Shift every qubit in a register to the left by one. +shift_left :: [DirectionRegister] -> Circ () +shift_left [] = return () +shift_left [d] = return () +shift_left (d:d':ds) = do + mapBinary copy_from_to d' d + shift_left (d':ds) + +-- | Shift every qubit in a register to the right by one. +shift_right :: [DirectionRegister] -> Circ () +shift_right [] = return () +shift_right [d] = return () +shift_right (d:d':ds) = do + shift_right (d':ds) + mapBinary copy_from_to (reverse d) (reverse d') + -- the arguments are reversed to give a nice symmetry to the circuits + -- and should be equivalent to if they're not reversed + return () + +-- ---------------------------------------------------------------------- +-- * Possible main functions + +-- $ The following functions define various \main\ functions that can be called +-- from an overall \main\ function to display various parts of the +-- overall Boolean Formula Algorithm. The Boolean +-- Formula Algorithm is split into 13 sub-algorithms, each of which can be +-- displayed separately, or in various combinations. + +-- | Displays the overall Boolean Formula circuit for a given oracle description. +main_circuit :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_circuit f g oracle = print_simple f (decompose_generic g (qw_bf oracle)) + +-- | Display just 1 time-step of the given oracle, +-- i.e., one iteration of the 'u' from 'exp_u', with no controls. +main_u :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_u f g o = print_generic f (decompose_generic g (u o)) (registerShape o) + +-- | Display just 1 time-step of the 'walk' algorithm for the given oracle, +-- i.e., one iteration of /walk/, with no controls. +main_walk :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_walk f g o = print_generic f (decompose_generic g walk) (registerShape o) + +-- | Display just 1 time-step of the 'diffuse' algorithm for the given oracle, +-- i.e., one iteration of /diffuse/, with no controls. +main_diffuse :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_diffuse f g o = print_generic f (decompose_generic g diffuse) (registerShape o) + +-- | Display just 1 time-step of the 'oracle' algorithm for the given oracle, +-- i.e., one iteration of /oracle/, with no controls. +main_oracle :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_oracle f g o = print_generic f (decompose_generic g (oracle o)) (registerShape o) + +-- | Display just 1 time-step of the 'undo_oracle' algorithm for the given oracle, +-- i.e., one iteration of /undo_oracle/, with no controls. +main_undo_oracle :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_undo_oracle f g o = print_generic f (decompose_generic g (undo_oracle o)) (registerShape o) + +-- | Display the circuit for the Hex algorithm, for the given oracle, +-- i.e., one iteration of 'hex_oracle', with no controls. +main_hex :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_hex f g o = print_generic f (decompose_generic g (hex_oracle init s x_max)) (pos,binary) + where + init = start_board o + s = oracle_s o + x_max = oracle_x_max o + reg = registerShape o + pos = position reg + binary = work_binary reg + +-- | Display the circuit for the Checkwin_red algorithm, for the given oracle, +-- i.e., one iteration of 'checkwin_red_circuit', with no controls. +main_checkwin_red :: Format -> GateBase -> BooleanFormulaOracle -> IO () +main_checkwin_red f g o = print_generic f (decompose_generic g (checkwin_red_circuit x_max)) (qshape redboard,qubit) + where + (redboard,_) = start_board o + x_max = oracle_x_max o + +-- ---------------------------------------------------------------------- +-- * Running the Boolean Formula Algorithm + +-- $ The following functions define the way that the Boolean Formula Algorithm +-- would be run, if we had access to a quantum computer. Indeed, the functions +-- here interface with the "QuantumSimulation" quantum simulator so that they +-- can be built. + +-- | Approximation of how the algorithm would be run if we had a quantum computer: +-- uses QuantumSimulation run_generic_io function. The output of the algorithm will +-- be all False only in the instance that the Blue player wins the game. +main_bf :: BooleanFormulaOracle -> IO Bool +main_bf oracle = do + output <- run_generic_io (undefined :: Double) (qw_bf oracle) + let result = if (or output) then True -- a /= 0 (Red Wins) + else False -- a == 0 (Blue Wins) + return result + +-- | Display the result of 'main_bf', +-- i.e., either \"Red Wins\", or \"Blue Wins\" is the output. +whoWins :: BooleanFormulaOracle -> IO () +whoWins oracle = do + result <- main_bf oracle + if result then putStrLn "Red Wins" + else putStrLn "Blue Wins" + +-- | Run 'whoWins' for the given oracle, and its \"initial\" board. +main_whoWins :: BooleanFormulaOracle -> IO () +main_whoWins o = whoWins o diff --git a/dist/build/Quipper/Algorithms/BF/Hex.hs b/dist/build/Quipper/Algorithms/BF/Hex.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/BF/Hex.hs @@ -0,0 +1,578 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/BF/Hex.hs" #-} +-- | This module contains the implementation of the circuits for determining which +-- player has won a completed game of Hex. Please see "Quipper.Algorithms.BF.Main" +-- for an overview of the boolean formula algorithm, or +-- "Quipper.Algorithms.BF.BooleanFormula" to see where these circuits are used in the +-- overall implementation of the boolean formula algorithm. +-- The functions defined in this module make heavy use of Quipper's \"build_circuit\" +-- keyword, to automatically generate quantum circuits. + +module Quipper.Algorithms.BF.Hex where + +import Quipper +import Quipper.Internal.CircLifting +import Quipper.Libraries.Qram +import Quipper.Libraries.Arith hiding (template_symb_plus_) + +import Prelude hiding (lookup) + +-- | A dummy gate, that when lifted will add a quantum trace to the circuit. +qtrace :: [Bool] -> [Bool] +qtrace bs = bs + +-- | A hand-lifted version of qtrace, adds a named \"trace\" gate to the circuit. +template_qtrace :: Circ ([Qubit] -> Circ [Qubit]) +template_qtrace = return $ \qs -> do + named_gate_at "trace" qs + return qs + +-- | A hand-lifted version of the Prelude 'show' function. +template_show :: Show a => Circ (a -> Circ String) +template_show = return $ \a -> return $ show a + +-- | A hand-lifted function to get the 'head' of a list. +template_head :: Circ ([a] -> Circ a) +template_head = return $ \q -> return (head q) + +-- | A hand-lifted function to get the 'tail' of a list. +template_tail :: Circ ([a] -> Circ [a]) +template_tail = return $ \q -> return (tail q) + +-- | A hand-lifted function to get the 'length' of a list. +template_length :: Circ ([a] -> Circ Int) +template_length = return $ \as -> return $ length as + +-- | A hand-lifted version of the 'take' function, specialized to lists of qubits. +template_take :: Circ (Int -> Circ ([Qubit] -> Circ [Qubit])) +template_take = return $ \n -> return $ \qs -> return (take n qs) + +-- | A hand-lifted version of the 'drop' function, specialized to lists of qubits. +template_drop :: Circ (Int -> Circ ([Qubit] -> Circ [Qubit])) +template_drop = return $ \n -> return $ \qs -> return (drop n qs) + +-- | A hand-lifted version of the 'replicate' function, specialized to create lists of 'BoolParam'. +template_replicate :: Circ (Int -> Circ (BoolParam -> Circ [BoolParam])) +template_replicate = return $ \n -> return $ \bp -> return (replicate n bp) + +-- | A hand-lifted version of the 'map' function. +template_map :: Circ ((a -> Circ a) -> Circ ([a] -> Circ [a])) +template_map = return $ \func -> return $ \qs -> mapM func qs + +-- | 'Int' is not changed along the conversion. +template_integer :: Int -> Circ Int +template_integer x = return x + +-- | A hand-lifted version of the '-' function, specialized to 'Int'. +template_symb_minus_ :: Circ (Int -> Circ (Int -> Circ Int)) +template_symb_minus_ = return $ \x -> return $ \y -> return (x - y) + +-- | A hand-lifted version of the '+' function, specialized to 'Int'. +template_symb_plus_ :: Circ (Int -> Circ (Int -> Circ Int)) +template_symb_plus_ = return $ \x -> return $ \y -> return (x + y) + +-- | A hand-lifted version of the '<' function, specialized to 'Int'. +template_symb_oangle_ :: Circ (Int -> Circ (Int -> Circ Bool)) +template_symb_oangle_ = return $ \x -> return $ \y -> return (x < y) + +-- | A hand-lifted version of the '<=' function, specialized to 'Int'. +template_symb_oangle_symb_equal_ :: Circ (Int -> Circ (Int -> Circ Bool)) +template_symb_oangle_symb_equal_ = return $ \x -> return $ \y -> return (x <= y) + +-- | A hand-lifted version of the 'div' function, specialized to 'Int'. +template_div :: Circ (Int -> Circ (Int -> Circ Int)) +template_div = return $ \x -> return $ \y -> return (x `div` y) + +-- | A function synonym for '&&'. +cand :: Bool -> Bool -> Bool +cand = (&&) + +-- | A hand-lifted version of the 'cand' function. +template_cand :: Circ (Bool -> Circ (Bool -> Circ Bool)) +template_cand = return $ \x -> return $ \y -> return (x && y) + +-- | A hand-lifted version of the '>' function, specialized to 'Int'. +template_symb_cangle_ :: Circ (Int -> Circ (Int -> Circ Bool)) +template_symb_cangle_ = return $ \x -> return $ \y -> return (x > y) + +-- | A hand-lifted version of the '!!' function. +template_symb_exclamation_symb_exclamation_ :: Circ ([a] -> Circ (Int -> Circ a)) +template_symb_exclamation_symb_exclamation_ = return $ \as -> return $ \i -> return (as !! i) + +-- | A hand-lifted version of the 'mod' function, specialized to 'Int'. +template_mod :: Circ (Int -> Circ (Int -> Circ Int)) +template_mod = return $ \x -> return $ \y -> return (x `mod` y) + +-- | A hand-lifted version of the 'zip' function, specialized to lists of qubits. +template_zip :: Circ ([Qubit] -> Circ ([Qubit] -> Circ [(Qubit,Qubit)])) +template_zip = return $ \as -> return $ \bs -> return $ zip as bs + +-- | A hand-lifted version of the 'unzip' function, specialized to a list of pairs of qubits. +template_unzip :: Circ ([(Qubit,Qubit)] -> Circ ([Qubit],[Qubit])) +template_unzip = return $ \abs -> return $ unzip abs + +-- | A hand-lifted version of the 'or' function, specialized to a list of qubits. +template_or :: Circ ([Qubit] -> Circ Qubit) +template_or = return $ \bs -> do + q <- qinit True + qnot q `controlled` [ b .==. 0 | b <- bs ] + +-- | The Hex board consists of boolean parameters. +type HexBoardParam = ([BoolParam],[BoolParam]) + +-- | Convert a list of boolean parameters into a list of boolean inputs. +newBools :: [BoolParam] -> [Bool] +newBools = map newBool + +-- | A hand-lifted function to convert a list of boolean parameters +-- into a list of qubits initialized as ancillas is the given states. +template_newBools :: Circ ([BoolParam] -> Circ [Qubit]) +template_newBools = return $ \bps -> do + let bs = map newBool bps + mapM qinit bs + +-- | Convert a little-endian list of booleans into an integer by +-- reversing the list and calling the big-endian conversion function +-- 'bools2int''. +bools2int :: [Bool] -> Int +bools2int bs = bools2int' (reverse bs) + +-- | Convert a big-endian list of booleans into an integer. This is +-- mainly used for displaying a \"position\" register. +bools2int' :: [Bool] -> Int +bools2int' [] = 0 +bools2int' (x:xs) = 2*(bools2int' xs) + (if x then 1 else 0) + +-- | Convert an integer into a little-endian list of booleans of length /n/ +-- by reversing the big-endian list created by the 'int2bools'' function. +int2bools :: Int -> Int -> [Bool] +int2bools n x = reverse (int2bools' n x) + +-- | Convert an integer into a big-endian list of booleans of length /n/. +-- | Note that the behavior when /x/ is greater than 2[sup /n/] - 1 is erroneous. +int2bools' :: Int -> Int -> [Bool] +int2bools' n x = take n (int2bools'' x ++ repeat False) + +-- | Convert an integer into a big-endian list of booleans of minimal length. +int2bools'' :: Int -> [Bool] +int2bools'' 0 = [False] +int2bools'' 1 = [True] +int2bools'' x = (odd x):(int2bools'' (x `div` 2)) + +-- | This function is a stub, because a hand lifted version is given +-- for creating the circuits. +lookup :: [Bool] -> [Bool] -> Bool +lookup board address = board !! (bools2int address) + +-- | Hand-lifted version of lookup that uses 'addressed_perform' to look up a qubit at the given address. +template_lookup :: Circ ([Qubit] -> Circ ([Qubit] -> Circ Qubit)) +template_lookup = return $ \board -> return $ \address -> do + addressed_perform board address $ \q -> do -- q is board[address] + anc <- qinit False + qnot_at anc `controlled` q + return anc + +-- | Update the board, by negating the boolean in board, at the given address. +update :: [Bool] -> [Bool] -> [Bool] +update board address = (take n board) ++ b:(drop (n+1) board) + where n = bools2int address + b = not (board !! n) + +-- | Hand-lifted version of update that uses 'addressed_perform' to negate a qubit at the given address. +template_update :: Circ ([Qubit] -> Circ ([Qubit] -> Circ [Qubit])) +template_update = return $ \board -> return $ \address -> do + addressed_perform board address $ \q -> do -- q is board[address] + qnot_at q + return board + +-- | An unencapsulated version of 'template_update', for testing purposes. +test_update :: [Qubit] -> [Qubit] -> Circ [Qubit] +test_update board address = do + qcqcq <- template_update + qqcq <- qcqcq board + qqcq address + +-- | Perform a given operation on a quantum-addressed element of an array of +-- quantum data. +addressed_perform :: QData qa => + [qa] -- ^ Array of quantum data. + -> [Qubit] -- ^ Index into the array. + -> (qa -> Circ b) -- ^ An operation to be performed. + -> Circ b +addressed_perform qs idx f = do + with_computed (indexed_access qs i) $ \x -> do + f x + where i = qdint_of_qulist_bh idx + +-- | Update the boolean value at the given position, to the given value. + +update_pos :: Int -> [Bool] -> Bool -> [Bool] +update_pos n bs b = (take n bs) ++ b:(drop (n+1) bs) + + +{-# LINE 209 "Quipper/Algorithms/BF/Hex.hs" #-} +$( decToCircMonad [d| update_pos :: Int -> [Bool] -> Bool -> [Bool] + update_pos n bs b = (take n bs) ++ b:(drop (n+1) bs) + + + |] ) +{-# LINE 210 "Quipper/Algorithms/BF/Hex.hs" #-} +-- ====================================================================== +-- * Oracle implementation + +-- $ The functions in this implementation follow a separation of the boolean +-- formula algorithm into two parts. The first part consists of the +-- algorithms defined in "Quipper.Algorithms.BF.BooleanFormula". The second part +-- consists of the algorithms defined in this module. This separation relates +-- to the first part defining the quantum parts of the algorithm, including the +-- phase estimation, and the quantum walk, whereas the remaining four define +-- the classical implementation of the circuit for determining which player +-- has won a completed game of Hex, which is converted to a quantum circuit +-- using Quipper's \"build_circuit\" keyword. + +-- | A helper function, used by the 'flood_fill' function, that +-- checks whether a given board position is currently vacant. + +testpos :: Int -> [Bool] -> [Bool] -> [Bool] -> Int -> [Bool] +testpos pos maskmap bitmap newmap xy_max = case (0 <= pos) `cand` (pos < xy_max) of + True -> if not (maskmap !! pos) && not (bitmap !! pos) && not (newmap !! pos) + then update_pos pos newmap True + else newmap + False -> newmap + + +{-# LINE 232 "Quipper/Algorithms/BF/Hex.hs" #-} +$( decToCircMonad [d| testpos :: Int -> [Bool] -> [Bool] -> [Bool] -> Int -> [Bool] + testpos pos maskmap bitmap newmap xy_max = case (0 <= pos) `cand` (pos < xy_max) of + True -> if not (maskmap !! pos) && not (bitmap !! pos) && not (newmap !! pos) + then update_pos pos newmap True + else newmap + False -> newmap + + + |] ) +{-# LINE 233 "Quipper/Algorithms/BF/Hex.hs" #-} +-- | Given a board position, this function will call +-- 'testpos' for each of its neighboring board positions. + +test_positions :: Int -> Int -> Int -> [Bool] -> [Bool] -> [Bool] -> ([Bool],[Bool]) +test_positions ii x_max xy_max bitmap newmap maskmap = + let bitmap' = update_pos ii bitmap True in + let newmap' = testpos (ii + x_max) maskmap bitmap' newmap xy_max in + let newmap'' = testpos (ii - x_max) maskmap bitmap' newmap' xy_max in + let newmap''' = case (ii `mod` x_max > 0) of + True -> testpos (ii - 1) maskmap bitmap' newmap'' xy_max + False -> newmap'' + in + let newmap'''' = case (ii `mod` x_max > 0) of + True -> testpos (ii + x_max - 1) maskmap bitmap' newmap''' xy_max + False -> newmap''' + in + let newmap''''' = case (ii `mod` x_max < x_max - 1) of + True -> testpos (ii + 1) maskmap bitmap' newmap'''' xy_max + False -> newmap'''' + in + let newmap'''''' = case (ii `mod` x_max < x_max - 1) of + True -> testpos (ii - x_max + 1) maskmap bitmap' newmap''''' xy_max + False -> newmap''''' + in + let newmap''''''' = update_pos ii newmap'''''' False in + (newmap''''''',bitmap') + + + + +{-# LINE 261 "Quipper/Algorithms/BF/Hex.hs" #-} +$( decToCircMonad [d| test_positions :: Int -> Int -> Int -> [Bool] -> [Bool] -> [Bool] -> ([Bool],[Bool]) + test_positions ii x_max xy_max bitmap newmap maskmap = + let bitmap' = update_pos ii bitmap True in + let newmap' = testpos (ii + x_max) maskmap bitmap' newmap xy_max in + let newmap'' = testpos (ii - x_max) maskmap bitmap' newmap' xy_max in + let newmap''' = case (ii `mod` x_max > 0) of + True -> testpos (ii - 1) maskmap bitmap' newmap'' xy_max + False -> newmap'' + in + let newmap'''' = case (ii `mod` x_max > 0) of + True -> testpos (ii + x_max - 1) maskmap bitmap' newmap''' xy_max + False -> newmap''' + in + let newmap''''' = case (ii `mod` x_max < x_max - 1) of + True -> testpos (ii + 1) maskmap bitmap' newmap'''' xy_max + False -> newmap'''' + in + let newmap'''''' = case (ii `mod` x_max < x_max - 1) of + True -> testpos (ii - x_max + 1) maskmap bitmap' newmap''''' xy_max + False -> newmap''''' + in + let newmap''''''' = update_pos ii newmap'''''' False in + (newmap''''''',bitmap') + + + + + |] ) +{-# LINE 262 "Quipper/Algorithms/BF/Hex.hs" #-} +-- | This function calls 'test_positions' for every board position in strictly +-- increasing order. + +while_for :: Int -> Int -> Int -> [Bool] -> [Bool] -> [Bool] -> ([Bool],[Bool]) +while_for counter xy_max x_max bitmap newmap maskmap = case counter of + 0 -> let bitmap' = qtrace bitmap in + (bitmap',newmap) + n -> let ii = xy_max - n in + let (newmap',bitmap') = if newmap !! ii + then test_positions ii x_max xy_max bitmap newmap maskmap + else (newmap,bitmap) in + while_for (n-1) xy_max x_max bitmap' newmap' maskmap + + +{-# LINE 274 "Quipper/Algorithms/BF/Hex.hs" #-} +$( decToCircMonad [d| while_for :: Int -> Int -> Int -> [Bool] -> [Bool] -> [Bool] -> ([Bool],[Bool]) + while_for counter xy_max x_max bitmap newmap maskmap = case counter of + 0 -> let bitmap' = qtrace bitmap in + (bitmap',newmap) + n -> let ii = xy_max - n in + let (newmap',bitmap') = if newmap !! ii + then test_positions ii x_max xy_max bitmap newmap maskmap + else (newmap,bitmap) in + while_for (n-1) xy_max x_max bitmap' newmap' maskmap + + + |] ) +{-# LINE 275 "Quipper/Algorithms/BF/Hex.hs" #-} +-- | This function is used by 'flood_fill' to perform an approximation of a while loop. +-- This starts with /newmap/ containing only the blue pieces from the top row of the +-- Hex board, and fills in all contiguous regions, i.e., areas bounded by red pieces. +-- The resulting bitmap will only have blue pieces in the bottom row of the Hex board, +-- if blue has won. The number of times the loop will repeat is bounded by the size of +-- the Hex board. + +while :: Int -> Int -> [Bool] -> [Bool] -> [Bool] -> [Bool] +while counter x_max bitmap newmap maskmap = case counter of + 0 -> bitmap + n -> let counter' = length bitmap in + let (bitmap',newmap') = while_for counter' counter' x_max bitmap newmap maskmap in + while (n-1) x_max bitmap' newmap' maskmap + + +{-# LINE 288 "Quipper/Algorithms/BF/Hex.hs" #-} +$( decToCircMonad [d| while :: Int -> Int -> [Bool] -> [Bool] -> [Bool] -> [Bool] + while counter x_max bitmap newmap maskmap = case counter of + 0 -> bitmap + n -> let counter' = length bitmap in + let (bitmap',newmap') = while_for counter' counter' x_max bitmap newmap maskmap in + while (n-1) x_max bitmap' newmap' maskmap + + + |] ) +{-# LINE 289 "Quipper/Algorithms/BF/Hex.hs" #-} +-- | Swap the position of two boolean values within a pair. +swapBool :: (Bool,Bool) -> (Bool,Bool) +swapBool (a,b) = (b,a) + +-- | A hand-lifted version of the 'swapBool' function, which uses a 'swap' operation +-- to swap the state of two qubits within a pair. +template_swapBool :: Circ ((Qubit,Qubit) -> Circ (Qubit,Qubit)) +template_swapBool = return $ \(a,b) -> do + swap a b + return (a,b) + +-- | Implements a 'flood_fill' algorithm on a representation of a Hex +-- board. Returning the \"flooded\" version of the board. + +flood_fill :: Int -> [Bool] -> [Bool] -> [Bool] +flood_fill x_max bitmap maskmap = + let newmap = newBools (replicate (length bitmap) PFalse) in + let (bitmap',newmap') = unzip (map (\(a,b) -> if a then swapBool (a,b) else (a,b)) (zip bitmap newmap)) in + let newmap'' = qtrace newmap' in + let counter = ((length bitmap) `div` 4) + 1 in + -- The worst case scenario in our case as we know only half the pieces + -- can be blue, and only half those can be left or above in a flood_fill path + while counter x_max bitmap' newmap'' maskmap + + +{-# LINE 312 "Quipper/Algorithms/BF/Hex.hs" #-} +$( decToCircMonad [d| flood_fill :: Int -> [Bool] -> [Bool] -> [Bool] + flood_fill x_max bitmap maskmap = + let newmap = newBools (replicate (length bitmap) PFalse) in + let (bitmap',newmap') = unzip (map (\(a,b) -> if a then swapBool (a,b) else (a,b)) (zip bitmap newmap)) in + let newmap'' = qtrace newmap' in + let counter = ((length bitmap) `div` 4) + 1 in + + + while counter x_max bitmap' newmap'' maskmap + + + |] ) +{-# LINE 313 "Quipper/Algorithms/BF/Hex.hs" #-} +-- | A sub-algorithm of the 'checkwin_red' algorithm, which is given the bottom row of +-- booleans after the 'flood_fill' algorithm has been run, and checks to see if any of +-- them are 'True'. + +checkwin_red' :: [Bool] -> Bool +checkwin_red' bs = not (or bs) + + +{-# LINE 319 "Quipper/Algorithms/BF/Hex.hs" #-} +$( decToCircMonad [d| checkwin_red' :: [Bool] -> Bool + checkwin_red' bs = not (or bs) + + + |] ) +{-# LINE 320 "Quipper/Algorithms/BF/Hex.hs" #-} +-- | Given a description of a valid Hex board, i.e., a board +-- that represents a finished game, with a single piece on each square, will return +-- a boolean value stating whether the red player has won. + +checkwin_red :: Int -> [Bool] -> Bool +checkwin_red x_max redboard = + let begin_blueboard = map not (take x_max redboard) in + let n = length redboard - x_max in + let tail_blueboard = newBools (replicate n PFalse) in + let blueboard = begin_blueboard ++ tail_blueboard in + let blueboard' = flood_fill x_max blueboard redboard in + checkwin_red' (drop n blueboard') + + +{-# LINE 332 "Quipper/Algorithms/BF/Hex.hs" #-} +$( decToCircMonad [d| checkwin_red :: Int -> [Bool] -> Bool + checkwin_red x_max redboard = + let begin_blueboard = map not (take x_max redboard) in + let n = length redboard - x_max in + let tail_blueboard = newBools (replicate n PFalse) in + let blueboard = begin_blueboard ++ tail_blueboard in + let blueboard' = flood_fill x_max blueboard redboard in + checkwin_red' (drop n blueboard') + + + |] ) +{-# LINE 333 "Quipper/Algorithms/BF/Hex.hs" #-} +-- | An unencapsulated version of the 'checkwin_red' circuit. +checkwin_red_c :: Int -> [Qubit] -> Circ Qubit +checkwin_red_c i qs = do + icqscq <- template_checkwin_red + cqscq <- icqscq i + cqscq qs + +-- | A recursive sub-algorithm of 'hexT' that goes through each +-- direction in the position register and recursively updates the +-- ancilla register representing the /blueboard/ and /redboard/ +-- depending on which player's turn it is. If a position is already +-- set in one of the ancilla registers, then the current player has +-- played an invalid move, and therefore loses. If we pass through the +-- entire position register, then we have a valid description of a Hex +-- board split between the /redboard/ and /blueboard/ registers, which +-- can then be passed to 'checkwin_red' to see who has won (we +-- actually only pass the /redboard/ to 'checkwin_red' as every square +-- is now either a red piece or a blue piece, so no extra information +-- is held in the /blueboard/ register). + +movesT :: Int -> [[Bool]] -> [Bool] -> [Bool] -> BoolParam -> Bool +movesT x_max pos redboard blueboard player = + case pos of + [] -> checkwin_red x_max redboard + (address:pos') -> + if lookup redboard address + then (newBool player) + else + ( if lookup blueboard address + then (newBool player) + else + ( case player of + PFalse -> movesT x_max pos' (update redboard address) blueboard PTrue -- Red played, so Blue is next + PTrue -> movesT x_max pos' redboard (update blueboard address) PFalse -- Blue played, so Red is next + ) + ) + + +{-# LINE 369 "Quipper/Algorithms/BF/Hex.hs" #-} +$( decToCircMonad [d| movesT :: Int -> [[Bool]] -> [Bool] -> [Bool] -> BoolParam -> Bool + movesT x_max pos redboard blueboard player = + case pos of + [] -> checkwin_red x_max redboard + (address:pos') -> + if lookup redboard address + then (newBool player) + else + ( if lookup blueboard address + then (newBool player) + else + ( case player of + PFalse -> movesT x_max pos' (update redboard address) blueboard PTrue + PTrue -> movesT x_max pos' redboard (update blueboard address) PFalse + ) + ) + + + |] ) +{-# LINE 370 "Quipper/Algorithms/BF/Hex.hs" #-} +-- | The overall hex function. This initializes two ancilla registers +-- to represent the /redboard/ and the /blueboard/, and passes these +-- to the recursive 'movesT' function to determine which color has won +-- the game of Hex. + +hexT :: HexBoardParam -> BoolParam -> Int -> [[Bool]] -> Bool +hexT (init_r,init_b) next_player x_max pos = + let redboard = newBools init_r in + let blueboard = newBools init_b in + let result = movesT x_max pos redboard blueboard next_player in + -- next_player: PFalse = Red, PTrue = Blue. + result + + +{-# LINE 382 "Quipper/Algorithms/BF/Hex.hs" #-} +$( decToCircMonad [d| hexT :: HexBoardParam -> BoolParam -> Int -> [[Bool]] -> Bool + hexT (init_r,init_b) next_player x_max pos = + let redboard = newBools init_r in + let blueboard = newBools init_b in + let result = movesT x_max pos redboard blueboard next_player in + + result + + + |] ) +{-# LINE 383 "Quipper/Algorithms/BF/Hex.hs" #-} +-- | A function to convert a boolean to a boolean parameters +newBoolParam :: Bool -> BoolParam +newBoolParam x = if x then PTrue else PFalse + +-- | A function to convert a list of booleans to a list of boolean +-- parameters. +newBoolParams :: [Bool] -> [BoolParam] +newBoolParams = map newBoolParam + +-- | An interface to the lifted version of 'hexT' (i.e., +-- 'template_hexT'), which unbinds the inputs from the 'Circ' monad. +hex_oracle_c :: ([Bool],[Bool]) -> Int -> Int -> [[Qubit]] -> Circ Qubit +hex_oracle_c (init_r,init_b) s x_max pos = do + let params = (newBoolParams init_r,newBoolParams init_b) + let next_player = newBoolParam (even s) -- the size of the board is always 1 less + -- than an integer power of 2, therefore + -- an odd number. Red goes first, and + -- players alternate, so if the number of + -- moves remaining is odd, then the next + -- player is Red. + template_hexT_bp <- template_hexT + template_hexT_int <- template_hexT_bp params + template_hexT_int' <- template_hexT_int next_player + template_hexT_qs <- template_hexT_int' x_max + template_hexT_qs pos + +-- | An embedding of 'hex_oracle_c' into a reversible circuit, where all +-- ancillas are uncomputed automatically. +hex_oracle :: ([Bool],[Bool]) -> Int -> Int -> ([[Qubit]],Qubit) -> Circ ([[Qubit]],Qubit) +hex_oracle init s x_max pb = do + comment "HEX" + label pb ("pos","binary") + (classical_to_quantum . classical_to_reversible) (hex_oracle_c init s x_max) pb + +-- | A dummy oracle is just a gate named "HEX" applied to the input qubits. +hex_oracle_dummy :: ([[Qubit]],Qubit) -> Circ ([[Qubit]],Qubit) +hex_oracle_dummy qs = named_gate "HEX" qs + +-- | An embedding of 'checkwin_red_c' into a reversible circuit, where all +-- ancillas are uncomputed automatically. +checkwin_red_circuit :: Int -> ([Qubit],Qubit) -> Circ ([Qubit],Qubit) +checkwin_red_circuit x_max = (classical_to_quantum . classical_to_reversible) (checkwin_red_c x_max) diff --git a/dist/build/Quipper/Algorithms/BF/HexBoard.hs b/dist/build/Quipper/Algorithms/BF/HexBoard.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/BF/HexBoard.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/BF/HexBoard.hs" #-} +-- | This module provides the code for drawing Hex boards in graphical +-- format. See "Quipper.Algorithms.BF.Main" for an overview of the boolean formula algorithm. + +module Quipper.Algorithms.BF.HexBoard +( + output_start_board, + output_HexBoards +) +where + +import Quipper + +import Quipper.Algorithms.BF.BooleanFormula +import Quipper.Algorithms.BF.Hex + +import Graphics.EasyRender +import Text.Printf + +-- ---------------------------------------------------------------------- +-- * Shared functions + +-- | An enumeration of the colors a cell on the Hex board can be +-- colored. +data HexColor = Empty | Red | Blue deriving (Eq,Show) + +-- | Convert a description of the pieces on a Hex board to a list of +-- the colors of the cells on the Hex board. Also check that the +-- hex boards are of the correct length. +hexboard_to_colorlist :: Int -> HexBoard -> [HexColor] +hexboard_to_colorlist xy_max (red,blue) = + if length red == xy_max && length blue == xy_max then + map color (zip red blue) + else + error "hexboard length mismatch" + where + color (_, True) = Blue + color (True, _) = Red + color (_, _) = Empty + +-- ---------------------------------------------------------------------- +-- * ASCII output + +-- | Output multiple HexBoards in ASCII, for the given oracle. +ascii_of_HexBoards :: BooleanFormulaOracle -> [HexBoard] -> String +ascii_of_HexBoards oracle boards = ascii_of_ColorBoards x_max y_max colorBoards + where + x_max = oracle_x_max oracle + y_max = oracle_y_max oracle + xy_max = x_max * y_max + colorBoards = map (hexboard_to_colorlist xy_max) boards + +-- | Output multiple lists of colors, that represent HexBoards, in ASCII, +-- for the given oracle. +ascii_of_ColorBoards :: Int -> Int -> [[HexColor]] -> String +ascii_of_ColorBoards x_max y_max cbs = concat (map (ascii_of_ColorBoard 1 x_max) cbs) + +-- | Output a single list of colors, that represents a HexBoard, in ASCII, +-- for the given oracle /x/ dimension. +ascii_of_ColorBoard :: Int -> Int -> [HexColor] -> String +ascii_of_ColorBoard _ _ [] = "\n" +ascii_of_ColorBoard spaces n cs = + show (map color_to_bash (take n cs)) ++ '\n':(replicate spaces ' ') + ++ ascii_of_ColorBoard (spaces+1) n (drop n cs) + +-- | An alternate enumeration of the colors a cell on the Hex board +-- can be colored, so we can use bash escape color codes in the ASCII +-- output. +data BashColor = BashEmpty | BashRed | BashBlue deriving Eq + +-- | A function to convert HexColor to BashColor +color_to_bash :: HexColor -> BashColor +color_to_bash Empty = BashEmpty +color_to_bash Red = BashRed +color_to_bash Blue = BashBlue + +-- | An instance of Show for BashColor, so the string for each color contains +-- the bash escape code for that color, and a single character. +instance Show BashColor where + show BashEmpty = " " + show BashRed = "\^[\ESC[1;31m\^]#\^[\ESC[0m\^]" + show BashBlue = "\^[\ESC[1;34m\^]*\^[\ESC[0m\^]" + +-- ---------------------------------------------------------------------- +-- * Graphical output + +-- | Given an oracle, and a list of Hex board descriptions of the +-- given size, output a graphical representation of the Hex boards, +-- one per page. +document_of_HexBoards :: BooleanFormulaOracle -> [HexBoard] -> Document () +document_of_HexBoards oracle boards = do + sequence_ [ drawPage w h b | b <- boards ] + where + w = oracle_x_max oracle + h = oracle_y_max oracle + +-- | Draw a Hex board of dimensions /w/ × /h/ on a page by itself. +-- The drawing takes place in the following user coordinate system: +-- +-- \[image hex-coord.png] +drawPage :: Int -> Int -> HexBoard -> Document () +drawPage w h board = do + newpage (width*sc) (height*sc) $ do + scale sc sc + translate 0.5 (height-1) + setlinewidth 0.05 + sequence_ [drawCell (i `mod` w) (i `div` w) color | (color, i) <- zip cboard [0..] ] + where + width = fromIntegral (2*w + h - 1) * sqrt 0.75 + 1 + height = 0.5 + 1.5 * fromIntegral h + 1 + cboard = hexboard_to_colorlist (w*h) board + sc = 18 -- each cell is 1/2 inch wide + +-- | Draw a single hex cell of the given color, at position /x/ \"over\" and /y/ \"across\". +drawCell :: Int -> Int -> HexColor -> Draw () +drawCell x y color = draw_subroutine alt $ do + block $ do + translate (s*x0) y0 + moveto 0 0 + lineto s (0.5) + lineto (2*s) 0 + lineto (2*s) (-1) + lineto s (-1.5) + lineto 0 (-1) + closepath + fillstroke (Color_RGB r g b) + where + x0 = fromIntegral (2*x+y) + y0 = (-1.5) * fromIntegral y + s = sqrt 0.75 + (r,g,b) = drawcolor color + drawcolor Red = (1, 0, 0) + drawcolor Blue = (0, 0, 1) + drawcolor Empty = (1, 1, 1) + alt = [custom_ps $ printf "%.0f %.0f %.0f %f %f hexagon\n" r g b x0 y0] + +-- | A version of 'print_of_document' that is enhanced with PostScript +-- definitions local to this module. +my_print_of_document :: Format -> Document a -> IO a +my_print_of_document = print_of_document_custom cust where + cust = custom { + ps_defs = "/hexagon { gsave exch s mul exch translate 0 0 moveto s .5 rlineto s -.5 rlineto 0 -1 rlineto s neg -.5 rlineto s neg .5 rlineto closepath gsave setrgbcolor fill grestore stroke grestore } bind def\n" ++ + "/s 0.75 sqrt def\n" + } + +-- ---------------------------------------------------------------------- +-- * Functions taking a Format parameter + +-- | Output the starting 'HexBoard' in the given format, for the given oracle. +output_start_board :: Format -> BooleanFormulaOracle -> IO () +output_start_board f o = output_HexBoards f o [board] + where board = start_board o + +-- | Output multiple 'HexBoard's in the given format, for the given oracle. +output_HexBoards :: Format -> BooleanFormulaOracle -> [HexBoard] -> IO () +output_HexBoards PS bfo hbs = my_print_of_document PS (document_of_HexBoards bfo hbs) +output_HexBoards PDF bfo hbs = my_print_of_document PDF (document_of_HexBoards bfo hbs) +output_HexBoards ASCII bfo hbs = Prelude.putStr (ascii_of_HexBoards bfo hbs) +output_HexBoards Preview bfo hbs = my_print_of_document Preview (document_of_HexBoards bfo hbs) +output_HexBoards GateCount _ _ = error "GateCount is not a valid format for displaying a Hex Board" +output_HexBoards EPS bfo hbs = output_HexBoards PS bfo hbs +output_HexBoards (CustomStyle _ ) _ _ = error "CustomStyle not currently supported" + +-- ---------------------------------------------------------------------- diff --git a/dist/build/Quipper/Algorithms/BF/Main.hs b/dist/build/Quipper/Algorithms/BF/Main.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/BF/Main.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/BF/Main.hs" #-} +-- | +-- Author: Alexander S. Green +-- +-- An implementation of the Boolean Formula algorithm, applied to +-- finding whether a winning strategy exists in a game of Hex. +-- +-- \[image hex1.png] +-- \[image hex2.png] +-- +-- The algorithm consists of eigenvalue analysis using phase estimation, +-- acting on an oracle that defines a quantum walk over the NAND graph +-- representation of a game of Hex, for a given size of board. +-- +-- The implementation defines the NAND graph of a game of Hex by adding a few +-- extra nodes to a graph representing pieces being played during a game of Hex. +-- An extra node is added to each leaf node that represents a completed game of +-- Hex, for which the red player has won, as well as two extra nodes being +-- added below the root node. +-- +-- The general form of the algorithm is described in: +-- +-- * A. Ambainis, A. M. Childs, B. W. Reichardt, R. Spalek, and +-- S. Zhang. \"Any AND-OR formula of size /N/ can be evaluated in +-- time /N/[sup 1\/2+/o/(1)] on a quantum computer.\" /SIAM J. Comput./, +-- 39:2513–2530, April 2010. See also +-- . +-- +-- * A. M. Childs, B. W. Reichardt, R. Spalek, and S. Zhang. +-- \"Every NAND formula of size /N/ can be evaluated in time +-- /N/[sup 1\/2+/o/(1)] on a quantum computer\" 2007. +-- . +-- +-- The present implementation is based on detailed algorithm and +-- oracle specifications that were provided to us by the IARPA QCS +-- program and written by Patrick Henry. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.BF.Main": Command line interface. +-- +-- * "Quipper.Algorithms.BF.BooleanFormula": Implementation of the various quantum +-- circuits that make up the boolean formula algorithm. +-- +-- * "Quipper.Algorithms.BF.Hex": Implementation of the circuits for determining which +-- player has won a completed game of Hex. +-- +-- * "Quipper.Algorithms.BF.HexBoard": Code for drawing Hex boards in graphical format. +-- +-- * "Quipper.Algorithms.BF.Testing": Testing facilities for the boolean +-- formula algorithm, and some auxiliary function definitions. + +module Quipper.Algorithms.BF.Main where + +import Quipper + +import Quipper.Libraries.Decompose + +import qualified Quipper.Algorithms.BF.BooleanFormula as BooleanFormula +import qualified Quipper.Algorithms.BF.Hex as Hex +import qualified Quipper.Algorithms.BF.Testing as Testing +import qualified Quipper.Algorithms.BF.HexBoard as HexBoard + +import Quipper.Utils.CommandLine +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Control.Monad +import Data.List +import Data.Char + +-- ---------------------------------------------------------------------- +-- * Command line interface + +-- $ This module provides a command line interface for the Boolean +-- Formula algorithm. This allows the user, for example, to plug in +-- different oracles, show different parts of the circuit, run a demo, +-- and select different output formats. + +-- ---------------------------------------------------------------------- +-- * Option processing + +-- | An enumeration type for determining the action that should be taken when +-- the executable is run. +data WhatToDo = + OutputCircuit -- ^ Output the circuit. + | Demo -- ^ Run a demo of the circuit, which is different for the + -- various parts of the algorithm. + | HexBoard -- ^ Output a representation of the moves already made for the + -- defined oracle, i.e. a partially filled Hex Board. + deriving Show + +-- | An enumeration type for determining what the main function should do. +data WhatPart = + WholeCircuit -- ^ The whole circuit. + | U -- ^ Only one iteration of the U from EXP_U circuit. + | Oracle -- ^ Only the Oracle circuit. + | Hex -- ^ Only the Hex circuit. + | Checkwin_Red -- ^ Only the Checkwin_Red circuit, i.e. including Flood_Fill. + | Diffuse -- ^ Only the Diffuse circuit. + | Walk -- ^ Only the Walk circuit. + | Undo_Oracle -- ^ Only the Undo_Oracle circuit. + deriving Show + +-- | An enumeration type for selecting an oracle size. +data OracleSize = + Full -- ^ The oracle for a 9 by 7 Hex board, + -- with a 189 qubit phase estimation register. + | Small -- ^ The oracle for a 5 by 3 Hex board, + -- with a 4 qubit phase estimation register + | Custom Int Int Int -- ^ A custom oracle. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + what :: WhatToDo, -- ^ What we want to do. + part :: WhatPart, -- ^ What part of the algorithm to use. + format :: Format, -- ^ The output format of a circuit. + oracle_size :: OracleSize, -- ^ Which size of oracle to use. + oracle_init :: [Int], -- ^ A list of moves already made, + -- which is used to define /s/ + hex :: BooleanFormula.HexCircuit, -- ^ A flag of which HEX circuit to use. + gatebase :: GateBase -- ^ What kind of gates to decompose into. +} + +-- | The default options, which correspond to a Preview of the entire circuit +-- for the small oracle. +defaultOptions :: Options +defaultOptions = Options + { what = OutputCircuit, + part = WholeCircuit, + format = Preview, + oracle_size = Small, + oracle_init = [], + hex = BooleanFormula.Hex, + gatebase = Logical + } + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = + [ Option ['C'] ["circuit"] (NoArg (what OutputCircuit)) "output the whole circuit (default)", + Option ['D'] ["demo"] (NoArg (what Demo)) "run a demo of the circuit", + Option ['H'] ["hexboard"] (NoArg (what HexBoard)) "output a representation of the initial state of the given oracle, i.e. the game played so far", + Option ['p'] ["part"] (ReqArg part "") "which part of the circuit to use (default: whole)", + Option ['o'] ["oracle"] (ReqArg oracle "") "which oracle to use (default: small)", + Option ['m'] ["moves"] (ReqArg oracle_init "") "which moves have already been made (default: [])", + Option ['f'] ["format"] (ReqArg format "") "output format for circuits (default: preview)", + Option ['d'] ["dummy"] (NoArg setDummy) "set to only use a dummy HEX gate instead of the full hex circuit", + Option ['h'] ["help"] (NoArg help) "print usage info and exit", + Option ['g'] ["gatebase"] (ReqArg gatebase "") "type of gates to decompose the output circuit into (default: logical)" + ] + where + help :: Options -> IO Options + help o = do + usage + exitSuccess + + what :: WhatToDo -> Options -> IO Options + what w o = return o { what = w } + + part :: String -> Options -> IO Options + part str opt = do + case match_enum part_enum str of + [(_, p)] -> return opt { part = p } + [] -> optfail ("Unknown part -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous part -- " ++ str ++ "\n") + + oracle :: String -> Options -> IO Options + oracle str opt = do + case match_enum oracle_enum str of + [(_, Just o)] -> return opt {oracle_size = o} + [] -> case getCustom str of + Just o -> return opt {oracle_size = o} + Nothing -> optfail ("Unknown oracle -- " ++ str ++ "\n") + _ -> case getCustom str of + Just o -> return opt {oracle_size = o} + Nothing -> optfail ("Ambiguous oracle -- " ++ str ++ "\n") + + oracle_init :: String -> Options -> IO Options + oracle_init str opt = case parse_list_int str of + Nothing -> error "moves should be given as a Haskell list of integers, e.g. [1,2,3,4,5]" + Just pos -> return opt {oracle_init = pos} + + format :: String -> Options -> IO Options + format str opt = do + case match_enum format_enum str of + [(_, f)] -> return opt { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + setDummy :: Options -> IO Options + setDummy o = return o {hex = BooleanFormula.Dummy} + + gatebase :: String -> Options -> IO Options + gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + +-- | An enumeration of available circuit parts and their names. +part_enum :: [(String, WhatPart)] +part_enum = [ + ("whole",WholeCircuit), + ("u",U), + ("oracle",Oracle), + ("hex",Hex), + ("checkwin_red",Checkwin_Red), + ("diffuse",Diffuse), + ("walk",Walk), + ("undo_oracle",Undo_Oracle) + ] + +-- | An enumeration of available oracles and their names. +oracle_enum :: [(String, Maybe OracleSize)] +oracle_enum = [ + ("9by7", Just Full), + ("small", Just Small), + ("custom x y t", Nothing) -- this is a dummy, to show in a help message + ] + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to 'stdout'. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "part" part_enum) + putStr (show_enum "oracle" oracle_enum) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + where header = "Usage: bf [OPTION...]" + +-- ---------------------------------------------------------------------- +-- * The BF main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO () +main = do + argv <- getArgs + options <- dopts argv + case check_options options of + Options { what = what, part = part, format = format, oracle_size = oracle_size, oracle_init = oracle_init, hex = hex, gatebase = gatebase } -> do + let bfo = getOracle oracle_size oracle_init + let bfo' = BooleanFormula.update_hex bfo hex + let bfo'' = BooleanFormula.update_start_board bfo' (Testing.moves_to_hex bfo' oracle_init) + case what of + OutputCircuit -> output_part part format gatebase bfo'' + Demo -> demo_part part format bfo'' + HexBoard -> do + let boards = map (Testing.moves_to_hex bfo') (inits oracle_init) + HexBoard.output_HexBoards format bfo' boards + +-- | Check that the given options are valid. This currently is only required to +-- check that the list of moves already made, is valid for the given size of oracle. +check_options :: Options -> Options +check_options opts = case length moves > xy of + True -> error "Too many moves have been given" + False -> case (filter (\pos -> pos >= xy || pos < 0) moves) of + [] -> case moves == nub moves of + True -> opts + False -> error "Duplicate moves made" + _ -> error "Move out of bounds" + where + moves = oracle_init opts + xy = x * y + (x,y) = case oracle_size opts of + Full -> (9,7) + Small -> (5,3) + (Custom x y t) -> (x,y) + +-- | Convert an OracleSize, and a list of played positions, into an actual oracle. +getOracle :: OracleSize -> [Int] -> BooleanFormula.BooleanFormulaOracle +getOracle Full _ = BooleanFormula.full_oracle +getOracle Small _ = BooleanFormula.test_oracle +getOracle (Custom x y t) _ = BooleanFormula.createOracle x y t + +-- | This function defines what should be output for each part of the circuit. +output_part :: WhatPart -> Format -> GateBase -> BooleanFormula.BooleanFormulaOracle -> IO () +output_part WholeCircuit f g o = BooleanFormula.main_circuit f g o +output_part U f g o = BooleanFormula.main_u f g o +output_part Oracle f g o = BooleanFormula.main_oracle f g o +output_part Hex f g o = BooleanFormula.main_hex f g o +output_part Checkwin_Red f g o = BooleanFormula.main_checkwin_red f g o +output_part Diffuse f g o = BooleanFormula.main_diffuse f g o +output_part Walk f g o = BooleanFormula.main_walk f g o +output_part Undo_Oracle f g o = BooleanFormula.main_undo_oracle f g o + +-- | This function defines what should be done for a demo of each part of the circuit. +demo_part :: WhatPart -> Format -> BooleanFormula.BooleanFormulaOracle -> IO () +demo_part WholeCircuit ASCII o = Testing.repeat_odwu_infinite (BooleanFormula.update_hex o BooleanFormula.EmptyHex) (BooleanFormula.createRegister o) +demo_part WholeCircuit f o = do + let n = (BooleanFormula.oracle_s o) * 2 + boards <- Testing.repeat_odwu_n n (BooleanFormula.update_hex o BooleanFormula.EmptyHex) (BooleanFormula.createRegister o) + HexBoard.output_HexBoards f o boards +demo_part Hex f o = do + let o_s = BooleanFormula.oracle_s o + case o_s of + 0 -> do + result <- Testing.run_hex_with_input o (BooleanFormula.createRegister o) + putStrLn ((if result then "Red" else "Blue") ++ " wins.") + _ -> error "Hex demo requires a moves input that leaves no moves remaining" +demo_part Checkwin_Red f o = do + let o_s = BooleanFormula.oracle_s o + case o_s of + 0 -> do + let (red_board,_) = BooleanFormula.start_board o + blue_boards <- Testing.checkwin_trace o + let boards = map (\x -> (red_board,x)) blue_boards + HexBoard.output_HexBoards f o boards + _ -> error "checkwin_red demo requires a moves input that leaves no moves remaining" +demo_part U f o = demo_part WholeCircuit f o +demo_part Oracle f o = demo_part WholeCircuit f o +demo_part Diffuse f o = demo_part WholeCircuit f o +demo_part Walk f o = demo_part WholeCircuit f o +demo_part Undo_Oracle f o = demo_part WholeCircuit f o + +----- Custom Sized Oracles ------- + +-- | An infinite list of all numbers that are one less than an integer power of 2. +valid_sizes :: [Int] +valid_sizes = map (\x -> (2^x) - 1) [1..] + +-- | Return True if the given number is one less than an integer power of 2. +valid_size :: Int -> Bool +valid_size s = valid_size' s valid_sizes + where + valid_size' s [] = error "Unreachable Error Occurred: valid_sizes is an infinite list" + valid_size' s (n:ns) = case compare s n of + LT -> False + EQ -> True + GT -> valid_size' s ns + +-- | Create a custom sized oracle, by checking the given /x/,/y/, and /t/ sizes are valid. +createCustom :: Int -> Int -> Int -> OracleSize +createCustom x y t = case (x >= y) of + False -> error "The x dimension must be at least as big as the y dimension" + True -> case valid_size (x*y) of + False -> error "The number of squares on the Hex Board (x*y), must be one less than an integer power of 2" + True -> case (t > 0) of + False -> error "The size of the phase estimation register must be greater than 0" + True -> Custom x y t + +-- | Parse a string defining a custom oracle size. +getCustom :: String -> Maybe OracleSize +getCustom s = + case tokens of + [] -> Nothing + (s:strs) -> case (isPrefixOf s "custom") of + False -> Nothing + True -> case strs of + [x_str,y_str,t_str] -> Just (createCustom x y t) + where + x = case (parse_int x_str) of + Just x -> x + Nothing -> error "error parsing x argument" + y = case (parse_int y_str) of + Just y -> y + Nothing -> error "error parsing y argument" + t = case (parse_int t_str) of + Just t -> t + Nothing -> error "error parsing y argument" + _ -> error "custom size requires x, y, and t arguments" + where tokens = words s diff --git a/dist/build/Quipper/Algorithms/BF/Testing.hs b/dist/build/Quipper/Algorithms/BF/Testing.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/BF/Testing.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/BF/Testing.hs" #-} +-- | This module provides some testing facilities for the Boolean +-- Formula algorithm, as well as some auxiliary function definitions. +-- See "Quipper.Algorithms.BF.Main" for an overview of the boolean formula algorithm. +module Quipper.Algorithms.BF.Testing where + +import Quipper.Algorithms.BF.BooleanFormula +import Quipper.Algorithms.BF.Hex +import Quipper.Algorithms.BF.HexBoard +import Quipper +import Quipper.Libraries.Simulation +import Quipper.Libraries.Unboxing + +-- * Auxiliary definitions + +-- | Convert list of moves, into a 'HexBoard'. +moves_to_hex :: BooleanFormulaOracle -> [Int] -> HexBoard +moves_to_hex o moves = fromPos o pos + where pos = moves_to_pos o moves + +-- | Convert a list of moves, into a list of positions. +moves_to_pos :: BooleanFormulaOracle -> [Int] -> [[Bool]] +moves_to_pos o moves = map (int2bools (oracle_m o)) moves + +-- | Set the position in board, at the given address, to the given boolean. +set_bool :: [Bool] -> [Bool] -> Bool -> [Bool] +set_bool board address value = (take n board) ++ value:(drop (n+1) board) + where n = bools2int address + +-- | Create the description of a Hex board, from the given classical state +-- of a position register from the Boolean Formula algorithm. +fromPos :: BooleanFormulaOracle -> [[Bool]] -> HexBoard +fromPos o pos = fromPos' pos (start_board o) (odd (oracle_s o)) + where + fromPos' :: [[Bool]] -> HexBoard -> Bool -> HexBoard + fromPos' [] rb _ = rb + fromPos' (p:ps) (red,blue) is_red = fromPos' ps (if is_red then (set_bool red p True,set_bool blue p False) else (set_bool red p False,set_bool blue p True)) (not is_red) + +-- * Testing various circuits + +-- | A dummy value of type 'Double', to feed the type in the simulator. +double :: Double +double = undefined + +-- | Construct the oracle circuit, initialized with the given boolean inputs. +oracle_with_input :: BooleanFormulaOracle -> BoolRegister -> Circ BooleanFormulaRegister +oracle_with_input o input = do + reg <- qinit input + oracle o reg + return reg + +-- | Simulate the oracle circuit with the given boolean inputs, to +-- give boolean outputs. +run_oracle_with_input :: BooleanFormulaOracle -> BoolRegister -> IO BoolRegister +run_oracle_with_input oracle input = do + run_generic_io double (unbox (oracle_with_input oracle input)) + +-- | Return the diffuse circuit, initialized with the given boolean +-- inputs. +diffuse_with_input :: BoolRegister -> Circ BooleanFormulaRegister +diffuse_with_input input = do + reg <- qinit input + diffuse reg + return reg + +-- | Simulate the diffuse circuit with the given boolean inputs, +-- to give boolean outputs. +run_diffuse_with_input :: BoolRegister -> IO BoolRegister +run_diffuse_with_input input = do + run_generic_io double (diffuse_with_input input) + +-- | Return the walk circuit, initialized with the given boolean inputs. +walk_with_input :: BoolRegister -> Circ BooleanFormulaRegister +walk_with_input input = do + reg <- qinit input + walk reg + return reg + +-- | Simulate the walk circuit with the given boolean inputs, to give +-- boolean outputs. +run_walk_with_input :: BoolRegister -> IO BoolRegister +run_walk_with_input input = do + run_generic_io double (walk_with_input input) + +-- | Return the 'undo_oracle' circuit, initialized with the given +-- boolean inputs. +undo_oracle_with_input :: BooleanFormulaOracle -> BoolRegister -> Circ BooleanFormulaRegister +undo_oracle_with_input o input = do + reg <- qinit input + undo_oracle o reg + return reg + +-- | Simulate the 'undo_oracle' circuit with the given boolean inputs, +-- to give boolean outputs. +run_undo_oracle_with_input :: BooleanFormulaOracle -> BoolRegister -> IO BoolRegister +run_undo_oracle_with_input oracle input = do + run_generic_io double (unbox (undo_oracle_with_input oracle input)) + +-- * Oracle, diffuse, walk, and undo_oracle + +-- | Create a register from the given boolean inputs, +-- and then run the oracle circuit, followed by the diffusion step, +-- followed by the walk step, and finally the 'undo_oracle' circuit. +-- +-- This is really a test of all four parts. The return values when +-- running this step can be fed forward into the next iteration, and +-- the 'undo_oracle' step should have returned the eight work qubits +-- back to the initial 'False' states. +-- +-- We break the simulation into the four separate steps, so that we are +-- not trying to simulate the walk/undo_oracle steps over a quantum state, as +-- this gives us an overhead. +run_odwu_with_input :: BooleanFormulaOracle -> BoolRegister -> IO BoolRegister +run_odwu_with_input o input = do + oracle_output <- run_oracle_with_input o input + diffuse_output <- run_diffuse_with_input oracle_output + walk_output <- run_walk_with_input diffuse_output + run_undo_oracle_with_input o walk_output + +-- | Simulate the /odwu/ circuit, running it /n/ times and passing the +-- output of each iteration as inputs to the next iteration. +-- The overall return value is a representation of the HexBoard at each step of +-- the simulation. +repeat_odwu_n :: Int -> BooleanFormulaOracle -> BoolRegister -> IO [HexBoard] +repeat_odwu_n n oracle input = repeat_odwu_n' n oracle input [] + where + repeat_odwu_n' 0 _ _ accum = return (reverse accum) + repeat_odwu_n' n oracle input accum = do + output <- run_odwu_with_input oracle input + let flags = position_flags output + let pos = position output + let hexboard = start_board (update_start_board oracle (fromPos oracle (tidy flags pos))) + repeat_odwu_n' (n-1) oracle output (hexboard:accum) + +-- | Simulate the /odwu/ circuit, running it repeatedly and passing +-- the output of each iteration as inputs to the next iteration. +-- Outputs an ASCII representation of the position register/board after each step. +repeat_odwu_infinite :: BooleanFormulaOracle -> BoolRegister -> IO () +repeat_odwu_infinite oracle input = do + output <- run_odwu_with_input oracle input + let flags = position_flags output + let pos = position output + putStrLn "Position Register: " + putStr (show ((\(l,p) -> [if l then 'L' else ' ',if p then 'P' else ' ']) flags)) + putStr " : " + putStrLn (show (map bools2int pos)) + output_start_board ASCII (update_start_board oracle (fromPos oracle (tidy flags pos))) + repeat_odwu_infinite oracle output + +-- | Trim any leading zeroes from a pos register, +-- and a single leading 1, if we're not at a paraleaf, +-- and a 3, if we're at the root. +tidy :: (Bool,Bool) -> [[Bool]] -> [[Bool]] +tidy flags pos = if pos == (zeroes ++ [three]) then [] else tidy' flags pos + where + zeroes = replicate (length pos - 1) (replicate (length (head pos)) False) + three = (replicate (length (head pos) - 2) False) ++ [True,True] + tidy' _ [] = [] + tidy' (l,p) (a:as) = case (a == replicate (length a) False) of + True -> tidy' (l,p) as + False -> case (a == (replicate (length a - 1) False) ++ [True]) of + False -> a:as + True -> if p then (a:as) else as + +-- | Return the 'Hex' circuit, initialized for the given oracle, with the given +-- boolean inputs. +hex_with_input :: BooleanFormulaOracle -> BoolRegister -> Circ Qubit +hex_with_input oracle input = do + let init = start_board oracle + let s = oracle_s oracle + let x_max = oracle_x_max oracle + reg <- qinit input + let pos = position reg + let binary = work_binary reg + (_,binary') <- hex_oracle init s x_max (pos,binary) + return binary' + +-- | Simulate the running of the 'Hex' circuit, initialized for the given oracle, +-- with the given boolean inputs. +run_hex_with_input :: BooleanFormulaOracle -> BoolRegister -> IO Bool +run_hex_with_input oracle input = run_generic_io double (hex_with_input oracle input) + +-- | Simulate the running of the 'checkwin_red' subroutine for the +-- given oracle, and keep track of the state of certain \"traced\" qubits within that +-- subroutine, which represent the Hex board at each iteration of the while loop in +-- the 'flood_fill' algorithm. +checkwin_trace :: BooleanFormulaOracle -> IO [[Bool]] +checkwin_trace o = do + let circuit = hex_with_input o (createRegister o) + trace <- run_generic_trace_io double circuit + -- trace :: [QuantumTrace] = [Vector Double [Bool]] = [Vector [([Bool],Double)]] + let boards = map (\(Vector [(bs,_)]) -> bs) trace + return boards + + diff --git a/dist/build/Quipper/Algorithms/BWT/Alternative.hs b/dist/build/Quipper/Algorithms/BWT/Alternative.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/BWT/Alternative.hs @@ -0,0 +1,759 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/BWT/Alternative.hs" #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | Alternative implementations for the binary welded tree algorithm. +-- The purpose of these is to experiment with and potentially +-- illustrate a more functional programming style. + +module Quipper.Algorithms.BWT.Alternative where + +import Quipper + +import Quipper.Libraries.Qureg +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.BWT.Definitions + +-- import other Quipper stuff +import qualified Quipper.Algorithms.BWT.BWT as BWT + +import Quipper.Utils.Sampling +import Quipper.Utils.Auxiliary + +-- import other stuff +import Control.Monad +import Text.Printf +import Data.Bits (xor) +import Text.Printf + +import Data.Map (Map) +import qualified Data.Map as Map + + +-- ====================================================================== +-- * Oracle abstraction + +-- | This is a version of 'BWT.Oracle' that uses 'Qulist' instead of +-- 'Qureg'. An oracle provides the following information: the tree +-- depth /n/, the label length /m/, the number of edge colors /k/, +-- the entrance label /ENTRANCE/, and for each color 0 ≤ /c/ < /k/, +-- a reversible circuit /ORACLE[sub c](a,b,r)/. + +data Oracle = Oracle { + n :: Int, + m :: Int, + k :: Int, + entrance :: Boollist, + oraclefun :: Int -> (Qulist, Qulist, Qubit) -> Circ () +} + +-- | Convert a "Alternative".'Oracle' into a "BWT".'BWT.Oracle'. +convert_oracle :: Oracle -> BWT.Oracle +convert_oracle Oracle { n=n, m=m, k=k, entrance=e, oraclefun=f1 } = + BWT.Oracle { BWT.n=n, BWT.m=m, BWT.k=k, BWT.entrance=e, BWT.oraclefun=f2 } + where + f2 c (a, b, r) = f1 c (qulist_of_qureg_te a, qulist_of_qureg_te b, r) + +-- ====================================================================== +-- * Top-level algorithm + +-- | Do a quantum random walk on the binary welded tree given by the +-- oracle, for /s/ times steps of length /dt/. Return a bit list +-- corresponding to the probable exit label. This is a more +-- functional implementation of 'BWT.qrwbwt' from the module "BWT". +-- +-- Note: This implementation does not rely on the oracle being +-- self-inverse, and therefore only requires that +-- +-- > ORACLE[sub c](a, 0, 0) = (a, v[sub c](a), f[sub c](a)), +-- +-- rather than the more general property +-- +-- > ORACLE[sub c](a, b, r) = (a, b ⊕ v[sub c](a), r ⊕ f[sub c](a)). +-- +-- This gives us the freedom to build more efficient oracles, where +-- appropriate. +qrwbwt :: Oracle -> Timestep -> Int -> Circ Bitlist +qrwbwt oracle dt s = do + comment (printf "ENTER: qrwbwt (dt=%.3e, s=%d)" dt s) + -- Initialize a to the entrance label. + a <- qinit (entrance oracle) + + -- Run the Hamiltonian /s/ times for time step /dt/. + replicateM s $ hamiltonian dt oracle a + + -- Measure /a/. + exit <- measure a + comment_with_label "EXIT: qrwbwt" exit "exit" + return exit + +-- | Apply one round of the Hamiltonian for time step /dt/ to /a/. +hamiltonian :: Timestep -> Oracle -> Qulist -> Circ () +hamiltonian dt oracle a = do + comment_with_label "ENTER: hamiltonian" a "a" + for 0 ((k oracle)-1) 1 $ \c -> do + -- for c from 0 to k-1 + + -- create ancillas b and r + with_ancilla_list (length a) $ \b -> do + with_ancilla $ \r -> do + + -- perform computations + (oraclefun oracle) c (a,b,r) + time_step dt (a,b,r) + reverse_generic_imp ((oraclefun oracle) c) (a,b,r) + -- "reverse" here is not quite GFI + comment_with_label "EXIT: hamiltonian" a "a" + +-- | Apply the diffusion step to /(a,b,r)/. Here /a/ and /b/ must be +-- of equal length. +time_step :: Timestep -> (Qulist, Qulist, Qubit) -> Circ () +time_step dt (a,b,r) = do + comment_with_label "ENTER: time_step" (a,b,r) ("a","b","r") + with_ancilla $ \h -> do + basischange (a,b,h) + controlledExpGate (dt,r,h) + (reverse_generic_imp basischange) (a,b,h) + comment_with_label "EXIT: time_step" (a,b,r) ("a","b","r") + +-- | Apply the basis change from Figure 3 of \[Childs et al.\] to /a/, +-- /b/, and /h/. Here /a/ and /b/ must be of equal length. +basischange :: (Qulist, Qulist, Qubit) -> Circ () +basischange (a,b,h) = do + comment_with_label "ENTER: basischange" (a,b,h) ("a","b","h") + -- apply W gates + zipWithM_ gate_W a b + -- apply doubly-controlled not-gates + zipWithM_ (dc_not h) a b + comment_with_label "EXIT: basischange" (a,b,h) ("a","b","h") + where + dc_not h x y = qnot_at h `controlled` (x .==. 1 .&&. y .==. 0) + +-- | Compute the required number of iterations as a function of ε and +-- /dt/. +-- +-- Inputs: /n/ is the tree depth, ε is the desired precision, /dt/ is +-- the simulation time step. Intermediate values: /t/ is the +-- simulation time. Output: /s/, the upper bound on the number of +-- simulation time steps. +-- +-- Note: \[Childs et al\] specifies that /t/ should be chosen +-- uniformly at random within the interval 0 < /t/ ≤ /n/[sup 4]\/2ε. +-- Here, for simplicity, we just use /t/ = ⌊/n/[sup 4]\/2ε⌋. Also note +-- that this function is for information only, as it is not actually +-- used. Users should specify /s/ directly. +compute_steps :: Int -> Double -> Double -> Int +compute_steps n epsilon dt = + floor (t / dt) + where + t = fromIntegral (n * n * n * n) / (2.0 * epsilon) + +-- ====================================================================== +-- * Oracle implementations + +-- ** Blackbox oracle + +-- | A blackbox oracle for testing. This just produces a labelled box +-- in place of the actual oracle circuit. The argument is the tree +-- height. +oracle_blackbox :: Int -> Oracle +oracle_blackbox n = + let m = n+2 in + Oracle { + n = n, + m = m, + k = 4, + entrance = boollist_of_int_bh (n+2) 1, + oraclefun = \c (a, b, r) -> + do + named_gate_at ("O(" ++ show c ++ ")") (a ++ b ++ [r]) + return () + } + +-- ---------------------------------------------------------------------- +-- ** A simple \"exponential\" oracle. + +-- | This oracle, which works only for the fixed tree height 3, works +-- by explicitly listing all the edges. It serves only to illustrate +-- how the edge information is encoded. Listing all edges explicitly +-- obviously would not scale well to larger graphs. +oracle_simple :: Oracle +oracle_simple = + let n = 3 + m = 5 + k = 4 + + invalid = 0 -- also works correctly for invalid = 31 + invalid_vec = boollist_of_int_bh m invalid + + green = 0 + blue = 1 + red = 2 + black = 3 + + edges :: Int -> [(Int, Int)] + edges 0 = [(1,3), (2,5), (4,8), (6,12), (7,15), (9,17), (10,18), + (13,21), (19,25), (22,27), (24,28), (26,29)] + edges 1 = [(2,4), (3,6), (5,10), (7,14), (8,16), (11,19), (12,20), + (17,24), (21,26), (23,27), (25,28), (29,30)] + edges 2 = [(1,2), (3,7), (4,9), (5,11), (6,13), (14,22), (15,23), + (16,24), (18,25), (20,26), (27,29), (28,30)] + edges 3 = [(8,17), (9,18), (10,19), (11,20), (12,21), (13,22), + (14,23), (15,16)] + edges n = error ("oracle_simple: illegal color: " ++ show n) + + -- apply an (a,n1)-controlled not operation to (v,n2) + multi_controlled_multi_not :: Int -> (Qulist, Qulist) -> (Int, Int) -> Circ () + multi_controlled_multi_not m (a,v) (n1, n2) = do + let vec1 = boollist_of_int_bh m n1 + let vec2 = boollist_of_int_bh m n2 + bool_controlled_not v vec2 `controlled` a .==. vec1 + return () + + -- the O_c circuit + oracle_O :: Int -> (Qulist, Qulist) -> Circ () + oracle_O c (a,v) = do + let e = edges c + foreach e $ \(n1, n2) -> do + multi_controlled_multi_not m (a,v) (n1, invalid `xor` n2) + multi_controlled_multi_not m (a,v) (n2, invalid `xor` n1) + + -- the B_c circuit + oracle_B :: (Qulist, Qulist) -> Circ () + oracle_B (v,b) = + for 0 (m-1) 1 $ \i -> do + qnot_at (b !! i) `controlled` (v !! i) .==. 1 + + -- the R_c circuit + oracle_R :: (Qulist, Qubit) -> Circ () + oracle_R (v,r) = do + qnot_at r `controlled` v .==. invalid_vec + + -- the oracle circuit + oraclefun :: Int -> (Qulist, Qulist, Qubit) -> Circ () + oraclefun c (a,b,r) = do + comment_with_label "ENTER: oracle_simple" (a,b,r) ("a","b","r") + with_ancilla_init invalid_vec $ \v -> do + oracle_O c (a,v) + oracle_B (v,b) + oracle_R (v,r) + oracle_O c (a,v) + comment_with_label "EXIT: oracle_simple" (a,b,r) ("a","b","r") + + in + + -- return the oracle object + Oracle { n = n, + m = m, + k = k, + entrance = boollist_of_int_bh m 1, + oraclefun = oraclefun + } + +-- ====================================================================== +-- ** Alternate implementations of the \"orthodox\" oracle + +-- ---------------------------------------------------------------------- +-- *** Classical implementation + +-- $ In this section, we first implement the oracle function +-- /v[sub c](a)/ as a classical boolean function. This implementation +-- is just for reference, and attempts to be neither efficient nor +-- quantum. It can, however, be used as a specification to test the +-- actual quantum oracles against. +-- +-- Both the classical circuit implementation (below) and the Template +-- Haskell implementation (in the module "BWT.Template") were derived +-- from this. +-- +-- We start with several auxiliary functions. + +-- | The type of nodes: a pair of a tree bit and a node address. +type Node = (Bool, [Bool]) + +-- | Convert integers to nodes, mainly for testing. +node_of_int :: Int -> Int -> Node +node_of_int m a = node_of_boollist (boollist_of_int_bh m a) + +-- | Convert nodes to integers, mainly for testing. +int_of_node :: Node -> Int +int_of_node n = int_of_boollist_unsigned_bh (boollist_of_node n) + +-- | Convert a bit vector to a node. +node_of_boollist :: [Bool] -> Node +node_of_boollist (t:a) = (t,a) +node_of_boollist [] = error "node_of_boollist: empty boollist" + +-- | Convert a node to a bit vector. +boollist_of_node :: Node -> [Bool] +boollist_of_node (t,a) = t:a + +-- | Input a node /a/ and return the parent of /a/. We assume that /a/ +-- is not a root or invalid. +parent :: Node -> Node +parent (t, aa) = (t, False : init aa) + +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True', +-- respectively). Assumes that /a/ is not a leaf. +childintree :: Node -> Bool -> Node +childintree (t, h:aa) childbit = (t, aa ++ [childbit]) +childintree _ _ = error "childintree: invalid node" + +-- | @'bit_adder' 'False'@ is a one-bit adder, and @'bit_adder' 'True'@ is +-- a one-bit subtracter (i.e., add the 2's complement of /y/). +bit_adder :: Bool -> (Bool, Bool, Bool) -> (Bool, Bool) +bit_adder sign (carry, x, y) = (carry', z) + where + y' = y `bool_xor` sign + z = carry `bool_xor` x `bool_xor` y' + carry' = majority carry x y' + majority a b c = if a==b then a else c + +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit; /a/ +-- is the highest bit and /aa/ is the remaining /n/ bits) and a sign +-- /s/ (where 'True' = negative, 'False' = positive). Return +-- /a/:(/aa/ + /s/ * /f/). The first input is the /n/-bit welding +-- vector /f/ (a parameter to the oracle). Note that /f/ is a +-- parameter and /s/, /aa/ are inputs. +doweld1 :: Boollist -> Bool -> [Bool] -> [Bool] +doweld1 f s (a:aa) = a : aa' where + aa' = snd $ fold_right_zip (bit_adder s) (s, aa, f) +doweld1 f s [] = error "doweld1: invalid node" + +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit), and +-- return /a/:(/aa/ ⊕ /g/). The first input is the /n/-bit welding +-- vector /g/ (a parameter to the oracle). +doweld0 :: Boollist -> [Bool] -> [Bool] +doweld0 g (a:aa) = a : aa' where + aa' = g `boollist_xor` aa +doweld0 g [] = error "doweld0: invalid node" + +-- | Input a leaf node /a/ and return the left or right weld of /a/ in +-- the other tree (depending on whether the /weldbit/ is 'False' or +-- 'True'). Assumes that /a/ is a leaf. +weld :: Boollist -> Boollist -> Node -> Bool -> Node +weld f g (t, aa) weldbit = (not t, bb) + where + bb = if weldbit + then doweld1 g t aa + else doweld0 f aa + +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True'. This +-- works for leaf and non-leaf nodes. +child :: Boollist -> Boollist -> Node -> Bool -> Node +child f g (t, aa) childbit = + case aa of + True : _ -> -- This is a leaf + weld f g (t, aa) childbit + False : _ -> -- This is not a leaf + childintree (t, aa) childbit + _ -> error "child: invalid node" + +-- | Input a node address (without the tree bit) and return the parity +-- of the node level expressed as a boolean either 'False' or +-- 'True'. Leaves have parity 'False', and other levels have +-- alternating parities. In other words: count the number of leading +-- zeros modulo 2. +level_parity :: [Bool] -> Bool +level_parity [] = False +level_parity (h:t) = if h then False else not (level_parity t) + +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node address is invalid. In other words, return 'True' iff the +-- list consists of all 0's. +is_zero :: [Bool] -> Bool +is_zero [] = True +is_zero (h:t) = if h then False else is_zero t + +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node is a root or invalid. In other words, check whether all +-- digits but the last are 0's. +is_root :: [Bool] -> Bool +is_root [] = True +is_root (h:[]) = True +is_root (h:t) = if h then False else is_root t + +-- | @'v_function' f g c a@: returns /v/[sub /c/](/a/), the label of the +-- node connected to /a/ by an edge of color /c/, or 'Nothing' if +-- there is no such node. The parameters /f/ and /g/ encode the +-- welding functions, and are lists of length /n/. /c/ is a color in +-- the range 0..3, and /a/ is an (/n/+2)-bit node label. +v_function :: Boollist -> Boollist -> Int -> Node -> Maybe Node +v_function f g c a = + let (t,aa) = a + bc_hi = level_parity aa + z = is_zero aa + e = is_root aa + a1 = if last aa then True else False + [c_hi, c_lo] = boollist_of_int_bh 2 c + [cbc_hi, cbc_lo] = [c_hi `bool_xor` bc_hi, c_lo] + in + if not e && [cbc_hi, cbc_lo] == [True, a1] then Just(parent a) else + if not z && cbc_hi == False then Just(child f g a cbc_lo) else + Nothing + +-- ---------------------------------------------------------------------- +-- *** Auxiliary functions + +-- | The type of nodes: a pair of a tree bit and a node address. +type CNode = (Bit, Bitlist) + +-- | Like 'CNode', but uses qubits instead of classical bits. +type QNode = (Qubit, [Qubit]) + +-- | Convert a 'Qulist' to a 'QNode'. +qnode_of_qulist :: Qulist -> QNode +qnode_of_qulist (t:a) = (t,a) +qnode_of_qulist [] = error "qnode_of_qulist: empty list" + +-- | Convert a 'Bitlist' to a 'CNode'. +cnode_of_bitlist :: Bitlist -> CNode +cnode_of_bitlist (t:a) = (t,a) +cnode_of_bitlist [] = error "cnode_of_bitlist: empty list" + +-- | Exclusive or operation on bit vectors. +cboollist_xor :: Bitlist -> Bitlist -> Circ Bitlist +cboollist_xor = zipWithM (\x y -> cgate_xor [x,y]) + +-- ---------------------------------------------------------------------- +-- *** Classical circuit implementation + +-- $ We now implement the oracle function v[sub c](a) as a classical +-- circuit, with /c/ as a parameter. We don't try to be clever or +-- efficient yet. The implementation follows the \"classical +-- implementation\" above, but must be reformulated due to the need to +-- work within the 'Circ' monad. + +-- | Input a node /a/ and return the parent of /a/. We assume that /a/ +-- is not a root or invalid. +cparent :: CNode -> Circ CNode +cparent (t, aa_in) = do + comment_with_label "ENTER: cparent" (t, aa_in) ("t", "aa_in") + false <- cinit False + let aa_out = false : init aa_in + comment_with_label "EXIT: cparent" (t, aa_out) ("t", "aa_out") + return (t, aa_out) + +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True', +-- respectively). Assumes that /a/ is not a leaf. +cchildintree :: CNode -> Bit -> Circ CNode +cchildintree (t, node_in@(h:aa)) childbit = do + comment_with_label "ENTER: cchildintree" (t, node_in) ("t", "node_in") + let node_out = aa ++ [childbit] + comment_with_label "EXIT: cchildintree" (t, node_out) ("t", "node_out") + return (t, node_out) +cchildintree _ _ = error "cchildintree: invalid node" + +-- | @'bit_adder' 'False'@ is a one-bit adder, and @'bit_adder' 'True'@ is +-- a one-bit subtracter (i.e., add the 2's complement of /y/). +cbit_adder :: Bit -> (Bit, Bit, Bit) -> Circ (Bit, Bit) +cbit_adder sign (carry_in, x, y) = do + comment_with_label "ENTER: cbit_adder" (sign, carry_in, x, y) ("sign", "carry_in", "x", "y") + y' <- cgate_xor [y, sign] + z <- cgate_xor [carry_in, x, y'] + carry_out <- cmajority carry_in x y' + comment_with_label "EXIT: cbit_adder" (carry_out, z) ("carry_out", "z") + return (carry_out, z) + where + cmajority a b c = do + cond <- cgate_eq a b + cgate_if cond a c + +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit; /a/ +-- is the highest bit and /aa/ is the remaining /n/ bits) and a sign +-- /s/ (where 'True' = negative, 'False' = positive). Return +-- /a/:(/aa/ + /s/ * /f/). The first input is the /n/-bit welding +-- vector /f/ (a parameter to the oracle). Note that /f/ is a +-- parameter and /s/, /aa/ are inputs. +cdoweld1 :: Boollist -> Bit -> Bitlist -> Circ Bitlist +cdoweld1 f s node_in@(a:aa) = do + comment_with_label "ENTER: cdoweld1" (s, node_in) ("s", "node_in") + f' <- cinit f + (_,aa') <- fold_right_zipM (cbit_adder s) (s, aa, f') + let node_out = a : aa' + comment_with_label "EXIT: cdoweld1" node_out "node_out" + return node_out +cdoweld1 f s [] = error "cdoweld1: invalid node" + +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit), and +-- return /a/:(/aa/ ⊕ /g/). The first input is the /n/-bit welding +-- vector /g/ (a parameter to the oracle). +cdoweld0 :: Boollist -> Bitlist -> Circ Bitlist +cdoweld0 g node_in@(a:aa) = do + comment_with_label "ENTER: cdoweld0" node_in "node_in" + g' <- cinit g + aa' <- g' `cboollist_xor` aa + let node_out = a:aa' + comment_with_label "EXIT: cdoweld0" node_out "node_out" + return node_out +cdoweld0 g [] = error "cdoweld0: invalid node" + +-- | Input a leaf node /a/ and return the left or right weld of /a/ in +-- the other tree (depending on whether the /weldbit/ is 'False' or +-- 'True'). Assumes that /a/ is a leaf. +cweld :: Boollist -> Boollist -> CNode -> Bit -> Circ CNode +cweld f g node_in@(t, aa) weldbit = do + comment_with_label "ENTER: cweld" (node_in, weldbit) ("node_in", "weldbit") + bb <- circ_if weldbit ( + cdoweld1 g t aa + )( + cdoweld0 f aa + ) + t' <- cgate_not t + let node_out = (t', bb) + comment_with_label "EXIT: cweld" node_out "node_out" + return node_out + +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True'. This +-- works for leaf and non-leaf nodes. +cchild :: Boollist -> Boollist -> CNode -> Bit -> Circ CNode +cchild f g node_in@(t, a:aa) childbit = do + comment_with_label "ENTER: cchild" (node_in, childbit) ("node_in", "childbit") + node_out <- circ_if a ( + -- This is a leaf + cweld f g (t, a:aa) childbit + )( + -- This is not a leaf + cchildintree (t, a:aa) childbit + ) + comment_with_label "EXIT: cchild" node_out "node_out" + return node_out + +cchild f g (t, _) childbit = + error "cchild: invalid node" + +-- | Input a node address (without the tree bit) and return the parity +-- of the node level expressed as a boolean either 'False' or +-- 'True'. Leaves have parity 'False', and other levels have +-- alternating parities. In other words: count the number of leading +-- zeros modulo 2. +clevel_parity :: Bitlist -> Circ Bit +clevel_parity node = do + comment_with_label "ENTER: clevel_parity" node "node" + parity <- clevel_parity_rec node + comment_with_label "EXIT: clevel_parity" parity "parity" + return parity + + where + clevel_parity_rec :: Bitlist -> Circ Bit + clevel_parity_rec [] = cinit False + clevel_parity_rec (h:t) = do + r <- clevel_parity_rec t + circ_if h ( + cinit False + )( + cgate_not r + ) + +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node address is invalid. In other words, return 'True' iff the +-- list consists of all 0's. +cis_zero :: Bitlist -> Circ Bit +cis_zero node = do + comment_with_label "ENTER: cis_zero" node "node" + is_zero <- cis_zero_rec node + comment_with_label "EXIT: cis_zero" is_zero "is_zero" + return is_zero + + where + cis_zero_rec :: Bitlist -> Circ Bit + cis_zero_rec [] = cinit True + cis_zero_rec (h:t) = do + circ_if h ( + cinit False + )( + cis_zero_rec t + ) + +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node is a root or invalid. In other words, check whether all +-- digits but the last are 0's. +cis_root :: Bitlist -> Circ Bit +cis_root node = do + comment_with_label "ENTER: cis_root" node "node" + is_root <- cis_root_rec node + comment_with_label "EXIT: cis_root" is_root "is_root" + return is_root + + where + cis_root_rec :: Bitlist -> Circ Bit + cis_root_rec [] = cinit True + cis_root_rec (h:[]) = cinit True + cis_root_rec (h:t) = do + circ_if h ( + cinit False + )( + cis_root_rec t + ) + +-- | @'cv_function' f g c a@: returns /v/[sub /c/](/a/), the label of the +-- node connected to /a/ by an edge of color /c/, or 'Nothing' if +-- there is no such node. The parameters /f/ and /g/ encode the +-- welding functions, and are lists of length /n/. /c/ is a color in +-- the range 0..3, and /a/ is an (/n/+2)-bit node label. +-- +-- We currently implement @'Maybe' 'CNode'@ as an indexed union, and +-- specifically as @('CNode','Bit')@. When /Bit/='True', the value of +-- 'CNode' is undefined (doesn't matter); in particular, this value +-- may contain garbage. +cv_function :: Boollist -> Boollist -> Int -> CNode -> Circ (CNode,Bit) +cv_function f g color a = do + comment_with_label (printf "ENTER: cv_function (color=%d)" color) a "a" + let (t,aa) = a + bc_hi <- clevel_parity aa + z <- cis_zero aa + e <- cis_root aa + let a1 = last aa + let [c_hi', c_lo'] = boollist_of_int_bh 2 color + c_hi <- cinit c_hi' + c_lo <- cinit c_lo' + cbc_hi <- cgate_xor [c_hi, bc_hi] + let cbc_lo = c_lo + not_e <- cgate_not e + cbc_lo_eq_a1 <- cgate_eq cbc_lo a1 + cond1 <- cgate_and [not_e, cbc_hi, cbc_lo_eq_a1] + (b, invalid) <- circ_if cond1 ( + do + cparent_a <- cparent a + false <- cinit False + return (cparent_a, false) + )( + do + cchild_a_cbc_lo <- cchild f g a cbc_lo + not_z <- cgate_not z + cbc_hi_eq_false <- cgate_not cbc_hi + valid <- cgate_and [not_z, cbc_hi_eq_false] + not_valid <- cgate_not valid + -- a slight optimization here: we return garbage in the + -- first register if not_valid == True + return (cchild_a_cbc_lo, not_valid) + ) + comment_with_label (printf "EXIT: cv_function (color=%d)" color) (b, invalid) ("b", "invalid") + return (b, invalid) + +-- ====================================================================== +-- *** Oracle abstraction + +-- | The classical oracle implementation, packaged into the 'Oracle' +-- abstraction. This oracle has two parameters, namely the welding +-- vectors /f/ and /g/. Note: this oracle has not been optimized +-- whatsoever. +oracle_classical :: Boollist -> Boollist -> Oracle +oracle_classical f g = + Oracle { n = n, + m = m, + k = k, + entrance = entrance, + oraclefun = oraclefun + } where + n = length f + m = n+2 + k = 4 + entrance = boollist_of_int_bh m 1 + + oraclefun :: Int -> (Qulist, Qulist, Qubit) -> Circ () + oraclefun color (a,b,r) = do + let an = qnode_of_qulist a + let bn = qnode_of_qulist b + (classical_to_quantum . classical_to_reversible) (cv_function f g color) (an, (bn, r)) + return () + +-- ====================================================================== +-- * Testing functions + +-- | Output the list of colored edges as computed by the classical +-- 'v_function', for some arbitrary choice of /f/ and /g/ and /n/=3. +main_edges1 :: IO() +main_edges1 = mapM_ output (sample_all0 (127,3)) + where + f = take 5 (True : False : f) + g = take 5 (False : True : g) + + output :: (Int,Int) -> IO() + output (a,c) = + case v_function f g c (node_of_int 7 a) of + Nothing -> printf "%d ---%d---> None\n" a c + Just b -> printf "%d ---%d---> %d\n" a c (int_of_node b) + +-- | For debugging: 'circfun' is similar to 'v_function', except it +-- works by calling 'cv_function' to assemble the circuit, then +-- simulates it. This is for testing whether the assembled circuit is +-- correct. Returns @('Bool', 'Node')@ instead of @'Maybe' 'Node'@, so +-- that we can see any garbage that is output in case of an invalid +-- node. +circfun :: Boollist -> Boollist -> Int -> Node -> (Node, Bool) +circfun f g color nd = + run_classical_generic (cv_function f g color) nd + +-- | Output the list of colored edges as computed by simulating the +-- circuit 'cv_function', for some arbitrary choice of /f/ and /g/ and +-- /n/=3. This is like 'main_edges1', except it actually assembles and +-- simulates the classical circuit. +main_edges2 :: IO() +main_edges2 = mapM_ output (sample_all0 (127,3)) + where + f = take 5 (True : False : f) + g = take 5 (False : True : g) + output :: (Int,Int) -> IO() + output (a,c) = + case circfun f g c (node_of_int 7 a) of + (node, False) -> printf "%d ---%d---> %d\n" a c (int_of_node node) + (garbage, True) -> printf "%d ---%d---> None (%d)\n" a c (int_of_node garbage) + +-- | Graphically output the classical oracle circuit for color /c/, +-- using /n/ from the oracle data structure, and for some arbitrary +-- /f/ and /g/. +main_oraclec :: Format -> BWT.Oracle -> Int -> IO() +main_oraclec format oracle color = + print_generic format circuit cnode_shape + where + m' = BWT.m oracle + n' = BWT.n oracle + f = take n' (True : False : f) + g = take n' (False : True : g) + cnode_shape = cnode_of_bitlist (replicate m' bit) + circuit n = cv_function f g color n + +-- | Like 'main_oraclec', except it rewrites the classical circuit in +-- terms of Toffoli gates. +main_oracle2 :: Format -> BWT.Oracle -> Int -> IO() +main_oracle2 format oracle color = + print_generic format circuit cnode_shape + where + m' = BWT.m oracle + n' = BWT.n oracle + f = take n' (True : False : f) + g = take n' (False : True : g) + cnode_shape = cnode_of_bitlist (replicate m' bit) + circuit n = classical_to_cnot (cv_function f g color n) + +-- | Like 'main_oraclec', except it makes the classical circuit +-- reversible first. +main_oracle3 :: Format -> BWT.Oracle -> Int -> IO() +main_oracle3 format oracle color = + print_generic format circuit (cnode_shape, (cnode_shape, qubit)) + where + m' = BWT.m oracle + n' = BWT.n oracle + f = take n' (True : False : f) + g = take n' (False : True : g) + cnode_shape = qnode_of_qulist (replicate m' qubit) + circuit = (classical_to_quantum . classical_to_reversible) (cv_function f g color) + +-- | Output the top-level circuit for the binary welded tree algorithm +-- with the classical oracle, using some arbitrary welding vectors /f/ +-- and /g/, and /s/=1. +main_qrwbwt :: IO() +main_qrwbwt = + print_simple EPS (qrwbwt (oracle_classical f g) dt 1) + where + f = [False, False, True] + g = [True, False, True] + dt = pi/180 diff --git a/dist/build/Quipper/Algorithms/BWT/BWT.hs b/dist/build/Quipper/Algorithms/BWT/BWT.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/BWT/BWT.hs @@ -0,0 +1,604 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/BWT/BWT.hs" #-} +-- | This module provides an implementation of the main binary welded +-- tree algorithm and oracle, using a more-or-less imperative +-- programming style. We abstract the oracle into a data type, so that +-- different oracles can be plugged into the main algorithm. + +module Quipper.Algorithms.BWT.BWT where + +-- import other Quipper stuff +import Quipper +import Quipper.Algorithms.BWT.Definitions + +import Quipper.Libraries.Qureg +import Quipper.Libraries.Decompose + +import Quipper.Utils.Auxiliary + +import Text.Printf + +-- ====================================================================== +-- * Oracle abstraction + +-- | A data structure to hold an oracle. The binary welded tree +-- algorithm is parametric on an oracle. An oracle encodes a graph, +-- and provides the following information: the tree depth /n/ (in the +-- above example: 3), the label length /m/ (in bits; 5 in the above +-- example), the number of edge colors /k/, the entrance label +-- /ENTRANCE/, and for each color 0 ≤ /c/ < /k/, a reversible circuit +-- /ORACLE/[sub /c/](/a/,/b/,/r/). On basis vectors, this circuit +-- encodes the edge information in the following sense: +-- +-- > ORACLE[sub c](a, b, r) = (a, b ⊕ v[sub c](a), r ⊕ f[sub c](a)), +-- +-- where /f/[sub /c/](/a/) is 1 if the node /a/ is connected to an +-- edge of color /c/, and 0 otherwise; and /v/[sub /c/](a) is the +-- node label connected to node /a/ along an edge of color /c/ (if +-- any), and arbitrary otherwise. +-- +-- Not all available node labels need to be used (for example, 0 and +-- 16 are unused in the graph in the above illustration). + +data Oracle = Oracle { + n :: Int, + m :: Int, + k :: Int, + entrance :: Boollist, + oraclefun :: Int -> (Qureg, Qureg, Qubit) -> Circ () +} + +-- ====================================================================== +-- * Top-level algorithm + +-- | The main loop of the binary welded tree algorithm. +-- +-- @qrwbwt oracle s dt@: Do a quantum random walk on the binary welded +-- tree given by the oracle /oracle/, for /s/ times steps of length +-- /dt/. Returns a bit list corresponding to the computed exit node +-- label. + +qrwbwt :: Oracle -> Int -> Timestep -> Circ [Bit] +qrwbwt oracle s dt = do + comment (printf "ENTER: qrwbwt (s=%d, dt=%.3e)" s dt) + -- initialize a to the entrance label + a <- qinit_register (entrance oracle) + with_ancilla_reg (m oracle) $ \b -> do + with_ancilla $ \r -> do + loopM_boxed_if (s > 1) "qrwbwt_loop" s (a,b,r) $ \(a,b,r) -> do + for 0 (k oracle-1) 1 $ \c -> do + (oraclefun oracle) c (a, b, r) + timestep (a, b, r, dt, m oracle) + (oraclefun oracle) c (a, b, r) + endfor + return (a,b,r) + endfor + exit <- qmeasure_register a + comment_with_label "EXIT: qrwbwt" exit "exit" + return exit + +-- | @timestep (a, b, r, dt, m)@: Perform a single time step /dt/ of +-- the quantum walk. This is done by iterating through each of the +-- available edge colors, and performing a diffusion step for each +-- color. Here, /a/ is an /m/-qubit registers holding (a superposition +-- of) the current node label. /b/ is an /m/-qubit ancilla register, +-- and /r/ is an ancilla qubit. Both /b/ and /r/ are expected to be +-- initialized to |0〉 by the caller, and will be returned in state +-- |0〉. +timestep :: (Qureg, Qureg, Qubit, Timestep, Int) -> Circ () +timestep (a, b, r, dt, m) = do + comment_with_label "ENTER: timestep" (a,b,r) ("a","b","r") + with_ancilla $ \h -> do + for 0 (m-1) 1 $ \i -> do + wGate (a.!(i), b.!(i)) + endfor + for 0 (m-1) 1 $ \i -> do + toffoliGate (a.!(i), b.!(i), h) + endfor + controlledExpGate (dt, r, h) + for (m-1) 0 (-1) $ \i -> do + toffoliGate (a.!(i), b.!(i), h) + endfor + for (m-1) 0 (-1) $ \i -> do + wGateInverse (a.!(i), b.!(i)) + endfor + comment_with_label "EXIT: timestep" (a,b,r) ("a","b","r") + return () + +-- ====================================================================== +-- * Oracle implementation + +-- $ The functions in this section implement a particular oracle for a +-- binary welded tree. The oracle is parametric on: +-- +-- * the tree depth /n/; +-- +-- * two \"welding vectors\" /f/ and /g/, specifying how the leaves of +-- the two binary trees are connected to each other. Specifically, /f/ +-- and /g/ encode the permutations of leaves given by a ↦ a ⊕ f and +-- a ↦ a + g, respectively, where \"⊕\" denotes bitwise exclusive or, +-- and \"+\" denotes binary addition. + +-- ---------------------------------------------------------------------- +-- ** Oracle subroutines + +-- | The top-level oracle circuit. The arguments are of the form (/a/, +-- /b/, /r/, /color/, /f/, /g/, /n/), where /a/, /b/ are quantum +-- registers of length /n/+2, /color/ is a boolean register of length +-- 2, and /f/ and /g/ are boolean registers of length /n/. +oracle :: (Qureg, Qureg, Qubit, Boolreg, Boolreg, Boolreg, Int) -> Circ () +oracle (a, b, r, color, f, g, n) = do + let c = int_of_boolreg_unsigned_le color :: Int + comment_with_label (printf "ENTER: oracle (color=%d)" c) (a,b,r) ("a","b","r") + with_ancilla $ \root -> do + with_ancilla $ \even -> do + with_ancilla $ \isparent -> do + with_ancilla $ \ischild -> do + with_ancilla $ \direction -> do + with_ancilla $ \ismatch -> do + parseNodeRoot (a, root, even, n) + parseNodeEven (a, even, n) + testIsParent (a, root, even, isparent, color, n, 1, ismatch) + testIsChild (even, ischild, direction, color, n) + setParent (a, b, isparent, n) + setChild (a, b, ischild, direction, f, g, n) + with_controls (isparent .==. 0 .&&. ischild .==. 0) $ do { + qnot_at r + } + testIsChild (even, ischild, direction, color, n) + testIsParent (a, root, even, isparent, color, n, 0, ismatch) + parseNodeEven (a, even, n) + parseNodeRoot (a, root, even, n) + comment_with_label (printf "EXIT: oracle (color=%d)" c) (a,b,r) ("a","b","r") + return () + +-- | Input a node label /a/ of length at least /n/+1. Negate both +-- /root/ and /even/ if /a/ is a root node. +parseNodeRoot :: (Qureg, Qubit, Qubit, Int) -> Circ () +parseNodeRoot (a, root, even, n) = do + comment_with_label "ENTER: parseNodeRoot" (a, root, even) ("a", "root", "even") + with_ancilla_reg (n+1) $ \scratch -> do + for n 1 (-1) $ \index -> do + with_controls (scratch.!(index) .==. 0 .&&. a.!(index) .==. 1) $ do { + qnot_at (scratch.!(index - 1)) + } + with_controls (scratch.!(index) .==. 1) $ do { + qnot_at (scratch.!(index - 1)) + } + endfor + with_controls (scratch.!(0) .==. 0) $ do { + qnot_at root; + qnot_at even + } + for 1 n 1 $ \index -> do + with_controls (scratch.!(index) .==. 1) $ do { + qnot_at (scratch.!(index - 1)) + } + with_controls (scratch.!(index) .==. 0 .&&. a.!(index) .==. 1) $ do { + qnot_at (scratch.!(index-1)) + } + endfor + comment_with_label "EXIT: parseNodeRoot" (a, root, even) ("a", "root", "even") + return () + +-- | Input a node label /a/ of length at least /n/+1. Negate /even/ +-- if the node /a/ occurs at an even height in the tree. +parseNodeEven :: (Qureg, Qubit, Int) -> Circ () +parseNodeEven (a, even, n) = do + comment_with_label "ENTER: parseNodeEven" (a, even) ("a", "even") + with_ancilla_reg (n+1) $ \scratch -> do + for n 1 (-1) $ \index -> do + with_controls (scratch.!(n) .==. 0 .&&. a.!(index) .==. 1) $ do { + qnot_at (scratch.!(index-1)); + with_controls (Prelude.even index) $ do { + qnot_at even + } + } + with_controls (scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(n)) + } + endfor + for 1 n 1 $ \index -> do + with_controls (scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(n)) + } + with_controls (scratch.!(n) .==. 0 .&&. a.!(index) .==. 1) $ do { + qnot_at (scratch.!(index-1)) + } + endfor + comment_with_label "EXIT: parseNodeEven" (a, even) ("a", "even") + return () + +-- | Input a node label /a/ of length at least 1, and flags /root/ +-- and /even/ describing whether /a/ is a root and at an even level, +-- respectively. Negate /isparent/ if /a/ has a parent of color +-- /color/ in the tree. +-- +-- The qubit /ismatch/ is an ancilla, and /really/ is either 0 or +-- 1. They are jointly used to control uncomputation, so that the +-- following sequence will compute and then uncompute 'testIsParent': +-- +-- > ismatch <- qinit 0 +-- > testIsParent (a, root, even, isparent, color, n, 1, ismatch) +-- > testIsParent (a, root, even, isparent, color, n, 0, ismatch) +-- > qterm 0 ismatch +testIsParent :: (Qureg, Qubit, Qubit, Qubit, Boolreg, Int, Int, Qubit) -> Circ () +testIsParent (a, root, even, isparent, color, n, really, ismatch) = do + let c = int_of_boolreg_unsigned_le color :: Int + comment_with_label (printf "ENTER: testIsParent (color=%d really=%d)" c really) (a, root, even, isparent, ismatch) ("a", "root", "even", "isparent", "ismatch") + with_controls (really == 0) $ do { + with_controls (root .==. 0 .&&. ismatch .==. 1) $ do { + qnot_at isparent + } + } + if color.!(1) == 1 + then + if color.!(0) == 1 then + with_controls (even .==. 1 .&&. a.!(0) .==. 1) $ do { + qnot_at ismatch + } + else + with_controls (even .==. 1 .&&. a.!(0) .==. 0) $ do { + qnot_at ismatch + } + else + if color.!(0) == 1 then + with_controls (even .==. 0 .&&. a.!(0) .==. 1) $ do { + qnot_at isparent + } + else + with_controls (even .==. 0 .&&. a.!(0) .==. 0) $ do { + qnot_at isparent + } + with_controls (root .==. 0 .&&. ismatch .==. 1) $ do { + qnot_at isparent + } + comment_with_label (printf "EXIT: testIsParent (color=%d really=%d)" c really) (a, root, even, isparent, ismatch) ("a", "root", "even", "isparent", "ismatch") + return () + +-- | Consider a node /a/, and negate /ischild/ if /a/ has a child +-- node of color /color/. Also set /direction/ to indicate whether +-- it is a \"left\" or \"right\" child. Here, /color/ is a boolean +-- register of length 2, representing a color. This function is +-- self-inverse. +testIsChild :: (Qubit, Qubit, Qubit, Boolreg, Int) -> Circ () +testIsChild (even, ischild, direction, color, n) = do + comment_with_label "ENTER: testIsChild" (even, ischild, direction) ("even", "ischild", "direction") + if color.!(1) == 1 + then + with_controls (even .==. 0) $ do { + qnot_at ischild + } + else + with_controls (even .==. 1) $ do { + qnot_at ischild + } + with_controls (color.!(0) == 1) $ do { + qnot_at direction + } + comment_with_label "EXIT: testIsChild" (even, ischild, direction) ("even", "ischild", "direction") + return () + +-- | Input a node label /a/ of length at least /n/+2, and a flag +-- /isparent/ that has been initialized accordingly. Also input a +-- register /b/ of length at least /n/+2, initialized to |0〉. If +-- /isparent/ is set, set /b/ to the node label of the parent of +-- /a/. This is self-inverse. +setParent :: (Qureg, Qureg, Qubit, Int) -> Circ () +setParent (a, b, isparent, n) = do + comment_with_label "ENTER: setParent" (a, b, isparent) ("a", "b", "isparent") + for 0 (n-1) 1 $ \index -> do + with_controls (isparent .==. 1 .&&. a.!(index+1) .==. 1) $ do { + qnot_at (b.!(index)) + } + endfor + with_controls (isparent .==. 1 .&&. a.!(n+1) .==. 1) $ do { + qnot_at (b.!(n+1)) + } + comment_with_label "EXIT: setParent" (a, b, isparent) ("a", "b", "isparent") + return () + +-- | Similar to 'setParent', but set /b/ to the node label of the +-- indicated child of /a/. Here /a/ and /b/ are quantum registers of +-- length at least /n/+2, and /f/ and /g/ are boolean registers of +-- length /n/. +setChild :: (Qureg, Qureg, Qubit, Qubit, Boolreg, Boolreg, Int) -> Circ () +setChild (a, b, ischild, direction, f, g, n) = do + comment_with_label "ENTER: setChild" (a, b, ischild, direction) ("a", "b", "ischild", "direction") + with_ancilla $ \childctrl -> do + with_controls (ischild .==. 1 .&&. a.!(n) .==. 1) $ do { + qnot_at childctrl + } + setWeld (a, b, childctrl, direction, f, g, n) + with_controls (ischild .==. 1) $ do { + qnot_at childctrl + } + setChildInTree (a, b, childctrl, direction, n) + with_controls (ischild .==. 1 .&&. a.!(n) .==. 0) $ do { + qnot_at childctrl + } + comment_with_label "EXIT: setChild" (a, b, ischild, direction) ("a", "b", "ischild", "direction") + return () + +-- | A special case of 'setChild', where the child is inside the same +-- binary tree (i.e., not via the welding). +setChildInTree :: (Qureg, Qureg, Qubit, Qubit, Int) -> Circ () +setChildInTree (a, b, childctrl, direction, n) = do + comment_with_label "ENTER: setChildInTree" (a, b, childctrl, direction) ("a", "b", "childctrl", "direction") + with_controls (childctrl .==. 1 .&&. direction .==. 1) $ do { + qnot_at (b.!(0)) + } + for 1 n 1 $ \index -> do + with_controls (childctrl .==. 1 .&&. a.!(index-1) .==. 1) $ do { + qnot_at (b.!(index)) + } + endfor + with_controls (childctrl .==. 1 .&&. a.!(n+1) .==. 1) $ do { + qnot_at (b.!(n+1)) + } + comment_with_label "EXIT: setChildInTree" (a, b, childctrl, direction) ("a", "b", "childctrl", "direction") + return () + +-- | A special case of 'setChild', where the child is in the opposite +-- binary tree, i.e., we follow one of the welding edges. +setWeld :: (Qureg, Qureg, Qubit, Qubit, Boolreg, Boolreg, Int) -> Circ () +setWeld (a, b, childctrl, direction, f, g, n) = do + comment_with_label "ENTER: setWeld" (a, b, childctrl, direction) ("a", "b", "childctrl", "direction") + with_ancilla $ \weldctrl -> do + with_controls (childctrl .==. 1 .&&. direction .==. 0) $ do { + qnot_at weldctrl + } + doWeld0 (a, b, weldctrl, f, n) + with_controls (childctrl .==. 1) $ do { + qnot_at weldctrl + } + doWeld1 (a, b, weldctrl, g, n) + with_controls (childctrl .==. 1 .&&. direction .==. 1) $ do { + qnot_at weldctrl + } + with_controls (childctrl .==. 1 .&&. a.!(n+1) .==. 1) $ do { + qnot_at (b.!(n+1)) + } + with_controls (childctrl .==. 1) $ do { + qnot_at (b.!(n)); + qnot_at (b.!(n+1)) + } + comment_with_label "EXIT: setWeld" (a, b, childctrl, direction) ("a", "b", "childctrl", "direction") + return () + +-- | Input a node label /a/, and a register /b/ initialized to +-- |0〉. If /weldctrl/ is set, set /b/ to the node connected to /a/ +-- by the welding function /f/. This is self-inverse. Here, /a/ and +-- /b/ are quantum registers of length at least /n/+2, and /f/ is a +-- boolean register of length /n/. +doWeld1 :: (Qureg, Qureg, Qubit, Boolreg, Int) -> Circ () +doWeld1 (a, b, weldctrl, g, n) = do + comment_with_label "ENTER: doWeld1" (a, b, weldctrl) ("a", "b", "weldctrl") + with_ancilla $ \addsub -> do + with_controls (weldctrl .==. 1 .&&. a.!(n+1) .==. 0) $ do { + qnot_at addsub + } + cAddNum (addsub, b, a, g, n) + with_controls (weldctrl .==. 1) $ do { + qnot_at addsub + } + cSubNum (addsub, b, a, g, n) + with_controls (weldctrl .==. 1 .&&. a.!(n+1) .==. 1) $ do { + qnot_at addsub + } + comment_with_label "EXIT: doWeld1" (a, b, weldctrl) ("a", "b", "weldctrl") + return () + +-- | Input a node label /a/, and a register /b/ initialized to +-- |0〉. If /weldctrl/ is set, set /b/ to the node connected to /a/ +-- by the welding function /g/. This is self-inverse. Here, /a/ and +-- /b/ are quantum registers of length at least /n/+2, and /g/ is a +-- boolean register of length /n/. +doWeld0 :: (Qureg, Qureg, Qubit, Boolreg, Int) -> Circ () +doWeld0 (a, b, weldctrl, f, n) = do + comment_with_label "ENTER: doWeld0" (a, b, weldctrl) ("a", "b", "weldctrl") + for 0 (n-1) 1 $ \index -> do + with_controls (weldctrl .==. 1) $ do { + qnot_at (b.!(index)) `controlled` a.!(index) ./=. f.!(index) + } + endfor + comment_with_label "EXIT: doWeld0" (a, b, weldctrl) ("a", "b", "weldctrl") + return () + +-- | This function implements integer addition. Input a quantum +-- register /input/ and a boolean register /num/, representing +-- integers, and a quantum register /out/ initialized to |0〉. If +-- /control/ is set, set /out/ to /input/ + /num/, otherwise do +-- nothing. Here /input/ and /out/ are quantum registers of length at +-- least /n/, /num/ is a boolean register of length /n/. +cAddNum :: (Qubit, Qureg, Qureg, Boolreg, Int) -> Circ () +cAddNum (control, out, input, num, n) = do + comment_with_label "ENTER: cAddNum" (control, out, input) ("control", "out", "input") + -- we represent mask as 1 << maskbit + with_ancilla_reg n $ \scratch -> do + let maskbit = 0 -- invariant: mask = 1 << maskbit + with_controls (control .==. 1 .&&. input.!(0) .==. 1) $ do { + qnot_at (out.!(0)) + } + with_controls (num.!(maskbit) /= 0) $ do { + with_controls (control .==. 1) $ do { + qnot_at (out.!(0)) + }; + with_controls (input.!(0) .==. 1) $ do { + qnot_at (scratch.!(0)) + } + } + for 1 (n-1) 1 $ \index -> do + let maskbit = index -- invariant: mask = 1 << maskbit + with_controls (control .==. 1 .&&. input.!(index) .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. control .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (control .==. 1 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. input.!(index) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (input.!(index) .==. 1 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + endfor + cAddNumClear (control, scratch, input, num, n) + comment_with_label "EXIT: cAddNum" (control, out, input) ("control", "out", "input") + return () + +-- | A helper function for clearing the scratch space used by 'cAddNum'. +cAddNumClear :: (Qubit, Qureg, Qureg, Boolreg, Int) -> Circ () +cAddNumClear (control, scratch, input, num, n) = do + comment_with_label "ENTER: cAddNumClear" (control, scratch, input) ("control", "scratch", "input") + -- we represent mask as 1 << maskbit + for (n-1) 1 (-1) $ \index -> do + let maskbit = index -- invariant: mask = 1 << maskbit + with_controls (num.!(maskbit) /= 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (input.!(index) .==. 1 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. input.!(index) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + endfor + let maskbit = 0 -- invariant: mask = 1 << maskbit + with_controls (num.!(maskbit) /= 0 .&&. input.!(0) .==. 1) $ do { + qnot_at (scratch.!(0)) + } + comment_with_label "EXIT: cAddNumClear" (control, scratch, input) ("control", "scratch", "input") + return () + +-- | Like 'cAddNum', except subtract instead of adding. +cSubNum :: (Qubit, Qureg, Qureg, Boolreg, Int) -> Circ () +cSubNum (control, out, input, num, n) = do + comment_with_label "ENTER: cSubNum" (control, out, input) ("control", "out", "input") + -- we represent mask as 1 << maskbit + with_ancilla_reg n $ \scratch -> do + let maskbit = 0 -- invariant: mask = 1 << maskbit + with_controls (control .==. 1 .&&. input.!(0) .==. 1) $ do { + qnot_at (out.!(0)) + } + with_controls (num.!(maskbit) /= 0) $ do { + with_controls (control .==. 1) $ do { + qnot_at (out.!(0)) + }; + with_controls (input.!(0) .==. 0) $ do { + qnot_at (scratch.!(0)) + } + } + for 1 (n-1) 1 $ \index -> do + let maskbit = index -- invariant: mask = 1 << maskbit + with_controls (control .==. 1 .&&. input.!(index) .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. control .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (control .==. 1 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (out.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. input.!(index) .==. 0) $ do { + qnot_at (scratch.!(index)) + } + with_controls (input.!(index) .==. 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + endfor + cSubNumClear (control, scratch, input, num, n) + comment_with_label "EXIT: cSubNum" (control, out, input) ("control", "out", "input") + return () + +-- | A helper function for clearing the scratch space used by 'cSubNum'. +cSubNumClear :: (Qubit, Qureg, Qureg, Boolreg, Int) -> Circ () +cSubNumClear (control, scratch, input, num, n) = do + comment_with_label "ENTER: cSubNumClear" (control, scratch, input) ("control", "scratch", "input") + -- we represent mask as 1 << maskbit + for (n-1) 1 (-1) $ \index -> do + let maskbit = index -- invariant: mask = 1 << maskbit + with_controls (num.!(maskbit) /= 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (input.!(index) .==. 0 .&&. scratch.!(index-1) .==. 1) $ do { + qnot_at (scratch.!(index)) + } + with_controls (num.!(maskbit) /= 0 .&&. input.!(index) .==. 0) $ do { + qnot_at (scratch.!(index)) + } + endfor + let maskbit = 0 -- invariant: mask = 1 << maskbit + with_controls (num.!(maskbit) /= 0 .&&. input.!(0) .==. 0) $ do { + qnot_at (scratch.!(0)) + } + comment_with_label "EXIT: cSubNumClear" (control, scratch, input) ("control", "scratch", "input") + return () + +-- ---------------------------------------------------------------------- +-- ** The oracle data structure + +-- | This function inputs two welding functions /f/ and /g/, and +-- returns the oracle defined by the preceding functions. +-- +-- We call this the \"orthodox\" oracle, because the implementation +-- follows its specification very closely. For example, it uses a very +-- \"imperative\" programming style. For alternative implementations +-- of this and other oracles, see the modules +-- "Quipper.Algorithms.BWT.Alternative" and "Quipper.Algorithms.BWT.Template". +oracle_orthodox :: Boollist -> Boollist -> Oracle +oracle_orthodox f g = + Oracle { n = n, + m = m, + k = k, + entrance = entrance, + oraclefun = oraclefun + } where + n = length f + m = n+2 + k = 4 + entrance = boollist_of_int_bh m 1 + f_reg = boolreg_of_boollist_te f + g_reg = boolreg_of_boollist_te g + + oraclefun :: Int -> (Qureg, Qureg, Qubit) -> Circ () + oraclefun c (a,b,r) = do + let color = boolreg_of_int_le 2 c + oracle (a, b, r, color, f_reg, g_reg, n) + return () + +-- ====================================================================== +-- * Main functions + +-- These functions are so that the user can output something. + +-- | Output the circuit for the quantum walk and a binary welded tree, +-- for the given 'Oracle' in the specified 'Format' and using the +-- specified 'GateBase'. Use /s/ time steps of length /dt/. +main_circuit :: Format -> GateBase -> Oracle -> Int -> Timestep -> IO() +main_circuit format base oracle s dt = + print_generic format (decompose_generic base circuit) + where + circuit = qrwbwt oracle s dt + +-- | Output the circuit for the given 'Oracle' and the given color +-- (specified as an 'Int'). Use the specified output 'Format' and +-- 'GateBase'. +main_oracle :: Format -> GateBase -> Oracle -> Int -> IO() +main_oracle format base oracle c = + let m' = m oracle + ofun = oraclefun oracle + circuit = (\(a,b,r) -> ofun c (qureg_of_qulist_te a, qureg_of_qulist_te b, r)) + in + print_generic format (decompose_generic base circuit) (replicate m' qubit, replicate m' qubit, qubit) diff --git a/dist/build/Quipper/Algorithms/BWT/Definitions.hs b/dist/build/Quipper/Algorithms/BWT/Definitions.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/BWT/Definitions.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/BWT/Definitions.hs" #-} +-- | This module provides some convenient definitions for the Binary +-- Welded Tree algorithm implementation. + +module Quipper.Algorithms.BWT.Definitions where + +import Quipper + +-- ====================================================================== +-- * Some convenient gates + +-- | Apply the binary /W/-gate to a pair of qubits. The W-gate +-- diagonalizes the SWAP operation. +wGate :: (Qubit, Qubit) -> Circ () +wGate (a,b) = do + gate_W a b + return () + +-- | Apply the /inverse/ of the /W/-gate. Note: since the /W/-gate is +-- self-inverse, this is really the same as 'wGate'. However, we +-- define this as a separate function for clarity. +wGateInverse :: (Qubit, Qubit) -> Circ () +wGateInverse = wGate + +-- | Apply a doubly-controlled not gate to a triple of qubits (/a/, +-- /b/, /c/). Here the qubit /c/ is negated if /a/=1 and /b/=0. +toffoliGate :: (Qubit, Qubit, Qubit) -> Circ () +toffoliGate (a, b, c) = + qnot_at c `controlled` (a .==. 1 .&&. b .==. 0) + +-- | @controlledExpGate(t, r, h):@ +-- Apply the [exp −/iZt/] gate to the qubit /h/, provided that /r/=0. +controlledExpGate :: (Timestep, Qubit, Qubit) -> Circ () +controlledExpGate (t, r, h) = do + expZt t h `controlled` (r .==. 0) + return () diff --git a/dist/build/Quipper/Algorithms/BWT/Main.hs b/dist/build/Quipper/Algorithms/BWT/Main.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/BWT/Main.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/BWT/Main.hs" #-} +-- | +-- Authors: Peter Selinger, Benoît Valiron +-- +-- An implementation of the Binary Welded Tree algorithm. This +-- algorithm inputs an oracle encoding a graph of the following form: +-- +-- \[image weldedtree.png] +-- +-- The graph consists of two binary trees whose leaves are connected +-- by two permutations as shown in the above illustration. Except for +-- the roots of the two trees, all nodes have degree 3. The edges +-- of the graph are colored with 4 different colors. The objective of +-- the algorithm is to find the exit node (17 in the above +-- illustration), given the entrance node (1 in the above +-- illustration). This is done by a Trotterized quantum walk on the +-- graph. +-- +-- The algorithm is described in: +-- +-- * A. M. Childs, R. Cleve, E. Deotto, E. Farhi, S. Gutmann, and +-- D. A. Spielman. \"Exponential algorithmic speedup by a quantum +-- walk.\" +-- /Proceedings of the 35th Annual ACM Symposium on Theory of Computing/, +-- pp. 59–68, 2003. See also . +-- +-- The present implementation is based on detailed algorithm and +-- oracle specifications that were provided to us by the IARPA QCS +-- program and written by Travis Humble. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.BWT.Main": Command line interface. +-- +-- * "Quipper.Algorithms.BWT.Definitions": Some general-purpose definitions. +-- +-- * "Quipper.Algorithms.BWT.BWT": The implementation of the main Binary +-- Welded Tree algorithm and oracle, using a more-or-less imperative +-- programming style. +-- +-- * "Quipper.Algorithms.BWT.Alternative": Alternate implementations of the +-- main algorithm and various oracles, using a more functional +-- programming style. +-- +-- * "Quipper.Algorithms.BWT.Template": Another oracle implementation, using +-- Quipper's \"build_circuit\" feature to automatically extract a +-- quantum circuit from a classical functional program. +-- +-- * "Quipper.Algorithms.BWT.Simulate": Functions for simulating, testing, and +-- debugging oracles. + +module Quipper.Algorithms.BWT.Main where + +import Quipper + +import Quipper.Libraries.Decompose + +import qualified Quipper.Algorithms.BWT.BWT as BWT +import qualified Quipper.Algorithms.BWT.Simulate as Simulate +import qualified Quipper.Algorithms.BWT.Alternative as Alternative +import qualified Quipper.Algorithms.BWT.Template as Template + +import Quipper.Utils.CommandLine + +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Control.Monad +import Data.List +import Data.Char + +-- ---------------------------------------------------------------------- +-- * Command line interface + +-- $ This module provides a command line interface for the Binary +-- Welded Tree algorithm. This allows the user, for example, to plug +-- in different oracles, show different parts of the circuit, select a +-- gate base, simulate, select parameters such as /n/ and /s/, and +-- select different output formats. + +-- ---------------------------------------------------------------------- +-- * Option processing + +-- | An enumeration type for determining what the main function should do. +data WhatToShow = + Circuit -- ^Show the whole circuit. + | Oracle -- ^Show only the oracle. + | Graph -- ^Show colored edges computed from oracle simulation. + | OracleC -- ^Show the \"classical\" oracle as a classical circuit. + | Simulate -- ^Run simulations of individual circuit fragments. + deriving Show + +-- | An enumeration type for selecting an oracle. +data OracleSelect = + Orthodox -- ^The \"orthodox\" oracle. + | Simple -- ^The \"simple\" oracle. + | Blackbox -- ^A blackbox oracle. + | Classical -- ^An oracle generated from classical program. + | Template -- ^An oracle automatically generated using Template Haskell. + | TemplateOptim -- ^An oracle automatically generated using Template Haskell, with peep-hole optimization. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + what :: WhatToShow, -- ^What kind of thing to output. + format :: Format, -- ^The output format. + gatebase :: GateBase, -- ^What kind of gates to decompose into. + oracle :: OracleSelect, -- ^Which kind of oracle to use. + n :: Int, -- ^The tree height. + c :: Int, -- ^The color to use with @--oracle@. + s :: Int, -- ^The parameter /s/ to use. + dt :: Timestep -- ^The parameter /dt/ to use. +} deriving Show + +-- | The default options. +defaultOptions :: Options +defaultOptions = Options + { what = Circuit, + format = Preview, + n = 5, + c = 0, + gatebase = Logical, + oracle = Orthodox, + s = 1, + dt = pi/180 + } + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = + [ Option ['h'] ["help"] (NoArg help) "print usage info and exit", + Option ['C'] ["circuit"] (NoArg (what Circuit)) "output the whole circuit (default)", + Option ['O'] ["oracle"] (NoArg (what Oracle)) "output only the oracle", + Option ['K'] ["oraclec"] (NoArg (what OracleC)) "output the \"classical\" oracle as a classical circuit", + Option ['G'] ["graph"] (NoArg (what Graph)) "print colored graph computed from oracle", + Option ['S'] ["simulate"] (NoArg (what Simulate)) "run simulations of some circuit fragments for tree height n", + Option ['f'] ["format"] (ReqArg format "") "output format for circuits (default: preview)", + Option ['g'] ["gatebase"] (ReqArg gatebase "") "type of gates to decompose into (default: logical)", + Option ['o'] [] (ReqArg oracle "") "select oracle to use (default: orthodox)", + Option ['n'] ["height"] (ReqArg height "") "set tree height (positive; default 5)", + Option ['c'] ["color"] (ReqArg color "") "color to use with --oracle (0..3, default 0)", + Option ['s'] ["repeats"] (ReqArg repeats "") "set parameter s (iteration count; default 1)", + Option ['l'] ["large"] (NoArg large) "set large problem size: n=300, s=336960", + Option ['t'] ["dt"] (ReqArg dt "
") "set parameter dt (simulation time step; default pi/180)" + ] + where + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + + height :: String -> Options -> IO Options + height string o = + case parse_int string of + Just n | n >= 1 -> return o { n = n } + _ -> optfail ("Invalid tree height -- " ++ string ++ "\n") + + color :: String -> Options -> IO Options + color string o = + case parse_int string of + Just c | c >= 0 && c < 4 -> return o { c = c } + _ -> optfail ("Invalid color -- " ++ string ++ "\n") + + repeats :: String -> Options -> IO Options + repeats string o = + case parse_int string of + Just s | s >= 0 -> return o { s = s } + _ -> optfail ("Invalid value for parameter s -- " ++ string ++ "\n") + + large :: Options -> IO Options + large o = return o { s = 336960, n = 300 } + + dt :: String -> Options -> IO Options + dt string o = + case parse_double string of + Just dt -> return o { dt = dt } + _ -> optfail ("Invalid value for parameter dt -- " ++ string ++ "\n") + + format :: String -> Options -> IO Options + format str o = do + case match_enum format_enum str of + [(_, f)] -> return o { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + gatebase :: String -> Options -> IO Options + gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + oracle :: String -> Options -> IO Options + oracle str o = do + case match_enum oracle_enum str of + [(_, f)] -> return o { oracle = f } + [] -> optfail ("Unknown oracle -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous oracle -- " ++ str ++ "\n") + + help :: Options -> IO Options + help o = do + usage + exitSuccess + + n_def = show (n defaultOptions) + c_def = show (c defaultOptions) + +-- | An enumeration of available oracles and their names. +oracle_enum :: [(String, OracleSelect)] +oracle_enum = [ + ("orthodox", Orthodox), + ("simple", Simple), + ("blackbox", Blackbox), + ("classical", Classical), + ("template", Template), + ("optimized", TemplateOptim) + ] + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to 'stdout'. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + putStr (show_enum "oracle" oracle_enum) + where header = "Usage: bwt [OPTION...]" + +-- ---------------------------------------------------------------------- +-- * The BWT main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO() +main = do + argv <- getArgs + options <- dopts argv + let oracle = oracle_of_options options + case options of + Options { what = Circuit, format = format, gatebase = gatebase, s = s, dt = dt } -> + BWT.main_circuit format gatebase oracle s dt + Options { what = Oracle, c = c, format = format, gatebase = gatebase } -> + BWT.main_oracle format gatebase oracle c + Options { what = OracleC, c = c, format = format } -> + Alternative.main_oraclec format oracle c + Options { what = Graph, format = ASCII, gatebase = gatebase } -> + Simulate.simulate_edges gatebase oracle + Options { what = Graph, format = format, oracle = Simple, gatebase = gatebase } -> do + -- special case: if Simple, change the node numbering + let doc = Simulate.render_oracle gatebase True oracle + print_of_document format doc + Options { what = Graph, format = format, gatebase = gatebase } -> do + let doc = Simulate.render_oracle gatebase False oracle + print_of_document format doc + Options { what = Simulate, n = n } -> do + Simulate.main_all n + +-- | Compute the appropriate 'Oracle' for the given options. +oracle_of_options :: Options -> BWT.Oracle + +oracle_of_options Options { oracle = Orthodox, n = n } = + BWT.oracle_orthodox f g + where + f = take n (True : False : f) + g = take n (False : True : g) + +oracle_of_options Options { oracle = Simple } = + Alternative.convert_oracle (Alternative.oracle_simple) + +oracle_of_options Options { oracle = Blackbox, n = n } = + Alternative.convert_oracle (Alternative.oracle_blackbox n) + +oracle_of_options Options { oracle = Classical, n = n } = + Alternative.convert_oracle (Alternative.oracle_classical f g) + where + f = take n (True : False : f) + g = take n (False : True : g) + +oracle_of_options Options { oracle = Template, n = n } = + Alternative.convert_oracle (Template.oracle_template f g) + where + f = take n (True : False : f) + g = take n (False : True : g) + +oracle_of_options Options { oracle = TemplateOptim, n = n } = + Alternative.convert_oracle (Template.oracle_template_optim f g) + where + f = take n (True : False : f) + g = take n (False : True : g) + diff --git a/dist/build/Quipper/Algorithms/BWT/Simulate.hs b/dist/build/Quipper/Algorithms/BWT/Simulate.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/BWT/Simulate.hs @@ -0,0 +1,602 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/BWT/Simulate.hs" #-} +-- | This module contains functions for simulating and debugging +-- BWT oracles. + +module Quipper.Algorithms.BWT.Simulate where + +import Quipper hiding (comment) + +import Quipper.Libraries.Qureg +import Quipper.Libraries.Simulation +import Quipper.Libraries.Decompose + +-- import other Quipper stuff +import Quipper.Algorithms.BWT.Definitions +import Quipper.Algorithms.BWT.BWT + +import Quipper.Utils.Sampling +import Quipper.Utils.Auxiliary + +-- import other stuff +import Graphics.EasyRender +import Text.Printf +import Data.Bits + +-- ====================================================================== +-- * Generic simulation + +-- | Inputs an oracle and prints out a list of colored edges in text +-- format. This is done by simulating the circuit for every possible +-- input, decomposed to the given 'GateBase'. +simulate_edges :: GateBase -> Oracle -> IO() +simulate_edges gb oracle = + mapM_ output (sample_all0 (2^m'-1, 3)) + where + m' = (m oracle) + ofun c (a, b, r) = do + let a_reg = qureg_of_qulist_te a + let b_reg = qureg_of_qulist_te b + (oraclefun oracle) c (a_reg, b_reg, r) + return (a, b, r) + + simulate :: (Int, Int) -> (Int, Bool) + simulate (c, a) = (b1, r1) where + + -- convert inputs to boollisttors + a_in = boollist_of_int_bh m' a + b_in = take m' $ repeat False + r_in = False + + (a_out, b_out, r_out) = run_classical_generic (decompose_generic gb (ofun c)) (a_in, b_in, r_in) + + -- convert outputs to integers + a1 = int_of_boollist_unsigned_bh a_out + b1 = int_of_boollist_unsigned_bh b_out + r1 = r_out + + output :: (Int, Int) -> IO() + output (a, c) = + case simulate (c, a) of + (b, False) -> printf "%d ---%d---> %d\n" a c b + (b, True) -> printf "%d ---%d---> None (%d)\n" a c b + +-- | Input an oracle and output the colored edges in graphical +-- format. This is done by simulating the circuit for every possible +-- input. The second parameter is a boolean which determines whether +-- the node numbering follows the schema of the orthodox oracle +-- ('True') or the simple oracle ('False'). +render_oracle :: GateBase -> Bool -> Oracle -> Document () +render_oracle gb node_style oracle = do + newpage (sc * width) (sc * height) $ do + scale sc sc + setlinewidth linewidth + sequence_ [ output a c | (a,c) <- sample_all0 (2^m'-1, 3) ] + setcolor (Color_Gray 0) + sequence_ [ label a | a <- sample_all0 (2^m'-1) ] + where + sc = 5.0 :: Double + labelfont = Font TimesRoman 0.8 + dotradius = 0.1 :: Double + linewidth = 0.04 :: Double + black = Color_Gray 0 + + m' = (m oracle) + n' = (n oracle) + nn = fromIntegral n' + ofun c (a, b, r) = do + let a_reg = qureg_of_qulist_te a + let b_reg = qureg_of_qulist_te b + (oraclefun oracle) c (a_reg, b_reg, r) + return (a, b, r) + + simulate :: (Int, Int) -> (Int, Bool) + simulate (c, a) = (b1, r1) where + + -- convert inputs to boollisttors + a_in = boollist_of_int_bh m' a + b_in = take m' $ repeat False + r_in = False + + (a_out, b_out, r_out) = run_classical_generic (decompose_generic gb (ofun c)) (a_in, b_in, r_in) + + -- convert outputs to integers + a1 = int_of_boollist_unsigned_bh a_out + b1 = int_of_boollist_unsigned_bh b_out + r1 = r_out + + width = 2.0^(n'+1) + height = (2.0*(nn)+4) * 2.0 + 2.0^n' + + -- coord: map a node id to a pair of coordinates + coord_simple :: Int -> (Double, Double) + coord_simple a = (x,y) where + t = (a .&. (2^(n'+1)) /= 0) -- tree bit + a' = a .&. (2^(n'+1)-1) -- node address + h = hibit a' -- logical height in subtree + w = a' .&. (2^(h-1)-1) -- logical position in row + hh = fromIntegral h + ww = fromIntegral w + h1 = 1 + 2 * hh -- physical height in subtree + y = if t then h1 else height - h1 + x = if h == 0 then 0.5 * width else (1+2*ww) * 2^(n'+1-h) + + -- coord_orthodox: same as coord, but use the layout of the orthodox oracle. + coord_orthodox :: Int -> (Double, Double) + coord_orthodox a | a >= 2^(n'+1) = (width - x,y) where + (x,y) = coord_simple (2^(n'+2)+2^(n'+1)-1-a) + coord_orthodox a = coord_simple a -- for the upper subtree, no difference + + coord :: Int -> (Double, Double) + coord = if node_style then coord_orthodox else coord_simple + + color :: Int -> Color + color 0 = Color_RGB 1 0 0 + color 1 = Color_RGB 0 1 0 + color 2 = Color_RGB 0 0 1 + color 3 = Color_RGB 1 1 0 + color n = error ("render_oracle: unknown color: " ++ show n) + + output :: Int -> Int -> Draw () + output a c = + case simulate (c, a) of + (b, False) -> do + comment (printf "%d ---%d---> %d" a c b) + moveto x0 y0 + lineto x2 y2 + setcolor (color c) + stroke + where + (x0,y0) = coord a + (x1,y1) = coord b + (x2,y2) = ((x0+x1)/2, (y0+y1)/2) + (b, True) -> do + comment (printf "%d ---%d---> None (%d)" a c b) + + label :: Int -> Draw () + label a = do + render_dot x y + textbox align_left labelfont black (x+0.1) y (x+1.9) y 0 (show a) + where + (x,y) = coord a + + render_dot :: X -> Y -> Draw () + render_dot x y = do + arc x y dotradius 0 360 + fill black + +-- ====================================================================== +-- * Testing of specific circuit fragments + +-- | Simulate 'parseNodeRoot' on all possible inputs for tree height /n/. +simulate_parseNodeRoot :: Int -> IO() +simulate_parseNodeRoot n = mapM_ output (sample_all0 (4*nn-1, True, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Bool,Bool) -> IO() + output (a, root, even) = + let + as = boollist_of_int_bh (n+2) a + (as',root',even') = run_classical_generic (runfun n) (as, root, even) + + runfun :: Int -> (Qulist,Qubit,Qubit) -> Circ (Qulist,Qubit,Qubit) + runfun n (as, root, even) = do + parseNodeRoot (qureg_of_qulist_te as, root, even, n) + return (as, root, even) + a' = int_of_boollist_unsigned_bh as' :: Integer + d_root = root `bool_xor` root' + d_even = even `bool_xor` even' + in do + printf "(a=%d, root=%s, even=%s) -> (a=%d, root=%s, even=%s)\n" a (show root) (show even) a' (show root') (show even') + if (a /= a' || d_root /= d_even) + then + error "Test failed (1)" + else if (d_root /= ((a .&. (2*nn-1)) <= 1)) then + error "Test failed (2)" + else + return () + +-- | Simulate 'parseNodeEven' on all possible inputs for tree height /n/. +simulate_parseNodeEven :: Int -> IO() +simulate_parseNodeEven n = mapM_ output (sample_all0 (4*nn-1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Bool) -> IO() + output (a, even) = + let + as = boollist_of_int_bh (n+2) a + (as',even') = run_classical_generic (runfun n) (as, even) + + runfun :: Int -> (Qulist,Qubit) -> Circ (Qulist,Qubit) + runfun n (as, even) = do + parseNodeEven (qureg_of_qulist_te as, even, n) + return (as, even) + a' = int_of_boollist_unsigned_bh as' :: Integer + d_even = even `bool_xor` even' + in do + printf "(a=%d, even=%s) -> (a=%d, even=%s)\n" a (show even) a' (show even') + if (a /= a') + then + error "Test failed (3)" + else if ((a .&. (2*nn-1)) <= 1) then + if (d_even) then + error "Test failed (4)" + else + return () + else if (d_even /= not (Prelude.even (hibit (a .&. (2*nn-1))))) then + error "Test failed (5)" + else + return () + +-- | Simulate 'testIsParent' on all possible inputs for tree height /n/. +simulate_testIsParent :: Int -> IO() +simulate_testIsParent n = mapM_ output (sample_all0 (1, True, True, True, 3, 1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer, Bool, Bool, Bool, Integer, Int, Bool) -> IO() + output (a, root, even, isparent, color, really, ismatch) = + let + as = boollist_of_int_bh 1 a + cs = boollist_of_int_bh 2 color + (as', root', even', isparent', ismatch') = run_classical_generic (runfun n cs really) (as, root, even, isparent, ismatch) + + runfun :: Int -> Boollist -> Int -> (Qulist,Qubit,Qubit,Qubit,Qubit) -> Circ (Qulist,Qubit,Qubit,Qubit,Qubit) + runfun n cs rs (as, root, even, isparent, ismatch) = do + testIsParent (qureg_of_qulist_te as, root, even, isparent, boolreg_of_boollist_te cs, n, really, ismatch) + return (as, root, even, isparent, ismatch) + + a' = int_of_boollist_unsigned_bh as' :: Integer + d_root = root `bool_xor` root' + d_even = even `bool_xor` even' + d_isparent = isparent `bool_xor` isparent' + d_ismatch = ismatch `bool_xor` ismatch' + in do + printf "(a=%d, root=%s, even=%s, isparent=%s, color=%d, really=%d, ismatch=%s) -> (a=%d, root=%s, even=%s, isparent=%s, ismatch=%s)\n" a (show root) (show even) (show isparent) color really (show ismatch) a' (show root') (show even') (show isparent') (show ismatch') + if (a /= a' || root /= root' || even /= even') + then + error "Test failed (6)" + else if (root == True && even == True) then + if d_isparent == False then + return () + else + error "Test failed (7)" + else if really == 1 && ismatch == False then + if d_isparent /= (color == (a .&. 1) .|. (if even then 2 else 0)) then + error "Test failed (8)" + else if d_ismatch /= (d_isparent && even) then + error "Test failed (9)" + else + return () + else -- really == 0 -- we don't write more test cases because the algorithm is so convoluted. + return () + +-- | Simulate 'testIsChild' on all possible inputs for tree height /n/. +simulate_testIsChild :: Int -> IO() +simulate_testIsChild n = mapM_ output (sample_all0 (True, True, True, 3)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Bool, Bool, Bool, Integer) -> IO() + output (even, ischild, direction, color) = + let + cs = boollist_of_int_bh 2 color + (even', ischild', direction') = run_classical_generic (runfun cs n) (even, ischild, direction) + + runfun :: Boollist -> Int -> (Qubit,Qubit,Qubit) -> Circ (Qubit,Qubit,Qubit) + runfun cs n (even, ischild, direction) = do + testIsChild (even, ischild, direction, boolreg_of_boollist_te cs, n) + return (even, ischild, direction) + d_ischild = ischild `bool_xor` ischild' + d_direction = direction `bool_xor` direction' + in do + printf "(even=%s, ischild=%s, direction=%s, color=%d) -> (even=%s, ischild=%s, direction=%s)\n" (show even) (show ischild) (show direction) color (show even') (show ischild') (show direction') + if (even /= even' || d_direction == (Prelude.even color)) + then + error "Test failed (10)" + else if even && (d_ischild /= (color <= 1)) then + error "Test failed (11)" + else if not even && (d_ischild /= (color >= 2)) then + error "Test failed (12)" + else + return () + +-- | Simulate 'setParent' on all possible inputs for tree height /n/. +simulate_setParent :: Int -> IO() +simulate_setParent n = mapM_ output (sample_all0 (4*nn-1, 4*nn-1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Integer,Bool) -> IO() + output (a,b,isparent) = + let + as = boollist_of_int_bh (n+2) a + bs = boollist_of_int_bh (n+2) b + (as',bs',isparent') = run_classical_generic (runfun n) (as, bs, isparent) + + runfun :: Int -> (Qulist,Qulist,Qubit) -> Circ (Qulist,Qulist,Qubit) + runfun n (as, bs, isparent) = do + setParent (qureg_of_qulist_te as, qureg_of_qulist_te bs, isparent, n) + return (as, bs, isparent) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + db = b `xor` b' + in do + printf "(a=%d, b=%d) -> (a=%d, b=%d) (db=%d) isparent=%s\n" a b a' b' db (show isparent) + if (a /= a' || isparent /= isparent') + then + error "Test failed (13)" + else if (isparent == False) then + if (b /= b') then + error "Test failed (14)" + else + return () + else if db /= ((a `div` 2) .&. (nn-1)) .|. (a .&. (2*nn)) then + error "Test failed (15)" + else + return () + +-- | Simulate 'setChild' on all possible inputs for tree height /n/. +simulate_setChild :: Int -> IO() +simulate_setChild n = mapM_ output (sample_all0 (4*nn-1, 4*nn-1, nn-1, nn-1, True, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Integer,Integer,Integer,Bool,Bool) -> IO() + output (a,b,f,g,ischild,direction) = + let + as = boollist_of_int_bh (n+2) a + bs = boollist_of_int_bh (n+2) b + fs = boollist_of_int_bh n f + gs = boollist_of_int_bh n g + (as',bs',ischild',direction') = run_classical_generic (runfun n fs gs) (as, bs, ischild, direction) + + runfun :: Int -> Boollist -> Boollist -> (Qulist,Qulist,Qubit,Qubit) -> Circ (Qulist,Qulist,Qubit,Qubit) + runfun n f g (as, bs, ischild, direction) = do + setChild (qureg_of_qulist_te as, qureg_of_qulist_te bs, ischild, direction, boolreg_of_boollist_te f, boolreg_of_boollist_te g, n) + return (as, bs, ischild, direction) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + db = b `xor` b' + in do + printf "(a=%d, b=%d, f=%d, g=%d) -> (a=%d, b=%d) (db=%d) ischild=%s direction=%s\n" a b f g a' b' db (show ischild) (show direction) + if (a /= a' || ischild /= ischild' || direction /= direction') + then + error "Test failed (16)" + else if (ischild == False) then + if (b /= b') then + error "Test failed (17)" + else + return () + else if a .&. nn /= 0 then + if direction == False && db /= (a `xor` f `xor` 2*nn) .|. nn then + error "Test failed (18)" + else if direction == True && a .&. (2*nn) /= 0 && db /= ((a - g) .&. (2*nn-1)) .|. nn then + error "Test failed (19)" + else if direction == True && a .&. (2*nn) == 0 && db /= (((a + g) .&. (2*nn-1)) .|. (2*nn) .|. nn) then + error "Test failed (20)" + else + return () + else + if db /= ((2*a) .&. (2*nn-1)) .|. (a .&. (2*nn)) .|. (if direction then 1 else 0) then + error "Test failed (21)" + else + return () + +-- | Simulate 'setChildInTree' on all possible inputs for tree height /n/. +simulate_setChildInTree :: Int -> IO() +simulate_setChildInTree n = mapM_ output (sample_all0 (4*nn-1, 4*nn-1, True, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Integer,Bool,Bool) -> IO() + output (a,b,childctrl,direction) = + let + as = boollist_of_int_bh (n+2) a + bs = boollist_of_int_bh (n+2) b + (as',bs',childctrl',direction') = run_classical_generic (runfun n) (as, bs, childctrl, direction) + + runfun :: Int -> (Qulist,Qulist,Qubit,Qubit) -> Circ (Qulist,Qulist,Qubit,Qubit) + runfun n (as, bs, childctrl, direction) = do + setChildInTree (qureg_of_qulist_te as, qureg_of_qulist_te bs, childctrl, direction, n) + return (as, bs, childctrl, direction) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + db = b `xor` b' + in do + printf "(a=%d, b=%d) -> (a=%d, b=%d) (db=%d) childctrl=%s direction=%s\n" a b a' b' db (show childctrl) (show direction) + if (a /= a' || childctrl /= childctrl' || direction /= direction') + then + error "Test failed (22)" + else if (childctrl == False) then + if (b /= b') then + error "Test failed (23)" + else + return () + else if db /= ((2*a) .&. (2*nn-1)) .|. (a .&. (2*nn)) .|. (if direction then 1 else 0) then + error "Test failed (24)" + else + return () + +-- | Simulate 'setWeld' on all possible inputs for tree height /n/. +simulate_setWeld :: Int -> IO() +simulate_setWeld n = mapM_ output (sample_all0 (4*nn-1, 4*nn-1, nn-1, nn-1, True, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer,Integer,Integer,Integer,Bool,Bool) -> IO() + output (a,b,f,g,childctrl,direction) = + let + as = boollist_of_int_bh (n+2) a + bs = boollist_of_int_bh (n+2) b + fs = boollist_of_int_bh n f + gs = boollist_of_int_bh n g + (as',bs',childctrl',direction') = run_classical_generic (runfun n fs gs) (as, bs, childctrl, direction) + + runfun :: Int -> Boollist -> Boollist -> (Qulist,Qulist,Qubit,Qubit) -> Circ (Qulist,Qulist,Qubit,Qubit) + runfun n f g (as, bs, childctrl, direction) = do + setWeld (qureg_of_qulist_te as, qureg_of_qulist_te bs, childctrl, direction, boolreg_of_boollist_te f, boolreg_of_boollist_te g, n) + return (as, bs, childctrl, direction) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + db = b `xor` b' + in do + printf "(a=%d, b=%d, f=%d, g=%d) -> (a=%d, b=%d) (db=%d) childctrl=%s direction=%s\n" a b f g a' b' db (show childctrl) (show direction) + if (a /= a' || childctrl /= childctrl' || direction /= direction') + then + error "Test failed (25)" + else if (childctrl == False) then + if (b /= b') then + error "Test failed (26)" + else + return () + else if direction == False && db /= (a `xor` f `xor` 2*nn) .|. nn then + error "Test failed (27)" + else if direction == True && a .&. (2*nn) /= 0 && db /= ((a - g) .&. (2*nn-1)) .|. nn then + error "Test failed (28)" + else if direction == True && a .&. (2*nn) == 0 && db /= (((a + g) .&. (2*nn-1)) .|. (2*nn) .|. nn) then + error "Test failed (29)" + else + return () + +-- | Simulate 'doWeld1' on all possible inputs for tree height /n/. +simulate_doWeld1 :: Int -> IO() +simulate_doWeld1 n = mapM_ output (sample_all0 (4*nn-1, 4*nn-1, nn-1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer, Integer, Integer, Bool) -> IO() + output (a,b,c,control) = + let + as = boollist_of_int_bh (n+2) a + bs = boollist_of_int_bh (n+2) b + cs = boollist_of_int_bh n c + (control', bs', as') = run_classical_generic (runfun n cs) (control, bs, as) + + runfun :: Int -> Boollist -> (Qubit, Qulist, Qulist) -> Circ (Qubit, Qulist, Qulist) + runfun n c (control, b, a) = do + doWeld1 (qureg_of_qulist_te a, qureg_of_qulist_te b, control, boolreg_of_boollist_te c, n) + return (control, b, a) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + in do + printf "(%d, %d, %d) -> (%d, %d) %s %s\n" a b c a' b' (show control) (show control') + if (control && a .&. (2*nn) /= 0 && a' == a && b' == (((a-c) .&. (nn-1)) `xor` b) && control' == control) + || (control && a .&. (2*nn) == 0 && a' == a && b' == (((a+c) .&. (nn-1)) `xor` b) && control' == control) + || (not control && a' == a && b' == b && control' == control) + then + return () -- assertion succeeds + else + error "Test failed (30)" + +-- | Simulate 'doWeld0' on all possible inputs for tree height /n/. +simulate_doWeld0 :: Int -> IO() +simulate_doWeld0 n = mapM_ output (sample_all0 (2*nn-1, 2*nn-1, nn-1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer, Integer, Integer, Bool) -> IO() + output (a,b,c,control) = + let + as = boollist_of_int_bh (n+1) a + bs = boollist_of_int_bh (n+1) b + cs = boollist_of_int_bh n c + (control', bs', as') = run_classical_generic (runfun n cs) (control, bs, as) + + runfun :: Int -> Boollist -> (Qubit, Qulist, Qulist) -> Circ (Qubit, Qulist, Qulist) + runfun n c (control, b, a) = do + doWeld0 (qureg_of_qulist_te a, qureg_of_qulist_te b, control, boolreg_of_boollist_te c, n) + return (control, b, a) + a' = int_of_boollist_unsigned_bh as' :: Integer + b' = int_of_boollist_unsigned_bh bs' :: Integer + in do + printf "(%d, %d, %d) -> (%d, %d) %s %s\n" a b c a' b' (show control) (show control') + if (control && a' == a && b' == (((a `xor` c) .&. (nn-1)) `xor` b) && control' == control) + || (not control && a' == a && b' == b && control' == control) + then + return () -- assertion succeeds + else + error "Test failed (31)" + +-- | Simulate 'cAddNum' (including 'cAddNumClear') on all possible inputs for tree height /n/. +simulate_cAddNum :: Int -> IO() +simulate_cAddNum n = mapM_ output (sample_all0 (nn-1, nn-1, nn-1, True)) + where + nn = 2^(toInteger n) :: Integer + output :: (Integer, Integer, Integer, Bool) -> IO() + output (a,b,c,control) = + let + as = boollist_of_int_bh n a + bs = boollist_of_int_bh n b + cs = boollist_of_int_bh n c + (control', bs', as') = run_classical_generic (runfun n cs) (control, bs, as) + + runfun :: Int -> Boollist -> (Qubit, Qulist, Qulist) -> Circ (Qubit, Qulist, Qulist) + runfun n c (control, b, a) = do + cAddNum (control, qureg_of_qulist_te b, qureg_of_qulist_te a, boolreg_of_boollist_te c, n) + return (control, b, a) + a' = int_of_boollist_unsigned_bh as' + b' = int_of_boollist_unsigned_bh bs' + in do + printf "(%d, %d, %d) -> (%d, %d) %s %s\n" a b c a' b' (show control) (show control') + if (control && a' == a && b' == (((a+c) `mod` (2^n)) `xor` b) && control' == control) + || (not control && a' == a && b' == b && control' == control) + then + return () -- assertion succeeds + else + error "Test failed (32)" + +-- | Simulate 'cSubNum' (including 'cSubNumClear') on all possible inputs for tree height /n/. +simulate_cSubNum :: Int -> IO() +simulate_cSubNum n = mapM_ output (sample_all0 (nn-1, nn-1, nn-1, True)) + where + nn = 2^(toInteger n) :: Integer -- can be quite large! + output :: (Integer, Integer, Integer, Bool) -> IO() + output (a,b,c,control) = + let + as = boollist_of_int_bh n a + bs = boollist_of_int_bh n b + cs = boollist_of_int_bh n c + (control', bs', as') = run_classical_generic (runfun n cs) (control, bs, as) + + runfun :: Int -> Boollist -> (Qubit, Qulist, Qulist) -> Circ (Qubit, Qulist, Qulist) + runfun n c (control, b, a) = do + cSubNum (control, qureg_of_qulist_te b, qureg_of_qulist_te a, boolreg_of_boollist_te c, n) + return (control, b, a) + a' = int_of_boollist_unsigned_bh as' + b' = int_of_boollist_unsigned_bh bs' + in do + printf "(%d, %d, %d) -> (%d, %d) %s %s\n" a b c a' b' (show control) (show control') + if (control && a' == a && b' == (((a-c) `mod` nn) `xor` b) && control' == control) + || (not control && a' == a && b' == b && control' == control) + then + return () -- assertion succeeds + else + error "Test failed (33)" + +-- ====================================================================== +-- * Auxiliary functions + +-- | Return the smallest number of bits required to hold the given integer. +hibit :: Integral a => Integral b => a -> b +hibit n = + if n <= 0 then + 0 + else + 1 + hibit (n `div` 2) + +-- ====================================================================== +-- * Main functions + +-- | Run simulations of 'parseNodeRoot', 'parseNodeEven', +-- 'testIsParent', 'testIsChild', 'setParent', 'setChild', +-- 'setChildInTree', 'setWeld', 'doWeld0', 'doWeld1', 'cAddNum', and +-- 'cSubNum' for tree height /n/. +main_all :: Int -> IO() +main_all n = do + simulate_parseNodeRoot n + simulate_parseNodeEven n + simulate_testIsParent n + simulate_testIsChild n + simulate_setParent n + simulate_setChild n + simulate_setChildInTree n + simulate_setWeld n + simulate_doWeld0 n + simulate_doWeld1 n + simulate_cAddNum n + simulate_cSubNum n diff --git a/dist/build/Quipper/Algorithms/BWT/Template.hs b/dist/build/Quipper/Algorithms/BWT/Template.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/BWT/Template.hs @@ -0,0 +1,416 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/BWT/Template.hs" #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | The BWT Oracle, written in a classical, functional manner and +-- automatically transformed to a quantum circuit using Quipper's +-- \"build_circuit\" mechanism. +module Quipper.Algorithms.BWT.Template where + +import Quipper + +import Control.Monad (sequence) +import Quipper.Algorithms.BWT.Alternative (Oracle(..), Node, QNode) + +import Quipper.Utils.Auxiliary hiding (boollist_xor) +import Quipper.Libraries.ClassicalOptim + +-- ---------------------------------------------------------------------- +-- * Circuit building functions + +-- $BUILDING +-- +-- This section contains an implementation of the oracle as a +-- collection of ordinary functional programs. Each function in this +-- section is decorated with the @build_circuit@ keyword (see +-- "Quipper.Internal.CircLifting#build_circuit"). Therefore, circuits are +-- automatically generated; for example, the circuit corresponding to +-- the function 'v_function' is automatically built and given the name +-- 'template_v_function'. + +---------------------------------------------------------------------- +-- ** General operations on booleans + +-- | Exclusive /or/ operation on bit vectors. + +boollist_xor :: [Bool] -> [Bool] -> [Bool] +boollist_xor x y = zipWith bool_xor x y + + + +{-# LINE 38 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| boollist_xor :: [Bool] -> [Bool] -> [Bool] + boollist_xor x y = zipWith bool_xor x y + + + + |] ) +{-# LINE 39 "Quipper/Algorithms/BWT/Template.hs" #-} +-- | 'bit_adder' 'False' is a one-bit adder, and 'bit_adder' 'True' is a +-- one-bit subtracter (i.e., add the 2's complement of /y/). + +bit_adder :: Bool -> (Bool,Bool,Bool) -> (Bool,Bool) +bit_adder sign (carry, x,y) = + let majority a b c = + if (a `bool_xor` b) then c else a in + let y' = y `bool_xor` sign in + let z = carry `bool_xor` x `bool_xor` y' in + let carry' = majority carry x y' in + (carry', z) + + + +{-# LINE 51 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| bit_adder :: Bool -> (Bool,Bool,Bool) -> (Bool,Bool) + bit_adder sign (carry, x,y) = + let majority a b c = + if (a `bool_xor` b) then c else a in + let y' = y `bool_xor` sign in + let z = carry `bool_xor` x `bool_xor` y' in + let carry' = majority carry x y' in + (carry', z) + + + + |] ) +{-# LINE 52 "Quipper/Algorithms/BWT/Template.hs" #-} +---------------------------------------------------------------------- +-- ** Encoding the BWT oracle on booleans and lists of booleans + +-- | Input a node /a/ and return the parent of /a/. We assume that /a/ +-- is not a root or invalid. + +parent :: Node -> Node +parent (x,y) = (x, False:(init y)) + + +{-# LINE 60 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| parent :: Node -> Node + parent (x,y) = (x, False:(init y)) + + + |] ) +{-# LINE 61 "Quipper/Algorithms/BWT/Template.hs" #-} +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True', +-- respectively). Assumes that /a/ is not a leaf. + +childintree :: Node -> Bool -> Node +childintree (t,l) c = + case l of + [] -> error "childintree" + h:aa -> (t, aa ++ [c]) + + + +{-# LINE 71 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| childintree :: Node -> Bool -> Node + childintree (t,l) c = + case l of + [] -> error "childintree" + h:aa -> (t, aa ++ [c]) + + + + |] ) +{-# LINE 72 "Quipper/Algorithms/BWT/Template.hs" #-} +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit; /a/ +-- is the highest bit and /aa/ is the remaining /n/ bits) and a sign +-- /s/ (where 'True' = negative, 'False' = positive). Return +-- /a/:(/aa/ + /s/ * /f/). The first input is the /n/-bit welding +-- vector /f/ (a parameter to the oracle). Note that /f/ is a +-- parameter and /s/, /aa/ are inputs. + +doweld1 :: Boollist -> Bool -> [Bool] -> [Bool] +doweld1 f s l = + case l of + [] -> error "doweld1" + a:aa -> a : (snd (fold_right_zip (bit_adder s) (s, aa, f))) + + + +{-# LINE 85 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| doweld1 :: Boollist -> Bool -> [Bool] -> [Bool] + doweld1 f s l = + case l of + [] -> error "doweld1" + a:aa -> a : (snd (fold_right_zip (bit_adder s) (s, aa, f))) + + + + |] ) +{-# LINE 86 "Quipper/Algorithms/BWT/Template.hs" #-} +-- | Input an /n/+1-bit leaf node /a/:/aa/ (without the tree bit), and +-- return /a/:(/aa/ ⊕ /g/). The first input is the /n/-bit welding +-- vector /g/ (a parameter to the oracle). + +doweld0 :: Boollist -> [Bool] -> [Bool] +doweld0 g l = + case l of + [] -> error "doweld0" + a:aa -> a : (g `boollist_xor` aa) + + + +{-# LINE 96 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| doweld0 :: Boollist -> [Bool] -> [Bool] + doweld0 g l = + case l of + [] -> error "doweld0" + a:aa -> a : (g `boollist_xor` aa) + + + + |] ) +{-# LINE 97 "Quipper/Algorithms/BWT/Template.hs" #-} +-- | Input a leaf node /a/ and return the left or right weld of /a/ in +-- the other tree (depending on whether the /weldbit/ is 'False' or +-- 'True'). Assumes that /a/ is a leaf. + +weld :: Boollist -> Boollist -> Node -> Bool -> Node +weld f g (t,aa) weldBit = + if weldBit then (not t, doweld1 g t aa) + else (not t, doweld0 f aa) + + + +{-# LINE 106 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| weld :: Boollist -> Boollist -> Node -> Bool -> Node + weld f g (t,aa) weldBit = + if weldBit then (not t, doweld1 g t aa) + else (not t, doweld0 f aa) + + + + |] ) +{-# LINE 107 "Quipper/Algorithms/BWT/Template.hs" #-} +-- | Input a node /a/ and return the left or right child of /a/ +-- (depending on whether the /childbit/ is 'False' or 'True'. This +-- works for leaf and non-leaf nodes. + +child :: Boollist -> Boollist -> Node -> Bool -> Node +child f g (t,aa) childBit = + case aa of + [] -> error "child" + h:tt -> if h then weld f g (t, aa) childBit + else childintree (t, aa) childBit + + + +{-# LINE 118 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| child :: Boollist -> Boollist -> Node -> Bool -> Node + child f g (t,aa) childBit = + case aa of + [] -> error "child" + h:tt -> if h then weld f g (t, aa) childBit + else childintree (t, aa) childBit + + + + |] ) +{-# LINE 119 "Quipper/Algorithms/BWT/Template.hs" #-} +-- | Input a node address (without the tree bit) and return the parity +-- of the node level expressed as a boolean either 'False' or +-- 'True'. Leaves have parity 'False', and other levels have +-- alternating parities. In other words: count the number of leading +-- zeros modulo 2. + +level_parity :: [Bool] -> Bool +level_parity l = foldl (\a b -> not (a || b)) False (reverse l) + + + +{-# LINE 128 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| level_parity :: [Bool] -> Bool + level_parity l = foldl (\a b -> not (a || b)) False (reverse l) + + + + |] ) +{-# LINE 129 "Quipper/Algorithms/BWT/Template.hs" #-} +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node address is invalid. In other words, return 'True' iff the +-- list consists of all 0's. + +is_zero :: [Bool] -> Bool +is_zero l = foldl (\a b -> a && (not b)) True l + + + +{-# LINE 136 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| is_zero :: [Bool] -> Bool + is_zero l = foldl (\a b -> a && (not b)) True l + + + + |] ) +{-# LINE 137 "Quipper/Algorithms/BWT/Template.hs" #-} +-- | Input a node address (without the tree bit) and return 'True' iff +-- the node is a root or invalid. In other words, check whether all +-- digits but the last are 0's. + +is_root :: [Bool] -> Bool +is_root l = case (reverse l) of + [] -> True + (h:t) -> is_zero t + + + + +{-# LINE 147 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| is_root :: [Bool] -> Bool + is_root l = case (reverse l) of + [] -> True + (h:t) -> is_zero t + + + + + |] ) +{-# LINE 148 "Quipper/Algorithms/BWT/Template.hs" #-} +-- | @'v_function' f g c a@: returns /v/[sub /c/](/a/), the label of the +-- node connected to /a/ by an edge of color /c/, or 'Nothing' if +-- there is no such node. The parameters /f/ and /g/ encode the +-- welding functions, and are lists of length /n/. /c/ is a color in +-- the range 0..3, and /a/ is an (/n/+2)-bit node label. + +v_function :: BoolParam -- ^First color bit. + -> BoolParam -- ^Second color bit. + -> Boollist -- ^Vector /f/ from Equation (26). + -> Boollist -- ^Vector /g/ from Equation (27). + -> Node -- ^Entry node /a/. + -> (Bool,Node) -- ^('True', exit node) or ('False', garbage). +v_function c_hi c_lo f g a = + let aa = snd a in + let cbc_hi = newBool c_hi `bool_xor` level_parity aa in + let cbc_lo = newBool c_lo in + if (not (is_root aa) && cbc_hi && not (cbc_lo `bool_xor` (last aa))) then + (False, parent a) + else + let res = child f g a cbc_lo in + (is_zero aa || cbc_hi, res) + + +{-# LINE 169 "Quipper/Algorithms/BWT/Template.hs" #-} +$( decToCircMonad [d| v_function :: BoolParam + -> BoolParam + -> Boollist + -> Boollist + -> Node + -> (Bool,Node) + v_function c_hi c_lo f g a = + let aa = snd a in + let cbc_hi = newBool c_hi `bool_xor` level_parity aa in + let cbc_lo = newBool c_lo in + if (not (is_root aa) && cbc_hi && not (cbc_lo `bool_xor` (last aa))) then + (False, parent a) + else + let res = child f g a cbc_lo in + (is_zero aa || cbc_hi, res) + + + |] ) +{-# LINE 170 "Quipper/Algorithms/BWT/Template.hs" #-} +-- ---------------------------------------------------------------------- +-- * Wrapping it into the Oracle data type + +-- $PACKAGE The following functions package the circuit generated by +-- 'v_function' into a data structure of type 'Oracle'. + +-- ---------------------------------------------------------------------- +-- ** Colors + +-- | A color is a number between 0 and 3. +type Color = Int + +-- | Convert an integer representation of a color into the two-bit representation. +colorToBoolParam :: Color -> (BoolParam,BoolParam) +colorToBoolParam 0 = (PFalse,PFalse) +colorToBoolParam 1 = (PFalse,PTrue) +colorToBoolParam 2 = (PTrue,PFalse) +colorToBoolParam 3 = (PTrue,PTrue) +colorToBoolParam _ = error "color out of range" + +-- ---------------------------------------------------------------------- +-- ** Functions for using the generated oracle + +-- | This is the /irreversible/ classical circuit generated from +-- 'v_function'. This is basically the same as 'template_v_function', +-- except that excessive uses of 'Circ' are removed from the type, and +-- the inputs and outputs have been reorganized. +classical_BWT_oracle :: Color -- ^ The color. + -> ([Qubit],[Qubit], QNode) -- ^ The two welding vectors and a node /a/. + -> Circ (Qubit, QNode) -- ^ Output /(r,b)/. +classical_BWT_oracle col (f,g,xs) = + unpack template_v_function b1 b2 f g xs + where + (b1,b2) = colorToBoolParam col + +-- | This is the /reversible/ circuit automatically generated from 'classical_BWT_oracle'. +reversible_BWT_oracle :: + Color -- ^ Color. + -> (([Qubit], [Qubit], QNode), (Qubit, QNode)) -- ^ /(f, g, a, r, b)/. + -> Circ (([Qubit], [Qubit], QNode), (Qubit, QNode)) -- ^ Output /(f, g, a, r, b)/. +reversible_BWT_oracle color ((f, g, a), (r, b)) = do + comment_with_label "ENTER: reversible_BWT_oracle" ((f, g, a), (r, b)) (("f", "g", "a"), ("r", "b")) + ((f, g, a), (r, b)) <- classical_to_reversible (classical_BWT_oracle color) ((f, g, a), (r, b)) + comment_with_label "EXIT: reversible_BWT_oracle" ((f, g, a), (r, b)) (("f", "g", "a"), ("r", "b")) + return ((f, g, a), (r, b)) + +-- | This is the /reversible/ circuit automatically generated from 'classical_BWT_oracle', and optimized with peep-hole optimization. +reversible_BWT_oracle_optim :: + Color -- ^ Color. + -> (([Qubit], [Qubit], QNode), (Qubit, QNode)) -- ^ /(f, g, a, r, b)/. + -> Circ (([Qubit], [Qubit], QNode), (Qubit, QNode)) -- ^ Output /(f, g, a, r, b)/. +reversible_BWT_oracle_optim color ((f, g, a), (r, b)) = do + comment_with_label "ENTER: reversible_BWT_oracle" ((f, g, a), (r, b)) (("f", "g", "a"), ("r", "b")) + ((f, g, a), (r, b)) <- classical_to_reversible_optim (classical_BWT_oracle color) ((f, g, a), (r, b)) + comment_with_label "EXIT: reversible_BWT_oracle" ((f, g, a), (r, b)) (("f", "g", "a"), ("r", "b")) + return ((f, g, a), (r, b)) + + +-- | The template oracle, packaged into the 'Oracle' abstraction. Note +-- that this circuit is automatically generated from the classical +-- functions above, but is completely unoptimized. This oracle has two +-- parameters, namely the welding vectors /f/ and /g/. +oracle_template :: [Bool] -> [Bool] -> Oracle +oracle_template f g = + Oracle { + n = n, + m = m, + k = 4, + entrance = boollist_of_int_bh m 1, + oraclefun = \c (as,bs,r) -> do qf <- qinit f + qg <- qinit g + let (a:aa) = as + let (b:bb) = bs + reversible_BWT_oracle c ((qf, qg, (a,aa)), (r, (b,bb))) + qterm g qg + qterm f qf + } + where n = length f + m = n+2 + + +-- | The template oracle, optimized. +oracle_template_optim :: [Bool] -> [Bool] -> Oracle +oracle_template_optim f g = + Oracle { + n = n, + m = m, + k = 4, + entrance = boollist_of_int_bh m 1, + oraclefun = \c (as,bs,r) -> do qf <- qinit f + qg <- qinit g + let (a:aa) = as + let (b:bb) = bs + reversible_BWT_oracle_optim c ((qf, qg, (a,aa)), (r, (b,bb))) + qterm g qg + qterm f qf + } + where n = length f + m = n+2 + diff --git a/dist/build/Quipper/Algorithms/CL/Auxiliary.hs b/dist/build/Quipper/Algorithms/CL/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/CL/Auxiliary.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/CL/Auxiliary.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | This module defines general-purpose functions not specific to the Class Number algorithm, but required by it. + +module Quipper.Algorithms.CL.Auxiliary where + +import Quipper +import Quipper.Libraries.Arith hiding (q_ext_euclid, q_add, q_mult, q_div_exact, + q_add_in_place, q_add_param_in_place, q_div, + q_mult_param, q_mod_unsigned, q_sub_in_place, + q_increment) +import qualified Quipper.Libraries.Arith as Arith +import Quipper.Libraries.FPReal + +-- Needed to define boxed arithmetic functions: +import Quipper.Internal + +import Data.Maybe +import Control.Monad + +-- ====================================================================== +-- * Classical functions + +-- ====================================================================== +-- ** Control + +-- | Assert that a condition is true, otherwise throwing an error with a given +-- error message, in a functional setting. +assert :: Bool -> String -> a -> a +assert condition error_message x = if condition then x else error error_message + +-- | Assert a condition, imperatively in a monad. +assertM :: (Monad m) => Bool -> String -> m () +assertM b errorstring = if b then return () else error errorstring + +-- | Given a list of monadic actions and a predicate on their results, +-- do the actions in sequence until one produces a result satisfying +-- the predicate; return this result. +sequence_until :: (Monad m) => (a -> Bool) -> [m a] -> m (Maybe a) +sequence_until _ [] = return Nothing +sequence_until p (m0:ms) = do + a0 <- m0 + if p a0 then return (Just a0) else sequence_until p ms + +-- | Test whether elements of a list are all equal +all_eq :: (Eq a) => [a] -> Bool +all_eq [] = True +all_eq [a] = True +all_eq (a:b:rest) = (a == b) && all_eq (b:rest) + +-- | Apply a function to data while condition holds true. For example: +-- +-- > while (not . isReduced . fst) rho ideal +-- +-- will apply the function /rho/ to an ideal-with-distance while it is +-- not yet reduced (until it is reduced). +while :: (a -> Bool) -> (a -> a) -> a -> a +while cond func x = if (cond x) then while cond func (func x) else x + +-- | Like 'while', but with a known bound on number of iterations. This +-- construct can be converted to a quantum circuit, while a general unbounded +-- 'while' cannot be lifted. +bounded_while :: (Integral int) => (a -> Bool) -> int -> (a -> a) -> a -> a +bounded_while cond bound func x + | bound < 0 = error "bounded_while: negative bound" + | bound == 0 && (not $ cond x) = x + | bound == 0 = error "bounded_while: last iteration doesn't satisfy condition" + | otherwise = + bounded_while cond (bound-1) func x' + where x' = if (cond x) then func x else x + +-- | A bounded version of Haskell 'iterate' function that produces an infinite +-- list. This function produces a finite bounded list. +bounded_iterate :: (Integral int) => int -> (a -> a) -> a -> [a] +bounded_iterate bound func x + | bound < 0 = error "negative bound in bounded_iterate" + | bound == 0 = [x] + | otherwise = + x : bounded_iterate (bound-1) (func) (func x) + +-- =========================================== +-- ** Mathematical functions + +-- | Generate primes using the Sieve of Eratosthenes. Straightforward +-- implementation - when a prime is found, filter all of its multiples +-- out of the already filtered list. This implementation may eventually blow +-- out of stack, but it should grow with the number of primes, which seems +-- to be O(log log n). +primes :: (Integral a) => [a] +primes = primesn (2 : [ k*2+1 | k <- [1..] ]) + where primesn (n:xs) = + n : (primesn (filter (\k -> k `mod` n /= 0) xs)) + primesn [] = undefined -- keep the compiler happy + +-- | Generate primes up to a given number. See implementation of 'primes' for +-- details. +primes_to :: (Integral a) => a -> [a] +primes_to k = takeWhile (<= k) primes + +-- | Check if a number is square-free (by brute force). +is_square_free :: (Integral a) => a -> Bool +is_square_free n = + (n /= 0) && + (not $ any (\p -> (p*p) `divides` n) $ takeWhile (\x -> x^2 <= (abs n)) [2..]) + +-- | Compute the Jacobi symbol. The definition and algorithm description is +-- taken from . +jacobi_symbol :: (Integral a, Num b) => a -> a -> b +jacobi_symbol a p = + jacobi_symbol' a p + where + -- The actual implementation of the algorithm. Splitted away to allow + -- logging. + jacobi_symbol' a p + | a == 0 = 0 + | a == 1 = 1 -- Rule 4 + | a == 2 = if (p `mod` 8 == 1 || p `mod` 8 == 7) then 1 else -1 -- Rule 8 + | a >= p = jacobi_symbol (a `mod` p) p -- Rule 2 + | 2 `divides` a = (jacobi_symbol (a `div` 2) p) * (jacobi_symbol 2 p) -- Rule 4 + | otherwise = (if p `mod` 4 == 3 && a `mod` 4 == 3 then -1 else 1) -- Rule 6 + * (jacobi_symbol p a) + +-- | @'mod_with_max' /x/ /y/ /max/@: reduce /x/ modulo /y/, returning the unique representative /x'/ in the range /max/ – /y/ < /x'/ ≤ /max/. +mod_with_max :: (Integral a) => a -> a -> a -> a +mod_with_max x y max = max - ((max - x) `mod` y) + +-- | Integer division with asserts making sure that the denominator +-- indeed divides the numerator. +divchk :: (Show a, Integral a) => a -> a -> a +divchk nom denom = + if (nom `mod` denom == 0) + then nom `div` denom + else error ("divchk: " ++ show denom ++ " does not divide " ++ show nom ++ "!") + +-- | @'extended_euclid' /a/ /b/@: return (/d/,/x/,/y/), +-- such that /d/ = gcd(/a/,/b/), and /ax/ + /by/ = /d/. +extended_euclid :: Integral a => a -> a -> (a, a, a) +extended_euclid a b = + if (b == 0) then (a, 1, 0) else (d, x, y) + where + (d', x', y') = extended_euclid b (a `mod` b) + (d, x, y ) = (d', y', x' - (a `div` b)*y') + +-- | @/a/ `divides` /b/@: return 'True' if /a/ divides /b/. +divides :: (Integral a) => a -> a -> Bool +divides denom nom = (nom `mod` denom == 0) + +-- | Test whether a real number is an integer. +is_int :: (RealFrac a, Eq a) => a -> Bool +is_int x = x == (fromIntegral $ round x) + +-- | Generate the list of integers describing the continued fraction of a given +-- rational number. Since the number is rational, the expansion is finite. +-- +-- Each rational number /q/ is equal to a unique expression of the form +-- +-- > [image contfrac.png] +-- +-- where /n/ ≥ 0, /a/[sub 0] is an integer, /a/[sub 1], …, /a/[sub /n/] are +-- positive integers, and /a/[sub /n/] ≠ 1 unless /n/=0. This is called the +-- (short) continued fraction expansion of /q/. The function 'continued_list' inputs +-- two integers /num/ and /denom/, computes the continued fraction expansion of +-- /q/ = /num/ \/ /denom/, and returns the non-empty sequence +-- [/a/[sub 0], …, /a/[sub /n/]]. +continued_list :: (Integral int) => int -> int -> [int] +continued_list _ 0 = [] +continued_list num denom = + int_part : continued_list denom num' + where + int_part = num `div` denom + num' = num - int_part*denom + +-- | Generate a list of convergents from a continued fraction (as described by +-- the non-empty list of integers of that fraction). +convergents :: (Integral int, Fractional a) => [int] -> [a] +convergents as = recursive (0,1) (1,0) as + where + recursive (h0, k0) (h1, k1) [] = [] + recursive (h0, k0) (h1, k1) (a2:as) = b2 : recursive (h1, k1) (h2, k2) as + where + h2 = a2 * h1 + h0 + k2 = a2 * k1 + k0 + b2 = (fromIntegral h2) / (fromIntegral k2) + +-- =========================================== +-- * Quantum functions +-- =========================================== + +-- =========================================== +-- ** Generic blackboxing + +-- | Unimplemented components need to be given as black boxes — like named gates, +-- except their types may not just be an endomorphism; like subroutines, except +-- with only a placeholder on the inside. +-- +-- For this module, black boxes are only needed for classical functional routines, +-- i.e. with type qa -> Circ (qa, qb) +blackbox :: (QData qa, QData qb) => String -> qb -> qa -> Circ (qa,qb) +blackbox n out_shape = box n $ \qx -> do + qy <- qinit $ qc_false out_shape + (qx,qy) <- named_gate n (qx,qy) + return (qx,qy) + +-- =========================================== +-- ** Boxed imported arithmetic + +-- $ To reduce the printed sizes of circuits, we box all imported arithmetic components. + +-- | Like 'box', but prepends \"Arith.\" to subroutine names, +-- as a crude form of namespace management. +arithbox :: (QCData qa, QCData qb, QCurry qa_qb qa qb) => String -> qa_qb -> qa_qb +arithbox n = box ("Arith." ++ n) + +-- | Boxed analogue of 'Arith.q_ext_euclid'. +q_ext_euclid :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt,QDInt,QDInt) +q_ext_euclid = arithbox "q_ext_euclid" Arith.q_ext_euclid + +-- | Boxed analogue of 'Arith.q_add'. +q_add :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt) +q_add = arithbox "q_add" Arith.q_add + +-- | Boxed analogue of 'Arith.q_mult'. +q_mult :: (QCData qa, QNum qa) + => qa -> qa -> Circ (qa,qa,qa) +q_mult = arithbox "q_mult" Arith.q_mult + +-- | Boxed analogue of 'Arith.q_div_exact'. +q_div_exact :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_div_exact = arithbox "q_div_exact" Arith.q_div_exact + +-- | Boxed analogue of 'Arith.q_add_in_place'. +q_add_in_place :: QDInt -> QDInt -> Circ (QDInt, QDInt) +q_add_in_place = arithbox "q_add_in_place" Arith.q_add_in_place + +-- | Boxed analogue of 'Arith.q_add_param_in_place'. +q_add_param_in_place ::IntM -> QDInt -> Circ QDInt +q_add_param_in_place = Arith.q_add_param_in_place +{- Currently doesn’t work: +q_add_param_in_place n = + arithbox ("q_add_param_in_place; n = " ++ show n ++ "; ") (Arith.q_add_param_in_place n) +-} + +-- | Boxed analogue of 'Arith.q_div'. +q_div :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_div = arithbox "q_div" Arith.q_div + +-- | Boxed analogue of 'Arith.q_mult_param'. +q_mult_param :: IntM -> QDInt -> Circ (QDInt, QDInt) +q_mult_param = Arith.q_mult_param +{- Currently doesn’t work: +q_mult_param n = + arithbox ("q_mult_param; n = " ++ show n ++ "; ") (Arith.q_mult_param n) +-} + +-- | Boxed analogue of 'Arith.q_mod_unsigned'. +q_mod_unsigned :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_mod_unsigned = arithbox "q_mod_unsigned" Arith.q_mod_unsigned + +-- | Boxed analogue of 'Arith.q_sub_in_place'. +q_sub_in_place :: QDInt -> QDInt -> Circ (QDInt, QDInt) +q_sub_in_place = arithbox "q_sub_in_place" Arith.q_sub_in_place + +-- | Boxed analogue of 'Arith.q_increment'. +q_increment :: QDInt -> Circ QDInt +q_increment = arithbox "q_increment" Arith.q_increment + +-- =========================================== +-- ** Other arithmetic functions + +-- | Turn a 'QDInt' into an 'FPRealQ', with shape specified by another 'FPRealQ' +fprealq_of_QDInt_with_shape :: FPRealQ -> QDInt -> Circ (QDInt, FPRealQ) +fprealq_of_QDInt_with_shape = blackbox "fprealq_of_QDInt_with_shape" + +-- | Divide a 'QDInt' by 2, in place. (Behavior on odd integers: so far, not required.) +-- As this is not required on odd integers, we can assume that the least significant +-- bit is 0, and use an operation equivalent to a right rotate, instead of a right +-- shift. This can be achieved by changing the list indices within the 'QDInt', and not +-- a quantum operation, but this operation is *NOT* controllable. +q_div2 :: QDInt -> Circ QDInt +q_div2 = return . qdint_of_qulist_bh . rotate . qulist_of_qdint_bh + where + rotate as = last as:init as + +-- | Square a 'QDInt'. This is achieved by creating a copy of the input, using the +-- out of place multiplier, and then uncopying the input. +q_square :: QDInt -> Circ (QDInt,QDInt) +q_square qx = do + qx' <- qc_copy qx + (qx,qx',qxqx) <- q_mult qx qx' + qx <- qc_uncopy_fun qx qx' + return (qx,qxqx) + +-- | Test whether a 'QDInt' is (strictly) greater than a parameter 'IntM'. +q_gt_param :: QDInt -> IntM -> Circ (QDInt,Qubit) +q_gt_param qx y = do + let y' = intm_promote y qx "q_gt_param: qx and y must be of the same length" + qy <- qinit y' + (qx, qy, qx_gt_y) <- q_gt qx qy + qterm y' qy + return (qx, qx_gt_y) + +-- | Test whether a 'QDInt' is greater than or equal to a parameter 'IntM'. +q_ge_param :: QDInt -> IntM -> Circ (QDInt,Qubit) +q_ge_param qx y = do + let y' = intm_promote y qx "q_ge_param: qx and y must be of the same length" + qy <- qinit y' + (qx, qy, qx_ge_y) <- q_ge qx qy + qterm y' qy + return (qx, qx_ge_y) + +-- | @'q_mod_semi_signed' /x/ /y/@: reduce /x/ modulo /y/. /x/ is +-- treated as signed, /y/ as unsigned. +-- +-- Note: not non-linear safe in /x/. +q_mod_semi_signed :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt) +q_mod_semi_signed = box "mod" $ \x y -> do +-- Approach: if x < 0, then (-1-x) >= 0, and +-- x `mod` y == (y-1) - ((-1-x) `mod` y) +-- +-- The (cheap) operations before and after 'q_mod_semi_signed' are +-- therefore conditioned on the sign of x; the (expensive) +-- 'q_mod_semi_signed' is performed just once, unconditionally. + x_mod_y <- with_computed + (do + sign_x <- case qdint_length x of + 0 -> qinit False + _ -> qc_copy $ head $ qulist_of_qdint_bh x + x <- q_negate_in_place x `controlled` sign_x + x <- q_decrement x `controlled` sign_x + (_, _, x') <- q_mod_unsigned x y + x' <- q_increment x' `controlled` sign_x + x' <- q_negate_in_place x' `controlled` sign_x + (y,x') <- q_add_in_place y x' `controlled` sign_x + return x') + qc_copy + return (x, y, x_mod_y) + +-- | @'q_mod_with_max' /x/ /y/ /m/@: reduce /x/ modulo /y/, into the range /max/ – /y/ < /x'/ ≤ /max/. (Compare 'mod_with_max'.) +q_mod_with_max :: QDInt -> QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt,QDInt) +q_mod_with_max x y m = do + -- Goal: max - ((max - x) `mod` y) + x_modmax_y <- with_computed + (do + (_, _, x') <- q_sub m x + (_, _, x'_mod_y) <- q_mod_semi_signed x' y + (_, _, x_modmax_y) <- q_sub m x'_mod_y + return x_modmax_y) + qc_copy + return (x, y, m, x_modmax_y) + + +-- | Obsolete function, retained for testing since it evokes a subtle bug in 'with_computed'. +q_mod_2times_buggy :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt) +q_mod_2times_buggy x a = do + x_mod_2a <- with_computed ( do + a' <- qc_copy a + (a,two_a) <- q_add_in_place a a' + x' <- qc_copy x + (x_mod_2a,two_a,x_div_2a) <- q_moddiv_unsigned_in_place x' two_a + return x_mod_2a + ) ( \x_mod_2a -> do + x_mod_2a' <- qc_copy x_mod_2a + return x_mod_2a' + ) + return (x,a,x_mod_2a) + +-- ====================================================================== +-- ** Looping combinators + +-- | Perform a bounded while loop, whose body may produce extra output. +q_bounded_while_with_garbage :: (QData qa, QCData qb) => + (qa -> Circ (qa,Qubit)) -- ^ the conditional test on the data + -> Int -- ^ a bound on the number of times the loop can run + -> qa -- ^ the starting value + -> (qa -> Circ (qa,qb)) -- ^ the body of the loop + -> Circ (qa,qa) -- ^ the initial and final values, and the produced data +q_bounded_while_with_garbage _ 0 x _ = qc_copy_fun x +q_bounded_while_with_garbage test bound x body = do + (x, x_really_out) <- with_computed_fun x + (\x -> do + x_out <- qinit $ qc_false x + failed_before <- qinit False + (x_final, x_out, failed_ever, loop_garbage) <- loopM bound (x, x_out, failed_before, []) + (\(x_cur, x_out, failed_before, garbage) -> do + (x_cur, good_now) <- test x_cur + -- If we fail now for the first time, copy the current value to the output value: + (x_out, x_cur) <- controlled_not x_out x_cur `controlled` good_now .==. 0 .&&. failed_before .==. 0 + -- Going forward, we’ve failed unless we’re good now *and* we’ve not failed before: + failed_now <- qinit True + failed_now <- qnot failed_now `controlled` good_now .==. 1 .&&. failed_before .==. 0 + -- In any case, apply the body again: + (x_cur, new_garbage) <- body x_cur + return (x_cur, x_out, failed_now, (good_now, failed_before, new_garbage):garbage)) + -- If the loop never finished, copy its last value to the output value: + (x_out, x_final) <- controlled_not x_out x_final `controlled` failed_ever .==. 0 + return (x_out, (x_final, failed_ever, loop_garbage))) + (\(x_out, garbage) -> do + (x_out, x_really_out) <- qc_copy_fun x_out + return ((x_out, garbage), x_really_out)) + return (x, x_really_out) + +-- | Perform a bounded-length while loop, with an endo-typed body. +-- +-- Note: uses /2 * bound/ ancillas. Can this be avoided? +q_bounded_while :: (QCData qa) => + (qa -> Circ (qa,Qubit)) -- ^ the conditional statement + -> Int -- ^ a bound on the number of times the loop can run + -> qa -- ^ the starting value + -> (qa -> Circ qa) -- ^ the body of the loop + -> Circ (qa,qa) -- ^ return the initial value, and the final post-loop value +q_bounded_while _ 0 x _ = qc_copy_fun x +q_bounded_while test bound x body = + with_computed_fun x + (\x -> do + (x,c) <- test x + x <- body x `controlled` c + return (x,c)) + + (\(x,c) -> bw_aux (bound-1) x c) + where +-- Auxiliary function: perform the loop with a running control qubit, +-- to avoid building up multi-ary controls: +-- bw_aux :: Int -> qa -> Qubit -> Circ ((qa,Qubit),qa) +-- Oddly, Haskell reads this type signature as generalising qa, +-- causing the following to fail to typecheck. + bw_aux 0 x c = do (x,x') <- qc_copy_fun x; return ((x,c),x') + bw_aux bound x c = do + with_computed_fun (x,c) + (\(x,c) -> do + (x,c') <- test x + c'' <- qinit False + c'' <- qnot c'' `controlled` [c,c'] + x <- body x `controlled` c'' + return (x,c,c',c'')) + (\(x,c,c',c'') -> do + ((x,c''),x') <- bw_aux (bound-1) x c'' + return ((x,c,c',c''),x')) + +-- | Perform a bounded while loop, whose body may produce extra output. +q_bounded_while_productive :: (QCData qa, QCData qb) => + (qa -> Circ (qa,Qubit)) -- ^ the conditional test on the data + -> Int -- ^ a bound on the number of times the loop can run + -> qa -- ^ the starting value + -> (qa -> Circ (qa,qb)) -- ^ the body of the loop + -> Circ (qa,qa,[qb]) -- ^ the initial and final values, and the produced data +q_bounded_while_productive test bound x body = do + ((x,[]),(x',ys)) <- + q_bounded_while + (\(x,ys) -> do (x,c) <- test x; return ((x,ys),c)) + bound + (x,[]) + (\(x,ys) -> do (x,y_new) <- body x; return (x,y_new:ys)) + return (x,x',ys) + +-- | Perform a bounded “do_until” loop. +q_do_until :: (QCData qa) => + Int -- ^ a bound on the number of times the loop can run + -> qa -- ^ the starting value + -> (qa -> Circ (qa,Qubit)) -- ^ the body of the loop, producing an input to the next iteration, plus a qubit to mark if we’re finished yet. + -> Circ (qa,qa) -- ^ return the initial and final values +q_do_until bound x body = do + with_computed_fun x body + (\(x,c) -> do_aux (bound-1) x c) + where +-- Auxiliary function: perform the loop with a running control qubit, +-- to avoid building up multi-ary controls: +-- do_aux :: Int -> qa -> Qubit -> Circ ((qa,Qubit),qa) +-- Oddly, Haskell reads this type signature as generalising qa, +-- causing the following to fail to typecheck. + do_aux 0 x c = do (x,x') <- qc_copy_fun x; return ((x,c),x') + do_aux bound x c = do + with_computed_fun (x,c) + (\(x,c) -> do + (x,c') <- body x `controlled` c + c'' <- qinit False + c'' <- qnot c'' `controlled` [c,c'] + return (x,c,c',c'')) + + (\(x,c,c',c'') -> do + ((x,c''),x') <- do_aux (bound-1) x c'' + return ((x,c,c',c''),x')) diff --git a/dist/build/Quipper/Algorithms/CL/CL.hs b/dist/build/Quipper/Algorithms/CL/CL.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/CL/CL.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/CL/CL.hs" #-} +-- | An implementation of the quantum algorithms, based on the works of Hallgren, to compute the class number of a real quadratic number field. + +module Quipper.Algorithms.CL.CL where + +import Quipper + +import Quipper.Libraries.QFT +import Quipper.Libraries.Arith +import Quipper.Libraries.FPReal +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.CL.Auxiliary +import Quipper.Algorithms.CL.Types +import Quipper.Algorithms.CL.RegulatorClassical +import Quipper.Algorithms.CL.RegulatorQuantum +import Quipper.Algorithms.CL.SmithReduction + +import Data.Ratio +import Data.Maybe +import Data.List +import System.Random + +-- ====================================================================== +-- * Stage 1 (quantum): Approximate regulator to low precision +-- ====================================================================== + +-- | Quantum part of the procedure to approximate the regulator /R/. +-- +-- Follows the procedure described in [Jozsa 2003], Sec. 10. An adapted +-- version of the Hidden Subgroup Problem (HSP) Algorithm is used to +-- estimate the (irrational) period of the function /f/ [sub /N/] +-- ('fN', 'q_fN'); this is the function /h/ of [Jozsa 2003], Sec. 9, +-- discretized with precision /N/ = 2 [super −/n/], and so has weak +-- period /S/ = /NR/. The precision /n/ is determined by 'n_of_bigD'. +-- +-- Inputs: Δ; /i/, an assumed bound such that /S/ ≤ 2[sup /i/]; +-- and a random “jitter” parameter. +approximate_regulator_circuit :: CLIntP -> Int -> CLIntP -> (Circ CInt) +approximate_regulator_circuit bigD i jitter = do + let n = n_of_bigD bigD + nn = 2^n + s_bound = 2^i + -- q is the register length, and Q = 2^q (qq in Haskell code) the number of states. + q = 2 + 2 * i -- So 2^q = 4 * (s_bound^2), the first power of 2 assumed to + qq = 2^q -- be above 3 S^2. + l = 4 + q + n -- Chosen to give: + ll = 2^l -- L = 16 Q N. + t = i + 2 * (ceiling $ logBase 2 $ sqrt $ fromIntegral bigD) + j_p = intm (4+q) jitter + + -- Step 1 - apply Hadamard transform to register 1 + reg1 <- qinit $ qc_false $ qshape $ intm q 0 + -- Note: the [qc_false $ qshape] is currently redundant, since 0 is encoded as |00…00>. + -- However, that is dependent on the specific representation of integers; + -- using qc_false specifies the all-0 state independently of the + -- representation of integers. + reg1 <- mapUnary hadamard reg1 + + -- Step 2 - Apply unitary transformation corresponding to f_N. (This automatically initialises reg2.) + (reg1,reg2) <- q_fN bigD n l reg1 j_p + + -- Step 3 - Discard contents of reg2. + reg2_c <- measure reg2 + cdiscard reg2_c + + -- Step 4 - apply QFT + reg1 <- qft_int reg1 + + -- Step 5 - measure register 1, and return the measurement. + reg1_c <- measure reg1 + return reg1_c + +-- | Attempt to approximate the regulator /R/, given an assumed +-- bound /i/ such that /S/ ≤ 2[sup /i/], using the probabilistic +-- quantum computation @approximate_regulator_circuit@ twice as +-- described in [Jozsa 2003], Sec. 10. +-- +-- Check the result for success; if it fails, return 'Nothing'. +-- +-- (The 'IO' monad is slight overkill here: it is just to make a +-- source of randomness available. A tighter approach could use e.g. a +-- monad transformer such as 'Control.Monad.Random.RandT', applied to +-- the 'Circ' monad.) +try_approximate_regulator :: CLIntP -> Int -> IO (Maybe CLReal) +try_approximate_regulator bigD i = do + let n = n_of_bigD bigD + q = 2 + 2 * i -- So 2^q = 4 * (s_bound^2), the first power of 2 assumed to + qq = 2^q -- be above 3 S^2. + + c_jitter <- getStdRandom $ randomR (0, 16*qq - 1) + c <- run_generic_io (undefined :: Double) $ approximate_regulator_circuit bigD i c_jitter + d_jitter <- getStdRandom $ randomR (0, 16*qq - 1) + d <- run_generic_io (undefined :: Double) $ approximate_regulator_circuit bigD i d_jitter + + -- Find the (possibly empty) list of m's that pass the verification + -- criteria. The candidate m's are constructed from the convergents of c/d + let candidate_ms = filter (verify_period_multiple bigD n) $ + map (\c_n -> round $ c_n * (fromIntegral qq) / (fromIntegral c)) $ + convergents $ continued_list (fromIntegral c) (fromIntegral d) + + return $ if (null candidate_ms) + then Nothing + else (Just (fprealx (-n) (head $ sort $ candidate_ms))) + +-- | @'verify_period_multiple' Δ /n/ /m/@: +-- check whether /m/ is within 1 of a multiple of the period /S/ of /f/[sub /N/]. +-- +-- Since for any ideal /I/, ρ(ρ(/I/)) is distance > ln 2 from /I/, it suffices +-- to check whether the unit ideal is within 4 steps either way of /f/[sub /N/](m). +verify_period_multiple :: CLIntP -> Int -> CLInt -> Bool +verify_period_multiple bigD n m = + let jj = fst $ fN m (2^n) 0 0 bigD + in (unit_ideal bigD) + `elem` ([jj] ++ (take 4 $ iterate rho jj) ++ (take 4 $ iterate rho_inv jj)) + +-- | Approximate the regulator for a given Δ (/bigD/). +-- +-- Repeatedly run @'try_approximate_regulator'@ enough times, with increasing +-- /i/, that it eventually succeeds with high probability. +approximate_regulator :: CLIntP -> IO CLReal +approximate_regulator bigD = + -- Create a (infinite and lazy) list of attempts to approximate the + -- regulator, assuming S ≤ 2^i for i = 1, 2, … + -- (For each value of /i/, make (36 * i) attempts.) + -- Run the attempts until one succeeds; return its answer. + fmap (fromJust . fromJust) $ sequence_until isJust $ concat + [ replicate (36*i) (try_approximate_regulator bigD i) | i <- [1..] ] + +-- ====================================================================== +-- * Stage 2 (classical): Compute the regulator more accurately. +-- ====================================================================== + +-- | Improve the precision of the initial estimate of the regulator /R/, for +-- a quadratic discriminant Δ. +-- +-- The implementation is essentially based on the proof of Theorem 5 of +-- [Jozsa 2003]. +improve_regulator_accuracy :: CLReal -> Integer -> CLReal +improve_regulator_accuracy bigR bigD = + fRefine dist idealNew + where + (dist, idealNew) = improve_regulator_accuracy' bigD + improve_regulator_accuracy' :: Integer -> (CLReal, IdDist) + improve_regulator_accuracy' bigd = refineR (head j') ideals + + -- ------------------------------------------------------------------------- + -- Step 3: So far we have computed ideals, I_i , I_i-1 , I_i-2 ,.., I_1. + -- Now, for I_i perform dot (*) operation with Ii-1, Ii-2, .., I_1 while + -- (I_i * I_k) < R is true. If (I_i *I_k) > R, then discard I_k and + -- continue with I_k-1. Finish when I_1 is reached. + -- At this point a reduced Ideal J* is produced to the left of R with + -- R - delta(J*). In parallel accumulate distances using fomula + -- delta(I,rho(I)) = ln |gamma| for I = Z +gammaZ and Proposition 34 + -- of [Jozsa 2003]. In the end apply repeatedly rho**2 to J* while + -- distance does not exeed R. + -- ------------------------------------------------------------------------ + fRefine :: CLReal -> IdDist -> CLReal + fRefine currDist reducedI = + -- fRefine currDist reducedI = if (newDist < bigR) + let + newReducedI = rho_d $ rho_d reducedI + newDist = delta newReducedI + in if (newDist < bigR) + then + fRefine newDist newReducedI + else + currDist + + refineR :: IdDist -> [IdDist] -> (CLReal, IdDist) + refineR currI (x:xs) = + -- repeat applying an Ideal to the reference Ideal until + -- the distance that is smaller than 'r' is found. + if (null xs) + then + case (distance > bigR) of + True -> (delta currI, currI) + False -> (distance, i') + else + if (distance > bigR) + then + refineR currI xs + else + refineR i' xs + where + distance = delta i' + i'' = currI `dot` x + i' = while (not . is_reduced . fst) rho_d i'' + + refineR _ [] = undefined -- keep the compiler happy + + -- -------------------------------------------------------------------- + -- Step 2: Compute the closest ideal I to the left of R along the cycle + -- of principal reduced ideals and its distance which is the closest + -- to real value. + -- At the end of this step an Ideal I_i and a list of ideals I_i-1, + -- I_i-2,.., In1, will be constructed. + -- -------------------------------------------------------------------- + -- The following function constructs a list of ideals I_i, I_i-1, I+i-2,..., I_1, + -- where delta(I_n) < bigR. + -- j' is an Ideal, I_i (or I_N of [Jozsa 2003], in first paragraph of p.24) + -- + -- @ideals@ contains the list of ideals so far collected, with the + -- the newest entry at the head. + (j', ideals) = splitAt 1 $ reverse $ refineR1 i0 + + refineR1 :: IdDist -> [IdDist] + refineR1 x + -- each time multiplication is done, reduce the Ideal and compute delta as well + -- rho function also computes the new accumulating distance each time + | (delta x) < bigR = x : refineR1 (reduceIdeal $ dot' x) + | otherwise = [] + where + -- reduce the ideal + reduceIdeal ::IdDist -> IdDist + reduceIdeal i = while (not . is_reduced . fst) rho_d i + + -- ---------------------------------------------------------------- + -- Step 1: Compute the initial Ideal I0 and its distance Delta(I0). + -- compute the initial Ideal + -- ---------------------------------------------------------------- + i0 = rho_d $ rho_d $ (unit_ideal bigD, 0) + +-- ====================================================================== +-- * Stage 3 (classical): Find generators of the class group. +-- ====================================================================== + +-- | A set of ideal classes generating /CL/(/K/). +-- +-- Implementation: assuming the Generalized Riemann Hypothesis, it is +-- enough to enumerate the non-principal prime ideals arising as +-- factors of (/p/), for primes /p/ ≤ 12(ln Δ)[super 2]. ([Haase and +-- Maier 2006], Prop. 4.4.) For each /p/, there are at most two such +-- prime ideals, and they are easily described. +compute_generators :: CLIntP -> [IdealRed] +compute_generators bigD = + map (reduce . ideal_from_generator) $ + concat [gens_from_prime p | p <- primes_to primes_bound, p >= 3] + where + primes_bound = (12*((floor $ log $ fromIntegral bigD)^2)) + d = d_of_bigD bigD + omega = omega_of_bigD bigD + omega_bar = conjugate omega + + -- the polynomial with roots omega, omega_bar + f = if (bigD `mod` 4 == 1) + then (\x -> x^2 - x - ((bigD - 1) `div` 4)) + else (\x -> x^2 - bigD) + + gens_from_prime 2 = case (d `mod` 8) of + 5 -> [] + 1 -> [(2, omega), (2, omega_bar)] + 3 -> [(2, AlgNum (-1) (1/2) bigD)] + 7 -> [(2, AlgNum (-1) (1/2) bigD)] + _ -> [(2, AlgNum 0 (1/2) bigD)] + gens_from_prime p = case (d `jacobi_symbol` p) of + 0 -> [(p, omega - c)] + 1 -> [(p, omega - c),(p, c - omega_bar)] + _ -> [] + where + c = fromIntegral $ head [ x | x <- [0..p-1], (f x) `mod` p == 0 ] + + -- give the standard form of the ideal generated by (p,x), + -- provided that x is of the form (b + √Δ)/2 + ideal_from_generator :: (CLIntP, AlgNum) -> Ideal + ideal_from_generator (p, w) = + let b = (2*w - (AlgNum 0 1 bigD)) + in assert (snd_AlgNum b == 0 && is_int (fst_AlgNum b)) + ("compute_generators: w = " ++ show w ++ " is not of expected form") + (Ideal bigD 1 1 (fromIntegral p) (truncate (fst_AlgNum b))) + +-- ====================================================================== +-- * Stage 4 (quantum): Find relations between generators. +-- +-- $ Notation is as in [Hallgren 2006, Section 5]. Note: Some +-- components are currently missing here, and are marked +-- \"incomplete\" in the code below. + +-- ====================================================================== + +-- | Compute the generators of /CL/(/K/), function /hI/. +hI :: IdDist -> CLInt -> CLInt -> CLInt -> CLIntP -> CLIntP -> (IdDist, CLInt) +hI ideal_I a b j n l = + (ideal_K'', floor (fromIntegral n * delta ideal_K'')) + where + bigD = bigD_of_Ideal (fst ideal_I) + ideal_J = ideal_I + ideal_K = (unit_ideal bigD, 0) + i = a + (i', ideal_J', ideal_K') = + bounded_while condition bound body (i, ideal_J, ideal_K) + where + bound = ceiling $ logBase 2 (fromIntegral a) + + body (i,j,k) = ( + floor ((fromIntegral i) / 2), + j `star` j, + if (i `mod` 2 /= 0) then k `star` j else k) + + condition (i,j,k) = (i /= 0) + + ideal_J'' = fst $ fN_d b j n l (bigD_of_Ideal $ fst ideal_I) + ideal_K'' = ideal_K' `star` ideal_J'' + +-- | Compute the ideals from the generators (ĝ function). +compute_ghat :: (Integral int) => [IdDist] -> [int] -> IdDist +compute_ghat gs is = + foldl1 (\g_i g_j -> g_i `star` g_j) $ + map (\(ik, gk) -> gk `power` ik) $ zip is gs + + where + power :: (Integral int) => IdDist -> int -> IdDist + power gk 0 = let (Ideal bigD m l a b, _) = gk in (unit_ideal bigD, 0) + power gk 1 = gk + power gk n = gk `star` (power gk (n-1)) + +-- | Compute /i/\//N/. Incomplete. +compute_i_N_at :: QDInt -> QDInt -> Circ() +compute_i_N_at reg_I reg_out = + error "incomplete" + + +-- | Compute register sizes for @structure_circuit@, given +-- Δ and a precise estimate of /R/. Return a 7-tuple +-- (/q/,1,2,3,4,5,6) where /q/ is the size of the first +-- /k/ registers, and 1…6 are the sizes of registers /k/+1…/k/+6. +register_sizes :: CLIntP -> CLReal -> (Int,Int,Int,Int,Int,Int,Int) +register_sizes bigD r = + (q, r1, r2, r3, r4, r5, r6) + where + q = clog2i bigD + r1 = 2 * clog2r sqrt_bigD + r2 = clog2i round_nr + r3 = 2 * clog2r sqrt_bigD + clog2i round_nr + r4 = clog2i (m * round_nr) + r5 = clog2i round_nr + r6 = 2 * clog2r sqrt_bigD + clog2i round_nr + + -- Algorithm constants + sqrt_bigD = sqrt $ fromIntegral bigD + round_nr = round nr + + m = ceiling $ 2*r+1 + b = ceiling $ 2 * sqrt_bigD + (p',q') = find_pq_satisfying_condition br m + n = q' * b + l = 16 * q * n + nr = fromIntegral n * r + br = fromIntegral b * r + + -- Find a pair (p,q) from the continued fraction expansion of BR such + -- that |BR - p\/q| <= 1/(4qM) + find_pq_satisfying_condition :: (Integral int, Show int) => CLReal -> int -> (int, int) + find_pq_satisfying_condition br m = + if (isJust found) + then (num, denom) + else error $ + "Could not find p/q such that |BR - p/q| <= 1/(4qM) for:\n" ++ + "br = " ++ (show br) ++ "\n" ++ + "m = " ++ (show m) ++ "\n" ++ + "convergents = " ++ (show convs) + where + num = fromIntegral $ numerator $ fromJust found + denom = fromIntegral $ denominator $ fromJust found + + found = find satisfies convs + + convs = convergents $ + continued_list + (numerator $ toRational $ br) + (denominator $ toRational $ br) + + satisfies :: Rational -> Bool + satisfies p_over_q = + abs (br - fromRational p_over_q) <= 1/(4*q*m') + where q = fromIntegral $ denominator p_over_q + m' = fromIntegral m + + -- Helper function - ceiling(log_2 val) + clog2r :: (RealFrac a, Floating a, Integral int) => a -> int + clog2r val = ceiling $ logBase 2 val + + clog2i :: (Integral int) => int -> Int + clog2i val = clog2r $ fromIntegral val + + +-- | The quantum circuit used in computing the structure of /CL/(/K/), +-- given Δ, a precise estimate of /R/, and a generating set for /CL/(/K/). +structure_circuit :: CLIntP -> CLReal -> [IdealRed] -> (Circ [CInt]) +structure_circuit bigD r gs = do + -- Apply H to first k registers of size 'q' each + reg_ks <- qinit [ intm q 0 | x <- gs ] + reg_ks <- mapUnary hadamard reg_ks + + -- Initialize the rest of the registers in state zero + -- note: fIN and fJN is the same thing. + reg_I <- qinit (intm reg_I_size 0) -- register 1 + reg_i <- qinit (intm reg_i_size 0) -- register 2 + reg_fIN <- qinit (intm reg_fIN_size 0) -- register 3 + reg_i_N <- qinit (intm reg_i_N_size 0) -- register 4 + + -- Apply U_g_hat +-- Incomplete: (q_compute_ghat gs) reg_ks reg_I + + -- Superposition of distances + reg_i <- mapUnary hadamard reg_i + + -- Evaluate f_I,N +-- Imcomplete: q_fJN reg_i reg_I reg_fIN + + -- Compute i/N + compute_i_N_at reg_I reg_i_N + + -- Erase reg_i +-- Incomplete: erase_at fJN reg_i reg_I reg_fIN + + -- Uncompute i/N +-- Incomplete: uncompute_i_N_at reg_I reg_i_N + + -- Uncompute I +-- Incomplete: q_compute_ghat gs reg_ks reg_I + + -- Measure and discard result (used to project the system) + result_discard <- measure reg_fIN + + -- Apply QFT + -- FIX: Looking at the definition: + -- Fq x Fq ... (|l1>...|lk>) = Fq|l1> x ... x Fq|lk> + -- it seems the QFT can can be applied on the per-register basis. Check. + -- FIX: Check if the endianness is correct + reg_ks <- sequence $ map qft_int reg_ks + + -- Measure the system + reg_ks_measured <- mapM measure reg_ks + return (reg_ks_measured) + + where + (q, + reg_I_size, reg_i_size, + reg_fIN_size, reg_i_N_size, + _, _) = register_sizes bigD r + +-- | Compute the relations between a given set of reduced generators. +compute_relations :: CLIntP -> CLReal -> [IdealRed] -> IO [CLInt] +compute_relations bigD r generators = do + result <- run_generic_io (undefined :: Double) $ structure_circuit bigD r generators + return (result) + +-- ====================================================================== +-- * Section 5 (classical): compute class number. +-- ====================================================================== + +-- | The full implementation of Hallgren’s algorithm. +-- +-- @class_number dd t@: computes the class number |/CL/(/K/)| for Δ = /dd/, +-- with success probability at least (1 - 1\/2[sup /t/]). +class_number :: CLIntP -> Int -> IO(CLInt) +class_number bigD t = do + -- Stage 1: Approximate regulator to low precision + approximate_regulator <- approximate_regulator bigD + + -- Stage 2 & 3: Classical algorithms + let regulator = improve_regulator_accuracy approximate_regulator bigD + generators = compute_generators bigD + + k = length generators + q = ceiling $ logBase 2 $ fromIntegral bigD + bigT = t + k * (ceiling $ logBase 10 $ fromIntegral q) + + -- Stage 4: Use HSP to compute set of relations + relations <- mapM (\_ -> compute_relations bigD regulator generators) [ 1 .. bigT ] + + -- Stage 5: Make canonical set and derive CL(K) from structure + return $ group_order_from_matrix $ matrix_from_list relations diff --git a/dist/build/Quipper/Algorithms/CL/Main.hs b/dist/build/Quipper/Algorithms/CL/Main.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/CL/Main.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/CL/Main.hs" #-} +-- | +-- Authors: Keith Kim, Peter LeFanu Lumsdaine, Alexandr Virodov +-- +-- An implementation of Hallgren’s Class Number algorithm. This algorithm computes various invariants of +-- a real quadratic number field /K/ = ℚ(√Δ), notably the class number and the structure of the class group /CL/(/K/). +-- The field /K/ is specified by its discriminant /Δ/, the main input to the algorithm. +-- +-- The algorithm may also be adapted to other problems from algebraic number theory, including Pell's equation (finding integer solutions to /x/ [sup 2] − /dy/ [sup 2] = 1, for non-square /d/) and the principal ideal problem (determining whether an ideal of a number field is principal, and finding a generator if so). +-- +-- The present implementation falls into five stages, which we will refer to throughout the documentation: +-- +-- 1. Approximate the regulator of /K/, to low precision, using a version of the the (quantum) HSP algorithm. +-- +-- 2. Classically, refine the approximation from part 1 to higher precision. +-- +-- 3. Classically compute a small generating set for the class group, using the value of the regulator from part 2. +-- +-- 4. Compute relations for these generators, again using a version of the HSP algorithm. +-- +-- 5. Classically compute from these the structure of the class group, and hence the class number. +-- +-- Further details are given in the documentation of individual modules. +-- +-- The algorithm and its mathematical background are described in: +-- +-- * Sean Hallgren, \"Polynomial-time quantum algorithms for Pell’s equation and the principal ideal problem\", +-- in /STOC ’02: Proceedings of the thirty-fourth annual ACM symposium on Theory of computing/, pp. 653–658, 2002. +-- (Also published in J. ACM, 54(1), 2007.) +-- +-- * Richard Jozsa, \"Quantum computation in algebraic number theory: Hallgren’s efficient quantum +-- algorithm for solving Pell’s equation.\" Annals of Physics, 306:241–279, February 2003; +-- also available as . All references in documentation +-- refer to arXiv version. +-- +-- * Daniel Haase and Helmut Maier, \"Quantum algorithms for number fields.\" Fortschr. Phys., +-- 54(8):866–881, 2006. +-- +-- The present implementation is based on a detailed algorithm specification that was provided to us by the IARPA QCS +-- program and written by Brian J. Matt, Durward McDonell, and David Zaret. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.CL.Main": Command line interface. +-- +-- * "Quipper.Algorithms.CL.Auxiliary": General-purpose functions required in Hallgren’s algorithm. +-- +-- * "Quipper.Algorithms.CL.Types": Specialized classical and quantum datatypes used in Hallgren’s algorithm, and basic functions on these types. +-- +-- * "Quipper.Algorithms.CL.CL": The high-level structure of Hallgren’s algorithm. +-- +-- * "Quipper.Algorithms.CL.RegulatorClassical": A classical implementation of the functions and operations of stages 1–4. +-- +-- * "Quipper.Algorithms.CL.RegulatorQuantum": A quantum implementation of the functions required for stages 1 and 4 +-- +-- * "Quipper.Algorithms.CL.SmithReduction": Matrices, and reduction to Smith Normal Form, for Stage 5. +-- +-- * "Quipper.Algorithms.CL.Test": Functions to test components of the present implementation, using classical computation. + +module Quipper.Algorithms.CL.Main where + +import Quipper +import Quipper.Utils.CommandLine +import Quipper.Libraries.Arith +import Quipper.Libraries.FPReal +import Quipper.Libraries.Decompose +import Quipper.Libraries.Unboxing + +import Quipper.Algorithms.CL.Auxiliary +import Quipper.Algorithms.CL.Types +import Quipper.Algorithms.CL.RegulatorClassical +import Quipper.Algorithms.CL.RegulatorQuantum +import Quipper.Algorithms.CL.CL +import Quipper.Algorithms.CL.Test + +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.Random +import Control.Monad +import Data.Bits +import Data.Maybe +import Data.List +import Data.Char + +-- ---------------------------------------------------------------------- +-- * Command line interface + +-- $ This module provides a command line interface for Hallgren’s Class +-- Number algorithm. This allows the user, for example, to print or simulate +-- the circuits used in quantum portions of the algorithm, or to run +-- small instances of the algorithm in a classical implementation. +-- +-- Sample invocations: +-- +-- >>> ./cl -R +-- +-- Compute, classically, the regulator of ℚ[√Δ], with Δ = 28 (default value). +-- +-- >>> ./cl -P -d 17 +-- +-- Compute, classically, the fundamental solution of Pell’s equation +-- /x/[super 2] − /d//y/[super 2] = 1 +-- with /d/ = /Δ/ = 17. +-- +-- >>> ./cl -S fn -d 5 -f eps > cl_fn_d5.eps +-- +-- Produce an .eps file of the quantum circuit implementing the +-- pseudo-periodic function /f/[sub /N/] used for regulator estimation, +-- for Δ = 5 +-- +-- >>> ./cl -S starprod -d 60 -f gatecount +-- +-- Give gate-count for the quantum circuit implementing the star-product +-- on ideals, for Δ = 17 +-- +-- >>> ./cl --help +-- +-- Print detailed usage information. + +-- ---------------------------------------------------------------------- +-- * Option processing +-- +-- | An enumeration type for determining what the main function should do. +data WhatToShow = + Stage1 -- ^Show the circuit for stage 1 of the algorithm + | Stage4 -- ^Show the circuit for stage 4 of the algorithm + | Sub -- ^Show the circuit for a specific quantum subroutine + | Regulator -- ^Classically, find the regulator + | FundamentalUnit -- ^Classically, find the fundamental unit + | PellSolution -- ^Classically, find the fundamental solution of Pell’s equation + deriving Show + +-- | An enumeration type for selecting a subroutine. +data Subroutine = + Rho + | RhoInv + | Normalize + | DotProd + | StarProd + | FN + deriving (Show, Enum, Bounded) + +-- | An enumeration of available subroutines. (Compare 'format_enum', 'gatebase_enum'.) +subroutine_enum :: [(String, Subroutine)] +subroutine_enum = map (\x -> (map toLower (show x),x)) [minBound..maxBound] + +-- | A data type to hold values set by command line options. +data Options = Options { + -- Main “what to do” type options: + what :: WhatToShow, -- ^What kind of thing to output. + format :: Format, -- ^The output format. + gatebase :: GateBase, -- ^What kind of gates to decompose into. + sub :: Subroutine, -- ^Which subroutine to output (if @'what' == 'Sub'@). + + -- Master problem parameter + cl_delta :: CLIntP, -- ^The discriminant Δ, specifying the problem. + + -- Inputs for stage 1 of the algorithm + cl_i :: Int, -- ^i, log_2 of the estimated bound 2^i for the weak period S. + + -- Inputs for stage 4 of the algorithm + cl_r :: CLReal, -- ^ The (good) approximation R of the period. + cl_q :: CLIntP, -- ^The parameter q for stage 4 of the algorithm. + cl_k :: CLIntP, -- ^The parameter k for stage 4 of the algorithm. + cl_n :: CLIntP, -- ^The parameter n for stage 4 of the algorithm. + cl_m :: CLIntP, -- ^The parameter m for stage 4 of the algorithm. + + cl_generators :: [IdealRed], -- ^A generating set for /CL/(/K/). + + -- Misc options + cl_seed :: Int -- ^The seed for the random generator (0 for seed from time) +} deriving (Show) + +-- | The default options. +default_options :: Options +default_options = Options { + what = Stage1, + format = ASCII, + gatebase = Logical, + sub = FN, + + cl_delta = 28, + + cl_i = 1, + + cl_r = 12.345, + cl_q = 4, + cl_k = 3, + cl_n = 3, + cl_m = 5, + + cl_generators = [], + + cl_seed = 1 +} + +-- | Show the default value of an option. +show_default :: (Show a) => (Options -> a) -> String +show_default func = show (func default_options) + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = [ +-- Generic options: + Option ['h'] ["help"] (NoArg help) $ "print usage info and exit", + Option ['f'] ["format"] (ReqArg read_format "") $ "output format for circuits (default: " ++ show_default format ++ ")", + Option ['g'] ["gatebase"] (ReqArg read_gatebase "") $ "gates to decompose into (default: " ++ show_default gatebase ++ ")", + +-- Select what to do: + Option ['1'] [] (NoArg (what Stage1)) $ "output the circuit for stage 1 of the algorithm (default)", + Option ['4'] [] (NoArg (what Stage4)) $ "output the circuit for stage 4 of the algorithm", + Option ['S'] ["sub"] (ReqArg read_subroutine "") $ "output the circuit for a specific subroutine", + Option ['R'] ["regulator"] (NoArg (what Regulator)) $ "classically, find the regulator, given Δ", + Option ['F'] [] (NoArg (what FundamentalUnit)) $ "classically, find the fundamental unit, given Δ", + Option ['P'] [] (NoArg (what PellSolution)) $ "classically, find the fundamental solution of Pell’s equation, given Δ", + +-- Input parameters + Option ['d'] ["delta"] (ReqArg read_delta "") $ "discriminant Δ (a.k.a. D) (default: " ++ show_default cl_delta ++ ")", + + Option ['s'] ["ss"] (ReqArg read_s "") $ "estimated bound on period S, for stage 1 (default: " ++ show (2^(cl_i default_options)) ++ ")", + Option ['i'] [] (ReqArg read_i "") $ "estimated bound on log_2 S, for stage 1 (default: " ++ show (cl_i default_options) ++ ")", + + Option ['r'] ["rr"] (ReqArg read_r "") $ "approximate regulator R, for stage 4 (default: " ++ show_default cl_r ++ ")", + Option ['q'] [] (ReqArg read_q "") $ "The parameter q, for stage 4 (default: " ++ show_default cl_q ++ ")", + Option ['k'] [] (ReqArg read_k "") $ "The parameter k, for stage 4 (default: " ++ show_default cl_k ++ ")", + Option ['n'] [] (ReqArg read_n "") $ "The parameter n, for stage 4 (default: " ++ show_default cl_n ++ ")", + Option ['m'] [] (ReqArg read_m "") $ "The parameter m, for stage 4 (default: " ++ show_default cl_m ++ ")", + +-- Miscellaneous options + Option [] ["seed"] (ReqArg read_seed "") $ "Random seed (0 for seed from time)(default: " ++ show_default cl_seed ++ ")" + ] + where + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + + read_format :: String -> Options -> IO Options + read_format str o = do + case match_enum format_enum str of + [(_, f)] -> return o { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + read_gatebase :: String -> Options -> IO Options + read_gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + read_subroutine :: String -> Options -> IO Options + read_subroutine str o = do + case match_enum subroutine_enum str of + [(_, f)] -> return o { sub = f, what = Sub } + [] -> optfail ("Unknown subroutine -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous subroutine -- " ++ str ++ "\n") + + read_delta = read_arg parse_int (>0) (\n o -> o { cl_delta = fromIntegral n }) "Invalid Δ" + read_seed = read_arg parse_int (>=0) (\n o -> o { cl_seed = fromIntegral n }) "Invalid seed" + read_i = read_arg parse_int (>=0) (\n o -> o { cl_i = fromIntegral n }) "Invalid i" + read_s = read_arg parse_int (>0) (\n o -> o { cl_i = ceiling $ logBase 2 $ fromIntegral n }) "Invalid s" + read_r = read_arg parse_double (>0) (\n o -> o { cl_r = fromRational $ toRational n }) "Invalid r" + read_q = read_arg parse_int (>0) (\n o -> o { cl_q = fromIntegral n }) "Invalid q" + read_k = read_arg parse_int (>0) (\n o -> o { cl_k = fromIntegral n }) "Invalid k" + read_n = read_arg parse_int (>0) (\n o -> o { cl_n = fromIntegral n }) "Invalid n" + read_m = read_arg parse_int (>0) (\n o -> o { cl_m = fromIntegral n }) "Invalid m" + + read_arg :: (String -> Maybe a) -> (a -> Bool) -> (a -> Options -> Options) -> String -> String -> Options -> IO Options + read_arg parse cond func err string o = + case parse string of + Just n | cond n -> return $ func n o + _ -> optfail (err ++ " -- " ++ string ++ "\n") + + help :: Options -> IO Options + help o = do + usage + exitSuccess + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) default_options o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to standard output. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + putStr (show_enum "subroutine" subroutine_enum) + where header = "Usage: cl [OPTION...]" + +-- ---------------------------------------------------------------------- +-- * The CL circuit generation main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO() +main = do + -- Read options. + argv <- getArgs + options <- dopts argv + + let bigD = cl_delta options + assertM (is_valid_bigD bigD) $ + "Δ = " ++ (show $ cl_delta options) ++ " not valid discriminant" + let d = d_of_bigD bigD + + case what options of + Stage1 -> main_stage1 options + Stage4 -> main_stage4 options + Sub -> main_sub options + Regulator -> do + putStrLn $ "Regulator (by classical period-finding):" + putStrLn $ "Δ = " ++ show bigD + putStrLn $ "d = " ++ show d + putStrLn $ "R = " ++ show (regulator bigD) + FundamentalUnit -> do + putStrLn $ "Fundamental unit (by classical period-finding):" + putStrLn $ "Δ = " ++ show bigD + putStrLn $ "d = " ++ show d + putStrLn $ "ε_0 = " ++ pretty_show_AlgNum (fundamental_unit bigD) + PellSolution -> do + putStrLn $ "Fundamental solution of Pell’s equation x^2 − d y^2 = 1 (by classical period-finding):" + let (x,y) = fundamental_solution d + putStrLn $ "Δ = " ++ show bigD + putStrLn $ "d = " ++ show d + putStrLn $ "x = " ++ show x + putStrLn $ "y = " ++ show y + +-- | Main function for outputting the circuit for stage 1 of Hallgren’s algorithm. +main_stage1 :: Options -> IO() +main_stage1 options = do + + -- Generate the main circuit. + let bigD = cl_delta options + assertM (is_valid_bigD bigD) $ + "Δ = " ++ (show $ cl_delta options) ++ " not valid discriminant" + let i = cl_i options + ss_bound = 2^i + q = 2 + 2 * i -- So 2^q = 4 * S_bound^2 is the first power of 2 above S_bound + t = 2 * (ceiling (logBase 2 (sqrt $ fromIntegral bigD))) + i + + putStrLn $ "Generating circuit for stage 1 with args: " + putStrLn $ show options + putStrLn $ "" + putStrLn $ "Computed values: " + putStrLn $ "Δ: " ++ show bigD + putStrLn $ "i: " ++ show i + putStrLn $ "S_bound: " ++ show ss_bound + putStrLn $ "q: " ++ show q + putStrLn $ "t: " ++ show t + + -- rand <- getStdRandom (random) + let rand = 0 -- Fix the random generator to get consistent circuits + let circuit = approximate_regulator_circuit bigD i rand + + -- Print it. + print_simple (format options) (decompose_generic (gatebase options) circuit) + + +-- | Main function for outputting the circuit for stage 4 of Hallgren’s algorithm. +main_stage4 :: Options -> IO() +main_stage4 options = do + putStrLn $ "Generating circuit for stage 4 with args: " ++ show options + + +-- | Main function for outputting the circuits for specific subroutines. +main_sub :: Options -> IO() +main_sub options = + let fmt = format options + gtb = gatebase options + bigD = cl_delta options + in case sub options of + Rho -> do + print_generic fmt (unbox q_rho_d) (sample_IdDistQ bigD) + RhoInv -> do + print_generic fmt (unbox q_rho_inv_d) (sample_IdDistQ bigD) + Normalize -> do + print_generic fmt (unbox q_normalize) (sample_IdDistQ bigD) + DotProd -> do + print_generic fmt (unbox q_dot_prod) iirq iirq + where iirq = sample_IdealRedQ bigD + StarProd -> do + print_generic fmt (unbox q_star_prod) iirdq iirdq + where iirdq = sample_IdRedDistQ bigD + FN -> do + print_generic fmt (unbox $ \qi -> q_fN bigD n 0 qi j) iq + where + i = cl_i options + q = 2 + 2 * i -- as used in Part 1 + n = n_of_bigD bigD + iq = qshape (intm q 0) + j = (intm (q + 4) 0) diff --git a/dist/build/Quipper/Algorithms/CL/RegulatorClassical.hs b/dist/build/Quipper/Algorithms/CL/RegulatorClassical.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/CL/RegulatorClassical.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/CL/RegulatorClassical.hs" #-} +-- | This module implements the classical operations on ideals used in Hallgren’s +-- algorithm (including also classical versions of the quantum operations required). + +module Quipper.Algorithms.CL.RegulatorClassical where + +import Data.Maybe + +import Quipper.Libraries.Arith +import Quipper.Libraries.FPReal + +import Quipper.Algorithms.CL.Auxiliary +import Quipper.Algorithms.CL.Types + +-- ====================================================================== +-- * Basic operations on ideals + +-- | @'unit_ideal' /bigD/ /l/@: the unit ideal /O/, for Δ = /bigD/, with the ideal’s coefficients given as /l/-bit integers. +-- ([Jozsa 2003], Prop. 14.) +unit_ideal :: CLIntP -> Ideal +unit_ideal = forget_reduced . unit_idealRed + +-- | Like 'unit_ideal', but considered as a reduced ideal. +unit_idealRed :: CLIntP -> IdealRed +unit_idealRed bigD = assert (is_valid_bigD bigD) ("unit_idealRed: " ++ show bigD ++ " not valid discriminant") + $ IdealRed bigD 1 (tau bigD (fromIntegral bigD) 1) + +-- | The integer constant /c/ of an ideal. +-- ([Jozsa 2003], page 14 bottom: \"Since 4/a/ divides /b/[sup 2]-/D/ +-- (cf. proposition 16) we introduce the integer /c/ = |/D/ − /b/[sup 2]|\/(4/a/)\") +c_of_ideal :: Ideal -> CLInt +c_of_ideal i@(Ideal bigD m l a b) = + if (num `mod` denom == 0) then num `div` denom + else error error_string + where num = abs ((fromIntegral bigD) - b*b) + denom = 4*a + error_string = "rho of ideal [" ++ show i ++ "] produces non-integer c" + +-- | γ(/I/) = (/b/+√Δ)\/(2/a/) for a given ideal /I/. +-- ([Jozsa 2003], Sec. 6.2.) +gamma_of_ideal :: Ideal -> AlgNum +gamma_of_ideal (Ideal bigD m l a b) = AlgNum a' b' bigD + where + a' = (fromIntegral b / fromIntegral (2*a)) :: CLRational + b' = (fromIntegral 1 / fromIntegral (2*a)) :: CLRational + -- Recall: @'AlgNum' u v bigD@ represents (u + v * √bigD). + +-- | The reduction function ρ on ideals. +-- ([Jozsa 2003], Sec. 6.2.) +rho :: Ideal -> Ideal +rho ii@(Ideal bigD m l a b) = (Ideal bigD m'' l'' a' b') + where + -- With little algebra, one can derive these: + m' = m * a + l' = l * a' + m'' = m' `div` (gcd m' l') + l'' = l' `div` (gcd m' l') + -- From [Jozsa 2003], p.15, equation (10) + a' = c_of_ideal ii + b' = tau bigD (-b) a' + +-- | The ρ[sup -1] function on ideals. Inverse to 'rho'. +-- ([Jozsa 2003], Sec. 6.4.) +rho_inv :: Ideal -> Ideal +rho_inv (Ideal bigD m l a b) = (Ideal bigD m'' l'' a'' b'') + where + -- Create m and l + m' = m * a + l' = l * a'' + -- Reduce them to have no common denominator + m'' = m' `div` (gcd m' l') + l'' = l' `div` (gcd m' l') + -- Calculate b* (b' below) + b' = tau bigD (-b) a + -- Calculate new a and b + a'' = ((fromIntegral bigD) - b'*b') `divchk` (4*a) + b'' = tau bigD b' a'' + +-- | The ρ operation on reduced ideals. +rho_red :: IdealRed -> IdealRed +rho_red = to_reduced . rho . forget_reduced + +-- | The ρ[sup –1] operation on reduced ideals. +rho_inv_red :: IdealRed -> IdealRed +rho_inv_red = to_reduced . rho_inv . forget_reduced + +-- | The ρ operation on ideals-with-distance. +rho_d :: IdDist -> IdDist +rho_d (ii, del) = (rho ii, del + del_change) + where + gamma = gamma_of_ideal ii + gamma_bar_by_gamma = (floating_of_AlgNum $ conjugate gamma) / (floating_of_AlgNum gamma) + del_change = (log $ abs gamma_bar_by_gamma) / 2 + +-- | The ρ[sup –1] operation on ideals-with-distance. +rho_inv_d :: IdDist -> IdDist +rho_inv_d (ii, del) = (ii', del - del_change) + where + ii' = rho_inv ii + gamma = gamma_of_ideal ii' + gamma_bar_by_gamma = (floating_of_AlgNum $ conjugate gamma) / (floating_of_AlgNum gamma) + del_change = (log $ abs gamma_bar_by_gamma) / 2 + +-- | The ρ operation on ideals-with-generator (i.e. pairs of an ideal /I/ and an 'AlgNum' /x/ such that /I/ is the principal ideal (/x/)). +rho_num :: (Ideal,AlgNum) -> (Ideal,AlgNum) +rho_num (ii, gen) = (rho ii, gen / (gamma_of_ideal ii)) + +-- | Apply ρ to an reduced-ideals-with-generator +rho_red_num :: (IdealRed,AlgNum) -> (IdealRed,AlgNum) +rho_red_num (ii, gen) = (rho_red ii, gen / (gamma_of_ideal $ forget_reduced ii)) + +-- ====================================================================== +-- * Ideal reductions (bounded) + +-- | Reduce an ideal, by repeatedly applying ρ. +reduce :: Ideal -> IdealRed +reduce ii = to_reduced $ while (not . is_reduced) rho ii + +-- | Reduce an ideal within a bounded loop. Applies the ρ function +-- until the ideal is reduced. Used in 'star' and 'fJN' algorithms. +bounded_reduce :: IdDist -> IdDist +bounded_reduce k@(ideal@(Ideal bigD m l a b),dist) = + fst $ bounded_while condition bound func (k,0) + where + -- NOTE: some uncertainty regarding loop bound. + bound = ceiling $ bound_log + 1 + bound_log = (logBase 2 ((fromIntegral bound_a) + / (sqrt $ fromIntegral $ bigD_of_Ideal $ ideal))) + bound_a = 2 ^ (fromJust (intm_length $ a)) + + condition (k,itr) = not $ is_reduced $ fst k + func (k,itr) = ((rho_d k),(itr+1)) + +-- | Apply a function (like ρ,ρ[sup -1],ρ[sup 2]) to an ideal, bounded +-- by 3*ln(Δ)\/2*ln(2). Execute while satisfies condition function. +bounded_step :: (IdDist -> Bool) -> (IdDist -> IdDist) -> IdDist -> IdDist +bounded_step condition step_function ideal = + -- Execute a bounded while loop + bounded_while condition bound step_function ideal + where + bound = ceiling $ (3 * (log $ fromIntegral $ bigD_of_Ideal $ fst ideal)) / (2 * log 2) + +-- | Like 'bounded_step', but the condition is checked against delta of the +-- current ideal. +bounded_step_delta :: (CLReal -> Bool) -> (IdDist -> IdDist) -> IdDist -> IdDist +bounded_step_delta condition step_function ideal = + bounded_step new_condition step_function ideal + where new_condition = (\k -> condition (delta k)) + +-- ====================================================================== +-- * Products of ideals + +-- | The ordinary (not necessarily reduced) product of two reduced fractional ideals. +-- +-- /I/⋅/J/ of [Jozsa 2003], Sec 7.1, following the description +-- given in Prop. 34. + +-- NOTE: assumes I, J reduced. Type should reflect this! +dot :: IdDist -> IdDist -> IdDist +dot i1@(Ideal bigD1 m1 l1 a1 b1, delta1) i2@(Ideal bigD2 m2 l2 a2 b2, delta2) = + assert_reduced (fst i1) $ + assert_reduced (fst i2) $ + (Ideal bigD1 m l a3 b3, del) + where + sqrtd :: CLReal + sqrtd = sqrt (fromIntegral bigD1) + (k', u', v') = extended_euclid a1 a2 + (k, x, w ) = extended_euclid k' ((b1 + b2) `divchk` 2) + a3 = (a1 * a2) `divchk` (k * k) + t1 = x * u' * a1 * b2 + t2 = x * v' * a2 * b1 + t3 = w*(b1 * b2 + (fromIntegral bigD1)) `divchk` 2 + t = (t1 + t2 + t3) `divchk` k + b3 = tau bigD1 t a3 + m = k + l = a3 + del = ((delta i1) + (delta i2)) + +-- | The dot-square /I/⋅/I/ of an ideal-with-distance /I/. +dot' :: IdDist -> IdDist +dot' i1@(Ideal bigD1 m1 l1 a1 b1, delta1) = + assert_reduced (fst i1) $ + (Ideal bigD1 m l a3 b3, del) + where + sqrtd :: CLReal + sqrtd = sqrt (fromIntegral bigD1) + (k, u, w) = extended_euclid (abs a1) (abs b1) + a3 = (a1 * a1) `divchk` (k * k) + t1 = u * a1 * b1 + t3 = w*(b1 * b1 + (fromIntegral bigD1)) `divchk` 2 + t = (t1 + t3) `divchk` k + b3 = tau bigD1 t a3 + m = k + -- l = a3 + l = 1 + del = ((delta i1) + (delta i1)) + +-- | The star-product of two ideals-with-distance. +-- +-- This is /I/*/J/ of [Jozsa 2003], Sec. 7.1, defined as the first reduced +-- ideal-with-distance following /I/⋅/J/. + +-- NOTE: assumes I, J reduced. Type should reflect this! +star :: IdDist -> IdDist -> IdDist +star i j = + if (delta k1 <= delta i_dot_j) + then bounded_step_delta (<= delta i_dot_j) rho_d k1 + else rho_d $ bounded_step_delta (>= delta i_dot_j) rho_inv_d k1 + where + i_dot_j = i `dot` j + -- FIX: Over bound (infinite loop) in reducing the following: + -- * + k1 = bounded_reduce i_dot_j + +-- ====================================================================== +-- * The function f[sub /N/], and variants + +-- | Compute the expression i\/N + j\/L. +compute_injl :: (Integral int) => CLInt -> int -> CLInt -> int -> CLReal +compute_injl i nn j ll = + (fromIntegral i)/(fromIntegral nn) + (fromIntegral j)/(fromIntegral ll) + +-- | @'fN' /i/ /j/ /n/ /l/ Δ@: find the minimal ideal-with-distance (/J/,δ[sub /J/]) such that δ[sub /J/] > /x/, where /x/ = /i/\//N/ + /j/\//L/, where /N/ = 2[sup /n/], /L/ = 2[sup /l/]. Return (/i/,/J/,δ[sub /J/]–/x/). Work under the assumption that /R/ < 2[sup /s/]. +-- +-- This is the function /h/ of [Jozsa 2003, Section 9], discretized with precision 1\//N/ = 2[sup −/n/], +-- and perturbed by the jitter parameter /j/\//L/. +fN :: (Integral int) => CLInt -> CLInt -> int -> int -> CLIntP -> (Ideal, CLInt) +fN i j nn ll bigD = + let ((ideal_J, _), diff) = fN_d i j nn ll bigD + in (ideal_J, diff) + +-- | Like 'fN', but returning an ideal-with-distance not just an ideal. +fN_d :: (Integral int) => CLInt -> CLInt -> int -> int -> CLIntP -> (IdDist, CLInt) +fN_d i j nn ll bigD = + (j_star_19, floor $ (fromIntegral nn) * (toRational $ injl - (snd j_star_19))) + where + -- Expression "i/N + j/L" used repeatedly + injl = compute_injl i nn j ll + + -- Generate J1 + j1 = rho_d $ rho_d $ (unit_ideal bigD, 0) + + -- Generate Jk's (make an infinite list and take only what is needed) + jks = takeWhile (\jk -> (delta jk) <= injl) $ + bounded_iterate bound_jks + (\jk -> jk `star` jk) j1 + where + -- Bound for jk generation + max_i = 2^(fromJust (intm_length $ i)) + bound_jks = ceiling $ + (log $ fromIntegral max_i) / + ((fromIntegral nn) * (delta j1)) + + -- Apply all Jk's to J* using '*' in reverse (remember that the last + -- element is J* itself) + j_star_14 = foldr1 applyJkIfConditionHolds jks + + -- Apply Jk to J* if a condition holds. + applyJkIfConditionHolds :: IdDist -> IdDist -> IdDist + applyJkIfConditionHolds jk jstar = + if (delta (jstar `star` jk) <= injl) then jstar `star` jk else jstar + + -- Go forward one step at a time as much as needed + j_star_17 = bounded_step_delta (< injl) (rho_d.rho_d) j_star_14 + + -- Go back one step if needed + j_star_19 = if (delta (rho_inv_d j_star_17) >= injl) + then rho_inv_d j_star_17 + else j_star_17 + +-- | Analogue of 'fN', working within the cycle determined by a given ideal /J/. +-- ([Hallgren 2006], Section 5.) +fJN :: IdDist -> CLInt -> CLInt -> CLInt -> CLInt -> CLIntP -> (Ideal, CLInt) +fJN ideal_J i j nn ll bigD = + let ((ideal_J', _), diff) = fJN_d ideal_J i j nn ll bigD + in (ideal_J', diff) + +-- | Like 'fJN', but returning an ideal-with-distance not just an ideal. +fJN_d :: IdDist -> CLInt -> CLInt -> CLInt -> CLInt -> CLIntP -> (IdDist, CLInt) +fJN_d ideal_J i j nn ll bigD = + (ideal_KFinal, floor $ (fromIntegral nn) * (injl - (delta ideal_KFinal))) + where + -- Expression "i/N + j/L" + injl = compute_injl i nn j ll + + -- Generate I and K + ideal_I = fst (fN_d i j nn ll bigD) + ideal_K = bounded_reduce (ideal_I `dot` ideal_J) + + -- Step forward/backward as much as needed + ideal_KFinal = + if (delta ideal_K <= injl) + then bounded_step_delta (< injl) (rho_d) ideal_K + else rho_d $ bounded_step_delta (>= injl) (rho_inv_d) ideal_K + +-- ====================================================================== +-- * Classical period-finding + +-- $ Functions for classically finding the regulator and fundamental unit of a field using the period of /f_N/. + +-- ====================================================================== +-- ** Auxiliary functions + +-- | Find the order of an endofunction on an argument. That is, @'order' /f/ /x/@ returns the first /n/ > 0 such that /f/[sup /n/](/x/) = /x/. +-- +-- Method: simple brute-force search/comparison. +order :: (Eq a) => (a -> a) -> a -> Int +order = order_with_projection id + +-- | Given a function /p/, an endofunction /f/, and an argument /x/, returns the first /n/ > 0 such that /p/(/f/[sup /n/](/x/)) = /p/(/x/). +-- +-- Method: simple brute-force search/comparison. +order_with_projection :: (Eq b) => (a -> b) -> (a -> a) -> a -> Int +order_with_projection p f x = 1 + (length $ takeWhile (\y -> p y /= p x) (tail $ iterate f x)) + +-- | Given a function /p/, an endofunction /f/, and an argument /x/, return /f/[sup /n/](/x/), for the first /n/ > 0 such that /p/(/f/[sup /n/](/x/)) = /p/(/x/). +-- +-- Method: simple brute-force search/comparison. +first_return_with_projection :: (Eq b) => (a -> b) -> (a -> a) -> a -> a +first_return_with_projection p f x = head $ dropWhile (\y -> p y /= p x) $ tail $ iterate f x + +-- | Given a bound /b/, a function /p/, an endofunction /f/, and an argument /x/, return /f/[sup /n/](/x/), for the first /n/ > 0 such that /p/(/f/[sup /n/](/x/)) = /p/(/x/), if there exists such an /n/ ≤ /b/. +-- +-- Method: simple brute-force search/comparison. +first_return_with_proj_bdd :: (Eq b) => Int -> (a -> b) -> (a -> a) -> a -> Maybe a +first_return_with_proj_bdd b p f x = listToMaybe $ dropWhile (\y -> p y /= p x) $ take b $ tail $ iterate f x + +-- | Find the period of a function on integers, assuming that it is periodic and injective on its period. That is, @'period' /f/@ returns the first /n/ > 0 such that /f/(/n/) = /f/(0). Method: simple brute-force search/comparison. +period :: (Eq a, Integral int) => (int -> a) -> int +period f = minimum [ n | n <- [1..], f n == f 0 ] + +-- ====================================================================== +-- ** Haskell native arithmetic + +-- $ The functions of this section use Haskell’s native integer and floating computation. + +-- | Find the regulator /R/ = log ε[sub 0] of a field, given the discriminant Δ, +-- by finding (classically) the order of ρ. +-- +-- Uses 'IdDist' and 'rho_d'. +regulator :: CLIntP -> FPReal +regulator bigD = snd $ head $ dropWhile (\(ii,_) -> ii /= calO) $ tail $ iterate rho_d $ (calO,0) + where calO = unit_ideal bigD + +-- | Find the fundamental unit ε[sub 0] of a field, given the discriminant Δ, +-- by finding (classically) the order of ρ. +-- +-- Uses '(Ideal,Number)' and 'rho_num'. +fundamental_unit :: CLIntP -> AlgNum +fundamental_unit bigD = maximum [eps, -eps, 1/eps, -1/eps] + where eps = snd $ first_return_with_projection fst rho_num (calO,1) + calO = unit_ideal bigD + +-- | Find the fundamental solution of Pell’s equation, given /d/. +-- +-- Solutions of Pell’s equations are integer pairs (/x/,/y/) such that +-- /x/,/y/ > 0, and (/x/ + /y/√d)(/x/ – /y/√d) = 1. +-- +-- In this situation, (/x/ + /y/√d) is a unit of the algebraic integers +-- of /K/, and is >1, so we simply search the powers of ε[sub 0] for a +-- unit of the desired form. +fundamental_solution :: CLIntP -> (Integer,Integer) +fundamental_solution d = head pell_solutions + where bigD = bigD_of_d d + eps0 = fundamental_unit bigD + pell_solutions = + [ (round x, round y) | n <- [1..], + let eps@(AlgNum a b _) = eps0^n, + a >= 0, b >= 0, + let x = a, + let y = if bigD == d then b else 2*b, + is_int x, is_int y, + eps * (conjugate eps) == 1] + +-- ====================================================================== +-- ** Fixed-precision arithmetic + +-- $ The functions of this section perform period-finding using fixed-precision arithmetic. +-- This should parallel closely (though at present not exactly, due to the implementations +-- of floating-point operations) the quantum circuit implementations, and hence allows +-- testing of whether the chosen precisions are accurate. + +-- | Find the regulator /R/ = log ε[sub 0] of a field, given the discriminant Δ, +-- by finding (classically) the order of ρ +-- using fixed-precision arithmetic: 'fix_sizes_Ideal' for 'Ideal's, +-- and given an assumed bound /b/ on log[sub 2] /R/. +-- +-- Uses 'IdDist' and 'rho_d'. +regulator_fixed_prec :: Int -> CLIntP -> Maybe FPReal +regulator_fixed_prec b bigD = fmap snd (first_return_with_proj_bdd b' fst rho_d (calO,zero)) + where calO = fix_sizes_Ideal $ unit_ideal bigD + n = n_of_bigD bigD + -- S = 2RN, so this /i/ gives an assumed bound on log_2 S: + i = 1 + b + n + -- Following precisions are as used in 'approximate_regulator_circuit', 'q_fN': + q = 2 + 2 * i + l = 4 + q + n + p = precision_for_fN bigD n l + zero = fprealx (-p) (intm (q - n + p) 0) + -- δ(I, ρ^2 (I)) ≥ √2 for any I, so the order of ρ is at most 2R / (√2 / 2): + b' = ceiling $ 2 * sqrt(2) * (fromIntegral 2^b) + + +{- +Waiting for 'AlgNum' to be rebased using 'IntM' instead of 'Integer'. + +-- | Find the fundamental unit ε[sub 0] of a field, given the discriminant Δ, +-- by finding (classically) the order of ρ, +-- using fixed-precision arithmetic: 'fix_sizes_Ideal' for 'Ideal's, +-- and a given /l/ for the 'AlgNum's generating them. +-- +-- Uses '(Ideal,Number)' and 'rho_num'. +fundamental_unit_with_fixed :: Int -> CLIntP -> AlgNum +fundamental_unit_with_fixed l bigD = maximum [eps, -eps, 1/eps, -1/eps] + where eps = snd $ head $ dropWhile (\(ii,_) -> ii /= calO) $ tail $ iterate rho_num $ (calO,one) + calO = fix_sizes_Ideal $ unit_ideal bigD + one = intm_with_length (Just l) 1 +-} diff --git a/dist/build/Quipper/Algorithms/CL/RegulatorQuantum.hs b/dist/build/Quipper/Algorithms/CL/RegulatorQuantum.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/CL/RegulatorQuantum.hs @@ -0,0 +1,508 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/CL/RegulatorQuantum.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | This module implements the specialized quantum operations required in stages 1 and 4 of Hallgren’s algorithm. +-- +-- The key operation for stage 1 is 'q_fN', implementing /f/[sub /N/], the quasi-periodic +-- function used in approximating the regulator. This is the function /h/ of +-- [Jozsa 2003], Sec. 9, discretized with precision 1\//N/ and translated by a +-- specified jitter parameter. +-- +-- The key functions for stage 4 are not yet implemented. These essentially +-- consist of the functions /f/[sub /I/,/N/], analogues of /f/[sub /N/] operating +-- within the equivalence classes of possibly non-principal ideals /I/ (representing +-- other elements of the class group), as described in [Hallgren 2006, Section 5]. + +module Quipper.Algorithms.CL.RegulatorQuantum where + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Arith hiding (q_ext_euclid, q_add, q_mult, q_div_exact, + q_add_in_place, q_add_param_in_place, q_div, + q_mult_param, q_mod_unsigned, q_sub_in_place, + q_increment) +import qualified Quipper.Libraries.Arith as Arith +import Quipper.Libraries.FPReal + +import Quipper.Algorithms.CL.Auxiliary +import Quipper.Algorithms.CL.Types +import Quipper.Algorithms.CL.RegulatorClassical + +import Control.Monad (foldM) + +-- ====================================================================== +-- * Basic operations on ideals + +-- | Send /I/ = \ to /l/\//ka/ /I/ = \<1,/a/,/a/,/b/>. +-- +-- On distances, send δ[sub /I/] to δ[sub /I/] - log (/l/\//ka/). + +-- Implementation note: is it more efficient to multply/divide and then +-- take log, or take logs separately and then add/subtract? +q_normalize :: IdDistQ -> Circ (IdDistQ,IdDistQ) +q_normalize = box "q_normalize" $ \((Ideal bigD k l a b), dist) -> do + let k_bits = qulist_of_qdint_bh k + n = length k_bits + k' <- qinit (intm n 1) + (a,l') <- qc_copy_fun a + (a,a') <- qc_copy_fun a + (b,b') <- qc_copy_fun b + ((k,l,a,dist), dist') <- with_computed_fun + (k,l,a,dist) + (\(k,l,a,dist) -> do + (k,k_clreal) <- q_fromQDInt k + (l,l_clreal) <- q_fromQDInt l + (a,a_clreal) <- q_fromQDInt a + (k_clreal,log_k) <- fprealq_log_with_shape dist k_clreal + (l_clreal,log_l) <- fprealq_log_with_shape dist l_clreal + (a_clreal,log_a) <- fprealq_log_with_shape dist a_clreal + (log_k, dist) <- fprealq_sub_in_place log_k dist + (log_l, dist) <- fprealq_add_in_place log_l dist + (log_a, dist) <- fprealq_sub_in_place log_a dist + return (((k,l,a),(k_clreal,l_clreal,a_clreal),(log_k,log_l,log_a)), dist)) + (\(various, dist) -> do + (dist,dist') <- qc_copy_fun dist + return ((various,dist), dist')) + return ((Ideal bigD k l a b, dist), (Ideal bigD k' l' a' b', dist')) + +-- | Apply the function ρ to an 'IdealQ' together with a distance. +-- See [Jozsa 2003], Sect 6.2, preceding Prop. 21; compare 'rho_d'. + +-- Implementation note: not factored into q_rho plus action on distance, +-- since the two share a bit of computation (c_num). +q_rho_d :: IdDistQ -> Circ (IdDistQ,IdDistQ) +q_rho_d = box "rho" $ \iid@(Ideal bigD m l a b, del) -> do + rho_iid <- with_computed + (do + (_,_,b_sq) <- q_mult b b + b_sq' <- q_sub_param_in_place (fromIntegral bigD) b_sq + (_,c_num) <- q_abs b_sq' + (_,c_denom) <- q_mult_param 4 a + (_,_,c) <- q_div_exact c_num c_denom + let a' = c + (_,b_neg) <- q_negate b + (_,_,b') <- q_tau bigD b_neg a' + (_,_,m') <- q_mult m a + (_,_,l') <- q_mult l a' + (_,_,_,_,d) <- q_ext_euclid m' l' + (_,_,m'') <- q_div_exact m' d + (_,_,l'') <- q_div_exact l' d + let ii' = Ideal bigD a' b' m'' l'' + + -- By definition, del_change = log $ abs $ gamma_bar / 2 * gamma, + -- where gamma = b/2a + (1/2*a)*(sqrt bigD). + -- + -- A few lines of algebra gives: + -- del_change = log $ (b - (sqrt bigD))^2 / (abs $ b^2 - bigD) + -- = log (b - (sqrt bigD))^2 - log (abs $ b^2 - bigD) + (_,b_fp) <- fprealq_of_QDInt_with_shape del b + b_fp <- fprealq_add_param_in_place (negate $ sqrt $ fromIntegral bigD) b_fp + (_,_,b_fp_sq) <- q_mult b_fp b_fp + (_,del_change_1) <- fprealq_log_with_shape del b_fp_sq + (_,del_change_2) <- fprealq_log_with_shape del (fprealx 0 c_num) + del' <- qc_copy del + (_,del') <- fprealq_add_in_place del_change_1 del' + (_,del') <- fprealq_sub_in_place del_change_2 del' + return (ii', del')) + qc_copy + return (iid, rho_iid) + +-- | Apply the function ρ[sup –1] to an 'IdealQ' together with a distance. +-- See [Jozsa 2003], Sec 6.2, preceding Prop. 21, and Sec 6.4; compare 'rho_inv_d'. +q_rho_inv_d :: IdDistQ -> Circ (IdDistQ, IdDistQ) +q_rho_inv_d = box "rho_inv" $ \iid@(Ideal bigD m l a b, del) -> do + rho_inv_iid <- with_computed + (do + -- b' = τ(Δ,-b,a): + (_, b_neg) <- q_negate b + (_, _, b') <- q_tau bigD b_neg a + -- a'' = (Δ - b'^2) / (4*a): + (_, b'_sq) <- q_square b' + (_, a''_num) <- q_negate b'_sq + a''_num <- q_add_param_in_place (fromIntegral bigD) a''_num + (_, a''_denom) <- q_mult_param 4 a + (_, _, a'') <- q_div_exact a''_num a''_denom + (_, _, b'') <- q_tau bigD b' a'' + -- m''/l'' = m*a / l*a'', reduced to lowest terms: + (_, _, m') <- q_mult m a + (_, _, l') <- q_mult l a'' + (_,_,_,_, d) <- q_ext_euclid m' l' + (_, _, m'') <- q_div_exact m' d + (_, _, l'') <- q_div_exact l' d + let ii' = Ideal bigD a'' b'' m'' l'' + + -- Compute del_change as in 'q_rho_d', + -- but using coefficients from ii': + (_,b_fp) <- fprealq_of_QDInt_with_shape del b'' + b_fp <- fprealq_add_param_in_place (negate $ sqrt $ fromIntegral bigD) b_fp + (_,_,b_fp_sq) <- q_mult b_fp b_fp + (_,del_change_1) <- fprealq_log_with_shape del b_fp_sq + (_,_,b_sq) <- q_mult b'' b'' + b_sq' <- q_sub_param_in_place (fromIntegral bigD) b_sq + (_,c_num) <- q_abs b_sq' + (_,del_change_2) <- fprealq_log_with_shape del (fprealx 0 c_num) + del' <- qc_copy del + (_,del') <- fprealq_sub_in_place del_change_1 del' + (_,del') <- fprealq_add_in_place del_change_2 del' + return (ii', del')) + qc_copy + return (iid, rho_inv_iid) + +-- | As 'q_rho_d', but for reduced ideals. + +-- Implementation note: could be optimised a bit, since some of the algebra +-- needed for ρ in the general case is redundant for reduced ideals. +q_rho_red_d :: IdRedDistQ -> Circ (IdRedDistQ,IdRedDistQ) +q_rho_red_d (ii,del) = do + ii <- q_forget_reduced ii + ((ii,del), (ii',del')) <- q_rho_d (ii,del) + ii <- q_assert_reduced ii + ii' <- q_assert_reduced ii' + return ((ii,del), (ii',del')) + +-- | As 'q_rho_inv_d', but for reduced ideals. + +-- Implementation note: could be optimised, like 'q_rho_red_d'. +q_rho_inv_red_d :: IdRedDistQ -> Circ (IdRedDistQ,IdRedDistQ) +q_rho_inv_red_d (ii,del) = do + ii <- q_forget_reduced ii + ((ii,del), (ii',del')) <- q_rho_inv_d (ii,del) + ii <- q_assert_reduced ii + ii' <- q_assert_reduced ii' + return ((ii,del), (ii',del')) + +-- ====================================================================== +-- * Products of ideals + +-- | Compute the ordinary (not necessarily reduced) product of two reduced +-- fractional ideals. +-- +-- This is /I/⋅/J/ of [Jozsa 2003], Sec 7.1, following the description +-- given in Prop. 34. +q_dot_prod :: IdealRedQ -> IdealRedQ -> Circ (IdealRedQ,IdealRedQ,IdealQ) +q_dot_prod = box "q_dot_prod" $ \(IdealRed bigD1 a1 b1) (IdealRed bigD2 a2 b2) -> do + assertM (all_eq [bigD1,bigD2]) "Error: mismatched Δ’s in q_dot_prod." + let bigD = bigD1 + n = qdint_length a1 + + label (a1,b1,a2,b2) ("a1","b1","a2","b2") + ((a1,a2,b1,b2),(k,l,a3,b3)) <- with_computed_fun (a1,a2,b1,b2) + (\(a1,a2,b1,b2) -> do + comment "q_dot_prod, step 1: (khat,uhat,vhat) <- ExtendedEuclid(a1,a2)" + (a1,a2,khat,uhat,vhat) <- q_ext_euclid a1 a2 + label (khat,uhat,vhat) ("khat","uhat","vhat") + comment "q_dot_prod, step 2: (k,u,v) <- ExtendedEuclid(khat,(b1+b2)/2)" + (b1,b2,b1b2) <- q_add b1 b2 + b1b2 <- q_div2 b1b2 + label (b1b2) ("(b1 + b2)/2") + (khat,b1b2,k,x,w) <- q_ext_euclid khat b1b2 + label (k,x,w) ("k","x","w") + comment "q_dot_prod, step 3: a3 := a1a2/k^2. [This should always be an integer.]" + (a1,a2,a1a2) <- q_mult a1 a2 + label (a1a2) ("a1*a2") + (k,k_sq) <- q_square k + label (k_sq) ("k^2") + (a1a2,k_sq,a3) <- q_div_exact a1a2 k_sq + label (a1a2,k_sq,a3) ("a3") + comment "q_dot_prod, step 4: t = (long formula, requiring many intermediate calculations)" + (((a1,b1,a2,b2),(uhat,vhat,k,x,w)),t) <- with_computed_fun + ((a1,b1,a2,b2),(uhat,vhat,k,x,w)) + + (\((a1,b1,a2,b2),(uhat,vhat,k,x,w)) -> do + comment "q_dot_prod, step 4, first summand: x * uhat * a1 * b2" + (x,uhat,x_uhat) <- q_mult x uhat + label x_uhat "x * uhat" + (x_uhat,a1,x_uhat_a1) <- q_mult x_uhat a1 + label x_uhat_a1 "x * uhat * a1" + (x_uhat_a1,b2,x_uhat_a1_b2) <- q_mult x_uhat_a1 b2 + label x_uhat_a1_b2 "x * uhat * a1 * b2" + comment "q_dot_prod, step 4, second summand: x * vhat * a2 * b1" + (x,vhat,x_vhat) <- q_mult x vhat + label x_vhat "x * vhat" + (x_vhat,a2,x_vhat_a2) <- q_mult x_vhat a2 + label x_vhat_a2 "x * vhat * a2" + (x_vhat_a2,b1,x_vhat_a2_b1) <- q_mult x_vhat_a2 b1 + label x_vhat_a2_b1 "x * vhat * a2 * b1" + comment "q_dot_prod, step 4, third summand: w * (b1 * b2 + Delta) / 2" + (b1,b2,b1_b2) <- q_mult b1 b2 + label b1_b2 "b1 * b2" + b1_b2_D <- q_add_param_in_place (fromInteger $ toInteger bigD) b1_b2 + label b1_b2_D "b1 * b2 + Delta" + b1_b2_D_by2 <- q_div2 b1_b2_D + label b1_b2_D_by2 "(b1 * b2 + Delta) / 2" + (w,b1_b2_D_by2,w_b1_b2_D_by2) <- q_mult w b1_b2_D_by2 + label b1_b2_D_by2 "w * (b1 * b2 + Delta) / 2" + comment "q_dot_prod, step 4, sum of all summands:" + (x_uhat_a1_b2,x_vhat_a2_b1,s) <- q_add x_uhat_a1_b2 x_vhat_a2_b1 + (w_b1_b2_D_by2,s) <- q_add_in_place w_b1_b2_D_by2 s + label s "big sum from step 4" + return ((a1,b1,a2,b2), + (uhat,vhat,k,x,w), + (x_uhat,x_uhat_a1,x_uhat_a1_b2), + (x_vhat,x_vhat_a2,x_vhat_a2_b1), + (b1_b2_D_by2,w_b1_b2_D_by2), + s)) + + (\(inputs, (uhat,vhat,k,x,w), subterm1, subterm2, subterm3, s) -> do + comment "q_dot_prod, step 4, final division: t := (big sum) / k" + (s,k,t) <- q_div s k + label t "t" + return ((inputs, (uhat,vhat,k,x,w), subterm1, subterm2, subterm3, s), t)) + + comment "q_dot_prod, step 5: set b3 <- (t mod 2a3) - (a3 - 1)." + (a3,twice_a3) <- q_mult_param 2 a3 + (t,twice_a3,b3) <- q_mod_unsigned t twice_a3 + (a3,b3) <- q_sub_in_place a3 b3 + b3 <- q_increment b3 + label b3 "b3" + + comment "q_dot_prod, step 6: test if (a3 > root Delta), store result as case_a3" + (a3,case_a3) <- q_gt_param a3 (floor (sqrt (fromIntegral bigD))) + label case_a3 "case_a3" + + comment "q_dot_prod, step 7: if (a3 > root Delta), then b3 <- b3 + (floor root Delta) - a3" + b3 <- q_add_param_in_place + (floor (sqrt (fromIntegral bigD))) + b3 `controlled` case_a3 + (a3,b3) <- q_sub_in_place a3 b3 `controlled` case_a3 + + return ((a1,a2,b1,b2),(khat,uhat,vhat),(k,x,w),(a1a2,b1b2,k_sq,t,case_a3,twice_a3),(a3,b3))) + + (\(inputs,temp1,(k,x,w),temp3,(a3,b3)) -> do + comment "q_dot_prod, step 8: copy computed values into place for I3 = I1.I2" + (a3,a3_out) <- qc_copy_fun a3 + (b3,b3_out) <- qc_copy_fun b3 + (k,k_out) <- qc_copy_fun k + l_out <- qinit (intm n 1) + label (k_out,l_out,a3_out,b3_out) "I3" + comment "q_dot_prod: uncompute garbage." + return ((inputs,temp1,(k,x,w),temp3,(a3,b3)) + ,(k_out,l_out,a3_out,b3_out))) + + return (IdealRed bigD1 a1 b1, IdealRed bigD1 a2 b2, Ideal bigD1 k l a3 b3) + +-- | Compute the dot-product of two reduced fractional ideals, all with distance. +q_dot_prod_with_dist :: IdRedDistQ -> IdRedDistQ -> Circ (IdRedDistQ, IdRedDistQ, IdDistQ) +q_dot_prod_with_dist = box "q_dot_prod_with_dist" $ \(ii,dist_ii) (jj,dist_jj) -> do + (ii, jj, ii_jj) <- q_dot_prod ii jj + (dist_ii, dist_jj, dist_ii_jj) <- q_mult dist_ii dist_jj + return ( (ii,dist_ii), (jj,dist_jj), (ii_jj,dist_ii_jj) ) + +-- | Given two reduced ideals-with-distance, compute their star-product, with distance. +-- +-- This is /I/*/J/ of [Jozsa 2003], Sec. 7.1, defined as the first reduced +-- ideal-with-distance following /I/⋅/J/. +q_star_prod :: IdRedDistQ -> IdRedDistQ -> Circ (IdRedDistQ, IdRedDistQ, IdRedDistQ) +q_star_prod = box "q_star_prod" $ \iid jjd -> do + let bigD = bigD_of_IdealRed $ fst iid + + ((iid,jjd), kkd_out) <- with_computed_fun + (iid,jjd) + (\(iid,jjd) -> do + comment "q_star_prod, step 1: K <- 1/ka (I . J)" + label (iid,jjd) (("I","δ(I)"),("J","δ(J)")) + (iid,jjd,ii_jjd) <- q_dot_prod_with_dist iid jjd + label (ii_jjd) ("II.JJ") + (ii_jjd,kkd) <- q_normalize ii_jjd + label (kkd) ("1/ka (II.JJ)") + + comment "q_star_prod, step 2: while K not reduced, set K <- rho(K)" + (kkd_initial,kkd_reduced) <- q_bounded_while_with_garbage + (\(kk,dist) -> do + comment "q_star_prod, step 2, loop conditional: is K reduced yet?" + (kk,c) <- q_is_reduced kk + c <- qnot c + return ((kk,dist),c)) + ((ceiling $ (logBase 2 $ fromIntegral bigD) / 2) + 1) +-- Generally, reduction may require log_2 (a/√D) steps, +-- but here a is a_3 from the dot-product I.J, +-- so a = a_3 = (a1 * a2) / k^2 ≤ a1 * a2; +-- but now a1, a2 ≤ √D since they come from reduced ideals, +-- so a ≤ √D * √D = D, and the bound simplifies. + kkd + (\kkd_old -> do + comment "q_star_prod, step 2, loop body: compute ρ(Κ)" + (kkd_old,kkd_new) <- q_rho_d kkd_old + return (kkd_new,kkd_old)) + + let (ii_jj,dist_ij) = ii_jjd + (kk_reduced,dist_k) = kkd_reduced + + comment "q_star_prod, step 2c: assert that K is now reduced." + kk <- q_assert_reduced kk_reduced + + comment "q_star_prod, step 3: pull K backwards or forwards to be as close as possible to I.J" + -- NB: implementation of the conditional + whiles could almost certainly be improved. + + (dist_k, dist_ij, k_lt_ij) <- q_lt dist_k dist_ij + label k_lt_ij "Initially, δ(K) ≤ δ(I.J)?" + let ii_jjd = (ii_jj,dist_ij) + kkd = (kk,dist_k) + + comment "q_star_prod, step 3a: pull-forwards loop" + ((dist_ij, kkd), (dij', kkd_forwards)) <- q_bounded_while_with_garbage + (\(dist_ij,(kk,dist_k)) -> do + comment "q_star_prod, step 3a, loop condition: is δ(K) ≤ δ(II.JJ) still?" + (dist_k, dist_ij, k_lt_ij) <- q_lt dist_k dist_ij + return ((dist_ij,(kk,dist_k)),k_lt_ij)) + (ceiling $ 3 * (logBase 2 $ fromIntegral bigD) / 2) + (dist_ij,kkd) + (\(dij,kkd_old) -> do + comment "q_star_prod, step 3a, loop body: compute ρ(Κ)" + (kkd_old,kkd_new) <- q_rho_red_d kkd_old + return ((dij,kkd_new),kkd_old)) + + comment "q_star_prod, step 3b: pull-backwards loop" + ((dist_ij, kkd), (dij'', kkd_too_far_back)) <- q_bounded_while_with_garbage + (\(dist_ij,(kk,dist_k)) -> do + comment "q_star_prod, step 3b, loop condition: is δ(K) ≥ δ(II.JJ) still?" + (dist_k, dist_ij, k_gt_ij) <- q_gt dist_k dist_ij + return ((dist_ij,(kk,dist_k)),k_gt_ij)) + (ceiling $ 3 * (logBase 2 $ fromIntegral bigD) / 2) + (dist_ij,kkd) + (\(dij,kkd_old) -> do + comment "q_star_prod, step 3b, loop body: compute ρ^-1(Κ)" + (kkd_old,kkd_new) <- q_rho_inv_red_d kkd_old + return ((dij,kkd_new),kkd_old)) + comment "q_star_prod, step 3b, cleanup: apply ρ once to the output of this loop" + (kkd_too_far_back, kkd_back) <- q_rho_red_d kkd_too_far_back + + return ((iid, jjd, ii_jjd, kkd_initial, kkd, dij', dij'', kkd_too_far_back), k_lt_ij, kkd_forwards, kkd_back)) + + (\(stuff, k_lt_ij, kkd_forwards, kkd_back) -> do + comment "q_star_prod, step 4: Return the result of either first or second loop, depending on test." + kkd_out <- qinit $ qc_false kkd_forwards + (kkd_out,kkd_forwards) <- controlled_not kkd_out kkd_forwards `controlled` k_lt_ij .==. True + (kkd_out,kkd_backwards) <- controlled_not kkd_out kkd_back `controlled` k_lt_ij .==. False + label kkd_out "kkd_out" + return ((stuff, k_lt_ij, kkd_forwards, kkd_back),kkd_out)) + + return (iid, jjd, kkd_out) + +-- | Compute /I/ * /I/, where /I/ is a reduced ideal/distance pair. +q_star_square :: IdRedDistQ -> Circ (IdRedDistQ, IdRedDistQ) +q_star_square = \iid -> with_computed_fun iid qc_copy_fun + (\(iid, iid_copy) -> do + (iid, iid_copy, iid_square) <- q_star_prod iid iid_copy + return ((iid, iid_copy), iid_square)) + +-- ====================================================================== +-- * The function f[sub /N/] + +-- | @'q_fN' Δ /s/ /n/ /l/ /qi/ /j/@: find the minimal ideal-with-distance (/J/,δ[sub /J/]) such that δ[sub /J/] > /x/, where /x/ = /i/\//N/ + /j/\//L/, where /N/ = 2[sup /n/], /L/ = 2[sup /l/]. /qi/ is quantum; other inputs are classical parameters. Return (/i/,/J/,δ[sub /J/]–/x/). Work under the assumption that /R/ < 2[sup /s/]. +-- +-- This is the function /h/ of [Jozsa 2003], Sec. 9, discretized with precision 1\//N/ = 2[sup −/n/], +-- and perturbed by the jitter parameter /j/\//L/. +q_fN :: CLIntP -> Int -> Int -> QDInt -> IntM -> Circ (QDInt,(IdealRedQ,FPRealQ)) +q_fN bigD n l qi j = do + let p = precision_for_fN bigD n l + nn = 2^n + ll = 2^l + q = qdint_length qi +-- Need to figure out a bound /p/ on the precision of the real arithmetic required. +-- It’s tempting to take /p/ = max(/n/,/l/); but I [pll] think we need larger, since if +-- I understand correctly, we want the /final output/ with precision of 2^-n, which +-- requires higher precision in intermediate calculations. + + (qi, (jj, diff)) <- with_computed_fun + qi + (\qi -> do + comment "q_fN, step 1: Precompute x := i/N + j/L, as it used many times." + qi <- return $ fprealx (-n) qi + qj <- qinit (fprealx (-l) j) + (qi,qj,qx) <- fprealq_add_het (-p) (q - n + p) qi qj + label qx "x := i/N + j/L" + + comment "q_fN, step 2: J <- ρ^2(O)." + oo <- qinit $ fix_sizes_IdealRed $ unit_idealRed bigD + dist_o <- qinit $ (fprealx (-p) (intm (q - n + p) 0)) + let ood = (oo,dist_o) + label ood ("O", "δ_O = 0") + + (ood,jjd0) <- q_rho_red_d ood + label jjd0 ("J0", "δ_J0)") + (jjd0,jjd1) <- q_rho_red_d jjd0 + label jjd1 ("J1", "δ_J1)") + + comment "q_fN, step 3: compute the iterated squares of (J1,δ_J1)." + -- Note: quantumly, it is cheaper to compute them all unconditionally, rather than + -- using a conditional loop that stops early, as one might classically. + jjds <- loop_with_indexM + (ceiling $ (fromIntegral q) * (log 2) / (nn * + (snd $ rho_d $ rho_d $ (unit_ideal bigD, 0)))) + [jjd1] + (\i (jjd_prev:jjds_earlier) -> do + (jjd_prev,jjd_new) <- q_star_square jjd_prev + label jjd_new ("J_" ++ show (i+2), "δ_" ++ show (i+2)) + return (jjd_new:jjd_prev:jjds_earlier)) + + comment "q_fN, step 4: compute the greatest product of these ≤ x" + -- Again, it is quantumly cheaper to start at the maximum possible bound, instead of k = M. + + let jjd_star = ood + label jjd_star ("J_*, δ_*") + + (qx, jjd_star, garbage) <- foldM + (\(qx, jjd_star_old, garbage) jjd_k -> do + (jjd_star_old, jjd_k, jjd_star_candidate) <- q_star_prod jjd_star_old jjd_k + let (jj_star_candidate, dist_candidate) = jjd_star_candidate + (dist_candidate, qx, test) <- q_lt dist_candidate qx + let jjd_star_candidate = (jj_star_candidate, dist_candidate) + jjd_star_new <- qinit (qc_false jjd_star_old) + (jjd_star_new, jjd_star_candidate) <- + controlled_not jjd_star_new jjd_star_candidate `controlled` test .==. True + (jjd_star_new, jjd_star_old) <- + controlled_not jjd_star_new jjd_star_old `controlled` test .==. False + label jjd_star_new ("J_*, δ(J_*)") + return (qx, jjd_star_new, (jjd_star_old,jjd_star_candidate,jjd_k,test):garbage)) + (qx, jjd_star, []) + jjds + + label jjd_star ("J_*, δ_*)") + comment "q_fN: (J_*,δ_*) is now the greatest ideal/distance pair ≤ x constructible from the iterated star-squares (J_k,δ_k)." + + comment "q_fN, step 5: apply ρ^2 to (J_*,δ_*) as long as δ_* ≤ x." + ((jjd_star_initial, qx), (jjd_star, qx_copy)) <- q_bounded_while_with_garbage + -- conditional test: + (\((jj_star, dist_star), qx) -> do + (dist_star, qx, test) <- q_le dist_star qx + return (((jj_star, dist_star), qx), test)) + -- bound + (ceiling $ 3 * logBase 2 (fromIntegral bigD) / 2) + -- starting value + (jjd_star, qx) + -- body of loop + (\(jjd_star_old, qx) -> do + (jjd_star_old, rho_jjd_star_old) <- q_rho_red_d jjd_star_old + (rho_jjd_star_old, jjd_star_new) <- q_rho_red_d rho_jjd_star_old + return ((jjd_star_new, qx), (jjd_star_old, rho_jjd_star_old))) + qx <- qc_uncopy_fun qx qx_copy + + comment "q_fN, step 6: apply ρ^{-1} once more if necessary." + (jjd_star_candidate1, jjd_star_candidate2) <- q_rho_inv_red_d jjd_star + + let (jj_star_candidate1, dist_star_candidate1) = jjd_star_candidate1 + (dist_star_candidate1, qx, final_test) <- q_le dist_star_candidate1 qx + let jjd_star_candidate1 = (jj_star_candidate1, dist_star_candidate1) + + -- End of the computation part of the 'with_computed_fun'. + -- Pass on everything we’ve constructed, with the relevant stuff put first. + return (qx, jjd_star_candidate1, jjd_star_candidate2, final_test, + (qi, qj, garbage, jjd0, jjd1, jjd_star_initial, jjd_star_initial))) + + (\(qx, jjd_star_candidate1, jjd_star_candidate2, test, irrelevant) -> do + jjd_star_out <- qinit (qc_false jjd_star_candidate1) + (jjd_star_out, jjd_star_candidate1) <- controlled_not jjd_star_out jjd_star_candidate1 `controlled` test .==. False + (jjd_star_out, jjd_star_candidate1) <- controlled_not jjd_star_out jjd_star_candidate2 `controlled` test .==. True + + let (jj_out, dist_jj) = jjd_star_out + (qx,diff_out) <- fprealq_sub_in_place qx dist_jj + + return ((qx, jjd_star_candidate1, jjd_star_candidate2, test, irrelevant), + (jj_out, diff_out))) + + return (qi, (jj, diff)) diff --git a/dist/build/Quipper/Algorithms/CL/RegulatorTemplate.hs b/dist/build/Quipper/Algorithms/CL/RegulatorTemplate.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/CL/RegulatorTemplate.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +-- | An experimental adaptation of the code from "Quipper.Algorithms.CL.Types", "Quipper.Algorithms.CL.Math", etc. to build circuits automatically using Template Haskell and "Quipper.Internal.CircLifting". +-- +-- Extremely incomplete. + +module Quipper.Algorithms.CL.RegulatorTemplate where + +import Quipper +import Text.Printf +import Quipper.Libraries.FPReal +import Quipper.Algorithms.CL.Types +import Quipper.Libraries.Arith +import Control.Monad + +-- * Auxiliary functions specific to the Class Number algorithm + +d_of_ideal :: Ideal -> Integer +d_of_ideal (Ideal bigD m l a b) = d_of_bigD bigD + +d_of_idealQ :: IdealQ -> Integer +d_of_idealQ (Ideal bigD m l a b) = d_of_bigD bigD + +equal_d_of_ideals :: Ideal -> Ideal -> BoolParam +equal_d_of_ideals i j = if ((d_of_ideal i) == (d_of_ideal j)) then PTrue else PFalse + +equal_d_of_idealQs :: IdealQ -> IdealQ -> BoolParam +equal_d_of_idealQs i j = if ((d_of_idealQ i) == (d_of_idealQ j)) then PTrue else PFalse + +template_equal_d_of_ideals :: Circ (IdealQ -> Circ (IdealQ -> Circ BoolParam)) +template_equal_d_of_ideals = return $ \i -> return $ \j -> return (equal_d_of_idealQs i j) + +template_and :: Circ ([Qubit] -> Circ Qubit) +template_and = return $ \qs -> do + result_qubit <- qinit False + qnot result_qubit `controlled` qs + +m_of_ideal :: Ideal -> IntM +m_of_ideal (Ideal bigD m l a b) = m + +l_of_ideal :: Ideal -> IntM +l_of_ideal (Ideal bigD m l a b) = l + +a_of_ideal :: Ideal -> IntM +a_of_ideal (Ideal bigD m l a b) = a + +b_of_ideal :: Ideal -> IntM +b_of_ideal (Ideal bigD m l a b) = b + +template_m_of_ideal :: Circ (IdealQ -> Circ QDInt) +template_m_of_ideal = return $ \(Ideal bigD m l a b) -> return m + +template_l_of_ideal :: Circ (IdealQ -> Circ QDInt) +template_l_of_ideal = return $ \(Ideal bigD m l a b) -> return l + +template_a_of_ideal :: Circ (IdealQ -> Circ QDInt) +template_a_of_ideal = return $ \(Ideal bigD m l a b) -> return a + +template_b_of_ideal :: Circ (IdealQ -> Circ QDInt) +template_b_of_ideal = return $ \(Ideal bigD m l a b) -> return b + +one_of_size :: IntM -> IntM +one_of_size n = + case intm_length n of + Just m -> intm m 1 + Nothing -> error "one_of_size: indeterminate size" + +template_one_of_size :: Circ (QDInt -> Circ QDInt) +template_one_of_size = return (\qx -> qinit $ one_of_size $ qc_false qx) + +-- * Functions from "Quipper.Algorithms.CL.Types" + +-- | Return 'True' if the given ideal is reduced. + +isReduced :: Ideal -> Bool +isReduced i = (m_of_ideal i == (one_of_size (m_of_ideal i)) && (l_of_ideal i == a_of_ideal i)) + + +{-# LINE 83 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +$( decToCircMonad [d| isReduced :: Ideal -> Bool + isReduced i = (m_of_ideal i == (one_of_size (m_of_ideal i)) && (l_of_ideal i == a_of_ideal i)) + + + |] ) +{-# LINE 84 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +-- assertReduced can't really be implemented as a quantum circuit. The closest we could +-- define is an asserted termination, that would throw an error at circuit run-time if +-- the assertion doesn't hold. +-- | An assert function will throw an error if the assertion is False. +assert :: Bool -> a -> a +assert True a = a +assert False _ = error "False Assertion" + +-- | A hand-lifted version of assert, that will produce a circuit run-time error +-- if the assertion doesn't hold. This is done by using an asserted discard. +template_assert :: Circ (Qubit -> Circ (a -> Circ a)) +template_assert = return $ \assertion -> return $ \a -> do + qterm True assertion + return a + +-- | This will throw an error if the given ideal isn't reduced. +-- The corresponding circuit will use an asserted termination, that will throw an +-- error at circuit run-time if the assertion doesn't hold. + +assertReduced :: Ideal -> a -> a +assertReduced i rest = + let assertion = isReduced i in + assert assertion rest + + +{-# LINE 107 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +$( decToCircMonad [d| assertReduced :: Ideal -> a -> a + assertReduced i rest = + let assertion = isReduced i in + assert assertion rest + + + |] ) +{-# LINE 108 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +-- | Check if a given ideal equals another ideal. + +idealEquals :: Ideal -> Ideal -> Bool +idealEquals i j = case equal_d_of_ideals i j of + PFalse -> error "Comparing two ideals of different d" + PTrue -> and [(m_of_ideal i == m_of_ideal j), + (l_of_ideal i == l_of_ideal j), + (a_of_ideal i == a_of_ideal j), + (b_of_ideal i == b_of_ideal j)] + + +{-# LINE 117 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +$( decToCircMonad [d| idealEquals :: Ideal -> Ideal -> Bool + idealEquals i j = case equal_d_of_ideals i j of + PFalse -> error "Comparing two ideals of different d" + PTrue -> and [(m_of_ideal i == m_of_ideal j), + (l_of_ideal i == l_of_ideal j), + (a_of_ideal i == a_of_ideal j), + (b_of_ideal i == b_of_ideal j)] + + + |] ) +{-# LINE 118 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +-- * Functions from "Quipper.Algorithms.CL.CL" + +-- * Some dummy functions for testing + +data BoolPair = BoolPair Bool Bool + +data QubitPair = QubitPair Qubit Qubit + +boolPair = BoolPair +template_boolPair = return $ \x -> return $ \y -> return $ QubitPair x y +template_BoolPair = QubitPair + + +truePair :: BoolPair +truePair = boolPair True True + + +{-# LINE 133 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +$( decToCircMonad [d| truePair :: BoolPair + truePair = boolPair True True + + + |] ) +{-# LINE 134 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +{- + +myAnd :: BoolPair -> Bool +myAnd (BoolPair x y) = x && y + +{-# LINE 137 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +$( decToCircMonad [d| myAnd :: BoolPair -> Bool + myAnd (BoolPair x y) = x && y + + |] ) +{-# LINE 138 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +-} + + +myPlus :: Int -> Int -> Int +myPlus x y = x + y + + +{-# LINE 143 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +$( decToCircMonad [d| myPlus :: Int -> Int -> Int + myPlus x y = x + y + + + |] ) +{-# LINE 144 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +-- * Some test functions +test_is_reduced :: IO () +test_is_reduced = let zero = qdint_shape 4 + ideal = Ideal 17 zero zero zero zero + in print_generic ASCII (unpack template_isReduced) ideal + +-- * A main function +main :: IO () +main = test_is_reduced + +{- +Notes: + +- it’s not quite clear to me what assumptions CircLifting makes about lingering arguments, linearity, etc. e.g.: should 'template_m_of_ideal' and the like return copies of the components, not the components themselves? Or is this kosher as currently written? + +- I guess at the moment, it *does* assume all input arguments are left lingering, and moreover unmodified (in the sense of the computational basis). A version not assuming this could be written by using the alternate type translation + +#(a -> b) = a -> Circ (a,#b) + +- linearity is much more of an issue! if we write something like + + +twice x = x + x + + +{-# LINE 167 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +$( decToCircMonad [d| twice x = x + x + + + |] ) +{-# LINE 168 "Quipper/Algorithms/CL/RegulatorTemplate.hs" #-} +this may well (depending on implementation of 'template_symb_plus_') build to a non-linear circuit (so, runtime error). With a little more effort we can write examples which will *not* produce runtime errors, but *will* produce incorrect circuit behaviour. + +Solution? One can imagine writing safe circuits like + +add_safe qx qy = if (qd_disjoint qx qy) then add qx qy + else do + ((qx,qy),qz) <- with_computed_fun (qx,qy) + (\(qx,qy) -> do + (qx,qx') <- qc_copy_fun qx + (qy,qy') <- qc_copy_fun qy + return (qx,qy,qx',qy')) + (\(qx,qy,qx',qy') -> + (qx',qy',qz) <- add qx' qy' + return ((qx,qy,qx',qy'),qz)) + return (qx,qy,qz) + +One can even imagine doing this generically, so that add_safe = make_safe q_add. The necessary assumption is just, I think, that q_add leaves qx, qy unmodified. Given a QData method qd_disjoint, this would not I think be hard. + +This may be the wrong solution to the problem, though. Thoughts? + +- It would be really nice if the lifting could deal better with (a) pattern-matching; (b) numeric literals. (e.g. how to write an algebraic operation like (p x = 17*x + 5)? Can write this for 'IntM', but can’t translate it correctly. + +-} diff --git a/dist/build/Quipper/Algorithms/CL/SmithReduction.hs b/dist/build/Quipper/Algorithms/CL/SmithReduction.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/CL/SmithReduction.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/CL/SmithReduction.hs" #-} +-- | This module provides functions for reducing (non-square) matrices +-- towards Smith Normal Form, and hence for computing the structure of +-- finitely-presented Abelian groups. +-- +-- The SNF transformation is similar to Gaussian elimination, but over integer matrices, +-- (more generally, matrices over any principal ideal domain) +-- +-- For background on how this is used to compute the structure of Abelian groups, +-- see the MathOverflow question , +-- in particular Greg Kuperberg’s answer . +-- +-- We do not implement full SNF reduction here, but rather just as much as is +-- needed to compute the structure of finitely presented Abelian groups from +-- matrix presentations. + +module Quipper.Algorithms.CL.SmithReduction where + +import Data.Array +import Quipper.Algorithms.CL.Auxiliary + +-- * Matrix type and basic access functions. + +-- | A data type to hold an /m/×/n/ matrix (/M/[sub /ij/]), +-- with entries from an arbitrary type @a@. +-- +-- The fields are: integers /m/ and /n/; a flag /t/ to indicate that a matrix +-- should be considered formally transposed; and an /m/×/n/ array /M/ +-- containing the entries. When /t/ is 'False', /m/ is the number of rows, +-- and /n/ the number of columns; when /t/ is 'True', this is reversed. +-- +-- (The point of the flag is to allow efficient transposition, and hence to +-- allow operations on rows to be implemented in terms of the corresponding +-- operations on columns without loss of efficiency.) +data CLMatrix a = CLMatrix Int Int Bool (Array (Int, Int) a) deriving (Show) + +-- | The transpose of a matrix +transpose :: CLMatrix a -> CLMatrix a +transpose (CLMatrix m n t mtx) = CLMatrix m n (not t) mtx + +-- | The number of rows of a matrix +rows :: CLMatrix a -> Int +rows (CLMatrix m n t _) = if t then n else m + +-- | The number of columns of a matrix +cols :: CLMatrix a -> Int +cols (CLMatrix m n t _) = if t then m else n + +-- | The row indices of a matrix. +row_list :: CLMatrix a -> [Int] +row_list m = [0..((rows m)-1)] + +-- | The column indices of a matrix. +col_list :: CLMatrix a -> [Int] +col_list m = [0..((cols m)-1)] + +-- | An index tuple for a matrix, at a given row and column +idx :: CLMatrix a -> Int -> Int -> (Int, Int) +idx (CLMatrix _ _ t _) i j = if t then (j,i) else (i,j) + +infix 9 !!! + +-- | The matrix entry at a given row and column +(!!!) :: CLMatrix a -> (Int,Int) -> a +(!!!) mm@(CLMatrix m n t mtx) (i,j) = + if (i >= rows mm || j >= cols mm) + then error $ "Matrix entry lookup (!!!): bad index i=" ++ show i ++ ", j=" ++ show j + else mtx ! idx mm i j + +infixl 9 /// + +-- | Update a matrix by a list of (/i/,/j/,/m_i_j/) pairs +-- (all indexes assumed in range of original matrix). +(///) :: CLMatrix a -> [(Int,Int,a)] -> CLMatrix a +(///) mm@(CLMatrix m n t mtx) l = + CLMatrix m n t (mtx // [ (idx mm i j,e) | (i,j,e) <- l ]) + +-- | Construct an 'CLMatrix' from a list such as @[[1,0],[4,-5]]@. +-- +-- Assumes that all inner lists are the same length, +-- and that the overall list is of length ≥1. +matrix_from_list :: [[a]] -> CLMatrix a +matrix_from_list [] = error "matrixFromList: empty list" +matrix_from_list rs@(r0:_) = CLMatrix (length rs) (length r0) False $ + array ((0,0), (length rs - 1, length r0 - 1)) + [ ((i,j),x) | (ri,i) <- zip rs [0..], (x,j) <- zip ri [0..] ] + +-- | Delete a row of a matrix +delete_row :: Int -> CLMatrix a -> CLMatrix a +delete_row i0 mm@(CLMatrix m n t mtx) = + if 0 <= i0 && i0 < rows mm + then + if t then CLMatrix m (n-1) t $ ixmap ((0,0),(m-1,n-2)) (\(j,i) -> (j,f i)) mtx + else CLMatrix (m-1) n t $ ixmap ((0,0),(m-2,n-1)) (\(i,j) -> (f i,j)) mtx + else error "delete_row: row out of range" + where f i = if i < i0 then i else i+1 + +-- | Delete the first column of a matrix +delete_col :: Int -> CLMatrix a -> CLMatrix a +delete_col j0 = transpose . (delete_row j0) . transpose + +-- * Smith reduction + +-- | @'elim_entry_with_pivot' /M/ /i/ /j/ /j'/@: apply elementary column operations +-- to /M/ (equivalently, post-multiply by an invertible matrix) to +-- obtain /M'/ such that /M'/[sub /i/,/j/] is gcd(/M/[sub /i/,/j/], /M/[sub /i/,/j'/]) +-- and /M'/[sub /i/,/j'/] is 0. +elim_entry_with_pivot :: (Integral int) => CLMatrix int -> Int -> Int -> Int -> CLMatrix int +elim_entry_with_pivot m i0 j0 j1 = + let a = m !!! (i0,j0) + b = m !!! (i0,j1) + in if (a == 0 && b == 0) then m + else + let (d,x,y) = extended_euclid a b + a' = a `div` d + b' = b `div` d + -- know that [x a + y b == d] and [d /= 0], so the matrix [[x,y],[−b',a']] + -- is invertible; so premultiplication by it does not change the group + -- presentation (and indeed could be obtained as a combination of elementary + -- column operations). + in m /// [ (i,j0, (x * m !!! (i,j0)) + (y * m !!! (i,j1))) | i <- row_list m ] + /// [ (i,j1, (-b' * m !!! (i,j0)) + (a' * m !!! (i,j1))) | i <- row_list m] + +-- | Given a matrix, repeatedly use 'elim_entry_with_pivot' to put the +-- top row into clean form (/d/,0,…,0). +clean_first_row :: (Integral int) => CLMatrix int -> CLMatrix int +clean_first_row m0 = + foldl (\m j -> elim_entry_with_pivot m 0 0 j) m0 (tail $ col_list m0) + +-- | Dual to 'clean_first_row'. +clean_first_col :: (Integral int) => CLMatrix int -> CLMatrix int +clean_first_col = transpose . clean_first_row . transpose + +-- | Given a matrix, repeatedly apply 'clean_first_row' and its analogue +-- on columns until the first row and column are both in clean form. +clean_first_row_col :: (Integral int) => CLMatrix int -> CLMatrix int +clean_first_row_col m = + if not $ all (==0) [ m !!! (0,j) | j <- tail $ col_list m ] + then clean_first_row_col $ clean_first_row m + else if not $ all (==0) [ m !!! (i,0) | i <- tail $ row_list m ] + then clean_first_row_col $ clean_first_col m + else m + +-- * Structure of Abelian Groups + +-- | Given a matrix, taken as presenting an Abelian group (with generators +-- corresponding to columns of the matrix, and relations specified by the +-- rows), compute the structure constants of the group, not necessarily sorted. +-- +-- That is, return a list of natural numbers [/n/[sub 0],…,/n/[sub /s/]] +-- such that the group given by the input presentation is isomorphic to the +-- product of the cyclic groups ℤ\/(/n/[sub /i/]). +structure_constants_from_matrix :: (Show int, Integral int) => CLMatrix int -> [int] +structure_constants_from_matrix m = + if cols m == 0 then [] + else if rows m == 0 then (replicate (cols m) 0) + else let m' = clean_first_row_col m + in (abs $ m' !!! (0,0)) + : (structure_constants_from_matrix $ delete_row 0 $ delete_col 0 m') + +-- | Given a matrix, taken as presenting an Abelian group, +-- compute the order of the group. +-- +-- Returns 0 if the group is of infinite order. +group_order_from_matrix :: (Show int, Integral int) => CLMatrix int -> int +group_order_from_matrix = product . structure_constants_from_matrix diff --git a/dist/build/Quipper/Algorithms/CL/Test.hs b/dist/build/Quipper/Algorithms/CL/Test.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/CL/Test.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/CL/Test.hs" #-} +-- | Test the Class Number algorithm, and its components, using classical computation + +module Quipper.Algorithms.CL.Test where + +import Quipper +import Quipper.Libraries.Arith +import Quipper.Libraries.FPReal +import Quipper.Algorithms.CL.Auxiliary +import Quipper.Algorithms.CL.Types +import Quipper.Algorithms.CL.RegulatorClassical +import Quipper.Algorithms.CL.CL +import Quipper.Algorithms.CL.SmithReduction +import Data.Ratio +import Data.List + +-- * Sample data + +-- $ Some fairly arbitrarily chosen sample elements of various types, for convenience in testing functions. + +-- ** Matrices + +-- | A sample square matrix +sample_matrix :: CLMatrix Integer +sample_matrix = matrix_from_list [ + [ 8, 16, 16 ], + [ 32, 6, 12 ], + [ 8, -4, -16 ] + ] + +-- | A sample non-square matrix +sample_matrix_2 :: CLMatrix Integer +sample_matrix_2 = matrix_from_list [ + [ 5, 1, 5, 253, 15, -725, 1 ], + [ 253,2,1001,11,23,273,14079 ], + [ 1,-185861,-28,11,91,29,-2717 ], + [ -319,1,-19,11,3146,1,-1 ], + [ 19285,-493,145,25,-1482,1,6647] + ] + +-- | Another sample non-square matrix +sample_matrix_3 :: CLMatrix Integer +sample_matrix_3 = matrix_from_list [ + [ 4, 8, 4 ], + [ 8, 4, 8 ] + ] + +-- ** Ideals and related types + +-- | A sample 'CLReal'. +sample_CLReal :: Int -> FPReal +sample_CLReal l = (fprealx 0 (intm l 0)) + +-- | A sample 'Ideal'. +sample_Ideal :: CLIntP -> Ideal +sample_Ideal bigD = + let l = max (length_for_ab bigD) (length_for_ml bigD) + x = (intm l 0) + in (Ideal bigD x x x x) + +-- | A sample 'IdealQ'. +sample_IdealQ :: CLIntP -> IdealQ +sample_IdealQ = qshape . sample_Ideal + +-- | A sample 'IdealRed'. +sample_IdealRed :: CLIntP -> IdealRed +sample_IdealRed bigD = + let l = max (length_for_ab bigD) (length_for_ml bigD) + x = (intm l 0) + in (IdealRed bigD x x) + +-- | A sample 'IdealRedQ'. +sample_IdealRedQ :: CLIntP -> IdealRedQ +sample_IdealRedQ = qshape . sample_IdealRed + +-- | A sample 'IdDist'. +sample_IdDist :: CLIntP -> IdDist +sample_IdDist bigD = (sample_Ideal bigD, sample_CLReal (length_for_ab bigD)) + +-- | A sample 'IdDistQ'. +sample_IdDistQ :: CLIntP -> IdDistQ +sample_IdDistQ = qshape . sample_IdDist + +-- | A sample 'IdRedDist'. +sample_IdRedDist :: CLIntP -> IdRedDist +sample_IdRedDist bigD = (sample_IdealRed bigD, sample_CLReal (length_for_ab bigD)) + +-- | A sample 'IdRedDistQ'. +sample_IdRedDistQ :: CLIntP -> IdRedDistQ +sample_IdRedDistQ = qshape . sample_IdRedDist + +-- * Testing routines + +-- ** Smith reduction + +-- | Test the Smith Normal Form code. +test_SNF :: IO () +test_SNF = do + flip mapM_ [sample_matrix,sample_matrix_2,sample_matrix_3] $ \m -> do + putStrLn $ show $ m + putStrLn $ show $ structure_constants_from_matrix m + putStrLn $ show $ group_order_from_matrix m + putStrLn "" + +-- ** Class group functions + +-- | Classical period finding (just compare the \"next\" ideal to /O/ and see if +-- it is the same). Takes in the /O/ ideal with appropriate Δ, and returns +-- the circle length (sum δ(I)) and the list of ideals in the first iteration. +period_of_ideals :: (IdDist->IdDist) -> IdDist -> (CLReal, [IdDist]) +period_of_ideals func o = (delta $ last list, list) + where + list = takePeriod False (iterate (\i -> func i) o) + takePeriod :: Bool -> [IdDist] -> [IdDist] + takePeriod got_first_o [] = undefined -- not reached + takePeriod got_first_o (x:xs) = + if (fst x == fst o) then + if (got_first_o) then + [x] -- Have two O's, stop iterating here + else + x : takePeriod True xs -- This was first O, mark as such + else + x : takePeriod got_first_o xs + +-- | Show period string for a given Δ. +show_period_for_bigD :: CLIntP -> String +show_period_for_bigD bigD = + let (delta, ideals) = period_of_ideals rho_d $ (unit_ideal bigD, 0) + in "For bigD=" ++ (show bigD) ++ " the period has " + ++ (show $ (length ideals) - 1) ++ " ideals and sum delta is " + ++ (show delta) + +-- | Show the period for the first /n/ valid Δ's. +show_period_for_many_bigDs :: Int -> IO() +show_period_for_many_bigDs n = do + putStrLn $ unlines $ map (\bigD -> show_period_for_bigD bigD) $ sort $ take n all_bigDs + +-- | Show period string and the list of ideals for a given Δ. +show_period_for_some_bigD :: CLIntP -> IO() +show_period_for_some_bigD bigD = do + putStrLn $ show_period_for_bigD bigD + putStrLn "Fwd rho_d:" + putStrLn $ unlines $ map printIdeal ideals + putStrLn "Inv rho_d:" + putStrLn $ unlines $ map printIdeal invideals + where + (delta, ideals) = period_of_ideals rho_d $ (unit_ideal bigD, 0) + (invdelta, invideals) = period_of_ideals rho_inv_d $ (unit_ideal bigD, 0) + printIdeal ideal = + (show ideal) + ++ " Reduced: " + ++ if (is_reduced $ fst ideal) then "true" else "false" + +-- | Show a list of valid Δ's. +show_bigDs :: Int -> IO() +show_bigDs n = do + putStrLn $ show $ take n all_bigDs + +-- | Explicitly compute first few ideals for some Δ. +first_few :: IO() +first_few = do + putStrLn $ "O :" ++ show j_0 + putStrLn $ "j1/2:" ++ show j_05 + putStrLn $ "j1 :" ++ show j_1 + where + bigD = 17 + j_0 = (unit_ideal bigD, 0) + j_05 = rho_d j_0 + j_1 = rho_d j_05 + +-- | Perform an operation on all ideal pairs that are generated by Δ. +op_all_ideals :: (IdDist -> IdDist -> IdDist) -> String -> CLIntP -> IO() +op_all_ideals op opString bigD = do + putStrLn $ unlines $ [ doOp i j | i <- ideals, j <- ideals ] + where + (delta, ideals_with_o) = period_of_ideals rho_d $ (unit_ideal bigD, 0) + ideals = init ideals_with_o + doOp i j = "(" ++ (show i) ++ ")" ++ opString ++ "(" ++ (show j) ++ ") = " + ++ (show (i_op_j)) + ++ " Reduced:" + ++ (if (is_reduced $ fst i_op_j) then "true" else "false") +-- ++ " rho_d of:" ++ (show $ rho_d i_op_j) + where i_op_j = i `op` j + +-- | The the product of all pairs of ideals for a given Δ. +dot_all_ideals :: CLIntP -> IO() +dot_all_ideals bigD = op_all_ideals dot "." bigD + +-- | Take the star product of all pairs of ideals for a given Δ. +star_all_ideals :: CLIntP -> IO() +star_all_ideals bigD = op_all_ideals star "*" bigD + +-- | Test the 'bounded_while' functionality. +test_bounded_while :: (Show int, Integral int) => int -> int -> IO() +test_bounded_while bound start = do + putStrLn $ show $ + bounded_while (\k -> k > 0) bound + (\k -> k-1) start + +-- | Run classical tests for Class Number algorithm. +main :: IO() +main = do +-- test_bounded_while 10 5 +-- putStrLn $ "a=23, b=-41, bigD=28, tau =" ++ show (tau (-41) 23 28) +-- putStrLn $ "a=23, b=-41, bigD=28, itau=" ++ show (itau (-41) 23 28) +-- putStrLn $ unlines $ testTauForDelta 28 tau +-- first_few +-- showDs 50 +-- showPeriodForManyBigDs 400 +-- show_period_for_some_bigD 28 +-- dot_all_ideals 28 + star_all_ideals 28 +-- putStrLn $ show $ rho_d $ (Ideal 28 1 1 9 8, 0) + +-- putStrLn $ show $ take 100 all_small_ds +-- putStrLn $ show $ sort $ take 100 all_bigDs + +-- For bigD=2524 the period has 48 ideals and sum delta is 41.3199021281136 + +-- putStrLn $ show $ continued_list 649 200 +-- putStrLn $ show $ convergents $ continued_list 649 200 + +-- | Test the primes code. +test_primes :: IO () +test_primes = do +-- putStrLn $ show $ jacobi_symbol 1001 9907 +-- putStrLn $ show $ jacobi_symbol 14 7 + putStrLn $ show $ primes_to 8000 diff --git a/dist/build/Quipper/Algorithms/CL/Types.hs b/dist/build/Quipper/Algorithms/CL/Types.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/CL/Types.hs @@ -0,0 +1,643 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/CL/Types.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This module defines the specialized datatypes of the Class Number algorithm, and basic utility functions on these types. +module Quipper.Algorithms.CL.Types where + +import Quipper +import Quipper.Internal +import Data.Typeable +import Data.Ratio + +import Quipper.Libraries.Arith hiding (q_mult_param) +import Quipper.Libraries.FPReal +import Quipper.Algorithms.CL.Auxiliary + +-- =========================================== +-- * Type synonyms + +-- $ First, we define some type synonyms for arithmetic types, selecting which will be used in the functions for the Class Number algorithm. +-- +-- We use three different integer types. For interfacing with quantum computation, we use 'CLInt' := 'IntM'. For efficient classical (i.e. circuit-generation time) computation on potentially large integers, we use 'CLIntP' := 'Integer', Haskell’s arbitrary-precision integers. (Δ, for instance, is taken to be a 'CLIntP'). For small classical integers (typically for register sizes), we use 'Int', Haskell’s bounded-precision integers. +-- +-- For the first two of these, we define type synonyms, so that they can be swapped out to other types if desired (they are to a large extent modular). For 'Int' we do not, since we make un-coerced use of built-in Haskell functions like 'length' which give it specifically. +-- +-- Where not dictated by these conventions, integer types are generalized, i.e., @(Integral a) =>@ … +-- +-- Rational and real numbers have not yet been similarly stratified. + +-- | Integers that may be passed into or received out of quantum computations. +type CLInt = IntM + +-- | Integers that will be used for parameter computation only, potentially large. +type CLIntP = Integer + +-- | Rational numbers for the Class Number code. +type CLRational = Rational + +-- | Real numbers for the Class Number code. +type CLReal = FPReal + +-- =========================================== +-- * Algebraic number fields + +-- =========================================== +-- ** Discriminants + +-- $ The functions of this subsection are needed only for circuit-generation-time classical computation, not for quantum circuit computation. + +-- | Compute Δ, given /d/. +-- (See [Jozsa 2003], Prop. 6 et seq. We use Δ, or in code /bigD/, +-- where Jozsa uses /D/.) +bigD_of_d :: Integral a => a -> a +bigD_of_d d = case (d `mod` 4) of + 1 -> d + _ -> 4*d + +-- | Compute /d/, given Δ. +-- (Again, see [Jozsa 2003], Prop. 6 et seq.) +d_of_bigD :: Integral a => a -> a +d_of_bigD bigD = case (bigD `mod` 4) of + 0 -> bigD `div` 4 + _ -> bigD + +-- | Check if /d/ is a valid input to Hallgren’s algorithm, +-- i.e. correctly defines a real quadratic number field. +is_valid_d :: (Integral a) => a -> Bool +is_valid_d d = d > 1 && is_square_free d + +-- | Check if /Δ/ is a valid input to Hallgren’s algorithm, +-- i.e. is the discriminant of a real quadratic number field. +-- (Cf. ) +is_valid_bigD :: (Integral a) => a -> Bool +is_valid_bigD bigD = bigD > 1 && case (bigD `mod` 4) of + 1 -> is_square_free bigD + 0 -> (d `mod` 4 == 2 || d `mod` 4 == 3) && is_square_free d + where d = bigD `div` 4 + _ -> False + +-- | The (infinite, lazy) list of all valid inputs /d/, +-- i.e. of all square-free integers above 2. +all_small_ds :: (Integral int) => [int] +all_small_ds = filter (\n -> is_valid_d n) [2..] + +-- | The (infinite, lazy) list of all valid inputs Δ, +-- i.e. of all discriminants of real quadratic number fields. +all_bigDs :: (Integral int) => [int] +all_bigDs = map bigD_of_d all_small_ds + +-- =========================================== +-- ** Field elements + +-- | A data type describing a number in the algebraic number field K = +-- ℚ[√Δ]: @'AlgNum' /a/ /b/ Δ@ represents /a/ + /b/√Δ. +-- +-- In general, the type of coefficients may be any type of (classical +-- or quantum) numbers, i.e. an instance of the 'Num' or 'QNum' class. +-- Given this, the algebraic numbers with a fixed Δ will in turn be an +-- instance of 'Num' or 'QNum'. +-- +-- A value @/a/ :: /x/@ may also be used as an @'AlgNumGen' /x/@, with +-- no Δ specified, to represent simply /a/ + 0√Δ; this can be +-- considered polymorphic over all possible values of Δ. +-- +-- This is similar to the use of 'IntM's or 'FPReal's of indeterminate +-- size, although unlike for them, we do not restrict this to the +-- classical case. However, the question of whether an 'AlgNum' has +-- specified √Δ is (like e.g. the length of a list) is a parameter +-- property, known at circuit generation time, not a purely quantum +-- property. +data AlgNumGen a = AlgNum a a CLIntP | AlgNum_indet a deriving (Show) + +-- | The specific instance of 'AlgNumGen' used for classical +-- (parameter) computation. +type AlgNum = AlgNumGen CLRational + +-- | Extract the first co-ordinate of an 'AlgNumGen' +fst_AlgNum :: AlgNumGen a -> a +fst_AlgNum (AlgNum u _ _) = u +fst_AlgNum (AlgNum_indet u) = u + +-- | Extract the second co-ordinate of an 'AlgNumGen' +snd_AlgNum :: (Num a) => AlgNumGen a -> a +snd_AlgNum (AlgNum _ v _) = v +snd_AlgNum (AlgNum_indet _) = 0 + +instance (Eq a, Num a) => Eq (AlgNumGen a) where + (AlgNum a b bigD) == (AlgNum a' b' bigD') = + if bigD == bigD' then a == a' && b == b' + else error "Operation = on AlgNum: operands must have same Δ." + (AlgNum a b bigD) == (AlgNum_indet a') = (AlgNum a b bigD) == (AlgNum a' 0 bigD) + (AlgNum_indet a) == (AlgNum a' b' bigD') = (AlgNum a 0 bigD') == (AlgNum a' b' bigD') + (AlgNum_indet a) == (AlgNum_indet a') = a == a' + +-- | Print an algebraic number in human-readable (though not +-- Haskell-readable) format, as e.g. /a/ + /b/√Δ. +pretty_show_AlgNum :: Show a => AlgNumGen a -> String +pretty_show_AlgNum (AlgNum a b bigD) = (show a) ++ " + " ++ (show b) ++ " √" ++ show bigD +pretty_show_AlgNum (AlgNum_indet a) = show a + +-- | Realize an algebraic number as a real number (of any 'Floating' type). +floating_of_AlgNum :: (Real a, Floating b) => AlgNumGen a -> b +floating_of_AlgNum (AlgNum a b bigD) = (realToFrac a) + (realToFrac b) * (sqrt $ fromIntegral bigD) +floating_of_AlgNum (AlgNum_indet a) = (realToFrac a) + +-- | Coerce one algebraic number into the field of a second, if possible. If not possible (i.e. if their Δ’s mismatch), throw an error. +number_promote :: Num a => AlgNumGen a -> AlgNumGen b -> ErrMsg -> AlgNumGen a +number_promote (AlgNum a b bigD) (AlgNum _ _ bigD') e = + if bigD == bigD' then AlgNum a b bigD + else error $ e "mismatched Δ." +number_promote (AlgNum_indet a) (AlgNum _ _ bigD') _ = AlgNum a 0 bigD' +number_promote n (AlgNum_indet _) _ = n + +instance (Ord a, Num a) => Ord (AlgNumGen a) where + compare (AlgNum a b bigD) (AlgNum a' b' bigD') = + if bigD == bigD' then + case (compare a a', compare b b') of + (EQ,y) -> y + (x,EQ) -> x + (GT,GT) -> GT + (LT,LT) -> LT + (GT,LT) -> compare ((a-a')^2) ((b-b')^2 * fromInteger bigD) + (LT,GT) -> compare ((b-b')^2 * fromInteger bigD) ((a-a')^2) + else + error "compare // AlgNumGen: mismatched Δ." + compare (AlgNum a b bigD) (AlgNum_indet a') = compare (AlgNum a b bigD) (AlgNum a' 0 bigD) + compare (AlgNum_indet a) (AlgNum a' b' bigD') = compare (AlgNum a 0 bigD') (AlgNum a' b' bigD') + compare (AlgNum_indet a) (AlgNum_indet a') = compare a a' + +instance (Ord a, Num a) => Num (AlgNumGen a) where + (AlgNum a b bigD) + (AlgNum a' b' bigD') = + if bigD == bigD' then AlgNum (a+a') (b+b') bigD + else error "Operation + on AlgNum: operands must have same Δ." + (AlgNum a b bigD) + (AlgNum_indet a') = (AlgNum a b bigD) + (AlgNum a' 0 bigD) + (AlgNum_indet a) + (AlgNum a' b' bigD') = (AlgNum a 0 bigD') + (AlgNum a' b' bigD') + (AlgNum_indet a) + (AlgNum_indet a') = (AlgNum_indet (a + a')) + + (AlgNum a b bigD) * (AlgNum a' b' bigD') = + if bigD == bigD' then AlgNum (a*a' + b*b'*(fromIntegral bigD)) (a*b' + a'*b) bigD + else error "Operation * on AlgNum: operands must have same Δ." + (AlgNum a b bigD) * (AlgNum_indet a') = (AlgNum a b bigD) * (AlgNum a' 0 bigD) + (AlgNum_indet a) * (AlgNum a' b' bigD') = (AlgNum a 0 bigD') * (AlgNum a' b' bigD') + (AlgNum_indet a) * (AlgNum_indet a') = (AlgNum_indet (a * a')) + + (AlgNum a b bigD) - (AlgNum a' b' bigD') = + if bigD == bigD' then AlgNum (a-a') (b-b') bigD + else error "Operation - on AlgNum: operands must have same Δ." + (AlgNum a b bigD) - (AlgNum_indet a') = (AlgNum a b bigD) - (AlgNum a' 0 bigD) + (AlgNum_indet a) - (AlgNum a' b' bigD') = (AlgNum a 0 bigD') - (AlgNum a' b' bigD') + (AlgNum_indet a) - (AlgNum_indet a') = (AlgNum_indet (a - a')) + + abs n = if (n >= 0) then n else -n + signum n = number_promote (if n > 0 then 1 else if n == 0 then 0 else (-1)) n + (const "CL.Types: internal error (signum // AlgNum)") + fromInteger = AlgNum_indet . fromInteger + +instance (Real a) => Real (AlgNumGen a) where + toRational = toRational . floating_of_AlgNum + +instance (Ord a, Fractional a) => Fractional (AlgNumGen a) where + fromRational = AlgNum_indet . fromRational + + recip (AlgNum a b bigD) = + let c = (a^2) - (b^2 * (fromIntegral bigD)) + in assert (c /= 0) (if (a == 0 && b == 0) then "CL.Types: divide-by-zero error" + else if is_valid_bigD bigD then "CL.Types: internal error (AlgNum // recip)" + else error "CL.Types: " ++ show bigD ++ " not a valid discriminant") + (AlgNum (a/c) (-b/c) bigD) + recip (AlgNum_indet a) = AlgNum_indet $ recip a + +instance (RealFrac a) => RealFrac (AlgNumGen a) where + properFraction x = (x',x - fromIntegral x') + where x' = truncate $ floating_of_AlgNum x + +-- | The algebraic conjugate: sends /a/ + /b/ √Δ to /a/ - /b/ √Δ. +conjugate :: (Num a) => AlgNumGen a -> AlgNumGen a +conjugate (AlgNum a b bigD) = (AlgNum a (-b) bigD) +conjugate (AlgNum_indet a) = (AlgNum_indet a) + +-- | Test whether an algebraic number is an algebraic integer. +-- +-- (A number is an algebraic integer iff it can be written in the form /m/ + /n/(Δ + √Δ)\/2, where /m/, /n/ are integers. +-- See [Jozsa 2003], proof of Prop. 14.) +is_alg_int :: (Ord a, RealFrac a) => AlgNumGen a -> Bool +is_alg_int (AlgNum a b bigD) = is_int n && is_int m + where +-- solve for m, n in the equation [a + b √D = m + n(Δ + √Δ)/2] + n = 2 * b + m = a - b * fromIntegral bigD +is_alg_int (AlgNum_indet a) = is_int a + +-- | Test whether an algebraic number is a unit of the ring of algebraic integers. +is_unit :: (Ord a, RealFrac a) => AlgNumGen a -> Bool +is_unit n = if n == 0 then False else (is_alg_int n) && (is_alg_int (recip n)) + +-- | The number ω associated to the field /K/. +omega_of_bigD :: CLIntP -> AlgNum +omega_of_bigD bigD = + if (bigD `mod` 4 == 1) + then (AlgNum (1/2) (1/2) bigD) + else (AlgNum 0 1 bigD) + +-- =========================================== +-- * Ideals + +-- | Data specifying an ideal in an algebraic number field. An ideal is described by a tuple +-- (Δ,/m/,/l/,/a/,/b/), representing the ideal +-- +-- /m/\//l/ (/aZ/ + (/b/+√Δ)\/2 /Z/), +-- +-- where moreover we assume and ensure always that the ideal is in /standard form/ ([Jozsa 2003], p.11, Prop. 16). Specifically, +-- +-- * /a/,/k/,/l/ > 0; +-- +-- * 4/a/ | /b/[sup 2] – Δ; +-- +-- * /b/ = τ(/a/,/b/); +-- +-- * gcd(/k/,/l/) = 1 +-- +-- In particular, this gives us bounds on the size of /a/ and /b/, +-- and hence tells us the sizes needed for these registers (see 'length_for_ab' below). +data IdealX x = Ideal CLIntP (XInt x) (XInt x) (XInt x) (XInt x) + deriving (Show, Eq, Typeable) + +-- | Classical parameter specifying an ideal. +type Ideal = IdealX Bool + +-- | Quantum circuit-type counterpart of 'Ideal'. +type IdealQ = IdealX Qubit + +-- | Classical circuit-type counterpart of 'Ideal'. +type IdealC = IdealX Bit + +type instance QCType x y (IdealX z) = IdealX (QCType x y z) +type instance QTypeB Ideal = IdealQ + +instance Show Ideal where + show (Ideal bigD m l a b) = + "Ideal " + ++ show bigD ++ " " + ++ show m ++ " " + ++ show l ++ " " + ++ show a ++ " " + ++ show b + +instance QCLeaf x => QCData (IdealX x) where + + qcdata_mapM ~(Ideal _ msh lsh ash bsh) f g (Ideal bigD m l a b) = do + m' <- qcdata_mapM msh f g m + l' <- qcdata_mapM lsh f g l + a' <- qcdata_mapM ash f g a + b' <- qcdata_mapM bsh f g b + return (Ideal bigD m' l' a' b') + + qcdata_zip ~(Ideal _ msh lsh ash bsh) q c q' c' (Ideal bigD m l a b) (Ideal bigD' m' l' a' b') e + | bigD /= bigD' + = error (e "Ideal exponent mismatch") + | otherwise + = (Ideal bigD m'' l'' a'' b'') + where + m'' = qcdata_zip msh q c q' c' m m' errmsg + l'' = qcdata_zip lsh q c q' c' l l' errmsg + a'' = qcdata_zip ash q c q' c' a a' errmsg + b'' = qcdata_zip bsh q c q' c' b b' errmsg + errmsg x = e ("in Ideal: " ++ x) + + qcdata_promote (Ideal bigD m l a b) (Ideal bigD' m' l' a' b') e + | bigD /= bigD' + = error (e "Ideal exponent mismatch") + | otherwise + = (Ideal bigD m'' l'' a'' b'') + where + m'' = qcdata_promote m m' errmsg + l'' = qcdata_promote l l' errmsg + a'' = qcdata_promote a a' errmsg + b'' = qcdata_promote b b' errmsg + errmsg x = e ("in Ideal: " ++ x) + +-- Labeling of IdealQ is (m,l,a,b). +instance QCLeaf x => Labelable (IdealX x) String where + label_rec (Ideal _ qm ql qa qb) s = do + label_rec qm s `dotted_indexed` "m" + label_rec ql s `dotted_indexed` "l" + label_rec qa s `dotted_indexed` "a" + label_rec qb s `dotted_indexed` "b" + +-- We also provide an alternate labeling by a 4-tuple of strings, in +-- case this is ever useful (maybe for an ideal where the components +-- are called something other than /m/, /l/, /a/, and /b/). +instance Labelable IdealQ (String, String, String, String) where + label_rec (Ideal _ qm ql qa qb) (sm, sl, sa, sb) = do + label_rec qm sm + label_rec ql sl + label_rec qa sa + label_rec qb sb + +instance Eq Ideal where + i1@(Ideal bigD m l a b) == i2@(Ideal bigD' m' l' a' b') + = if (bigD /= bigD') + then error error_string + else (m == m' && l' == l' && a == a' && b == b') + where error_string = "Comparing two ideals of different Δ: " ++ (show i1) ++ "," ++ (show i2) + +-- | Data specifying a reduced ideal, by a tuple (Δ,/a/,/b/); this +-- corresponds to the ideal specified by (Δ,1,/a/,/a/,/b/), i.e., +-- /Z/ + (/b/+√Δ)\/2/a/ /Z/. +data IdealRedX x = IdealRed CLIntP (XInt x) (XInt x) + deriving (Show, Typeable) + +-- | Classical parameter specifying a reduced ideal. +type IdealRed = IdealRedX Bool + +-- | Quantum circuit-type counterpart of 'IdealRed'. +type IdealRedQ = IdealRedX Qubit + +-- | Classical circuit-type counterpart of 'IdealRed'. +type IdealRedC = IdealRedX Bit + +instance Show IdealRed where + show (IdealRed bigD a b) = + "IdealRed " + ++ show bigD ++ " " + ++ show a ++ " " + ++ show b + +instance Eq IdealRed where + i1@(IdealRed bigD a b) == i2@(IdealRed bigD' a' b') + = if (bigD /= bigD') + then error error_string + else (a == a' && b == b') + where error_string = "Comparing two reduced ideals of different Δ: " + ++ (show i1) ++ "," ++ (show i2) + +type instance QCType x y (IdealRedX z) = IdealRedX (QCType x y z) +type instance QTypeB IdealRed = IdealRedQ + +instance QCLeaf x => QCData (IdealRedX x) where + + qcdata_mapM ~(IdealRed _ ash bsh) f g (IdealRed bigD a b) = do + a' <- qcdata_mapM ash f g a + b' <- qcdata_mapM bsh f g b + return (IdealRed bigD a' b') + + qcdata_zip ~(IdealRed _ ash bsh) q c q' c' (IdealRed bigD a b) (IdealRed bigD' a' b') e + | bigD /= bigD' + = error (e "IdealRed exponent mismatch") + | otherwise + = (IdealRed bigD a'' b'') + where + a'' = qcdata_zip ash q c q' c' a a' errmsg + b'' = qcdata_zip bsh q c q' c' b b' errmsg + errmsg x = e ("in IdealRed: " ++ x) + + qcdata_promote (IdealRed bigD a b) (IdealRed bigD' a' b') e + | bigD /= bigD' + = error (e "IdealRed exponent mismatch") + | otherwise + = (IdealRed bigD a'' b'') + where + a'' = qcdata_promote a a' errmsg + b'' = qcdata_promote b b' errmsg + errmsg x = e ("in IdealRed: " ++ x) + +-- Labeling of IdealRedQ is (a,b). +instance QCLeaf x => Labelable (IdealRedX x) String where + label_rec (IdealRed _ qa qb) s = do + label_rec qa s `dotted_indexed` "a" + label_rec qb s `dotted_indexed` "b" + +-- We also provide an alternate labeling by a pair of strings, in case +-- this is ever useful (maybe for an ideal where the two components +-- are called something other than /a/ and /b/). +instance QCLeaf x => Labelable (IdealRedX x) (String, String) where + label_rec (IdealRed _ qa qb) (sa, sb) = do + label_rec qa sa + label_rec qb sb + +-- | An ideal /I/, together with a distance δ for it — that is, /some/ representative, mod /R/, for δ(/I/) as defined on /G/ p.4. +-- Most functions described as acting on ideals need in fact to be seen as a pair of an ideal and a distance for it. +type IdDist = (Ideal,FPReal) + +-- | Quantum analogue of 'IdDist'. +type IdDistQ = (IdealQ,FPRealQ) + +-- | A reduced ideal /I/, together with a distance δ for it. +type IdRedDist = (IdealRed,FPReal) + +-- | Quantum analogue of 'IdRedDist'. +type IdRedDistQ = (IdealRedQ,FPRealQ) + +-- =========================================== +-- ** Trivial access functions + +-- | Extract the /d/ component from an 'IdealQ'. +d_of_Ideal :: IdealX a -> CLIntP +d_of_Ideal (Ideal bigD _ _ _ _) = d_of_bigD bigD + +-- | Extract the /d/ component from an 'IdealRedQ'. +d_of_IdealRed :: IdealRedX a -> CLIntP +d_of_IdealRed (IdealRed bigD _ _) = d_of_bigD bigD + +-- | Extract Δ from an 'IdealQ'. +bigD_of_Ideal :: IdealX a -> CLIntP +bigD_of_Ideal (Ideal bigD _ _ _ _) = bigD + +-- | Extract Δ from an 'IdealRedQ'. +bigD_of_IdealRed :: IdealRedX a -> CLIntP +bigD_of_IdealRed (IdealRed bigD _ _) = bigD + +-- | Extract the delta part from an ideal/distance pair. +delta :: IdDist -> CLReal +delta (Ideal _ _ _ _ _, del) = del + +-- =========================================== +-- ** Assertions, coercions + +-- $ Elements of the types 'Ideal', 'IdealRed', etc are assumed to +-- satisfy certain extra conditions. This section includes functions +-- for checking that these conditions are satisfied, and for safely +-- coercing between these types. + +-- | @'tau' Δ /b/ /a/@: the function τ(/b/,/a/). Gives the representative for /b/ mod /2a/, in a range dependent on /a/ and √Δ. +-- +-- (This doesn't quite belong here, but is included as a prerequisite of the assertions). +tau :: (Integral int, Integral int') => int' -> int -> int -> int +tau bigD b a = mod_with_max b (2*a) max + where + max = if a > root_bigD then a else root_bigD + root_bigD = floor $ sqrt $ fromIntegral bigD + +-- | Return 'True' if the given ideal is in standard form. (Functions should /always/ keep ideals in standard form). +is_standard :: Ideal -> Bool +is_standard (Ideal bigD m l a b) = + (a > 0) && (l > 0) && (m > 0) + && ((bigD - (fromIntegral b)^2) `mod` (4 * (fromIntegral a)) == 0) + && b == tau bigD b a + +-- | Test whether an 'Ideal' is reduced. (An ideal \ is reduced iff /m/ = 1, /l/ = /a/, /b/ ≥ 0 and /b/ + √Δ > 2/a/ ([Jozsa 2003], Prop. 20)). +is_reduced :: Ideal -> Bool +is_reduced (Ideal bigD m l a b) = (m == 1) && (l == a) && (b >= 0) && (b + root_bigD > 2 * a) + where root_bigD = ceiling $ sqrt $ fromIntegral bigD + +-- | Test whether an 'IdealRed' is really reduced. (An ideal \<1,/a/,/a/,/b/> is reduced iff /b/ ≥ 0 and /b/ + √Δ > 2/a/ ([Jozsa 2003], Prop. 20)). +is_really_reduced :: IdealRed -> Bool +is_really_reduced (IdealRed bigD a b) = (b >= 0) && (b + root_bigD > 2 * a) + where root_bigD = ceiling $ sqrt $ fromIntegral bigD + +-- | Coerce an 'IdealRed' to an 'Ideal'. +forget_reduced :: IdealRed -> Ideal +forget_reduced (IdealRed bigD a b) = (Ideal bigD 1 a a b) + +-- | Coerce an 'Ideal' to an 'IdealRed', if it is reduced, or throw an error otherwise. Cf. [Jozsa 2003], Prop. 20. +to_reduced :: Ideal -> IdealRed +to_reduced ii@(Ideal bigD m l a b) = + if is_reduced ii then (IdealRed bigD a b) + else error $ "to_reduced: (" ++ (show ii) ++ ") is not reduced." + +-- | Throw an error if an 'Ideal' is not reduced; otherwise, the identity function. +assert_reduced :: Ideal -> a -> a +assert_reduced ii = + assert (is_reduced ii) ("assert_reduced: (" ++ (show ii) ++ ") is not reduced.") + +-- | Throw an error if an 'IdealRed' is not really reduced; otherwise, the identity function. +assert_really_reduced :: IdealRed -> a -> a +assert_really_reduced ii = + assert (is_really_reduced ii) ("assert_really_reduced: (" ++ (show ii) ++ ") is not reduced.") + +-- | Quantum analogue of 'tau'. @'q_tau' Δ /qb/ /qa/@: compute the representative for /qb/ mod 2/qa/, in a range dependent on /qa/ and √Δ. +q_tau :: CLIntP -> QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_tau bigD = box ("tau, Δ = " ++ show bigD) $ \a b -> do + let root_bigD = floor $ sqrt $ fromIntegral bigD + t <- with_computed + (do + (_, a_gt_rtD) <- q_gt_param a root_bigD + max <- qinit $ qc_false a + (max, _) <- controlled_not max a `controlled` a_gt_rtD + max <- bool_controlled_not max (intm_promote root_bigD max "q_tau: internal error") `controlled` (a_gt_rtD .==. False) + (_, twice_a) <- q_mult_param 2 a + (_, _, _, t) <- q_mod_with_max b twice_a max + return t) + qc_copy + return (a,b,t) + +-- | Test whether a given 'IdealQ' is reduced. \ is reduced iff /m/ = 1, /l/ = /a/, /b/ ≥ 0 and /b/ + √Δ > 2/a/ ([Jozsa 2003], Prop. 20). +q_is_reduced :: IdealQ -> Circ (IdealQ,Qubit) +q_is_reduced = box "is_reduced" $ \qii -> + let bigD = bigD_of_Ideal qii in + with_computed_fun qii + (\(Ideal bigD qm ql qa qb) -> do + test1 <- qinit False + test1 <- qnot test1 `controlled` qm .==. 1 + (ql,qa,test2) <- q_is_equal ql qa + (qb,test3) <- q_ge_param qb 0 + (qa, q2a) <- q_mult_param 2 qa + qx <- q_sub_param_in_place (ceiling $ sqrt $ fromIntegral bigD) q2a + (qb, qx, test4) <- q_gt qb qx + return ([test1,test2,test3,test4], (qm,ql,qa,qb,qx))) + (\(tests, rest) -> do + test_out <- qinit False + test_out <- qnot test_out `controlled` tests + return ((tests, rest), test_out)) + +-- | Test whether a given 'IdealQ' is really reduced (as it should always be, if code is written correctly). An ideal \<1,/a/,/a/,/b/> is reduced iff /b/ ≥ 0 and /b/ + √Δ > 2/a/ ([Jozsa 2003], Prop. 20). +q_is_really_reduced :: IdealRedQ -> Circ (IdealRedQ,Qubit) +q_is_really_reduced = box "is_really_reduced" $ \qii -> + let bigD = bigD_of_IdealRed qii in + with_computed_fun qii + (\(IdealRed bigD qa qb) -> do + (qb,test1) <- q_ge_param qb 0 + (qa, q2a) <- q_mult_param 2 qa + qx <- q_sub_param_in_place (ceiling $ sqrt $ fromIntegral bigD) q2a + (qb, qx, test2) <- q_gt qb qx + return ([test1,test2], (qa,qb,qx))) + (\(tests, rest) -> do + test_out <- qinit False + test_out <- qnot test_out `controlled` tests + return ((tests, rest), test_out)) + +-- | Coerce an 'IdealRedQ' to an 'IdealQ', initializing the extra components appropriately. +q_forget_reduced :: IdealRedQ -> Circ IdealQ +q_forget_reduced = box "forget_reduced" $ \(IdealRed bigD a b) -> do + let a_bits = qulist_of_qdint_bh a + n = length a_bits + m <- qinit (intm n 1) + (a,l) <- qc_copy_fun a + return (Ideal bigD m l a b) + +-- | Coerce an 'IdealQ' to an 'IdealRedQ', assertively terminating the extra components +-- (and hence throwing an error at quantum runtime if the input is not reduced). +q_assert_reduced :: IdealQ -> Circ IdealRedQ +q_assert_reduced = box "assert_reduced" $ \x@(Ideal bigD m l a b) -> do + x_red <- reverse_generic q_forget_reduced (IdealRed bigD a b) x + q_assert_really_reduced x_red + +-- | Throw a (quantum-runtime) error if an 'IdealRedQ' is not really reduced; otherwise, do nothing. +-- +-- Compare 'assert_reduced', 'q_is_really_reduced' in "Quipper.Algorithms.CL.RegulatorQuantum", and [Jozsa 2003] Prop. 20. +q_assert_really_reduced :: IdealRedQ -> Circ IdealRedQ +q_assert_really_reduced = box "assert_really_reduced" $ \ii -> do + (ii,test) <- q_is_really_reduced ii + qterm True test + return ii + +-- ====================================================================== +-- ** Bounds on coefficient sizes + +-- $ Given Δ, how much space should be allocated for the coefficients of ideals? Most of these bounds are currently missing or uncertain, as documented below. Note these bounds are intended to be sufficient for the calculations occurring in this algorithm, /not/ for representing arbitrary ideals. + +-- | Given Δ, return the size of integers to be used for the coefficients /a/, /b/ of reduced ideals. +-- +-- Note: can we bound this more carefully? In reduced ideals, we always have 0 ≤ /a/,/b/ ≤ √Δ (see notes on 'is_standard', 'is_reduced'), and the outputs of ρ, ρ[sup –1] and dot-products of reduced ideals always keep |/a/| ≤ Δ. However, intermediate calculations may involve larger values, so we allocate a little more space. For now, this padding is a seat-of-the-pants estimate. +length_for_ab :: CLIntP -> Int +length_for_ab bigD = 3 + (ceiling $ logBase 2 $ fromIntegral bigD) + +-- | Given Δ, return the size of integers to be used for the coefficients /m/, /l/ of general ideals. +-- +-- TODO: bound this! Neither Hallgren nor [Jozsa 2003] discusses bounds on the values of /m/ and /l/ that will appear, and we do not yet have a bound. For now we use the same length as for /a/ and /b/, for convenience; this should be considered a dummy bound, quite possibly not sufficient in general. +length_for_ml :: CLIntP -> Int +length_for_ml = length_for_ab + +-- | Given Δ, return the precision /n/ = log[sub 2]/N/ to be used for +-- discretizing the quasi-periodic function /f/ to /f/[sub /N/]. +-- +-- (“Precision” here means the number of binary digits after the point). +-- +-- Taken to ensure 1\//N/ < 3/(32 Δ log Δ). (Cf. [Jozsa 2003], Prop. 36 (iii).) +n_of_bigD :: (Integral int) => CLIntP -> int +n_of_bigD bigD = + ceiling $ logBase 2 $ 32 * (fromIntegral bigD) * (log $ fromIntegral bigD) / 3 + +-- | Given Δ, /n/, /l/ (as for +-- 'Quipper.Algorithms.CL.RegulatorClassical.fN', +-- 'Quipper.Algorithms.CL.RegulatorQuantum.q_fN'), return the +-- precision required for intermediate distance calculations during +-- the computation of /f/[sub /N/]. +-- +-- TODO: bound this more carefully. [Jozsa 2003] asks for the final output to be precision /n/, but does not discuss intermediate precision, and we have not yet got a confident answer. For now, just a back-of-the-envelope estimate, which should be sufficient and /O/(correct), but is almost certainly rather larger than necessary. +precision_for_fN :: CLIntP -> Int -> Int -> Int +precision_for_fN _ n l = 2 * (n + l) + +-- | Set the 'IntM' coefficients of an 'Ideal' to the standard lengths, if they are not already fixed incompatibly. The standard lengths are determined by 'length_for_ml', 'length_for_ab'. (Compare 'intm_promote', etc.) +fix_sizes_Ideal :: Ideal -> Ideal +fix_sizes_Ideal (Ideal bigD m l a b) = (Ideal bigD (f m) (f l) (f a) (f b)) + where + f x = intm_promote x (intm n 0) "set_sizes_Ideal: lengths already fixed incompatibly" + n = max (length_for_ml bigD) (length_for_ab bigD) + +-- | Set the 'IntM' coefficients of an 'IdealRed' to the standard lengths, if they are not already fixed incompatibly. The standard lengths are determined by 'length_for_ml', 'length_for_ab'. (Compare 'intm_promote', etc.) +fix_sizes_IdealRed :: IdealRed -> IdealRed +fix_sizes_IdealRed (IdealRed bigD a b) = (IdealRed bigD (f a) (f b)) + where + f x = intm_promote x (intm n 0) "set_sizes_Ideal: lengths already fixed incompatibly" + n = max (length_for_ml bigD) (length_for_ab bigD) diff --git a/dist/build/Quipper/Algorithms/GSE/GSE.hs b/dist/build/Quipper/Algorithms/GSE/GSE.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/GSE/GSE.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/GSE/GSE.hs" #-} +-- | This module provides the main circuit for the GSE algorithm. +-- This circuit consists of a state preparation, followed by a large +-- number of Hamiltonian simulation terms for small time steps, +-- followed by an inverse Quantum Fourier Transform and a final +-- measurement. + +module Quipper.Algorithms.GSE.GSE where + +import Quipper +import Quipper.Libraries.QFT +import Quipper.Algorithms.GSE.GSEData +import Quipper.Algorithms.GSE.JordanWigner + +import Control.Monad +import Text.Printf + +-- ---------------------------------------------------------------------- +-- * Basic time step + +-- $ These functions provide one- and two-electron operators for an +-- individual Trotter time step θ. Each operator consists of a large +-- number of individual Hamiltonian terms. + +-- | Apply the one-electron operator [exp -/i/θ/H/], where +-- /H/ = /h/[sub /pq/] /a/[sub /p/][sup †]/a/[sub /q/] if /p/ = /q/ and +-- /H/ = /h/[sub /pq/] (/a/[sub /p/][sup †]/a/[sub /q/] +-- + /a/[sub /q/][sup †]/a/[sub /p/]) otherwise, to every pair of +-- qubits /p/≥/q/ in a register |ψ〉. The inputs are Hamiltonian data +-- /h/, the angle θ, the register |ψ〉, and a control qubit. +exp_pq :: ((Int,Int) -> Double) -> Double -> [Qubit] -> Qubit -> Circ() +exp_pq h theta psi ctl = do + comment_with_label (printf "ENTER: exp_pq (theta=%.3e)" theta) (psi, ctl) ("psi", "ctl") + + for 0 (m-1) 1 $ \p -> do + for 0 (m-1) 1 $ \q -> do + when (p >= q) $ do + one_electron_circuit (theta * h (p,q)) p q psi [ctl] + comment_with_label "EXIT: exp_pq" (psi, ctl) ("psi", "ctl") + where + m = length psi + +-- | Apply the two-electron operator [exp -/i/θ/H/], where +-- /H/ = /h/[sub /pqrs/] +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] if +-- (/p/,/q/) = (/s/,/r/) and /H/ = +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] + +-- /a/[sub /s/][sup †]/a/[sub /r/][sup †]/a/[sub /q/]/a/[sub /p/] +-- otherwise, to every quadruple (/p/, /q/, /r/, /s/) of qubits in a +-- register |ψ〉. To ensure that terms are enumerated exactly once, we +-- only consider indices where (/p/, /q/) ≥ (/s/, /r/) in the +-- lexicographic order (i.e., /p/>/s/ or (/p/=/s/ and /q/≥/r/). The +-- inputs are Hamiltonian data /h/, the angle θ, the register |ψ〉, +-- and a control qubit. +exp_pqrs :: ((Int,Int,Int,Int) -> Double) -> Double -> [Qubit] -> Qubit -> Circ() +exp_pqrs h theta psi ctl = do + comment_with_label (printf "ENTER: exp_pqrs (theta=%.3e)" theta) (psi, ctl) ("psi", "ctl") + + for 0 (m-1) 1 $ \p -> do + for 0 p 1 $ \s -> do -- constraint p >= s built into the loop for efficiency + for 0 (m-1) 1 $ \q -> do + for 0 (m-1) 1 $ \r -> do + when (p > s || (p == s && q >= r)) $ do + two_electron_circuit (0.5 * theta * h(p,q,r,s)) p q r s psi [ctl] + comment_with_label "EXIT: exp_pqrs" (psi, ctl) ("psi", "ctl") + where + m = length psi + +-- | Like 'exp_pqrs', but use the \"orthodox\" circuit template for +-- the Coulomb operator. +exp_pqrs_orthodox :: ((Int,Int,Int,Int) -> Double) -> Double -> [Qubit] -> Qubit -> Circ() +exp_pqrs_orthodox h theta psi ctl = do + comment_with_label (printf "ENTER: exp_pqrs_orthodox (theta=%.3e)" theta) (psi, ctl) ("psi", "ctl") + + for 0 (m-1) 1 $ \p -> do + for 0 p 1 $ \s -> do -- constraint p >= s built into the loop for efficiency + for 0 (m-1) 1 $ \q -> do + for 0 (m-1) 1 $ \r -> do + when (p > s || (p == s && q >= r)) $ do + two_electron_circuit_orthodox (0.5 * theta * h(p,q,r,s)) p q r s psi [ctl] + comment_with_label "EXIT: exp_pqrs_orthodox" (psi, ctl) ("psi", "ctl") + where + m = length psi + +-- ---------------------------------------------------------------------- +-- * Iteration + +-- $ The following function iterates the basic Trotter timestep +-- /N/[sub /k/] times, and also normalizes the maximum energy +-- /E/[sub max]. + +-- | Apply the operator Û[sub k] ≈ +-- [exp /iE/[sub max]τ2[sup /k/]][exp -/iH/τ2[sup /k/]] to |ψ〉. +unitary_hat_at :: GSEData -- ^ The integral data /h/[sub pq] and /h/[sub pqrs]. + -> Int -- ^ The Trotter iteration count /N/[sub /k/]. + -> Double -- ^ The Hamiltonian scaling parameter τ. + -> Double -- ^ The maximum energy /E/[sub max]. + -> Bool -- ^ Use the \"orthodox\" Coulomb operator? + -> Int -- ^ The control qubit index /k/. + -> [Qubit] -- ^ The state |ψ〉. + -> Qubit -- ^ The control qubit /b/[sub /k/]. + -> Circ() +unitary_hat_at gse_data nk tau e_max orth k psi ctl = do + comment_with_label (printf "ENTER: unitary_hat_at (k=%d, nk=%d)" k nk) (psi, ctl) ("psi", "ctl") + -- abbreviate tau 2^k: + let tau2k = tau * 2**(fromIntegral k) + + -- multiply by exp(i E_max tau 2^k) + gse_T_at (-e_max * tau2k) ctl + + let theta = tau2k / (fromIntegral nk) + for 1 nk 1 $ \j -> do + exp_pq h1 theta psi ctl + if orth + then exp_pqrs_orthodox h2 theta psi ctl + else exp_pqrs h2 theta psi ctl + + comment_with_label "EXIT: unitary_hat_at" (psi, ctl) ("psi", "ctl") + + where + h1 = gse_data_h1 gse_data + h2 = gse_data_h2 gse_data + +-- ---------------------------------------------------------------------- +-- * Main circuit + +-- $ The main circuit for the GSE Algorithm. This consists of the +-- initial state preparation, the Trotterized phase estimation +-- circuit, the Quantum Fourier Transform, and the final measurement. + +-- | The main circuit for the GSE Algorithm. +gse :: Int -- ^ The number of precision qubits /b/. + -> Int -- ^ The number of basis functions /M/. + -> Int -- ^ The number of occupied orbitals /N/. + -> GSEData -- ^ The integral data /h/[sub pq] and /h/[sub pqrs]. + -> Double -- ^ The Hamiltonian scaling parameter τ. + -> Double -- ^ The maximum energy /E/[sub max]. + -> (Int -> Int) -- ^ The function /k/ ↦ /N/[sub /k/]. + -> Bool -- ^ Use the \"orthodox\" Coulomb operator? + -> Circ([Bit]) +gse b m o gse_data tau e_max nfun orth = do + comment "ENTER: gse" + + -- set up the state for b and psi + bstate <- qinit (take b (repeat False)) + psi <- qinit (take m (repeat False)) + + -- apply X gate to the first o 'occupied' qubits of psi + sequence_ [ gate_X_at q | q <- take o psi ] + + -- put the b register into superposition + bstate <- mapUnary hadamard bstate + + -- add the U-hat controlled on b + for 0 (b-1) 1 $ \k -> do + let nk = nfun k + unitary_hat_at gse_data nk tau e_max orth k psi (bstate !! k) + + -- apply inverse QFT + bstate <- (reverse_generic_endo qft_little_endian) bstate + + -- perform measurement + mk <- measure bstate + qdiscard psi + + comment_with_label "EXIT: gse" mk "mk" + return mk diff --git a/dist/build/Quipper/Algorithms/GSE/GSEData.hs b/dist/build/Quipper/Algorithms/GSE/GSEData.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/GSE/GSEData.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/GSE/GSEData.hs" #-} +-- | This module contains functions for reading the GSE one- and +-- two-electron integral data from a file, converting this data from +-- spatial to spin indices, and accessing the data. +-- +-- The external interface consists of the type 'GSEData' and the +-- function 'load_gse_data'. +-- +-- The Quipper distribution contains example data files +-- \"@h_1e_ascii@\" and \"@h_2e_ascii@\". These files contain enough +-- data for /M/ = 32 spin orbitals (corresponding to /M/\/2 = 16 +-- spatial orbitals). Note that the example data was randomly +-- generated and is only a mock-up. In actual applications, physically +-- meaningful data should be substituted. + +module Quipper.Algorithms.GSE.GSEData where + +import Data.Array +import Data.Bits +import Data.Char + +-- * Data abstraction + +-- | A data structure describing the GSE Data - the number +-- of integrals and the functions to access the data by index. +data GSEData = GSEData { + + -- | The number of spin orbitals /M/. + gse_data_M :: Int, + + -- | 1-electron integrals /h/[sub p,q] in spin coordinates. + gse_data_h1 :: (Int,Int) -> Double, + + -- | 2-electron integrals /h/[sub p,q,r,s] in spin coordinates. + -- Follows the physics convention for the ordering of indices. + gse_data_h2 :: (Int,Int,Int,Int) -> Double + + } + +instance Show (GSEData) where + show a = "GSEData { size = " ++ show (gse_data_M a) ++ " }" + +-- ---------------------------------------------------------------------- +-- * Reading GSE data from files + +-- $ This section provides function for reading one- and two-electron +-- GSE data from files. The file formats are as follows. The file for +-- the one-electron data consists of lines of the form: +-- +-- > ((i, j), h) +-- +-- where /i/ and /j/ are integer indices in the range from /0/ to +-- /M/−1, and /h/ = /h/[sub i,j] is a real floating point number. +-- Please note that the file contains data for (/i/, /j/) and +-- (/j/, /i/), and that the indices /i/ and /j/ are in /spatial/ +-- coordinates. The file data is sorted in order of increasing /i/, +-- then /j/. +-- +-- The file for the two-electron data consists of lines of the form: +-- +-- > ((i, j, k, l), h) +-- +-- where /i/, /j/, /k/, and /l/ are integer indices in the range from +-- /0/ to /M/−1, and /h/ = /h/[sub i,k,l,j] is a real floating point +-- number. Please note that the indices /i/, /j/, /k/, and /l/ are in +-- /spatial/ coordinates, and the ordering of indices in the file +-- follows the /chemists'/ convention. Also, to save storage space, +-- the file only contains data for /i/ ≥ /j/, /k/ ≥ /l/, and either +-- /i/ > /k/, or /i/ = /k/ and /j/ ≥ /l/. The remaining data must be +-- inferred from symmetries. The file data is sorted in order of +-- increasing /i/, then /j/, then /k/, then /l/. +-- +-- We also note that the data files, and the functions of this module +-- where noted, are the /only/ places where we use Chemists' notation +-- and spatial orbitals. The remainder of our implementation uses +-- physicists' notation and spin orbitals throughout. + +-- | Read the 'GSEData' from two files. The first argument is /M/, the +-- number of spin orbitals. The second and third argument are the +-- filenames for the one-electron and two-electron data, respectively. +-- +-- If the file contains data for more than /M/ spin orbitals, ignore +-- the excess data (this is useful for generating smaller problem +-- sizes for testing). In this case, only the necessary portion of the +-- file is read. If the file contains data for fewer than /M/ spin +-- orbitals, this is silently ignored, but will lead to an +-- \"undefined\" error later. +load_gse_data :: Int -> String -> String -> IO GSEData +load_gse_data size filename1 filename2 = do + content1 <- readFile filename1 + content2 <- readFile filename2 + let spatial_size = (size + 1) `div` 2 + let spacial_data1 = parsefile1 spatial_size content1 + let spacial_data2 = parsefile2 spatial_size content2 + return (GSEData { + gse_data_M = size, + gse_data_h1 = spin1 $ access_1e spacial_data1, + gse_data_h2 = spin2 $ access_2e spacial_data2 + }) + +-- ---------------------------------------------------------------------- +-- * Low-level access functions + +-- | Access 1-electron integral data. The indices are spatial, i.e., +-- they run from 0 to /M/\/2 − 1. +access_1e :: Array (Int, Int) e -> (Int, Int) -> e +access_1e arr tuple = arr ! tuple + +-- | Access 2-electron integral data. The input array is sparse (i.e., +-- contains only one representative of each equivalence class), and +-- uses chemists' conventions. The output uses physicists' +-- conventions. The indices in both input and output are spatial, +-- i.e., they run from 0 to /M/\/2 − 1. +access_2e :: Array (Int, Int, Int, Int) e -> (Int, Int, Int, Int) -> e +access_2e arr (i,k,l,j) = + -- The indices are not in correct order on purpose. We + -- need to express the fact that h_prsq = h[pq|rs] = h[p,q,r,s] = h[i,j,k,l] + arr ! (swap_ijkl $ swap_kl $ swap_ij (i,j,k,l)) + + -- Note that because of symmetries, we have + -- h2(i,j,k,l) = h2(j,i,k,l) + -- h2(i,j,k,l) = h2(i,j,l,k) + -- h2(i,j,k,l) = h2(k,l,i,j) + -- For this reason, and to save space, the file only contains one + -- representative of each equivalence class. + where + swap_ij (i,j,k,l) = if (i < j) then (j,i,k,l) else (i,j,k,l) + swap_kl (i,j,k,l) = if (k < l) then (i,j,l,k) else (i,j,k,l) + swap_ijkl (i,j,k,l) = if ((i < k) || ((i == k) && (j < l))) then (k,l,i,j) else (i,j,k,l) + +-- ---------------------------------------------------------------------- +-- * Low-level parsing functions + +-- | Decide whether a string is a comment. A comment is a line with +-- only whitespace characters, or where the first non-whitespace +-- character is \'\#\'. +is_comment :: String -> Bool +is_comment [] = True +is_comment ('#':t) = True +is_comment (h:t) + | isSpace h = is_comment t + | otherwise = False + +-- | Extract an array from the one-electron file data. We do this +-- lazily, i.e., we stop reading as soon as enough data is found. +-- The resulting array uses spatial indices. +parsefile1 :: Int -> String -> Array (Int, Int) Double +parsefile1 size content = + array ((0,0), (n, n)) list3 + where + n = size-1 + list1 = [ read_line_h1 s | s <- lines content, not (is_comment s) ] + list2 = takeWhile (\((i,j),h) -> i ((Int,Int), Double) + read_line_h1 s = case reads s of + [(x, "")] -> x + _ -> error ("Illegal line: " ++ s ++ " -- expected format ((int, int), double)") + +-- | Extract an array from the two-electron file data. We do this +-- lazily, i.e., we stop reading as soon as enough data is found. The +-- resulting array uses spatial indices in chemists' notation. Also, +-- the output array is sparse; it only contains as much data as the +-- file itself. +parsefile2 :: Int -> String -> Array (Int, Int, Int, Int) Double +parsefile2 size content = + array ((0,0,0,0), (n,n,n,n)) list3 + where + n = size-1 + list1 = [ read_line_h2 s | s <- lines content, not (is_comment s) ] + list2 = takeWhile (\((i,j,k,l),h) -> i ((Int,Int,Int,Int), Double) + read_line_h2 s = case reads s of + [(x, "")] -> x + _ -> error ("Illegal line: " ++ s ++ " -- expected format ((int, int, int, int), double)") + +-- ---------------------------------------------------------------------- +-- * Conversion of spin to spatial indices + +-- | In the molecule we have twice as many orbitals (spin orbitals) +-- than data in the integral file (spatial orbitals). This function +-- converts /h[sub 1]/ from spatial-orbitals (/M/\/2 = 104) to spin +-- orbitals (/M/ = 208). +-- +-- Spin orbitals are indexed by /p/=(/i/, σ/[sub i]/), where /i/ is a spatial +-- index and σ/[sub i]/ is a spin (up or down). For two spin indices +-- /p/=(/i/, σ/[sub i]/) and /q/=(/j/, σ/[sub j]/), the transition integral +-- h[sub pq] is given by the following formula: +-- +-- \[image spin1.png] +-- +-- The Hamiltonian vanishes for σ/[sub i]/ ≠ σ/[sub j]/ because we +-- assume that there is no spin orbital coupling. +-- +-- Given /M/\/2 spatial orbitals, we re-map the spin orbitals to +-- integers from 0 to /M/−1 using the formula /p/ = 2/i/+σ/[sub i]/, +-- where σ[sub i] is 0 or 1. +-- +-- The function 'spin1' inputs (/h[sub ij]/), the table of 1-electron +-- integrals for /M/\/2 spatial orbitals, and outputs the +-- corresponding table (/h[sub pq]/) for /M/ spin orbitals. + +spin1 :: ((Int,Int) -> Double) -> ((Int,Int) -> Double) +spin1 h1 (p,q) = + if sigma_i == sigma_j + then h1 (i,j) + else 0.0 + where + sigma_i = p .&. 1 + i = p `div` 2 + sigma_j = q .&. 1 + j = q `div` 2 + +-- | Like 'spin1', but for 2-electron integrals. Here, the transition +-- integrals in spin coordinates are given by: +-- +-- \[image spin2.png] +-- +-- The Hamiltonian vanishes for σ/[sub i]/ ≠ σ/[sub l]/ or σ/[sub j]/ +-- ≠ σ/[sub k]/ because we assume that there is no spin orbital +-- coupling. +-- +-- The function 'spin2' inputs (/h[sub ijkl]/), the table of +-- 2-electron transition amplitudes for /M/\/2 spatial orbitals, and +-- outputs the corresponding table (/h[sub pqrs]/) for /M/ spin +-- orbitals. Index ordering follows the physicists' convention. + +spin2 :: ((Int, Int, Int, Int) -> Double) -> ((Int, Int, Int, Int) -> Double) +spin2 h2 (p,q,r,s) = + if sigma_i == sigma_l && sigma_j == sigma_k + then h2 (i,j,k,l) + else 0.0 + where + sigma_i = p .&. 1 + i = p `div` 2 + sigma_j = q .&. 1 + j = q `div` 2 + sigma_k = r .&. 1 + k = r `div` 2 + sigma_l = s .&. 1 + l = s `div` 2 + +-- * Testing + +-- | Print the /h/[sub 1] data for 1-electron integrals. +print_1e :: GSEData -> String +print_1e gse_data = unlines $ [ inner_print i j | i <- list, j <- list] + where list = [0..m-1] + inner_print i j = show (i,j) ++ " : " ++ show (h1 (i, j)) + m = gse_data_M gse_data + h1 = gse_data_h1 gse_data + +-- | Print the /h/[sub 2] data for 2-electron integrals. +print_2e :: GSEData -> String +print_2e gse_data = unlines $ [ inner_print i j k l | i <- list, j <- list, k <- list, l <- list] + where list = [0..m-1] + inner_print i j k l = show (i,j,k,l) ++" : " ++ show (h2 (i, j, k, l)) + m = gse_data_M gse_data + h2 = gse_data_h2 gse_data + +-- | A main function to test the GSEData module. +gse_data_test :: Int -> IO () +gse_data_test n = do + gse_data <- load_gse_data n "h_1e_ascii" "h_2e_ascii" + putStr $ print_1e gse_data + putStr $ print_2e gse_data diff --git a/dist/build/Quipper/Algorithms/GSE/JordanWigner.hs b/dist/build/Quipper/Algorithms/GSE/JordanWigner.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/GSE/JordanWigner.hs @@ -0,0 +1,696 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/GSE/JordanWigner.hs" #-} +-- | This module provides the Jordan-Wigner transformation and +-- symbolic derivation of circuit templates for second quantized +-- interaction terms. It is essentially a fully automated version of +-- the calculations from +-- +-- * James D. Whitfield, Jacob Biamonte, and Alán +-- Aspuru-Guzik. \"Simulation of electronic structure Hamiltonians +-- using quantum computers.\" +-- /Molecular Physics/ 109(5):735–750, 2011. +-- See also . + + +module Quipper.Algorithms.GSE.JordanWigner where + +import Quipper + +import Quipper.Libraries.Decompose + +import Data.Complex +import qualified Data.Map as Map +import Data.Map (Map) + +import Quipper.Utils.Auxiliary (sequence_right_) + +import Text.Printf + +-- ---------------------------------------------------------------------- +-- * Overview + +-- $ For a given tuple of orbital indices, (/p/,/q/) in case of +-- one-electron interactions, or (/p/,/q/,/r/,/s/) in case of two-electron +-- interactions, we first calculate the Jordan-Wigner transformation +-- of the second quantized hermitian interaction terms +-- +-- /a/[sub /p/][sup †]/a/[sub /p/], +-- +-- /a/[sub /p/][sup †]/a/[sub /q/] + /a/[sub /q/][sup †]/a/[sub /p/], +-- +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /q/]/a/[sub /p/], +-- +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] + +-- /a/[sub /s/][sup †]/a/[sub /r/][sup †]/a/[sub /q/]/a/[sub /p/]. +-- +-- Next, we decompose each operator into a linear combination /H/ = +-- λ[sub 1]/M/[sub 1] + ... + λ[sub /n/]/M/[sub /n/] of mutually +-- commuting hermitian tensors. At this point, each summand /M/[sub /j/] +-- in the linear combination will be a tensor product of the following +-- operators (not necessarily in this order): +-- +-- * an even number (possibly zero) of Pauli /X/ operators; +-- +-- * an even number (possibly zero) of Pauli /Y/ operators; +-- +-- * zero or more Pauli /Z/ operators, and +-- +-- * zero or more /D/ operators, where /D/ = σ[sup −]σ[sup +] = (/I/−/Z/)\/2. +-- +-- Note that there may be zero terms in the summation; this happens, +-- for example, for +-- /a/[sub /p/][sup †]/a/[sub /p/][sup †]/a/[sub /r/]/a/[sub /s/], +-- because two electrons cannot occupy the same spin orbital due to +-- their fermionic nature. In this case, /H/ = 0 and [exp -/i/θ/H/] = /I/. +-- +-- Next, we calculate [exp -/i/θ/H/]. Because the summands /M/[sub /j/] +-- commute, we can exponentiate each summand separately, using the formula +-- [exp -/i/θ/H/] = [exp -/i/θλ[sub 1]/M/[sub 1]]⋯[exp -/i/θλ[sub /n/]/M/[sub /n/]]. +-- +-- We then generate the circuit for [exp -/i/θλ[sub /j/]/M/[sub /j/]] +-- by applying a sequence of basis changes until the problem is +-- reduced to a controlled rotation. The basis changes are, in this +-- order: +-- +-- 1. Change each Pauli /X/ operator in /M/[sub /j/] to a Pauli /Z/ +-- operator, and apply a Hadamard basis change to the corresponding +-- qubit. This uses the relation /HXH/ = /Z/. +-- +-- 2. Change each Pauli /Y/ operator in /M/[sub /j/] to a Pauli /Z/ +-- operator, and apply a [bold Y] basis change to the corresponding +-- qubit. Note: the [bold Y] basis change operator is defined in +-- [Whitfield et al.] as /R/[sub /x/](-π\/2) = (/I/+/iX/)\/√2, or +-- equivalently [bold Y] = /SHS/, and satisfies [bold Y][super †]/Y/[bold Y] = +-- /Z/. It should not be confused with the Pauli /Y/ operator. +-- +-- 3. If the operator /M/[sub /j/] contains one or more Pauli /Z/ operators +-- (including those obtained in steps 1 and 2), then do a basis change +-- by a cascade of controlled-not gates to reduce this to a single /Z/ +-- operator. This uses the relation /CNot/ (/Z/⊗/Z/) /CNot/ = /I/⊗/Z/. +-- +-- After these basis changes, the operator /M/[sub /j/] consists of +-- exactly zero or one Pauli /Z/ operator, together with zero or more +-- /D/ operators. To see how to translate this into a controlled +-- rotation, note that for any operator /A/, we have +-- +-- \[image expDA.png] +-- +-- Therefore, each /D/ operator in /M/[sub /j/] turns into a control +-- after exponentiation. The final rotation is then computed by +-- distinguishing two cases: +-- +-- * If /M/[sub /j/] contains a Pauli /Z/ operator, then use the +-- relation [exp -/i/θ/Z/] = /R/[sub /z/](2θ). In this case, the circuit +-- for [exp -/i/θ/M/[sub /j/]] is a controlled /R/[sub /z/](2θ) gate in +-- the position of the /Z/ operator, with zero or more controls in the +-- positions of any /D/ operators. +-- +-- * If /M/[sub /j/] does not contain a Pauli /Z/ operator, then the +-- operation to be performed is a phase change [exp -/i/θ], controlled +-- by the qubits in the positions of the /D/ operators. Note that +-- there must be at least one /D/ operator in this case. Also note +-- that a controlled [exp -/i/θ] gate is identical to a /T/(θ) gate. + +-- ---------------------------------------------------------------------- +-- * Correctness of the templates + +-- $ As outlined above, the functions in this module generate each +-- circuit from first principles, based on the Jordan-Wigner +-- representation of operators and on algebraic transformations. They +-- do not rely on pre-fabricated circuit templates. +-- +-- Based on the automated calculations provided by this module, we +-- have found small typos in the 5 templates provided by [Whitfield +-- et al.] (Table 3, or Table A1 in the arXiv version). +-- +-- * The template for the number-excitation operator is missing a +-- control on its rotation gate. +-- +-- * In the template for the Coulomb operator, the angles are wrong. +-- Moreover, this program finds a simpler template. +-- +-- * In the template for the double excitation operator, the angles +-- are wrong; they should be ±θ\/4 instead of θ. +-- +-- The corrected templates generated by our code are as follows: +-- +-- * Number operator /h/[sub /pp/] /a/[sub /p/][sup †]/a/[sub /p/]. +-- +-- > [image b0-template.png] +-- +-- * Excitation operator /h/[sub /pq/] /a/[sub /p/][sup †]/a/[sub /q/]. +-- +-- > [image b1-template.png] +-- +-- * Coulomb and exchange operators /h/[sub /pqqp/] +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /q/]/a/[sub /p/]. +-- +-- > [image b2-template.png] +-- +-- * Number-excitation operator /h/[sub /pqqr/] +-- (/a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /q/]/a/[sub /r/] + +-- /a/[sub /r/][sup †]/a/[sub /q/][sup †]/a/[sub /q/]/a/[sub /p/]). +-- The sign of ±θ depends on the relative ordering of the indices /p,q,r/. +-- +-- > [image b3-template.png] +-- +-- * Double excitation operator +-- /h/[sub /pqrs/] +-- (/a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] + +-- /a/[sub /s/][sup †]/a/[sub /r/][sup †]/a/[sub /q/]/a/[sub /p/]). +-- The sign of ±θ\/4 in each of the eight terms depends on the relative ordering of the indices /p,q,r,s/. +-- +-- > [image b4-template.png] + +-- ---------------------------------------------------------------------- +-- * Alternate Coulomb templates + +-- $ As noted above, our algorithm found the following template for the +-- Coulomb operator +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /q/]/a/[sub /p/]: +-- +-- > [image b2-template.png] +-- +-- This is simpler than the template given in [Whitfield et al.], even +-- after one accounts for the cost of decomposing the additional +-- controlled /T/(θ) gate into elementary gates. However, an +-- equivalent circuit can also be given that is more similar to the +-- one in [Whitfield et al.] (but with corrected rotation angles): +-- +-- > [image b2-orthodox.png] +-- +-- We call this the \"orthodox\" template, because it is closer to the +-- one specified by Whitfield et al. The program will use the orthodox +-- template if the command line option @--orthodox@ is given, and it +-- will use the simplified template otherwise. + +-- ---------------------------------------------------------------------- +-- * General-purpose auxiliary functions + +-- | Construct a list consisting of /n/ repetitions of some element. +power :: Int -> a -> [a] +power n x = take n $ repeat x + +-- | Extract a list of /n/-1 consecutive pairs from an /n/-element list: +-- +-- > consecutive_pairs [] = [] +-- > consecutive_pairs [1] = [] +-- > consecutive_pairs [1,2] = [(1,2)] +-- > consecutive_pairs [1,2,3] = [(1,2),(2,3)] +-- > consecutive_pairs [1,2,3,4] = [(1,2),(2,3),(3,4)] +consecutive_pairs :: [a] -> [(a,a)] +consecutive_pairs [] = [] +consecutive_pairs [h] = [] +consecutive_pairs (h1:h2:t) = (h1,h2) : consecutive_pairs (h2:t) + +-- ---------------------------------------------------------------------- +-- * Scalars + +-- | The type of complex numbers. Here, we use a floating point +-- representation, although a symbolic representation would also be +-- possible. Since for the purpose of this algorithm, all denominators +-- are powers of 2, the floating point representation is in fact exact. +type Scalar = Complex Double + +-- | The complex number /i/. +i :: Scalar +i = 0 :+ 1 + +-- ---------------------------------------------------------------------- +-- * Basic Gates + +-- | Apply a /R/[sub z](θ)=[exp -/i/θ/Z/\/2] gate. The parameter θ is a +-- Bloch sphere angle. +-- +-- \[image Rz.png] +rotZ_at :: Double -> Qubit -> Circ () +rotZ_at theta q = named_rotation_at "Rz(%)" theta q + +-- | Apply a /G/(θ) gate. This is a global phase change of [exp -/i/θ], +-- so this gate only \"does\" something when it is controlled. +-- Although it is logically a 0-ary gate, we give it a qubit argument +-- to specify where the gate can be drawn in circuit diagrams. +-- +-- \[image G.png] +gse_G_at :: Double -> Qubit -> Circ () +gse_G_at theta q = named_rotation_at "G(%)" theta q + +-- | Apply a /T/(θ) gate. This is a /Z/-rotation, but differs +-- from /R/[sub z](-θ) by a global phase. +-- +-- \[image T.png] +gse_T_at :: Double -> Qubit -> Circ () +gse_T_at theta q = named_rotation_at "T(%)" theta q + +-- | Apply a [bold Y] basis change gate. This is defined as [bold Y] = /SHS/, +-- or equivalently, +-- +-- \[image Y.png] +-- +-- This should not be confused with the Pauli /Y/ gate. +gse_Y_at :: Qubit -> Circ () +gse_Y_at q = named_gate_at "YY" q + +-- ---------------------------------------------------------------------- +-- * Basic operators + +-- | This type provides a symbolic representation of certain +-- operators, generated by the Pauli operators, /P/ = σ[sup +], and +-- /M/ = σ[sup −]. For lack of a better term, we call these the +-- \"basic\" operators. Note that apart from /P/ and /M/, all of these +-- are hermitian. +data Op = + I -- ^ Identity operator. + | X -- ^ Pauli /X/ operator. + | Y -- ^ Pauli /Y/ operator. + | Z -- ^ Pauli /Z/ operator. + | P -- ^ σ[sup +] operator = (0,1;0,0). + | M -- ^ σ[sup −] operator = (0,0;1,0). + | A -- ^ σ[sup +]σ[sup −] operator = (1,0;0,0). + | D -- ^ σ[sup −]σ[sup +] operator = (0,0;0,1). + deriving (Show, Eq, Ord) + +-- | A type to represent scalar multiples. An element of ('Scaled' +-- /a/) is a pair (λ, /x/) of a complex scalar λ and an element /x/ ∈ +-- /a/. +data Scaled a = Scaled Scalar a + +-- | Multiplication of basic operators. Note that the product of two +-- basic operators is not usually itself a basic operator, but a +-- scalar multiple thereof. This multiplication encodes the algebraic +-- laws of basic operators in symbolic form. + +-- Implementation note: the multiplication laws are currently +-- implemented as a long case distinction. Perhaps it could be done +-- more cleverly. +mult :: Op -> Op -> Scaled Op + +-- The Pauli group +mult I x = Scaled 1 x +mult x I = Scaled 1 x + +mult X X = Scaled 1 I +mult X Y = Scaled i Z +mult X Z = Scaled (-i) Y + +mult Y X = Scaled (-i) Z +mult Y Y = Scaled 1 I +mult Y Z = Scaled i X + +mult Z X = Scaled i Y +mult Z Y = Scaled (-i) X +mult Z Z = Scaled 1 I + +-- P, M, D, and A +mult X P = Scaled 1 D +mult X M = Scaled 1 A +mult X A = Scaled 1 M +mult X D = Scaled 1 P + +mult Y P = Scaled i D +mult Y M = Scaled (-i) A +mult Y A = Scaled i M +mult Y D = Scaled (-i) P + +mult Z P = Scaled 1 P +mult Z M = Scaled (-1) M +mult Z A = Scaled 1 A +mult Z D = Scaled (-1) D + +mult P X = Scaled 1 A +mult M X = Scaled 1 D +mult A X = Scaled 1 P +mult D X = Scaled 1 A + +mult P Y = Scaled i A +mult M Y = Scaled (-i) D +mult A Y = Scaled (-i) P +mult D Y = Scaled i M + +mult P Z = Scaled (-1) P +mult M Z = Scaled 1 M +mult A Z = Scaled 1 A +mult D Z = Scaled (-1) D + +mult P P = Scaled 0 I +mult P M = Scaled 1 A +mult P A = Scaled 0 I +mult P D = Scaled 1 P + +mult M P = Scaled 1 D +mult M M = Scaled 0 I +mult M A = Scaled 1 M +mult M D = Scaled 0 I + +mult A P = Scaled 1 P +mult A M = Scaled 0 I +mult A A = Scaled 1 A +mult A D = Scaled 0 I + +mult D P = Scaled 0 I +mult D M = Scaled 1 M +mult D A = Scaled 0 I +mult D D = Scaled 1 D + +-- ---------------------------------------------------------------------- +-- * Tensors of basic operators + +-- | We use a list of basic operators to represent a tensor +-- product. The convention is that infinitely many identity operators +-- are implicitly appended at the end of the list. +type Tensor = [Op] + +-- | Normalize a tensor, by stripping away trailing identities. +normalize_tensor :: Tensor -> Tensor +normalize_tensor [] = [] +normalize_tensor (h:t) = + if h == I && null n + then [] + else (h:n) + where n = normalize_tensor t + +-- | The identity tensor. +tensor_id :: Tensor +tensor_id = [] + +-- | Multiply two tensors. This returns a scaled tensor. +mult_tensor :: Tensor -> Tensor -> Scaled Tensor +mult_tensor [] bs = Scaled 1 bs +mult_tensor as [] = Scaled 1 as +mult_tensor (a:as) (b:bs) = Scaled (x*y) (c:cs) where + Scaled x c = mult a b + Scaled y cs = mult_tensor as bs + +-- | Multiply two scaled tensors. +mult_scaled_tensor :: Scaled Tensor -> Scaled Tensor -> Scaled Tensor +mult_scaled_tensor (Scaled x a) (Scaled y b) = Scaled (x*y*z) c where + Scaled z c = a `mult_tensor` b + +-- ---------------------------------------------------------------------- +-- * Linear combinations of tensors + +-- | A type to represent complex linear combinations of tensors. +type TensorLC = Map Tensor Scalar + +-- | The origin. +lc_zero :: TensorLC +lc_zero = Map.empty + +-- | Add a tensor to a linear combination. +lc_insert :: TensorLC -> Scaled Tensor -> TensorLC +lc_insert lc (Scaled lambda t) = + if newvalue == 0 + then + Map.delete m lc + else + Map.insert m newvalue lc + where + m = normalize_tensor t + newvalue = case Map.lookup m lc of + Nothing -> lambda + Just x -> lambda + x + +-- | Turn a list of scaled tensors into a 'TensorLC'. +lc_from_list :: [Scaled Tensor] -> TensorLC +lc_from_list = foldl lc_insert lc_zero + +-- | Turn a 'TensorLC' into a list of scaled tensors. +lc_to_list :: TensorLC -> [Scaled Tensor] +lc_to_list lc = [Scaled x y | (y,x) <- Map.toList lc] + +-- ---------------------------------------------------------------------- +-- * Jordan-Wigner representation + +-- $ The next two functions provide the Jordan-Wigner representation of +-- (Fock-space) annihilation and creation operators. + +-- | Construct the Jordan-Wigner annihilation operator /a/[sub /p/] = +-- /IIIIPZZZZZ.../ for spin-orbital index /p/. The first parameter is +-- /p/, and the second one is /M/ (the number of spin-orbitals). +-- Precondition: 0 ≤ /p/ < /M/. +jw :: Int -> Int -> Scaled Tensor +jw p m = Scaled 1 (power p I ++ [P] ++ power (m-p-1) Z) + +-- | Construct the Jordan-Wigner creation operator /a/[sub /p/][sup †] +-- = /IIIIMZZZZ.../ for spin-orbital index /p/. The first parameter +-- is /p/, and the second one is /M/ (the number of spin-orbitals). +-- Precondition: 0 ≤ /p/ < /M/. +jw_dagger :: Int -> Int -> Scaled Tensor +jw_dagger p m = Scaled 1 (power p I ++ [M] ++ power (m-p-1) Z) + +-- ---------------------------------------------------------------------- +-- * Second quantized interaction terms + +-- ** Simple interaction terms + +-- | Construct the one-electron second quantized non-hermitianized +-- interaction term /a/[sub /p/][sup †]/a/[sub /q/]. The parameters +-- are /p,q/. +one_electron_operator_simple :: Int -> Int -> Scaled Tensor +one_electron_operator_simple p q = ap * aq + where + ap = jw_dagger p m + aq = jw q m + m = maximum [p,q] + 1 + (*) = mult_scaled_tensor + +-- | Construct the two-electron second quantized non-hermitianized +-- interaction term +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/]. +-- The parameters are /p,q,r,s/. +two_electron_operator_simple :: Int -> Int -> Int -> Int -> Scaled Tensor +two_electron_operator_simple p q r s = ap * aq * ar * as + where + ap = jw_dagger p m + aq = jw_dagger q m + ar = jw r m + as = jw s m + m = maximum [p,q,r,s] + 1 + (*) = mult_scaled_tensor + +-- ** Hermitian interaction terms + +-- | Construct +-- /a/[sub /p/][sup †]/a/[sub /q/] +-- if /p/ = /q/, and +-- /a/[sub /p/][sup †]/a/[sub /q/] + /a/[sub /q/][sup †]/a/[sub /p/] +-- otherwise. +one_electron_operator :: Int -> Int -> TensorLC +one_electron_operator p q = + if p == q + then lc_from_list [a_pq] + else lc_from_list [a_pq, a_qp] + where + a_pq = one_electron_operator_simple p q + a_qp = one_electron_operator_simple q p + +-- | Construct +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] +-- if (/p/,/q/) = (/s/,/r/), and +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] + +-- /a/[sub /s/][sup †]/a/[sub /r/][sup †]/a/[sub /q/]/a/[sub /p/] +-- otherwise. +two_electron_operator :: Int -> Int -> Int -> Int -> TensorLC +two_electron_operator p q r s = + if (p,q) == (s,r) + then lc_from_list [a_pqrs] + else lc_from_list [a_pqrs, a_srqp] + where + a_pqrs = two_electron_operator_simple p q r s + a_srqp = two_electron_operator_simple s r q p + +-- ---------------------------------------------------------------------- +-- * /XYZD/ decomposition + +-- | Decompose a basic operator into linear combinations of hermitian basic operators. +-- This uses the relations /P/ = 1\/2 /X/ + /i/\/2 /Y/ and +-- /M/ = 1\/2 /X/ - /i/\/2 /Y/. +decompose_basis :: Op -> [Scaled Op] +decompose_basis P = [Scaled (1/2) X, Scaled (i/2) Y] +decompose_basis M = [Scaled (1/2) X, Scaled (-i/2) Y] +decompose_basis x = [Scaled 1 x] -- default case: the remaining operators are already hermitian + +-- | Decompose a tensor into a linear combination of hermitian +-- tensors. Due to sign alternation, the individual tensors all come +-- out to commute with each other. +decompose_tensor :: Tensor -> TensorLC +decompose_tensor [] = lc_from_list [Scaled 1 tensor_id] +decompose_tensor (h:t) = + lc_from_list [Scaled (x*y) (g:gs) | + Scaled x g <- decompose_basis h, + Scaled y gs <- lc_to_list (decompose_tensor t)] + +-- | Decompose a linear combination of tensors into a linear +-- combination of hermitian tensors. +decompose_tensor_lc :: TensorLC -> TensorLC +decompose_tensor_lc lc = + lc_from_list [ Scaled (x*y) g | + Scaled x gs <- lc_to_list lc, + Scaled y g <- lc_to_list (decompose_tensor gs)] + +-- ---------------------------------------------------------------------- +-- * Exponentiation and circuit generation + +-- | Given a simple hermitian tensor /H/ and an angle θ, generate a +-- circuit for [exp -/i/θ/H/]. The given list of input qubits is in +-- the same order as the operators in /H/. Precondition: /H/ is made +-- up of zero or more identity operators and one or more of the +-- operators /X/, /Y/, /Z/, and /D/. The last parameter is a list of +-- additional controls. + +exponentiate_simple :: Scaled Tensor -> Double -> [Qubit] -> [Qubit] -> Circ () +exponentiate_simple (Scaled s ms) theta qs ctl = do + -- First analyze the tensor: + let + -- Find all X positions + xs = [ i | (m, i) <- zip ms [0,1..], m == X ] + -- Find all Y positions + ys = [ i | (m, i) <- zip ms [0,1..], m == Y ] + -- Find all X, Y, Z positions + zs = [ i | (m, i) <- zip ms [0,1..], m `elem` [X, Y, Z] ] + -- Find all D positions + ds = [ i | (m, i) <- zip ms [0,1..], m == D ] + basischange xs ys zs qs + rotation alpha ds zs `controlled` ctl + reverse_generic_imp (basischange xs ys zs) qs + where + alpha = theta * realPart s + basischange :: [Int] -> [Int] -> [Int] -> [Qubit] -> Circ () + basischange xs ys zs qs = do + -- for every X or Y in the operator, apply the appropriate basis + -- change to change it to Z. + sequence_ [ hadamard_at (qs !! i) | i <- xs ] + sequence_ [ gse_Y_at (qs !! i) | i <- ys ] + -- apply a cascade of c-not operators to all X, Y, or Z in the + -- operator + sequence_right_ [ qnot_at (qs !! i0) `controlled` (qs !! i1) | (i0,i1) <- consecutive_pairs zs] + rotation :: Timestep -> [Int] -> [Int] -> Circ () + rotation alpha ds zs = do + case zs of + [] -> -- if there are no Z operators, produce a controlled + -- e^{-iα} gate. + case ds of + [] -> error "exponentiate_simple: precondition violated" + d:ds' -> gse_T_at alpha (qs !! d) `controlled` [qs !! d' | d' <- ds'] + z:zs' -> -- if there are Z operators, produce a controlled + -- e^{-iαZ} gate. + rotZ_at (2*alpha) (qs !! z) `controlled` [qs !! d | d <- ds] + +-- | Given a tensor /H/ (already decomposed into commuting simple +-- tensors) and an angle θ, generate a circuit for [exp -/i/θ/H/]. +-- The given list of input qubits is in the same order as the +-- operators in /H/. +exponentiate :: TensorLC -> Double -> [Qubit] -> [Qubit] -> Circ () +exponentiate lc theta qs ctl = + sequence_ [ exponentiate_simple a theta qs ctl | a <- lc_to_list lc ] + +-- ---------------------------------------------------------------------- +-- * Generate top-level templates + +-- | @'one_electron_circuit' theta p q@: Generate the circuit for the +-- hermitianized one-electron interaction with spin-orbital indices +-- /p/, /q/. More precisely, generate [exp -/i/θ/H/], where +-- /H/ = /a/[sub /p/][sup †]/a/[sub /q/] if /p/ = /q/ and +-- /H/ = /a/[sub /p/][sup †]/a/[sub /q/] +-- + /a/[sub /q/][sup †]/a/[sub /p/] otherwise. +-- +-- This function recognizes an important special case: if θ=0.0, don't +-- generate any gates at all. The case θ=0.0 frequently arises because +-- of the conversion from spatial orbitals to spin orbitals. +one_electron_circuit :: Double -> Int -> Int -> [Qubit] -> [Qubit] -> Circ () +one_electron_circuit 0.0 p q qs ctl = return () +one_electron_circuit theta p q qs ctl = do + comment_with_label (printf "ENTER: one_electron_circuit (theta=%.3e, p=%d, q=%d)" theta p q) (qs,ctl) ("qs","ctl") + exponentiate op theta qs ctl + comment_with_label "EXIT: one_electron_circuit" (qs,ctl) ("qs","ctl") + where + op = decompose_tensor_lc (one_electron_operator p q) + +-- | @'two_electron_circuit' theta p q r s@: +-- Generate the circuit for the hermitianized two-electron interaction +-- with spin-orbital indices /p/, /q/, /r/, /s/. More precisely, generate +-- [exp -/i/θ/H/], where +-- /H/ = /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] if +-- (/p/,/q/) = (/s/,/r/) and /H/ = +-- /a/[sub /p/][sup †]/a/[sub /q/][sup †]/a/[sub /r/]/a/[sub /s/] + +-- /a/[sub /s/][sup †]/a/[sub /r/][sup †]/a/[sub /q/]/a/[sub /p/] +-- otherwise. +-- +-- This function recognizes an important special case: if θ=0.0, don't +-- generate any gates at all. The case θ=0.0 frequently arises because +-- of the conversion from spatial orbitals to spin orbitals. +two_electron_circuit :: Double -> Int -> Int -> Int -> Int -> [Qubit] -> [Qubit] -> Circ () +two_electron_circuit 0.0 p q r s qs ctl = return () +two_electron_circuit theta p q r s qs ctl = do + comment_with_label (printf "ENTER: two_electron_circuit (theta=%.3e, p=%d, q=%d, r=%d, s=%d)" theta p q r s) (qs,ctl) ("qs","ctl") + exponentiate op theta qs ctl + comment_with_label "EXIT: two_electron_circuit" (qs,ctl) ("qs","ctl") + where + op = decompose_tensor_lc (two_electron_operator p q r s) + +-- | Like 'two_electron_circuit', but use the \"orthodox\" circuit +-- template for the Coulomb operator /a/[sub /p/][sup †]/a/[sub +-- /q/][sup †]/a/[sub /q/]/a/[sub /p/]. This generates a circuit using +-- three rotations, similar to [Whitfield et al.], but with corrected +-- angles, +-- +-- > [image b2-orthodox.png] +-- +-- instead of the simpler circuit that 'two_electron_circuit' would +-- normally generate: +-- +-- > [image b2-template.png] + +two_electron_circuit_orthodox :: Double -> Int -> Int -> Int -> Int -> [Qubit] -> [Qubit] -> Circ () +two_electron_circuit_orthodox 0.0 p q r s qs ctl = return () +two_electron_circuit_orthodox theta p q r s qs ctl | q==r && p==s && p/=q = do + comment_with_label (printf "ENTER: two_electron_circuit_orthodox(theta=%.3e, p=%d, q=%d, r=%d, s=%d)" theta p q r s) (qs,ctl) ("qs","ctl") + let pp = qs !! p + qq = qs !! q + gse_G_at (theta/4) pp `controlled` ctl + rotZ_at (-theta/2) pp `controlled` ctl + rotZ_at (-theta/2) qq `controlled` ctl + qnot_at qq `controlled` pp -- control ctl is not needed + rotZ_at (theta/2) qq `controlled` ctl + qnot_at qq `controlled` pp -- control ctl is not needed + comment_with_label "EXIT: two_electron_circuit_orthodox" (qs,ctl) ("qs","ctl") + +-- all other cases aren't Coulomb operators, so fall back to +-- two_electron_circuit. +two_electron_circuit_orthodox theta p q r s qs ctl = do + two_electron_circuit theta p q r s qs ctl + +-- ---------------------------------------------------------------------- +-- * Testing + +-- $ We provide two functions, accessible via command line options, +-- that allow the user to display individual templates. + +-- | Display the circuit for the hermitianized one-electron interaction, +-- with θ=1. +show_one_electron :: Format -> GateBase -> Int -> Int -> IO () +show_one_electron format gatebase p q = + print_generic format (decompose_generic gatebase circuit) (replicate (n-m) qubit) where + circuit qs = one_electron_circuit 1.0 (p-m) (q-m) qs [] + n = maximum [p,q] + 1 + m = minimum [p,q] + +-- | Display the circuit for the hermitianized two-electron interaction, +-- with θ=1. +show_two_electron :: Format -> GateBase -> Int -> Int -> Int -> Int -> IO () +show_two_electron format gatebase p q r s = + print_generic format (decompose_generic gatebase circuit) (replicate (n-m) qubit) where + circuit qs = two_electron_circuit 1.0 (p-m) (q-m) (r-m) (s-m) qs [] + n = maximum [p,q,r,s] + 1 + m = minimum [p,q,r,s] + +-- | Like 'show_two_electron', but use the \"orthodox\" template for +-- the Coulomb operator. +show_two_electron_orthodox :: Format -> GateBase -> Int -> Int -> Int -> Int -> IO () +show_two_electron_orthodox format gatebase p q r s = + print_generic format (decompose_generic gatebase circuit) (replicate (n-m) qubit) where + circuit qs = two_electron_circuit_orthodox 1.0 (p-m) (q-m) (r-m) (s-m) qs [] + n = maximum [p,q,r,s] + 1 + m = minimum [p,q,r,s] diff --git a/dist/build/Quipper/Algorithms/GSE/Main.hs b/dist/build/Quipper/Algorithms/GSE/Main.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/GSE/Main.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/GSE/Main.hs" #-} +-- | +-- Authors: Alexander S. Green, Artur Scherer, Peter Selinger, +-- Alexandr Virodov +-- +-- An implementation of the Ground State Estimation algorithm. The +-- purpose of this algorithm is to determine the ground state energy +-- of a quantum molecular system. The algorithm depends on a table of +-- one- and two-electron transition integrals, which must be +-- separately pre-computed and supplied in a pair of data files. From +-- this integral data, the molecular electronic Hamiltonian is derived +-- using the Jordan-Wigner transformation. To simulate this +-- Hamiltonian by a quantum circuit, it is first broken into small +-- time steps using Trotterization. The second quantized local +-- Hamiltonian interaction terms can be divided into a small number of +-- cases (number operators, excitation operators, Coulomb and exchange +-- operators, number-excitation operators, and double excitation +-- operators). Each interaction term is synthesized into a piece of +-- quantum circuit following one of a small number of patterns (called +-- \"circuit templates\"). Finally, the quantum phase estimation +-- algorithm is applied to the resulting circuit to obtain the ground +-- state energy. +-- +-- The algorithm is described in: +-- +-- * James D. Whitfield, Jacob Biamonte, and Alán +-- Aspuru-Guzik. \"Simulation of electronic structure Hamiltonians +-- using quantum computers.\" +-- /Molecular Physics/ 109(5):735–750, 2011. +-- See also . +-- +-- The present implementation is based on a detailed algorithm +-- specification that was provided to us by the IARPA QCS program and +-- written by Anargyros Papageorgiou, James Whitfield, Joseph Traub, +-- and Alán Aspuru-Guzik. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.GSE.Main": Command line interface. +-- +-- * "Quipper.Algorithms.GSE.JordanWigner": The Jordan-Wigner transformation +-- and automated symbolic derivation of circuit templates for second +-- quantized interaction terms. +-- +-- * "Quipper.Algorithms.GSE.GSE": The main circuit for the GSE Algorithm. +-- +-- * "Quipper.Algorithms.GSE.GSEData": Functions for reading the one- and +-- two-electron integral data from a pair of data files. + +module Quipper.Algorithms.GSE.Main where + +import Quipper + +import Quipper.Libraries.Decompose + +import Quipper.Algorithms.GSE.GSE +import Quipper.Algorithms.GSE.GSEData +import Quipper.Algorithms.GSE.JordanWigner +import Quipper.Utils.CommandLine + +-- import other stuff +import System.Console.GetOpt +import System.Environment +import System.Exit +import Control.Monad +import Data.Bits +import qualified System.FilePath as FilePath + +-- ---------------------------------------------------------------------- +-- * Documentation + +-- $ This module provides a command line interface for the Ground +-- State Estimation algorithm. This allows the user to set a number of +-- parameters, such as /b/ (the number of precision qubits), /M/ (the +-- number of spin orbitals), /N/ (the number of occupied spin orbitals +-- in the prepared approximate ground state), and /E/[sub min] and +-- /E/[sub max] (the energy range). Command line options are also +-- provided to specify the filenames for the Hamiltonian integral +-- data, and to specify the output format and gate base. + +-- ---------------------------------------------------------------------- +-- * Option processing + +-- | An enumeration type for determining what the main function should do. +data WhatToShow = + Circuit -- ^Show the whole circuit (default). + | Template [Int] -- ^Show a particular template. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + what :: WhatToShow, -- ^What kind of thing to output. + format :: Format, -- ^The output format. + gatebase :: GateBase, -- ^What kind of gates to decompose into. + gse_orthodox :: Bool, -- ^Use the Coulomb operator of Whitman et al. + + gse_b :: Int, -- ^The number of precision qubits /b/. + gse_m :: Int, -- ^The number of basis functions /M/. + gse_occupied :: Int, -- ^The number of occupied orbitals. + gse_delta_e :: Double, -- ^Energy range Δ/E/ = /E/[sub max] - /E/[sub min]. + gse_e_max :: Double, -- ^Energy range /E/[sub max]. + gse_nfun :: Int -> Int, -- ^The function /k/ ↦ /N/[sub /k/]. + + gse_h1_file :: String, -- ^Filename for one-electron data. + gse_h2_file :: String, -- ^Filename for two-electron data. + gse_datadir :: String -- ^Directory for data files. + } + +-- | The default options. +defaultOptions :: Options +defaultOptions = Options { + what = Circuit, + format = Preview, + gatebase = Logical, + gse_orthodox = False, + + gse_b = 3, + gse_m = 4, + gse_occupied = 2, + gse_delta_e = 6.5536, + gse_e_max = -3876.941, + gse_nfun = (\k -> 1), -- by default, we skip the repetition + + gse_h1_file = "h_1e_ascii", + gse_h2_file = "h_2e_ascii", + gse_datadir = "." + } + +-- | Show the default value of an option. +showDefault :: (Show a) => (Options -> a) -> String +showDefault func = show (func defaultOptions) + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = [ + Option ['h'] ["help"] (NoArg help) $ "print usage info and exit", + Option ['C'] ["circuit"] (NoArg (what Circuit)) $ "output the whole circuit (default)", + Option ['T'] ["template"] (ReqArg read_template "") $ "output a particular circuit template", + Option ['f'] ["format"] (ReqArg read_format "") $ "output format for circuits (default: " ++ showDefault format ++ ")", + Option ['g'] ["gatebase"] (ReqArg read_gatebase "") $ "gates to decompose into (default: " ++ showDefault gatebase ++ ")", + Option ['m'] ["orbitals"] (ReqArg read_m "") $ "number of orbitals (default: " ++ showDefault gse_m ++ ")", + Option ['o'] ["occupied"] (ReqArg read_occupied "") $ "number of occupied orbitals (default: " ++ showDefault gse_occupied ++ ")", + Option ['b'] ["precision"] (ReqArg read_b "") $ "number of precision qubits (default: " ++ showDefault gse_b ++ ")", + Option ['D'] ["delta_e"] (ReqArg read_delta_e "") $ "energy range (default: " ++ showDefault gse_delta_e ++ ")", + Option ['E'] ["e_max"] (ReqArg read_e_max "") $ "maximum energy (default: " ++ showDefault gse_e_max ++ ")", + Option [] ["n0"] (ReqArg read_n0 "") $ "use N_k = n0 * 2^k (default: N_k = 1)", + Option ['l'] ["large"] (NoArg large_parameters) $ "set large problem size (m=208, o=84, b=12, n0=100)", + Option ['x'] ["orthodox"] (NoArg orthodox) $ "use the Coulomb operator of Whitman et al.", + Option [] ["h1"] (ReqArg read_h1 "") $ "filename for one-electron data (default: " ++ showDefault gse_h1_file ++ ")", + Option [] ["h2"] (ReqArg read_h2 "") $ "filename for two-electron data (default: " ++ showDefault gse_h2_file ++ ")", + Option ['d'] ["datadir"] (ReqArg read_datadir "") $ "directory for one- and two-electron data (default: current)" + ] + where + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + + large_parameters o = + return o { + gse_b = 12, + gse_m = 208, + gse_delta_e = 6.5536, + gse_e_max = -3876.941, + gse_occupied = 84, + gse_nfun = (\k -> 100 * (1 `shift` k)) + } + + orthodox o = return o {gse_orthodox = True } + + read_format :: String -> Options -> IO Options + read_format str o = do + case match_enum format_enum str of + [(_, f)] -> return o { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + read_gatebase :: String -> Options -> IO Options + read_gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + read_b :: String -> Options -> IO Options + read_b string o = + case parse_int string of + Just n | n > 0 -> return o { gse_b = n } + _ -> optfail ("Invalid b (precision) -- " ++ string ++ "\n") + + read_m :: String -> Options -> IO Options + read_m string o = + case parse_int string of + Just n | n > 0 -> return o { gse_m = n } + _ -> optfail ("Invalid m (orbitals) -- " ++ string ++ "\n") + + read_n0 :: String -> Options -> IO Options + read_n0 string o = + case parse_int string of + Just n | n > 0 -> return o { gse_nfun = (\k -> n * (1 `shift` k)) } + _ -> optfail ("Invalid n0 -- " ++ string ++ "\n") + + read_occupied :: String -> Options -> IO Options + read_occupied string o = + case parse_int string of + Just n | n > 0 -> return o { gse_occupied = n } + _ -> optfail ("Invalid o (occupied) -- " ++ string ++ "\n") + + read_delta_e :: String -> Options -> IO Options + read_delta_e string o = + case parse_double string of + Just n | n >= 0 -> return o { gse_delta_e = n } + _ -> optfail ("Invalid Delta E -- " ++ string ++ "\n") + + read_e_max :: String -> Options -> IO Options + read_e_max string o = + case parse_double string of + Just n | n >= 0 -> return o { gse_e_max = n } + _ -> optfail ("Invalid E_max -- " ++ string ++ "\n") + + read_h1 :: String -> Options -> IO Options + read_h1 string o = return o { gse_h1_file = string } + + read_h2 :: String -> Options -> IO Options + read_h2 string o = return o { gse_h2_file = string } + + read_datadir :: String -> Options -> IO Options + read_datadir string o = return o { gse_datadir = string } + + read_template :: String -> Options -> IO Options + read_template string o = do + ps <- sequence [ convert p | p <- split ',' string ] + let len = length ps + if len == 2 || len == 4 then + return o { what = Template ps } + else + optfail ("Must give 2 or 4 indices, not " ++ (show len) ++ "\n") + where + split c as = case break (== c) as of + (h,_:t) -> h : (split c t) + (h,[]) -> [h] + convert p = case parse_int p of + Just n | n >= 0 -> return n + _ -> optfail ("Invalid index -- '" ++ p ++ "'\n") + + help :: Options -> IO Options + help o = do + usage + exitSuccess + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to standard output. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + putStr ("Indices can be specified as p,q or p,q,r,s (with no spaces)\n") + where header = "Usage: gse [OPTION...]" + +-- ---------------------------------------------------------------------- +-- * The GSE main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO() +main = do + -- Read options. + argv <- getArgs + options <- dopts argv + + case what options of + Circuit -> main_circuit options + Template qs -> main_template options qs + +-- | Main function for outputting the GSE circuit. +main_circuit :: Options -> IO() +main_circuit options = do + + -- Read parameters. + let b = gse_b options + m = gse_m options + o = gse_occupied options + dE = gse_delta_e options + e_max = gse_e_max options + datadir = gse_datadir options + file1 = gse_h1_file options + file2 = gse_h2_file options + nfun = gse_nfun options + orth = gse_orthodox options + + -- Calculate derived parameters. + let tau = 2*pi / dE + + path1 = FilePath.combine datadir file1 + path2 = FilePath.combine datadir file2 + + -- Load data from file. + gse_data <- load_gse_data m path1 path2 + + -- Generate the main circuit. + let circuit = gse b m o gse_data tau e_max nfun orth + + -- Print it. + print_simple (format options) (decompose_generic (gatebase options) circuit) + + -- Of course, if we had a quantum computer, we would run it instead. + {- + ms <- run_simple circuit + let e0 = e_max - dE * (int_from_bitlist mk) / (2**b) + return e0 + -} + +-- | Main function for outputting a particular template. +main_template :: Options -> [Int] -> IO() +main_template options [p,q] = do + show_one_electron (format options) (gatebase options) p q + +main_template options [p,q,r,s] = do + if gse_orthodox options + then show_two_electron_orthodox (format options) (gatebase options) p q r s + else show_two_electron (format options) (gatebase options) p q r s + +main_template options qs = + error "main_template: wrong number of indices given" + diff --git a/dist/build/Quipper/Algorithms/QLS/CircLiftingImport.hs b/dist/build/Quipper/Algorithms/QLS/CircLiftingImport.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/QLS/CircLiftingImport.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/QLS/CircLiftingImport.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +-- | This module contains definitions to work with Template Haskell. All +-- the definitions in this module are used by Template Haskell in +-- "Quipper.Algorithms.QLS.TemplateOracle" and "Quipper.Algorithms.QLS.RealFunc". +module Quipper.Algorithms.QLS.CircLiftingImport where + +import Data.Typeable + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Arith +import Quipper.Libraries.Decompose + +import Quipper.Algorithms.QLS.QDouble +import Quipper.Algorithms.QLS.QSignedInt +import Quipper.Algorithms.QLS.Utils + +-- * Utility function + +-- | @'grepn' /regexp/ /list/@: Counts how many times /regexp/ is a +-- sublist of /list/. +grepn :: (Eq a) => [a] -> [a] -> Int +grepn regexp l = + if (length regexp > length l) then 0 + else if ((take (length regexp) l) == regexp) then 1 + (grepn regexp $ tail l) + else grepn regexp $ tail l + + + + +-- * Lifting of ordering operators. + + +-- | Template version of '/='. +template_symb_slash_symb_equal_ :: (Typeable qa, QOrd qa) => Circ (qa -> Circ (qa -> Circ Qubit)) +template_symb_slash_symb_equal_ = return $ \x -> return $ \y -> do + (_,_,r) <- box "/=" (decompose_generic Toffoli $ uncurry q_is_not_equal) (x,y) + return r + +-- | Template version of '<'. +template_symb_oangle_ :: (Typeable qa, QOrd qa) => Circ (qa -> Circ (qa -> Circ Qubit)) +template_symb_oangle_ = return $ \x -> return $ \y -> box "<" (uncurry q_less) (x,y) + +-- | Template version of '<='. +template_symb_oangle_symb_equal_ :: (Typeable qa, QOrd qa) => Circ (qa -> Circ (qa -> Circ Qubit)) +template_symb_oangle_symb_equal_ = return $ \x -> return $ \y -> box "<=" (uncurry q_leq) (x,y) + +-- | Template version of '>'. +template_symb_cangle_ :: (Typeable qa, QOrd qa) => Circ (qa -> Circ (qa -> Circ Qubit)) +template_symb_cangle_ = return $ \x -> return $ \y -> box ">" (uncurry q_greater) (x,y) + +-- | Template version of '>='. +template_symb_cangle_symb_equal_ :: (Typeable qa, QOrd qa) => Circ (qa -> Circ (qa -> Circ Qubit)) +template_symb_cangle_symb_equal_ = return $ \x -> return $ \y -> box ">=" (uncurry q_geq) (x,y) + + + + +-- * Lifting of arithmetic operators + +-- | Template version of '-'. +template_symb_minus_ :: (Typeable qa, QNum qa) => Circ (qa -> Circ (qa -> Circ qa)) +template_symb_minus_ = return $ \qx -> return $ \qy -> do (qx,qy,qz) <- box "-" (uncurry q_sub) (qx,qy); return qz + +-- | Template version of '+'. +template_symb_plus_ :: (Typeable qa, QNum qa) => Circ (qa -> Circ (qa -> Circ qa)) +template_symb_plus_ = return $ \qx -> return $ \qy -> do (qx,qy,qz) <- box "+" (uncurry q_add) (qx,qy); return qz + +-- | Template version of '*'. +template_symb_star_ :: (Typeable qa, QNum qa) => Circ (qa -> Circ (qa -> Circ qa)) +template_symb_star_ = return $ \qx -> return $ \qy -> do (qx,qy,qz) <- box "*" (uncurry q_mult) (qx,qy); return qz + +-- | Template version of 'negate'. +template_negate :: (Typeable qa, QNum qa) => Circ (qa -> Circ qa) +template_negate = return $ \qx -> do (_,qz) <- box "neg" q_negate qx; return qz + +-- | Template version of 'abs'. +template_abs :: (Typeable qa, QNum qa) => Circ (qa -> Circ qa) +template_abs = return $ \x -> do + (_,r) <- box "abs" q_abs x + return r + +-- | Template version of 'mod' +template_mod :: Circ (QSignedInt -> Circ (QSignedInt -> Circ QSignedInt)) +template_mod = return $ \x -> return $ \y -> box "mod" (decompose_generic Toffoli $ uncurry q_mod) (x,y) + + +-- * Operations on 'QDouble' + +-- | Template version of '/' on 'Fractional'. +template_symb_slash_:: Circ (QDouble -> Circ (QDouble -> Circ QDouble)) +template_symb_slash_ = return $ \x -> return $ \y -> box "/" (decompose_generic Toffoli $ uncurry q_div_real) (x,y) + +-- | The constant 'pi' as an 'FDouble'. +local_pi :: FDouble +local_pi = fdouble pi + +-- | Template version of 'local_pi'. +template_local_pi :: Circ QDouble +template_local_pi = qinit (fdouble pi) + +-- | The identity function of type 'FDouble'. This is used to help the +-- type checker work around a problem in GHC 8.0, where types of +-- overloaded operations sometimes require disambiguation. +id_fdouble :: FDouble -> FDouble +id_fdouble x = x + +-- | Template version of 'id_fdouble'. +template_id_fdouble :: Circ (QDouble -> Circ QDouble) +template_id_fdouble = return $ \x -> return x + +-- * Relation between 'QDouble' and 'QSignedInt'. + +-- | Template version of 'floor'. +template_floor :: Circ (QDouble -> Circ QSignedInt) +template_floor = return $ \(XDouble k (SInt x b)) -> + return $ SInt (reverse . drop k . reverse $ x) b + +-- | Template version of 'ceiling'. +template_ceiling :: Circ (QDouble -> Circ QSignedInt) +template_ceiling = return $ \x -> q_ceiling x + +-- | Template version of 'fromIntegral'. +template_fromIntegral :: Circ (QSignedInt -> Circ QDouble) +template_fromIntegral = return $ \x -> q_fromIntegral x + + + +-- * Dealing with parameters. + + +-- | Lift a real number to 'QDouble'. +template_rational :: Double -> Circ QDouble +template_rational x = qinit $ fdouble x + +-- | Lift an integer to 'QSignedInt'. +template_integer :: Int -> Circ QSignedInt +template_integer x = qinit $ fromIntegral x + + +-- | Make a parameter 'Int' as a regular 'Int' that can be lifted. +getIntFromParam :: Int -> Int +getIntFromParam x = fromIntegral x + +-- | Template version of 'getIntFromParam'. +template_getIntFromParam :: Circ (Int -> Circ QSignedInt) +template_getIntFromParam = return $ \x -> qinit $ fromIntegral x + +-- | Parameter integer of value '0'. +paramZero :: Int +paramZero = 0 + +-- | Template version of 'paramZero'. +template_paramZero :: Circ Int +template_paramZero = return 0 + +-- | Parameter integer of value '10'. +paramTen :: Int +paramTen = 10 + +-- | Template version of 'paramTen'. +template_paramTen :: Circ Int +template_paramTen = return paramTen + +-- | Successor function acting on parameter 'Int'. +paramSucc :: Int -> Int +paramSucc x = x+1 + +-- | Template version of 'paramSucc'. +template_paramSucc :: Circ (Int -> Circ Int) +template_paramSucc = return $ \x -> return (x+1) + +-- | Predecessor function acting on parameter 'Int'. +paramPred :: Int -> Int +paramPred x = x - 1 + +-- | Template version of 'paramPred'. +template_paramPred :: Circ (Int -> Circ Int) +template_paramPred = return $ \x -> return (x-1) + + + +-- | Subtraction of parameter integers. +paramMinus :: Int -> Int -> Int +paramMinus x y = x - y + +-- | Template version of 'paramMinus'. +template_paramMinus :: Circ (Int -> Circ (Int -> Circ Int)) +template_paramMinus = return $ \x -> return $ \y -> return (x-y) + + + +-- * Miscellaneous operations. + +-- | Lifted version of @'length'@. +template_length :: Circ ([a] -> Circ QSignedInt) +template_length = return $ \l -> qinit $ fromIntegral $ length l + +-- | Return the first half of the input list. +take_half :: [a] -> [a] +take_half l = take (1 + (length l) `div` 2) l + +-- | Lifted version of @'take_half'@. +template_take_half :: Circ ([a] -> Circ [a]) +template_take_half = return $ \l -> return $ take_half l + diff --git a/dist/build/Quipper/Algorithms/QLS/Main.hs b/dist/build/Quipper/Algorithms/QLS/Main.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/QLS/Main.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/QLS/Main.hs" #-} +-- | +-- Authors: Artur Scherer, Siun-Chuon Mau, Benoît Valiron +-- +-- An implementation of the quantum linear system algorithm. The +-- algorithm finds the solution to a sparse system of linear equations +-- /Ax/=/b/, with a scaling exponentially better than the best known +-- classical algorithms. Here, /A/ is an /N/ × /N/ sparse matrix, /b/ +-- an /N/ × 1 vector of known values, and /x/ is the solution. +-- +-- Huge sparse linear systems are common in applied sciences and +-- engineering, such as those resulting from solving partial +-- differential equations by means of Finite Element Method (FEM). +-- +-- The example analyzed in this program is the scattering of +-- electromagnetic waves off a 2D metallic region, where the FEM +-- allows to convert Maxwell’s equations into a sparse linear system. +-- +-- The QLS algorithm is based on two main techniques: +-- +-- * Quantum Phase Estimation, which uses the Quantum Fourier +-- Transform and Hamiltonian Simulation, which makes frequent queries +-- to the oracle for matrix /A/; +-- +-- * Quantum Amplitude Estimation, based on Grover’s search technique. +-- +-- +-- The algorithm is described in: +-- +-- * Aram W. Harrow, Avinatan Hassidim, Seth Lloyd. Quantum algorithm +-- for solving linear systems of equations. /Phys. Rev. Lett./ vol. 15, +-- no. 103, pp. 150502 (2009). +-- +-- * B. D. Clader, B. C. Jacobs, C. R. Sprouse. Quantum algorithm to +-- calculate electromagnetic scattering cross +-- sections. . +-- +-- The present implementation is based on detailed algorithm and +-- oracle specifications that were provided to us by the IARPA QCS +-- program and written by B. David Clader and Bryan C. Jacobs. +-- +-- +-- Modules: +-- +-- * "Quipper.Algorithms.QLS.Main": Command line interface. +-- +-- * "Quipper.Algorithms.QLS.QSignedInt": An implementation of signed +-- integers. +-- +-- * "Quipper.Algorithms.QLS.QSignedIntAux": Helper module. +-- +-- * "Quipper.Algorithms.QLS.QDouble": An implementation of real numbers, +-- using fixed-point notation. +-- +-- * "Quipper.Algorithms.QLS.RealFunc": Implementation of various analytic +-- functions, for use with the automated circuit generation tool. +-- +-- * "Quipper.Algorithms.QLS.Utils": Helper module. +-- +-- * "Quipper.Algorithms.QLS.QLS": The implementation of the main algorithm. +-- +-- * "Quipper.Algorithms.QLS.CircLiftingImport": Helper module. +-- +-- * "Quipper.Algorithms.QLS.TemplateOracle": Implementation of the oracle, +-- in regular Haskell, together with the \"build_circuit\" keyword to +-- allow automated circuit generation. + +module Quipper.Algorithms.QLS.Main where + +import Quipper + +import Quipper.Libraries.Arith +import Quipper.Libraries.Decompose +import Quipper.Libraries.Unboxing + +import qualified Quipper.Algorithms.QLS.QLS as QLS +import Quipper.Algorithms.QLS.Utils +import Quipper.Algorithms.QLS.QDouble as QDouble +import Quipper.Algorithms.QLS.RealFunc as QReal +import Quipper.Algorithms.QLS.QSignedInt as QSInt +import Quipper.Algorithms.QLS.TemplateOracle + +import Quipper.Utils.CommandLine + +-- import other stuff +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Control.Monad +import Data.List +import Data.Char +import Data.Ratio as Ratio + +-- ---------------------------------------------------------------------- +-- * Command line interface + +-- $ This module provides a command line interface for the Quantum +-- Linear System algorithm. This allows the user, for example, to plug +-- in different oracles, select a gate base, control boxing of +-- subcircuits, and select different output formats. + +-- ---------------------------------------------------------------------- +-- * Option processing + +-- | An enumeration type for determining what the main function should do. +data WhatToShow = + Circuit -- ^Show the whole circuit. + | Oracle -- ^Show only an oracle. + deriving Show + +-- | An enumeration type for selecting an oracle implementation. +data OracleSelect = + Matlab -- ^The oracle, implemented with Template Haskell. + | Blackbox -- ^A blackbox oracle. + deriving Show + +-- | An enumeration type for selecting an oracle to print. +data WhichOracle = + OracleR -- ^Oracle r. + | OracleB -- ^Oracle b. + | OracleA Int Bool -- ^Oracle A, with selected band and boolean parameter. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + what :: WhatToShow, -- ^What kind of thing to output. + format :: Format, -- ^The output format. + gatebase :: GateBase, -- ^What kind of gates to decompose into. + oracle :: OracleSelect, -- ^Which oracle implementation to use. + whichoracle :: WhichOracle, -- ^Which oracle to output. + param :: QLS.RunTimeParam, -- ^Run time parameters. + peel :: Int -- ^number of layers of subroutines to peel away. +} deriving Show + +-- | The default options. +defaultOptions :: Options +defaultOptions = Options + { what = Circuit, + format = GateCount, + gatebase = Logical, + oracle = Blackbox, + whichoracle = OracleR, + param = QLS.dummy_RT_param, + peel = 0 + } + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = + [ Option ['h'] ["help"] (NoArg help) "print usage info and exit", + Option ['C'] ["circuit"] (NoArg (what Circuit)) "output the whole circuit (default)", + Option ['O'] ["oracle"] (ReqArg whichoracle "") "output only the oracle (default: r) ", + Option ['f'] ["format"] (ReqArg format "") "output format for circuits (default: gatecount)", + Option ['g'] ["gatebase"] (ReqArg gatebase "") "type of gates to decompose into (default: logical)", + Option ['o'] [] (ReqArg oracle "") "select oracle implementation to use (default: blackbox)", + Option ['p'] ["param"] (ReqArg param "") "choose a set of parameters (default: dummy).", + Option ['P'] ["peel"] (ReqArg peel "") "peel layers of boxed subroutines (default: 0)." + ] + where + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + + peel :: String -> Options -> IO Options + peel string o = case (parse_int string) of + Just i -> return o { peel = i } + Nothing -> optfail ("peel requires a argument number.") + + param :: String -> Options -> IO Options + param string o = + case string of + "large" -> return o { param = QLS.large_RT_param } + "dummy" -> return o { param = QLS.dummy_RT_param } + "small" -> return o { param = QLS.small_RT_param } + _ -> let (p,v) = break ((==) '=') string in + case p of + _ -> optfail ("Parameter not implemented -- " ++ string ++ "\n") + + whichoracle :: String -> Options -> IO Options + whichoracle string o = + case (toLower $ head string) of + 'r' -> return o { whichoracle = OracleR, what = Oracle } + 'b' -> return o { whichoracle = OracleB, what = Oracle } + 'a' -> let b = parse_int [string !! 1] in + let a = toLower (string !! 2) in + case (b,a) of + (Just i, 't') -> return o { whichoracle = OracleA i True, what = Oracle } + (Just i, 'f') -> return o { whichoracle = OracleA i False, what = Oracle } + _ -> error ("Band " ++ (show (string !! 1)) ++ " or boolean " ++ (show a) ++ " not valid.") + _ -> error ("Oracle " ++ (show (string !! 0)) ++ " not valid.") + + + format :: String -> Options -> IO Options + format str o = do + case match_enum format_enum str of + [(_, GateCount)] -> return o { format = GateCount } + [(_, ASCII)] -> return o { format = ASCII } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + gatebase :: String -> Options -> IO Options + gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + oracle :: String -> Options -> IO Options + oracle str o = do + case match_enum oracle_enum str of + [(_, f)] -> return o { oracle = f } + [] -> optfail ("Unknown oracle -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous oracle -- " ++ str ++ "\n") + + help :: Options -> IO Options + help o = do + usage + exitSuccess + +-- | An enumeration of available oracles and their names. +oracle_enum :: [(String, OracleSelect)] +oracle_enum = [ + ("matlab", Matlab), + ("blackbox", Blackbox) + ] + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to 'stdout'. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" [("ascii", ASCII),("gatecount",GateCount)]) + putStr (show_enum "gatebase" gatebase_enum) + putStr (show_enum "oracle implementation" oracle_enum) + putStrLn "Possible values for param are: dummy, small, large." + putStrLn "Possible values for oracle are: r, b, A[band][t|f]. E.g. \"-OA1t\" asks for band 1 with boolean argument True. For all three oracles, the factors are set up to 1.0." + where header = "Usage: qls [OPTION...]" + + +-- ---------------------------------------------------------------------- +-- * The QLS main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO() +main = do + argv <- getArgs + options <- dopts argv + case options of + Options { what = Circuit, format = format, gatebase = gatebase, oracle = oracle, param = param, peel = peel} -> + let o = case oracle of {Blackbox -> QLS.dummy_oracle; Matlab -> QLS.inline_oracle} in + print_simple format $ decompose_generic gatebase $ ncompose peel unbox $ do QLS.qlsa_FEM_main param o; return () + Options { what = Oracle, format = format, gatebase = gatebase, param = param, whichoracle = whichoracle, peel = peel } -> + let n2_blist = replicate (QLS.n2 param) qubit in + let n4_blist = replicate (QLS.n4 param) qubit in + let (oracle, list_of_inputs) = + case whichoracle of + OracleR -> (QLS.inline_oracle_r param 1.0 1.0, (n2_blist, n4_blist, n4_blist)) + OracleB -> (QLS.inline_oracle_b param 1.0 1.0, (n2_blist, n4_blist, n4_blist)) + OracleA i b -> (QLS.inline_oracle_A param 1.0 i b, (n2_blist, n2_blist, n4_blist)) + in do + print_generic format (decompose_generic gatebase $ ncompose peel unbox $ oracle) list_of_inputs + diff --git a/dist/build/Quipper/Algorithms/QLS/QDouble.hs b/dist/build/Quipper/Algorithms/QLS/QDouble.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/QLS/QDouble.hs @@ -0,0 +1,562 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/QLS/QDouble.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This modules implements a library for fixed-points real numbers. +module Quipper.Algorithms.QLS.QDouble where + +import qualified Data.Ratio as Ratio + +import Data.Typeable + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Arith +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.QLS.Utils +import Quipper.Algorithms.QLS.QSignedInt + +import Quipper.Utils.Auxiliary (getId, mmap) + +-- * Signed fixed point type + +-- | Data type for fixed point arithmetic. +-- +-- 'XDouble' /k/ /n/ represents the number /n/⋅2[sup -/k/], where /n/ +-- is a signed integer and /k/ is an integer parameter. +-- +-- We refer to /k/ as the /exponent/ of the fixed point number. When +-- we speak of the /length/, we mean the total number of digits +-- (excluding the sign), i.e., the length, in binary digits, of the +-- underlying /n/. +data XDouble x = XDouble Int (SignedInt x) + deriving (Show, Typeable) + +-- | The parameter type of fixed-point numbers. +type FDouble = XDouble Bool + +-- | The quantum type of fixed-point numbers. +type QDouble = XDouble Qubit + +-- | The classical type of fixed-point numbers. +type CDouble = XDouble Bit + +-- ---------------------------------------------------------------------- +-- * Auxiliary definitions + +-- | Compute the power of an integer by a non-negative integer. +integer_power :: Int -> Int -> Integer +integer_power x y = (fromIntegral x) ^ y + +-- | Compute the power of an integer by another, possibly negative one. +double_power :: Int -> Int -> Double +double_power x y + | y >= 0 = (fromIntegral x) ^ y + | otherwise = 1 / ((fromIntegral x) ^ (-y)) + +-- | Divide one integer by another, and round the result to the closest +-- integer. If the result is half way between two integers, round to +-- the even one (this is the same behavior as Haskell's 'round' +-- function). This function has unlimited precision. +div_round :: Integer -> Integer -> Integer +div_round x y = round (x Ratio.% y) + +-- ---------------------------------------------------------------------- +-- * Operation for length and exponent + +-- ---------------------------------------------------------------------- +-- ** Generic functions for XDouble + +-- | Return the exponent /k/ of an 'XDouble'. +xdouble_exponent :: XDouble x -> Int +xdouble_exponent (XDouble k _) = k + +-- | Return the length /m/ of an 'XDouble'. +xdouble_length :: XDouble x -> Int +xdouble_length (XDouble _ n) = sint_length n + +-- | Return the \"extent\" of an 'XDouble'. The extent of a fixed-point +-- number /x/ is, by definition, the pair (/hi/,/lo/) of integers such +-- that the most significant bit of /x/ has positional index /hi/-1 +-- (in other words, the value of this bit is 2[sup /hi/-1]), and the +-- least significant bit of /x/ has positional index /lo/ (in other +-- words, the value of this bit is 2[sup /lo/]. Typically, but not +-- necessarily, /hi/ ≥ 0 and /lo/ ≤ 0. In this case, one can also +-- think of /hi/ as \"the number of digits before the radix point\" +-- and −/lo/ as \"the number of digits after the radix point\". +-- +-- The exponent /k/, length /m/, and extent (/hi/,/lo/) are related by +-- /k/=-/lo/ and /m/=/hi/−/lo/. +-- +-- Examples: +-- +-- * a number represented in the form /xxxx.yyy/ has extent (4,-3), +-- exponent 3, and length 7. +-- +-- * a number represented in the form /xxxx000./ has extent (7,3), +-- exponent -3, and length 4. +-- +-- * a number represented in the form /.000xxxx/ has extent (-3,-7), +-- exponent 7, and length 4. +-- +-- If we regard extents as intervals, ordered by inclusion, then it is +-- always possible to losslessly cast a fixed-point number from a +-- smaller to a larger extent. +xdouble_extent :: XDouble x -> (Int, Int) +xdouble_extent x = (m-k, -k) where + m = xdouble_length x + k = xdouble_exponent x + +-- | Add /n/ zeros to the high bits of the 'XDouble'. This sends +-- /xxx.yyy/ to 000/xxx.yyy/. This increases the length without changing +-- the exponent or value. +xdouble_pad_left :: (Monad m) => m x -> Int -> XDouble x -> m (XDouble x) +xdouble_pad_left zero n (XDouble k (SInt digits s)) = do + pad <- sequence $ replicate n zero + let digits' = pad ++ digits + return $ XDouble k (SInt (digits') s) + +-- | Add /n/ zeros to the low bits of the 'XDouble'. This sends +-- /xxx.yyy/ to /xxx.yyy000/. This increases the length and the +-- exponent without changing the value. +xdouble_pad_right :: (Monad m) => m x -> Int -> XDouble x -> m (XDouble x) +xdouble_pad_right zero n (XDouble k (SInt digits s)) = do + pad <- sequence $ replicate n zero + let digits' = digits ++ pad + return $ XDouble (k+n) (SInt (digits') s) + +-- | Pad an 'XDouble' on both sides to reach the desired extent. This +-- increases the length and exponent without changing the value (it is +-- a lossless operation). It is an error to call this function if the +-- selected extent does not contain the extent of the input 'XDouble'. +xdouble_pad_to_extent :: (Monad m) => m x -> (Int, Int) -> XDouble x -> m (XDouble x) +xdouble_pad_to_extent zero (hi, lo) x + | lo <= lo_x && hi_x <= hi + = xdouble_pad_left zero (hi - hi_x) =<< xdouble_pad_right zero (lo_x - lo) x + | otherwise + = error "qdouble_pad_to_extent: bad extent" + where + (hi_x, lo_x) = xdouble_extent x + +-- | Remove the /n/ low bits of an 'XDouble'. This sends /xxx.yyyzzz/ +-- to /xxx.yyy/. It is an error to call this function when the +-- 'XDouble' has fewer than /n/ digits. +xdouble_truncate_right :: Int -> QDouble -> QDouble +xdouble_truncate_right n (XDouble k (SInt digits s)) = (XDouble k' (SInt digits' s)) + where + k' = k - n + digits' | length digits >= n = reverse $ drop n $ reverse digits + | otherwise = error "xdouble_truncate_right" + +-- | Convert a 'SignedInt' to an 'XDouble' with exponent 0. +xdouble_of_sint :: SignedInt x -> XDouble x +xdouble_of_sint n = XDouble 0 n + +-- ---------------------------------------------------------------------- +-- ** Special cases for QDouble + +-- | Add /n/ zeros to the high bits of the 'QDouble'. This sends +-- /xxx.yyy/ to 000/xxx.yyy/. This increases the length without +-- changing the exponent or value. This function does not return a +-- fresh copy; it reuses part of its input. +qdouble_pad_left :: Int -> QDouble -> Circ QDouble +qdouble_pad_left = xdouble_pad_left (qinit False) + +-- | Add /n/ zeros to the low bits of the 'QDouble'. This sends +-- /xxx.yyy/ to /xxx.yyy000/. This increases the length and the +-- exponent without changing the value. This function does not return +-- a fresh copy; it reuses part of its input. +qdouble_pad_right :: Int -> QDouble -> Circ QDouble +qdouble_pad_right = xdouble_pad_right (qinit False) + +-- | Pad a 'QDouble' on both sides to reach the desired extent. This +-- increases the length and exponent without changing the value (it is +-- a lossless operation). It is an error to call this function if the +-- selected extent does not contain the extent of the input +-- 'QDouble'. This function does not return a fresh copy; it reuses +-- part of its input. +qdouble_pad_to_extent :: (Int, Int) -> QDouble -> Circ QDouble +qdouble_pad_to_extent = xdouble_pad_to_extent (qinit False) + +-- | Remove the /n/ low bits of a 'QDouble'. This sends /xxx.yyyzzz/ +-- to /xxx.yyy/. Note that the /n/ low qubits are not terminated and +-- become garbage. It is an error to call this function when the +-- 'QDouble' has fewer than /n/ digits. +qdouble_truncate_right :: Int -> QDouble -> QDouble +qdouble_truncate_right = xdouble_truncate_right + +-- ---------------------------------------------------------------------- +-- ** Special cases for FDouble + +-- | Add /n/ zeros to the low bits of the 'FDouble'. This sends +-- /xxx.yyy/ to /xxx.yyy000/. This increases the length and the +-- exponent without changing the value. +fdouble_pad_right :: Int -> FDouble -> FDouble +fdouble_pad_right k x = getId $ xdouble_pad_right (return False) k x + +-- | Pad a 'FDouble' on both sides to reach the desired extent. This +-- increases the length and exponent without changing the value (it is +-- a lossless operation). It is an error to call this function if the +-- selected extent does not contain the extent of the input 'FDouble'. +fdouble_pad_to_extent :: (Int, Int) -> FDouble -> FDouble +fdouble_pad_to_extent extent x = getId $ xdouble_pad_to_extent (return False) extent x + +-- ---------------------------------------------------------------------- +-- * Operations for FDouble + +-- ---------------------------------------------------------------------- +-- ** Casts + +-- | @'fdouble_of_double' /k/ /m/ /x/@: Convert /x/ to an 'FDouble' of +-- exponent /k/ and length /m/ ≥ 0. Note that the exponent does not +-- need to be between 0 and /m/; it can even be negative. +fdouble_of_double :: Int -> Int -> Double -> FDouble +fdouble_of_double k m x + | abs n >= integer_power 2 m + = error "fdouble_of_double: number too large" + | otherwise + = XDouble k (fsint_of_integer m n) + where + d = double_power 2 k + n = round (d * x) + +-- | Convert an 'FDouble' to a 'Double'. +double_of_fdouble :: FDouble -> Double +double_of_fdouble (XDouble k n) = (fromIntegral x) / (double_power 2 k) + where + x = integer_of_fsint n + +-- | Convert an 'FSignedInt' to an 'FDouble' with exponent 0. +fdouble_of_fsint :: FSignedInt -> FDouble +fdouble_of_fsint = xdouble_of_sint + +-- | Make an 'FDouble' value of exponent /k/, length /m/, and value /a/2[sup /-k/]. +fdouble_of_integer :: Int -> Int -> Integer -> FDouble +fdouble_of_integer k m a = XDouble k (fsint_of_integer m a) + +-- | Construct a 'Double' from an 'FDouble', using some arbitrary +-- method to guess the length and exponent. +fdouble :: Double -> FDouble +fdouble x = fromRational $ toRational x + +-- | Convert an 'FDouble' to a string in human-readable form. +show_fdouble :: FDouble -> String +show_fdouble x@(XDouble k (SInt digits s)) = sign ++ binary ++ " (" ++ (show float) ++ ")" + where + float = double_of_fdouble x + sign = if s then "-" else "+" + m = length digits + binary_full = [ if h then '1' else '0' | h <- digits ] + binary | k < 0 = binary_full ++ "e" ++ show (-k) + | k > m = "." ++ binary_full ++ "e" ++ show (m-k) + | otherwise = binary1 ++ "." ++ binary2 + (binary1,binary2) = splitAt ((fromIntegral m) - k) binary_full + +-- ---------------------------------------------------------------------- +-- ** Type class instances + +-- $ We make 'FDouble' an instance of 'Eq', 'Ord', 'Real', 'Num', +-- 'Fractional', and 'RealFrac'. See the source code for details. + +-- Note: none of the arithmetic operations pass via the native +-- 'Double' type, and therefore they are not subject to arbitrary +-- precision limits. However, most operations set the precision of the +-- result to the maximum precision of the inputs. + + +-- | Express a pair of 'FDouble' values as a pair of 'FSignedInt's with a +-- common exponent. +fdouble_align :: FDouble -> FDouble -> (Int, FSignedInt, FSignedInt) +fdouble_align (XDouble h m) (XDouble k n) + | h <= k = (k, fsint_shift (k-h) m, n) + | otherwise = (h, m, fsint_shift (h-k) n) + +instance Eq FDouble where + x == y = m == n where (k,m,n) = fdouble_align x y + +instance Ord FDouble where + compare x y = compare m n where (k,m,n) = fdouble_align x y + +instance Real FDouble where + toRational (XDouble h n) + | h >= 0 = (Ratio.%) nx (integer_power 2 h) + | otherwise = fromInteger (nx * integer_power 2 (-h)) + where + nx = integer_of_fsint n + +instance Num FDouble where + -- Additive operations set the exponent to the maximum of the two + -- exponents, and extend the length if necessary. Signum keeps the + -- length but resets the exponent to 0. + x + y = XDouble k (m + n) where (k,m,n) = fdouble_align x y + x - y = XDouble k (m - n) where (k,m,n) = fdouble_align x y + abs x = XDouble k (abs m) where XDouble k m = x + signum x = fdouble_of_fsint (signum m) where XDouble k m = x + + -- fromInteger uses the fixed exponent 'after_radix_length'. + fromInteger = fdouble_pad_right after_radix_length . fdouble_of_fsint . fromInteger + + -- Multiplication sets the extent to the maximum of the two extents. + x * y | k >= 0 = fdouble_of_integer k len (a*b `div_round` integer_power 2 k) + | otherwise = fdouble_of_integer k len (a*b * integer_power 2 (-k)) + where + (k,m,n) = fdouble_align x y + a = integer_of_fsint m + b = integer_of_fsint n + len = max (sint_length m) (sint_length n) + +instance Fractional FDouble where + -- Division sets the extent to the maximum of the two extents. + x / y | k >= 0 = fdouble_of_integer k len ((a * integer_power 2 k) `div_round` b) + | otherwise = fdouble_of_integer k len (a `div_round` (b * integer_power 2 (-k))) + where + (k,m,n) = fdouble_align x y + a = integer_of_fsint m + b = integer_of_fsint n + len = max (sint_length m) (sint_length n) + + fromRational x = fdouble_of_double before_radix_length (before_radix_length+after_radix_length) ((fromInteger $ Ratio.numerator x) / (fromInteger $ Ratio.denominator x)) + +instance RealFrac FDouble where + properFraction x + | k <= 0 = (0, x) + | otherwise = (fromInteger q, fdouble_of_integer k len r) + where + XDouble k m = x + a = integer_of_fsint m + len = sint_length m + (q, r) = a `quotRem` integer_power 2 k + +-- ---------------------------------------------------------------------- +-- Operations for QDouble + +-- ---------------------------------------------------------------------- +-- QCData instance + +type instance QCType x y (XDouble z) = XDouble (QCType x y z) +type instance QTypeB FDouble = QDouble + +instance QCLeaf x => QCData (XDouble x) where + qcdata_mapM ~(XDouble _ shape) f g (XDouble n xs) = + mmap (XDouble n) $ qcdata_mapM shape f g xs + qcdata_zip ~(XDouble _ shape) q c q' c' (XDouble n xs) (XDouble m ys) e + | n == m + = XDouble n $ qcdata_zip shape q c q' c' xs ys (const $ e "XDouble length mismatch") + | otherwise + = error (e "XDouble exponent mismatch") + qcdata_promote (XDouble n b) (XDouble m q) e + | n == m + = XDouble n $ qcdata_promote b q (const $ e "XDouble length mismatch") + | otherwise + = error (e "XDouble exponent mismatch") + +-- Labeling of QDouble is s.sign, s[hi-1], ..., s[lo], where lo = -k. +instance QCLeaf x => Labelable (XDouble x) String where + label_rec (XDouble k (SInt digits sign)) s = do + label_rec sign s `dotted_indexed` "sign" + sequence_ [ label_rec d s `indexed` show i | (d,i) <- zip rdigits [-k,-k+1..] ] + where + rdigits = reverse digits + +instance CircLiftingUnpack (Circ QDouble) (Circ QDouble) where + pack x = x + unpack x = x + +-- ---------------------------------------------------------------------- +-- * Casts + +-- | Convert a 'QSignedInt' to a 'QDouble' with exponent 0. This +-- function does not return a fresh copy; instead, it uses the input +-- qubits. +qdouble_of_qsint :: QSignedInt -> Circ QDouble +qdouble_of_qsint x = do + (_,y) <- qc_copy_fun x + return $ xdouble_of_sint y + +-- ---------------------------------------------------------------------- +-- ** Type class instances + +-- $ We make 'QDouble' an instance of 'QOrd'. + +instance QOrd QDouble where + q_less x y | kx < ky = do + x <- qdouble_pad_right (ky-kx) x + compare_right x y + | kx > ky = do + y <- qdouble_pad_right (kx-ky) y + compare_right x y + | otherwise = compare_right x y + where + kx = xdouble_exponent x + ky = xdouble_exponent y + + -- compare_right assumes matching exponent, i.e., both bit strings + -- are right-aligned. + compare_right :: QDouble -> QDouble -> Circ Qubit + compare_right (XDouble _ n) (XDouble _ m) = q_less n m + +-- | Express a pair of 'QDouble' values as a pair of 'QSignedInt's with a +-- common exponent. +qdouble_align :: QDouble -> QDouble -> Circ (Int, QSignedInt, QSignedInt) +qdouble_align (XDouble h m) (XDouble k n) + | h <= k = do + m <- qsint_shift (k-h) m + return (k, m, n) + | otherwise = do + n <- qsint_shift (h-k) n + return (k, m, n) + + +instance QNum QDouble where + -- Additive operations set the exponent to the maximum of the two + -- exponents, and extend the length if necessary. Signum keeps the + -- length but resets the exponent to 0. + q_add x y = do + (k,m,n) <- qdouble_align x y + (_, _, r) <- q_add m n + return (x, y, XDouble k r) + q_sub x y = do + (k,m,n) <- qdouble_align x y + (_, _, r) <- q_sub m n + return (x, y, XDouble k r) + q_abs x = do + let XDouble k m = x + (_, r) <- q_abs m + return (x, XDouble k r) + q_negate x = do + let XDouble k m = x + (_, r) <- q_negate m + return (x, XDouble k r) + q_signum x = do + let XDouble k m = x + (_, r) <- q_signum m + y <- qdouble_of_qsint r + return (x, y) + q_fromQDInt x = do + (_,y) <- q_fromQDInt x + z <- qdouble_of_qsint y + w <- qdouble_pad_right after_radix_length z + return (x,w) + -- 'q_mult' currently does not work with negative exponents. + q_mult x y = let m = max (xdouble_exponent x) (xdouble_exponent y) in + let s = (xdouble_exponent x) + (xdouble_exponent y) in + do + ext_x <- qdouble_pad_left m x + ext_y <- qdouble_pad_left m y + let XDouble kx nx = ext_x + let XDouble ky ny = ext_y + (_,_,nz) <- q_mult nx ny + let z = XDouble s nz + return (x,y,qdouble_truncate_right (s-m) z) + + +-- ---------------------------------------------------------------------- +-- * Other functions + + + +-- Developer note: the following instances are to be able to use +-- named_gate_safe, which is probably not at all safe. Also, it +-- requires us to define an Eq instance for every type where this is +-- used. The instances are defined as follows, and are considered a +-- temporary hack. + +-- Textual equality for 'QDouble'. +instance Eq QDouble where + XDouble a b == XDouble a' b' = (a,b) == (a',b') + +-- Textual equality for 'QSignedInt'. +instance Eq QSignedInt where + (SInt b c) == (SInt b' c') = (b,c) == (b',c') + + +-- | Coercion from 'QSignedInt' to 'QDouble'. +q_fromIntegral :: QSignedInt -> Circ QDouble +q_fromIntegral x = do + x' <- qsint_shift after_radix_length x + return $ XDouble after_radix_length x' + +-- | QDouble of 'ceiling': coercion from 'QDouble' to 'QSignedInt'. + +-- Note: This rounds to 0 and not to infinity. +q_ceiling :: QDouble -> Circ QSignedInt +q_ceiling (XDouble k (SInt x b)) = return $ SInt (reverse . drop k . reverse $ x) b + + +-- | Real division with 'QDouble'. +q_div_real :: QDouble -> QDouble -> Circ QDouble +q_div_real (XDouble kx (SInt x bx)) (XDouble ky (SInt y by)) = + if (kx /= ky) then error "q_div_real" + else + let k = kx in do + pad_x <- qinit (replicate k False) + pad_y <- qinit (replicate k False) + let ext_x = x ++ pad_x + let ext_y = pad_y ++ y + (_,_,ext_z) <- q_quot (qdint_of_qulist_bh ext_x) + (qdint_of_qulist_bh ext_y) + let z = reverse $ drop k $ reverse $ qulist_of_qdint_bh ext_z + bz <- qinit False + qnot_at bz `controlled` bx + qnot_at bz `controlled` by + return (XDouble k (SInt z bz)) + + + + +my_test = let x = fromRational $ toRational (12345.34) in + let y = fromRational $ toRational (323.1) in + let last (x,y,z) = z in + do + putStrLn $ show_fdouble x + putStrLn $ show_fdouble y + putStrLn $ show_fdouble $ snd $ run_classical_generic q_negate x + + + + + + +instance Num (FDouble,FDouble) where + x + y = undefined + x * y = undefined + x - y = undefined + fromInteger x = undefined + abs x = undefined + signum x = undefined + + +instance QNum (QDouble,QDouble) where + q_add (x1,x2) (y1,y2) = do + (_,_,z1) <- q_add x1 y1 + (_,_,z2) <- q_add x2 y2 + return ((x1,x2),(y1,y2),(z1,z2)) + + q_mult (x1,x2) (y1,y2) = do + (_,_,a) <- q_mult x1 y1 + (_,_,b) <- q_mult x2 y2 + (_,_,z1) <- q_sub a b + (_,_,c) <- q_mult x1 y2 + (_,_,d) <- q_mult x2 y1 + (_,_,z2) <- q_add c d + return ((x1,x2),(y1,y2),(z1,z2)) + + q_sub (x1,x2) (y1,y2) = do + (_,_,z1) <- q_sub x1 y1 + (_,_,z2) <- q_sub x2 y2 + return ((x1,x2),(y1,y2),(z1,z2)) + + q_abs x = do z <- qinit $ qc_false x; named_gate "abs" (x,z) + q_negate x = do z <- qinit $ qc_false x; named_gate "neg" (x,z) + q_signum x = do z <- qinit $ qc_false x; named_gate "sigNum" (x,z) + q_fromQDInt x = undefined diff --git a/dist/build/Quipper/Algorithms/QLS/QLS.hs b/dist/build/Quipper/Algorithms/QLS/QLS.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/QLS/QLS.hs @@ -0,0 +1,976 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/QLS/QLS.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 + {-# OPTIONS -fcontext-stack=50 #-} +#else + {-# OPTIONS -freduction-depth=50 #-} +#endif + +-- | This module contains the Quipper implementation of the Quantum +-- Linear Systems Algorithm. +-- +-- The algorithm estimates the radar cross section for a FEM +-- scattering problem by using amplitude estimation to calculate +-- probability amplitudes. +-- +-- The notations are based on the paper +-- +-- * B. D. Clader, B. C. Jacobs, C. R. Sprouse. Quantum algorithm to +-- calculate electromagnetic scattering cross +-- sections. . +module Quipper.Algorithms.QLS.QLS where + +import Quipper + +import Quipper.Libraries.QFT +import Quipper.Libraries.Arith +import Quipper.Libraries.Decompose + +import Data.Complex +import qualified Data.Map as Map + +import qualified Quipper.Algorithms.QLS.TemplateOracle as Template +import Quipper.Algorithms.QLS.QDouble +import Quipper.Algorithms.QLS.QSignedInt +import Quipper.Algorithms.QLS.CircLiftingImport +import Quipper.Algorithms.QLS.Utils + +import Quipper.Utils.Auxiliary(boollist_of_int_bh) + + +-- | The type of 'oracle_A' input arguments during runtime. +type OracleARunTime = Double -- ^Value resolution. + -> Int -- ^Band. + -> Bool -- ^Argflag. + -> ([Qubit],[Qubit],[Qubit]) -- ^(x=index,y+node,z+value). + -> Circ ([Qubit],[Qubit],[Qubit]) + +-- | The type of 'oracle_b' and 'oracle_r' input arguments during runtime. +type OracleBRRunTime = Double -- ^Magnitude resolution. + -> Double -- ^Phase resolution. + -> ([Qubit],[Qubit],[Qubit]) -- ^(x=index,m+magnitude,p+phase). + -> Circ ([Qubit],[Qubit],[Qubit]) + + +-- | A type to encapsulate all three oracles. +data Oracle = Oracle { + oracle_A :: RunTimeParam -> OracleARunTime, + oracle_b :: RunTimeParam -> OracleBRRunTime, + oracle_r :: RunTimeParam -> OracleBRRunTime +} + + +-- | A set of oracles using only blackboxes. +dummy_oracle :: Oracle +dummy_oracle = Oracle { + oracle_A = \d r i b x -> named_gate "Oracle A" x, + oracle_b = \d1 d2 r x -> named_gate "Oracle b" x, + oracle_r = \d1 d2 r x -> named_gate "Oracle r" x +} + + + +-- | A type to hold the runtime parameters. +data RunTimeParam = RT_param { + k :: Double, -- ^ Wave number. + theta :: Double, -- ^ Incident wave angle. + phi :: Double, -- ^ Direction of desired far field radiation pattern. + e0 :: Double, -- ^ Incident wave amplitude. + lambda :: Double, -- ^ Wavelength. + xlength :: Double, -- ^ /x/-length of square scattering region. + ylength :: Double, -- ^ /y/-length of square scattering region. + + scatteringnodes :: [(Int,Int)], -- ^ Metallic region. + + nx :: Int, + ny :: Int, + lx :: Double, + ly :: Double, + + kappa :: Double, + epsilon :: Double, + t0 :: Double, + r :: Double, + b_max :: Double, + r_max :: Double, + d :: Int, + nb :: Int, + p2 :: Double, + n0 :: Int, + n1 :: Int, + n2 :: Int, + n4 :: Int, + + -- argflags for oracle_A + magnitudeArgflag :: Bool, + phaseArgflag :: Bool +} deriving (Show) + + +-- | A convenient set of runtime parameters for testing. +dummy_RT_param :: RunTimeParam +dummy_RT_param = RT_param { + + k = 2.0*pi*1.0, + theta = 0.0*pi/4.0, + phi = 0.0, + e0 = 1.0, + lambda = (k dummy_RT_param)/(2.0*pi), + xlength = 2.0*(lambda dummy_RT_param), + ylength = 2.0*(lambda dummy_RT_param), + + scatteringnodes = + let rt = dummy_RT_param in + let xul = round((fromIntegral $ nx rt)/2) + - round((xlength rt)/(2.0*(lx rt))) in -- Upper left x index + let yul = round((fromIntegral $ ny rt)/2) + - round((ylength rt)/(2.0*(ly rt))) in -- Upper left y index + let xlr = round((fromIntegral $ nx rt)/2) + + round((xlength rt)/(2.0*(lx rt))) in -- Lower right x index + let ylr = round((fromIntegral $ ny rt)/2) + + round((ylength rt)/(2.0*(ly rt))) in -- Lower right y in + [(xul, yul), (xlr, ylr)], + + nx = 12885, + ny = 12885, + lx = 0.1, + ly = 0.1, + + kappa = 1.0, + epsilon = 1.0, + t0 = 1.0, + r = 1.0, + b_max = 1.0, + r_max = 1.0, + d = 3, + nb = 2, + p2 = 3, + n0 = 3, + n1 = 3, + n2 = 3, + n4 = 3, + + -- argflags for oracle_A + magnitudeArgflag = False, + phaseArgflag = True +} + + +-- | A set of larger values, for testing scalability. +large_RT_param :: RunTimeParam +large_RT_param = RT_param { + + k = 2.0*pi*1.0, + theta = 0.0*pi/4.0, + phi = 0.0, + e0 = 1.0, + lambda = (k large_RT_param)/(2.0*pi), + xlength = 2.0*(lambda large_RT_param), + ylength = 2.0*(lambda large_RT_param), + + scatteringnodes = + let rt = large_RT_param in + let xul = round((fromIntegral $ nx rt)/2) + - round((xlength rt)/(2.0*(lx rt))) in -- Upper left x index + let yul = round((fromIntegral $ ny rt)/2) + - round((ylength rt)/(2.0*(ly rt))) in -- Upper left y index + let xlr = round((fromIntegral $ nx rt)/2) + + round((xlength rt)/(2.0*(lx rt))) in -- Lower right x index + let ylr = round((fromIntegral $ ny rt)/2) + + round((ylength rt)/(2.0*(ly rt))) in -- Lower right y in + [(xul, yul), (xlr, ylr)], + + nx = 12885, + ny = 12885, + lx = 0.1, + ly = 0.1, + + kappa = 1e4, + epsilon = 0.01, + t0 = 7.0e6, + r = 2.5e12, + b_max = 5.0, + r_max = 1.01, + d = 7, + nb = 9, + p2 = ( 1.0 / (4-(4**(1/3))) ), + n0 = 14, + n1 = 24, + n2 = 30, + n4 = 65, + + -- argflags for oracle_A + magnitudeArgflag = False, + phaseArgflag = True +} + + +-- | A set of smaller values, for manageable yet meaningful output. +small_RT_param :: RunTimeParam +small_RT_param = RT_param { + + k = 2.0*pi*1.0, + theta = 0.0*pi/4.0, + phi = 0.0, + e0 = 1.0, + lambda = (k small_RT_param)/(2.0*pi), + xlength = 2.0*(lambda small_RT_param), + ylength = 2.0*(lambda small_RT_param), + + scatteringnodes = + let xul = 2 in + let yul = 2 in + let xlr = 3 in + let ylr = 3 in + [(xul, yul), (xlr, ylr)], + + nx = 4, + ny = 4, + lx = 0.1, + ly = 0.1, + + kappa = 1e4, + epsilon = 0.01, + t0 = 7.0e6, + r = 2.5e12, + b_max = 5.0, + r_max = 1.01, + d = 7, + nb = 9, + p2 = ( 1.0 / (4-(4**(1/3))) ), + n0 = 14, + n1 = 24, + n2 = 6, + n4 = 65, + + -- argflags for oracle_A + magnitudeArgflag = False, + phaseArgflag = True +} + + + +-- | Apply an [exp −/iYt/] gate. The timestep /t/ is a parameter. +expYt :: Timestep -> Qubit -> Circ Qubit +expYt = named_rotation "exp(-i%Y)" + + +-- | Apply an [exp −/iYt/] gate. The timestep /t/ is a parameter. +expYt_at :: Timestep -> Qubit -> Circ () +expYt_at = named_rotation_at "exp(-i%Y)" + + +-- | Read a list of bits and make it into a 'Double', by multiplying +-- its integer value by the provided factor. +dynamic_lift_double :: Double -> [Bit] -> Circ Double +dynamic_lift_double factor cl = do + cdiscard cl + +-- Implementation note: removed dynamic_lift as for now it breaks all +-- output formats except ASCII. + +-- bl <- dynamic_lift cl + let sign = 1 -- if (head $ reverse bl) then 1 else -1 + let unsigned_value = 1 -- integer_of_intm_unsigned $ + -- intm_of_boollist_bh (tail $ reverse bl) + return (sign * factor * (fromIntegral unsigned_value)) + + +-- | A black box gate to stand in as a replacement for QFT. +qft_for_show :: [Qubit] -> Circ [Qubit] +qft_for_show qs = named_gate "QFT" qs + + + +-- | Main function: for estimating the radar cross section for a FEM +-- scattering problem. The problem can be reduced to the calculation +-- of four angles: φ[sub /b/], φ[sub /bx/], φ[sub /r/1] and φ[sub /r/0]. +qlsa_FEM_main :: RunTimeParam -> Oracle -> Circ Double +qlsa_FEM_main param oracle = do + comment "FEM_main" + phi_b <- qlsa_AmpEst_phi_b param oracle + phi_bx <- qlsa_AmpEst_phi_bx param oracle + phi_r1 <- qlsa_AmpEst_phi_bxr param oracle True + phi_r0 <- qlsa_AmpEst_phi_bxr param oracle False + let sigma = ((((fromIntegral $ nb param) ^ 2) * ((b_max param) ^ 2) * ((r_max param) ^ 2) * ((sin phi_b) ^ 2)) / ( 4 * pi)) + comment "FEM_main" + return sigma + + + + +-- * Amplitude Estimation Functions + +-- | Estimates φ[sub /b/], related to the probability of success for the +-- preparation of the known state /b/, using amplitude amplification. +qlsa_AmpEst_phi_b :: RunTimeParam -> Oracle -> Circ Double +qlsa_AmpEst_phi_b param oracle = do + g <- qinit $ replicate (n0 param) False + with_ancilla_init (replicate (n2 param) False) $ \x -> do + label (g,x) ("g","x") + with_ancilla $ \a -> do + label (a) ("anc. a") + with_ancilla $ \b -> do + label (b) ("anc. b") + g <- map_hadamard g + u_b (x,b) + loop g u_g (x,b,a) + return () + return () + g' <- qft_big_endian g -- QFT : Is it really big-endian? + value_bits <- measure g' + value_double <- dynamic_lift_double 1.0 value_bits + return (pi * value_double / (2 ** (fromIntegral $ n0 param))) + where + loop :: [Qubit] -> (a -> Circ ()) -> a -> Circ () + loop [] f x = return () + loop (h:t) f x = do + f x `controlled` h + loop t f' x; + where + f' x = do f x; f x + + u_b :: ([Qubit],Qubit) -> Circ () + u_b xb = qlsa_StatePrep param xb (oracle_b oracle param) (1.0/(b_max param)) + + + u_g :: ([Qubit],Qubit,Qubit) -> Circ () + u_g (x,b,a) = do + comment "U_g starts" + gate_Z_at b + -- For unitrary linear transformation, adjoint == inverse, hence reverse_... + (reverse_generic_imp u_b) (x,b) + qnot_at a `controlled` x .==. (map (\x -> False) x) + gate_X_at a + gate_Z_at a + gate_X_at a + qnot_at a `controlled` x .==. (map (\x -> False) x) + u_b (x,b) + comment "U_g ends" + return () + + + +-- | Testing function for 'qlsa_AmpEst_phi_b'. +test_qlsa_AmpEst_phi_b :: Bool -> IO () +test_qlsa_AmpEst_phi_b dummyRTParamFlag = do + let param = if dummyRTParamFlag then dummy_RT_param else large_RT_param + print_simple GateCount (qlsa_AmpEst_phi_b param dummy_oracle) + print_simple Preview (qlsa_AmpEst_phi_b param dummy_oracle) + + +-- | Estimates φ[sub /bx/], related to the probability of success in +-- computing solution value /x/. +qlsa_AmpEst_phi_bx :: RunTimeParam -> Oracle -> Circ Double +qlsa_AmpEst_phi_bx param oracle = do + g <- qinit (take (n0 param) (repeat False)) + with_ancilla_init (take (n2 param) (repeat False)) $ \x -> do + with_ancilla $ \a -> do + with_ancilla $ \b -> do + with_ancilla $ \s -> do + g <- map_hadamard g + u_bx (x,b,s) + loop g u_g (x,b,s,a) + return () + return () + return () + g' <- qft_big_endian g -- QFT : Is it really big-endian? + value_bits <- measure g' + value_double <- dynamic_lift_double 1.0 value_bits + return (pi * value_double / (2 ** (fromIntegral $ n0 param))) + where + loop :: [Qubit] -> (a -> Circ ()) -> a -> Circ () + loop [] f x = return () + loop (h:t) f x = do + f x `controlled` h + loop t f' x + where + f' x = do f x; f x + + u_bx :: ([Qubit],Qubit,Qubit) -> Circ () + u_bx (x,b,s) = do + qlsa_StatePrep param (x,b) (oracle_b oracle param) (1.0/(b_max param)) + qlsa_Solve_x param (x,s) oracle + return () + + u_g :: ([Qubit],Qubit,Qubit,Qubit) -> Circ () + u_g (x,b,s,a) = do --named_gate_at "Ug_phi_bx" (x,b,s,a) + qnot_at a `controlled` b .&&. s + gate_Z_at a + qnot_at a `controlled` b .&&. s + (reverse_generic_imp u_bx) (x,b,s) + qnot_at a `controlled` [ q .==. 0 | q <- x ] .&&. b .==. 0 .&&. s .==. 0 + gate_X_at a + gate_Z_at a + gate_X_at a + qnot_at a `controlled` [ q .==. 0 | q <- x ] .&&. b .==. 0 .&&. s .==. 0 + u_bx (x,b,s) + return () + + + + +-- | Estimates φ[sub /r/0] and φ[sub /r/1] (depending on the boolean +-- parameter), related to the overlap of the solution with the +-- arbitrary state /r/. +qlsa_AmpEst_phi_bxr :: RunTimeParam -> Oracle -> Bool -> Circ Double +qlsa_AmpEst_phi_bxr param oracle target = do + g <- qinit (take (n0 param) (repeat False)) + with_ancilla_init (take (n2 param) (repeat False)) $ \x -> do + with_ancilla_init (take (n2 param) (repeat False)) $ \y -> do + with_ancilla $ \a -> do + with_ancilla $ \b -> do + with_ancilla $ \s -> do + with_ancilla $ \r -> do + with_ancilla $ \c -> do + g <- map_hadamard g + u_r (x,y,b,s,r,c) + loop g u_g (x,y,b,s,r,c,a) + return () + return () + return () + return () + return () + g' <- qft_big_endian g -- QFT : Is it really big-endian? + value_bits <- measure g' + value_double <- dynamic_lift_double 1.0 value_bits + return (pi * value_double / (2 ** (fromIntegral $ n0 param))) + where + loop :: [Qubit] -> (a -> Circ ()) -> a -> Circ () + loop [] f x = return () + loop (h:t) f x = do + f x `controlled` h + loop t f' x + where + f' x = do f x; f x + + u_r :: ([Qubit],[Qubit],Qubit,Qubit,Qubit,Qubit) -> Circ () + u_r (x,y,b,s,r,c) = do + qlsa_Solve_xr param (x,y,b,s,r,c) oracle + return () + + u_g :: ([Qubit],[Qubit],Qubit,Qubit,Qubit,Qubit,Qubit) -> Circ () + u_g (x,y,b,s,r,c,a) = do --named_gate_at "Ug_phi_bxr" (x,y,b,s,r,c,a) + qnot_at a `controlled` (b .==. 1 .&&. s .==. 1 .&&. r .==. 1 .&&. c .==. target) + gate_Z_at a + qnot_at a `controlled` (b .==. 1 .&&. s .==. 1 .&&. r .==. 1 .&&. c .==. target) + (reverse_generic_imp u_r) (x,y,b,s,r,c) + qnot_at a `controlled` [ q .==. 0 | q <- x ] .&&. [ q .==. 0 | q <- y ] .&&. b .==. 0 .&&. s .==. 0 .&&. r .==. 0 .&&. c .==. 0 + gate_X_at a + gate_Z_at a + gate_X_at a + qnot_at a `controlled` [ q .==. 0 | q <- x ] .&&. [ q .==. 0 | q <- y ] .&&. b .==. 0 .&&. s .==. 0 .&&. r .==. 0 .&&. c .==. 0 + u_r (x,y,b,s,r,c) + return () + + +-- * State Preparation. + +-- | Prepares a quantum state /x/, as specified by an oracle function, +-- entangled with a single qubit flag /q/ marking the desired state. +qlsa_StatePrep :: + RunTimeParam + -> ([Qubit], Qubit) -- x & qare handles to wires to be changed by StatePrep + -> OracleBRRunTime -- Common type of (oracle_b oracle) and (oracle_r oracle), if oracle is typed Oracle + -> Double + -> Circ () +qlsa_StatePrep param (x, q) oracle phi0 = do + _ <- (flip $ box ("qlsa_StatePrep_" ++ (show phi0))) (x,q) $ \(x,q) -> do + -- comment "StatePrep starts" + label (x,q) ("x", "q") + with_ancilla_list (n4 param) $ \m -> do + label (m) ("anc. m") + with_ancilla_list (n4 param) $ \p -> do + label (p) ("anc. p") + x <- map_hadamard x + (x, m, p) <- oracle phi0 (epsilon param) (x, m, p) + qlsa_ControlledPhase p (epsilon param) False + qlsa_ControlledRotation (m, q) phi0 False + (x, m, p) <- oracle phi0 (epsilon param) (x, m, p) + return (x,q) + -- comment "StatePrep ends" + return () + + +-- | Testing function for 'qlsa_StatePrep'. +test_qlsa_StatePrep :: Bool -> IO () +test_qlsa_StatePrep dummyRTParamFlag = do + let param = if dummyRTParamFlag then dummy_RT_param else large_RT_param + let oraclebRunTime = (oracle_b dummy_oracle param) + let testCirc = do + x <- qinit $ replicate (n2 param) False + q <- qinit False + qlsa_StatePrep param (x,q) oraclebRunTime 1.0 + print_simple GateCount testCirc + print_simple Preview testCirc + + + + +-- * Linear System Solver Functions + +-- | Implements the QLSA procedure to generate the solution state |/x/〉. +qlsa_Solve_x :: RunTimeParam ->([Qubit],Qubit) -> Oracle -> Circ () +qlsa_Solve_x param (x,s) oracle = do + _ <- (flip $ box "qlsa_Solve_x") (x,s) $ \(x,s) -> do + with_ancilla_list (n1 param) $ \t -> do + with_ancilla_list (length t) $ \f -> do + let phi0 = 2 * pi / (2 ** (fromIntegral $ n1 param) - (epsilon param)) + t <- map_hadamard t + u_hs (t,x) + t <- qft_big_endian t + integer_inverse (t,f) + qlsa_ControlledRotation (f,s) phi0 False + integer_inverse (t,f) + (reverse_generic_endo qft_big_endian) t + (reverse_generic_imp u_hs) (t,x) + t <- map_hadamard t + return() + return () + return (x,s) + return () + where + u_hs :: ([Qubit],[Qubit]) -> Circ () + u_hs (t,x) = do + qlsa_HamiltonianSimulation param (t,x) (oracle_A oracle param) + return () + + +-- | Implementation of the integer division. The two registers are +-- supposed to be of the same size and represent little-headian +-- unsigned integers, i.e., the head of the list holds the least +-- significant bit. +integer_inverse :: ([Qubit],[Qubit]) -> Circ () +integer_inverse (t,f) = do + _ <- (flip $ box "integer_inverse") (t,f) $ \(t,f) -> do + -- sanity check + if (length t /= length f) + then error "integer_inverse: registers of distinct sizes" + else return () + -- initialize an unsigned integer to 2^(length t) - 1 + with_ancilla_init (map (\_ -> True) t) $ \num -> do + -- perform the division (encapsulated in a subroutine) + let d = classical_to_reversible $ \(t,num) -> do + let x = ((qdint_of_qulist_lh num),(qdint_of_qulist_lh t)) + (_,_,f') <- uncurry q_div_unsigned x + return $ qulist_of_qdint_lh f' + d ((t,num),f) + return (t,f) + return () + + + + + +-- | Implements the complete QLSA procedure to find the +-- solution state |/x/〉 and then implements the swap protocol +-- required for estimation of 〈/x/|/r/〉. +qlsa_Solve_xr :: RunTimeParam ->([Qubit],[Qubit],Qubit,Qubit,Qubit,Qubit) -> Oracle -> Circ () +-- qlsa_Solve_xr param (x,y,b,s,r,c) oracle = named_gate_at "Solve_xr" (x,y,b,s,r,c) +qlsa_Solve_xr param (x,y,b,s,r,c) oracle = do + _ <- (flip $ box "qlsa_Solve_xr") (x,y,b,s,r,c) $ \(x,y,b,s,r,c) -> do + qlsa_StatePrep param (x,b) (oracle_b oracle param) (1.0/(b_max param)) + qlsa_Solve_x param (x,s) oracle + qlsa_StatePrep param (y,r) (oracle_r oracle param) (1.0/(r_max param)) + hadamard_at c + swap_at y x `controlled` c + hadamard_at c + return (x,y,b,s,r,c) + return () + + +-- * Hamiltonian Simulation Functions. + +-- | Uses a quantum register |/t/〉 to control the +-- implementation of the Suzuki method for simulating a Hamiltonian +-- specified by an oracle function. +qlsa_HamiltonianSimulation :: + RunTimeParam + -> ([Qubit], [Qubit]) + -> OracleARunTime + -> Circ () +qlsa_HamiltonianSimulation param (t, x) oracleA = do + _ <- (flip $ box "qlsa_HamiltonianSimulation") (t,x) $ \(t,x) -> do + -- Code the first line in a way that depends on the length of t rather + -- explicitly on (n1 param) which is supposed to be the length of t + -- Hence replaced the line below by the line after it. + -- let denom = 2 * (r param) * (fromIntegral ((n1 param) - 1)) + let denom = 2 * (r param) * ( 2^((length t) - 1) ) + let t1 = (p2 param) * (t0 param) / denom + let t2 = (1.0 - 4.0 * (p2 param)) * (t0 param) / denom + (t,x) <- box_loopM "TrotterLoop" (round $ r param) (t,x) (hs_loop t1 t2) + return (t,x) + return () + where + hs_loop :: Double -> Double -> ([Qubit], [Qubit]) -> Circ ([Qubit], [Qubit]) + hs_loop t1 t2 (t,x) = do + u_z_at (t,x) t1 + u_z_at (t,x) t1 + u_z_at (t,x) t2 + u_z_at (t,x) t1 + u_z_at (t,x) t1 + return (t,x) + + u_z_at :: ([Qubit], [Qubit]) -> Double -> Circ () + u_z_at (t, x) timeStep = do + for (nb param) 1 (-1) $ \jj -> do + qlsa_HsimKernel param (t, x) jj timeStep oracleA + endfor + for 1 (nb param) 1 $ \jj -> do + qlsa_HsimKernel param (t, x) jj timeStep oracleA + endfor + return () + +-- | Testing function for 'qlsa_HamiltonianSimulation'. +test_qlsa_HamiltonianSimulation :: Bool -> IO () +test_qlsa_HamiltonianSimulation dummyRTParamFlag = do + let param = if dummyRTParamFlag then dummy_RT_param else large_RT_param + let oracleARunTime = (oracle_A dummy_oracle param) + let testCirc = do + t <- qinit (take (n0 param) (repeat False)) + x <- qinit (take (n4 param) (repeat False)) + label(t,x) ("t", "x") + qlsa_HamiltonianSimulation param (t,x) oracleARunTime + print_simple GateCount testCirc +-- print_simple Preview testCirc + + + +-- | Uses an oracle function and timestep control register (/t/) to +-- apply 1-sparse Hamiltonian to the input state |/t/, /x/〉. +qlsa_HsimKernel :: + RunTimeParam + -> ([Qubit], [Qubit]) + -> Int + -> Double + -> OracleARunTime + -> Circ () +-- qlsa_HsimKernel param tx band timeStep oracleA = named_gate_at "HsimKernel" tx + +qlsa_HsimKernel param (t, x) band timeStep oracleA = do + _ <- (flip $ box ("qlsa_HsimKernel" ++ (show band) ++ (show timeStep))) (t,x) $ \(t,x) -> do + let phiP = (epsilon param) + with_ancilla_list (n2 param) $ \y -> do + with_ancilla_list (n4 param) $ \m -> do + with_ancilla_list (n4 param) $ \p -> do + label (y,m,p) ("y","m","p") + -- phases + oracleA phiP band (phaseArgflag param) (x,y,p) + qlsa_ControlledPhase p phiP False + oracleA phiP band (phaseArgflag param) (x,y,p) + -- magnitudes + let phiMag = 2 ** (negate $ fromIntegral $ after_radix_length) + oracleA phiMag band (magnitudeArgflag param) (x,y,m) + for 0 ((length t) - 1) 1 $ \ii -> do + let phi_mt = timeStep * phiMag * (2^ii) + qlsa_ApplyHmag param (x,y,m) phi_mt `controlled` (t !! ii) + endfor + oracleA phiMag band (magnitudeArgflag param) (x,y,m) + -- phases again + oracleA phiP band (phaseArgflag param) (x,y,p) + qlsa_ControlledPhase p phiP True + oracleA phiP band (phaseArgflag param) (x,y,p) + return () + return () + return () + return (t,x) + return () + +-- | Testing function for 'qlsa_HsimKernel'. +test_qlsa_HsimKernel :: Bool -> IO () +test_qlsa_HsimKernel dummyRTParamFlag = do + let param = if dummyRTParamFlag then dummy_RT_param else large_RT_param + let oracleARunTime = (oracle_A dummy_oracle param) + let testCirc = do + t <- qinit (take (n0 param) (repeat False)) + x <- qinit (take (n4 param) (repeat False)) + label(t,x) ("t", "x") + qlsa_HsimKernel param (t,x) 1 0.1 oracleARunTime + print_simple GateCount testCirc +-- print_simple Preview testCirc + + +-- | Applies the magnitude component of coupling elements in a +-- 1-sparse Hamiltonian. +qlsa_ApplyHmag :: RunTimeParam -> ([Qubit], [Qubit], [Qubit]) -> Double -> Circ () +qlsa_ApplyHmag param (x,y,m) phi0 = do + _ <- (flip $ box ("qlsa_ApplyHmag " ++ (show phi0))) (x,y,m) $ \(x,y,m) -> do + let (onOne, onZero) = (True, False) + with_ancilla $ \a -> do -- Assume initialized to False (0) + label (a) ("anc. a") + if (length x /= length y) + then error "qlsa_ApplyHmag: Input registers x and y have different lengths." + else return () + let length_xy = length x + for 0 (length_xy - 1) 1 $ \ii -> do + let (xi, yi) = (x !! ii, y !! ii) + w (xi, yi) + qnot_at a `controlled` (xi .==. onOne .&&. yi .==. onZero) + endfor + qlsa_ControlledPhase (m ++ [a]) phi0 False + for (length_xy - 1) 0 (-1) $ \ii -> do + let (xi, yi) = (x !! ii, y !! ii) + qnot_at a `controlled` (xi .==. onOne .&&. yi .==. onZero) + w (xi, yi) + endfor + return () + return (x,y,m) + return () + + +-- | Testing function for 'qlsa_ApplyHmag'. +test_qlsa_ApplyHmag :: Bool -> IO () +test_qlsa_ApplyHmag dummyRTParamFlag = do + let param = if dummyRTParamFlag then dummy_RT_param else large_RT_param + let testCirc = do + x <- qinit (take (n2 param) (repeat False)) + y <- qinit (take (n2 param) (repeat False)) + m <- qinit (take (n4 param) (repeat False)) + label(x,y,m) ("x", "y", "m") + qlsa_ApplyHmag param (x,y,m) 0.1 + print_simple GateCount testCirc + print_simple Preview testCirc + + + + + +-- | Auxiliary function: the /W/-gate. +w :: (Qubit, Qubit) -> Circ () +-- w xy = named_gate_at "W" xy +w (xi,yi) = do + _ <- box "w" (\(xi, yi) -> do + label (xi,yi) ("x[i]","y[i]") + gate_X_at xi `controlled` yi + gate_X_at yi `controlled` xi + hadamard_at yi `controlled` xi + gate_X_at yi `controlled` xi + gate_X_at xi `controlled` yi + return (xi,yi)) (xi,yi) + return () + +-- | Testing function for 'w'. +test_w :: IO () +test_w = do + let testCirc = do + xi <- qinit False + yi <- qinit False + w (xi, yi) + print_simple GateCount testCirc + print_simple Preview testCirc + + +-- * Controlled Logic Operations + + +-- | Applies a phase shift of φ\/2 to the signed input register |φ〉. + +-- For c, bit locations are counted starting from 0 (least significant) to (length c - 2) (most significant) +-- last c (or c !! (n-1)) is the sign bit +qlsa_ControlledPhase :: [Qubit] -> Double -> Bool -> Circ () +-- qlsa_ControlledPhase c phi0 f = named_gate_at "CPhase" c +qlsa_ControlledPhase c phi0 f = do + _ <- (flip $ box ("qlsa_ControlledPhase " ++ (show phi0) ++ " " ++ (show f))) c $ \c -> do + with_ancilla $ \a -> do -- ancilla is initialized to False + if f then (qnot_at a) else return () + let signQubit = last c + qnot_at a `controlled` signQubit + for 0 (length c - 2) 1 $ \ii -> do + let theta = ( (2.0^(ii)) * phi0 / 2.0) -- Note the divide by 2 + -- The following three lines are equivalent + expZt_at theta a `controlled` (c !! ii) + -- a <- expZt theta a `controlled` (c !! ii); return () + -- qlsa_ControlledU (c !! ii, a) (expZt theta) False + endfor + qnot_at a `controlled` signQubit + return c + return () + + +-- | Applies a rotation of φ\/2 to the signed input register |φ〉. +qlsa_ControlledRotation :: ([Qubit], Qubit) -> Double -> Bool -> Circ () +-- qlsa_ControlledRotation ct phi0 f = named_gate_at "CRotate" ct +qlsa_ControlledRotation (c, t) phi0 f = do + _ <- (flip $ box ("qlsa_ControlledRotation " ++ (show phi0) ++ " " ++ (show f))) (c,t) $ \(c,t) -> do + if f then (qnot_at t) else return () + let signQubit = last c + qnot_at t `controlled` signQubit + for 0 (length c - 2) 1 $ \ii -> do + let theta = (2.0^(ii)) * phi0 / 2.0 + expYt_at theta t `controlled` (c !! ii) + endfor + qnot_at t `controlled` signQubit + if f then (qnot_at t) else return () + return (c,t) + return () + + +---------------------------------------------------------------------- +-- * Oracles + +-- | Map a 'QDouble' into an integer, understood as being scaled by +-- the given factor. Take the factor and the size of the output +-- register as parameter. +make_factor_rep :: Double -> Int -> QDouble -> Circ [Qubit] +make_factor_rep factor size p = do + -- number of high bits of p + let p_int_size = (xdouble_length p) - (xdouble_exponent p) + -- get the required number of bits for doing the encoding + let auxsize = max (size - 1) p_int_size + -- do the operation: + -- (1) build a QDouble from the factor: need (size-1) bits of integer part + qfactor <- qinit $ fdouble_of_double (xdouble_exponent p) + (auxsize + xdouble_exponent p) factor + -- (2) scale p + p_large <- qdouble_pad_to_extent (auxsize,- (xdouble_exponent p)) p + -- (3) divide p by factor + qreal_multiples <- unpack template_symb_slash_ p_large qfactor + -- (4) get the floor of the result + q_floor <- template_floor + qmultiples <- q_floor qreal_multiples + -- (5) set them in the right format (it has size elements) + let (SInt tp bp) = qmultiples + let new_p = (take (size - 1) $ reverse tp) ++ [bp] + return new_p + + + +-- | Implements the oracle for the arbitrary state |/r/〉, using the +-- Template Haskell implementation of 'Template.calcRweights'. +inline_oracle_r :: RunTimeParam -> Double -> Double -> ([Qubit],[Qubit],[Qubit]) -> Circ ([Qubit],[Qubit],[Qubit]) +inline_oracle_r rt factor_m factor_p = box ("Or " ++ (show factor_m) ++ " " ++ (show factor_p)) $ decompose_generic Toffoli $ \(x',m',p') -> + with_ancilla_init (fromIntegral $ nx rt :: FSignedInt) $ \qnx -> + with_ancilla_init (fromIntegral $ ny rt :: FSignedInt) $ \qny -> + with_ancilla_init (fdouble $ lx rt) $ \qlx -> + with_ancilla_init (fdouble $ ly rt) $ \qly -> + with_ancilla_init (fdouble $ k rt) $ \qk -> + with_ancilla_init (fdouble $ theta rt) $ \qtheta -> + with_ancilla_init (fdouble $ phi rt) $ \qphi -> + -- the x register is smaller than the size of a QSInt, + -- and x is an unsigned integer: make up a positive + -- sign and a pad + + with_ancilla_init False $ \bx -> do + with_ancilla_init (replicate (fixed_int_register_length - (n2 rt)) + False) $ \pad_x -> do + + let x = SInt (pad_x ++ (reverse x')) bx + let f = classical_to_reversible $ + \(x,nx,ny,lx,ly,k,theta,phi) -> do + (m,p) <- unpack Template.template_calcRweights + x nx ny lx ly k theta phi + new_p <- make_factor_rep factor_p (n4 rt) p + new_m <- make_factor_rep factor_m (n4 rt) m + return (new_m, new_p) + f ((x,qnx,qny,qlx,qly,qk,qtheta,qphi),(m',p')) + return (x',m',p') + + + + + +-- | Implements the oracle for the known state |/b/〉, using the +-- Template Haskell implementation of 'Template.getKnownWeights'. +inline_oracle_b :: RunTimeParam -> Double -> Double -> ([Qubit],[Qubit],[Qubit]) -> Circ ([Qubit],[Qubit],[Qubit]) +inline_oracle_b rt factor_m factor_p = box ("Ob " ++ (show factor_m) ++ " " ++ (show factor_p)) $ decompose_generic Toffoli $ \(x',m',p') -> + -- Make ancillas for constant values + + with_ancilla_init (listpair_fmap fromIntegral $ scatteringnodes rt :: [(FDouble,FDouble)]) $ \qscatteringnodes -> + with_ancilla_init (fromIntegral $ ny rt :: FSignedInt) $ \qny -> + with_ancilla_init (fdouble $ lx rt) $ \qlx -> + with_ancilla_init (fdouble $ ly rt) $ \qly -> + with_ancilla_init (fdouble $ k rt) $ \qk -> + with_ancilla_init (fdouble $ theta rt) $ \qtheta -> + with_ancilla_init (fdouble $ e0 rt) $ \qe0 -> + with_ancilla_init (fromIntegral $ nx rt :: FSignedInt) $ \qnx -> do + + -- the x register is smaller than the size of a QSInt, + -- and x is an unsigned integer: make up a positive + -- sign and a pad + + with_ancilla_init False $ \bx -> do + with_ancilla_init (replicate (fixed_int_register_length - (n2 rt)) + False) $ \pad_x -> do + + let x = SInt (pad_x ++ (reverse x')) bx + + let f = classical_to_reversible $ + \(y,nx,ny,scatteringnodes,lx,ly,k,theta,e0) -> do + -- get some QSInt and QDouble + (m,p) <- unpack Template.template_getKnownWeights + y nx ny scatteringnodes lx ly k theta e0 7 + new_p <- make_factor_rep factor_p (n4 rt) p + new_m <- make_factor_rep factor_m (n4 rt) m + + return (new_m, new_p) + + f ((x,qnx,qny,qscatteringnodes,qlx,qly,qk,qtheta,qe0),(m',p')) + return (x',m',p') + + +-- | Implementation of the oracle calculating the matrix /A/ +-- corresponding to the discretization of the scattering problem, +-- using the Template Haskell implementation of +-- 'Template.getNodeValuesMoreOutputs'. +inline_oracle_A :: RunTimeParam -> Double -> Int -> Bool -> ([Qubit],[Qubit],[Qubit]) -> Circ ([Qubit],[Qubit],[Qubit]) +inline_oracle_A rt factor band argflag = box ("OA " ++ (show band) ++ " " ++ (show argflag)) $ decompose_generic Toffoli $ \(x',y',p') -> do + + let argflag' = if argflag then PTrue else PFalse + + -- Make ancillas for constant values + + with_ancilla_init (listpair_fmap fromIntegral $ scatteringnodes rt :: [(FDouble, FDouble)]) $ \qscatteringnodes -> + with_ancilla_init (fromIntegral $ ny rt :: FSignedInt) $ \qny -> + with_ancilla_init (fromRational $ toRational $ lx rt) $ \qlx -> + with_ancilla_init (fromRational $ toRational $ ly rt) $ \qly -> + with_ancilla_init (fromRational $ toRational $ k rt) $ \qk -> + with_ancilla_init (fromIntegral $ nx rt :: FSignedInt) $ \qnx -> do + + -- the x register is smaller than the size of a QSInt, + -- and x is an unsigned integer: make up a positive + -- sign and a pad + + with_ancilla_init False $ \bx -> do + with_ancilla_init (replicate (fixed_int_register_length - (n2 rt)) + False) $ \pad_x -> do + + let x = SInt (pad_x ++ (reverse x')) bx + + let f = classical_to_reversible $ + \(v,nx,ny,scatteringnodes,lx,ly,k) -> do + -- get some QSInt and QDouble + (y,p) <- unpack Template.template_getNodeValuesMoreOutputs + v band nx ny scatteringnodes lx ly k argflag' 7 + + new_p <- make_factor_rep factor (n4 rt) p + + -- set y in the correct format (it has n2 elements) + -- we can assume that the sign is positive. + -- we also assume that n2 < size of QSInt register + let (SInt ty _) = y + let new_y = (take (n2 rt) $ reverse ty) + + -- return the values in the right format. + return (new_y,new_p) + + f ((x,qnx,qny,qscatteringnodes,qlx,qly,qk),(y',p')) + + return (x',y',p') + + +-- | Encapsulate the inline oracles in Template Haskell into an object +-- of type 'Oracle'. +inline_oracle :: Oracle +inline_oracle = Oracle { + oracle_A = inline_oracle_A, + oracle_b = inline_oracle_b, + oracle_r = inline_oracle_r +} diff --git a/dist/build/Quipper/Algorithms/QLS/QSignedInt.hs b/dist/build/Quipper/Algorithms/QLS/QSignedInt.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/QLS/QSignedInt.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/QLS/QSignedInt.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A module implementing signed quantum integers. We piggy-back on +-- the type 'IntM', considering it as a type of unsigned quantum +-- integers. +module Quipper.Algorithms.QLS.QSignedInt where + +import Data.Typeable + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Arith +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.QLS.Utils +import Quipper.Algorithms.QLS.QSignedIntAux + +import Quipper.Utils.Auxiliary + +-- ---------------------------------------------------------------------- +-- * Signed integer type + +-- | Data type for signed integers. Note that this particular variant +-- does not use two's complement to represent negative numbers, but an +-- explicit sign bit. In particular, there are two different +-- representations of 0 (however, the arithmetic operations always +-- produce +0). +-- +-- This is the generic type, where /x/ represents a bit. An integer is +-- represented as 'SInt' /digits/ /sign/, where /digits/ is a +-- big-headian list of digits (i.e., the most significant bit occupies +-- the head of the list), and /sign/ is the sign, with 'False' +-- representing plus and 'True' representing minus. +-- +-- When we speak of the \"length\" of a 'SignedInt', we mean the +-- number of digits excluding the sign. +data SignedInt x = SInt [x] x + deriving (Show, Typeable) + +-- | The parameter type of signed integers. +type FSignedInt = SignedInt Bool + +-- | The quantum type of signed integers. +type QSignedInt = SignedInt Qubit + +-- | The classical type of signed integers. +type CSignedInt = SignedInt Bit + +-- ---------------------------------------------------------------------- +-- * Conversions for 'FSignedInt' + +-- | Take a length and an integer, and return a 'FSignedInt' of the +-- given length. +fsint_of_integer :: Int -> Integer -> FSignedInt +fsint_of_integer m x = SInt digits sign where + digits = boollist_of_int_bh m (abs x) + sign = (x < 0) + +-- | Convert an 'FSignedInt' to an integer. +integer_of_fsint :: FSignedInt -> Integer +integer_of_fsint (SInt digits sign) = if sign then -a else a where + a = int_of_boollist_unsigned_bh digits + +-- | Get the length of a 'SignedInt'. +sint_length :: SignedInt x -> Int +sint_length (SInt digits sign) = length digits + +instance Enum FSignedInt where + succ x = fsint_of_integer m . succ . integer_of_fsint $ x + where m = sint_length x + pred x = fsint_of_integer m . pred . integer_of_fsint $ x + where m = sint_length x + toEnum x = fsint_of_integer m (fromIntegral x) + where m = (+) 1 $ ceiling $ logBase 2 $ fromIntegral x + fromEnum x = fromIntegral . integer_of_fsint $ x + +-- QCData instance + +type instance QCType x y (SignedInt z) = SignedInt (QCType x y z) +type instance QTypeB FSignedInt = QSignedInt + +instance QCLeaf x => QCData (SignedInt x) where + qcdata_mapM (shape :: SignedInt x) f g (SInt digits sign) = do + digits' <- qcdata_mapM [dummy :: x] f g digits + sign' <- qcdata_mapM (dummy :: x) f g sign + return (SInt digits' sign') + + qcdata_zip (shape :: SignedInt x) q c q' c' (SInt digits sign) (SInt digits' sign') e + = (SInt digits'' sign'') + where + digits'' = qcdata_zip [dummy :: x] q c q' c' digits digits' errmsg + sign'' = qcdata_zip (dummy :: x) q c q' c' sign sign' e + errmsg x = e "SignedInt length mismatch" + + qcdata_promote (SInt digits sign) (SInt digits' sign') e + | length digits /= length digits' + = error (e "SignedInt length mismatch") + | otherwise + = (SInt digits'' sign'') + where + digits'' = qcdata_promote digits digits' e + sign'' = sign + +-- Labeling of QSignedInt is s.sign, s[m-1], ..., s[0] +instance QCLeaf x => Labelable (SignedInt x) String where + label_rec (SInt digits sign) s = do + label_rec (reverse digits) s + label_rec sign s `dotted_indexed` "sign" + +-- * Operations + +-- | Make two qubit lists be of the same length, by prepending qubits +-- initialized to 'False' to the head of the shorter of the two lists. +left_pad_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit]) +left_pad_qulist l1 l2 = if (length l1 == length l2) then return (l1,l2) + else do + let m = abs (length l1 - length l2) + pad <- qinit (replicate m False) + if (length l1 > length l2) + then return (l1,pad ++ l2) + else return (pad ++ l1, l2) + +-- | Shift an 'FSignedInt' by /k/ digits to the left. In other words, +-- multiply it by 2[sup /k/], while simultaneously increasing the +-- length by /k/. +fsint_shift :: Int -> FSignedInt -> FSignedInt +fsint_shift k (SInt digits sign) = (SInt digits' sign) + where + digits' = digits ++ replicate k False + + +-- | One half of an isomorphism between 'QSignedInt' and ('Qubit', 'QDInt'). +s_qdint_of_qsint :: QSignedInt -> (Qubit, QDInt) +s_qdint_of_qsint (SInt q b) = (b, qdint_of_qulist_bh q) + +-- | The other half of an isomorphism between 'QSignedInt' and +-- ('Qubit', 'QDInt'). +qsint_of_s_qdint :: (Qubit, QDInt) -> QSignedInt +qsint_of_s_qdint (b, q) = SInt (qulist_of_qdint_bh q) b + +-- | Shift a 'QSignedInt' by /k/ digits to the left. In other words, +-- multiply it by 2[sup /k/], while simultaneously increasing the +-- length by /k/. +qsint_shift :: Int -> QSignedInt -> Circ QSignedInt +qsint_shift k (SInt digits sign) = do + pad <- qinit (replicate k False) + let digits' = digits ++ pad + return (SInt digits' sign) + + + + +-- Ordering on QSignedInt. If two operands are to be compared, it is +-- not necessarily assumed that they are of the same length, and this +-- feature is actually exploited by the QOrd QDouble instance. +-- However, note that the default implementations of 'max' and 'min' +-- do assume equal length. +instance QOrd QSignedInt where + q_less (SInt x' b) (SInt y' c) = do + (x,y) <- left_pad_qulist x' y' + unpack template_be_signed_boollist_less (b, x) (c, y) + + +instance Eq FSignedInt where + x == y = (integer_of_fsint x) == (integer_of_fsint y) + + +instance Ord FSignedInt where + compare x y = compare (integer_of_fsint x) (integer_of_fsint y) + + +instance Num FSignedInt where + x + y = fsint_of_integer m $ (integer_of_fsint x) + (integer_of_fsint y) + where + m = max (sint_length x) (sint_length y) + x * y = fsint_of_integer m $ (integer_of_fsint x) * (integer_of_fsint y) + where + m = max (sint_length x) (sint_length y) + x - y = fsint_of_integer m $ (integer_of_fsint x) - (integer_of_fsint y) + where + m = max (sint_length x) (sint_length y) + fromInteger x = fsint_of_integer fixed_int_register_length x + abs x = fsint_of_integer m . abs . integer_of_fsint $ x + where + m = sint_length x + signum x = fsint_of_integer m . signum . integer_of_fsint $ x + where + m = sint_length x + + +instance Real FSignedInt where + toRational = toRational . integer_of_fsint + +instance Integral FSignedInt where + quotRem x y = (fsint_of_integer m q, fsint_of_integer m r) where + m = max (sint_length x) (sint_length y) + (q,r) = quotRem (integer_of_fsint x) (integer_of_fsint y) + toInteger = integer_of_fsint + + +instance QNum QSignedInt where + q_add (SInt x' b) (SInt y' c) = do + (x,y) <- left_pad_qulist x' y' + (d,z) <- unpack template_be_signed_boollist_add (b,x) (c,y) + return (SInt x' b, SInt y' c, SInt z d) + + q_mult (SInt x' b) (SInt y' c) = do + (x,y) <- left_pad_qulist x' y' + (_, _, z') <- q_mult (qdint_of_qulist_bh x) (qdint_of_qulist_bh y) + (_, _, d') <- q_add (qdint_of_qulist_bh [b]) (qdint_of_qulist_bh [c]) + let z = qulist_of_qdint_bh z' + let d = qulist_of_qdint_bh d' + return (SInt x' b, SInt y' c, SInt z $ head d) + + q_sub x y = do + (y,z) <- q_negate y + (x,z,t) <- q_add x z + return (x,y,t) + + q_abs (SInt l s) = do + l' <- qinit $ qc_false l; + s' <- qinit False + controlled_not_at l' l + return (SInt l s, SInt l' s') + + q_negate (SInt l s) = do + l' <- qinit $ qc_false l; + s' <- qinit False + controlled_not_at l' l + qnot_at s' `controlled` s .==. 0 + return (SInt l s, SInt l' s') + + q_signum (SInt l s) = do + l' <- qinit $ qc_false l; + s' <- qinit False + qnot s' `controlled` s + return (SInt l s, SInt l' s') + + q_fromQDInt l1 = do + let l = qulist_of_qdint_bh l1 + l' <- qinit $ qc_false l; + controlled_not_at l' l + s' <- qinit False + return (qdint_of_qulist_bh l, SInt l' s') + + + +-- | The modulo operation on 'QSignedInt'. +q_mod :: QSignedInt -> QSignedInt -> Circ QSignedInt +q_mod x y = do + let (x_b, x') = s_qdint_of_qsint x + let (y_b, y') = s_qdint_of_qsint y + (_,_,z1) <- q_quot x' y' + (_,_,z2) <- q_mult y' z1 + (_,_,z3) <- q_sub x' z2 + z_b <- qinit False + qnot_at z_b `controlled` x_b + qnot_at z_b `controlled` y_b -- XXXXXXXXXX TO CHECK + let z = qsint_of_s_qdint (z_b,z3) + return z + + + +my_test = let x = fsint_of_integer 50 1595713 in + let y = fsint_of_integer 30 547137 in + let last (x,y,z) = z in + do + putStrLn $ show (x < y) + putStrLn $ show $ last $ run_classical_generic q_add x y + putStrLn $ show (x - y) + putStrLn $ show $ last $ run_classical_generic q_sub x y + putStrLn $ show $ run_classical_generic q_less x y + putStrLn $ show $ run_classical_generic q_less y x + print_simple GateCount $ do + a <- qinit x + b <- qinit y + b <- q_less a b + return () + + diff --git a/dist/build/Quipper/Algorithms/QLS/QSignedIntAux.hs b/dist/build/Quipper/Algorithms/QLS/QSignedIntAux.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/QLS/QSignedIntAux.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/QLS/QSignedIntAux.hs" #-} +-- | Helper module for "Quipper.Algorithms.QLS.QSignedInt": some functions +-- defined with Template Haskell. +module Quipper.Algorithms.QLS.QSignedIntAux where + +import Quipper +import Quipper.Libraries.Arith + + + +-- | Subtraction on lists of booleans, understood as big-headian, +-- unsigned integers. + +-- void definition for now +be_boollist_sub :: [Bool] -> [Bool] -> [Bool] +be_boollist_sub = error "be_boollist_sub yet undefined." + + +-- Template version of 'be_boollist_sub'. + +-- Right now, call to q_sub. +-- template_be_boollist_sub :: Circ ([Qubit] -> Circ ([Qubit] -> Circ [Qubit])) +template_be_boollist_sub = return $ \x -> return $ \y -> do + let x' = qdint_of_qulist_bh x + let y' = qdint_of_qulist_bh y + (_,_,z) <- q_sub x' y' + return $ qulist_of_qdint_bh z + + +-- | Addition on lists of booleans, understood as big-headian, unsigned +-- integers. + +-- void definition for now. +be_boollist_add :: [Bool] -> [Bool] -> [Bool] +be_boollist_add = error "be_boollist_add yet undefined." + + + +-- Template version of 'be_boollist_add' + +-- Right now, call q_add +-- template_be_boollist_add :: Circ ([Qubit] -> Circ ([Qubit] -> Circ [Qubit])) +template_be_boollist_add = return $ \x -> return $ \y -> do + let x' = qdint_of_qulist_bh x + let y' = qdint_of_qulist_bh y + (_,_,z) <- q_add x' y' + return $ qulist_of_qdint_bh z + + + +-- | Strict ordering on lists of booleans, understood as big-headian +-- unsigned integers. If the lists are not of equal length, the +-- shorter list is treated as if its tail were padded with zeros. + +be_boollist_less :: [Bool] -> [Bool] -> Bool +be_boollist_less l1 l2 = + case (l1,l2) of + (a,[]) -> False + ([],a) -> be_boollist_less [False] a + (h1:t1, h2:t2) -> + let parity = if h1 then h2 else not h2 in + if parity then be_boollist_less t1 t2 + else h2 + + + +{-# LINE 64 "Quipper/Algorithms/QLS/QSignedIntAux.hs" #-} +$( decToCircMonad [d| be_boollist_less :: [Bool] -> [Bool] -> Bool + be_boollist_less l1 l2 = + case (l1,l2) of + (a,[]) -> False + ([],a) -> be_boollist_less [False] a + (h1:t1, h2:t2) -> + let parity = if h1 then h2 else not h2 in + if parity then be_boollist_less t1 t2 + else h2 + + + + |] ) +{-# LINE 65 "Quipper/Algorithms/QLS/QSignedIntAux.hs" #-} +-- | Strict ordering on lists of booleans, understood as big-headian +-- signed integers: the 'Bool' in the pair stands for the sign: 'False' +-- is positive, 'True' is negative. + +be_signed_boollist_less :: (Bool,[Bool]) -> (Bool,[Bool]) -> Bool +be_signed_boollist_less (b1,l1) (b2,l2) = + if b1 then (if b2 then be_boollist_less l2 l1 else True) + else (if b2 then False else be_boollist_less l1 l2) + + + +{-# LINE 74 "Quipper/Algorithms/QLS/QSignedIntAux.hs" #-} +$( decToCircMonad [d| be_signed_boollist_less :: (Bool,[Bool]) -> (Bool,[Bool]) -> Bool + be_signed_boollist_less (b1,l1) (b2,l2) = + if b1 then (if b2 then be_boollist_less l2 l1 else True) + else (if b2 then False else be_boollist_less l1 l2) + + + + |] ) +{-# LINE 75 "Quipper/Algorithms/QLS/QSignedIntAux.hs" #-} +-- | Test whether all elements of a list are 'False'. + +boollist_is_zero :: [Bool] -> Bool +boollist_is_zero l = + case l of + [] -> True + (h:t) -> if h then boollist_is_zero t else False + + + +{-# LINE 83 "Quipper/Algorithms/QLS/QSignedIntAux.hs" #-} +$( decToCircMonad [d| boollist_is_zero :: [Bool] -> Bool + boollist_is_zero l = + case l of + [] -> True + (h:t) -> if h then boollist_is_zero t else False + + + + |] ) +{-# LINE 84 "Quipper/Algorithms/QLS/QSignedIntAux.hs" #-} +-- | Addition on signed integers, encoded as big-headian lists of +-- booleans. + +be_signed_boollist_add :: (Bool,[Bool]) -> (Bool,[Bool]) -> (Bool,[Bool]) +be_signed_boollist_add (b,x) (c,y) = + let parity = if b then c else not c in + let (d,z) = if parity then (b, be_boollist_add x y) + else if (be_boollist_less x y) then (c, be_boollist_sub y x) + else (b, be_boollist_sub x y) + in if (boollist_is_zero z) then (False,z) else (d,z) + +$( decToCircMonad [d| be_signed_boollist_add :: (Bool,[Bool]) -> (Bool,[Bool]) -> (Bool,[Bool]) + be_signed_boollist_add (b,x) (c,y) = + let parity = if b then c else not c in + let (d,z) = if parity then (b, be_boollist_add x y) + else if (be_boollist_less x y) then (c, be_boollist_sub y x) + else (b, be_boollist_sub x y) + in if (boollist_is_zero z) then (False,z) else (d,z) + + |] ) diff --git a/dist/build/Quipper/Algorithms/QLS/RealFunc.hs b/dist/build/Quipper/Algorithms/QLS/RealFunc.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/QLS/RealFunc.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + + +-- | Define various analytic functions for 'FDouble' and 'QDouble'. +module Quipper.Algorithms.QLS.RealFunc where + +import Data.List(mapAccumL) +import Quipper +import Quipper.Algorithms.QLS.CircLiftingImport +import Quipper.Algorithms.QLS.QSignedInt +import Quipper.Algorithms.QLS.QDouble +import Quipper.Algorithms.QLS.Utils + + +-- * Some analytic functions on 'FDouble'. + +-- | Approximation of the sine function using Taylor series. + +approx_sin :: FDouble -> FDouble +approx_sin x = let x2 = x * x in + let x3 = x2 * x in + let x4 = x2 * x2 in + let x5 = x4 * x in + let x7 = x2 * x5 in + let x9 = x2 * x7 in + let x11 = x2 * x9 in + x - (x3 / 6.0) + + (x5 / 120.0) + - (x7 / 5040.0) + + (x9 / 362880.0) + - (x11 / 39916800.0) + + + +{-# LINE 34 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +$( decToCircMonad [d| approx_sin :: FDouble -> FDouble + approx_sin x = let x2 = x * x in + let x3 = x2 * x in + let x4 = x2 * x2 in + let x5 = x4 * x in + let x7 = x2 * x5 in + let x9 = x2 * x7 in + let x11 = x2 * x9 in + x - (x3 / 6.0) + + (x5 / 120.0) + - (x7 / 5040.0) + + (x9 / 362880.0) + - (x11 / 39916800.0) + + + + |] ) +{-# LINE 35 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +-- | Implementation of the sine function valid on the whole domain of +-- 'FDouble'. + +local_sin :: FDouble -> FDouble +local_sin x = let n = fromIntegral $ floor (x/(2.0*local_pi)) in + let y = x - 2.0*local_pi*n in + if (y < local_pi/2.0) then approx_sin y + else if (y > 3.0*local_pi/2.0) then approx_sin (y - 2.0*local_pi) + else approx_sin (local_pi - y) + + + +{-# LINE 45 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +$( decToCircMonad [d| local_sin :: FDouble -> FDouble + local_sin x = let n = fromIntegral $ floor (x/(2.0*local_pi)) in + let y = x - 2.0*local_pi*n in + if (y < local_pi/2.0) then approx_sin y + else if (y > 3.0*local_pi/2.0) then approx_sin (y - 2.0*local_pi) + else approx_sin (local_pi - y) + + + + |] ) +{-# LINE 46 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +-- | Implementation of the cosine function valid on the whole domain +-- of 'FDouble'. + +local_cos :: FDouble -> FDouble +local_cos x = local_sin (x + local_pi/2.0) + + + + + +{-# LINE 54 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +$( decToCircMonad [d| local_cos :: FDouble -> FDouble + local_cos x = local_sin (x + local_pi/2.0) + + + + + + |] ) +{-# LINE 55 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +-- listAngle :: [Double] +listAngle = snd $ mapAccumL (\a x -> (a+1, x / (2 ** a))) 3.0 (replicate after_radix_length pi) + +-- template_listAngle :: Circ [QDouble] +template_listAngle = mapM (\x -> qinit $ fdouble x) listAngle + +-- listCos :: [Double] +listCos = map cos listAngle + +-- template_listCos :: Circ [QDouble] +template_listCos = mapM (\x -> qinit $ fdouble x) listCos + +-- listSin :: [Double] +listSin = map sin listAngle + +-- template_listSin :: Circ [QDouble] +template_listSin = mapM (\x -> qinit $ fdouble x) listCos + + + +-- list_values :: [(FDouble,FDouble,FDouble)] +list_values = map (\(x,y,z) -> (fdouble x, fdouble y, fdouble z)) $ + zip3 listAngle listCos listSin + +template_list_values = mapM (\(x,y,z) -> do + x' <- qinit $ fdouble x + y' <- qinit $ fdouble y + z' <- qinit $ fdouble z + return (x',y',z')) $ zip3 listAngle listCos listSin + + +-- | Auxiliary function for 'local_sqrt'. + +approx_sqrt :: Int -> FDouble -> FDouble +approx_sqrt n x = case n of + 0 -> x + n -> let s = approx_sqrt (paramPred n) x in (s + x/s)/2.0 + + +{-# LINE 92 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +$( decToCircMonad [d| approx_sqrt :: Int -> FDouble -> FDouble + approx_sqrt n x = case n of + 0 -> x + n -> let s = approx_sqrt (paramPred n) x in (s + x/s)/2.0 + + + |] ) +{-# LINE 93 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +-- | Approximation of the square root using iterative means. + +local_sqrt :: FDouble -> FDouble +local_sqrt x = approx_sqrt paramTen x + + + +{-# LINE 98 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +$( decToCircMonad [d| local_sqrt :: FDouble -> FDouble + local_sqrt x = approx_sqrt paramTen x + + + + |] ) +{-# LINE 99 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +-- | The function 'Data.Complex.magnitude' defined for +-- 'FDouble'. Calculate the non-negative magnitude of a complex number. + +local_mag :: FDouble -> FDouble -> FDouble +local_mag x y = local_sqrt (x * x + y * y) + + + +{-# LINE 105 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +$( decToCircMonad [d| local_mag :: FDouble -> FDouble -> FDouble + local_mag x y = local_sqrt (x * x + y * y) + + + + |] ) +{-# LINE 106 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +-- | Apply the matrix +-- +-- > ( a b ) +-- > ( c d ) +-- +-- to the column vector (/x/,/y/). + +rotate :: FDouble -> FDouble -> FDouble -> FDouble -> FDouble -> FDouble -> (FDouble,FDouble) +rotate a b c d x y = (a * x + b * y, c * x + d * y) + where + -- To help the GHC 8.0 typechecker + dummy = id_fdouble x + + + +{-# LINE 119 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +$( decToCircMonad [d| rotate :: FDouble -> FDouble -> FDouble -> FDouble -> FDouble -> FDouble -> (FDouble,FDouble) + rotate a b c d x y = (a * x + b * y, c * x + d * y) + where + + dummy = id_fdouble x + + + + |] ) +{-# LINE 120 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +-- | Auxiliary function for 'approx_atan2'. + +approx_atan2_aux :: FDouble -> FDouble -> (FDouble,FDouble, FDouble) -> (FDouble, FDouble, FDouble) + -> (FDouble,FDouble,FDouble) +approx_atan2_aux x y (angle, x', y') (r, cn, sn) = + let (a,(b,c)) = if (y' > y) then (angle - r, rotate cn sn (-sn) cn x' y') + else (angle + r, rotate cn (-sn) sn cn x' y') + in (a,b,c) + where + -- To help the GHC 8.0 typechecker + dummy_r = id_fdouble r + + +{-# LINE 131 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +$( decToCircMonad [d| approx_atan2_aux :: FDouble -> FDouble -> (FDouble,FDouble, FDouble) -> (FDouble, FDouble, FDouble) + -> (FDouble,FDouble,FDouble) + approx_atan2_aux x y (angle, x', y') (r, cn, sn) = + let (a,(b,c)) = if (y' > y) then (angle - r, rotate cn sn (-sn) cn x' y') + else (angle + r, rotate cn (-sn) sn cn x' y') + in (a,b,c) + where + + dummy_r = id_fdouble r + + + |] ) +{-# LINE 132 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +-- | Definition of 'atan2' using a CORDIC method. Assume (/x/,/y/) is +-- in first quadrant and that /x/ > /y/. + +approx_atan2 :: FDouble -> FDouble -> FDouble +approx_atan2 y x = + let list = list_values in + let (a,_,_) = foldl (approx_atan2_aux x y) (0.0, local_mag x y, 0.0) list in a + + +{-# LINE 139 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +$( decToCircMonad [d| approx_atan2 :: FDouble -> FDouble -> FDouble + approx_atan2 y x = + let list = list_values in + let (a,_,_) = foldl (approx_atan2_aux x y) (0.0, local_mag x y, 0.0) list in a + + + |] ) +{-# LINE 140 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +-- | Definition of 'atan2' using a CORDIC method. /x/ and /y/ can be any 'FDouble'. + +local_atan2 :: FDouble -> FDouble -> FDouble +local_atan2 y' x' = + let (x,y,(pad,sign)) = if (x' >= 0.0 && y' >= 0.0) then ( x', y', (0.0, 1.0)) + else if (x' >= 0.0 && y' < 0.0) then ( x', -y', (0.0, -1.0)) + else if (x' < 0.0 && y' < 0.0) then (-x', -y', (-local_pi, 1.0)) + else (-x', y', (local_pi, -1.0)) + in + let angle = if (x > y) then approx_atan2 y x + else local_pi/2.0 - approx_atan2 x y + in sign * angle + pad + + + +{-# LINE 153 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +$( decToCircMonad [d| local_atan2 :: FDouble -> FDouble -> FDouble + local_atan2 y' x' = + let (x,y,(pad,sign)) = if (x' >= 0.0 && y' >= 0.0) then ( x', y', (0.0, 1.0)) + else if (x' >= 0.0 && y' < 0.0) then ( x', -y', (0.0, -1.0)) + else if (x' < 0.0 && y' < 0.0) then (-x', -y', (-local_pi, 1.0)) + else (-x', y', (local_pi, -1.0)) + in + let angle = if (x > y) then approx_atan2 y x + else local_pi/2.0 - approx_atan2 x y + in sign * angle + pad + + + + |] ) +{-# LINE 154 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +-- | The function 'Data.Complex.mkPolar' defined for 'FDouble'. Form a +-- complex number from polar components of magnitude and phase. + +local_mkPolar :: FDouble -> FDouble -> (FDouble,FDouble) +local_mkPolar p t = (p * local_cos t, p * local_sin t) + + + + + + + +{-# LINE 164 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +$( decToCircMonad [d| local_mkPolar :: FDouble -> FDouble -> (FDouble,FDouble) + local_mkPolar p t = (p * local_cos t, p * local_sin t) + + + + + + + + |] ) +{-# LINE 165 "Quipper/Algorithms/QLS/RealFunc.hs" #-} +instance Floating FDouble where + pi = fromRational $ toRational pi + sin x = local_sin x + cos x = local_cos x + + sinh x = (exp x - exp (-x)) / 2 + cosh x = (exp x - exp (-x)) / 2 + + asinh x = error "asinh not defined for FDouble" + acosh x = error "acosh not defined for FDouble" + atanh x = error "atanh not defined for FDouble" + + exp x = undefined + log x = undefined + + asin x = error "asin not defined for FDouble" + acos x = error "acos not defined for FDouble" + atan x = atan2 x 1 + + +instance RealFloat FDouble where + floatRadix _ = 2 + floatDigits x = xdouble_length x + floatRange _ = (0,0) + decodeFloat (XDouble k n) = (integer_of_fsint n, -k) + encodeFloat x k = XDouble (-k) (fromInteger x) + isNaN _ = False + isInfinite _ = False + isDenormalized _ = False + isNegativeZero _ = False + isIEEE _ = False + atan2 y x = local_atan2 y x + + + + +-- | A type class for quantum floating-point numbers. +class QFloating a where + -- | Quantum implementation of the sine function. + q_sin :: a -> Circ a + -- | Quantum implementation of the cosine function. + q_cos :: a -> Circ a + +instance QFloating QDouble where + q_sin x = (unpack template_local_sin) x + q_cos x = (unpack template_local_cos) x + + +-- | Quantum implementation of 'atan2' on 'QDouble'. +q_atan2 :: QDouble -> QDouble -> Circ QDouble +q_atan2 = unpack template_local_atan2 + +-- | Quantum implementation of 'Data.Complex.magnitude' on 'QDouble'. +q_magnitude :: (QDouble, QDouble) -> Circ QDouble +q_magnitude = Prelude.uncurry $ unpack template_local_mag + + +-- | Quantum implementation of 'Data.Complex.mkPolar' on 'QDouble'. +q_mkPolar :: QDouble -> QDouble -> Circ (QDouble,QDouble) +q_mkPolar = unpack template_local_mkPolar + + +-- | Quantum implementation of 'Data.Complex.realPart' on 'QDouble': +-- return the real part of a complex number. A quantum complex is a +-- pair of two 'QDouble's. +q_Re :: (QDouble,QDouble) -> Circ QDouble +q_Re (x,y) = return x + +-- | Quantum implementation of 'Data.Complex.imagPart' on 'QDouble': +-- return the imaginary part of a copmlex number. A quantum complex is +-- a pair of two 'QDouble's. +q_Im :: (QDouble,QDouble) -> Circ QDouble +q_Im (x,y) = return y + + + +my_test_fdouble = do + for 0 37 1 $ \i -> do + let x = fromIntegral i + let a1 = fromRational $ toRational (sin(x * pi/37)) + let a2 = fromRational $ toRational (cos(x * pi/37)) + let z1 = local_atan2 a1 a2 + let z2 = fromRational $ toRational $ atan2 (sin(x * pi/37)) (cos(x * pi/37)) + putStrLn $ show_fdouble $ abs (z1 - z2) + + + + +-- * Template subroutines of analytic functions. + +-- | Template version of 'sin'. +template_sin :: Circ (QDouble -> Circ QDouble) +template_sin = return $ \x -> box "sin" q_sin x + +-- | Template version of 'cos'. +template_cos :: Circ (QDouble -> Circ QDouble) +template_cos = return $ \x -> box "cos" q_cos x + +-- | Template version of 'atan2'. +template_atan2 :: Circ (QDouble -> Circ (QDouble -> Circ QDouble)) +template_atan2 = return $ \x -> return $ \y -> box "atan" (uncurry q_atan2) (x,y) + + + + + + +-- * Template subroutines for dealing with quantum complex number encoded as pairs of 'QDouble'. + +-- | Template version of 'Data.Complex.mkPolar'. +template_mkPolar :: Circ (QDouble -> Circ (QDouble -> Circ (QDouble,QDouble))) +template_mkPolar = return $ \x -> return $ \y -> box "mkPolar" (uncurry q_mkPolar) (x,y) + +-- | Template version of the constructor 'Data.Copmlex.:+' of +-- 'Data.Complex.Complex'. +template_symb_colon_symb_plus_ :: Circ (QDouble -> Circ (QDouble -> Circ (QDouble,QDouble))) +template_symb_colon_symb_plus_ = return $ \x -> return $ \y -> return (x,y) + + +-- | Template version of 'Data.Complex.magnitude'. +template_magnitude :: Circ ((QDouble,QDouble) -> Circ QDouble) +template_magnitude = return $ \p -> box "mag" q_magnitude p + +-- | Template version of 'Data.Complex.realPart'. +template_realPart :: Circ ((QDouble,QDouble) -> Circ QDouble) +template_realPart = return $ \(x,y) -> return x + +-- | Template version of 'Data.Complex.imagPart'. +template_imagPart :: Circ ((QDouble,QDouble) -> Circ QDouble) +template_imagPart = return $ \(x,y) -> return y + diff --git a/dist/build/Quipper/Algorithms/QLS/TemplateOracle.hs b/dist/build/Quipper/Algorithms/QLS/TemplateOracle.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/QLS/TemplateOracle.hs @@ -0,0 +1,973 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + + +-- | This module contains an implementation of the oracle and its +-- automatic lifting to quantum circuits using Template Haskell. +module Quipper.Algorithms.QLS.TemplateOracle where + +import Data.Complex +import Quipper.Utils.Auxiliary + +import Control.Monad + +import Quipper.Libraries.Arith hiding (template_symb_plus_) +import Quipper.Algorithms.QLS.Utils +import Quipper.Algorithms.QLS.QDouble +import Quipper.Algorithms.QLS.RealFunc +import Quipper.Algorithms.QLS.QSignedInt +import Quipper.Algorithms.QLS.CircLiftingImport + +import Quipper +import Quipper.Internal.CircLifting + +-- | Lifted version of @'any'@ (local version). + +local_any :: (a -> Bool) -> [a] -> Bool +local_any f l = case l of + [] -> False + (h:t) -> if (f h) then True else local_any f t + + + + +{-# LINE 31 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| local_any :: (a -> Bool) -> [a] -> Bool + local_any f l = case l of + [] -> False + (h:t) -> if (f h) then True else local_any f t + + + + + |] ) +{-# LINE 32 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | Auxiliary function. + +itoxy :: Int -> Int -> Int -> (Int, Int) +itoxy i nx ny = + if (i <= 0) then (0,0) + else if (i > (nx-1)*ny + nx*(ny-1)) then (0,0) + else ((mod (i - 1) (2*nx - 1)) + 1, ceiling ((fromIntegral i)/(2.0*(fromIntegral nx)-1.0))) + + + +{-# LINE 40 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| itoxy :: Int -> Int -> Int -> (Int, Int) + itoxy i nx ny = + if (i <= 0) then (0,0) + else if (i > (nx-1)*ny + nx*(ny-1)) then (0,0) + else ((mod (i - 1) (2*nx - 1)) + 1, ceiling ((fromIntegral i)/(2.0*(fromIntegral nx)-1.0))) + + + + |] ) +{-# LINE 41 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | The function sin /x/ \/ /x/. + +sinc :: Double -> Double +sinc x = if (x /= 0.0) then (sin x) / x else 1.0 + + + +{-# LINE 46 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| sinc :: Double -> Double + sinc x = if (x /= 0.0) then (sin x) / x else 1.0 + + + + |] ) +{-# LINE 47 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | Auxiliary function. + +edgetoxy :: Int -> Int -> Int -> (Double, Double) +edgetoxy e nx ny = + let (ex,ey) = itoxy e nx ny in + if (ex < nx) then ((fromIntegral ex) + 0.5, fromIntegral ey) + else (fromIntegral (ex - nx + 1), (fromIntegral ey) + 0.5) + + + +{-# LINE 55 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| edgetoxy :: Int -> Int -> Int -> (Double, Double) + edgetoxy e nx ny = + let (ex,ey) = itoxy e nx ny in + if (ex < nx) then ((fromIntegral ex) + 0.5, fromIntegral ey) + else (fromIntegral (ex - nx + 1), (fromIntegral ey) + 0.5) + + + + |] ) +{-# LINE 56 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | Auxiliary function. The inputs are: +-- +-- * /y1/ :: 'Int' - Global edge index of row index of desired matrix element; +-- +-- * /y2/ :: 'Int' - Global edge index of column index of desired matrix element; +-- +-- * /nx/ :: 'Int' - Number of vertices left to right; +-- +-- * /ny/ :: 'Int' - Number of vertices top to bottom; +-- +-- * /lx/ :: 'Double' - Length of horizontal edges (distance between vertices in /x/ direction); +-- +-- * /ly/ :: 'Double' - Length of vertical edges (distance between vertices in /y/ direction); +-- +-- * /k/ :: 'Double' - Plane wave wavenumber. +-- +-- The output is the matrix element /A/(/y1/, /y2/). + +calcmatrixelement :: -- + -- Inputs + Int -- int y1 - Global edge index of row index of desired matrix element + -> Int -- int y2 - Global edge index of column index of desired matrix element + -> Int -- int nx - Number of vertices left to right + -> Int -- int ny - Number of vertices top to bottom + -> Double -- float lx - Length of horizontal edges (distance between vertices in x direction) + -> Double -- float ly - Length of vertical edges (distance between vertices in y direction) + -> Double -- float k - Plane wave wavenumber + -- Outputs + -> Complex Double -- float A - Matrix element A(y1,y2) +calcmatrixelement y1 y2 nx ny lx ly k = + let (xg1, yg1) = itoxy y1 nx ny in + let (xg2, yg2) = itoxy y2 nx ny in + let b = if ( (y1==y2) && (xg1 >= nx) ) then ly/lx - k*k*lx*ly/3.0 + -- B11 and B22 + else if ( (y1==y2) && (xg1=nx) ) then -ly/lx + k*k*lx*ly/12.0 + -- B13 + else if ( (yg1==(yg2+1)) && (xg1==(xg2-nx+1)) && (xg2>=nx) ) then -1.0 + -- B31 + else if ( (yg2==(yg1+1)) && (xg2==(xg1-nx+1)) && (xg1>=nx) ) then -1.0 + -- B14 + else if ( (yg1==(yg2+1)) && (xg1==(xg2-nx)) && (xg1=nx) ) then -1.0 + -- B24 + else if ( (yg2==yg1) && (xg2==(xg1+nx)) && (xg2>=nx) ) then -1.0 + -- B32 + else if ( (yg1==yg2) && (xg1==(xg2+nx-1)) && (xg2 Int + -> Int + -> Int + -> Double + -> Double + -> Double + + -> Complex Double + calcmatrixelement y1 y2 nx ny lx ly k = + let (xg1, yg1) = itoxy y1 nx ny in + let (xg2, yg2) = itoxy y2 nx ny in + let b = if ( (y1==y2) && (xg1 >= nx) ) then ly/lx - k*k*lx*ly/3.0 + + else if ( (y1==y2) && (xg1=nx) ) then -ly/lx + k*k*lx*ly/12.0 + + else if ( (yg1==(yg2+1)) && (xg1==(xg2-nx+1)) && (xg2>=nx) ) then -1.0 + + else if ( (yg2==(yg1+1)) && (xg2==(xg1-nx+1)) && (xg1>=nx) ) then -1.0 + + else if ( (yg1==(yg2+1)) && (xg1==(xg2-nx)) && (xg1=nx) ) then -1.0 + + else if ( (yg2==yg1) && (xg2==(xg1+nx)) && (xg2>=nx) ) then -1.0 + + else if ( (yg1==yg2) && (xg1==(xg2+nx-1)) && (xg2 [] + (x:tt) -> case tt of + [] -> [] + (y:t) -> (x,y):(get_edges (y:t)) + + +{-# LINE 126 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| get_edges l = case l of + [] -> [] + (x:tt) -> case tt of + [] -> [] + (y:t) -> (x,y):(get_edges (y:t)) + + + |] ) +{-# LINE 127 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | Auxiliary function. + +checkedge :: Int -> [(Double,Double)] -> Int -> Int -> Bool +checkedge e scatteringnodes nx ny = + let (xi,yi) = edgetoxy e nx ny in + let test_elt ((x1,y1),(x2, y2)) = xi >= x1 && yi >= y1 && xi <= x2 && yi <= y2 in + let half = take_half scatteringnodes in + let test_list = local_any test_elt (get_edges half) in (not test_list) + + + + + +{-# LINE 138 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| checkedge :: Int -> [(Double,Double)] -> Int -> Int -> Bool + checkedge e scatteringnodes nx ny = + let (xi,yi) = edgetoxy e nx ny in + let test_elt ((x1,y1),(x2, y2)) = xi >= x1 && yi >= y1 && xi <= x2 && yi <= y2 in + let half = take_half scatteringnodes in + let test_list = local_any test_elt (get_edges half) in (not test_list) + + + + + + |] ) +{-# LINE 139 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | Oracle /r/. + +calcRweights :: Int -> Int -> Int -> Double -> Double -> Double -> Double -> Double -> Complex Double +calcRweights y nx ny lx ly k theta phi = + let (xc',yc') = edgetoxy y nx ny in + let xc = (xc'-1.0)*lx - ((fromIntegral nx)-1.0)*lx/2.0 in + let yc = (yc'-1.0)*ly - ((fromIntegral ny)-1.0)*ly/2.0 in + let (xg,yg) = itoxy y nx ny in + + if (xg == nx) then + + let i = (mkPolar ly (k*xc*(cos phi)))* + (mkPolar 1.0 (k*yc*(sin phi)))* + ((sinc (k*ly*(sin phi)/2.0)) :+ 0.0) in + + let r = ( cos(phi) :+ k*lx )*((cos (theta - phi))/lx :+ 0.0) in i * r + + else if (xg==2*nx-1) then + + let i = (mkPolar ly (k*xc*cos(phi)))* + (mkPolar 1.0 (k*yc*sin(phi)))* + ((sinc (k*ly*sin(phi)/2.0)) :+ 0.0) in + + let r = ( cos(phi) :+ (- k*lx))*((cos (theta - phi))/lx :+ 0.0) in i * r + + + else if ( (yg==1) && (xg Int -> Int -> Double -> Double -> Double -> Double -> Double -> Complex Double + calcRweights y nx ny lx ly k theta phi = + let (xc',yc') = edgetoxy y nx ny in + let xc = (xc'-1.0)*lx - ((fromIntegral nx)-1.0)*lx/2.0 in + let yc = (yc'-1.0)*ly - ((fromIntegral ny)-1.0)*ly/2.0 in + let (xg,yg) = itoxy y nx ny in + + if (xg == nx) then + + let i = (mkPolar ly (k*xc*(cos phi)))* + (mkPolar 1.0 (k*yc*(sin phi)))* + ((sinc (k*ly*(sin phi)/2.0)) :+ 0.0) in + + let r = ( cos(phi) :+ k*lx )*((cos (theta - phi))/lx :+ 0.0) in i * r + + else if (xg==2*nx-1) then + + let i = (mkPolar ly (k*xc*cos(phi)))* + (mkPolar 1.0 (k*yc*sin(phi)))* + ((sinc (k*ly*sin(phi)/2.0)) :+ 0.0) in + + let r = ( cos(phi) :+ (- k*lx))*((cos (theta - phi))/lx :+ 0.0) in i * r + + + else if ( (yg==1) && (xg Int -> Int -> Int -> Int +convertband y b nx ny = + let nedges = (nx - 1)*ny + nx*(ny - 1) in + let (ex,ey) = itoxy y nx ny in + let x = if ( (ex < nx) && (ey /= 1) ) then + case b of + 1 -> y-2*nx+1 + 2 -> y-nx + 3 -> y-nx+1 + 5 -> y + 7 -> y+nx-1 + 8 -> y+nx + 9 -> y+2*nx-1 + _ -> -1 + else if ( (ex < nx) && (ey == 1) ) then + case b of + 5 -> y + 7 -> y+nx-1 + 8 -> y+nx + 9 -> y+2*nx-1 + _ -> -1 + else if ( (ex >= nx) && (ex /= nx) && (ex /= 2*nx-1) ) then + case b of + 2 -> y-nx + 3 -> y-nx+1 + 4 -> y-1 + 5 -> y + 6 -> y+1 + 7 -> y+nx-1 + 8 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == nx) ) then + case b of + 3 -> y-nx+1 + 5 -> y + 6 -> y+1 + 8 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == 2*nx-1) ) then + case b of + 2 -> y-nx + 4 -> y-1 + 5 -> y + 7 -> y+nx-1 + _ -> -1 + else -1 + in if ( (x < 1) || (x > nedges) ) then -1 else x + + + + + +{-# LINE 238 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| convertband :: Int -> Int -> Int -> Int -> Int + convertband y b nx ny = + let nedges = (nx - 1)*ny + nx*(ny - 1) in + let (ex,ey) = itoxy y nx ny in + let x = if ( (ex < nx) && (ey /= 1) ) then + case b of + 1 -> y-2*nx+1 + 2 -> y-nx + 3 -> y-nx+1 + 5 -> y + 7 -> y+nx-1 + 8 -> y+nx + 9 -> y+2*nx-1 + _ -> -1 + else if ( (ex < nx) && (ey == 1) ) then + case b of + 5 -> y + 7 -> y+nx-1 + 8 -> y+nx + 9 -> y+2*nx-1 + _ -> -1 + else if ( (ex >= nx) && (ex /= nx) && (ex /= 2*nx-1) ) then + case b of + 2 -> y-nx + 3 -> y-nx+1 + 4 -> y-1 + 5 -> y + 6 -> y+1 + 7 -> y+nx-1 + 8 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == nx) ) then + case b of + 3 -> y-nx+1 + 5 -> y + 6 -> y+1 + 8 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == 2*nx-1) ) then + case b of + 2 -> y-nx + 4 -> y-1 + 5 -> y + 7 -> y+nx-1 + _ -> -1 + else -1 + in if ( (x < 1) || (x > nedges) ) then -1 else x + + + + + + |] ) +{-# LINE 239 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | Oracle /A/. It is equivalent to the Matlab function +-- /getBandNodeValues/. +-- +-- 'getNodeValuesMoreOutputs' /v/ /b/ ... outputs the node of the +-- edge connected to vertex /v/ in band /b/, and a real number +-- parameterized by the 'BoolParam' parameter: the magnitude +-- ('PFalse') or the phase ('PTrue') of the complex value at the +-- corresponding place in the matrix /A/. + +getNodeValuesMoreOutputs :: + Int -> Int -> Int -> Int -> [(Double,Double)] -> Double -> Double -> Double -> BoolParam + -> Int -> (Int, Double) +getNodeValuesMoreOutputs v' b' nx ny scatteringnodes lx ly k argflag maxConnectivity = + let maxC = getIntFromParam maxConnectivity in + let b = getIntFromParam b' in + let nedges = (nx - 1)*ny + nx*(ny - 1) in + let flag = v' <= nedges in + let v = (if flag then v' else (v' - nedges)) in + let nodeDefault = (if flag then v + nedges else v) in + let valueDefault = 0.0 in + let indicesDefault = (-1, -1) in + let isvalid = checkedge v scatteringnodes nx ny + in + if ( (not isvalid) && b == 5 ) then + + let indices = (if flag then (v, v + nedges) else (v + nedges, v)) in + case argflag of + PTrue -> (nodeDefault, valueDefault) + PFalse -> (nodeDefault, 1.0) + + else if ( (not isvalid) && b /= 5) then (nodeDefault, valueDefault) + + else if ((b > maxC + 2) || (b <= 0)) then (nodeDefault, valueDefault) + + else + + let x = convertband v b' nx ny in + + if (x == -1) then (nodeDefault, valueDefault) + else + + let isvalid = checkedge x scatteringnodes nx ny in + + if isvalid then + + let ax = calcmatrixelement v x nx ny lx ly k in + let (node, indices) = if flag then (x + nedges, (v, x + nedges)) + else (x, (v+nedges,x)) in + let value = case argflag of + PTrue -> atan2 (imagPart ax) (realPart ax) + PFalse -> magnitude ax + in (node, value) + + else + (nodeDefault, valueDefault) + + + + + +{-# LINE 297 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| getNodeValuesMoreOutputs :: + Int -> Int -> Int -> Int -> [(Double,Double)] -> Double -> Double -> Double -> BoolParam + -> Int -> (Int, Double) + getNodeValuesMoreOutputs v' b' nx ny scatteringnodes lx ly k argflag maxConnectivity = + let maxC = getIntFromParam maxConnectivity in + let b = getIntFromParam b' in + let nedges = (nx - 1)*ny + nx*(ny - 1) in + let flag = v' <= nedges in + let v = (if flag then v' else (v' - nedges)) in + let nodeDefault = (if flag then v + nedges else v) in + let valueDefault = 0.0 in + let indicesDefault = (-1, -1) in + let isvalid = checkedge v scatteringnodes nx ny + in + if ( (not isvalid) && b == 5 ) then + + let indices = (if flag then (v, v + nedges) else (v + nedges, v)) in + case argflag of + PTrue -> (nodeDefault, valueDefault) + PFalse -> (nodeDefault, 1.0) + + else if ( (not isvalid) && b /= 5) then (nodeDefault, valueDefault) + + else if ((b > maxC + 2) || (b <= 0)) then (nodeDefault, valueDefault) + + else + + let x = convertband v b' nx ny in + + if (x == -1) then (nodeDefault, valueDefault) + else + + let isvalid = checkedge x scatteringnodes nx ny in + + if isvalid then + + let ax = calcmatrixelement v x nx ny lx ly k in + let (node, indices) = if flag then (x + nedges, (v, x + nedges)) + else (x, (v+nedges,x)) in + let value = case argflag of + PTrue -> atan2 (imagPart ax) (realPart ax) + PFalse -> magnitude ax + in (node, value) + + else + (nodeDefault, valueDefault) + + + + + + |] ) +{-# LINE 298 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | Auxiliary function for oracle /b/. The inputs are: +-- +-- * /y/ :: 'Int' - Global edge index. Note this is the unmarked /y/ +-- coordinate, i.e. the coordinate without scattering regions removed; +-- +-- * /nx/ :: 'Int' - Number of vertices left to right; +-- +-- * /ny/ :: 'Int' - Number of vertices top to bottom; +-- +-- * /lx/ :: 'Double' - Length of horizontal edges (distance between vertices in /x/ direction); +-- +-- * /ly/ :: 'Double' - Length of vertical edges (distance between vertices in /y/ direction); +-- +-- * /k/ :: 'Double' - Plane wave wavenumber; +-- +-- * θ :: 'Double' - Direction of wave propagation; +-- +-- * /E0/ :: 'Double' - Magnitude of incident plane wave. +-- +-- The output is the magnitude of the electric field on edge /y/. + +calcincidentfield :: -- + -- Inputs + Int -- int y - Global edge index. Note this is the unmarked y coordinate, + -- i.e. the coordinate without scattering regions removed. + -> Int -- int nx - Number of vertices left to right + -> Int -- int ny - Number of vertices top to bottom + -> Double -- float lx - Length of horizontal edges (distance between vertices in x direction) + -> Double -- float ly - Length of vertical edges (distance between vertices in y direction) + -> Double -- float k - Plane wave wavenumber + -> Double -- float theta - Direction of wave propagation + -> Double -- float E0 - Magnitude of incident plane wave + -- Outputs + -> Complex Double -- complex float e - Magnitude of electric field on edge y +calcincidentfield y nx ny lx ly k theta e0 = + let (xg, yg) = itoxy y nx ny in + --Determine whether edge is horizontal or vertical + let isvertical = xg >= nx in + let (xvalueTmp, yvalueTmp) = edgetoxy y nx ny in + let xvalue = xvalueTmp * lx in + let yvalue = yvalueTmp * ly in + -- Convert x and y edge coordinates to x and y values and caluculate field + if isvertical then + mkPolar (-cos(theta)*e0) ( -k*(xvalue*cos(theta)+yvalue*sin(theta))) + else + mkPolar (sin(theta)*e0) ( -k*(xvalue*cos(theta)+yvalue*sin(theta))) + + + +{-# LINE 345 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| calcincidentfield :: + + Int + + -> Int + -> Int + -> Double + -> Double + -> Double + -> Double + -> Double + + -> Complex Double + calcincidentfield y nx ny lx ly k theta e0 = + let (xg, yg) = itoxy y nx ny in + + let isvertical = xg >= nx in + let (xvalueTmp, yvalueTmp) = edgetoxy y nx ny in + let xvalue = xvalueTmp * lx in + let yvalue = yvalueTmp * ly in + + if isvertical then + mkPolar (-cos(theta)*e0) ( -k*(xvalue*cos(theta)+yvalue*sin(theta))) + else + mkPolar (sin(theta)*e0) ( -k*(xvalue*cos(theta)+yvalue*sin(theta))) + + + + |] ) +{-# LINE 346 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | Auxiliary function for oracle /b/. + +getconnection :: Int -> Int -> Int -> Int -> Int -> Int +getconnection y i' nx ny maxConnectivity = + let i = getIntFromParam i' in + let maxC = getIntFromParam maxConnectivity in + let (ex,ey) = itoxy y nx ny in + let x = if ( (ex < nx) && (ey /= 1) ) then + case i' of + 1 -> y-2*nx+1 + 2 -> y-nx + 3 -> y-nx+1 + 4 -> y + 5 -> y+nx-1 + 6 -> y+nx + 7 -> y+2*nx-1 + _ -> -1 + else if ( (ex < nx) && (ey == 1) ) then + case i' of + 1 -> y + 2 -> y+nx-1 + 3 -> y+nx + 4 -> y+2*nx-1 + _ -> -1 + else if ( (ex >= nx) && (ex /= nx) && (ex /= 2*nx-1) ) then + case i' of + 1 -> y-nx + 2 -> y-nx+1 + 3 -> y-1 + 4 -> y + 5 -> y+1 + 6 -> y+nx-1 + 7 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == nx) ) then + case i' of + 1 -> y-nx+1 + 2 -> y + 3 -> y+1 + 4 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == 2*nx-1) ) then + case i' of + 1 -> y-nx + 2 -> y-1 + 3 -> y + 4 -> y+nx-1 + _ -> -1 + else -1 + in + if (i > maxC) then -1 + else if (x > nx*(ny-1)+ny*(nx-1)) then -1 + else x + + + + +{-# LINE 401 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| getconnection :: Int -> Int -> Int -> Int -> Int -> Int + getconnection y i' nx ny maxConnectivity = + let i = getIntFromParam i' in + let maxC = getIntFromParam maxConnectivity in + let (ex,ey) = itoxy y nx ny in + let x = if ( (ex < nx) && (ey /= 1) ) then + case i' of + 1 -> y-2*nx+1 + 2 -> y-nx + 3 -> y-nx+1 + 4 -> y + 5 -> y+nx-1 + 6 -> y+nx + 7 -> y+2*nx-1 + _ -> -1 + else if ( (ex < nx) && (ey == 1) ) then + case i' of + 1 -> y + 2 -> y+nx-1 + 3 -> y+nx + 4 -> y+2*nx-1 + _ -> -1 + else if ( (ex >= nx) && (ex /= nx) && (ex /= 2*nx-1) ) then + case i' of + 1 -> y-nx + 2 -> y-nx+1 + 3 -> y-1 + 4 -> y + 5 -> y+1 + 6 -> y+nx-1 + 7 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == nx) ) then + case i' of + 1 -> y-nx+1 + 2 -> y + 3 -> y+1 + 4 -> y+nx + _ -> -1 + else if ( (ex >= nx) && (ex == 2*nx-1) ) then + case i' of + 1 -> y-nx + 2 -> y-1 + 3 -> y + 4 -> y+nx-1 + _ -> -1 + else -1 + in + if (i > maxC) then -1 + else if (x > nx*(ny-1)+ny*(nx-1)) then -1 + else x + + + + + |] ) +{-# LINE 402 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | Auxiliary function to @'template_paramZero'@. + +local_loop_with_index_aux :: Int -> Int -> t -> (Int -> t -> t) -> t +local_loop_with_index_aux i n x f = + case paramMinus n i of + 0 -> x + _ -> local_loop_with_index_aux (paramSucc i) n (f i x) f + + + +{-# LINE 410 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| local_loop_with_index_aux :: Int -> Int -> t -> (Int -> t -> t) -> t + local_loop_with_index_aux i n x f = + case paramMinus n i of + 0 -> x + _ -> local_loop_with_index_aux (paramSucc i) n (f i x) f + + + + |] ) +{-# LINE 411 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | Local version of @'loop_with_index'@, for lifting. + +local_loop_with_index :: Int -> t -> (Int -> t -> t) -> t +local_loop_with_index n x f = local_loop_with_index_aux paramZero n x f + + + +{-# LINE 416 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| local_loop_with_index :: Int -> t -> (Int -> t -> t) -> t + local_loop_with_index n x f = local_loop_with_index_aux paramZero n x f + + + + |] ) +{-# LINE 417 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +-- | Oracle /b/. + +getKnownWeights :: Int -> Int -> Int -> [(Double,Double)] -> Double -> Double -> Double -> Double -> Double -> Int -> Complex Double +getKnownWeights y nx ny scatteringnodes lx ly k theta e0 maxConnectivity = + let makeConnections i connections = let x = getconnection y (paramSucc i) nx ny maxConnectivity in + let t = not $ checkedge x scatteringnodes nx ny in + (x,t):connections + in + let calcTang b (c,t) = if t + then let matElt = calcmatrixelement y c nx ny lx ly k in + let incField = calcincidentfield c nx ny lx ly k theta e0 + in b - matElt * incField + else b + in + let connections = local_loop_with_index maxConnectivity [] makeConnections in + if (not $ checkedge y scatteringnodes nx ny) then 0.0 :+ 0.0 + else foldl calcTang (0.0 :+ 0.0) connections + + + + + + +{-# LINE 438 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +$( decToCircMonad [d| getKnownWeights :: Int -> Int -> Int -> [(Double,Double)] -> Double -> Double -> Double -> Double -> Double -> Int -> Complex Double + getKnownWeights y nx ny scatteringnodes lx ly k theta e0 maxConnectivity = + let makeConnections i connections = let x = getconnection y (paramSucc i) nx ny maxConnectivity in + let t = not $ checkedge x scatteringnodes nx ny in + (x,t):connections + in + let calcTang b (c,t) = if t + then let matElt = calcmatrixelement y c nx ny lx ly k in + let incField = calcincidentfield c nx ny lx ly k theta e0 + in b - matElt * incField + else b + in + let connections = local_loop_with_index maxConnectivity [] makeConnections in + if (not $ checkedge y scatteringnodes nx ny) then 0.0 :+ 0.0 + else foldl calcTang (0.0 :+ 0.0) connections + + + + + + + |] ) +{-# LINE 439 "Quipper/Algorithms/QLS/TemplateOracle.hs" #-} +---------------------------------------------------------------------- +---------------------------------------------------------------------- +-- Testing functions + +test_template_sinc = do + f <- template_sinc + r <- qinit (0 :: FDouble) + f r + return () + +test_template_itoxy = do + f <- template_itoxy + x <- qinit (0 :: FSignedInt) + y <- qinit (0 :: FSignedInt) + z <- qinit (0 :: FSignedInt) + g <- f x + h <- g y + k <- h z + return () + +test_template_edgetoxy = do + f <- template_edgetoxy + x <- qinit (0 :: FSignedInt) + y <- qinit (0 :: FSignedInt) + z <- qinit (0 :: FSignedInt) + g <- f x + h <- g y + k <- h z + return () + +test_template_calcRweights = do + f <- template_calcRweights + n1 <- qinit (0 :: FSignedInt) + n2 <- qinit (0 :: FSignedInt) + n3 <- qinit (0 :: FSignedInt) + x1 <- qinit (0 :: FDouble) + x2 <- qinit (0 :: FDouble) + x3 <- qinit (0 :: FDouble) + x4 <- qinit (0 :: FDouble) + x5 <- qinit (0 :: FDouble) + f1 <- f n1 + f2 <- f1 n2 + f3 <- f2 n3 + g1 <- f3 x1 + g2 <- g1 x2 + g3 <- g2 x3 + g4 <- g3 x4 + g5 <- g4 x5 + return () + +test_template_calcincidentfield = do + y' <- qinit (0 :: FSignedInt) + nx' <- qinit (0 :: FSignedInt) + ny' <- qinit (0 :: FSignedInt) + lx' <- qinit (0 :: FDouble) + ly' <- qinit (0 :: FDouble) + k' <- qinit (0 :: FDouble) + theta' <- qinit (0 :: FDouble) + e0' <- qinit (0 :: FDouble) + f <- template_calcincidentfield + f1 <- f y' + f2 <- f1 nx' + f3 <- f2 ny' + f4 <- f3 lx' + f5 <- f4 ly' + f6 <- f5 k' + f7 <- f6 theta' + f8 <- f7 e0' + return () + +test_template_calcmatrixelement = do + y1 <- qinit (0 :: FSignedInt) + y2 <- qinit (0 :: FSignedInt) + nx <- qinit (0 :: FSignedInt) + ny <- qinit (0 :: FSignedInt) + lx <- qinit (0 :: FDouble) + ly <- qinit (0 :: FDouble) + k <- qinit (0 :: FDouble) + f <- template_calcmatrixelement + f1 <- f y1 + f2 <- f1 y2 + f3 <- f2 nx + f4 <- f3 ny + f5 <- f4 lx + f6 <- f5 ly + f7 <- f6 k + return () + +test_template_getconnection = do + y <- qinit (0 :: FSignedInt) + nx <- qinit (0 :: FSignedInt) + ny <- qinit (0 :: FSignedInt) + f <- template_getconnection + f1 <- f y + f2 <- f1 6 + f3 <- f2 nx + f4 <- f3 ny + f5 <- f4 7 + return () + +test_template_checkedge = do + y <- qinit (0 :: FSignedInt) + nx <- qinit (0 :: FSignedInt) + ny <- qinit (0 :: FSignedInt) + s <- qinit [(0 :: FDouble,0 :: FDouble),(0 :: FDouble,0 :: FDouble)] + f <- template_checkedge + f1 <- f y + f2 <- f1 s + f3 <- f2 nx + f4 <- f3 ny + return () + diff --git a/dist/build/Quipper/Algorithms/QLS/Utils.hs b/dist/build/Quipper/Algorithms/QLS/Utils.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/QLS/Utils.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/QLS/Utils.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + + +-- | This module defines some auxiliary machinery required for the QLS algorithm. +module Quipper.Algorithms.QLS.Utils where + +import Quipper +import Control.Monad +import Data.List + +import Quipper.Internal.Control + +import qualified Data.Map as Map + + +-- * Hard-coded default sizes for quantum numbers + +-- | Default size of a register +-- 'Quipper.Algorithms.QLS.QSignedInt.QSignedInt' (not counting the +-- sign). +fixed_int_register_length :: Int +fixed_int_register_length = 32 + +-- | Default size for the /xxx/ part of the +-- 'Quipper.Algorithms.QLS.QDouble.QDouble' /xxx.yyy/. +before_radix_length :: Int +before_radix_length = 32 + +-- | Default size for the /yyy/ part of the +-- 'Quipper.Algorithms.QLS.QDouble.QDouble' /xxx.yyy/. +after_radix_length :: Int +after_radix_length = 32 + + + +-- * Miscellaneous utilities + +-- | Compose a function with itself /n/ times. +ncompose :: Int -> (a -> a) -> a -> a +ncompose 0 f x = x +ncompose n f x = ncompose (n-1) f (f x) + +-- | Specialized 'map' for lists of pairs. +listpair_fmap :: (a -> b) -> [(a,a)] -> [(b,b)] +listpair_fmap f t = map (\(x,y) -> (f x,f y)) t + + diff --git a/dist/build/Quipper/Algorithms/TF/Alternatives.hs b/dist/build/Quipper/Algorithms/TF/Alternatives.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/TF/Alternatives.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/TF/Alternatives.hs" #-} +-- | This module contains various supplementary functions related +-- to the Triangle Finding algorithm: alternatives to and/or +-- generalizations of the various routines in +-- 'Quipper.Algorithms.TF.Oracle' and 'Quipper.Algorithms.TF.QWTFP'. + +module Quipper.Algorithms.TF.Alternatives where + +import Quipper +import Quipper.Algorithms.TF.Definitions +import Quipper.Libraries.Qram +import Quipper.Libraries.Arith + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + +-- ====================================================================== +-- * Arithmetic functions + +-- | Increment a 'QIntTF' (i.e., little-endian, mod 2[sup /l/] – 1) +-- in place. +-- +-- This and 'decrement_TF' assume as precondition that the input is never +-- 11…11, and preserve this condition, by fixing 11…11. This means these +-- are /not/ correct if 'IntTF' is treated as a formal quotient of +-- 2[sup /l/] ; with that approach, incrementing/decrementing in place +-- cannot be a quantum operation (since it must map 00…00 and 11…11 both +-- to 00…01, so would have nonzero kernel). These are however correct if +-- 'IntTF' is considered as a formal /subspace/ of 2[sup /l/] (in which +-- case the other arithmetic routines are unsound, since they may break +-- the precondition). +increment_TF :: QIntTF -> Circ QIntTF +increment_TF l1 = do + let l = qulist_of_qinttf_lh l1 + -- mark whether /l/ is initially in forbidden state “all true”: + is_bad <- qinit False + is_bad <- qnot is_bad `controlled` [ q .==. 1 | q <- l ] + -- now, increment /l/ treating it mod 2^/n/: + l' <- increment_big (reverse l) + l <- return $ reverse l' + -- now mark if the /incremented/ /l/ is “all true”: + needs_rollover <- qinit False + needs_rollover <- qnot needs_rollover `controlled` [ q .==. 1 | q <- l ] + -- if it’s now “all true”, roll it over; or if it initially was, roll it back: + l <- mapM (\q -> do + q <- qnot q `controlled` is_bad + q <- qnot q `controlled` needs_rollover + return q) + l + -- finally, uncompute the ancillas: + needs_rollover <- qnot needs_rollover `controlled` [ q .==. 0 | q <- l ] + qterm False needs_rollover + is_bad <- qnot is_bad `controlled` [ q .==. 1 | q <- l ] + qterm False is_bad + return (qinttf_of_qulist_lh l) + + +-- | Decrement a 'QIntTF' in place. +decrement_TF :: QIntTF -> Circ QIntTF +decrement_TF l1 = do + let l = qulist_of_qinttf_lh l1 + -- mark whether /l/ is initially in forbidden state “all true”: + with_ancilla $ \is_bad -> do + is_bad <- qnot is_bad `controlled` [ q .==. 1 | q <- l ] + -- also mark if /l/ is “all false”: + l <- with_ancilla $ \needs_rollover -> do + needs_rollover <- qnot needs_rollover `controlled` [ q .==. 0 | q <- l ] + -- exchange these two states: + l <- mapM (\q -> do + q <- qnot q `controlled` is_bad + q <- qnot q `controlled` needs_rollover + return q) + l + -- uncompute @needs_rollover@ + needs_rollover <- qnot needs_rollover `controlled` [ q .==. 1 | q <- l ] + return l + -- now, decrement /l/ treating it mod 2^/n/: + l' <- decrement_big (reverse l) + -- finally, uncompute is_bad: + is_bad <- qnot is_bad `controlled` [ q .==. 1 | q <- l' ] + return (qinttf_of_qulist_lh (reverse l')) + +-- | An alternative to 'Quipper.Algorithms.TF.Oracle.o5_MOD3' for +-- reducing mod-3, conceptually simpler and not size-limited: uses the +-- fact that 2-bit 'QIntTF's give us true mod-3 arithmetic. +-- +-- Has same complexity /O(l)/ as +-- 'Quipper.Algorithms.TF.Oracle.o5_MOD3', with (probably) a slightly +-- higher leading coefficient, due to difference in size between +-- 'increment_TF' and 'increment_little'. +o5_MOD3_alt :: QIntTF -> Circ (QIntTF,QIntTF) +o5_MOD3_alt x1 = do + let x = qulist_of_qinttf_lh x1 + let l = length x + + m <- qinit (inttf 2 0) + (x,m) <- loop_with_indexM l (x,m) (\i (x,m) -> do + m <- if (even i) + then increment_TF m `controlled` (x !! i) + else decrement_TF m `controlled` (x !! i) + return (x,m)) + return (qinttf_of_qulist_lh x, m) + +-- ====================================================================== +-- * Efficient qRAM + +-- $ We provide an efficient qRAM implementation in "Quipper.Libraries.Qram". +-- The following turns it into a 'Qram' object for the Triangle +-- Finding algorithm. + +-- | Efficient qRAM \"fetch\" operation. @'indexed_fetch' /i/ /m/ /q/@ +-- performs the operation /q/ ⊕= /m/[/i/]. +indexed_fetch :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +indexed_fetch i m q = do + indexed_fetch_at qs i q + return (i,m,q) + where + qs = IntMap.elems m + +-- | Efficient qRAM \"store\" operation. @'indexed_store' /i/ /m/ /q/@ +-- performs the operation /m/[/i/] ⊕= /q/. +indexed_store :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +indexed_store i m q = do + indexed_store_at qs i q + return (i,m,q) + where + qs = IntMap.elems m + +-- | Efficient qRAM \"swap\" operation. @'indexed_swap' /i/ /m/ /q/@ +-- swaps /q/ and /m/[/i/]. +indexed_swap :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +indexed_swap i m q = do + indexed_swap_at qs i q + return (i,m,q) + where + qs = IntMap.elems m + +-- | Our efficient qRAM implementation wrapped in a 'Qram' object. +alt_qram :: Qram +alt_qram = Qram { + qram_fetch = indexed_fetch, + qram_store = indexed_store, + qram_swap = indexed_swap +} diff --git a/dist/build/Quipper/Algorithms/TF/Definitions.hs b/dist/build/Quipper/Algorithms/TF/Definitions.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/TF/Definitions.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/TF/Definitions.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE IncoherentInstances #-} + +-- | This module provides global definitions for the Triangle Finding Algorithm. + +module Quipper.Algorithms.TF.Definitions where + +import Prelude hiding (mapM, mapM_) +import qualified Data.Map as Map +import Data.IntMap (IntMap, Key) +import qualified Data.IntMap as IntMap +import Data.Traversable (mapM) +import Data.Foldable (mapM_) +import Data.Typeable (Typeable) + +import Quipper +import Quipper.Internal +import Quipper.Libraries.Arith + +import Quipper.Utils.Auxiliary (mmap) + +-- ====================================================================== +-- * Qram abstraction + +-- | A data structure to hold a Qram implementation. This provides +-- operations for fetching and storing quantum data from a quantum +-- array, addressed by a quantum integer. One implementation is given +-- by algorithms 'Quipper.Algorithms.TF.QWTFP.a8_FetchT', +-- 'Quipper.Algorithms.TF.QWTFP.a9_StoreT' and +-- 'Quipper.Algorithms.TF.QWTFP.a10_FetchStoreT'. + +data Qram = Qram { + qram_fetch :: forall qa.(QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa), + qram_store :: forall qa.(QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa), + qram_swap :: forall qa.(QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +} + +-- ====================================================================== +-- * Types for the Triangle Finding Algorithm + +-- As synonyms, these first few types are all automatically instances of QCData. + +-- | A node of the graph (classical circuit type). +type CNode = [Bit] + +-- | A node of the graph (quantum circuit type). +type QNode = [Qubit] + +-- | The type of problem specifications for the Triangle Finding Problem. A problem +-- specification consists of: +-- +-- * an integer /n/ which determines the number /N=//2/[sup /n/] of nodes of the graph, +-- +-- * an integer /r/ which determines the size /R=//2/[sup /r/] of tuples in the Hamming +-- graph, +-- +-- * a function /edge_oracle/ which inputs two graph nodes and a qubit and flips the qubit +-- if the nodes are connected by an edge and +-- +-- * additional options, for selecting, e.g., which qRAM implementation should be used. +type QWTFP_spec = (Int, Int, QNode -> QNode -> Qubit -> Circ Qubit, Qram) + +-- ====================================================================== +-- * TF integers + +-- ---------------------------------------------------------------------- +-- ** Types + +-- $ We define a 'QData' family of integer datatypes ('QIntTF', +-- 'CIntTF', 'IntTF'). These are similar to ('QDInt', 'CInt', 'IntM'), +-- except that the integers are considered to be mod 2[sup /m/]-1 instead +-- of 2[sup /m/]. +-- +-- In general, functions on these types should be able to handle both 00…00 and 11…11, +-- and should treat them equally, essentially regarding 'IntTF', 'CIntTF', and the +-- computational basis of 'QIntTF' as formal quotients. +-- Some operations are not perfect. One should keep in mind, for example, that specifying +-- a control on a 'QIntTF' of the form @/q/ .==. 0@ will compare the bitwise representation +-- to 0, and not the logical quotient. + +-- | All three types 'QIntTF', 'CIntTF', and 'IntTF' are special cases +-- of a more general type 'XIntTF' /x/, parameterized by a type /x/ of +-- bits. It is an abstract type, and details of its implementation is +-- not exposed to user-level code. +data XIntTF x = XIntTF (XInt x) + deriving (Show, Typeable) + +-- | The type of fixed-length /m/-qubit quantum integers, regarded +-- modulo 2[sup /m/]-1. +type QIntTF = XIntTF Qubit + +-- | The type of fixed-length /m/-bit classical integers, regarded +-- modulo 2[sup /m/]-1. +type CIntTF = XIntTF Bit + +-- | The type of fixed-length /m/-bit integer parameters, regarded +-- modulo 2[sup /m/]-1. A value of type 'IntTF' may have indeterminate +-- length, similarly to 'IntM'. +type IntTF = XIntTF Bool + +-- ---------------------------------------------------------------------- +-- ** Operations for IntTF + +-- | Convert an 'IntTF' of length /m/ to an 'Integer' in the range {0, +-- …, 2[sup /m/]-2}. If the 'IntTF' has indeterminate length, return +-- the original 'Integer'. +integer_of_inttf :: IntTF -> Integer +integer_of_inttf (XIntTF x) = + case intm_length x of + Just m -> (integer_of_intm_unsigned x) `mod` (2^m - 1) + Nothing -> integer_of_intm_unsigned x + +-- | Convert an 'Integer' to an 'IntTF' of indeterminate length. +inttf_of_integer :: Integer -> IntTF +inttf_of_integer n = XIntTF (intm_of_integer n) + +-- | Convert an 'Integer' to an 'IntTF' of length /m/. +inttf :: Int -> Integer -> IntTF +inttf m n = XIntTF (intm m n') + where + n' = n `mod` (2^m-1) + +-- | Return the length of an 'IntTF', or 'Nothing' if indeterminate. +inttf_length :: IntTF -> Maybe Int +inttf_length = intm_length . xint_of_xinttf + +instance Eq IntTF where + x == y = + case inttf_length x' of + Just m -> (integer_of_inttf x') `mod` (2^m - 1) == (integer_of_inttf y') `mod` (2^m - 1) + Nothing -> x' == y' + where + x' = inttf_promote x y errstr + y' = inttf_promote y x errstr + errstr = "Equality test on IntTF: operands must be of equal length" + +-- | Set the length of an 'IntTF' to /m/ ≥ 0. This operation is only +-- legal if the input (a) has indeterminate length or (b) has +-- determinate length already equal to /m/. In particular, it cannot +-- be used to change the length from anything other than from +-- indeterminate to determinate. +-- +-- If both arguments already have determinate lengths, and they do not +-- coincide, throw an error. The 'String' argument is used as an error +-- message in that case. +inttf_set_length :: Int -> IntTF -> String -> IntTF +inttf_set_length m (XIntTF x) errmsg | m < 0 = + error "inttf_set_length: negative length not permitted" +inttf_set_length m (XIntTF x) errmsg = + case intm_length x of + Just n | m==n -> (XIntTF x) + | otherwise -> error errmsg + Nothing -> XIntTF (intm m n) + where + -- Here "unsigned" or "signed" doesn't matter, since this is + -- the indeterminate case, where the original integer is + -- returned. + n = integer_of_intm_unsigned x `mod` (2^m - 1) + +-- | Try to set the length of an 'IntTF' to that of another 'XIntTF' +-- value (which could be a 'QIntTF', a 'CIntTF', or another 'IntTF'). This +-- will fail with an error if both numbers already have determinate +-- lengths that don't coincide. In this case, the string argument is +-- used as an error message. The promotion is done modulo 2[sup /m/]-1. +inttf_promote :: IntTF -> XIntTF x -> String -> IntTF +inttf_promote b (XIntTF x) errmsg = + case xint_maybe_length x of + Nothing -> b + Just m -> inttf_set_length m b errmsg + +-- | Convert an 'IntTF' to human readable form. We show the bit value, +-- i.e., 0 and 2[sup /m/]-1 are shown as different values. +show_inttf :: IntTF -> String +show_inttf x = + case inttf_length x of + Nothing -> "IntTF -- " ++ show (integer_of_inttf x) + Just m -> "IntTF " ++ show m ++ " " ++ show (integer_of_intm_unsigned (xint_of_xinttf x)) + +-- make 'IntTF' an (overlapping) instance of 'Show': +instance Show IntTF where + show = show_inttf + +-- ---------------------------------------------------------------------- +-- ** Operations for QIntTF + +-- | Convert a 'QIntTF' to a list of qubits. The conversion is +-- little-headian, i.e., the head of the list holds the least +-- significant digit. +qulist_of_qinttf_lh :: QIntTF -> [Qubit] +qulist_of_qinttf_lh = reverse . qulist_of_qdint_bh . xint_of_xinttf + +-- | Convert a list of qubits to a 'QIntTF'. The conversion is +-- little-headian, i.e., the head of the list holds the least +-- significant digit. +qinttf_of_qulist_lh :: [Qubit] -> QIntTF +qinttf_of_qulist_lh = xinttf_of_xint . qdint_of_qulist_bh . reverse + +-- | Return a piece of shape data to represent an /m/-qubit +-- 'QIntTF'. Please note that the data can only be used as shape; it +-- will be undefined at the leaves. +qinttf_shape :: Int -> QIntTF +qinttf_shape = xinttf_of_xint . qdint_shape + +-- ---------------------------------------------------------------------- +-- ** Auxiliary functions + +-- | The low-level isomorphism from 'XInt' /x/ to 'XIntTF' /x/. Note +-- that \"isomorphism\" is between the underlying raw types, and does not +-- respect the arithmetic operations. +xinttf_of_xint :: XInt x -> XIntTF x +xinttf_of_xint = XIntTF + +-- | The low-level isomorphism from 'XIntTF' /x/ to 'XInt' /x/. Note +-- that \"isomorphism\" is between the underlying raw types, and does not +-- respect the arithmetic operations. +xint_of_xinttf :: XIntTF x -> XInt x +xint_of_xinttf (XIntTF x) = x + +-- | Like 'xint_of_xinttf', but first try to promote the length of the +-- 'IntTF' to that of the given 'XIntTF'. +xint_with_promote :: XIntTF y -> IntTF -> IntM +xint_with_promote x b = xint_of_xinttf b' where + b' = inttf_promote b x "xint_with_promote: length change not permitted" + +-- ---------------------------------------------------------------------- +-- The QCData instance + +type instance QCType x y (XIntTF z) = XIntTF (QCType x y z) +type instance QTypeB IntTF = QIntTF + +instance QCLeaf x => QCData (XIntTF x) where + qcdata_mapM shape f g xs = + mmap xinttf_of_xint $ qcdata_mapM (xint_of_xinttf shape) f g (xint_of_xinttf xs) + qcdata_zip shape q c q' c' xs ys e = + xinttf_of_xint $ qcdata_zip (xint_of_xinttf shape) q c q' c' (xint_of_xinttf xs) (xint_of_xinttf ys) errmsg + where + errmsg x = e "QDInt length mismatch" + qcdata_promote b q e = inttf_promote b q errmsg + where + errmsg = e "IntM length mismatch" + +-- Labeling of QIntTF is s[m-1], ..., s[0], with the least significant +-- bit at index 0. +instance QCLeaf x => Labelable (XIntTF x) String where + label_rec qa = label_rec (xint_of_xinttf qa) + +-- ====================================================================== +-- * Miscellaneous circuit-building functions + + +-- | Controlled phase flip of -1. +phaseFlipIf :: (ControlSource ctrl) => ctrl -> Circ () +phaseFlipIf ctrl = do + -- why would one do an uncontrolled phase flip? Because it could be + -- part of a subroutine that will later get controlled. + global_phase 1.0 `controlled` ctrl + +-- | Variant of 'phaseFlipIf' that performs a phase flip /unless/ all +-- controls are in the given state. +phaseFlipUnless :: (ControlSource ctrl) => ctrl -> Circ () +phaseFlipUnless ctrls = do + global_phase 1.0 + global_phase 1.0 `controlled` ctrls + +-- | @qor q c@: Applies \"not\" to /q/, if /any/ of the control qubits +-- in /c/ is in specified state. +qor :: Qubit -> [(Qubit,Bool)] -> Circ Qubit +qor q cs = do + q <- qnot q + q <- qnot q `controlled` (map (\(p,b) -> (p .==. not b)) cs) + return q + +-- ====================================================================== +-- * Arithmetic functions + +-- | Increment a standard 'QDInt' (i.e. big-endian, mod 2[sup ℓ]). +increment :: QDInt -> Circ QDInt +increment x = do + comment_with_label "ENTER: increment" x "x" + x <- mmap qdint_of_qulist_bh . increment_big . qulist_of_qdint_bh $ x + comment_with_label "EXIT: increment" x "x" + return x + +-- | Decrement a standard 'QDInt' (i.e. big-endian, mod 2[sup ℓ]). +decrement :: QDInt -> Circ QDInt +decrement x = do + comment_with_label "ENTER: decrement" x "x" + x <- mmap qdint_of_qulist_bh . decrement_big . qulist_of_qdint_bh $ x + comment_with_label "EXIT: decrement" x "x" + return x + +-- | Increment a bit-string, considered as a big-endian integer mod 2[sup ℓ]. +increment_big :: [Qubit] -> Circ [Qubit] +increment_big [] = return [] +increment_big (i_high:i_lower) = do + i_high <- qnot i_high `controlled` i_lower + i_lower <- increment_big i_lower + return (i_high:i_lower) + +-- | Decrement a bit-string, considered as a big-endian integer mod 2[sup ℓ]. +decrement_big :: [Qubit] -> Circ [Qubit] +decrement_big [] = return [] +decrement_big (i_high:i_lower) = do + i_lower <- decrement_big i_lower + i_high <- qnot i_high `controlled` i_lower + return (i_high:i_lower) + +-- | Increment a bit-string, considered as a little-endian integer mod 2[sup ℓ]. +increment_little :: [Qubit] -> Circ [Qubit] +increment_little [] = return [] +increment_little (i_low:i_higher) = do + i_higher <- increment_little i_higher `controlled` i_low + i_low <- qnot i_low + return (i_low:i_higher) + +-- | Decrement a bit-string, considered as a little-endian integer mod 2[sup ℓ]. +decrement_little :: [Qubit] -> Circ [Qubit] +decrement_little [] = return [] +decrement_little (i_low:i_higher) = do + i_low <- qnot i_low + i_higher <- decrement_little i_higher `controlled` i_low + return (i_low:i_higher) + +-- | The standard “combinations” function “/n/ choose /k/”. +choose :: (Integral a) => a -> a -> a +choose n 0 = 1 +choose 0 k = 0 +choose n k = ((choose (n-1) (k-1)) * n) `div` k + +-- ====================================================================== +-- * IntMaps as QData + +-- | Replace an 'IntMap' /f/ with the 'IntMap' mapping each key /k/ to (/k/,/f(k)/). An auxiliary function for defining 'mapWithKeyM', etc. +addKeys :: IntMap a -> IntMap (Key,a) +addKeys = IntMap.mapWithKey (\k x -> (k,x)) + +-- | Analogous to 'mapM', but allows the function to use the key. Particularly useful for mapping in parallel over two (or more) 'IntMap's assumed to have the same domain. +mapWithKeyM :: (Monad m) => (IntMap.Key -> a -> m b) -> IntMap a -> m (IntMap b) +mapWithKeyM f as = mapM (\(k,x) -> f k x) (addKeys as) + +-- | Analogous to 'mapM_', but allows the function to use the key. +mapWithKeyM_ :: (Monad m) => (IntMap.Key -> a -> m b) -> IntMap a -> m () +mapWithKeyM_ f as = mapM_ (\(k,x) -> f k x) (addKeys as) + +-- | Analogous to 'replicate' on lists. +intMap_replicate :: Int -> a -> IntMap a +intMap_replicate n x = IntMap.fromList [(i,x) | i <- [0..n-1]] + +infixl 9 ! + +-- | Convenient syntax for accessing elements of an 'IntMap'. Left associative, and binds very strongly, like '(!!)'. +(!) :: IntMap a -> IntMap.Key -> a +xs ! k = let (Just x) = IntMap.lookup k xs in x + +type instance QCType x y (IntMap a) = IntMap (QCType x y a) +type instance QTypeB (IntMap a) = IntMap (QTypeB a) + +instance QCData a => QCData (IntMap a) where + qcdata_mapM a f g xs = + intmap_mapM (qcdata_mapM a' f g) xs + where a' = shape $ a IntMap.! 0 + + qcdata_zip a q c q' c' xs ys e = + intmap_map (\(x,y) -> qcdata_zip a' q c q' c' x y e) (intmap_zip_errmsg xs ys errmsg) + where + a' = shape $ a IntMap.! 0 + errmsg = e "IntMap domains do not agree" + + qcdata_promote as xs e + | IntMap.keys as /= IntMap.keys xs = error errmsg + | otherwise = + intmap_map (\(a,x) -> qcdata_promote a x e) (intmap_zip_errmsg as xs errmsg) + where + errmsg = e "IntMap domains do not agree" + +instance (Labelable a String) => Labelable (IntMap a) String where + label_rec xs s = do + sequence_ [ label_rec x s `indexed` show i | (i,x) <- IntMap.toList xs ] + +instance (Labelable a s) => Labelable (IntMap a) (IntMap s) where + label_rec xs ss = do + sequence_ [ label_rec x s | (i,x) <- IntMap.toList xs, IntMap.member i ss, let s = ss IntMap.! i ] diff --git a/dist/build/Quipper/Algorithms/TF/Main.hs b/dist/build/Quipper/Algorithms/TF/Main.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/TF/Main.hs @@ -0,0 +1,442 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/TF/Main.hs" #-} +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 + {-# OPTIONS -fcontext-stack=50 #-} +#else + {-# OPTIONS -freduction-depth=50 #-} +#endif + +-- | +-- Authors: Peter LeFanu Lumsdaine, Neil Julien Ross +-- +-- An implementation of the Triangle Finding Algorithm. The +-- Triangle Finding Problem is given by an undirected dense +-- simple graph /G/ containing exactly one triangle ∆. The +-- graph is given by an oracle function /f/ , such that, for +-- any two nodes /v/, /w/ of /G/, /f/(/v/,/w/)=1 if (/v/,/w/) +-- is an edge of /G/ and /f/(/v/,/w/)=0 otherwise. To solve +-- such an instance of the problem is to find the set of +-- vertices {/e/[sub 1] , /e/[sub 2] , /e/[sub 3]} forming +-- ∆ by querying /f/. +-- +-- The algorithm works by performing a Grover-based quantum +-- walk on a larger graph /H/, called the Hamming graph +-- associated to /G/. It is designed to find ∆ with high +-- probability. The algorithm is parametric on an oracle +-- defining the graph /G/. In our implementation, the +-- oracle is a changeable part, but we have also +-- implemented a particular predefined oracle. +-- +-- The algorithm is described in: +-- +-- * A. Childs and R. Kothari. \"Quantum query complexity of +-- minor-closed graph properties.\" In +-- /Proceedings of the 28th Symposium on Theoretical Aspects of Computer Science/, +-- pages 661–672, 2011. +-- +-- * F. Magniez, M. Santha, and M. Szegedy. \"Quantum +-- algorithms for the triangle problem.\" In +-- /Proceedings of the 16th Annual ACM-SIAM Symposium on Discrete Algorithms/, +-- pages 1109–1117, 2005. +-- +-- The present implementation is based on detailed +-- algorithm and oracle specifications that were provided to +-- us by the IARPA QCS program and written by Richard +-- Wisniewski. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.TF.Main": Command line interface. +-- +-- * "Quipper.Algorithms.TF.Definitions": Some general purpose +-- definitions. +-- +-- * "Quipper.Algorithms.TF.QWTFP": The implementation of the main +-- Triangle Finding algorithm. +-- +-- * "Quipper.Algorithms.TF.Oracle": The implementation of the +-- oracle for the Triangle Finding algorithm. +-- +-- * "Quipper.Algorithms.TF.Alternatives": Some alternative +-- implementations of some of the subroutines. +-- +-- * "Quipper.Algorithms.TF.Simulate": Functions for simulating, +-- testing, and debugging oracles. + +module Quipper.Algorithms.TF.Main where + +import Quipper + +import Quipper.Libraries.Arith +import Quipper.Libraries.Decompose + +import Quipper.Algorithms.TF.Definitions +import Quipper.Algorithms.TF.Oracle +import Quipper.Algorithms.TF.QWTFP +import Quipper.Algorithms.TF.Simulate +import Quipper.Algorithms.TF.Alternatives + +import Quipper.Utils.CommandLine + +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import Control.Monad +import Data.List +import Data.Char +import qualified Data.IntMap as IntMap + +---------------------------------------------------------------------- +-- * Documentation + +-- $ This module provides a command line interface for the +-- Triangle Finding Algorithm. This allows the user, for +-- example, to plug in different oracles, show different +-- parts of the circuit, select a gate base, simulate, +-- and select various parameters. +-- +-- * Example invocations: +-- +-- @./tf@ +-- +-- Default options: the full 'a1_QWTFP' circuit, with +-- (l,n,r) = (4,3,2), and a black-box oracle. +-- +-- @./tf --oracle -o "Orthodox" -l 3 -n 2 -r 2@ +-- +-- A manageable size to inspect the orthodox oracle. +-- +-- @./tf -s mult -l 4@ +-- +-- The multiplier, for 4-bit integers mod 15. +-- +-- @./tf --help@ +-- +-- Print detailed usage info (accepted options, etc.). +-- +-- * Parameters: +-- +-- /l/: the length of integers used in the oracle. +-- (Default value: 4.) +-- +-- /n/: the size of nodes in the graph. +-- (Default value: 3.) +-- +-- /r/: log[sub 2] of the tuple size of the Hamming graph. +-- (Default value: 2.) + +-- +-- * Option processing +-- +-- | An enumeration type for determining what the main function should do. +data WhatToShow = + Circuit -- ^Show the whole circuit. + | Oracle -- ^Show only the oracle. + | Sub -- ^Show a specific subroutine. + | Arith -- ^Run simulation tests of the arithmetic subroutines. + | OTest -- ^Run simulation tests of the oracle. + deriving Show + +-- | An enumeration type for selecting an oracle. +data OracleSelect = + Orthodox -- ^The default oracle. + | Blackbox -- ^A blackbox oracle. + deriving Show + +-- | A datatype for selecting a qRAM implementation. +data QRamSelect = + Standard_QRam -- ^ The default qRAM. + | Alt_QRam -- ^ A slightly more efficient implementation. + deriving Show + +-- | An enumeration type for selecting a subroutine. +data Subroutine = + A2 -- ^Algorithm 2: Zero. + | A3 -- ^Algorithm 3: Initialize. + | A4 -- ^Algorithm 4: Hadamard. + | A5 -- ^Algorithm 5: Setup. + | A6 -- ^Algorithm 6: QWSH. + | A7 -- ^Algorithm 7: Diffuse. + | A8 -- ^Algorithm 8: FetchT. + | A9 -- ^Algorithm 9: StoreT. + | A10 -- ^Algorithm 10: FetchStoreT. + | A11 -- ^Algorithm 11: FetchE. + | A12 -- ^Algorithm 12: FetchStoreE. + | A13 -- ^Algorithm 13: Update. + | A14 -- ^Algorithm 14: SWAP. + | A15 -- ^Algorithm 15: TestTriangleEdges (inner quantum walk). + | A16 -- ^Algorithm 16: TriangleTestT. + | A17 -- ^Algorithm 17: TriangleTestTw. + | A18 -- ^Algorithm 18: TriangleEdgeSearch. + | A19 -- ^Algorithm 19: GCQWalk. + | A20 -- ^Algorithm 20: GCQWStep. + | O2 -- ^Algorithm O2: ConvertNODE. + | O3 -- ^Algorithm O3: TestEqual. + | O4 -- ^Algorithm O4: Pow17. + | O5 -- ^Algorithm O5: Mod3. + | O6 -- ^Algorithm O6: Sub. + | O7 -- ^Algorithm O7: Add. + | O8 -- ^Algorithm O8: Mul. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + what :: WhatToShow, -- ^What kind of thing to output. + s :: Subroutine, -- ^What specific subroutine to output. + format :: Format, -- ^The output format. + gatebase :: GateBase, -- ^What kind of gates to decompose into. + oracle :: OracleSelect, -- ^Which kind of oracle to use. + qram :: QRamSelect, -- ^Which qram implementation to use. + l :: Int, -- ^Parameter 'l'. + n :: Int, -- ^Parameter 'n'. + r :: Int -- ^Parameter 'r'. +} deriving Show + + +-- | The default options. +defaultOptions :: Options +defaultOptions = Options + { what = Circuit, + s = O7, + format = Preview, + gatebase = Logical, + oracle = Blackbox, + qram = Standard_QRam, + l = 4, + n = 3, + r = 2 + } + + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = + [ +-- Generic options + Option ['h'] ["help"] (NoArg help) "print usage info and exit", + Option ['f'] ["format"] (ReqArg format "") "output format for circuits (default: preview)", + Option ['g'] ["gatebase"] (ReqArg gatebase "") "type of gates to decompose into (default: logical)", +-- Triangle finding parameters + Option ['l'] ["l"] (ReqArg lll "") "parameter l (default: 4)", + Option ['n'] ["n"] (ReqArg nnn "") "parameter n (default: 3)", + Option ['r'] ["r"] (ReqArg rrr "") "parameter r (default: 2)", +-- Main circuits + Option ['C'] ["QWTFP"] (NoArg (what Circuit)) "output the whole circuit (default)", + Option ['O'] ["oracle"] (NoArg (what Oracle)) "output only the oracle", +-- Subroutine option + Option ['s'] ["subroutine"] (ReqArg sub "") "output the chosen subroutine (default: adder)", +-- QRAM option + Option ['Q'] [] (NoArg (qram Alt_QRam)) "use alternative qRAM implementation", +-- Oracle option + Option ['o'] [] (ReqArg oracle "") "select oracle to use (default: blackbox)", +-- Testing options + Option ['A'] ["arith"] (NoArg (what Arith)) "test/simulate the arithmetic routines", + Option ['T'] ["oracletest"] (NoArg (what OTest)) "test/simulate the oracle" + ] + where + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + + sub :: String -> Options -> IO Options + sub str o = do + case match_enum subroutine_enum str of + [(_, f)] -> return o { what = Sub, s = f } + [] -> optfail ("Unknown subroutine -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous subroutine -- " ++ str ++ "\n") + + qram :: QRamSelect -> Options -> IO Options + qram q o = return o { qram = q } + + lll :: String -> Options -> IO Options + lll string o = + case parse_int string of + Just l | l >= 1 -> return o { l = l } + _ -> optfail ("Invalid value for parameter l -- " ++ string ++ "\n") + + nnn :: String -> Options -> IO Options + nnn string o = + case parse_int string of + Just n | n >= 1 -> return o { n = n } + _ -> optfail ("Invalid value for parameter n -- " ++ string ++ "\n") + + rrr :: String -> Options -> IO Options + rrr string o = + case parse_int string of + Just r | r >= 1 -> return o { r = r } + _ -> optfail ("Invalid value for parameter r -- " ++ string ++ "\n") + + format :: String -> Options -> IO Options + format str o = do + case match_enum format_enum str of + [(_, f)] -> return o { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + gatebase :: String -> Options -> IO Options + gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + oracle :: String -> Options -> IO Options + oracle str o = do + case match_enum oracle_enum str of + [(_, f)] -> return o { oracle = f } + [] -> optfail ("Unknown oracle -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous oracle -- " ++ str ++ "\n") + + help :: Options -> IO Options + help o = do + usage + exitSuccess + +-- | An enumeration of available oracles and their names. +oracle_enum :: [(String, OracleSelect)] +oracle_enum = [ + ("orthodox", Orthodox), + ("blackbox", Blackbox) + ] + +-- | An enumeration of available subroutines and their names. +subroutine_enum :: [(String, Subroutine)] +subroutine_enum = [ + ("zero", A2), + ("initialize", A3), + ("hadamard", A4), + ("setup", A5), + ("qwsh", A6), + ("diffuse", A7), + ("fetcht", A8), + ("storet", A9), + ("fetchstoret", A10), + ("fetche", A11), + ("fetchstoree", A12), + ("update", A13), + ("swap", A14), + ("a15", A15), + ("a16", A16), + ("a17", A17), + ("a18", A18), + ("gcqwalk", A19), + ("gcqwstep", A20), + ("convertnode", O2), + ("testequal", O3), + ("pow17", O4), + ("mod3", O5), + ("sub", O6), + ("add", O7), + ("mult", O8) + ] + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to 'stdout'. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + putStr (show_enum "oracle" oracle_enum) + putStr (show_enum "subroutine" subroutine_enum) + where header = "Usage: tf [OPTION...]" + +-- ---------------------------------------------------------------------- +-- * The Triangle Finding Algorithm main function + +-- | Main function: read options, then execute the appropriate task. +main :: IO() +main = do + argv <- getArgs + options <- dopts argv + let spec = spec_of_options options + let p = ceiling (logBase 2 (fromIntegral (2^9 `choose` 3))) + case options of + + Options { oracle = oracle, what = what, format = format, gatebase = gatebase, n = n, r = r, l = l, s = s} -> + + case what of + Circuit -> print_generic format $ decompose_generic gatebase $ a1_QWTFP spec + Oracle -> print_generic format (decompose_generic gatebase $ proj3 spec) node_shape node_shape qubit + Arith -> arithmetic_tests l + OTest -> oracle_tests n l + Sub -> case s of + A2 -> print_generic format (decompose_generic gatebase $ a2_ZERO (replicate n False)) + A3 -> print_generic format (decompose_generic gatebase $ a3_INITIALIZE (replicate n False)) + A4 -> print_generic format (decompose_generic gatebase $ a4_HADAMARD) (replicate n qubit) + A5 -> print_generic format (decompose_generic gatebase $ a5_SETUP spec) tt_shape + A6 -> print_generic format (decompose_generic gatebase $ a6_QWSH spec) + tt_shape (qdint_shape r) node_shape ee_shape + A7 -> print_generic format (decompose_generic gatebase $ a7_DIFFUSE) node_shape + A8 -> print_generic format (decompose_generic gatebase $ a8_FetchT) + (qdint_shape r) tt_shape node_shape + A9-> print_generic format (decompose_generic gatebase $ a9_StoreT) + (qdint_shape r) tt_shape node_shape + A10-> print_generic format (decompose_generic gatebase $ a10_FetchStoreT) + (qdint_shape r) tt_shape node_shape + A11-> print_generic format (decompose_generic gatebase $ a11_FetchE) + (qdint_shape r) ee_shape eed_shape + A12-> print_generic format (decompose_generic gatebase $ a12_FetchStoreE) + (qdint_shape r) ee_shape eed_shape + A13-> print_generic format (decompose_generic gatebase $ a13_UPDATE spec) + tt_shape node_shape eed_shape + A14-> print_generic format (decompose_generic gatebase $ a14_SWAP) + node_shape node_shape + A15 -> print_generic format (decompose_generic gatebase $ a15_TestTriangleEdges spec) + tt_shape ee_shape + A16 -> print_generic format (decompose_generic gatebase $ a16_TriangleTestT) + ee_shape + A17 -> print_generic format (decompose_generic gatebase $ a17_TriangleTestTw spec) + tt_shape ee_shape node_shape + A18 -> print_generic format (decompose_generic gatebase $ a18_TriangleEdgeSearch spec) + tt_shape ee_shape qubit + A19 -> print_generic format (decompose_generic gatebase $ a19_GCQWalk spec) + tt_shape ee_shape node_shape qubit + A20 -> print_generic format (decompose_generic gatebase $ a20_GCQWStep spec) + tt_shape ee_shape node_shape gcqw_shape + O2 -> print_generic format (decompose_generic gatebase $ \u -> o2_ConvertNode l u (2^(n-1))) node_shape + O3 -> print_generic format (decompose_generic gatebase $ o3_TestEqual) (qinttf_shape l) (qinttf_shape l) + O4 -> print_generic format (decompose_generic gatebase $ o4_POW17) (qinttf_shape l) + O5 -> print_generic format (decompose_generic gatebase $ o5_MOD3) (qinttf_shape l) + O6 -> print_generic format (decompose_generic gatebase $ \u -> o6_SUB u (2^(n-1))) (qinttf_shape l) + O7 -> print_generic format (decompose_generic gatebase $ o7_ADD) (qinttf_shape l) (qinttf_shape l) + O8 -> print_generic format (decompose_generic gatebase $ o8_MUL) (qinttf_shape l) (qinttf_shape l) + + where + rbar = max ((2 * r) `div` 3) 1 + proj3 (a,b,c,d) = c + node_shape = (replicate n qubit) + tt_shape = (intMap_replicate (2^r) node_shape) + ee_shape = (IntMap.fromList [(j,intMap_replicate j qubit) | j <- [0..((2^r)-1)]]) + eed_shape = (intMap_replicate (2^r) qubit) + gcqw_shape = (intMap_replicate (2^rbar) (qdint_shape r), + (qdint_shape rbar), + (qdint_shape r), + (intMap_replicate (2^rbar) qubit), + (qdint_shape (2*rbar - 1)), + qubit) + + +-- | Compute the appropriate problem specification for the given options. +spec_of_options :: Options -> QWTFP_spec +spec_of_options Options { oracle = Orthodox, n = n, r = r, l = l, qram = qram} = + (n,r, + (\u v edge -> do (u,v,edge) <- o1_ORACLE l u v edge; return edge), + qram_select qram) +spec_of_options Options { oracle = Blackbox, n = n, r = r, qram = qram} = + (n,r,placeholder_oracle,qram_select qram) + +-- | Maps a 'QRamSelect' element to the corresponding 'Qram' object. +qram_select :: QRamSelect -> Qram +qram_select Standard_QRam = standard_qram +qram_select Alt_QRam = alt_qram diff --git a/dist/build/Quipper/Algorithms/TF/Oracle.hs b/dist/build/Quipper/Algorithms/TF/Oracle.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/TF/Oracle.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/TF/Oracle.hs" #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | This module provides implementations of an oracle for the +-- Triangle Finding Algorithm. +-- +-- This oracle injects the graph /G/ into the space +-- {0, 1, . . . , 2/l/ − 1} of /l/-bit integers, and each oracle +-- call requires the extensive use of modular arithmetic. +-- +-- The circuits produced by running this \"orthodox\" oracle are +-- very big. We therefore also provide a \"blackbox\" oracle, +-- which is simply a placeholder for an actual oracle call, +-- to replace the orthodox oracle when running subroutines and +-- for resource estimation. The oracle circuit is the same every +-- time it is used, so for resource estimation purposes, it only +-- needs to be generated once, rather than inlined at every use site. + +module Quipper.Algorithms.TF.Oracle where + +import Quipper + +import Quipper.Algorithms.TF.Definitions + +import Quipper.Utils.Auxiliary + +-- ====================================================================== + +-- * Orthodox oracle + +-- | Algorithm O-1. The two 'QNode' inputs /u/ and +-- /v/ are assumed to be of equal length. +o1_ORACLE :: Int -> QNode -> QNode -> Qubit -> Circ (QNode,QNode,Qubit) +o1_ORACLE l = box "o1" $ \u v edge -> do + comment_with_label "ENTER: o1_ORACLE" (u,v,edge) ("u","v","edge") + let n = length u + hn = 2^(n-1) + + ((u,v),e) <- with_computed_fun (u,v) + (o1_ORACLE_aux l hn) + (\((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) -> do + edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 1 .&&. vF .==. 1) + edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 1 .&&. vF .==. 0 .&&. t_u3v3 .==. 1) + edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 0 .&&. vF .==. 1 .&&. t_u3v3 .==. 1) + edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 0 .&&. vF .==. 0 .&&. t_u3v3 .==. 0 .&&. t_uHvH .==. 0) + return (((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)),edge)) + + comment_with_label "EXIT: o1_ORACLE" (u,v,edge) ("u","v","edge") + return (u,v,edge) + +-- | Compute the various auxiliary data for 'o1_ORACLE'. +o1_ORACLE_aux :: Int -> Int -> (QNode, QNode) -> Circ ((QNode, QNode), (QIntTF, QIntTF, QIntTF, QIntTF, QIntTF, QIntTF), (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit)) +o1_ORACLE_aux l hn = box "o1_aux" $ \(u,v) -> do + comment_with_label "ENTER: o1_ORACLE_aux" (u,v) ("u","v") + (u,uint) <- o2_ConvertNode l u hn + (v,vint) <- o2_ConvertNode l v hn + (uint,vint,t_uv) <- o3_TestEqual uint vint + {- Since we don’t have “quantum control”, we can’t say “if t == True… return” here; + instead we just add a “control on t_uv == False” to the later flips of ‘edge’. -} + + (uint,u17) <- o4_POW17 uint + (uint,u17,uF) <- o3_TestEqual uint u17 + (vint,v17) <- o4_POW17 vint + (vint,v17,vF) <- o3_TestEqual vint v17 + + let uint_bits = qulist_of_qinttf_lh uint + let vint_bits = qulist_of_qinttf_lh vint + uH <- qinit False + uH <- qnot uH `controlled` (uint_bits !! (l-1)) + vH <- qinit False + vH <- qnot vH `controlled` (vint_bits !! (l-1)) +-- Would like to say ”t_uHvH <- qd_testequal uH vH t_uHvH”, if testequal were generic. + t_uHvH <- qinit True + t_uHvH <- qnot t_uHvH `controlled` uH + t_uHvH <- qnot t_uHvH `controlled` vH + + (u17,u3) <- o5_MOD3 u17 + (v17,v3) <- o5_MOD3 v17 + (u3,v3,t_u3v3) <- o3_TestEqual u3 v3 + + comment_with_label "EXIT: o1_ORACLE_aux" ((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) (("u","v"),("uint","vint","u17","v17","u3","v3"),("uF","vF","uH","vH","t_uv","t_uHvH","t_u3v3")) + return ((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) + +-- | Algorithm O-2. Convert a 'QNode' into a freshly assigned 'QIntTF', +o2_ConvertNode :: Int -> QNode -> Int -> Circ (QNode,QIntTF) +o2_ConvertNode l u hn = ($ u) $ box "o2" $ \u -> do + comment_with_label "ENTER: o2_ConvertNode" u "u" + let n = if (length u < l) then (length u) else (error ("ConvertNode: requires n < l. n = " ++ (show (length u)) ++ ", l = " ++ (show l) ++ ".")) + + (u, uint) <- with_computed_fun u + (\u -> do + (u,w_low) <- qc_copy_fun u + w_high <- qinit (replicate (l-n) False) + return (u,qinttf_of_qulist_lh (w_low ++ w_high))) + + (\(u,w) -> do + (w,uint) <- o6_SUB w hn + return ((u,w),uint)) + comment_with_label "EXIT: o2_ConvertNode" (u, uint) ("u", "uint") + return (u, uint) + +-- | Algorithm O-3. Compare if two QIntTF’s are equal; +-- return the result in a fresh Qubit. +-- +-- This function is in general iffy: 00…00 and 11…11 do /not/ test as equal, as they should. +-- However, that case does not arise in the oracle: on the one hand, both 00…00 and 11…11 +-- are literal fixed points of 'o4_POW17', and on the other, 'o5_MOD3' never outputs 00. +o3_TestEqual :: QIntTF -> QIntTF-> Circ (QIntTF,QIntTF,Qubit) +o3_TestEqual = box "o3" $ \x y -> do + comment_with_label "ENTER: o3_TestEqual" (x,y) ("x", "y") + let x_bits = qulist_of_qinttf_lh x + let y_bits = qulist_of_qinttf_lh y + y_bits <- mapM (\(p,q) -> qnot q `controlled` p) (zip x_bits y_bits) + t <- qinit False + t <- qnot t `controlled` [ q .==. 0 | q <- y_bits ] + y_bits <- mapM (\(p,q) -> qnot q `controlled` p) (zip x_bits y_bits) + let x = qinttf_of_qulist_lh x_bits + let y = qinttf_of_qulist_lh y_bits + comment_with_label "EXIT: o3_TestEqual" (x, y, t) ("x", "y", "t") + return (x, y, t) + +-- | Algorithm O-4. Compute 17th power of a 31-bit 'QIntTF' /x/, into a +-- freshly 31-bit /QIntTF/. +o4_POW17 :: QIntTF -> Circ (QIntTF,QIntTF) +o4_POW17 = box "o4" $ \x -> do + comment_with_label "ENTER: o4_POW17" x "x" + (x, x17) <- with_computed_fun x + (\x -> do + (x,x2) <- square x + (x2,x4) <- square x2 + (x4,x8) <- square x4 + (x8,x16) <- square x8 + return (x,x2,x4,x8,x16)) + + (\(x,x2,x4,x8,x16) -> do + (x,x16,x17) <- o8_MUL x x16 + return ((x,x2,x4,x8,x16),x17)) + comment_with_label "EXIT: o4_POW17" (x, x17) ("x", "x17") + return (x, x17) + +{- Alternative coding style: +o4_POW17 x = do + (x,x17) <- with_computed_fun square x (\(x,x2) -> do + (x2,(x,x17)) <- with_computed_fun square x2 (\(x2,x4) -> do + (x4,(x,x17)) <- with_computed_fun square x4 (\(x4,x8) -> do + (x8,(x,x17)) <- with_computed_fun square x8 (\(x8,x16) -> do + (x,x16,x17) <- o8_MUL x x16 + return ((x8,x16),(x,x17))) + return ((x4,x8),(x,x17))) + return ((x2,x4),(x,x17))) + return ((x,x2),x17)) + return (x,x17) +-} + +-- | Map a QIntTF /x/ to (/x/,/x/^2). +-- +-- A subroutine factored out of @'o4_POW17'@. +square :: QIntTF -> Circ (QIntTF,QIntTF) +square x = do +-- comment_with_label "ENTER: square" x "x" + (x, x2) <- with_computed_fun x qc_copy_fun + (\(x,x') -> do + (x,x',x2) <- o8_MUL x x' + return ((x,x'),x2)) +-- comment_with_label "EXIT: square" (x, x2) ("x", "x2") + return (x, x2) + +-- | Algorithm O-5. Compute residue modulo 3 of the lower-order bits of a +-- 'QIntTF', into a fresh 2-bit 'QIntTF'. +-- +-- This algorithm is size-limited — works for up to 31-bit integers, but not beyond. +-- +-- This also currently is mismatched with our specification of QIntTF, since it +-- produces output in the range 1–3, rather than 0–2. However, output of this +-- algorithm is only used via '03_TestEqual', so this is not a problem in practice. +o5_MOD3 :: QIntTF -> Circ (QIntTF,QIntTF) +o5_MOD3 = box "o5" $ \x -> do + comment_with_label "ENTER: o5_MOD3" x "x" + let x_bits = qulist_of_qinttf_lh x + let l = length x_bits + l' = if (l <= 31) then (l `div` 2) + else error "o5_MOD3: requires l <= 31" + (x_bits, m_bits) <- with_computed_fun x_bits + (\x_bits -> do + s5 <- mmap qulist_of_qinttf_lh $ qinit (inttf 5 15) + + (x_bits,s5) <- loop_with_indexM l' (x_bits,s5) (\i (x_bits,s5) -> do + s5 <- increment_little s5 `controlled` (x_bits !! (2*i)) + s5 <- if (2*i + 1 <= l - 2) -- in case l is even, skip this step on the last iteration. + then decrement_little s5 `controlled` (x_bits !! (2*i + 1)) + else return s5 + return (x_bits,s5)) + + s3 <- mmap qulist_of_qinttf_lh $ qinit (inttf 3 3) + + (s5,s3) <- loop_with_indexM 2 (s5,s3) (\i (s5,s3) -> do + s3 <- increment_little s3 `controlled` (s5 !! (2*i)) + s3 <- decrement_little s3 `controlled` (s5 !! (2*i + 1)) + return (s5,s3)) + s3 <- increment_little s3 `controlled` (s5 !! 4) + + let s3_high = last s3 + s2 = init s3 + s2 <- increment_little s2 `controlled` s3_high + + return (x_bits,s5,s3_high,s2)) + + (\(x_bits,s5,s3_high,s2) -> do + (s2,m_bits) <- qc_copy_fun s2 + return ((x_bits,s5,s3_high,s2), m_bits)) + let x = qinttf_of_qulist_lh x_bits + let m = qinttf_of_qulist_lh m_bits + comment_with_label "EXIT: o5_MOD3" (x, m) ("x", "m") + return (x, m) + +-- | Algorithm O-6. Subtract an integer parameter from a 'QIntTF'. +-- Return the result as a second, freshly assigned 'QIntTF'. +o6_SUB :: QIntTF -> Int -> Circ (QIntTF,QIntTF) +o6_SUB x y = ($ x) $ box "o6" $ \x -> do + comment_with_label "ENTER: o6_SUB" x "x" + (x, d_out) <- with_computed_fun x + (\x1 -> do + let x = qulist_of_qinttf_lh x1 + let l = length x + let y_bits = reverse (boollist_of_int_bh l y) -- the little-endian binary rep of /y/ + + d <- qinit (replicate l False) -- will be [the list of bits of] the eventual answer + d1 <- qinit (replicate l False) -- will hold an intermediate version of the + -- subtraction, not “corrected” modulo (2^l – 1). + c1 <- qinit (replicate (l+1) False) + + (c1,d1,x) <- loop_with_indexM l (c1,d1,x) (\j (c1,d1,x) -> do + let c1_j1 = c1 !! (j+1) + let d1_j = d1 !! j + c1_j1 <- if y_bits !! j + then return c1_j1 + else qnot c1_j1 `controlled` (x !! j) + c1_j1 <- qnot c1_j1 `controlled` (x !! j) .&&. (c1 !! j) + c1_j1 <- if y_bits !! j + then return c1_j1 + else qnot c1_j1 `controlled` (c1!!j) + d1_j <- qnot d1_j `controlled` (x !! j) + d1_j <- if y_bits !! j + then return d1_j + else qnot d1_j + d1_j <- qnot d1_j `controlled` (c1 !! j) + c1 <- return $ overwriteAt (j+1) c1_j1 c1 + d1 <- return $ overwriteAt j d1_j d1 + return (c1,d1,x)) + + c2 <- qinit (replicate (l+1) False) + c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l) + c2 <- return $ overwriteAt 0 c2_0 c2 + + (d,d1,c2) <- loop_with_indexM l (d,d1,c2) (\j (d,d1,c2) -> do + let c2_j1 = c2 !! (j+1) + let dj = d !! j + c2_j1 <- qnot c2_j1 `controlled` (d1 !! j) .&&. (c2 !! j) + dj <- qnot dj `controlled` (d1 !! j) + dj <- qnot dj `controlled` (c2 !! j) + c2 <- return $ overwriteAt (j+1) c2_j1 c2 + d <- return $ overwriteAt j dj d + return (d,d1,c2)) + + d_0 <- qnot (d !! 0) `controlled` (c2 !! l) + d <- return $ overwriteAt 0 d_0 d + return (x,d,d1,c1,c2)) + -- Having computed the difference /d/ along with much auxiliary data, we save a + -- copy of /d/ before undoing all the computation: + (\(x,d,d1,c1,c2) -> do + (d,d_out) <- qc_copy_fun d + return ((x,d,d1,c1,c2),qinttf_of_qulist_lh d_out)) + comment_with_label "EXIT: o6_SUB" (x, d_out) ("x", "d_out") + return (x, d_out) + +-- | Algorithm O-7. Add two 'QIntTF's. Return the result as a third, freshly assigned 'QIntTF'. +o7_ADD :: QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF) +o7_ADD = box "o7" $ \x y -> do + comment_with_label "ENTER: o7_ADD" (x, y) ("x", "y") + let x_bits = qulist_of_qinttf_lh x + let y_bits = qulist_of_qinttf_lh y + let l = length x_bits + + ((x_bits,y_bits),s_out) <- with_computed_fun (x_bits,y_bits) + (\(x_bits,y_bits) -> do + s <- qinit (replicate l False) -- holds the eventual sum + s1 <- qinit (replicate l False) -- holds the uncorrected sum + c1 <- qinit (replicate (l+1) False) -- holds the carries + + (c1,s1,x_bits,y_bits) <- loop_with_indexM l (c1,s1,x_bits,y_bits) (\j (c1,s1,x_bits,y_bits) -> do + let c1_j1 = c1 !! (j+1) + let s1_j = s1 !! j + c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (y_bits!!j) + c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (c1!!j) + c1_j1 <- qnot c1_j1 `controlled` (y_bits!!j) .&&. (c1!!j) + s1_j <- qnot s1_j `controlled` (x_bits !! j) + s1_j <- qnot s1_j `controlled` (y_bits !! j) + s1_j <- qnot s1_j `controlled` (c1 !! j) + c1 <- return $ overwriteAt (j+1) c1_j1 c1 + s1 <- return $ overwriteAt j s1_j s1 + return (c1,s1,x_bits,y_bits)) + + c2 <- qinit (replicate (l+1) False) + c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l) + c2 <- return $ overwriteAt 0 c2_0 c2 + + (s,s1,c2) <- loop_with_indexM l (s,s1,c2) (\j (s,s1,c2) -> do + let c2_j1 = c2 !! (j+1) + let sj = s !! j + c2_j1 <- qnot c2_j1 `controlled` (s1 !! j) .&&. (c2 !! j) + sj <- qnot sj `controlled` (s1 !! j) + sj <- qnot sj `controlled` (c2 !! j) + c2 <- return $ overwriteAt (j+1) c2_j1 c2 + s <- return $ overwriteAt j sj s + return (s,s1,c2)) + + s_0 <- qnot (s !! 0) `controlled` (c2 !! l) + s <- return $ overwriteAt 0 s_0 s + + return (x_bits,y_bits,s,s1,c1,c2)) + + (\(x_bits,y_bits,s,s1,c1,c2) -> do + (s,s_out) <- qc_copy_fun s + return ((x_bits,y_bits,s,s1,c1,c2), s_out)) + let x = qinttf_of_qulist_lh x_bits + let y = qinttf_of_qulist_lh y_bits + let s = qinttf_of_qulist_lh s_out + comment_with_label "EXIT: o7_ADD" (x, y, s) ("x", "y", "s") + return (x, y, s) + +-- | Controlled version of 'o7_ADD'. Returns either a copy of the first +-- input (if controls are “off”) or the sum of the inputs +-- (if controls are “on”). +-- +-- We make this version explicitly, rather than just using 'controlled', +-- because the controls only need to be applied to a very few selected +-- gates in the routine. +o7_ADD_controlled :: (ControlSource ctrl, Labelable ctrl String) + => ctrl -> QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF) +o7_ADD_controlled controls x y = do + comment_with_label "ENTER: o7_ADD_controlled" (controls,x,y) ("ctrl","x","y") + let x_bits = qulist_of_qinttf_lh x + let y_bits = qulist_of_qinttf_lh y + let l = length x_bits + + ((x_bits,y_bits),s_out) <- with_computed_fun (x_bits,y_bits) + (\(x_bits,y_bits) -> do + s <- qinit (replicate l False) -- holds the eventual sum + s1 <- qinit (replicate l False) -- holds the uncorrected sum + c1 <- qinit (replicate (l+1) False) -- holds the carries + + (c1,s1,x_bits,y_bits) <- loop_with_indexM l (c1,s1,x_bits,y_bits) (\j (c1,s1,x_bits,y_bits) -> do + let c1_j1 = c1 !! (j+1) + let s1_j = s1 !! j + c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (y_bits!!j) + c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (c1!!j) + c1_j1 <- qnot c1_j1 `controlled` (y_bits!!j) .&&. (c1!!j) + s1_j <- qnot s1_j `controlled` (x_bits !! j) + s1_j <- qnot s1_j `controlled` (y_bits !! j) + s1_j <- qnot s1_j `controlled` (c1 !! j) + c1 <- return $ overwriteAt (j+1) c1_j1 c1 + s1 <- return $ overwriteAt j s1_j s1 + return (c1,s1,x_bits,y_bits)) + + c2 <- qinit (replicate (l+1) False) + c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l) + c2 <- return $ overwriteAt 0 c2_0 c2 + + (s,s1,c2) <- loop_with_indexM l (s,s1,c2) (\j (s,s1,c2) -> do + let c2_j1 = c2 !! (j+1) + let sj = s !! j + c2_j1 <- qnot c2_j1 `controlled` (s1 !! j) .&&. (c2 !! j) + sj <- qnot sj `controlled` (s1 !! j) + sj <- qnot sj `controlled` (c2 !! j) + c2 <- return $ overwriteAt (j+1) c2_j1 c2 + s <- return $ overwriteAt j sj s + return (s,s1,c2)) + + s_0 <- qnot (s !! 0) `controlled` (c2 !! l) + s <- return $ overwriteAt 0 s_0 s + + return (x_bits,y_bits,s,s1,c1,c2)) + + (\(x_bits,y_bits,s,s1,c1,c2) -> do + -- Prepare a qubit holding the value of the controls, + -- since we want to control also on their negation. + -- /Can’t/ include this in “with_computed_fun”: controls can’t be bound + -- as QData, and including it unbound yields rather interesting bug. + temp_control <- qinit False + temp_control <- qnot temp_control `controlled` controls + s_out <- qinit (replicate l False) + (x_bits,s_out) <- mapBinary + (\q q' -> do + q' <- qnot q' `controlled` (q .&&. (temp_control .==. 0)) + return (q,q')) + x_bits s_out + (s,s_out) <- mapBinary + (\q q' -> do + q' <- qnot q' `controlled` (q .&&. (temp_control .==. 1)) + return (q,q')) + s s_out + temp_control <- qnot temp_control `controlled` controls + qterm False temp_control + return ((x_bits,y_bits,s,s1,c1,c2), s_out)) + let x = qinttf_of_qulist_lh x_bits + let y = qinttf_of_qulist_lh y_bits + let s = qinttf_of_qulist_lh s_out + comment_with_label "EXIT: o7_ADD_controlled" (x,y,s) ("x","y","s") + return (x, y, s) + + +-- | Algorithm O-8. Multiply two 'QIntTF's; return the +-- result as a third, freshly assigned 'QIntTF'. +o8_MUL :: QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF) +o8_MUL = box "o8" $ \x y -> do +-- comment_with_label "ENTER: o8_MUL" (x,y) ("x","y") + let x_bits = qulist_of_qinttf_lh x + let l = length x_bits + + ((x,y),p) <- with_computed_fun (x,y) + (\(x, y) -> do + let x_bits = qulist_of_qinttf_lh x + -- We will build up a register of partial products, each obtained from the previous + -- by adding (2^i * y) if the ith bit of x is set. + -- For this, we make a copy of y, to be repeatedly doubled as we go. + (y,tmp_y) <- qc_copy_fun y + wrk0 <- qinit (inttf l 0) + (tmp_y,wrks) <- loop_with_indexM l (tmp_y,[wrk0]) + (\k (tmp_y,(wrk_prev:wrks_older)) -> do + (wrk_prev,tmp_y,wrk_new) + <- o7_ADD_controlled (x_bits !! k) wrk_prev tmp_y + tmp_y <- double_TF tmp_y + return (tmp_y,(wrk_new:wrk_prev:wrks_older))) + return ((qinttf_of_qulist_lh x_bits),y,tmp_y,wrks)) + + (\(x,y,tmp_y,(wrks_head:wrks_rest)) -> do + (wrks_head,p) <- qc_copy_fun wrks_head + return ((x,y,tmp_y,(wrks_head:wrks_rest)), p)) + +-- comment_with_label "EXIT: o8_MUL" (x,y,p) ("x","y","p") + return (x,y,p) + +-- | Double a 'QIntTF' in place. +-- +-- A subroutine factored out of 'o8_MUL'. +double_TF :: QIntTF -> Circ QIntTF +double_TF x = do + comment_with_label "ENTER: double_TF" x "x" + x <- case qulist_of_qinttf_lh x of + [] -> return (qinttf_of_qulist_lh []) + x_bits -> return (qinttf_of_qulist_lh ((last x_bits):(init x_bits))) + comment_with_label "EXIT: double_TF" x "x" + return x + +-- ====================================================================== + +-- * Blackbox oracle + +-- | A black-box oracle for testing. Produces a labelled black-box gate in +-- place of the actual oracle circuit. + +placeholder_oracle :: QNode -> QNode -> Qubit -> Circ Qubit +placeholder_oracle node1 node2 outp_bit = do + comment_with_label "placeholder_oracle" (node1, node2, outp_bit) ("node1", "node2", "outp_bit") + extended_named_gate_at "OC" [outp_bit] (node1 ++ node2) + return outp_bit + + diff --git a/dist/build/Quipper/Algorithms/TF/QWTFP.hs b/dist/build/Quipper/Algorithms/TF/QWTFP.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/TF/QWTFP.hs @@ -0,0 +1,652 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/TF/QWTFP.hs" #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 + {-# OPTIONS -fcontext-stack=50 #-} +#else + {-# OPTIONS -freduction-depth=50 #-} +#endif + +-- | This module provides an implementation of the Quantum Walk for +-- the Triangle Finding Problem. +-- +-- The algorithm works by performing a Grover-based quantum walk on +-- a larger graph /H/, called the Hamming graph associated to /G/. +-- We refer to this part of the algorithm as the /outer/ walk. +-- The subroutine used to check whether a triangle has been found +-- is itself a quantum walk, the /inner/ walk. +-- +-- The overall algorithm is parameterized on integers /l/, /n/ and /r/ +-- specifying respectively the length /l/ of the integers used by the +-- oracle, the number 2[sup /n/] of nodes of /G/ and the size 2[sup /r/] +-- of Hamming graph tuples. + +module Quipper.Algorithms.TF.QWTFP where + +import Prelude hiding (mapM, mapM_) + +import Quipper +import Quipper.Internal (BType) +import Quipper.Libraries.Arith +import Quipper.Algorithms.TF.Definitions + +import Data.IntMap (IntMap, adjust, insert, size) +import qualified Data.IntMap as IntMap +import Data.Traversable (mapM) +import Data.Foldable (mapM_) +import Control.Monad (foldM) + + +-- ====================================================================== +-- * Main TF algorithm + +-- | Algorithm 1. Do a quantum walk on the Hamming graph associated with /G/. +-- Returns a quadruple /(testTMeasure, wMeasure, TMeasure, EMeasure)/ +-- where /wMeasure/ contains a node of the triangle with the +-- other two nodes in /TMeasure/. +a1_QWTFP :: QWTFP_spec -> Circ (Bit,CNode,IntMap CNode,IntMap (IntMap Bit)) +a1_QWTFP oracle@(n,r,edgeOracle,_) = do + comment "ENTER: a1_QWTFP" + let nn = 2^n + let rr = 2^r + let rbar = max ((2 * r) `div` 3) 1 + let rrbar = 2^rbar + let tm = 2^(n - r) + let tw = floor $ sqrt $ fromIntegral rr + + testTEdge <- a2_ZERO False + tt <- a3_INITIALIZE (intMap_replicate rr (replicate n False)) + i <- a3_INITIALIZE (intm r 0) + v <- a3_INITIALIZE (replicate n False) + + (tt, ee) <- a5_SETUP oracle tt + + (tt,i,v,ee) <- box_loopM "a1_loop1" tm (tt,i,v,ee) + (\(tt,i,v,ee) -> do + + ((tt,ee),_) <- with_computed_fun (tt,ee) + + (\(tt,ee) -> a15_TestTriangleEdges oracle tt ee) + + (\(tt,ee,w,triTestT,triTestTw) -> do + phaseFlipUnless (triTestT .==. 0 .&&. triTestTw .==. 0) + return ((tt,ee,w,triTestT,triTestTw),())) + + (tt,i,v,ee) <- box_loopM "a1_loop2" tw (tt,i,v,ee) (\(a,b,c,d) -> a6_QWSH oracle a b c d) + return (tt,i,v,ee)) + + (tt,ee,w,triTestT,triTestTw) <- a15_TestTriangleEdges oracle tt ee + + testTEdge <- qor testTEdge [(triTestT, True), (triTestTw, True)] + + testTMeasure <- measure testTEdge + wMeasure <- measure w + ttMeasure <- measure tt + eeMeasure <- measure ee + qdiscard (i,v,triTestT,triTestTw) + comment_with_label "EXIT: a1_QWTFP" (testTMeasure, wMeasure, ttMeasure, eeMeasure) ("testTMeasure", "wMeasure", "ttMeasure", "eeMeasure") + return (testTMeasure, wMeasure, ttMeasure, eeMeasure) + + +-- ====================================================================== +-- *Utility subroutines + +-- | Algorithm 2. +-- Initialize the qubits in a register to a specified state. +-- Defined using the more generic 'qinit'. +a2_ZERO :: QShape a qa ca => a -> Circ qa +a2_ZERO b = do + comment "ENTER: a2_ZERO" + q <- qinit b + comment_with_label "EXIT: a2_ZERO" q "q" + return q + +-- | Algorithm 3. +-- Initialize to a specified state then apply a Hadamard gate to +-- the qubits in a register. +a3_INITIALIZE :: QShape a qa ca => a -> Circ qa +a3_INITIALIZE reg = do + comment "ENTER: a3_INITIALIZE" + zreg <- a2_ZERO reg + hzreg <- a4_HADAMARD zreg + comment_with_label "EXIT: a3_INITIALIZE" hzreg "hzreg" + return hzreg + +-- | Algorithm 4. +-- Apply a Hadamard gate to every qubit in the given quantum data. +-- Defined using the more generic 'map_hadamard'. +a4_HADAMARD :: QData qa => qa -> Circ qa +a4_HADAMARD q = do + comment_with_label "ENTER: a4_HADAMARD" q "q" + q <- map_hadamard q + comment_with_label "EXIT: a4_HADAMARD" q "q" + return q + +-- | Algorithm 5. +-- Set up the register /ee/ with the edge information +-- for the nodes contained in /tt/. +a5_SETUP :: QWTFP_spec -> (IntMap QNode) -> Circ (IntMap QNode, IntMap (IntMap Qubit)) +a5_SETUP oracle@(n,r,edgeOracle,_) = box "a5" $ \tt -> do + comment_with_label "ENTER: a5_SETUP" tt "tt" + let rr = 2^r + ee <- qinit $ IntMap.fromList [(j,(intMap_replicate j False)) | j <- [0..(rr-1)]] + ee <- loop_with_indexM (rr) ee (\k ee -> + loop_with_indexM k ee (\j ee -> do + edgejk <- edgeOracle (tt ! j) (tt ! k) (ee ! k ! j) + ee <- return $ adjust (insert j edgejk) k ee + return ee)) + comment_with_label "EXIT: a5_SETUP" (tt,ee) ("tt","ee") + return (tt, ee) + + +-- ====================================================================== +-- ** The outer quantum walk and the standard Qram + +-- | Algorithm 6. +-- Do a quantum walk step on the Hamming graph. +a6_QWSH :: QWTFP_spec -> (IntMap QNode) -> QDInt -> QNode -> (IntMap (IntMap Qubit)) + -> Circ (IntMap QNode, QDInt, QNode, IntMap (IntMap Qubit)) +a6_QWSH oracle@(n,r,edgeOracle,qram) = box "a6" $ \tt i v ee -> do + comment_with_label "ENTER: a6_QWSH" (tt, i, v, ee) ("tt", "i", "v", "ee") + with_ancilla_init (replicate n False) $ \ttd -> do + with_ancilla_init (intMap_replicate (2^r) False) $ \eed -> do + (i,v) <- a7_DIFFUSE (i,v) + + ((tt,i,v,ee,ttd,eed),_) <- with_computed_fun (tt,i,v,ee,ttd,eed) + + (\(tt,i,v,ee,ttd,eed) -> do + (i,tt,ttd) <- qram_fetch qram i tt ttd + (i,ee,eed) <- a12_FetchStoreE i ee eed + (tt,ttd,eed) <- a13_UPDATE oracle tt ttd eed + (i,tt,ttd) <- qram_store qram i tt ttd + return (tt,i,v,ee,ttd,eed)) + + (\(tt,i,v,ee,ttd,eed) -> do + (ttd,v) <- a14_SWAP ttd v + return ((tt,i,v,ee,ttd,eed),())) + + comment_with_label "EXIT: a6_QWSH" (tt, i, v, ee) ("tt", "i", "v", "ee") + return (tt,i,v,ee) + +-- | Algorithm 7. +-- Diffuse a piece of quantum data, in the Grover search sense of +-- reflecting about the average. +-- +-- Note: relies on @'qshape' q@ corresponding to the “all false” state. +a7_DIFFUSE :: (QData qa) => qa -> Circ qa +a7_DIFFUSE = box "a7" $ \q -> do + comment_with_label "ENTER: a7_DIFFUSE" q "q" + q <- a4_HADAMARD q + phaseFlipUnless $ q .==. qc_false q + q <- a4_HADAMARD q + comment_with_label "EXIT: a7_DIFFUSE" q "q" + return q + +-- | Algorithm 8. +-- Perform a quantum-addressed fetch operation. +-- This fetches the /i/-th element from /tt/ into /ttd/. +-- Precondition: /ttd/ = 0. +-- +-- This could be implemented more efficiently using the qRAM implementation +-- in "Alternatives". +a8_FetchT :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +a8_FetchT = box "a8" $ \i tt ttd -> do + comment_with_label "ENTER: a8_FetchT" (i,tt,ttd) ("i","tt","ttd") + let r = qdint_length i + (i,tt,ttd) <- loop_with_indexM (2^r) (i,tt,ttd) + (\j (i,tt,ttd) -> do + let ttj = tt ! j + (ttj,ttd) <- mapBinary + (\q p -> do + p <- qnot p `controlled` q .&&. i .==. (fromIntegral j) + return (q,p)) + (tt ! j) ttd + return (i, insert j ttj tt, ttd)) + comment_with_label "EXIT: a8_FetchT" (i,tt,ttd) ("i","tt","ttd") + return (i,tt,ttd) + +-- | Algorithm 9. +-- Perform a quantum-addressed store operation: +-- store /ttd/ into the /i/-th element from /tt/. +-- Analogous to 'a8_FetchT'. +a9_StoreT :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +a9_StoreT = box "a9" $ \i tt ttd -> do + comment_with_label "ENTER: a9_StoreT" (i,tt,ttd) ("i","tt","ttd") + let r = qdint_length i + (i,tt,ttd) <- loop_with_indexM (2^r) (i,tt,ttd) + (\j (i,tt,ttd) -> do + (ttj,ttd) <- mapBinary + (\q p -> do + q <- qnot q `controlled` p .&&. i .==. (fromIntegral j) + return (q,p)) + (tt ! j) ttd + return (i, insert j ttj tt, ttd)) + comment_with_label "EXIT: a9_StoreT" (i,tt,ttd) ("i","tt","ttd") + return (i,tt,ttd) + + +-- | Algorithm 10. +-- Perform a quantum-addressed swap: +-- swap /ttd/ with the /i/-th element of /tt/. +-- Analogous to 'a8_FetchT' and 'a9_StoreT'. +a10_FetchStoreT :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa) +a10_FetchStoreT = box "a10" $ \i tt ttd -> do + comment_with_label "ENTER: a10_FetchStoreT" (i,tt,ttd) ("i","tt","ttd") + let r = qdint_length i + (i,tt,ttd) <- loop_with_indexM (2^r) (i,tt,ttd) + (\j (i,tt,ttd) -> do + (qq,ttd) <- a14_SWAP (tt ! j) ttd + `controlled` i .==. (fromIntegral j) + return (i,(insert j qq tt), ttd)) + comment_with_label "EXIT: a10_FetchStoreT" (i,tt,ttd) ("i","tt","ttd") + return (i,tt,ttd) + + +-- | Algorithm 11. Perform a quantum-addressed fetch operation. This +-- is a somewhat specialized addressed fetching operation. +a11_FetchE :: QDInt -> IntMap (IntMap Qubit) -> IntMap Qubit + -> Circ (QDInt, IntMap (IntMap Qubit), IntMap Qubit) +a11_FetchE = box "a11" $ \i qs ps -> do + comment_with_label "ENTER: a11_FetchE" (i, qs, ps) ("i", "qs", "ps") + let r = qdint_length i + (i,qs,ps) <- loop_with_indexM (2^r) (i,qs,ps) (\j (i,qs,ps) -> + loop_with_indexM j (i,qs,ps) (\k (i,qs,ps) -> do + pk <- qnot (ps ! k) `controlled` + (qs ! j ! k) .&&. i .==. (fromIntegral j) + ps <- return $ insert k pk ps + pj <- qnot (ps ! j) `controlled` + (qs ! j ! k) .&&. i .==. (fromIntegral k) + ps <- return $ insert j pj ps + return (i,qs,ps))) + comment_with_label "EXIT: a11_FetchE" (i, qs, ps) ("i", "qs", "ps") + return (i,qs,ps) + +-- | Algorithm 12. +-- Perform a quantum-addressed swap. Analogous to 'a11_FetchE'. +a12_FetchStoreE :: QDInt -> IntMap (IntMap Qubit) -> IntMap Qubit + -> Circ (QDInt, IntMap (IntMap Qubit), IntMap Qubit) +a12_FetchStoreE = box "a12" $ \i qs ps -> do + comment_with_label "ENTER: a12_FetchStoreE" (i, qs, ps) ("i", "qs", "ps") + let r = qdint_length i + (i,qs,ps) <- loop_with_indexM (2^r) (i,qs,ps) (\j (i,qs, ps) -> + loop_with_indexM j (i,qs, ps) (\k (i,qs, ps) -> do + (q,p) <- a14_SWAP (qs ! j ! k) (ps ! k) + `controlled` i .==. (fromIntegral j) + (qs,ps) <- return (adjust (insert k q) j qs, insert k p ps) + (q,p) <- a14_SWAP (qs ! j ! k) (ps ! j) + `controlled` i .==. (fromIntegral k) + (qs,ps) <- return (adjust (insert k q) j qs, insert j p ps) + return (i,qs,ps))) + comment_with_label "EXIT: a12_FetchStoreE" (i, qs, ps) ("i", "qs", "ps") + return (i,qs,ps) + +-- | Algorithm 13. +-- Given a list of nodes /tt/, a distinguished node /ttd/, +-- and a list of bits /eed/, either: +-- +-- * store the edge information for /(ttd,tt)/ into /eed/, if /eed/ is initially 0; or +-- +-- * zero /eed/, if it initially holds the edge information. +a13_UPDATE :: QWTFP_spec -> IntMap QNode -> QNode -> IntMap Qubit + -> Circ (IntMap QNode, QNode, IntMap Qubit) +a13_UPDATE oracle@(n,r,edgeOracle,_) = box "a13" $ \tt ttd eed -> do + comment_with_label "ENTER: a13_UPDATE" (tt,ttd,eed) ("tt","ttd","eed") + (tt,ttd,eed) <- loop_with_indexM (2^r) (tt,ttd,eed) (\j (tt,ttd,eed) -> do + e <- edgeOracle (tt ! j) ttd (eed ! j) + return (tt,ttd,insert j e eed)) + comment_with_label "EXIT: a13_UPDATE" (tt,ttd,eed) ("tt","ttd","eed") + return (tt,ttd,eed) + +-- | Algorithm 14. Swap two registers of equal size. This is a +-- generic function and works for any quantum data type. +a14_SWAP :: QCData qa => qa -> qa -> Circ (qa, qa) +a14_SWAP q r = do + comment_with_label "ENTER: a14_SWAP" (q,r) ("q", "r") + (q,r) <- swap q r + comment_with_label "EXIT: a14_SWAP" (q,r) ("q", "r") + return (q,r) + +-- | The qRAM operations from Algorithms 8–10 wrapped into a 'Qram' object. +standard_qram :: Qram +standard_qram = Qram { + qram_fetch = a8_FetchT, + qram_store = a9_StoreT, + qram_swap = a10_FetchStoreT +} + +-- ====================================================================== +-- ** The inner quantum walk + +-- | A type to hold the Graph Collision Quantum Walk Registers +-- /(tau, iota, sigma, eew, cTri, triTestT)/, used in 'a20_GCQWStep'. +type GCQWRegs = (IntMap QDInt, QDInt, QDInt, IntMap Qubit, QDInt, Qubit) + +-- | Algorithm 15: /TestTriangleEdges/. +-- Test whether the nodes /tt/ contain a pair that can be extended to a +-- triangle in the graph. Used as the test function in the outer quantum +-- walk. Seeks triangles in two different ways: +-- +-- 1. Entirely within the nodes /tt/. If found, set qubit /triTestT/. +-- +-- 2. With two vertices from /tt/, a third anywhere in the graph. If found, +-- set qubit /triTestTw/, and return the third vertex as /w/. This is +-- implemented using an “inner quantum walk” to seek /w/. +a15_TestTriangleEdges :: + QWTFP_spec -- ^ The ambient oracle. + -> IntMap QNode -- ^ /tt/, an /R/-tuple of nodes. + -> IntMap (IntMap Qubit) -- ^ /ee/, a cache of the edge information between nodes in /tt/. + -> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit,Qubit) -- ^ Return /(tt, ee, w, triTestT,triTestTw)/. +a15_TestTriangleEdges oracle = box "a15" $ \tt ee -> do + comment_with_label "ENTER: a15_TestTriangleEdges" (tt,ee) ("tt","ee") + (ee,triTestT) <- a16_TriangleTestT ee + (tt,ee,w,triTestT) <- a18_TriangleEdgeSearch oracle tt ee triTestT + (tt,ee,w,triTestTw) <- a17_TriangleTestTw oracle tt ee w + comment_with_label "EXIT: a15_TestTriangleEdges" (tt,ee,w,triTestT,triTestTw) ("tt","ee","w","triTestT","triTestTw") + return (tt,ee,w,triTestT,triTestTw) + +-- | Algorithm 16: /TriangleTestT ee triTestT/. +-- Search exhaustively over the array /ee/ of edge data, seeking a triangle. +-- Whenever one is found, flip the qubit /triTestT/. +a16_TriangleTestT :: IntMap (IntMap Qubit) -> Circ (IntMap (IntMap Qubit), Qubit) +a16_TriangleTestT = box "a16" $ \ee -> do + comment_with_label "ENTER: a16_TriangleTestT" ee "ee" + let rr = size ee + (ee,triTestT) <- with_computed_fun ee + + (\ee -> do + cTri <- qinit (intm (ceiling (logBase 2 (fromIntegral (rr `choose` 3)))) 0) + cTri <- foldM (\cTri (i,j,k) -> do + cTri <- increment cTri `controlled` (ee ! j ! i) .&&. (ee ! k ! i) .&&. (ee ! k ! j) + return cTri) + cTri [(i,j,k) | i <- [0..rr-1], j <- [i+1..rr-1], k <- [j+1..rr-1]] + return (ee,cTri)) + + (\(ee,cTri) -> do + triTestT <- qinit True + triTestT <- qnot triTestT `controlled` cTri .==. 0 + return ((ee,cTri),triTestT)) + + comment_with_label "EXIT: a16_TriangleTestT" (ee,triTestT) ("ee","triTestT") + return (ee,triTestT) + +{-Alternative implementation, using (a lot of) extra ancillas instead of a counter: +a16_TriangleTestT :: [[Qubit]] -> Qubit -> Circ ([[Qubit]], Qubit) +a16_TriangleTestT ee triTestT = do + let rr = length ee + ((ee,triTestT),_) <- with_computed_fun + + (\(ee,triTestT) -> do + tests <- mapM (\(i,j,k) -> do + t <- a2_ZERO False + t <- qnot t `controlled` + [(ee !! j !! i),(ee !! k !! i),(ee !! k !! j)] + return(t)) + [(i,j,k) | i <- [0..rr-1], j <- [i+1..rr-1], k <- [j+1..rr-1]] + return (ee,triTestT,tests)) + + (ee,triTestT) + + (\(ee,triTestT,tests) -> do + triTestT <- qor triTestT (map (\p -> (p,True)) tests) + return ((ee,triTestT,tests),())) + + return (ee,triTestT)-} + + +-- | Algorithm 17: /TriangleTestTw ee triTestTw/. +-- Search exhaustively for a pair of nodes in /tt/ that form a triangle with /w/. +-- Whenever a triangle found, flip qubit /triTestTw/. +a17_TriangleTestTw :: QWTFP_spec -- ^ The ambient oracle. + -> IntMap QNode -- ^ /tt/, an /R/-tuple of nodes. + -> IntMap (IntMap Qubit) -- ^ /ee/, a cache of the edge data for /T/. + -> QNode -- ^ /w/, another node. + -> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit) -- ^ return /(tt,ee,w,triTestTw)/. +a17_TriangleTestTw oracle@(n,r,edgeOracle,_) = box "a17" $ \tt ee w -> do + comment_with_label "ENTER: a17_TriangleTestTw" (tt,ee,w) ("tt","ee","w") + let rr = size ee + with_ancilla_init (intMap_replicate rr False) $ \eed -> do + ((tt,ee,w,eed),triTestTw) <- with_computed_fun (tt,ee,w,eed) + + (\(tt,ee,w,eed) -> do + eed <- mapWithKeyM (\k e -> do + e <- edgeOracle (tt ! k) w e + return e) + eed + cTri <- qinit (intm (ceiling (logBase 2 (fromIntegral (rr `choose` 2)))) 0) + cTri <- foldM + (\cTri (i,j) -> + increment cTri `controlled` (ee ! j ! i) .&&. (eed ! i) .&&. (eed ! j)) + cTri + [(i,j) | i <- [0..rr-1], j <- [i+1..rr-1]] + return (tt,ee,w,eed,cTri)) + + (\(tt,ee,w,eed,cTri) -> do + triTestTw <- qinit True + triTestTw <- qnot triTestTw `controlled` cTri .==. 0 + return ((tt,ee,w,eed,cTri),triTestTw)) + + comment_with_label "EXIT: a17_TriangleTestTw" (tt,ee,w,triTestTw) ("tt","ee","w","triTestTw") + return (tt,ee,w,triTestTw) + +{-Alternative implementation, using (a lot of) extra ancillas instead of a counter: +a17_TriangleTestTw oracle@(n,r,edgeOracle) tt ee w triTestTw = do + let rr = length ee + with_ancilla_list rr $ \eed -> do + ((tt,ee,w,triTestTw,eed),_) <- with_computed_fun + + (\(tt,ee,w,triTestTw,eed) -> do + eed <- mapM (\(b,a) -> do + b <- edgeOracle (tt !! a) w b + return (b)) + (zip (eed) [0..rr-1]) + tests <- mapM (\(i,j) -> do + t <- a2_ZERO False + t <- qnot t `controlled` (ee !! j !! i) .&&. (eed !! i) .&&. (eed !! j) + return(t)) + [(i,j) | i <- [0..rr-1], j <- [i+1..rr-1]] + return (tt,ee,w,triTestTw,eed,tests)) + + (tt,ee,w,triTestTw,eed) + + (\(tt,ee,w,triTestTw,eed,tests) -> do + triTestTw <- qor triTestTw (map (\p -> (p,True)) tests) + return ((tt,ee,w,triTestTw,eed,tests),())) + + return (tt,ee,w,triTestTw)-} + + +-- | Algorithm 18: /TriangleEdgeSearch/. +-- Use Grover search to seek a node /w/ that forms a triangle with some pair of +-- nodes in /tt/, unless a triangle has already been found (recorded in /triTestT/), +-- in which case do nothing. +a18_TriangleEdgeSearch :: QWTFP_spec -- ^ The ambient oracle. + -> IntMap QNode -- ^ /tt/, an /R/-tuple of nodes. + -> IntMap (IntMap Qubit) -- ^ /ee/, a cache of edge data for /R/. + -> Qubit -- ^ /triTestT/, test qubit recording if a triangle has already been found. + -> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit) -- ^ Return /(tt, ee, w, regs)/. +a18_TriangleEdgeSearch oracle@(n,r,edgeOracle,_) = box "a18" $ \tt ee triTestT -> do + comment_with_label "ENTER: a18_TriangleEdgeSearch" (tt,ee,triTestT) ("tt","ee","triTestT") + let nn = 2^n + tG = floor (pi/4 *( sqrt ( fromIntegral nn))) + + w <- a2_ZERO (replicate n False) + w <- a4_HADAMARD w + + box_loopM "a18_loop" tG (tt,ee,w,triTestT) (\(tt,ee,w,triTestT) -> do + ((tt,ee,w,triTestT),()) <- with_computed_fun (tt,ee,w,triTestT) + + (\(tt,ee,w,triTestT) -> do + (tt,ee,w,triTestT,cTri) <- a19_GCQWalk oracle tt ee w triTestT + + cTri_nonzero <- qinit True + cTri_nonzero <- qnot cTri_nonzero `controlled` cTri .==. 0 + + return (tt,ee,w,triTestT,cTri,cTri_nonzero)) + + (\(tt,ee,w,triTestT,cTri,cTri_nonzero) -> do + phaseFlipIf $ (triTestT .==. 0) .&&. cTri_nonzero + return ((tt,ee,w,triTestT,cTri,cTri_nonzero),())) + + w <- a7_DIFFUSE w + return (tt,ee,w,triTestT)) + comment_with_label "EXIT: a18_TriangleEdgeSearch" (tt,ee,w,triTestT) ("tt","ee","w","triTestT") + return (tt,ee,w,triTestT) + +-- | Algorithm 19: /GCQWalk/ (“Graph Collision Quantum Walk”) +-- +-- Perform graph collision on the /R/-tuple /tt/ and the node /w/, to determine +-- (with high probability) whether /w/ forms a triangle with some pair of nodes +-- in /tt/. +a19_GCQWalk :: QWTFP_spec -- ^ The ambient oracle. + -> IntMap QNode -- ^ /tt/, an /R/-tuple of nodes. + -> IntMap (IntMap Qubit) -- ^ /ee/, a cache of the edge data for /tt/. + -> QNode -- ^ /w/, a node. + -> Qubit -- ^ /triTestT/, test qubit to record if a triangle has already been found. + -> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit, QDInt) -- ^ Return /(tt,ee,w,triTestT,cTri)/. +a19_GCQWalk oracle@(n,r,edgeOracle,qram) = box "a19" $ \tt ee w triTestT -> do + comment_with_label "ENTER: a19_GCQWalk" (tt,ee,w,triTestT) ("tt","ee","w","triTestT") + let nn = 2^n + rr = 2^r + rbar = max ((2 * r) `div` 3) 1 + rrbar = 2^rbar + tbarm = max (rr `div` rrbar) 1 + tbarw = floor $ sqrt $ fromIntegral rrbar + + cTri <- qinit (intm (2*rbar - 1) 0) + + with_ancilla_init + ((intMap_replicate rrbar (intm r 0)), + (intm rbar 0), + (intm r 0), + (intMap_replicate rrbar False)) + $ \(tau,iota,sigma,eew) -> do + + tau <- a4_HADAMARD tau + iota <- a4_HADAMARD iota + sigma <- a4_HADAMARD sigma + + eew <- mapWithKeyM (\j eew_j -> do + let taub = tau ! j + ttd <- qinit (replicate n False) + (taub, tt, ttd) <- qram_fetch qram taub tt ttd + eew_j <- edgeOracle ttd w eew_j + (taub, tt, ttd) <- qram_fetch qram taub tt ttd + qterm (replicate n False) ttd + return eew_j) + eew + + cTri <- foldM (\cTri j -> do + let tau_j = tau ! j + eed <- qinit (intMap_replicate rr False) + (taub,ee,eed) <- a11_FetchE tau_j ee eed + cTri <- foldM (\cTri k -> do + let tau_k = tau ! k + -- Note: the Fetch to eedd_k seems redundant here; why not control on (eedd !! k) directly? + eedd_k <- qinit False + (tauc, eed, eedd_k) <- qram_fetch qram tau_k eed eedd_k + cTri <- increment cTri `controlled` eedd_k .&&. (eew ! j) .&&. (eew ! k) + (tauc, eed, eedd_k) <- qram_fetch qram tau_k eed eedd_k + qterm False eedd_k + return cTri) + cTri [j+1..rrbar-1] + (taub,ee,eed) <- a11_FetchE tau_j ee eed + qterm (intMap_replicate rr False) eed + return cTri) + cTri [0..rrbar-1] + + (tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT)) <- box_loopM "a19_loop1" tbarm + (tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT)) + + (\(tt,ee,w,(e1,e2,e3,e4,cTri,triTestT)) -> do + ((cTri,triTestT),()) <- with_computed_fun (cTri,triTestT) + + (\(cTri,triTestT) -> do + cTri_nonzero <- qinit True + cTri_nonzero <- qnot cTri_nonzero `controlled` cTri .==. 0 + return (cTri,triTestT,cTri_nonzero)) + + (\(cTri,triTestT,cTri_nonzero) -> do + phaseFlipIf $ (triTestT .==. 0) .&&. cTri_nonzero + return ((cTri,triTestT,cTri_nonzero),())) + + box_loopM "a19_loop2" tbarw (tt,ee,w,(e1,e2,e3,e4,cTri,triTestT)) (\(b,c,d,e) -> a20_GCQWStep oracle b c d e)) + + comment_with_label "EXIT: a19_GCQWalk" (tt,ee,w,triTestT,cTri) ("tt","ee","w","triTestT","cTri") + return (tt,ee,w,triTestT,cTri) + + +-- | Algorithm 20: /GCQWStep/ +-- Take one step in the graph collision walk (used in 'a19_GCQWalk' above). +-- Uses many auxiliary registers. +-- The arguments are, in this order: +-- +-- * The ambient oracle. +-- +-- * /tt/, an /R/-tuple of nodes. +-- +-- * /ee/, a cache of the edge data for /tt/. +-- +-- * /w/, a node. +-- +-- * /regs/, various workspace\/output registers. +-- +-- * /ttd/, /eed/, /taud/, /eewd/, and /eedd/, local ancillas. +-- +-- The function returns /(tt, ee, w, regs)/. +a20_GCQWStep :: QWTFP_spec + -> IntMap QNode + -> IntMap (IntMap Qubit) + -> QNode + -> GCQWRegs + -> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, GCQWRegs) +a20_GCQWStep oracle@(n,r,edgeOracle,qram) = box "a20" $ + \tt ee w gcqwRegs@(tau,iota,sigma,eew,cTri,triTestT) -> do + comment_with_label "ENTER: a20_GCQWStep" (tt,ee,w,tau,iota,sigma,eew,cTri,triTestT) ("tt","ee","w","tau","iota","sigma","eew","cTri","triTestT") + let rr = 2^r + rbar = max ((2 * r) `div` 3) 1 + rrbar = 2^rbar + + (iota, sigma) <- a7_DIFFUSE (iota, sigma) + + ((tt,ee,w,gcqwRegs),_) <- with_computed_fun (tt,ee,w,gcqwRegs) + + (\(tt,ee,w,gcqwRegs@(tau,iota,sigma,eew,cTri,triTestT)) -> do + ttd <- qinit (replicate n False) + eed <- qinit (intMap_replicate rr False) + taud <- qinit (intm r 0) + eewd <- qinit False + eedd <- qinit (intMap_replicate rrbar False) + + (iota, tau, taud) <- qram_fetch qram iota tau taud + (taud, tt, ttd) <- qram_fetch qram taud tt ttd + (iota,eew,eewd) <- qram_swap qram iota eew eewd + (taud,ee,eed) <- a11_FetchE taud ee eed + eedd <- mapWithKeyM (\k eeddb -> do + let taub = tau ! k + (taub, eed, eeddb) <- qram_fetch qram taub eed eeddb + return eeddb) + eedd + cTri <- loop_with_indexM (rrbar-1) cTri (\a cTri -> do + decrement cTri `controlled` (eedd ! a) .&&. (eewd) .&&. (eew ! a)) + eewd <- edgeOracle ttd w eewd + eedd <- mapWithKeyM (\k e -> do + let taub = tau ! k + let eeddb = eedd ! k + (taub, eed, eeddb) <- qram_fetch qram taub eed eeddb + return e) + eedd + (taud,ee,eed) <- a11_FetchE taud ee eed + (taud,tt,ttd) <- qram_fetch qram taud tt ttd + (iota,tau,taud) <- qram_store qram iota tau taud + return (tt,ee,w,gcqwRegs,ttd,eed,taud,eewd,eedd)) + + (\(tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT),ttd,eed,taud,eewd,eedd) -> do + (taud,sigma) <- a14_SWAP taud sigma + return ((tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT),ttd,eed,taud,eewd,eedd),())) + + comment_with_label "ENTER: a20_GCQWStep" (tt,ee,w,gcqwRegs) ("tt","ee","w",("tau","iota","sigma","eew","cTri","triTestT")) + return (tt,ee,w,gcqwRegs) diff --git a/dist/build/Quipper/Algorithms/TF/Simulate.hs b/dist/build/Quipper/Algorithms/TF/Simulate.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/TF/Simulate.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/TF/Simulate.hs" #-} +-- | This module contains functions for simulating and debugging +-- the Triangle Finding Oracle and its subroutines. + +module Quipper.Algorithms.TF.Simulate where + +import Quipper + +import Quipper.Libraries.Arith +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.TF.Definitions +import Quipper.Algorithms.TF.Oracle +import Quipper.Algorithms.TF.Alternatives + +import Data.Maybe + +import Quipper.Utils.Sampling +import Quipper.Utils.Auxiliary (boollist_of_int_bh) + +-- ====================================================================== +-- * Native and simulated arithmetic functions + +-- $ For each arithmetic routine implemented in the Triangle Finding +-- Oracle, we give two parallel implementations: one using Haskell’s +-- arithmetic, and one by simulating the circuit execution. +-- +-- These can then be cross-checked against each other for correctness. + +-- | Increment an /m/-bit Quipper integer (mod 2[sup /m/]). Native Haskell. +increment_haskell :: IntM -> IntM +increment_haskell = succ + +-- | Increment an /m/-bit Quipper integer (mod 2[sup /m/]). Simulated from +-- 'increment'. +increment_simulate :: IntM -> IntM +increment_simulate = run_classical_generic increment + +-- | Increment an /m/-bit Triangle Finding integer (mod 2[sup /m/]–1). +-- Native Haskell. +incrementTF_haskell :: IntTF -> IntTF +incrementTF_haskell x1 = (inttf m ((x+1) `mod` (2^m - 1))) + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + +-- | Increment an /m/-bit TF integer (mod 2[sup /m/]–1). Simulated from +-- 'increment_TF'. +incrementTF_simulate :: IntTF -> IntTF +incrementTF_simulate = run_classical_generic increment_TF + +-- | Double an /m/-bit TF integer (mod 2[sup /m/]–1). Native Haskell. +doubleTF_haskell :: IntTF -> IntTF +doubleTF_haskell x1 = (inttf m ((2*x) `mod` (2^m - 1))) + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + +-- | Double an /m/-bit TF integer (mod 2[sup /m/]–1). Simulated from +-- 'double_TF'. +doubleTF_simulate :: IntTF -> IntTF +doubleTF_simulate = run_classical_generic double_TF + +-- | Add two 'IntTF's. Native Haskell. +addTF_haskell :: IntTF -> IntTF -> IntTF +addTF_haskell x1 y1 = + if (m == n) then (inttf m $ (x + y) `mod` (2^m - 1)) + else error "addTF_haskell: Cannot add IntTF’s with different moduli." + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + n = fromJust (inttf_length y1) + y = integer_of_inttf y1 + +-- | Add two 'IntTF's. Simulated from 'o7_ADD'. +addTF_simulate :: IntTF -> IntTF -> IntTF +addTF_simulate = + run_classical_generic (\x y -> do + (_,_,z) <- o7_ADD x y + return z) + +-- | Multiply two 'IntTF's. Native Haskell. +multTF_haskell :: IntTF -> IntTF -> IntTF +multTF_haskell x1 y1 = + if (m == n) then (inttf m $ (x * y) `mod` (2^m - 1)) + else error "multTF_haskell: Cannot multiply IntTF’s with different moduli." + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + n = fromJust (inttf_length y1) + y = integer_of_inttf y1 + +-- | Multiply two 'IntTF's. Simulated from 'o8_MUL'. +multTF_simulate :: IntTF -> IntTF -> IntTF +multTF_simulate = + run_classical_generic (\x y -> do + (_,_,z) <- o8_MUL x y + return z) + +-- | Raise an 'IntTF' to the 17th power. Native Haskell. +pow17_haskell :: IntTF -> IntTF +pow17_haskell x1 = inttf m ((x^17) `mod` (2^m - 1)) + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + +-- | Raise an 'IntTF' to the 17th power. Simulated from 'o4_POW17'. +pow17_simulate :: IntTF -> IntTF +pow17_simulate = + run_classical_generic (\x -> do + (_,z) <- o4_POW17 x + return z) + +-- | Compute the reduction, mod 3, of lower-order bits of an 'IntTF'. +-- Native Haskell. +mod3_haskell :: IntTF -> IntTF +mod3_haskell x1 = inttf 2 ((x `mod` (2^(m-1))) `mod` 3) + where + m = fromJust (inttf_length x1) + x = integer_of_inttf x1 + +-- | Compute the reduction, mod 3, of lower-order bits of an 'IntTF'. +-- Simulated from 'o5_MOD3'. +mod3_simulate :: IntTF -> IntTF +mod3_simulate = + run_classical_generic (\x -> do + (_,z) <- o5_MOD3 x + return z) + +-- | Compute the reduction, mod 3, of lower-order bits of an 'IntTF'. +-- Simulated from 'o5_MOD3_alt'. +mod3_alt_simulate :: IntTF -> IntTF +mod3_alt_simulate = + run_classical_generic (\x -> do + (_,z) <- o5_MOD3_alt x + return z) + +-- ====================================================================== +-- * Native and simulated oracle functions + +-- | Oracle: compute the edge information between two nodes. +-- Native Haskell. +oracle_haskell :: Int -> [Bool] -> [Bool] -> Bool +oracle_haskell l u v + | n /= length v = error "oracle_haskell: bad input size: length of v and u must be the same" + | n >= l = error "oracle_haskell: bad input size: n must be less than l" + | otherwise = + if uint == vint then False + else if (u17 == uint) && (v17 == vint) then True + else if (u17 /= uint) && (v17 /= vint) then + (uH /= vH) && (u3 /= v3) + else (u3 == v3) + where + modup z n = ((z-1) `mod` n) + 1 + n = length u :: Int + hn = 2^(n-1) + incl :: [Bool] -> Integer + incl x = + ((sum [ if b then 2^i else 0 | (b,i) <- zip x [0..]]) - hn) + `modup` (2^l - 1) + uint = incl u + vint = incl v + u17 = (uint^17) `modup` (2^l - 1) + v17 = (vint^17) `modup` (2^l - 1) + u3 = (u17 `mod` 2^(l-1)) `modup` 3 + v3 = (v17 `mod` 2^(l-1)) `modup` 3 + uF = u17 == uint + vF = v17 == vint + uH = (uint >= 2^(l-1)) + vH = (vint >= 2^(l-1)) + +-- | Oracle: compute the edge information between two nodes. +-- Simulated from 'o1_ORACLE'. +oracle_simulate :: Int -> [Bool] -> [Bool] -> Bool +oracle_simulate l = + run_classical_generic (\u v -> do + e <- qinit False + (u,v,e) <- o1_ORACLE l u v e + return e) + + +-- | Oracle auxiliary information. Native Haskell. +oracle_aux_haskell :: Int -> [Bool] -> [Bool] -> + (([Bool], [Bool]), + (IntTF, IntTF, IntTF, IntTF, IntTF, IntTF), + (Bool, Bool, Bool, Bool, Bool, Bool, Bool)) +oracle_aux_haskell l u v + | n /= length v = error "oracle_aux_haskell: bad input size: length of v and u must be the same" + | n >= l = error "oracle_aux_haskell: bad input size: n must be less than l" + | otherwise = + ((u,v),(inttf l uint,inttf l vint,inttf l u17,inttf l v17,inttf 2 u3,inttf 2 v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) + where + modup z n = ((z-1) `mod` n) + 1 + n = length u :: Int + hn = 2^(n-1) + incl :: [Bool] -> Integer + incl x = + ((sum [ if b then 2^i else 0 | (b,i) <- zip x [0..]]) - hn) + `modup` (2^l - 1) + uint = incl u + vint = incl v + u17 = (uint^17) `modup` (2^l - 1) + v17 = (vint^17) `modup` (2^l - 1) + u3 = (u17 `mod` 2^(l-1)) `modup` 3 + v3 = (v17 `mod` 2^(l-1)) `modup` 3 + uF = u17 == uint + vF = v17 == vint + uH = (uint >= 2^(l-1)) + vH = (vint >= 2^(l-1)) + t_uv = uint == vint + t_uHvH = uH == vH + t_u3v3 = u3 == v3 + + +-- | Oracle auxiliary information. Simulated from 'o1_ORACLE_aux'. +oracle_aux_simulate :: Int -> [Bool] -> [Bool] -> + (([Bool], [Bool]), + (IntTF, IntTF, IntTF, IntTF, IntTF, IntTF), + (Bool, Bool, Bool, Bool, Bool, Bool, Bool)) +oracle_aux_simulate l = + run_classical_generic (\u v -> o1_ORACLE_aux l (2^((length u)-1)) (u,v)) + +-- | A specialized 'show' for oracle auxiliary data. +show_oracle_details :: Show a => (([Bool], [Bool]), + (a,a,a,a,a,a), + (Bool, Bool, Bool, Bool, Bool, Bool, Bool)) + -> String +show_oracle_details ((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) + = (showBits u) ++ " " ++ (showBits v) ++ " " ++ + showBits [uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3] ++ " " ++ + show [uint,vint,u17,v17,u3,v3] + where + showBits :: [Bool] -> String + showBits [] = "[]" + showBits bs = map (\b -> if b then '1' else '0') bs + +-- | Conversion of a node to an integer. Native Haskell. +convertNode_haskell :: Int -> [Bool] -> IntTF +convertNode_haskell l u = inttf l (incl u) + where + incl :: [Bool] -> Integer + incl u = + ((sum [ if b then 2^i else 0 | (b,i) <- zip u [0..]]) - (2^((length u)-1))) + `mod` (2^l - 1) + +-- | Conversion of a node to an integer. Simulated from 'o2_ConvertNode'. +convertNode_simulate :: Int -> [Bool] -> IntTF +convertNode_simulate l = run_classical_generic (\u -> do + (u,uint) <- o2_ConvertNode l u (2^((length u)-1)) + return uint) + +-- ====================================================================== +-- * Testing functions + +-- $ Various small test suites, checking the simulated circuit arithmetic +-- functions against their Haskell equivalents. + +-- | Give full table of values for 'increment' functions. +increment_table :: Int -> [String] +increment_table l = [ "increment table for l = " ++ (show l) ++ ":" + , "" + , "x x+H x+Q "] + ++ + [ (show x) ++ " " ++ (show x_h) ++ " " ++ (show x_q) ++ flag + | x <- [0..(2^l - 1)] + , let x_h = integer_of_intm_unsigned $ increment_haskell (intm l x) + , let x_q = integer_of_intm_unsigned $ increment_simulate (intm l x) + , let flag = if x_h /= x_q then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the 'increment_TF' functions. +incrementTF_table :: Int -> [String] +incrementTF_table l = [ "incrementTF table for l = " ++ (show l) ++ ":" + , "" + , "x x+H x+Q "] + ++ + [ (show x) ++ " " ++ (show x_h) ++ " " ++ (show x_q) ++ flag + | x <- [0..(2^l - 2)] + , let x_h = incrementTF_haskell (inttf l x) + , let x_q = incrementTF_simulate (inttf l x) + , let flag = if x_h /= x_q then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the 'double_TF' functions. +doubleTF_table :: Int -> [String] +doubleTF_table l = [ "doubleTF table for l = " ++ (show l) ++ ":" + , "" + , "x 2xH 2xQ "] + ++ + [ (show x) ++ " " ++ (show x_h) ++ " " ++ (show x_q) ++ flag + | x <- [0..(2^l - 2)] + , let x_h = doubleTF_haskell (inttf l x) + , let x_q = doubleTF_simulate (inttf l x) + , let flag = if x_h /= x_q then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the TF addition ('o7_ADD') +-- functions. +addTF_table :: Int -> [String] +addTF_table l = [ "addTF table for l = " ++ (show l) ++ ":" + , "" + , "x y x+yH x+yQ "] + ++ + [ (show x) ++ " " ++ (show y) ++ " " + ++ (show xyh) ++ " " ++ (show xyq) + ++ flag + | x <- [0..(2^l - 1)] , y <- [0..(2^l - 1)] + , let xyh = addTF_haskell (inttf l x) (inttf l y) + , let xyq = addTF_simulate (inttf l x) (inttf l y) + , let flag = if xyh /= xyq then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the TF multiplication ('o8_MUL') +-- functions. +multTF_table :: Int -> [String] +multTF_table l = [ "multTF table for l = " ++ (show l) ++ ":" + , "" + , "x y x*yH x*yQ "] + ++ + [ (show x) ++ " " ++ (show y) ++ " " + ++ (show xyh) ++ " " ++ (show xyq) + ++ flag + | x <- [0..(2^l - 1)] , y <- [0..(2^l - 1)] + , let xyh = multTF_haskell (inttf l x) (inttf l y) + , let xyq = multTF_simulate (inttf l x) (inttf l y) + , let flag = if xyh /= xyq then " **MISMATCH**" else ""] + ++ + ["",""] + + +-- | Give full table of values for the \'pow17\' functions. +pow17_table :: Int -> [String] +pow17_table l = [ "pow17 table for l = " ++ (show l) ++ ":" + , "" + , "x x17H x17Q "] + ++ + [ (show x) ++ " " ++ (show x_h) ++ " " ++ (show x_q) ++ flag + | x <- [0..(2^l - 1)] + , let x_h = pow17_haskell (inttf l x) + , let x_q = pow17_simulate (inttf l x) + , let flag = if x_h /= x_q then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the \'mod3\' functions. +mod3_table :: Int -> [String] +mod3_table l = [ "mod3 table for l = " ++ (show l) ++ ":" + , "" + , "x Haskell o5_MOD3 o5_MOD3_alt"] + ++ + [ (show x) ++ " " ++ (show x_h) ++ " " + ++ (show x_q) ++ flag + | x <- [0..(2^l - 1)] + , let x_h = mod3_haskell (inttf l x) + , let x_q = mod3_simulate (inttf l x) + , let x_q' = mod3_alt_simulate (inttf l x) + , let flag = if x_h /= x_q then " **MISMATCH**" else ""] + ++ + ["",""] + +-- | Give full table of values for the oracle. +oracle_table :: Int -> Int -> [String] +oracle_table n l = [ "oracle table for l = " ++ (show l) ++ ", n = " ++ (show n) ++ ":" + , "" + , "u v E_H E_Q"] + ++ + [ (showBits u) ++ " " ++ (showBits v) ++ " " + ++ (show e_h) ++ " " ++ (show e_q) ++ flag + | uint <- [0..(2^n - 1)], let u = boollist_of_int_bh n uint + , vint <- [0..(2^n - 1)], let v = boollist_of_int_bh n vint + , let e_h = oracle_haskell l u v + , let e_q = oracle_simulate l u v + , let flag = if e_h /= e_q then " **MISMATCH**" else ""] + ++ + ["",""] + where + showBits :: [Bool] -> String + showBits [] = "[]" + showBits bs = map (\b -> if b then '1' else '0') bs + +-- | Give a full table of values for 'o1_ORACLE_aux'. +oracle_table_detailed :: Int -> Int -> [String] +oracle_table_detailed n l = [ "oracle_aux table for l = " ++ (show l) ++ ", n = " ++ (show n) ++ ":" + , "" + , "((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3))"] + ++ + (concat + [ [show_oracle_details od_h,show_oracle_details od_q] + | uint <- [0..(2^n - 1)], let u = boollist_of_int_bh n uint + , vint <- [0..(2^n - 1)], let v = boollist_of_int_bh n vint + , let od_h = oracle_aux_haskell l u v + , let od_q = oracle_aux_simulate l u v + , let flag = if od_h /= od_q then " **MISMATCH**" else "" + ]) + ++ + ["",""] + where + showBits :: [Bool] -> String + showBits [] = "[]" + showBits bs = map (\b -> if b then '1' else '0') bs + + +-- | Give full table of values for the \'convertNode\' functions. +convertNode_table :: Int -> Int -> [String] +convertNode_table l n = [ "convertNode table for l = " ++ (show l) ++ ", n = " ++ (show n) ++ ":" + , "" + , "u uint_H uint_Q"] + ++ + [ (showBits u) ++ " " ++ (show u_h) ++ " " ++ (show u_q) ++ flag + | uint <- [0..(2^n - 1)], let u = boollist_of_int_bh n uint + , let u_h = convertNode_haskell l u + , let u_q = convertNode_simulate l u + , let flag = if u_h /= u_q then " **MISMATCH**" else ""] + ++ + ["",""] + where + showBits :: [Bool] -> String + showBits [] = "[]" + showBits bs = map (\b -> if b then '1' else '0') bs + +-- | A compilation of the various tests above, to be called by +-- 'Quipper.Algorithms.TF.Main'. +arithmetic_tests :: Int -> IO () +arithmetic_tests l = do + mapM putStrLn $ increment_table l + mapM putStrLn $ incrementTF_table l + mapM putStrLn $ doubleTF_table l + mapM putStrLn $ addTF_table l + mapM putStrLn $ multTF_table l + mapM putStrLn $ pow17_table l + mapM putStrLn $ mod3_table l + return () + +-- | A suite of tests for the oracle, to be called by +-- 'Quipper.Algorithms.TF.Main'. +oracle_tests :: Int -> Int -> IO () +oracle_tests n l = do + mapM_ putStrLn $ oracle_table n l + mapM_ putStrLn $ oracle_table_detailed n l + mapM_ putStrLn $ convertNode_table l n diff --git a/dist/build/Quipper/Algorithms/USV/Definitions.hs b/dist/build/Quipper/Algorithms/USV/Definitions.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/USV/Definitions.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/USV/Definitions.hs" #-} +-- | This module provides global definitions for +-- the Unique Shortest Vector algorithm. + +module Quipper.Algorithms.USV.Definitions where + +import Quipper +import Quipper.Libraries.Arith + +import Control.Monad (foldM, zipWithM, replicateM) +import qualified Math.Lattices.LLL +import Data.Array +import Data.List (mapAccumL) +import Data.Numbers.Primes +import System.Random +import qualified Data.Map as Map +import Data.Map (Map) + + +-- ============================================================== +-- * Types for the Unique Shortest Vector algorithm + +-- | An input to 'Quipper.Algorithms.USV.USV.tPP': a pair of a 'Qubit' +-- and a list of 'QDInt's. Holds a superposition of two vectors with +-- an unknown fixed difference. +type TwoPoint = (Qubit, [QDInt]) + +-- | An input to 'Quipper.Algorithms.USV.USV.dCP': a pair of a 'Qubit' +-- and a 'QDInt'. Holds a superposition of two numbers with an unknown +-- fixed difference. +type CosetState = (Qubit, QDInt) + +-- | An input to 'Quipper.Algorithms.USV.USV.sieving': a pair of a +-- 'Qubit' and an integer. Holds a state of the form: +-- +-- \[image CosetState.png] +-- +-- together with the integer /k/. +type Psi_k = (Qubit, Int) + + +-- ============================================================== +-- * General purpose functions + +-- | Concatenate two pairs of lists componentwise. +concat_pair :: ([a],[b]) -> ([a],[b]) -> ([a],[b]) +concat_pair (i,j) (k,l) = (i ++ k, j ++ l) + +-- | Construct a list of random number generators. +multi_split :: StdGen -> [StdGen] +multi_split gen = gen1 : multi_split gen2 where + (gen1, gen2) = split gen + +-- | Given a list /l/, a predicate /p/ and an error message /msg/, +-- return a pair (/a/,/l'/) where /a/ is the first element +-- of /l/ satisfying /p/ and /l'/ is the remaining list. +-- If no such element exists, raise an error and display /msg/. +find :: [a] -> (a -> Bool) -> String -> (a, [a]) +find [] condition msg = error msg +find (a:as) condition msg = + if (condition a) then (a,as) + else (b,(a:bs)) + where + (b,bs) = find as condition msg + +-- | Given a list /l/ and a predicate /p/, return a pair +-- (/l1/, /l2/) where /l1/ contains the elements of /l/ +-- satisfying /p/ and /l2/ the others. +separate :: [a] -> (a -> Bool) -> ([a], [a]) +separate [] condition = ([],[]) +separate (h:t) condition = + if (condition h) then concat_pair ([h],[]) (separate t condition) + else concat_pair ([],[h]) (separate t condition) + +-- | Given integers /m/ and /n/, compute the +-- big-endian expansion of /m/ in base /n/. +expand :: Integer -> Integer -> [Integer] +expand _ n | n <= 1 = error ("Cannot expand a number in base " ++ show n ++ ".") +expand 0 n = [0] +expand m n = reverse $ expand_aux m n [] + where + expand_aux 0 n l = l + expand_aux m n l = (m-s) : expand_aux r n l where + r = m `div` n + s = n*r + +-- | Discard a list of 'Psi_k's +qdiscard_psi_ks :: [Psi_k] -> Circ () +qdiscard_psi_ks l = do + mapM (\(q,n) -> do + qdiscard q + return ()) l + return () + +-- | Given a list of people, and a function assigning a religion to +-- each person, divide the people into couples of the same religion. +-- Some people will remain single if there isn't a suitable +-- partner. Return a list of couples and a list of single people. +-- +-- The algorithm proceeds as follows. We have a room for each +-- religion. Initially the rooms are empty. As each person arrives, +-- they go to their room. If the room is empty, they stay there. If +-- the room is occupied, they marry the occupant and join the list +-- of couples. At the end, all single people are retrieved from +-- their rooms. +-- +-- This function is lazy, i.e., couples are formed as they are +-- found. Only the singles have to wait until the end of the list. +-- +-- Running time is O(/n/ log /n/). +find_partners :: (Ord b) => (a -> b) -> [a] -> ([(a,a)], [a]) +find_partners f = find_partners_in_rooms Map.empty + where + --find_partners_in_rooms :: Map b a -> [a] -> ([(a,a)], [a]) + find_partners_in_rooms rooms [] = ([], Map.elems rooms) + find_partners_in_rooms rooms (a:as) = + case Map.lookup (f a) rooms of + Just c -> ((a,c):pairs, singles) + where (pairs, singles) = find_partners_in_rooms rooms' as + rooms' = Map.delete (f a) rooms + Nothing -> find_partners_in_rooms rooms' as + where rooms' = Map.insert (f a) a rooms + + +-- ============================================================== +-- * Linear algebra + +-- | Compute the Euclidean norm of a vector. +norm :: [Integer] -> Float +norm v = sqrt $ fromIntegral $ foldl (+) 0 $ map (\x -> x^2) v + +-- | Compute the sum of two vectors. +vector_add :: Num a => [a] -> [a] -> [a] +vector_add u v = zipWith (+) u v + +-- | Quantum version of 'vector_add'. +q_vector_add :: [QDInt] -> [QDInt] -> Circ [QDInt] +q_vector_add u v = do + w <- zipWithM q_add u v + return (map (\(_,_,z) -> z) w) + +-- | Compute the multiplication of a scalar with a vector. +scalar_mult :: Num a => a -> [a] -> [a] +scalar_mult n v = map (\x -> n*x) v + +-- | Quantum version of 'scalar_mult'. +q_scalar_mult :: QDInt -> [QDInt] -> Circ [QDInt] +q_scalar_mult a v = do + v' <- mapM (\u -> do + (_,_,z) <- q_mult a u + return z) v + return v' + +-- | Multiply an /n/×/m/-matrix by an /m/-dimensional column +-- vector to obtain an /n/-dimensional column vector. The +-- matrix is represented as a list of /m/ columns. +-- +-- Precondition: /m/ > 0. +-- +-- Example: +-- +-- > matrix_mult [[1,2,3],[1,0,0]] [1,1] = [2,2,3] +matrix_mult :: [[Integer]] -> [Integer] -> [Integer] +matrix_mult m a = foldl vector_add zero $ zipWith scalar_mult a m + where + zero = replicate (length (head m)) 0 + +-- | Quantum version of 'matrix_mult'. +q_matrix_mult :: [[QDInt]] -> [QDInt] -> Circ [QDInt] +q_matrix_mult m a = do + let l1 = length (head m) + l2 = qdint_length (head a) + zero <- qinit (replicate l1 (intm l2 0)) + m <- zipWithM q_scalar_mult a m + result <- foldM q_vector_add zero m + return result + +-- | Check whether a vector is 0. +is_zero_vector :: [Integer] -> Bool +is_zero_vector = all (== 0) + + +-- ============================================================== +-- * Euclid's algorithm + +-- | The extended Euclidean algorithm. 'ext_euclid' /a/ /b/ returns +-- (/x/, /y/, /z/, /w/, /d/) such that: +-- +-- * 0 ≤ /d/ = gcd(/a/, /b/), the greatest common divisor of /a/ and +-- /b/; +-- +-- * /ax/ + /by/ = /d/; +-- +-- * /az/ + /bw/ = 0; +-- +-- * the determinant /xw/ - /yz/ = 1. +ext_euclid :: Integer -> Integer -> (Integer, Integer, Integer, Integer, Integer) +ext_euclid a b = ext_euclid_rec 1 0 0 1 a b 1 where + + -- the invariants for ext_euclid_rec are: + -- + -- [ x y ] [ a ] = [ r ] + -- [ z w ] [ b ] [ s ] + -- + -- and det [[x y] [z w]] = t = ±1. + + ext_euclid_rec x y z w r s t | r < 0 = + ext_euclid_rec (-x) (-y) z w (-r) s (-t) + ext_euclid_rec x y z w r s t | s < 0 = + ext_euclid_rec x y (-z) (-w) r (-s) (-t) + ext_euclid_rec x y z w r s t | r < s = + ext_euclid_rec z w x y s r (-t) + ext_euclid_rec x y z w r s t | 0 < s = + ext_euclid_rec z w (x-q*z) (y-q*w) s (r-q*s) (-t) + where q = r `div` s + ext_euclid_rec x y z w r s t = -- Note: s = 0, r ≥ 0. + (x, y, t*z, t*w, r) + + +-- ============================================================== +-- * Classical subroutines + +-- | Reduce a basis using the Lenstra-Lenstra-Lováscz algorithm. +-- +-- Uses the corresponding Haskell library. +lll :: [[Integer]] -> [[Integer]] +lll bb = bb_reduced_integral + where + bb_rational = map (\v -> map toRational v) bb + bb_reduced = Math.Lattices.LLL.lll bb_rational + bb_reduced_integral = map (\v -> map ceiling v) (elems bb_reduced) + +-- | Given an integer /m/, find the smallest prime /p/ such that /m/ ≤ +-- /p/ ≤ 2/m/. +-- +-- Uses preexisting 'isPrime' algorithm. +find_prime :: Int -> Int +find_prime m = head $ filter isPrime [(m)..(2*m)] + +-- | Given a vector /u/ and a basis /bb/ = [/b/[sub 0], …, +-- /b/[sub /n/-1]], determine whether /u/ belongs to the lattice +-- generated by /bb/, i.e., whether there exist integers /a/[sub 0], +-- …, /a/[sub /n/-1] such that /u/ = /a/[sub 0]/b/[sub 0] + … + +-- /a/[sub /n/-1]/b/[sub /n/-1]. +-- +-- Precondition: /u/ and /b/[sub 0], …, /b/[sub /n/-1] must all be +-- of the same dimension. +-- +-- The algorithm proceeds as follows: first, do invertible integer +-- column operations on /b/[sub 0], …, /b/[sub /n/-1] until the top +-- entries of /b/[sub 1], …, /b/[sub /n/-1] are 0. This can be done +-- efficiently by using the extended Euclidean algorithm for two +-- columns at a time. Then check whether the top entry of /b/[sub 0] +-- divides the top entry of /u/. If no, output 'False'. Otherwise, if +-- the top entry of /b/[sub 0] is 0, drop the top row and continue +-- recursively. Otherwise, subtract an appropriate multiple of +-- /b/[sub 0] from /u/, drop /b/[sub 0], drop the top row, and +-- continue recursively. Trivial base cases occur when the number of +-- rows or columns reaches 0. +is_in_lattice :: [Integer] -> [[Integer]] -> Bool +is_in_lattice [] bb = True +is_in_lattice u [] = is_zero_vector u +is_in_lattice (u0:us) (b0:bs) = + let (c00:c0s, cs) = mapAccumL column_op b0 bs in + if c00 == 0 + then if u0 /= 0 + then False + else is_in_lattice us (c0s:cs) + else if u0 `mod` c00 /= 0 + then False + else + let q = u0 `div` c00 + us' = us `vector_add` ((-q) `scalar_mult` c0s) + in is_in_lattice us' cs + +-- | Given a basis /bb/ = [/b/[sub 0], …, /b/[sub /n/-1]], find +-- another equivalent basis whose elements are linearly independent. +reduce_lattice :: [[Integer]] -> [[Integer]] +reduce_lattice [] = [] +reduce_lattice ([]:bs) = [] +reduce_lattice (b0:bs) = + let (c0, cs) = mapAccumL column_op b0 bs in + case c0 of + 0 : c0s -> [ 0:x | x <- reduce_lattice (c0s:cs) ] + _ -> c0 : [ 0:x | x <- reduce_lattice cs ] + +-- | Perform a reversible column operation on two integer vectors, +-- creating (and then dropping) a leading zero in the second vector. +column_op :: [Integer] -> [Integer] -> ([Integer], [Integer]) +column_op (m:ms) (n:ns) = (m':ms', ns') where + (x, y, z, w, d) = ext_euclid m n + m' = x*m + y*n -- m' == d by extended Euclid's algorithm + n' = z*m + w*n -- n' == 0 by extended Euclid's algorithm + ms' = (x `scalar_mult` ms) `vector_add` (y `scalar_mult` ns) + ns' = (z `scalar_mult` ms) `vector_add` (w `scalar_mult` ns) +column_op _ _ = error "is_in_lattice: dimension mismatch" + diff --git a/dist/build/Quipper/Algorithms/USV/Main.hs b/dist/build/Quipper/Algorithms/USV/Main.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/USV/Main.hs @@ -0,0 +1,305 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/USV/Main.hs" #-} +-- | +-- Author: Neil Julien Ross +-- +-- An implementation of the Unique Shortest Vector (USV) +-- algorithm. The input to the Unique Shortest Vector +-- problem is an /n/×/n/ integer matrix /B/ with +-- the property that the lattice /L(B)/ spanned by /B/ +-- contains a unique vector /u/ such that that any +-- other non-parallel vector /v/ in the lattice is +-- longer then /u/ by a factor of /n/[sup 3]. The +-- output is the vector /u/. +-- +-- The algorithm proceeds in two steps: first it uses +-- Regev’s method to reduce the USV to the Two +-- Point problem (TPP) and then to the Dihedral +-- Coset problem (DCP), second it uses Kuperberg’s +-- algorithm to solve the DCP. The first step +-- transforms the input matrix into a set of coset +-- states by partitioning the space into hypercubes +-- containing at most two lattice points, and then +-- collapsing the space onto one such cube. The second +-- step uses a sieving method on the obtained set of +-- coset states to extract the shortest vector. +-- +-- These algorithms are described in: +-- +-- * G. Kuperberg, \"A subexponential-time quantum +-- algorithm for the dihedral hidden subgroup problem.\" +-- /SIAM J. Comput./ 35(1):170-188,2005. +-- +-- * O. Regev, \"Quantum computation and lattice problems.\" +-- In Danielle C. Martin, editor, +-- /Proceedings of the 43rd IEEE Symposium on Foundations of Computer Science/, +-- pp. 520-529, Nov. 16-19, Vancouver, BC, Canada, 2002. IEEE, IEEE +-- Press, Los Alamitos, CA. +-- +-- The present implementation is based on a detailed algorithm +-- specification that was provided to us by the IARPA QCS +-- program and written by Andrew J. Landahl. +-- +-- Modules: +-- +-- * "Quipper.Algorithms.USV.Main": Command line interface. +-- +-- * "Quipper.Algorithms.USV.Definitions": Some general-purpose +-- definitions. +-- +-- * "Quipper.Algorithms.USV.USV": The implementation of the +-- main Unique Shortest Vector algorithm. +-- +-- * "Quipper.Algorithms.USV.Simulate": Functions for testing +-- and debugging certain subroutines. + +module Quipper.Algorithms.USV.Main where + +import Quipper + +import Quipper.Libraries.Arith +import Quipper.Libraries.Decompose + +import Quipper.Algorithms.USV.Definitions +import Quipper.Algorithms.USV.USV +import Quipper.Algorithms.USV.Simulate + +import Quipper.Utils.CommandLine +import Quipper.Utils.Sampling + +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import System.Random +import Control.Monad +import Data.List +import Data.Char + +-- ---------------------------------------------------------------------- +-- * Command line interface + +-- $ This module provides a command line interface for the Unique +-- Shortest Vector algorithm. This allows the user, for example, to +-- show different parts of the circuit, select a gate base, +-- select parameters such as /n/ and /b/, and select different output +-- formats. +-- +-- [Example invocations:] +-- +-- > ./usv +-- +-- Default options: the 'sieving' algorithm with +-- /n/=5 and ASCII output format. Because the 'sieving' +-- algorithm uses the 'dynamic_lift' function, the user +-- will be prompted to provide values corresponding to +-- a hypothetical measurement outcome (0 or 1) . +-- +-- > ./usv -F -f gatecount +-- +-- The gate count for 'f_quantum'. +-- +-- [Options and parameters:] +-- +-- * /b/ is the lattice basis (Default value: a 5×5 +-- matrix with entries set to 1). +-- +-- * /n/ is the dimension of the lattice +-- (Default value: 5). +-- +-- * /s/ is the seed for the random number generator +-- (Default value: 1). +-- +-- [Restrictions:] +-- +-- The 'sieving' algorithm uses the 'dynamic_lift' function. +-- The only output format that currently supports such a +-- functionality is ASCII. All algorithms that call +-- 'sieving' must therefore be run with the default +-- (ASCII) output format. These are: 'sieving', 'dCP', 'tPP', +-- 'algorithm_Q' and 'uSVP'. + +-- ============================================================== + +-- * Option processing + +-- | An enumeration type for determining what the main function +-- should do. +data WhatToShow = + F -- ^Show 'f_quantum'. Depends on input /b/. + | G -- ^Show 'g_quantum'. Depends on input /b/. + | H -- ^Show 'h_quantum'. Depends on input /n/. + | USVP -- ^Run 'uSVP'. Depends on input /b/. + | Q -- ^Run 'algorithm_Q'. Depends on input /b/. + | R -- ^Show 'algorithm_R'. Depends on input /b/. + | TPP -- ^Run 'tPP'. Depends on input /n/. + | Sieve -- ^Run 'sieving'. Depends on input /n/. + | DCP -- ^Run 'dCP'. Depends on input /n/. + | Test -- ^Run Simulation test for 'h_quantum'. Depends on input /n/. + deriving Show + +-- | A data type to hold values set by command line options. +data Options = Options { + s :: Int, -- ^Parameter /s/ (seed for random number generator). + n :: Int, -- ^Parameter /n/ (lattice dimension). + b :: [[Integer]], -- ^Parameter /b/ (lattice basis). + what :: WhatToShow, -- ^What kind of thing to output. + format :: Format, -- ^The output format. + gatebase :: GateBase -- ^What kind of gates to decompose into. +} deriving Show + +-- | The default options. +defaultOptions :: Options +defaultOptions = Options + { s = 1, + n = 5, + b = (replicate 5 (replicate 5 1)), + what = Sieve, + format = ASCII, + gatebase = Logical + } + +-- | The list of command line options, in the format required by 'getOpt'. +options :: [OptDescr (Options -> IO Options)] +options = + [ +-- Generic options + Option ['h'] ["help"] (NoArg help) "print usage info and exit", + Option ['f'] ["format"] (ReqArg format "") "output format for circuits (default: eps)", + Option ['g'] ["gatebase"] (ReqArg gatebase "") "type of gates to decompose into (default: logical)", +-- Algorithm parameter + Option ['n'] ["n"] (ReqArg nnn "") "parameter n (default: 5)", + Option ['b'] ["b"] (ReqArg bbb "") "parameter b (default: 5X5 with entries = 1)", + Option ['s'] ["s"] (ReqArg sss "") "Random number generator seed s (default: 1)", +-- Algorithm specific options + Option ['F'] [] (NoArg (what F)) "output subroutine f (depends on b).", + Option ['G'] [] (NoArg (what G)) "output subroutine g (depends on b).", + Option ['H'] [] (NoArg (what H)) "output subroutine h (depends on n).", + Option ['U'] [] (NoArg (what USVP)) "output algorithm 1 (depends on b).", + Option ['Q'] [] (NoArg (what Q)) "output algorithm 2 (depends on b).", + Option ['R'] [] (NoArg (what R)) "output algorithm 3 (depends on b).", + Option ['T'] [] (NoArg (what TPP)) "output algorithm 4 (depends on n).", + Option ['S'] [] (NoArg (what Sieve)) "output sieving subroutine (depends on n).", + Option ['D'] [] (NoArg (what DCP)) "output algorithm 5 (depends on n).", +-- Testing options + Option ['t'] [] (NoArg (what Test)) "test subroutine h (depends on n)." + ] + where + help :: Options -> IO Options + help o = do + usage + exitSuccess + + format :: String -> Options -> IO Options + format str o = do + case match_enum format_enum str of + [(_, f)] -> return o { format = f } + [] -> optfail ("Unknown format -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous format -- " ++ str ++ "\n") + + gatebase :: String -> Options -> IO Options + gatebase str o = do + case match_enum gatebase_enum str of + [(_, f)] -> return o { gatebase = f } + [] -> optfail ("Unknown gate base -- " ++ str ++ "\n") + _ -> optfail ("Ambiguous gate base -- " ++ str ++ "\n") + + nnn :: String -> Options -> IO Options + nnn string o = + case parse_int string of + Just n | n >= 1 -> return o { n = n } + _ -> optfail ("Invalid value for parameter n -- " ++ string ++ "\n") + + bbb :: String -> Options -> IO Options + bbb string o = + case parse_list_basis string of + Just b -> if (all is_zero_vector b) + then optfail ("0 is an invalid value for parameter b " ++ "\n") + else return o { b = b } + _ -> optfail ("Invalid value for parameter b -- " ++ string ++ "\n") + + sss :: String -> Options -> IO Options + sss string o = + case parse_int string of + Just s -> return o { s = s } + _ -> optfail ("Invalid value for parameter s -- " ++ string ++ "\n") + + what :: WhatToShow -> Options -> IO Options + what w o = return o { what = w } + +-- | Process /argv/-style command line options into an 'Options' structure. +dopts :: [String] -> IO Options +dopts argv = + case getOpt Permute options argv of + (o, [], []) -> (foldM (flip id) defaultOptions o) + (_, _, []) -> optfail "Too many non-option arguments\n" + (_, _, errs) -> optfail (concat errs) + +-- | Print usage message to 'stdout'. +usage :: IO () +usage = do + putStr (usageInfo header options) + putStr (show_enum "format" format_enum) + putStr (show_enum "gatebase" gatebase_enum) + where header = "Usage: usv [OPTION...]" + +-- | Parse a string to a list of integers, or return 'Nothing' on failure. +parse_list_basis :: String -> Maybe [[Integer]] +parse_list_basis s = case reads s of + [(ns, "")] -> Just ns + _ -> Nothing + +-- ============================================================== +-- * Main function + +-- | The main function for the Unique Shortest Vector problem: read +-- options, then execute the appropriate task. +main :: IO() +main = do + argv <- getArgs + options <- dopts argv + case options of + + Options { what = what, format = format, gatebase = gatebase, n = n, b = b, s = s} -> + case what of + F -> print_generic format (decompose_generic gatebase (f_quantum b p m i0)) twopoint_from_b + G -> print_generic format (decompose_generic gatebase (g_quantum (toInteger n) ws)) vector_from_b + H -> print_generic format (decompose_generic gatebase h_quantum) vector_from_n + USVP -> print_generic format (decompose_generic gatebase (uSVP b)) + Q -> print_generic format (decompose_generic gatebase (algorithm_Q b (l, m, i0, p) randomgen)) + R -> print_generic format (decompose_generic gatebase (algorithm_R b l m i0 p randomgen)) + TPP -> print_generic format (decompose_generic gatebase (tPP n)) (replicate (4*n^2+n) twopoint_from_n) + Sieve -> print_generic format (decompose_generic gatebase (\l -> sieving n 2 (zip l [0..]))) (replicate (2^n-1) qubit) + DCP -> print_generic format (decompose_generic gatebase (dCP n 0 0)) (replicate (8^n) cosetstate) + Test -> h_test n + + where + randomgen = mkStdGen s + -- To reduce the number of inputs to be provided by the user, + -- inputs other than n and b are derived. + -- + -- Some inputs are therefore hardwired to arbitrary values. + -- Moreover, some subroutines are parameterized by b while + -- others are parameterized by n. Subroutines H, TPP, Sieve, Test + -- and DCP depend on n. The remaining subroutines depend on b. + -- + -- Inputs derived from b: + -- + n_from_b = length b + l = ceiling $ norm $ head b + p = find_prime ((n_from_b)^3) + m = p-1 -- In fact, m ranges from 1 to (p-1). + i0 = 0 -- In fact, i_0 ranges from 0 to (n-1). + max_b = maximum (map maximum b) + s = ceiling (logBase 2 (fromIntegral max_b)) + 5*n + twopoint_from_b = (qubit, (replicate n_from_b (qdint_shape (4*n_from_b)))) + vector_from_b = (replicate n_from_b (qdint_shape s)) + -- + -- Inputs derived from n: + -- + vector_from_n = (replicate n (qdint_shape (4*n))) + twopoint_from_n = (qubit, vector_from_n) + cosetstate = (qubit, (qdint_shape n)) + ws = take n $ sample_random0 randomgen 1 diff --git a/dist/build/Quipper/Algorithms/USV/Simulate.hs b/dist/build/Quipper/Algorithms/USV/Simulate.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/USV/Simulate.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/USV/Simulate.hs" #-} +-- | This module contains functions for simulating and +-- debugging the USV algorithm and some of its subroutines. + +module Quipper.Algorithms.USV.Simulate where + +import Quipper + +import Quipper.Libraries.Arith +import Quipper.Libraries.Simulation + +import Quipper.Algorithms.USV.USV +import Quipper.Algorithms.USV.Definitions + +import Quipper.Utils.Sampling + +-- $ For the coherent arithmetic subroutines defined +-- in "Quipper.Algorithms.USV.USV", compare the classical +-- implementation (implemented using Haskell +-- functions) and the quantum one (simulated). + + +-- ===================================================================================== +-- * Testing for subroutine /h/ + +-- | Given an integer /n/, print the table comparing the output values +-- of the functions 'h_classical' and 'h_quantum' on every possible +-- vector in (ℤ[sub 2[sup 4/n/]])[sup /n/]. +h_test :: Int -> IO () +h_test n = do + +-- Compute a table containing: +-- Intput | Output of h_classical | Output of (simulated) h_quantum + let h_table_n = [ "h table for n = " ++ (show n) ++ ":" + , "" + , "v h(v)_C h(v)_Q "] + ++ + [ (show (map integer_of_intm_unsigned w)) ++ " " ++ (show y) ++ " " ++ (show z) ++ flag + | w <- (sample_all0 (replicate n (intm (4*n) (2^(4*n)-1)))) + , let y = integer_of_intm_unsigned $ h_classical w + , let z = integer_of_intm_unsigned $ (run_classical_generic h_quantum) w + , let flag = if y /= z then " **MISMATCH**" else ""] + ++ + ["",""] + +--Print the table + mapM putStrLn $ h_table_n + return () + diff --git a/dist/build/Quipper/Algorithms/USV/USV.hs b/dist/build/Quipper/Algorithms/USV/USV.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Algorithms/USV/USV.hs @@ -0,0 +1,503 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Algorithms/USV/USV.hs" #-} +-- | This module provides an implementation of the +-- main Unique Shortest Vector algorithm. + +module Quipper.Algorithms.USV.USV where + +import Quipper +import Quipper.Libraries.QFT +import Quipper.Libraries.Arith +import Quipper.Utils.Sampling + +import Quipper.Algorithms.USV.Definitions + +import Control.Monad (foldM, zipWithM, replicateM) +import Data.Maybe +import System.Random +import Text.Printf + +import Quipper.Utils.Auxiliary + + +-- ============================================================== +-- * Coherent arithmetic + +-- $ Some arithmetic functions used in the reductions of the /USV/ to +-- the /TPP/ and of the /TPP/ to the /DCP/. + +-- | Compute the function /f/, that selects a subset +-- of lattice points. It is defined as: +-- +-- \[image def_f.png] +-- +-- The arguments are: +-- +-- * /bb_bar/, an /n/-dimensional matrix; +-- +-- * /p/, a prime such that /n/ ≤ /p/ ≤ 2/n/; +-- +-- * /m/, an integer such that /1/ ≤ /m/ ≤ /p-1/; +-- +-- * /i0/, an integer index such that /0/ ≤ /i0/ ≤ /n-1/; +-- +-- * /t/, an integer (either /0/ or /1/); +-- +-- * /a/=(/a/[sub 1],...,/a/[sub /n/]), an integer vector. +f_classical :: [[Integer]] -> Int -> Int -> Int -> (Int,[Int]) -> [Integer] +f_classical bb p m i0 (t,a) = matrix_mult bb a' + where + a' = map toInteger $ applyAt i0 (\x -> x*p + t*m) a + +-- | Quantum version of 'f_classical'. +f_quantum :: [[Integer]] -> Int -> Int -> Int -> TwoPoint -> Circ [QDInt] +f_quantum bb p m i0 = box "f" $ \(t,a) -> do + comment_with_label "ENTER: f_quantum" (t,a) ("t","a") + let n = (length . head) bb + b = maximum (map maximum bb) + s = ceiling (logBase 2 (fromIntegral b)) + 5*n + + qp <- qinit (intm s (toInteger p)) + qm <- qinit (intm s (toInteger m)) + qbb <- qinit (map (\vs -> (map (\v -> (intm s v)) vs)) bb) + a <- mapM (\x -> qdint_extend_signed s x) a + + let ai0 = a !! i0 + (_,_,x) <- q_mult ai0 qp + q_add_in_place x qm `controlled` t + let a' = overwriteAt i0 x a + + result <- q_matrix_mult qbb a' + comment_with_label "EXIT: f_quantum" (qp,qm,qbb,t,a) ("qp","qm","qbb","t","a") + return result + + +-- | Compute the function /g/ defined as: +-- +-- \[image def_g1.png] +-- +-- The arguments are: +-- +-- * /l/, an integer (in principle, a real number, but the +-- GFI only uses integer values); +-- +-- * /w/, a real number in the interval [0,1); +-- +-- * /v/, an integer. +-- +-- We note that in the quantum version of this function, /l/ +-- and /w/ will be parameters, and /v/ will be a quantum +-- input. We implement this operation using only integer +-- division, using the following property: for all integers +-- /v/, /m/ and real numbers /w/, +-- +-- \[image floor2.png] +g1_classical :: Integer -> Double -> Integer -> Integer +g1_classical l w v = + let m = 128 * l + c = ceiling (fromIntegral m * w) + in + (v - c) `div` m + +-- | Compute the function /g/. The function /g/ +-- partitions the space into hypercubes of size +-- 128/l/ at a random offset /w/. It is defined as: +-- +-- \[image def_g.png] +-- +-- This is just the componentwise application of 'g1_classical'. +g_classical :: Integer -> [Double] -> [Integer] -> [Integer] +g_classical l w v = zipWith (g1_classical l) w v + +-- | Quantum version of 'g1_classical'. +g1_quantum :: Integer -> Double -> QDInt -> Circ QDInt +g1_quantum l w = box "g_1" $ \v -> do + comment_with_label "ENTER: g1_quantum" v "v" + let m = fromIntegral (128 * l) + c = ceiling (fromIntegral m * w) + l' = qdint_length v + c' <- qinit (intm l' c) + (_, _, n) <- q_sub v c' + m' <- qinit (intm l' m) + (_, _, q) <- q_div n m' + comment_with_label "EXIT: g1_quantum" (v,c',m',n,q) ("v","c'","m'","n","q") + return q + +-- | Quantum version of 'g_classical'. +g_quantum :: Integer -> [Double] -> [QDInt] -> Circ [QDInt] +g_quantum l w = box "g" $ \v -> do + zipWithM (g1_quantum l) w v + + +-- | Compute the function /h/, defined as: +-- +-- \[image def_h.png] +-- +-- The function /h/ transforms a vector /a/=(/a/[sub 1],...,/a/[sub n]) +-- of 4/n/-bit integers into a 4/n/[super 2]+/n/-bit integer by +-- inserting a 0 between each component of /a/. +h_classical :: [IntM] -> IntM +h_classical v = (intm (4*n^2+n) w) + where + n = length v + m = 4*n + 1 + mm = 2^m + v' = map integer_of_intm_unsigned v + w = foldl (+) 0 $ zipWith (*) v' [mm^k | k <- [0..(n-1)]] + +-- | Quantum version of 'h_classical'. +h_quantum :: [QDInt] -> Circ QDInt +h_quantum a = do + comment_with_label "ENTER: h_quantum" a "a" + a <- mapM (extend . qulist_of_qdint_bh) (reverse a) + comment_with_label "EXIT: h_quantum" a "a" + return (qdint_of_qulist_bh (concat a)) + where + -- | Prepend a qubit in state |0> to a list of qubits. + extend :: [Qubit] -> Circ [Qubit] + extend x = do + z <- qinit False + return (z : x) + + +-- ============================================================== +-- * Algorithm 1: \"uSVP\" + +-- | Find the shortest vector. The argument, /bb/, is an +-- /n/-dimensional integer matrix. The algorithm first uses +-- /bb/ to generate a list of parameter tuples and then +-- recursively goes through this list by calling 'algorithm_Q' +-- on each tuple until it either finds the shortest vector +-- or exhausts the list and fails by returning 0. +-- +-- Remark: +-- +-- * Argument /n/ is redundant, it can be inferred from /bb/. +uSVP :: [[Integer]] -> Circ [Integer] +uSVP bb = do + + ----------------------------------------------------------------- + -- Prepare the list of parameter values, + -- and a random number generator. + ----------------------------------------------------------------- + comment "ENTER: algorithm_uSVP" + let n = length bb + randomgen = mkStdGen n + p = find_prime (n^3) + bb_bar = (lll . reduce_lattice) bb + b1 = head bb_bar + l1 = norm b1 + k = ceiling $ fromIntegral $ (n - 1) `div` 2 + ls = [ceiling (l1 / (2^s)) | s <- [0..k] ] + parameters = [(l, m, i0, p) | l <- ls, + m <- [1..(p-1)], + i0 <- [0..(n-1)]] + + ----------------------------------------------------------------- + -- Conditional recursion over the list of parameters + -- using the function 'usvp_aux'. + ----------------------------------------------------------------- + v <- usvp_aux n bb_bar parameters randomgen + comment "EXIT: algorithm_uSVP" + return v + +----------------------------------------------------------------- +-- | For each tuple of parameters, call 'algorithm_Q' and +-- then test whether the returned vector is the shortest vector +-- in the lattice. If it is, return it. If not, move on to +-- the next tuple. If the end of the list is reached, return 0. +-- +-- Remark: +-- +-- * The algorithm takes as additional argument a random number +-- generator. At each iteration, a new seed is extracted and used +-- by the next iteration's generator. +----------------------------------------------------------------- +usvp_aux :: Int -> [[Integer]] -> [(Int, Int, Int, Int)] -> StdGen -> Circ [Integer] +usvp_aux n b [] randomgen = return (replicate n 0) +usvp_aux n b (h:t) randomgen = do + let (g1,g2) = split randomgen + u <- algorithm_Q b h g1 + if (is_in_lattice u b) then return u + else usvp_aux n b t g2 + + +-- ============================================================== +-- * Algorithm 2: \"Q\" + +-- | Compute 'algorithm_Q'. The arguments are: +-- +-- * /bb_bar/, an /n/-dimensional LLL-reduced basis; +-- +-- * (/l/,/m/,/i0/,/p/), a 4-tuple of integer parameters; +-- +-- * /randomgen/, a random number generator. +-- +-- The algorithm first calls algorithm 'algorithm_R' to prepare +-- a list of 'TwoPoint's parameterized on (/l/,/m/,/i0/,/p/) and +-- then calls 'tPP' on this list. With high probability, the +-- returned vector is the shortest vector in the lattice up to +-- one component. +-- +-- Remark: +-- +-- * Argument /n/ is redundant, it can be inferred +-- from /bb_bar/. +algorithm_Q :: [[Integer]] -> (Int, Int, Int, Int) -> StdGen -> Circ [Integer] +algorithm_Q bb_bar (l, m, i0, p) randomgen = do + ----------------------------------------------------------------- + -- Extract (4*n^2+n) random number generators + ----------------------------------------------------------------- + comment "ENTER: algorithm_Q" + let n = length bb_bar + generators = take (4*n^2+n) $ multi_split randomgen + + ----------------------------------------------------------------- + -- Call algorithm 'r' to prepare a list of 'TwoPoint's + -- using the given parameters and a random number generator. + ----------------------------------------------------------------- + states <- sequence [algorithm_R bb_bar l m i0 p g | g <- generators] + + ----------------------------------------------------------------- + -- Run tpp to get the shortest vector up to i0-th component. + ----------------------------------------------------------------- + u <- tPP n states + + ----------------------------------------------------------------- + -- Adjust i0-th component and return the vector. + ----------------------------------------------------------------- + comment "EXIT: algorithm_Q" + return $ applyAt i0 (\x -> x*(toInteger p) + (toInteger m)) u + + +-- ============================================================== +-- * Algorithm 3: \"R\" + +-- | Compute 'algorithm_R'. The arguments are: +-- +-- * /bb_bar/, an /n/-dimensional LLL-reduced basis, +-- +-- * /l/, an integer approximation of the length of the +-- shortest vector, +-- +-- * /p/, a prime such that /n/ ≤ /n/ ≤ 2/n/, +-- +-- * /m/, an integer such that /1/ ≤ /m/ ≤ /p-1/, +-- +-- * /i0/, an integer index such that /0/ ≤ /i0/ ≤ /n-1/ and +-- +-- * /randomgen/, a random number generator. +-- +-- The algorithm first calls the functions 'f_quantum' and +-- 'g_quantum' to prepare a superposition of hypercubes +-- containing at most two lattice points, whose difference +-- is the shortest vector. It then measures the output to +-- collapses the state to a 'TwoPoint'. +algorithm_R :: [[Integer]] -> Int -> Int -> Int -> Int -> StdGen -> Circ TwoPoint +algorithm_R bb_bar l m i0 p randomgen = do + comment "ENTER: algorithm_R" + let n = length bb_bar + b = maximum (map maximum bb_bar) + s = ceiling (logBase 2 (fromIntegral b)) + 5*n + ws = take n $ sample_random randomgen 0 1 + + ----------------------------------------------------------------- + -- Use functions 'f_quantum' and 'g_quantum' to partition + -- the space into hypercubes containing two points whose + -- difference is the shortest vector. + ----------------------------------------------------------------- + t <- qinit False + a <- qinit $ replicate n (intm (4*n) 0) + r <- qinit $ replicate n (intm s 0) + (t,a) <- map_hadamard (t,a) + + ((t,a),r) <- classical_to_reversible (\(t,a) -> do + result <- f_quantum bb_bar p m i0 (t,a) + result <- g_quantum (toInteger l) ws r + return result) ((t,a),r) + + ----------------------------------------------------------------- + -- Collapse the space onto one such cube to create a 'TwoPoint'. + ----------------------------------------------------------------- + r_measured <- measure r + cdiscard r_measured + + comment "EXIT: algorithm_R" + return (t,a) + + +-- ============================================================== +-- * Algorithm 4: \"TPP\" + +-- | Perform Regev's reduction of the /TPP/ to the /DCP/ and then +-- call 'dCP'. The arguments are: +-- +-- * /n/, an integer and +-- +-- * /states/, a list of 'TwoPoint's. +-- +-- The algorithm transforms the 'TwoPoint's in /states/ into +-- 'CosetState's using the function 'h_quantum', then calls +-- 'dCP' on this modified list to find the shortest vector. +tPP :: Int -> [TwoPoint] -> Circ [Integer] +tPP n states = do + comment_with_label "ENTER: algorithm_TPP" states "states" + let m = 2^(4*n) + ms = foldl (+) 0 [m*(2*m)^k | k <- [0..(n-1)]] + + ----------------------------------------------------------------- + -- Use the function h to transform 'TPP' inputs (i.e. 'TwoPoint's) + -- into 'DCP' inputs (i.e. 'CosetState's). + ----------------------------------------------------------------- + states <- mapM (\(t,a) -> do + a <- h_quantum a + return (t,a)) states + + ----------------------------------------------------------------- + -- Call 'DCP' to find the difference between. + ----------------------------------------------------------------- + d <- dCP n 0 0 states + + ----------------------------------------------------------------- + -- Convert the integer output of 'dcp' back to a vector. + ----------------------------------------------------------------- + comment "EXIT: algorithm_TPP" + return $ map (\x -> x-m) $ expand (d + ms) (2*m) + + +-- ============================================================== +-- * Algorithm 5: \"DCP\" + +-- | Given integers /m/ and /n/ and a 'Psi_k' /(q,k)/ +-- compute the last /n/ bits of the binary expansion +-- of /k/ on /m/ bits. +n_low_bits :: Int -> Int -> Psi_k -> [Bool] +n_low_bits m n p = take n $ boollist_of_int_lh m (toInteger(snd p)) + +-- | Given integers /m/ and /n/ and a list /l/ of 'Psi_k's, group the +-- elements of /l/ into pairs /(psi_p, psi_q)/ where +-- /p/ and /q/ share /n/ low bits. Return the list of all such +-- pairs together with the list of unpaired elements of /l/. +pairing :: Int -> Int -> [Psi_k] -> ([(Psi_k, Psi_k)], [Psi_k]) +pairing m n l = find_partners (\p -> n_low_bits m n p) l + +-- | Perform Kuperberg's sieve. The arguments are: +-- +-- * /n/, an integer, +-- +-- * /m/, an integer and +-- +-- * /l/, a list of 'Psi_k's. +-- +-- The algorithm recursively combines and sieves the +-- elements of /l/ until it reaches a list whose +-- elements have /m/[sup 2] trailing zeros. +-- At each step, the list of remaining 'Psi_k's are +-- paired and each pair +-- ((/q/[sub 1], /k/[sub 1]), (/q/[sub 2], /k/[sub 2])) +-- is combined into a new 'Psi_k' /(q, k)/ with +-- /k/= /k/[sub 1] ± /k/[sub 2]. +-- If /k/= /k/[sub 1] - /k/[sub 2], the 'Psi_k' is preserved, +-- otherwise it is discarded. +-- +-- Remark: +-- +-- * Uses 'dynamic_lift' to determine whether +-- to keep a discard a 'Psi_k'. +sieving :: Int -> Int -> [Psi_k] -> Circ [Psi_k] +sieving n m l = do + comment "ENTER: sieving" + l <- loop_with_indexM m l (\j l -> do + -- Pair the states sharing m+m*j low bits. + comment "ENTER: Pairing" + let mmj = m + m*j + (pairs, unpaired) = pairing n mmj l + -- Discard the states that haven't been paired. + qdiscard_psi_ks unpaired + comment "EXIT: Pairing" + -- Combine pairs (Psi_k, Psi_l) to get Psi_k±l. + -- If the measurement outcome ('sign') is 0, then the + -- associated state is of the form Psi_k-l. + combined_states <- mapM (\((q,k),(q',l)) -> do + comment "ENTER: Combining" + q <- qnot q `controlled` q' + q <- measure q + sign <- dynamic_lift q + comment "EXIT: Combining" + return (sign, (q', (k-l)))) pairs + -- Separate the states according to the value of 'sign'. + -- Discard the states of the form Psi_k+l and + -- return the ones of the form Psi_k-l. + let (plus, minus) = separate combined_states fst + qdiscard_psi_ks $ map snd plus + return $ map snd minus) + comment "EXIT: sieving" + return l + +-- | Perform Kuperberg's algorithm solving the Dihedral +-- Coset problem. The arguments are: +-- +-- * /n/, an integer measuring the length of the output, +-- +-- * /d/, an integer to hold the output initially set to 0, +-- +-- * /s/, an integer counter initially set to 0 and +-- +-- * /states/, a list of 'CosetState's. +-- +-- The algorithm proceeds recursively. At each iteration it +-- uses Kuperberg's sieve on the first /n/ elements of /states/ +-- to compute the /s/-th bit of the output and updates /d/ with +-- the result. Then it increments /s/ and repeats until /states/ is +-- exhausted. +-- +-- Remark: +-- +-- * The function 'dynamic_lift' used in this algorithm is presumably +-- very expensive in terms of resources. In this implementation +-- it is used profusely but there is room for optimization. +dCP :: Int -> Integer -> Int -> [CosetState] -> Circ Integer +dCP n d s states = if s == n then return d else do + comment (printf "ENTER algorithm_DCP: n=%d d=%d s=%d" n d s) + let nn = 2^n + r = exp $ -( 2*pi*(fromIntegral d / fromIntegral(nn)) ) + m = ceiling $ sqrt $ fromIntegral $ n-s-1 + (l1, l2) = splitAt n states + + ----------------------------------------------------------------- + -- Transform the first n coset states + -- into states of the form Psi_k. + ----------------------------------------------------------------- + comment "ENTER: TO_Psi_k" + l <- mapM (\(t,a) -> do + a <- qft_int a + ca <- measure a + k <- mmap fromIntegral $ dynamic_lift ca + t <- named_rotation "R" (r*(fromIntegral k)) t + return (t, k)) l1 + comment "EXIT: To_Psi_k" + + ----------------------------------------------------------------- + -- Sieve the Psi_k's to get Psi_2^{n-s-1}. + ----------------------------------------------------------------- + l <- sieving n m l + ----------------------------------------------------------------- + -- Extract the s-th bit of d by finding in l a state of the + -- form Psi_2^{n-s-1} and measuring it in the +/- basis. The + -- remaining states in l are discarded. + ----------------------------------------------------------------- + let ((q,k),psis) = find l (\x -> ((snd x) == 2^(n-s-1))) "The sieving process failed to produce a state of the form 2^k." + --let ((q,k),psis) = ((head l),(tail l)) + q <- map_hadamard q + q <- measure q + q <- dynamic_lift q + qdiscard_psi_ks psis + let d_lsb = int_of_boollist_unsigned_bh [q] + + ----------------------------------------------------------------- + -- Update d_low and iterate on the remaining list. + ----------------------------------------------------------------- + comment "EXIT: algorithm_DCP" + dCP n (d + (2^s)*d_lsb) (s+1) l2 diff --git a/dist/build/bf/bf-tmp/bf.hs b/dist/build/bf/bf-tmp/bf.hs new file mode 100644 --- /dev/null +++ b/dist/build/bf/bf-tmp/bf.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "programs/bf.hs" #-} +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.BF.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.BF.Main +main = Quipper.Algorithms.BF.Main.main diff --git a/dist/build/bwt/bwt-tmp/bwt.hs b/dist/build/bwt/bwt-tmp/bwt.hs new file mode 100644 --- /dev/null +++ b/dist/build/bwt/bwt-tmp/bwt.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "programs/bwt.hs" #-} +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.BWT.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.BWT.Main +main = Quipper.Algorithms.BWT.Main.main diff --git a/dist/build/cl/cl-tmp/cl.hs b/dist/build/cl/cl-tmp/cl.hs new file mode 100644 --- /dev/null +++ b/dist/build/cl/cl-tmp/cl.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "programs/cl.hs" #-} +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.CL.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.CL.Main +main = Quipper.Algorithms.CL.Main.main diff --git a/dist/build/gse/gse-tmp/gse.hs b/dist/build/gse/gse-tmp/gse.hs new file mode 100644 --- /dev/null +++ b/dist/build/gse/gse-tmp/gse.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "programs/gse.hs" #-} +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.GSE.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.GSE.Main +main = Quipper.Algorithms.GSE.Main.main diff --git a/dist/build/qls/qls-tmp/qls.hs b/dist/build/qls/qls-tmp/qls.hs new file mode 100644 --- /dev/null +++ b/dist/build/qls/qls-tmp/qls.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "programs/qls.hs" #-} +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.QLS.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.QLS.Main +main = Quipper.Algorithms.QLS.Main.main diff --git a/dist/build/tf/tf-tmp/tf.hs b/dist/build/tf/tf-tmp/tf.hs new file mode 100644 --- /dev/null +++ b/dist/build/tf/tf-tmp/tf.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "programs/tf.hs" #-} +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.TF.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.TF.Main +main = Quipper.Algorithms.TF.Main.main diff --git a/dist/build/usv/usv-tmp/usv.hs b/dist/build/usv/usv-tmp/usv.hs new file mode 100644 --- /dev/null +++ b/dist/build/usv/usv-tmp/usv.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "programs/usv.hs" #-} +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.USV.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.USV.Main +main = Quipper.Algorithms.USV.Main.main diff --git a/images/CosetState.png b/images/CosetState.png new file mode 100644 Binary files /dev/null and b/images/CosetState.png differ diff --git a/images/E.png b/images/E.png new file mode 100644 Binary files /dev/null and b/images/E.png differ diff --git a/images/ERot_phase.png b/images/ERot_phase.png new file mode 100644 Binary files /dev/null and b/images/ERot_phase.png differ diff --git a/images/ERot_zx.png b/images/ERot_zx.png new file mode 100644 Binary files /dev/null and b/images/ERot_zx.png differ diff --git a/images/G.png b/images/G.png new file mode 100644 Binary files /dev/null and b/images/G.png differ diff --git a/images/GateR.png b/images/GateR.png new file mode 100644 Binary files /dev/null and b/images/GateR.png differ diff --git a/images/Rz.png b/images/Rz.png new file mode 100644 Binary files /dev/null and b/images/Rz.png differ diff --git a/images/T.png b/images/T.png new file mode 100644 Binary files /dev/null and b/images/T.png differ diff --git a/images/V.png b/images/V.png new file mode 100644 Binary files /dev/null and b/images/V.png differ diff --git a/images/W.png b/images/W.png new file mode 100644 Binary files /dev/null and b/images/W.png differ diff --git a/images/Y.png b/images/Y.png new file mode 100644 Binary files /dev/null and b/images/Y.png differ diff --git a/images/adder-optimized.png b/images/adder-optimized.png new file mode 100644 Binary files /dev/null and b/images/adder-optimized.png differ diff --git a/images/adder-unoptimized.png b/images/adder-unoptimized.png new file mode 100644 Binary files /dev/null and b/images/adder-unoptimized.png differ diff --git a/images/b0-template.png b/images/b0-template.png new file mode 100644 Binary files /dev/null and b/images/b0-template.png differ diff --git a/images/b1-template.png b/images/b1-template.png new file mode 100644 Binary files /dev/null and b/images/b1-template.png differ diff --git a/images/b2-orthodox.png b/images/b2-orthodox.png new file mode 100644 Binary files /dev/null and b/images/b2-orthodox.png differ diff --git a/images/b2-template.png b/images/b2-template.png new file mode 100644 Binary files /dev/null and b/images/b2-template.png differ diff --git a/images/b3-template.png b/images/b3-template.png new file mode 100644 Binary files /dev/null and b/images/b3-template.png differ diff --git a/images/b4-template.png b/images/b4-template.png new file mode 100644 Binary files /dev/null and b/images/b4-template.png differ diff --git a/images/cH_AMMR.png b/images/cH_AMMR.png new file mode 100644 Binary files /dev/null and b/images/cH_AMMR.png differ diff --git a/images/ccZ_AMMR.png b/images/ccZ_AMMR.png new file mode 100644 Binary files /dev/null and b/images/ccZ_AMMR.png differ diff --git a/images/ccZ_S.png b/images/ccZ_S.png new file mode 100644 Binary files /dev/null and b/images/ccZ_S.png differ diff --git a/images/cc_iX.png b/images/cc_iX.png new file mode 100644 Binary files /dev/null and b/images/cc_iX.png differ diff --git a/images/cc_iX_S.png b/images/cc_iX_S.png new file mode 100644 Binary files /dev/null and b/images/cc_iX_S.png differ diff --git a/images/cc_iX_simple.png b/images/cc_iX_simple.png new file mode 100644 Binary files /dev/null and b/images/cc_iX_simple.png differ diff --git a/images/contfrac.png b/images/contfrac.png new file mode 100644 Binary files /dev/null and b/images/contfrac.png differ diff --git a/images/controlled-phase-decomp.png b/images/controlled-phase-decomp.png new file mode 100644 Binary files /dev/null and b/images/controlled-phase-decomp.png differ diff --git a/images/controlled-zrot.png b/images/controlled-zrot.png new file mode 100644 Binary files /dev/null and b/images/controlled-zrot.png differ diff --git a/images/controlled_E.png b/images/controlled_E.png new file mode 100644 Binary files /dev/null and b/images/controlled_E.png differ diff --git a/images/controlled_S.png b/images/controlled_S.png new file mode 100644 Binary files /dev/null and b/images/controlled_S.png differ diff --git a/images/controlled_T.png b/images/controlled_T.png new file mode 100644 Binary files /dev/null and b/images/controlled_T.png differ diff --git a/images/controlled_V.png b/images/controlled_V.png new file mode 100644 Binary files /dev/null and b/images/controlled_V.png differ diff --git a/images/controlled_W.png b/images/controlled_W.png new file mode 100644 Binary files /dev/null and b/images/controlled_W.png differ diff --git a/images/controlled_YY.png b/images/controlled_YY.png new file mode 100644 Binary files /dev/null and b/images/controlled_YY.png differ diff --git a/images/controlled_iX.png b/images/controlled_iX.png new file mode 100644 Binary files /dev/null and b/images/controlled_iX.png differ diff --git a/images/controlled_phase.png b/images/controlled_phase.png new file mode 100644 Binary files /dev/null and b/images/controlled_phase.png differ diff --git a/images/coord.png b/images/coord.png new file mode 100644 Binary files /dev/null and b/images/coord.png differ diff --git a/images/dashed-cnot-bwd.png b/images/dashed-cnot-bwd.png new file mode 100644 Binary files /dev/null and b/images/dashed-cnot-bwd.png differ diff --git a/images/dashed-cnot-fwd.png b/images/dashed-cnot-fwd.png new file mode 100644 Binary files /dev/null and b/images/dashed-cnot-fwd.png differ diff --git a/images/decompose2Controls.png b/images/decompose2Controls.png new file mode 100644 Binary files /dev/null and b/images/decompose2Controls.png differ diff --git a/images/decomposeControls.png b/images/decomposeControls.png new file mode 100644 Binary files /dev/null and b/images/decomposeControls.png differ diff --git a/images/def_f.png b/images/def_f.png new file mode 100644 Binary files /dev/null and b/images/def_f.png differ diff --git a/images/def_g.png b/images/def_g.png new file mode 100644 Binary files /dev/null and b/images/def_g.png differ diff --git a/images/def_g1.png b/images/def_g1.png new file mode 100644 Binary files /dev/null and b/images/def_g1.png differ diff --git a/images/def_h.png b/images/def_h.png new file mode 100644 Binary files /dev/null and b/images/def_h.png differ diff --git a/images/expDA.png b/images/expDA.png new file mode 100644 Binary files /dev/null and b/images/expDA.png differ diff --git a/images/floor.png b/images/floor.png new file mode 100644 Binary files /dev/null and b/images/floor.png differ diff --git a/images/floor2.png b/images/floor2.png new file mode 100644 Binary files /dev/null and b/images/floor2.png differ diff --git a/images/fredkin.png b/images/fredkin.png new file mode 100644 Binary files /dev/null and b/images/fredkin.png differ diff --git a/images/gate_W_CliffordT.png b/images/gate_W_CliffordT.png new file mode 100644 Binary files /dev/null and b/images/gate_W_CliffordT.png differ diff --git a/images/hex-coord.png b/images/hex-coord.png new file mode 100644 Binary files /dev/null and b/images/hex-coord.png differ diff --git a/images/hex1.png b/images/hex1.png new file mode 100644 Binary files /dev/null and b/images/hex1.png differ diff --git a/images/hex2.png b/images/hex2.png new file mode 100644 Binary files /dev/null and b/images/hex2.png differ diff --git a/images/iX.png b/images/iX.png new file mode 100644 Binary files /dev/null and b/images/iX.png differ diff --git a/images/multi_ciX_noancilla.png b/images/multi_ciX_noancilla.png new file mode 100644 Binary files /dev/null and b/images/multi_ciX_noancilla.png differ diff --git a/images/multi_cnot_barenco.png b/images/multi_cnot_barenco.png new file mode 100644 Binary files /dev/null and b/images/multi_cnot_barenco.png differ diff --git a/images/phase.png b/images/phase.png new file mode 100644 Binary files /dev/null and b/images/phase.png differ diff --git a/images/quantum_and.png b/images/quantum_and.png new file mode 100644 Binary files /dev/null and b/images/quantum_and.png differ diff --git a/images/quantum_and_iX.png b/images/quantum_and_iX.png new file mode 100644 Binary files /dev/null and b/images/quantum_and_iX.png differ diff --git a/images/rGate.png b/images/rGate.png new file mode 100644 Binary files /dev/null and b/images/rGate.png differ diff --git a/images/spin1.png b/images/spin1.png new file mode 100644 Binary files /dev/null and b/images/spin1.png differ diff --git a/images/spin2.png b/images/spin2.png new file mode 100644 Binary files /dev/null and b/images/spin2.png differ diff --git a/images/toffoli_AMMR.png b/images/toffoli_AMMR.png new file mode 100644 Binary files /dev/null and b/images/toffoli_AMMR.png differ diff --git a/images/toffoli_NC.png b/images/toffoli_NC.png new file mode 100644 Binary files /dev/null and b/images/toffoli_NC.png differ diff --git a/images/toffoli_S.png b/images/toffoli_S.png new file mode 100644 Binary files /dev/null and b/images/toffoli_S.png differ diff --git a/images/toffoli_V.png b/images/toffoli_V.png new file mode 100644 Binary files /dev/null and b/images/toffoli_V.png differ diff --git a/images/weldedtree.png b/images/weldedtree.png new file mode 100644 Binary files /dev/null and b/images/weldedtree.png differ diff --git a/images/with_combined_controls1.png b/images/with_combined_controls1.png new file mode 100644 Binary files /dev/null and b/images/with_combined_controls1.png differ diff --git a/images/with_combined_controls2.png b/images/with_combined_controls2.png new file mode 100644 Binary files /dev/null and b/images/with_combined_controls2.png differ diff --git a/images/with_computed.png b/images/with_computed.png new file mode 100644 Binary files /dev/null and b/images/with_computed.png differ diff --git a/images/with_signed_qubit.png b/images/with_signed_qubit.png new file mode 100644 Binary files /dev/null and b/images/with_signed_qubit.png differ diff --git a/programs/bf.hs b/programs/bf.hs new file mode 100644 --- /dev/null +++ b/programs/bf.hs @@ -0,0 +1,7 @@ +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.BF.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.BF.Main +main = Quipper.Algorithms.BF.Main.main diff --git a/programs/bwt.hs b/programs/bwt.hs new file mode 100644 --- /dev/null +++ b/programs/bwt.hs @@ -0,0 +1,7 @@ +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.BWT.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.BWT.Main +main = Quipper.Algorithms.BWT.Main.main diff --git a/programs/cl.hs b/programs/cl.hs new file mode 100644 --- /dev/null +++ b/programs/cl.hs @@ -0,0 +1,7 @@ +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.CL.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.CL.Main +main = Quipper.Algorithms.CL.Main.main diff --git a/programs/gse.hs b/programs/gse.hs new file mode 100644 --- /dev/null +++ b/programs/gse.hs @@ -0,0 +1,7 @@ +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.GSE.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.GSE.Main +main = Quipper.Algorithms.GSE.Main.main diff --git a/programs/qls.hs b/programs/qls.hs new file mode 100644 --- /dev/null +++ b/programs/qls.hs @@ -0,0 +1,7 @@ +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.QLS.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.QLS.Main +main = Quipper.Algorithms.QLS.Main.main diff --git a/programs/tf.hs b/programs/tf.hs new file mode 100644 --- /dev/null +++ b/programs/tf.hs @@ -0,0 +1,7 @@ +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.TF.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.TF.Main +main = Quipper.Algorithms.TF.Main.main diff --git a/programs/usv.hs b/programs/usv.hs new file mode 100644 --- /dev/null +++ b/programs/usv.hs @@ -0,0 +1,7 @@ +-- This is a stub main file. It only purpose is to re-export the +-- "real" main function, which is Quipper.Algorithms.USV.Main. The +-- reason for putting the "real" main into a library is that we want +-- documentation to be generated for it. + +import qualified Quipper.Algorithms.USV.Main +main = Quipper.Algorithms.USV.Main.main diff --git a/quipper-algorithms.cabal b/quipper-algorithms.cabal new file mode 100644 --- /dev/null +++ b/quipper-algorithms.cabal @@ -0,0 +1,189 @@ +-- The name of the package. +name: quipper-algorithms + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.9.0.0 + +-- A short (one-line) description of the package. +synopsis: A set of algorithms implemented in Quipper. + +-- A longer description of the package. +description: + + This package provides seven algorithms that have been implemented in + Quipper. They are: + + BF - Boolean formula algorithm, + BWT - Binary welded tree algorithm, + CL - Class number algorithm, + GSE - Ground state estimation algorithm, + QLS - Quantum linear systems algorithm, + TF - Triangle finding algorithm, + USV - Unique shortest vector algorithm. + +-- URL for the project homepage or repository. +homepage: http://www.mathstat.dal.ca/~selinger/quipper/ + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: COPYRIGHT + +-- The package author(s). +author: Alexander S. Green, Keith Kim, Peter LeFanu Lumsdaine, + Siun-Chuon Mau, Neil J. Ross, Artur Scherer, + Peter Selinger, Benoît Valiron, Alexandr Virodov + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: selinger@mathstat.dal.ca + +-- A copyright notice. +copyright: Copyright (c) 2011-2019. All rights reserved. + +-- A classification category for future use by the package catalogue +-- Hackage. These categories have not yet been specified, but the +-- upper levels of the module hierarchy make a good start. +category: Quipper + +-- The type of build used by this package. +build-type: Custom + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >= 1.8 + +-- A list of additional files to be included in source distributions +-- built with setup sdist. +extra-source-files: images/*.png ChangeLog README + +executable bf + main-is: bf.hs + hs-source-dirs: programs + build-depends: + base >= 4.5 && < 5, + quipper-algorithms + +executable bwt + main-is: bwt.hs + hs-source-dirs: programs + build-depends: + base >= 4.5 && < 5, + quipper-algorithms + +executable cl + main-is: cl.hs + hs-source-dirs: programs + build-depends: + base >= 4.5 && < 5, + quipper-algorithms + +executable gse + main-is: gse.hs + hs-source-dirs: programs + build-depends: + base >= 4.5 && < 5, + quipper-algorithms + +executable qls + main-is: qls.hs + hs-source-dirs: programs + build-depends: + base >= 4.5 && < 5, + quipper-algorithms + +executable tf + main-is: tf.hs + hs-source-dirs: programs + build-depends: + base >= 4.5 && < 5, + quipper-algorithms + +executable usv + main-is: usv.hs + hs-source-dirs: programs + build-depends: + base >= 4.5 && < 5, + quipper-algorithms + + +library + -- Modules included in this executable, other than Main. + exposed-modules: + Quipper.Algorithms.BF.BooleanFormula + Quipper.Algorithms.BF.HexBoard + Quipper.Algorithms.BF.Hex + Quipper.Algorithms.BF.Main + Quipper.Algorithms.BF.Testing + + Quipper.Algorithms.BWT.Alternative + Quipper.Algorithms.BWT.BWT + Quipper.Algorithms.BWT.Definitions + Quipper.Algorithms.BWT.Main + Quipper.Algorithms.BWT.Simulate + Quipper.Algorithms.BWT.Template + + Quipper.Algorithms.CL.Auxiliary + Quipper.Algorithms.CL.CL + Quipper.Algorithms.CL.Main + Quipper.Algorithms.CL.RegulatorClassical + Quipper.Algorithms.CL.RegulatorQuantum + Quipper.Algorithms.CL.RegulatorTemplate + Quipper.Algorithms.CL.SmithReduction + Quipper.Algorithms.CL.Test + Quipper.Algorithms.CL.Types + + Quipper.Algorithms.GSE.GSEData + Quipper.Algorithms.GSE.GSE + Quipper.Algorithms.GSE.JordanWigner + Quipper.Algorithms.GSE.Main + + Quipper.Algorithms.QLS.CircLiftingImport + Quipper.Algorithms.QLS.Main + Quipper.Algorithms.QLS.QDouble + Quipper.Algorithms.QLS.QLS + Quipper.Algorithms.QLS.QSignedIntAux + Quipper.Algorithms.QLS.QSignedInt + Quipper.Algorithms.QLS.RealFunc + Quipper.Algorithms.QLS.TemplateOracle + Quipper.Algorithms.QLS.Utils + + Quipper.Algorithms.TF.Alternatives + Quipper.Algorithms.TF.Definitions + Quipper.Algorithms.TF.Main + Quipper.Algorithms.TF.Oracle + Quipper.Algorithms.TF.QWTFP + Quipper.Algorithms.TF.Simulate + + Quipper.Algorithms.USV.Definitions + Quipper.Algorithms.USV.Main + Quipper.Algorithms.USV.Simulate + Quipper.Algorithms.USV.USV + + -- Other library packages from which modules are imported. + build-depends: base >= 4.5 && < 5, + array >= 0.5, + containers >= 0.5.2.1, + mtl >= 2.1.2, + random >= 1.0.1.1, + newsynth >= 0.3.0.1, + easyrender >= 0.1.0.0, + Lattices >= 0.0.1, + deepseq >= 1.4, + primes >= 0.2.1.0, + QuickCheck >= 2.6, + filepath >= 1.4, + quipper-utils >= 0.9.0.0, + quipper-language >= 0.9.0.0, + quipper-libraries >= 0.9.0.0 + +custom-setup + setup-depends: base >= 4.5, + superdoc >= 0.1, + Cabal >= 1.24, + quipper-cabal >= 0.9.0.0