Reorganize code

Circuit.hs

@@ -1,250 +1,89 @@
-import Data.Maybe
-import Text.ParserCombinators.ReadP
+
+module Circuit (
+	Fuel, Tank, cartanks, createTank, createFuel, evalChamber, checkChamber, evalFuel, checkFuel, build1, build, key_circuit, test_key_circ, key_input, key, big_input,
+	Circuit(..), Chamber(..), Car(..), server_input, circ_from_perm,
+	execCircuit, execCircuit2, checkCircuit, checkCircuits,
+
+	permutations
+) where
+
+import Encoding
+import CircuitBase
+import CircuitParser
+
+import CircuitSimulator
+-- import CircuitC
+
 import Data.List
+
+import Data.Maybe
 import Data.Packed
 
+
+
 type Fuel = [Tank]
 type Tank = Matrix Double
 
-type Nat = Int
-
 -- IMPORANT functions:
 -- * build
 --   create a circuit for a desired fuel output
 -- example:
 --   build ""
 
-type Dec a = ([Nat] -> (a, [Nat]))
-type Enc a = a -> String
-
-type Chamber = ([Nat], Nat, [Nat])
-type Car = [Chamber]
-
-decodeTern :: Num n => Int -> Dec n
-decodeTern k xs = dec k 0 xs where
-	dec 0 s xs = (s, xs)
-	dec k s (i:xs) = dec (k-1) (3*s + (fromIntegral i)) xs
-
-encodeTern 0 0 = ""
-encodeTern k x = (encodeTern (k-1) (x `div` 3)) ++ show (x `mod` 3)
-
-decodeNumber :: Dec Int
-decodeNumber xs = let (len, x0) = decodeListLen xs in let (r, x1) = decodeTern len x0 in (((3^len - 1) `div` 2) + r, x1)
-
-decodeListLen :: Dec Int
-decodeListLen (0:xs) = (0,xs)
-decodeListLen (1:xs) = (1,xs)
-decodeListLen (2:2:xs) = let (r,x0) = decodeNumber xs in (fromIntegral $ 2+r,x0)
-
-decodeTuple2 :: (Dec a, Dec b) -> Dec (a, b)
-decodeTuple2 (f, g) x = let (a, x1) = f x in let (b, x2) = g x1 in ((a,b), x2)
-decodeTuple3 :: (Dec a, Dec b, Dec c) -> Dec (a, b, c)
-decodeTuple3 (f, g, h) x = let (a, x1) = f x in let (b, x2) = g x1 in let (c, x3) = h x2 in ((a,b,c), x3)
-
-decodeList :: Dec a -> Dec [a]
-decodeList f x = let (len,x1) = decodeListLen x in get [] len x1 where
-	get r 0 x = (r, x)
-	get r k x = let (e,xn) = f x in get (r ++ [e]) (k-1) xn
-
-decodeNumberList = decodeList decodeNumber
-
-
-decodeCar = fst . decodeList (decodeTuple3 (decodeNumberList, decodeNumber, decodeNumberList)) . readstream
-
-cartanks :: Car -> Nat
-cartanks = (1+) . maximum . concat . map (\(upper, _, lower) -> upper ++ lower)
-
-encodeNumber :: Enc Integer
-encodeNumber n
-	| n < 0 = error "Can't encode negative numbers"
-	| n == 0 = "0"
-	| n > 0 = let len = log3 n in encodeListLen len ++ encodeTern len (n - base len) where
-		base len = (3^len - 1) `div` 2
-		log3 n = (head $ filter (\len -> n < base len) [0..]) - 1
+cartanks :: Car -> Int
+cartanks = (1+) . maximum . concat . map (\(Chamber upper _ lower) -> upper ++ lower) . chambers
 
-encodeListLen :: Enc Int
-encodeListLen n
-	| n < 0 = error "Can't encode negative numbers"
-	| n == 0 = "0"
-	| n == 1 = "1"
-	| n >= 2 = "22" ++ encodeNumber (fromIntegral $ n-2)
-
-encodeList :: Enc a -> Enc [a]
-encodeList e xs = (encodeListLen (length xs)) ++ (concat $ map e xs)
-
-encodeFuel :: [[[Integer]]] -> String
-encodeFuel = (encodeList $ encodeList $ encodeList encodeNumber)
-
-createTank :: [[Nat]] -> Tank
+createTank :: [[Integer]] -> Tank
 createTank = fromLists . map (map fromIntegral)
 createFuel = map createTank
 
 evalChamber :: Fuel -> Chamber -> Matrix Double
