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

Reorganize code

master
Stefan Bühler 12 years ago
parent
6a103bc8ab
commit
d28673fb14
8 changed files with 517 additions and 206 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 251
      Circuit.hs
  2. 21
      CircuitBase.hs
  3. 107
      CircuitC.hs
  4. 81
      CircuitParser.hs
  5. 101
      CircuitSimulator.hs
  6. 120
      Encoding.hs
  7. 36
      circsim.c
  8. 6
      circsim.h

251
Circuit.hs
Unescape 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.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"
-- 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)
-- 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)
-- 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)
-- instance Show Circuit where
-- show = showCircuit
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
-- 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
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"

21
CircuitBase.hs
Unescape 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
Unescape 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
Unescape 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
Unescape 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
Unescape 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
Unescape 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
Unescape 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);
Write Preview
Loading…
Cancel
Save