From d28673fb14461e7b98f78f119c6dd711d881514c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Stefan=20B=C3=BChler?= Date: Wed, 23 Jun 2010 12:50:41 +0200 Subject: [PATCH] Reorganize code --- Circuit.hs | 245 ++++++++------------------------------------ CircuitBase.hs | 21 ++++ CircuitC.hs | 107 +++++++++++++++++++ CircuitParser.hs | 81 +++++++++++++++ CircuitSimulator.hs | 101 ++++++++++++++++++ Encoding.hs | 120 ++++++++++++++++++++++ circsim.c | 36 +++++++ circsim.h | 6 ++ 8 files changed, 514 insertions(+), 203 deletions(-) create mode 100644 CircuitBase.hs create mode 100644 CircuitC.hs create mode 100644 CircuitParser.hs create mode 100644 CircuitSimulator.hs create mode 100644 Encoding.hs create mode 100644 circsim.c create mode 100644 circsim.h diff --git a/Circuit.hs b/Circuit.hs index 93676dd..88de51b 100644 --- a/Circuit.hs +++ b/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: --- :[]: --- each Pin is either "X" (circuit IN or OUT) --- or + ("L" | "R") --- gates are numbered from 0 --- one gate is 0# --- 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" diff --git a/CircuitBase.hs b/CircuitBase.hs new file mode 100644 index 0000000..bbdfe9a --- /dev/null +++ b/CircuitBase.hs @@ -0,0 +1,21 @@ + +module CircuitBase (Circuit(..), Chamber(..), Car(..), server_input, circ_from_perm) where + +import Encoding + +data Circuit = Circuit { outPin :: Int, inPins :: [Int] } deriving (Eq, Show) +circ_from_perm (x:xs) = if (odd $ length xs) then error "Wrong pin count" else Circuit x xs + +data Chamber = Chamber { upperPipe :: [Int], mainChamber :: Bool, lowerPipe :: [Int] } +data Car = Car { chambers :: [Chamber] } + +instance Encode Chamber where + sdecode xs = let (x0, (a,b,c)) = sdecode xs in (x0, Chamber a (not b) c) + sencode (Chamber a b c) = sencode (a, not b, c) + +instance Encode Car where + sdecode xs = let (x0, a) = sdecode xs in (x0, Car a) + sencode (Car a) = sencode a + +server_input = "01202101210201202" + diff --git a/CircuitC.hs b/CircuitC.hs new file mode 100644 index 0000000..1b45b3e --- /dev/null +++ b/CircuitC.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS -lcircsim -L. #-} + +-- gcc -fPIC -shared -o libcircsim.so circsim.c +-- ghci CircuitC.hs -lcircsim -L. + +module CircuitC (execCircuit, execCircuit2, checkCircuit, checkCircuits) where + +import Foreign.C.Types +import Foreign.Storable +import Foreign.Ptr +import Foreign.Marshal.Array +import Foreign.Marshal.Alloc +import System.IO.Unsafe + +import Data.List +import Data.Maybe + +import Encoding +import CircuitBase + +foreign import ccall unsafe "circsim.h circsim" + imp_circsim :: CInt -> Ptr CInt -> Ptr CInt -> CInt -> Ptr CInt -> IO () +-- (int gates, int *gatepins, int *states, int streamlen, int *stream) +foreign import ccall unsafe "circsim.h findcirc" + imp_findcirc :: CInt -> Ptr CInt -> CInt -> Ptr CInt -> Ptr CInt -> IO CInt +-- (int gates, int *gatepins, int *states, int streamlen, int *stream, int *output) + +normlists a b = unzip $ zip a b + +execCircuit :: Stream s => Circuit -> s +execCircuit c = execCircuit2 c (streamread server_input ++ repeat T0) +execCircuit2 :: (Stream s1, Stream s2) => Circuit -> s1 -> s2 +execCircuit2 c input = streamwrite $ execCircuit3 c $ streamread input + +execCircuit3 c input = map toTrit $ snd $ circsim n (take (length n) $ repeat 0) i where + n = circ_to_native c + i = map fromTrit input :: [Int] + +checkCircuit :: (Stream s1, Stream s2) => Circuit -> s1 -> s2 -> Bool +checkCircuit c input output = findcirc n i o where + n = circ_to_native c + (i, o) = normlists (map fromTrit $ streamread input) (map fromTrit $ streamread output) + +checkCircuits :: (Stream s1, Stream s2) => s1 -> s2 -> [Circuit] -> [Circuit] +checkCircuits input output circs = map native_to_circ $ maybeToList $ findcircs (map circ_to_native circs) i o where + (i, o) = normlists (map fromTrit $ streamread input) (map fromTrit $ streamread output) + +circsim :: [Int] -> [Int] -> [Int] -> ([Int], [Int]) +circsim gatepins state input = unsafePerformIO $ do + let gates = length gatepins `div` 2 + let slen = length input + pins <- newArray $ map fromIntegral gatepins :: IO (Ptr CInt) + states <- newArray $ map fromIntegral state :: IO (Ptr CInt) + sin <- newArray $ map fromIntegral input :: IO (Ptr CInt) + imp_circsim (fromIntegral gates) pins states (fromIntegral slen) sin + ostate <- peekArray (length state) states + output <- peekArray slen sin + free states + free sin + free pins + return (map fromIntegral ostate, map fromIntegral output) + +-- input and output must have the same length +findcircs :: [[Int]] -> [Int] -> [Int] -> Maybe [Int] +findcircs circs input output = unsafePerformIO $ do + let slen = length input + sin <- newArray $ map fromIntegral input :: IO (Ptr CInt) + sout <- newArray $ map fromIntegral output :: IO (Ptr CInt) + res <- findfirstcirc slen sin sout circs + free sin + free sout + return res where + findfirstcirc slen sin sout [] = return Nothing + findfirstcirc slen sin sout (gatepins:circs) = do + let gates = length gatepins `div` 2 + pins <- newArray $ map fromIntegral gatepins :: IO (Ptr CInt) + res <- imp_findcirc (fromIntegral gates) pins (fromIntegral slen) sin sout + free pins + if (res /= 0) then return (Just gatepins) else findfirstcirc slen sin sout circs + + +-- input and output must have the same length +findcirc :: [Int] -> [Int] -> [Int] -> Bool +findcirc gatepins input output = unsafePerformIO $ do + let gates = length gatepins `div` 2 + let slen = length input + pins <- newArray $ map fromIntegral gatepins :: IO (Ptr CInt) + sin <- newArray $ map fromIntegral input :: IO (Ptr CInt) + sout <- newArray $ map fromIntegral output :: IO (Ptr CInt) + res <- imp_findcirc (fromIntegral gates) pins (fromIntegral slen) sin sout + free sin + free sout + free pins + return $ res /= 0 + +brutecircs :: Int -> [Int] -> Maybe Circuit +brutecircs gates output = case findcircs (permutations [0..2*gates]) (map fromTrit $ streamread server_input) output of + Nothing -> Nothing + Just p -> Just $ circ_from_perm $ map (\x -> x-1) p + + +circ_to_native :: Circuit -> [Int] +circ_to_native (Circuit o p) = (map (1+) (o:p)) + +native_to_circ :: [Int] -> Circuit +native_to_circ n = let (o:p) = map (\x -> x-1) n in Circuit o p diff --git a/CircuitParser.hs b/CircuitParser.hs new file mode 100644 index 0000000..f5de95b --- /dev/null +++ b/CircuitParser.hs @@ -0,0 +1,81 @@ + +module CircuitParser (parseCircuit, showCircuit) where + +import Text.ParserCombinators.ReadP +import Data.List + +import CircuitBase + +-- instance Show Circuit where +-- show = showCircuit + +showCircuit (Circuit op inpins) = (formatPin ip) ++ ":" ++ (joinWith "," (nodes inpins outpins)) ++ ":" ++ (formatPin op) where + nodes :: [Int] -> [Int] -> [String] + nodes [] [] = [] + nodes (a:b:i) (c:d:o) = ((formatPin a) ++ (formatPin b) ++ "0#" ++ (formatPin c) ++ (formatPin d)):nodes i o + joinWith sep [] = [] + joinWith sep (x:xs) = (x ++) $ concat $ map (sep ++) xs + -- build reverse pin mapping + (ip:outpins) = map snd $ sort $ zip (op:inpins) [-1..] + formatPin p = if (-1 == p) then "X" else (show (p `div` 2)) ++ (if even p then "L" else "R") + +-- Circuit Syntax: +-- :[]: +-- each Pin is either "X" (circuit IN or OUT) +-- or + ("L" | "R") +-- gates are numbered from 0 +-- one gate is 0# +-- 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 diff --git a/CircuitSimulator.hs b/CircuitSimulator.hs new file mode 100644 index 0000000..51084f5 --- /dev/null +++ b/CircuitSimulator.hs @@ -0,0 +1,101 @@ + +module CircuitSimulator (execCircuit, execCircuit2, checkCircuit, checkCircuits) where + +import Encoding +import CircuitBase + +-- import Control.Monad.ST +import Data.Array.IO +import Data.Int +import System.IO.Unsafe + +-- this is the gate function for "0#" (no other function found until now) +-- gate0 :: (Nat, Nat) -> (Nat, Nat) +-- gate0 (l,r) = (makef [0,2,1,1,0,2,2,1,0] (l,r), makef [2,2,2,2,0,1,2,1,0] (l,r)) + +-- helper to create gate functions +-- values for [(0,0),(0,1),(0,2),(1,0),(1,1),(1,2),(2,0),(2,1),(2,2)] +-- makef l x = fromJust $ lookup x $ zip [(i,j) | i <- [0..2], j <- [0..2]] l + +gate0 :: (Trit, Trit) -> (Trit, Trit) +gate0 (l, r) = (l - r, l * r - 1) +igate0 :: (Int8, Int8) -> (Int8, Int8) +igate0 (l, r) = ((l - r) `mod` 3, (l * r - 1) `mod` 3) + +execCircuit :: Stream s => Circuit -> s +execCircuit c = execCircuit2 c (streamread server_input ++ repeat T0) +execCircuit2 :: (Stream s1, Stream s2) => Circuit -> s1 -> s2 +execCircuit2 c input = streamwrite $ execCircuit3 c $ streamread input + +-- execCircuit3 c input = execfactory (circfactory c) input +execCircuit3 c input = ec c input + +checkCircuit :: (Stream s1, Stream s2) => Circuit -> s1 -> s2 -> Bool +checkCircuit c input output = cec c i o where + o = streamread output + i = streamread input + +checkCircuits :: (Stream s1, Stream s2) => s1 -> s2 -> [Circuit] -> [Circuit] +checkCircuits input output circs = filter (\c -> cec c i o) circs where + o = streamread output + i = streamread input + +sameprefix :: Eq a => [a] -> [a] -> Bool +sameprefix a b = all (uncurry (==)) $ zip a b + +circfactory :: Circuit -> ([Trit], ([Trit], Trit) -> ([Trit], Trit)) +circfactory circ = (map (const 0) (inPins circ), next) where + next (pins, inp) = (pint, if (-1 == outPin circ) then inp else pint !! (outPin circ)) where + pint = work 0 [] pins + work _ n [] = n + work k n o@(a:b:t) = let (c,d) = gate0 (get k, get (k+1)) in c `seq` d `seq` work (k+2) (n ++ [c,d]) t where + get x = let r = (inPins circ !! x) in if (-1 == r) then inp else (n ++ o) !! r + +ec :: Circuit -> [Trit] -> [Trit] +ec circ input = map (toTrit . fromIntegral) $ unsafePerformIO $ do + state <- newListArray (-1, length pins - 1) (0:map (const 0) pins) :: IO (IOUArray Int Int8) + next [] state (map (fromIntegral . fromTrit) input) + where + pins = inPins circ + opin = outPin circ + next r state [] = return r + next r state (x:xs) = do + writeArray state (-1) x + work state 0 pins + e <- readArray state opin + next (r ++ [e]) state xs + work state k [] = return () + work state k (a:b:t) = do + x <- readArray state a + y <- readArray state b + let (c, d) = igate0 (x, y) + writeArray state k c + writeArray state (k+1) d + work state (k+2) t + +cec :: Circuit -> [Trit] -> [Trit] -> Bool +cec circ input output = unsafePerformIO $ do + state <- newListArray (-1, length pins - 1) (0:map (const 0) pins) :: IO (IOUArray Int Int8) + next [] state (map (fromIntegral . fromTrit) input) (map (fromIntegral . fromTrit) output) + where + pins = inPins circ + opin = outPin circ + next r state [] _ = return True + next r state _ [] = return True + next r state (x:xs) (y:ys) = do + writeArray state (-1) x + work state 0 pins + e <- readArray state opin + if (e /= y) then return False else next (r ++ [e]) state xs ys + work state k [] = return () + work state k (a:b:t) = do + x <- readArray state a + y <- readArray state b + let (c, d) = igate0 (x, y) + writeArray state k c + writeArray state (k+1) d + work state (k+2) t + +execfactory :: (a, (a, Trit) -> (a, Trit)) -> [Trit] -> [Trit] +execfactory (s, f) [] = [] +execfactory (s, f) (x:xs) = o:execfactory (t, f) xs where (t, o) = f (s, x) diff --git a/Encoding.hs b/Encoding.hs new file mode 100644 index 0000000..da4bee3 --- /dev/null +++ b/Encoding.hs @@ -0,0 +1,120 @@ +{-# OPTIONS -fglasgow-exts #-} + +module Encoding (Trit(..), Encode(..), Stream(..), encode, decode, decodeStrict, toTrit, fromTrit) where + +data Trit = T0 | T1 | T2 deriving (Enum, Eq) + +instance Show Trit where + show = show . fromEnum + +instance Read Trit where + readsPrec _ "0" = [(T0, "")] + readsPrec _ "1" = [(T1, "")] + readsPrec _ "2" = [(T2, "")] + +instance Num Trit where + (+) = liftToTrit (+) + (*) = liftToTrit (*) + (-) = liftToTrit (-) + abs = id + signum = const 0 + fromInteger 0 = T0 + fromInteger 1 = T1 + fromInteger 2 = T2 + +liftToTrit :: (Int -> Int -> Int) -> Trit -> Trit -> Trit +liftToTrit f x y = toEnum $ (fromEnum x `f` fromEnum y) `mod` 3 + +toTrit :: Int -> Trit +toTrit = toEnum +fromTrit :: Integral i => Trit -> i +fromTrit = fromIntegral . fromEnum + +type DR a = ([Trit], a) + +class Stream a where + streamread :: a -> [Trit] + streamwrite :: [Trit] -> a + +instance Stream [Trit] where + streamread = id + streamwrite = id + +instance Stream [Int] where + streamread = map toEnum + streamwrite = map fromEnum + +instance Stream String where + streamread = map (toEnum . read . (:[])) + streamwrite = concat . map (show . fromEnum) + +class Encode a where + sdecode :: [Trit] -> ([Trit], a) + sencode :: a -> [Trit] + +encode :: (Stream s, Encode a) => a -> s +encode = streamwrite . sencode +decode :: (Stream s, Encode a) => s -> a +decode = snd . sdecode . streamread +decodeStrict :: (Stream s, Encode a) => s -> a +decodeStrict x = case (sdecode $ streamread x) of + ([], a) -> a + (_, _) -> error "Expected end of input" + +instance Encode Bool where + sdecode xs = case sdecode xs :: DR Int of + (x0, 0) -> (x0, False) + (x0, 1) -> (x0, True) + (x0, i) -> error "Expected 0 or 1" + sencode True = [1] + sencode False = [0] + +instance Encode Trit where + sdecode [] = error "Unexpected end of stream" + sdecode (i:xs) = (xs, i) + sencode t = [t] + +instance Encode a => Encode [a] where + sdecode [] = error "Unexpected end of stream" + sdecode (T0:xs) = (xs, []) + sdecode (T1:xs) = let (x0, a) = sdecode xs in (x0, [a]) + sdecode (T2:T2:xs) = let (x0, a) = sdecode xs :: DR Int in get [] (a+2) x0 where + get r 0 x = (x, r) + get r k x | k > 0 = let (xn, e) = sdecode x in get (r ++ e) (k-1) xn + sencode [] = [T0] + sencode [x] = T1:sencode x + sencode xs = (sencode $ length xs - 2) ++ concat (map sencode xs) + +instance Encode Int where + sdecode xs = let (x0, i) = sdecode xs :: DR Integer in (x0, fromIntegral i) + sencode i = sencode (fromIntegral i :: Integer) + +instance Encode Integer where + sdecode xs = let (x0, digits) = sdecode xs :: DR [Trit] in + let sum = decodeTern digits in (x0, (3^(length digits - 1) `div` 2) + sum) + sencode n + | n < 0 = error "Can't encode negative numbers" + | n == 0 = [0] + | n > 0 = let len = log3 n in sencode (encodeTern len (n - base len)) where + base len = (3^len - 1) `div` 2 + log3 n = (head $ filter (\len -> n < base len) [0..]) - 1 + +instance (Encode a, Encode z) => Encode (a, z) where + sdecode xs = let (x0, a) = sdecode xs in let (x1, z) = sdecode x0 in (x1, (a, z)) + sencode (a, z) = sencode a ++ sencode z + +instance (Encode (a, b), Encode z) => Encode (a, b, z) where + sdecode xs = let (x0, (a, b)) = sdecode xs in let (x1, z) = sdecode x0 in (x1, (a, b, z)) + sencode (a, b, z) = sencode (a, b) ++ sencode z + +decodeTern :: Integral i => [Trit] -> i +decodeTern digits = dec 0 digits where + dec s [] = s + dec s (i:xs) = dec (3*s + (fromTrit i)) xs + +encodeTern :: Integral i => Int -> i -> [Trit] +encodeTern 0 0 = [] +encodeTern k x = (encodeTern (k-1) (x `div` 3)) ++ [toTrit $ fromIntegral (x `mod` 3)] + +-- cartanks :: Car -> Nat +-- cartanks = (1+) . maximum . concat . map (\(upper, _, lower) -> upper ++ lower) diff --git a/circsim.c b/circsim.c new file mode 100644 index 0000000..a8665cb --- /dev/null +++ b/circsim.c @@ -0,0 +1,36 @@ + +#include "circsim.h" + +#include + +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; +} diff --git a/circsim.h b/circsim.h new file mode 100644 index 0000000..20e1c7a --- /dev/null +++ b/circsim.h @@ -0,0 +1,6 @@ + +#include +#include + +void circsim(int gates, int *gatepins, int *states, int streamlen, int *stream); +int findcirc(int gates, int *gatepins, int streamlen, int *stream, int *output);