Ticket #2932: Quantum.hs

File Quantum.hs, 11.7 KB (added by dave@…, 5 years ago)
Line 
1{-# LANGUAGE Arrows, RankNTypes #-}
2
3module Control.Arrow.Quantum
4    ( Quantum
5    , Amp
6    , entangle
7    , qLift
8    , qLift_
9    , observeWith
10    , observe
11    , runQuantum
12    , execQuantum
13    )
14where
15
16import Control.Category
17import Prelude hiding ((.), id)
18import Control.Arrow
19import Data.Complex
20import System.Random
21import Control.Monad.State
22import Control.Monad.Random
23
24-- |Representation of a probability amplitude
25type Amp = Complex Double
26
27-- |An eigenstate, qsAmp |qsValue>
28data QState a = QState { qsValue :: a, qsAmp :: Amp }
29
30-- |A quantum state: a sum of eigenstates (represented as a list)
31type QStateVec a = [QState a]
32
33-- |QState is a functor that maps the value and keeps the
34-- probability amplitude fixed.
35instance Functor QState where
36    fmap f (QState x p) = QState (f x) p
37
38-- |The Operator arrow is half of a Quantum arrow: it represents
39-- the "parallel" nature of quantum computations, but only handles
40-- choice in a "pure" way; that is, if you have:
41--
42-- > if x > 0
43-- >     then opLift print -< "Hello"
44-- >     else opLift print -< "Goodbye"
45--
46-- Then if x represents a superposition of both positive and
47-- negative numbers, both "Hello" and "Goodbye" will be printed
48-- (x taking on positive values in the then branch and negative
49-- values in the else branch).  This is leveraged by the Quantum
50-- arrow to do proper branch collapsation.
51--
52-- It is implemented as a function from quantum states to quantum
53-- states (under some MonadRandom for selection).  But the states are augmented
54-- by a dummy parameter 'd' to keep track of the relationship between
55-- the input and the output.  So if the value |1> generated the value
56-- |"foo"> in the output, then we know that when we collapse the
57-- input to 1, whatever the output of this computation was has to
58-- be collapsed to "foo" simultaneously.  The dummy parameter
59-- implements entanglement!
60newtype Operator m b c
61    = Op (forall d. QStateVec (b,d) -> m (QStateVec (c,d)))
62
63instance (Monad m) => Category (Operator m) where
64        id = Op (return . mapStateVec id)
65        (Op g) . (Op f) =
66                Op (\sts -> f sts >>= g)
67       
68instance (Monad m) => Arrow (Operator m) where
69    arr f             = 
70        Op (return . mapStateVec f)
71    first (Op f)      = 
72        Op (liftM (map (fmap shuffleLeftPair)) -- move it back
73          . f
74          . map (fmap shuffleRightPair))      -- move the fixed argument to the dummy parameter
75
76instance (Monad m) => ArrowChoice (Operator m) where
77    left (Op f) = Op $ \sts -> do
78        -- Our QStateVecs represent a sum, so the list is commutative.
79        -- So let's just split up the input based on what we want
80        -- f to transform and what we dont...
81        let lefts  = [ QState (st,d) p | QState (Left  st,d) p <- sts ]
82        let rights = [ QState (st,d) p | QState (Right st,d) p <- sts ]
83        -- ...transform half of it...
84        lefts' <- f lefts
85        -- ...and merge them back together...
86        return $ mapStateVec Left lefts'
87              ++ mapStateVec Right rights
88
89-- |opObserveWith f takes an equivalence relation f, splits the state
90-- space into equivalence classes based on f, and then randomly chooses
91-- one based on the probablity sum of each class.  The output is
92-- the chosen class.
93opObserveWith :: (MonadRandom m) => (a -> a -> Bool) -> Operator m a a
94opObserveWith eq = Op $ \sts -> do
95    let cls = classify eq sts
96    if null cls
97        then return []
98        else liftM snd $ pick (classify eq sts)
99
100-- |classify is a helper function for opObserveWith which splits the input into
101-- equivalence classes, finding the sum of the amplitudes of the states in each
102-- class (for selection purposes).  It returns a state vector of (a, QStateVec
103-- (a,b)):  the first element of the tuple is an arbitrary representitave of the
104-- class; the second element is the class itself (represented as a state vector).
105classify :: (a -> a -> Bool) -> QStateVec (a,b) -> QStateVec (a, QStateVec (a,b))
106classify eq xs = execState (classify' xs) []
107    where
108    classify' [] = return ()
109    classify' (QState (a,b) p:sts) = do
110        accum <- get
111        case break (\(QState (a',_) _) -> eq a a') accum of
112            (pre, []) -> do
113                put $ QState (a, [QState (a,b) p]) p : pre
114            (pre, QState (_,bs) p' : posts) ->
115                put $ pre ++ QState (a, QState (a,b) p : bs) (p+p') : posts
116        classify' sts
117
118-- |pick is a helper function for opObserveWith which takes a state vector and
119-- chooses an element from it at random based on the argument squared of the
120-- probability amplitudes.
121pick :: (MonadRandom m) => QStateVec a -> m a
122pick sts = pick' 0 (error "empty state") sts
123    where
124    pick' accum cur [] = return cur
125    pick' accum cur (QState x p : xs) = do
126        let prob = magnitude p^2
127        rand <- getRandomR (0, accum + prob)
128        pick' (accum + prob)
129              (if rand <= prob then x else cur)
130              xs
131
132   
133-- |opEntangle is an Operator arrow which takes a list of eigenstates and
134-- amplitudes and constructs a state vector out of them.
135opEntangle :: (Monad m) => Operator m [(a,Amp)] a
136opEntangle = Op $ \sts ->
137    return [ QState (a,d) (p*p') 
138             | QState (st,d) p <- sts
139             , (a,p') <- st ]
140   
141-- |opLift takes an action in the underlying monad and converts it into
142-- a quantum arrow.  The arrow observes the input to the action, collapsing
143-- the state, before performing the action.
144opLift :: (Eq a, MonadRandom m) => (a -> m b) -> Operator m a b
145opLift f = opObserveWith (==) >>> Op (\sts -> do
146    case sts of
147        (s:_) -> do
148            result <- f $ fst $ qsValue s
149            return [ QState (result,d) p | QState (_,d) p <- sts ]
150        [] -> return [])
151 
152-- |runOperator takes an input state vector, runs it through the given
153-- Operator arrow, and returns a state vector of outputs.
154runOperator :: (Monad m) => Operator m a b -> [(a,Amp)] -> m [(b,Amp)]
155runOperator (Op f) sts = do
156    ret <- f [ QState (st,()) p | (st,p) <- sts ]
157    return [ (st,p) | QState (st,()) p <- ret ]
158
159
160-- |The Quantum arrow represents a quantum computation with observation.
161-- You can give a quantum computation a superposition of values, and
162-- it will operate over them, returning you a superposition back.  If
163-- ever you observe (using the qLift or qLift_ functions), the system
164-- collapses to an eigenstate of what you observed.
165--
166-- > x <- entangle -< [(1, 1 :+ 0), (2, 1 :+ 0)]
167-- > -- x is in state |1> + |2>; i.e. 1 or 2 with equal probability
168-- > let y = x + 1
169-- > -- y is in state |2> + |3>
170-- > qLift print -< y    -- will print either 2 or 3; let's say it printed 2
171-- > -- state collapses here, y in state |2>
172-- > qLift print -< x    -- prints 1 (assuming 2 was printed earlier)
173--
174-- So the variables become entangled with each other in order to
175-- maintain consistency of the computation.
176newtype Quantum m b c
177--       |It is implemented by a "choice" over the Operator arrow.
178--       The Left states represent values in the current "branch"
179--       (think if statements, so eg. the "then" branch) computation,
180--       and the Right is states elsewhere.  If we decide to collapse,
181--       we need to collapse into a single branch.  If we chose the
182--       Left branch, we prune out all Right states from the input.
183--       If we chose the Right branch, we prune all Left states
184--       (thus "aborting" the current branch).
185    = Q (forall d. Operator m (Either b d) (Either c d))
186
187instance (Monad m) => Category (Quantum m) where
188        id           = Q (left (arr id))
189        (Q g) . (Q f) = Q (f >>> g)
190
191instance (Monad m) => Arrow (Quantum m) where
192    arr f           = Q (left (arr f))
193    first (Q f)     = Q (eitherToTuple ^>> first f >>^ tupleToEither)
194
195instance (Monad m) => ArrowChoice (Quantum m) where
196    left (Q f) = Q (shuffleRightEither ^>> f >>^ shuffleLeftEither)
197
198-- |observeBranch forces the computation to collapse into a
199-- single branch:
200--
201-- > x <- entangle -< [(1, 1 :+ 0), (2, 1 :+ 0)]
202-- > if x == 1
203-- >     then do ...
204-- >             observeBranch -- decide NOW whether x is 1 or not
205-- >     else ...
206--
207-- This is /the/ function for which the two-stage Operator/Quantum
208-- distinction was written, to be able to collapse conditionals
209-- "after they happen" rather than "as they happen".
210observeBranch :: (MonadRandom m) => Quantum m a a
211observeBranch = Q (opObserveWith sameSide)
212
213-- |entangle takes as input a list of values and probability
214-- amplitudes and gives as output a superposition of the inputs.
215-- For example:
216--
217-- > x <- entangle -< [(1, 1 :+ 0), (2, 0 :+ 1)]
218-- > -- x is now |1> + i|2>
219-- > qLift print -< x    -- prints 1 or 2 with equal probability
220entangle :: (Monad m) => Quantum m [(a,Amp)] a
221entangle = Q (left opEntangle)
222
223-- |@qLift f -< x@ first collapses @x@ to an eigenstate (using observe) then
224-- executes @f x@ in the underlying monad.  All conditionals up to this point are
225-- collapsed to an eigenstate (True or False) so a "current branch" of
226-- the computation is selected.
227qLift :: (Eq a, MonadRandom m) => (a -> m b) -> Quantum m a b
228qLift f = observeBranch >>> Q (left (opLift f))
229
230-- |qLift_ is just qIO which doesn't take an input.  eg.
231--
232-- > qLift_ $ print "hello world" -< ()
233--
234-- All conditionals up to this point are collapsed to an eigenstate
235-- (True or False) so a "current branch" of the computation is selected.
236qLift_ :: (MonadRandom m) => m b -> Quantum m () b
237qLift_ = qLift . const
238
239-- |@observeWith f@ takes an equivalence relation f, breaks the state
240-- space into eigenstates of that relation, and collapses to one. 
241-- For example:
242--
243-- > x <- entangle -< map (\s -> (s,1 :+ 0)) [1..20]
244-- > observeWith (\x y -> x `mod` 2 == y `mod` 2)
245--
246-- Will collapse @x@ to be either even or odd, but make no finer
247-- decisions than that.
248observeWith :: (MonadRandom m) => (a -> a -> Bool) -> Quantum m a a
249observeWith f = Q (left (opObserveWith f))
250
251-- |observe is just observeWith on equality.
252observe :: (Eq a, MonadRandom m) => Quantum m a a
253observe = observeWith (==)
254
255-- |runQuantum takes an input state vector, runs it through the given
256-- Quantum arrow, and returns a state vector of outputs.
257runQuantum :: (Monad m) => Quantum m a b -> [(a,Amp)] -> m [(b,Amp)]
258runQuantum (Q q) = runOperator (Left ^>> q >>^ either id undefined)
259
260-- |@execQuantum q x@ passes the state |x> through q, collapses q's
261-- output to an eigenstate, and returns it.
262execQuantum :: (Eq b, MonadRandom m) => Quantum m a b -> a -> m b
263execQuantum q a = 
264    liftM (fst . head) $ runQuantum (q >>> observeWith (==)) [(a, 1 :+ 0)]
265
266
267mapStateVec :: (a -> b) -> QStateVec (a,d) -> QStateVec (b,d)
268mapStateVec = map . fmap . first
269
270sameSide :: Either a b -> Either c d -> Bool
271sameSide (Left _)  (Left _)  = True
272sameSide (Right _) (Right _) = True
273sameSide _          _        = False
274
275shuffleRightPair :: ((a,b),c) -> (a,(b,c))
276shuffleRightPair ((a,b),c) = (a,(b,c))
277
278shuffleLeftPair :: (a,(b,c)) -> ((a,b),c)
279shuffleLeftPair (a,(b,c)) = ((a,b),c)
280
281shuffleRightEither :: Either (Either a b) c -> Either a (Either b c)
282shuffleRightEither = either (either Left (Right . Left)) (Right . Right)
283
284shuffleLeftEither :: Either a (Either b c) -> Either (Either a b) c
285shuffleLeftEither = either (Left . Left) (either (Left . Right) Right)
286
287tupleToEither :: (Either a b, Either c ()) -> Either (a,c) b
288tupleToEither (Left x, Left y)    = Left (x,y)
289tupleToEither (Right x, Right ()) = Right x
290tupleToEither _                   = error "Non-homogeneous pair"
291
292eitherToTuple :: Either (a,b) c -> (Either a c, Either b ())
293eitherToTuple (Left  (x,y)) = (Left x, Left y)
294eitherToTuple (Right x)     = (Right x, Right ())
295