A true work of haskell art

Quantum.hs

import Data.Bits
import Data.List
import qualified Data.Map.Lazy as Map
import Control.Monad.Trans.State
import Control.Applicative
import Control.Monad

type EntanglementId = Int
type EntanglementState = State EntanglementId

getNewEntanglementId :: EntanglementState Int
getNewEntanglementId = state $ \a -> (a, a + 1)

runEntanglement :: EntanglementState a -> a
runEntanglement f = evalState f 0

type SuperpositionId = Integer

getSuperpositionId :: [EntanglementId] -> SuperpositionId
getSuperpositionId = foldr (\a b -> b .|. (bit a)) 0

data SuperposedValue a = SuperposedValue SuperpositionId (Map.Map SuperpositionId a) deriving Show

unentangle :: SuperposedValue a -> Map.Map SuperpositionId a
unentangle (SuperposedValue _ a) = a

unsuperpose :: SuperposedValue a -> [a]
unsuperpose (SuperposedValue _ a) = Map.elems a

instance Functor SuperposedValue where
	fmap f (SuperposedValue as a) = SuperposedValue as (fmap f a)

bitsOf :: (Bits a, Ord a) => a -> [Int]
bitsOf a = findIndices (\v -> testBit a v) $ takeWhile (\v -> (bit v) <= a) [0..]

addEntanglement :: EntanglementId -> SuperposedValue a -> SuperposedValue a
addEntanglement i (SuperposedValue as a) = let is = bit i in
	SuperposedValue (as .|. is) (a `Map.union` (Map.mapKeys (.|.is) a))

coEntangle :: SuperpositionId -> SuperposedValue a -> SuperposedValue a
coEntangle is a@(SuperposedValue as _) = foldr addEntanglement a $ bitsOf ((as .&. is) `xor` is)

instance Applicative SuperposedValue where
	pure a = SuperposedValue 0 $ Map.singleton 0 a
	f@(SuperposedValue fs _) <*> a@(SuperposedValue as _) = SuperposedValue (fs .|. as) $ Map.intersectionWith ($) (unentangle $ coEntangle as f) (unentangle $ coEntangle fs a)

limit :: (a -> Bool) -> SuperposedValue a -> SuperposedValue a
limit f (SuperposedValue as a) = SuperposedValue as $ Map.filter f a

nilSuperposition :: EntanglementState (SuperposedValue a)
nilSuperposition = return $ SuperposedValue 0 Map.empty

singletonSuperposition :: a -> EntanglementState (SuperposedValue a)
singletonSuperposition a = do
	return $ SuperposedValue 0 $ Map.singleton 0 a

binarySuperposition :: a -> a -> EntanglementState (SuperposedValue a)
binarySuperposition a b = do
	i <- getNewEntanglementId
	let is = bit i
	return $ SuperposedValue is $ Map.fromList [(0, a), (is, b)]

listSuperposition :: Show a => [a] -> EntanglementState (SuperposedValue a)
listSuperposition [] = nilSuperposition
listSuperposition [a] = singletonSuperposition a
listSuperposition a = do
	is <- replicateM loglength getNewEntanglementId
	return $ SuperposedValue (getSuperpositionId is) $ Map.fromList $ superpose 0 is a
	where
		loglength = let al = length a in head $ dropWhile (\v -> (bit v) < al) [1..]
		superpose n _ [a] = [(n, a)]
		superpose n [] _ = []
		superpose n (i:is) a = let (xs, ys) = split a in (superpose n is xs) ++ (superpose (n .|. (bit i)) is ys)
		split [] = ([], [])
		split [a] = ([a], [])
		split (x:y:xys) = (x:xs, y:ys) where (xs, ys) = split xys