-evalChamber tanks (upper, _, lower) = product (map (tanks !! ) upper) - product (map (tanks !! ) lower)
+evalChamber tanks (Chamber upper _ lower) = product (map (tanks !! ) upper) - product (map (tanks !! ) lower)
 
 checkChamber :: Fuel -> Chamber -> Bool
-checkChamber tanks c@(upper, mode, lower) = (all (>= 0) $ concat $ toLists diff) && (mode /= 0 || (diff @@> (0,0)) > 0) where
+checkChamber tanks c@(Chamber upper main lower) = (all (>= 0) $ concat $ toLists diff) && (not main || (diff @@> (0,0)) > 0) where
 	diff = evalChamber tanks c
 
 evalFuel :: Fuel -> Car -> [Matrix Double]
-evalFuel = map . evalChamber
+evalFuel f = map (evalChamber f) . chambers
 
 checkFuel :: Fuel -> Car -> Bool
-checkFuel fuel car = checkfuel && all (checkChamber fuel) car where
+checkFuel fuel car = checkfuel && all (checkChamber fuel) (chambers car) where
 	checkfuel = if (all (>= 0) $ concat $ concat $ map toLists fuel) && all (\t -> (t @@> (0,0)) > 0) fuel then True else error "Fuel broken"
 
-
-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))
-
-makef l x = fromJust $ lookup x $ zip [(i,j) | i <- [0..2], j <- [0..2]] l
-
---
-execcirc :: Circuit -> [Nat]
-
-key_circuit = parseCircuit key_circuit_str
-key_circuit_str = "19L:12R13R0#1R12R,14R0L0#4R9L,9R10R0#3L8L,2L17R0#5L9R,15R1L0#10R13R,3L18R0#6L15L,5L11R0#13L12L,19R16R0#11R8R,2R7R0#11L10L,1R3R0#18L2L,8R4L0#16L2R,8L7L0#15R6R,6R0R0#14L0L,6L4R0#14R0R,12L13L0#17L1L,5R11L0#16R4L,10L15L0#17R7R,14L16L0#18R3R,9L17L0#19R5R,X18L0#X7L:19L"
-
-test_key_circ :: Circuit -> Bool
-test_key_circ circ = checkcirc circ input key
-
-factory0 = parseCircuit "0L:X0R0#X0R:0L"
-fact0_output = readstream "02120112100002120"
-test0 = fact0_output == execcirc factory0
-
-input = readstream "01202101210201202"
-
-block0 = 0:(init input)
-block1 = 1:(init input)
-block2 = 2:(init input)
+-- zero everything:
+-- Circuit {outPin = 8, inPins = [2,9,4,5,-1,3,1,0,6,7]}
 
 -- basic blocks
 -- 0: 1R:2L1L0#X2L,2RX0#0R2R,0R1R0#0L1L:0L
 -- 1: 2L:2R1R0#2R1R,2L0R0#X0R,X0L0#1L0L:1L
 -- 2: 2R:2R1R0#2L1L,0R2L0#X0R,0LX0#1R0L:1L
 -- build circuit for needed output
-build1 s = let (p, pins) = step 4 [0,-1,1,6,2,3,5,7] (dropWhile (0 == ) $ reverse (key ++ (readstream s))) in Circuit p pins where
+build1 s = let (p, pins) = step 4 [0,-1,1,6,2,3,5,7] (dropWhile (0 == ) $ reverse (key ++ (streamread s))) in Circuit p pins where
 	step p gates [] = (p, gates)
 	step p gates (x:xs) = let k = length gates in case x of
 		0 -> step k (gates ++ [k+4,k+2,k+5,p,k+1,k+3]) xs
 		1 -> step (k+2) (gates ++ [k+5,k+3,k+4,k+1,p,k]) xs
 		2 -> step (k+2) (gates ++ [k+5,k+3,k+1,k+4,k,p]) xs
 
