icfp13/CircuitSimulator.hs
2010-06-23 12:50:41 +02:00

102 lines
3.5 KiB
Haskell

module CircuitSimulator (execCircuit, execCircuit2, checkCircuit, checkCircuits) where
import Encoding
import CircuitBase
-- import Control.Monad.ST
import Data.Array.IO
import Data.Int
import System.IO.Unsafe
-- this is the gate function for "0#" (no other function found until now)
-- gate0 :: (Nat, Nat) -> (Nat, Nat)
-- gate0 (l,r) = (makef [0,2,1,1,0,2,2,1,0] (l,r), makef [2,2,2,2,0,1,2,1,0] (l,r))
-- helper to create gate functions
-- values for [(0,0),(0,1),(0,2),(1,0),(1,1),(1,2),(2,0),(2,1),(2,2)]
-- makef l x = fromJust $ lookup x $ zip [(i,j) | i <- [0..2], j <- [0..2]] l
gate0 :: (Trit, Trit) -> (Trit, Trit)
gate0 (l, r) = (l - r, l * r - 1)
igate0 :: (Int8, Int8) -> (Int8, Int8)
igate0 (l, r) = ((l - r) `mod` 3, (l * r - 1) `mod` 3)
execCircuit :: Stream s => Circuit -> s
execCircuit c = execCircuit2 c (streamread server_input ++ repeat T0)
execCircuit2 :: (Stream s1, Stream s2) => Circuit -> s1 -> s2
execCircuit2 c input = streamwrite $ execCircuit3 c $ streamread input
-- execCircuit3 c input = execfactory (circfactory c) input
execCircuit3 c input = ec c input
checkCircuit :: (Stream s1, Stream s2) => Circuit -> s1 -> s2 -> Bool
checkCircuit c input output = cec c i o where
o = streamread output
i = streamread input
checkCircuits :: (Stream s1, Stream s2) => s1 -> s2 -> [Circuit] -> [Circuit]
checkCircuits input output circs = filter (\c -> cec c i o) circs where
o = streamread output
i = streamread input
sameprefix :: Eq a => [a] -> [a] -> Bool
sameprefix a b = all (uncurry (==)) $ zip a b
circfactory :: Circuit -> ([Trit], ([Trit], Trit) -> ([Trit], Trit))
circfactory circ = (map (const 0) (inPins circ), next) where
next (pins, inp) = (pint, if (-1 == outPin circ) then inp else pint !! (outPin circ)) where
pint = work 0 [] pins
work _ n [] = n
work k n o@(a:b:t) = let (c,d) = gate0 (get k, get (k+1)) in c `seq` d `seq` work (k+2) (n ++ [c,d]) t where
get x = let r = (inPins circ !! x) in if (-1 == r) then inp else (n ++ o) !! r
ec :: Circuit -> [Trit] -> [Trit]
ec circ input = map (toTrit . fromIntegral) $ unsafePerformIO $ do
state <- newListArray (-1, length pins - 1) (0:map (const 0) pins) :: IO (IOUArray Int Int8)
next [] state (map (fromIntegral . fromTrit) input)
where
pins = inPins circ
opin = outPin circ
next r state [] = return r
next r state (x:xs) = do
writeArray state (-1) x
work state 0 pins
e <- readArray state opin
next (r ++ [e]) state xs
work state k [] = return ()
work state k (a:b:t) = do
x <- readArray state a
y <- readArray state b
let (c, d) = igate0 (x, y)
writeArray state k c
writeArray state (k+1) d
work state (k+2) t
cec :: Circuit -> [Trit] -> [Trit] -> Bool
cec circ input output = unsafePerformIO $ do
state <- newListArray (-1, length pins - 1) (0:map (const 0) pins) :: IO (IOUArray Int Int8)
next [] state (map (fromIntegral . fromTrit) input) (map (fromIntegral . fromTrit) output)
where
pins = inPins circ
opin = outPin circ
next r state [] _ = return True
next r state _ [] = return True
next r state (x:xs) (y:ys) = do
writeArray state (-1) x
work state 0 pins
e <- readArray state opin
if (e /= y) then return False else next (r ++ [e]) state xs ys
work state k [] = return ()
work state k (a:b:t) = do
x <- readArray state a
y <- readArray state b
let (c, d) = igate0 (x, y)
writeArray state k c
writeArray state (k+1) d
work state (k+2) t
execfactory :: (a, (a, Trit) -> (a, Trit)) -> [Trit] -> [Trit]
execfactory (s, f) [] = []
execfactory (s, f) (x:xs) = o:execfactory (t, f) xs where (t, o) = f (s, x)