WFC Haskell

Playground.hs

coin1 = 0.5 .* return Heads + 0.5 .* return Tails :: P Coin

runW coin1


--albert Heads
--albert Tails


albert1 n = 
  return Heads 
    ->- repeat n (->< albert)
    ->- collect


runW $ albert1 20



runW $ snot1 4
runW $ snot1 3
runW $ snot1 2
runW $ snot1 1


runW $ zeno1 4
runW $ zeno1 3
runW $ zeno1 2
runW $ zeno1 1


runW $ zeno2 4
runW $ zeno2 3
runW $ zeno2 2
runW $ zeno2 1


runW $ zeno3 4
runW $ zeno3 3
runW $ zeno3 2
runW $ zeno3 1

WFC.hs

module WFC1 where

{- From http://blog.sigfpe.com/2007/03/monads-vector-spaces-and-quantum.html -}
    

import Prelude hiding (repeat)
import Data.Map (toList,fromListWith)
import Data.Complex

infixl 7 .*

data W b a = W { runW :: [(a,b)] } deriving (Eq,Show,Ord) -- Wave


mapW f (W l) = W $ map (\(a,b) -> (a,f b)) l


instance Functor (W b) where
  fmap f (W a) = W $ map (\(a,p) -> (f a,p)) a


instance Num b => Applicative (W b) where
  pure = return
  _ <*> _ = error "No Ap"


instance Num b => Monad (W b) where
  return x = W [(x,1)]
  l >>= f = 
    W $ concatMap 
       (\(W d, p) -> map (\(x, q) -> (x, p*q)) d) (runW $ fmap f l)
    

a .* b = mapW (a*) b


instance (Eq a,Show a,Num b) => Num (W b a) where
  W a + W b = W $ (a ++ b)
  a - b = a + (-1) .* b
  _ * _ = error "Num is annoying"
  abs _ = error "Num is annoying"
  signum _ = error "Num is annoying"
  fromInteger a = 
    if a==0 
      then W [] 
      else error "fromInteger can only take zero argument"
      

collect :: (Ord a,Num b) => W b a -> W b a
collect = W . toList . fromListWith (+) . runW


type P a = W Float a -- Probablity
type Q a = W (Complex Float) a -- P with Complex probabilities


(->-) :: a -> (a -> b) -> b
g ->- f = f g

(-><) :: Q a -> (a -> Q b) -> Q b
g ->< f = g >>= f


observe :: Ord a => Q a -> P a
observe = W . map (\(a,w) -> (a,magnitude (w*w))) . runW . collect


rotate :: Float -> Bool -> Q Bool
rotate theta True = let theta' = theta :+ 0
  in cos (theta'/2) .* return True - sin (theta'/2) .* return False
rotate theta False = let theta' = theta :+ 0
  in cos (theta'/2) .* return False + sin (theta'/2) .* return True
  


snot = rotate (pi/2)


snot1 n = return True ->- repeatM n snot ->- observe


repeat 0 f = id
repeat n ~f = repeat (n-1) f . f


repeatM n f = repeat n (>>= f)


(=>=) :: P a -> (a -> b) -> P b
g =>= f = fmap f g


(=><) :: P (Q a) -> (a -> Q b) -> P (Q b)
g =>< f = fmap (>>= f) g


join :: P (P a) -> P a
join = (>>= id)


zeno1 n = 
  return True 
  ->- repeatM n (rotate (pi/fromInteger n)) 
  ->- collect 
  ->- observe


zeno2 n = 
  return True 
  ->- repeat n
    (\x -> 
        x =>= return 
          =>< rotate (pi/fromInteger n) 
          =>= observe 
          ->- join)
  ->- collect
  

zeno3 n = 
  return ([],True) 
    ->- repeatM n 
      (\(m,s) -> do
        s' <- rotate (pi/fromInteger n) s
        return (s:m,s')) 
    ->- observe 
    =>= snd 
    ->- collect  
          


data Coin = Heads | Tails deriving (Eq,Show,Ord)

albert :: Coin -> Q Coin
albert Heads = 0.5 .* return Heads + 0.5 .* return Tails 
albert Tails = 0.25 .* return Heads + 0.75 .* return Tails