-build s = let (p, pins) = step (-1) [] (reverse (key ++ (readstream s))) in Circuit p pins where
+build s = let (p, pins) = step (-1) [] (reverse (key ++ (streamread s))) in Circuit p pins where
 	step p gates [] = (p, gates)
 	step p gates (x:xs) = let k = length gates in case x of
 		0 -> step k (gates ++ [k+4,k+2,k+5,p,k+1,k+3]) xs
 		1 -> step (k+2) (gates ++ [k+5,k+3,k+4,k+1,p,k]) xs
 		2 -> step (k+2) (gates ++ [k+5,k+3,k+1,k+4,k,p]) xs
 
-data Circuit = Circuit { outPin :: Int, inPins :: [Int] } deriving (Eq, Show)
-
-
-circfactory :: Circuit -> ([Nat], ([Nat], Nat) -> ([Nat], Nat))
-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 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
-
-showCircuit (Circuit op inpins) = (formatPin ip) ++ ":" ++ (joinWith "," (nodes inpins outpins)) ++ ":" ++ (formatPin op) where
-	nodes :: [Nat] -> [Nat] -> [String]
-	nodes [] [] = []
-	nodes (a:b:i) (c:d:o) = ((formatPin a) ++ (formatPin b) ++ "0#" ++ (formatPin c) ++ (formatPin d)):nodes i o
-	joinWith sep [] = []
-	joinWith sep (x:xs) = (x ++) $ concat $ map (sep ++) xs
-	-- build reverse pin mapping
-	(ip:outpins) = map snd $ sort $ zip (op:inpins) [-1..]
-	formatPin p = if (-1 == p) then "X" else (show (p `div` 2)) ++ (if even p then "L" else "R")
-
-circ_from_perm (x:xs) = if (odd $ length xs) then error "Wrong pin count" else Circuit x xs
-
-readPlace :: ReadP Int
-readPlace = (char 'L' >> return 0) <++ (char 'R' >> return 1)
-
-readInt :: ReadP Int
-readInt = readS_to_P reads
-
-readPin :: ReadP Int
-readPin = (char 'X' >> return (-1)) <++ do
-	i <- readInt
-	p <- readPlace
-	return $ (2*i) + p
-
-readNode :: ReadP [Int]
-readNode = do
-	a <- readPin
-	b <- readPin
-	char '0'
-	char '#'
-	readPin
-	readPin
-	return [a,b]
-
-readNodes1 :: ReadP [Int]
-readNodes1 = (do
-	char ','
-	x <- readNode
-	xl <- readNodes1
-	return $ x ++ xl
-	) <++ (return [])
-
-readNodes :: ReadP [Int]
-readNodes = (do
-	x <- readNode
-	xl <- readNodes1
-	return $ x ++ xl
-	) <++ (return [])
-
-
-readCircuit :: ReadP Circuit
-readCircuit = do
-	readPin
-	char ':'
-	nodes <- readNodes
-	char ':'
-	outPin <- readPin
-	return $ Circuit outPin nodes
-
-doparse p s = fst $ head $ readP_to_S p s                                                                                                                                                                                                       
-parseCircuit s = doparse readCircuit s
-
-execfactory :: (a, (a, Nat) -> (a, Nat)) -> [Nat] -> [Nat]
-execfactory (s, f) [] = []
-execfactory (s, f) (x:xs) = o:execfactory (t, f) xs where (t, o) = f (s, x)
-
-checkcirc :: Circuit -> [Nat] -> [Nat] -> Bool
-checkcirc c input output = let inp = take (length output) (input ++ repeat 0) in output == execCirc c inp
-
-execCirc c input = execfactory (circfactory c) input
-execcirc c = execCirc c input
-ec circ = execfactory (circfactory circ) (input ++ take 100 (repeat 0))
-
-readstream :: String -> [Int]
-readstream = map (\c -> read [c] :: Int)
-
-key_input = [0,2,2,2,2,2,2,0,2,1,0,1,1,0,0,1,1]
-key = execCirc key_circuit key_input
+key_circuit = parseCircuit key_circuit_str
+key_circuit_str = "19L:12R13R0#1R12R,14R0L0#4R9L,9R10R0#3L8L,2L17R0#5L9R,15R1L0#10R13R,3L18R0#6L15L,5L11R0#13L12L,19R16R0#11R8R,2R7R0#11L10L,1R3R0#18L2L,8R4L0#16L2R,8L7L0#15R6R,6R0R0#14L0L,6L4R0#14R0R,12L13L0#17L1L,5R11L0#16R4L,10L15L0#17R7R,14L16L0#18R3R,9L17L0#19R5R,X18L0#X7L:19L"
+
+-- goal: Find a circuit with test_key_circ circ == True
+test_key_circ :: Circuit -> Bool
+test_key_circ circ = checkCircuit circ server_input key
+
+key_input :: [Trit]
+key_input = streamread "02222220210110011"
+key :: [Trit]
+key = execCircuit2 key_circuit key_input
+-- key: "11021210112101221"
+
+big_input = streamread "0120101201201020210210020210101010101110202022202020202001010210200102010201010201201020201201020120101202102021010120120210201201020120102102"

