icfp/icfp13
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Reorganize code

Browse Source
This commit is contained in:
Stefan Bühler 2010-06-23 12:50:41 +02:00
parent 6a103bc8ab
commit d28673fb14
8 changed files with 514 additions and 203 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

245
Circuit.hs
View File

@ -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.List
import Data.Maybe
import Data.Packed import Data.Packed
type Fuel = [Tank] type Fuel = [Tank]
type Tank = Matrix Double type Tank = Matrix Double
type Nat = Int
-- IMPORANT functions: -- IMPORANT functions:
-- * build -- * build
-- create a circuit for a desired fuel output -- create a circuit for a desired fuel output
-- example: -- example:
-- build "" -- build ""
type Dec a = ([Nat] -> (a, [Nat])) cartanks :: Car -> Int
type Enc a = a -> String cartanks = (1+) . maximum . concat . map (\(Chamber upper _ lower) -> upper ++ lower) . chambers
type Chamber = ([Nat], Nat, [Nat]) createTank :: [[Integer]] -> Tank
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
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 = fromLists . map (map fromIntegral) createTank = fromLists . map (map fromIntegral)
createFuel = map createTank createFuel = map createTank
evalChamber :: Fuel -> Chamber -> Matrix Double 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 :: 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 diff = evalChamber tanks c
evalFuel :: Fuel -> Car -> [Matrix Double] evalFuel :: Fuel -> Car -> [Matrix Double]
evalFuel = map . evalChamber evalFuel f = map (evalChamber f) . chambers
checkFuel :: Fuel -> Car -> Bool 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" checkfuel = if (all (>= 0) $ concat $ concat $ map toLists fuel) && all (\t -> (t @@> (0,0)) > 0) fuel then True else error "Fuel broken"
-- Circuit Syntax: -- zero everything:
-- <inPin>:[<gates>]:<outPin> -- Circuit {outPin = 8, inPins = [2,9,4,5,-1,3,1,0,6,7]}
-- 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)
-- 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
--
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"
-- goal: Find a circuit with test_key_circ circ == True
test_key_circ :: Circuit -> Bool
-- test_key_circ circ = (key == execcirc circ)
test_key_circ circ = checkcirc circ input key
-- key: 11021210112101221
factory0 = parseCircuit "0L:X0R0#X0R:0L"
fact0_output = readstream "02120112100002120"
test0 = fact0_output == execcirc factory0
-- known server input stream (from factory "X::X")
input = readstream "01202101210201202"
block0 = 0:(init input)
block1 = 1:(init input)
block2 = 2:(init input)
-- basic blocks -- basic blocks
-- 0: 1R:2L1L0#X2L,2RX0#0R2R,0R1R0#0L1L:0L -- 0: 1R:2L1L0#X2L,2RX0#0R2R,0R1R0#0L1L:0L
-- 1: 2L:2R1R0#2R1R,2L0R0#X0R,X0L0#1L0L:1L -- 1: 2L:2R1R0#2R1R,2L0R0#X0R,X0L0#1L0L:1L
-- 2: 2R:2R1R0#2L1L,0R2L0#X0R,0LX0#1R0L:1L -- 2: 2R:2R1R0#2L1L,0R2L0#X0R,0LX0#1R0L:1L
-- build circuit for needed output -- 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 [] = (p, gates)
step p gates (x:xs) = let k = length gates in case x of 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 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 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 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 [] = (p, gates)
step p gates (x:xs) = let k = length gates in case x of 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 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 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 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) 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"
-- instance Show Circuit where -- goal: Find a circuit with test_key_circ circ == True
-- show = showCircuit test_key_circ :: Circuit -> Bool
test_key_circ circ = checkCircuit circ server_input key
circfactory :: Circuit -> ([Nat], ([Nat], Nat) -> ([Nat], Nat)) key_input :: [Trit]
circfactory circ = (map (const 0) (inPins circ), next) where key_input = streamread "02222220210110011"
next (pins, inp) = (pint, if (-1 == outPin circ) then inp else pint !! (outPin circ)) where key :: [Trit]
pint = work 0 [] pins key = execCircuit2 key_circuit key_input
work _ n [] = n -- key: "11021210112101221"
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 big_input = streamread "0120101201201020210210020210101010101110202022202020202001010210200102010201010201201020201201020120101202102021010120120210201201020120102102"
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
-- checkcirc c input output = findcirc (circ_to_native c) input output
execCirc c input = execfactory (circfactory c) input
-- execCirc = eec
execcirc c = execCirc c input
ec circ = execfactory (circfactory circ) (input ++ take 100 (repeat 0))
-- ec c = eec c (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

21
CircuitBase.hs Normal file
View File

@ -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"

107
CircuitC.hs Normal file
View File

@ -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

81
CircuitParser.hs Normal file
View File

@ -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

101
CircuitSimulator.hs Normal file
View File

@ -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)

120
Encoding.hs Normal file
View File

@ -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)

36
circsim.c Normal file
View File

@ -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;
}

6
circsim.h Normal file
View File

@ -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);