Reorganize code
This commit is contained in:
Stefan Bühler
parent
6a103bc8ab
commit
d28673fb14
245
Circuit.hs
245
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
|
||||
cartanks :: Car -> Int
|
||||
cartanks = (1+) . maximum . concat . map (\(Chamber upper _ lower) -> upper ++ lower) . chambers
|
||||
|
||||
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
|
||||
|
||||
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)
|
||||
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
|
||||
-- show = showCircuit
|
||||
-- goal: Find a circuit with test_key_circ circ == True
|
||||
test_key_circ :: Circuit -> Bool
|
||||
test_key_circ circ = checkCircuit circ server_input key
|
||||
|
||||
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
|
||||
key_input :: [Trit]
|
||||
key_input = streamread "02222220210110011"
|
||||
key :: [Trit]
|
||||
key = execCircuit2 key_circuit key_input
|
||||
-- key: "11021210112101221"
|
||||
|
||||
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
|
||||
big_input = streamread "0120101201201020210210020210101010101110202022202020202001010210200102010201010201201020201201020120101202102021010120120210201201020120102102"
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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)
|
||||
|
|
@ -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;
|
||||
}
|
||||
Loading…
Reference in New Issue