CircuitBase.hs

@@ -0,0 +1,21 @@
+
+module CircuitBase (Circuit(..), Chamber(..), Car(..), server_input, circ_from_perm) where
+
+import Encoding
+
+data Circuit = Circuit { outPin :: Int, inPins :: [Int] } deriving (Eq, Show)
+circ_from_perm (x:xs) = if (odd $ length xs) then error "Wrong pin count" else Circuit x xs
+
+data Chamber = Chamber { upperPipe :: [Int], mainChamber :: Bool, lowerPipe :: [Int] }
+data Car = Car { chambers :: [Chamber] }
+
+instance Encode Chamber where
+	sdecode xs = let (x0, (a,b,c)) = sdecode xs in (x0, Chamber a (not b) c)
+	sencode (Chamber a b c) = sencode (a, not b, c)
+
+instance Encode Car where
+	sdecode xs = let (x0, a) = sdecode xs in (x0, Car a)
+	sencode (Car a) = sencode a
+
+server_input = "01202101210201202"
+

CircuitC.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS -lcircsim -L. #-}
+
+-- gcc -fPIC -shared -o libcircsim.so circsim.c
+-- ghci CircuitC.hs -lcircsim -L.
+
+module CircuitC (execCircuit, execCircuit2, checkCircuit, checkCircuits) where
+
+import Foreign.C.Types                                                                                                                                                                                                                          
+import Foreign.Storable                                                                                                                                                                                                                         
+import Foreign.Ptr                                                                                                                                                                                                                              
+import Foreign.Marshal.Array                                                                                                                                                                                                                    
+import Foreign.Marshal.Alloc                                                                                                                                                                                                                    
+import System.IO.Unsafe                                                                                                                                                                                                                         
+
+import Data.List
+import Data.Maybe
+
+import Encoding
+import CircuitBase
+
+foreign import ccall unsafe "circsim.h circsim"                                                                                                                                                                                                    
+	imp_circsim :: CInt -> Ptr CInt -> Ptr CInt -> CInt -> Ptr CInt -> IO ()                                                                                                                                                                                                     
+-- (int gates, int *gatepins, int *states, int streamlen, int *stream)
+foreign import ccall unsafe "circsim.h findcirc"                                                                                                                                                                                                    
+	imp_findcirc :: CInt -> Ptr CInt -> CInt -> Ptr CInt -> Ptr CInt -> IO CInt                                                                                                                                                                                                    
+-- (int gates, int *gatepins, int *states, int streamlen, int *stream, int *output)
+
+normlists a b = unzip $ zip a b
+
+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 = map toTrit $ snd $ circsim n (take (length n) $ repeat 0) i where
+	n = circ_to_native c
+	i = map fromTrit input :: [Int]
+
+checkCircuit :: (Stream s1, Stream s2) => Circuit -> s1 -> s2 -> Bool
+checkCircuit c input output = findcirc n i o where
+	n = circ_to_native c
+	(i, o) = normlists (map fromTrit $ streamread input) (map fromTrit $ streamread output)
+
+checkCircuits :: (Stream s1, Stream s2) => s1 -> s2 -> [Circuit] -> [Circuit]
+checkCircuits input output circs = map native_to_circ $ maybeToList $ findcircs (map circ_to_native circs) i o where
+	(i, o) = normlists (map fromTrit $ streamread input) (map fromTrit $ streamread output)
+
+circsim :: [Int] -> [Int] -> [Int] -> ([Int], [Int])
+circsim gatepins state input = unsafePerformIO $ do
+	let gates = length gatepins `div` 2
+	let slen = length input
+	pins <- newArray $ map fromIntegral gatepins :: IO (Ptr CInt)
+	states <- newArray $ map fromIntegral state :: IO (Ptr CInt)
+	sin <- newArray $ map fromIntegral input :: IO (Ptr CInt)
+	imp_circsim (fromIntegral gates) pins states (fromIntegral slen) sin
+	ostate <- peekArray (length state) states
+	output <- peekArray slen sin
+	free states
+	free sin
+	free pins
+	return (map fromIntegral ostate, map fromIntegral output)
+
+-- input and output must have the same length
+findcircs :: [[Int]] -> [Int] -> [Int] -> Maybe [Int]
+findcircs circs input output = unsafePerformIO $ do
+	let slen = length input
+	sin <- newArray $ map fromIntegral input :: IO (Ptr CInt)
+	sout <- newArray $ map fromIntegral output :: IO (Ptr CInt)
+	res <- findfirstcirc slen sin sout circs
+	free sin
+	free sout
+	return res where
+		findfirstcirc slen sin sout [] = return Nothing
+		findfirstcirc slen sin sout (gatepins:circs) = do
+			let gates = length gatepins `div` 2
+			pins <- newArray $ map fromIntegral gatepins :: IO (Ptr CInt)
+			res <- imp_findcirc (fromIntegral gates) pins (fromIntegral slen) sin sout
+			free pins
+			if (res /= 0) then return (Just gatepins) else findfirstcirc slen sin sout circs
+
+
+-- input and output must have the same length
+findcirc :: [Int] -> [Int] -> [Int] -> Bool
+findcirc gatepins input output = unsafePerformIO $ do
+	let gates = length gatepins `div` 2
+	let slen = length input
+	pins <- newArray $ map fromIntegral gatepins :: IO (Ptr CInt)
+	sin <- newArray $ map fromIntegral input :: IO (Ptr CInt)
+	sout <- newArray $ map fromIntegral output :: IO (Ptr CInt)
+	res <- imp_findcirc (fromIntegral gates) pins (fromIntegral slen) sin sout
+	free sin
+	free sout
+	free pins
+	return $ res /= 0
+
+brutecircs :: Int -> [Int] -> Maybe Circuit
+brutecircs gates output = case findcircs (permutations [0..2*gates]) (map fromTrit $ streamread server_input) output of
+							   Nothing -> Nothing
+							   Just p -> Just $ circ_from_perm $ map (\x -> x-1) p
+
+
+circ_to_native :: Circuit -> [Int]
+circ_to_native (Circuit o p) = (map (1+) (o:p))
+
+native_to_circ :: [Int] -> Circuit
+native_to_circ n = let (o:p) = map (\x -> x-1) n in Circuit o p

