
8 changed files with 517 additions and 206 deletions
@ -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" |
||||
|
@ -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