{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}

module QIO.Qdata where

import Data.Monoid as Monoid
import QIO.QioSyn

class Qdata a qa | a -> qa, qa -> a where
    mkQ :: a -> QIO qa
    measQ :: qa -> QIO a
    letU :: a -> (qa -> U) -> U
    condQ :: qa -> (a -> U) -> U

instance Qdata Bool Qbit where
    mkQ = mkQbit
    measQ = measQbit
    letU b xu = ulet b xu
    condQ q br = cond q br
                         
instance (Qdata a qa,Qdata b qb) => Qdata (a,b) (qa,qb) where

    mkQ (a,b) = do qa <- mkQ a
                   qb <- mkQ b
                   return (qa,qb)

    measQ (qa,qb) = do a <- measQ qa
                       b <- measQ qb
                       return (a,b)

    letU (a,b) xyu = letU a (\ x -> letU b (\ y -> xyu (x,y)))

    condQ (qa,qb) br = condQ qa (\x -> condQ qb (\y -> br (x,y))) 

instance Qdata a qa => Qdata [a] [qa] where
    mkQ n = sequence (map mkQ n)
    measQ qs = sequence (map measQ qs)
    letU as xsu = letU' as []
        where letU' [] xs = xsu xs
              letU' (a:as) xs = letU a (\ x -> letU' as (xs++[x]))
    condQ qs qsu = condQ' qs []
	where condQ' [] xs = qsu xs
	      condQ' (a:as) xs = condQ a (\ x -> condQ' as (xs++[x]))

condQRec :: Qdata a qa => [qa] -> [(a -> U)] -> U
condQRec [] [] = mempty
condQRec (q:qs) (u:us) = (condQ q u) `mappend` condQRec qs us


qIntSize :: Int
qIntSize = 4

newtype QInt = QInt [Qbit] deriving Show

int2bits :: Int -> [Bool]
int2bits n = int2bits' n qIntSize
             where int2bits' 0 0 = []
                   int2bits' _ 0 = error "int2bits: too large"
                   int2bits' n l = ((n `mod` 2) /= 0) : int2bits' (n `div` 2) (l-1)

bits2int :: [Bool] -> Int
bits2int [] = 0
bits2int (b:bs) = (2*bits2int bs)+(if b then 1 else 0)

instance Qdata Int QInt where
    mkQ n = do qn <- mkQ (int2bits n)
               return (QInt qn)
    measQ (QInt qbs) = 
        do bs <- measQ qbs
           return (bits2int bs)
    letU n xu = letU (int2bits n) (\ bs -> xu (QInt bs))
    condQ (QInt qi) qiu = condQ qi (\ x -> qiu (bits2int x))