CircuitParser.hs

@@ -0,0 +1,81 @@
+
+module CircuitParser (parseCircuit, showCircuit) where
+
+import Text.ParserCombinators.ReadP
+import Data.List
+
+import CircuitBase
+
+-- instance Show Circuit where
+-- 	show = showCircuit
+
+showCircuit (Circuit op inpins) = (formatPin ip) ++ ":" ++ (joinWith "," (nodes inpins outpins)) ++ ":" ++ (formatPin op) where
+	nodes :: [Int] -> [Int] -> [String]
+	nodes [] [] = []
+	nodes (a:b:i) (c:d:o) = ((formatPin a) ++ (formatPin b) ++ "0#" ++ (formatPin c) ++ (formatPin d)):nodes i o
+	joinWith sep [] = []
+	joinWith sep (x:xs) = (x ++) $ concat $ map (sep ++) xs
+	-- build reverse pin mapping
+	(ip:outpins) = map snd $ sort $ zip (op:inpins) [-1..]
+	formatPin p = if (-1 == p) then "X" else (show (p `div` 2)) ++ (if even p then "L" else "R")
+
+-- Circuit Syntax:
+-- <inPin>:[<gates>]:<outPin>
+-- each Pin is either "X" (circuit IN or OUT)
+--   or <gate-number> + ("L" | "R")
+-- gates are numbered from 0
+-- one gate is <inPinLeft><inPinRight>0#<outPinLeft><outPinRight>
+--   obviously you specify the connector of the other side
+--   (0 is probably the gate "function")
+-- this contains redundancy ofc, it would be enough to specify only the in pins of the gates and the circuit OUT
+--   (internal representation)
+
+readPlace :: ReadP Int
+readPlace = (char 'L' >> return 0) <++ (char 'R' >> return 1)
+
+readInt :: ReadP Int
+readInt = readS_to_P reads
+
+readPin :: ReadP Int
+readPin = (char 'X' >> return (-1)) <++ do
+	i <- readInt
+	p <- readPlace
+	return $ (2*i) + p
+
+readNode :: ReadP [Int]
+readNode = do
+	a <- readPin
+	b <- readPin
+	char '0'
+	char '#'
+	readPin
+	readPin
+	return [a,b]
+
+readNodes1 :: ReadP [Int]
+readNodes1 = (do
+	char ','
+	x <- readNode
+	xl <- readNodes1
+	return $ x ++ xl
+	) <++ (return [])
+
+readNodes :: ReadP [Int]
+readNodes = (do
+	x <- readNode
+	xl <- readNodes1
+	return $ x ++ xl
+	) <++ (return [])
+
+
+readCircuit :: ReadP Circuit
+readCircuit = do
+	readPin
+	char ':'
+	nodes <- readNodes
+	char ':'
+	outPin <- readPin
+	return $ Circuit outPin nodes
+
+doparse p s = fst $ head $ readP_to_S p s                                                                                                                                                                                                       
+parseCircuit s = doparse readCircuit s

CircuitSimulator.hs

@@ -0,0 +1,101 @@
+
+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)

Encoding.hs

@@ -0,0 +1,120 @@
+{-# OPTIONS -fglasgow-exts #-}
+
+module Encoding (Trit(..), Encode(..), Stream(..), encode, decode, decodeStrict, toTrit, fromTrit) where
+
+data Trit = T0 | T1 | T2 deriving (Enum, Eq)
+
+instance Show Trit where
+  show = show . fromEnum
+
+instance Read Trit where
+  readsPrec _ "0" = [(T0, "")]
+  readsPrec _ "1" = [(T1, "")]
+  readsPrec _ "2" = [(T2, "")]
+
+instance Num Trit where
+  (+) = liftToTrit (+)
+  (*) = liftToTrit (*)
+  (-) = liftToTrit (-)
+  abs = id
+  signum = const 0
+  fromInteger 0 = T0
+  fromInteger 1 = T1
+  fromInteger 2 = T2
+
+liftToTrit :: (Int -> Int -> Int) -> Trit -> Trit -> Trit
+liftToTrit f x y  = toEnum $ (fromEnum x `f` fromEnum y) `mod` 3
+
+toTrit :: Int -> Trit
+toTrit = toEnum
+fromTrit :: Integral i => Trit -> i
+fromTrit = fromIntegral . fromEnum
+
+type DR a = ([Trit], a)
+
+class Stream a where
+	streamread :: a -> [Trit]
+	streamwrite :: [Trit] -> a
+
+instance Stream [Trit] where
+	streamread = id
+	streamwrite = id
+
+instance Stream [Int] where
+	streamread = map toEnum
+	streamwrite = map fromEnum
+
+instance Stream String where
+	streamread = map (toEnum . read . (:[]))
+	streamwrite = concat . map (show . fromEnum)
+
+class Encode a where
+	sdecode :: [Trit] -> ([Trit], a)
+	sencode :: a -> [Trit]
+
+encode :: (Stream s, Encode a) => a -> s
+encode = streamwrite . sencode
+decode  :: (Stream s, Encode a) => s -> a
+decode = snd . sdecode . streamread
+decodeStrict :: (Stream s, Encode a) => s -> a
+decodeStrict x = case (sdecode $ streamread x) of
+	([], a) -> a
+	(_, _) -> error "Expected end of input"
+
+instance Encode Bool where
+	sdecode xs = case sdecode xs :: DR Int of
+		(x0, 0) -> (x0, False)
+		(x0, 1) -> (x0, True)
+		(x0, i) -> error "Expected 0 or 1"
+	sencode True = [1]
+	sencode False = [0]
+
+instance Encode Trit where
+	sdecode [] = error "Unexpected end of stream"
+	sdecode (i:xs) = (xs, i)
+	sencode t = [t]
+
+instance Encode a => Encode [a] where
+	sdecode [] = error "Unexpected end of stream"
+	sdecode (T0:xs) = (xs, [])
+	sdecode (T1:xs) = let (x0, a) = sdecode xs in (x0, [a])
+	sdecode (T2:T2:xs) = let (x0, a) = sdecode xs :: DR Int in get [] (a+2) x0  where
+		get r 0 x = (x, r)
+		get r k x | k > 0 = let (xn, e) = sdecode x in get (r ++ e) (k-1) xn
+	sencode [] = [T0]
+	sencode [x] = T1:sencode x
+	sencode xs = (sencode $ length xs - 2) ++ concat (map sencode xs)
+
+instance Encode Int where
+	sdecode xs = let (x0, i) = sdecode xs :: DR Integer in (x0, fromIntegral i)
+	sencode i = sencode (fromIntegral i :: Integer)
+
+instance Encode Integer where
+	sdecode xs = let (x0, digits) = sdecode xs :: DR [Trit] in
+		let sum = decodeTern digits in (x0, (3^(length digits - 1) `div` 2) + sum)
+	sencode n
+		| n < 0 = error "Can't encode negative numbers"
+		| n == 0 = [0]
+		| n > 0 = let len = log3 n in sencode (encodeTern len (n - base len)) where
+			base len = (3^len - 1) `div` 2
+			log3 n = (head $ filter (\len -> n < base len) [0..]) - 1
+
+instance (Encode a, Encode z) => Encode (a, z) where
+	sdecode xs = let (x0, a) = sdecode xs in let (x1, z) = sdecode x0 in (x1, (a, z))
+	sencode (a, z) = sencode a ++ sencode z
+
+instance (Encode (a, b), Encode z) => Encode (a, b, z) where
+	sdecode xs = let (x0, (a, b)) = sdecode xs in let (x1, z) = sdecode x0 in (x1, (a, b, z))
+	sencode (a, b, z) = sencode (a, b) ++ sencode z
+
+decodeTern :: Integral i => [Trit] -> i
+decodeTern digits = dec 0 digits where
+	dec s [] = s
+	dec s (i:xs) = dec (3*s + (fromTrit i)) xs
+
+encodeTern :: Integral i => Int -> i -> [Trit]
+encodeTern 0 0 = []
+encodeTern k x = (encodeTern (k-1) (x `div` 3)) ++ [toTrit $ fromIntegral (x `mod` 3)]
+
+-- cartanks :: Car -> Nat
+-- cartanks = (1+) . maximum . concat . map (\(upper, _, lower) -> upper ++ lower)

circsim.c

@@ -0,0 +1,36 @@
+
+#include "circsim.h"
+
+#include <string.h>
+
+static const int gateL[9] = { 0, 2, 1, 1, 0, 2, 2, 1, 0 };
+static const int gateR[9] = { 2, 2, 2, 2, 0, 1, 2, 1, 0 };
+
+void circsim(int gates, int *gatepins, int *states, int streamlen, int *stream) {
+	for (; streamlen-- > 0; stream++) {
+		int i;
+		states[0] = *stream;
+		for (i = 0; i < gates; i++) {
+			int k = 3*states[gatepins[2*i+1]] + states[gatepins[2*i+2]];
+			states[2*i+1] = gateL[k];
+			states[2*i+2] = gateR[k];
+		}
+		*stream = states[gatepins[0]];
+	}
+}
+
+int findcirc(int gates, int *gatepins, int streamlen, int *stream, int *output) {
+	int states[2*gates+1];
+	memset(states, 0, sizeof(int) * (2*gates+1));
+	for (; streamlen-- > 0; stream++) {
+		int i;
+		states[0] = *stream;
+		for (i = 0; i < gates; i++) {
+			int k = 3*states[gatepins[2*i+1]] + states[gatepins[2*i+2]];
+			states[2*i+1] = gateL[k];
+			states[2*i+2] = gateR[k];
+		}
+		if (*output++ != states[gatepins[0]]) return 0;
+	}
+	return 1;
+}

circsim.h

@@ -0,0 +1,6 @@
+
+#include <stdint.h>
+#include <stdlib.h>
+
+void circsim(int gates, int *gatepins, int *states, int streamlen, int *stream);
+int findcirc(int gates, int *gatepins, int streamlen, int *stream, int *output);