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

Reorganize code

master
Stefan Bühler 10 years ago
parent
6a103bc8ab
commit
d28673fb14
8 changed files with 517 additions and 184 deletions
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. +45
    -184
      Circuit.hs
  2. +21
    -0
      CircuitBase.hs
  3. +107
    -0
      CircuitC.hs
  4. +81
    -0
      CircuitParser.hs
  5. +101
    -0
      CircuitSimulator.hs
  6. +120
    -0
      Encoding.hs
  7. +36
    -0
      circsim.c
  8. +6
    -0
      circsim.h

+ 45
- 184
Circuit.hs View File

@@ -1,250 +1,89 @@
import Data.Maybe
import Text.ParserCombinators.ReadP

module Circuit (
Fuel, Tank, cartanks, createTank, createFuel, evalChamber, checkChamber, evalFuel, checkFuel, build1, build, key_circuit, test_key_circ, key_input, key, big_input,
Circuit(..), Chamber(..), Car(..), server_input, circ_from_perm,
execCircuit, execCircuit2, checkCircuit, checkCircuits,

permutations
) where

import Encoding
import CircuitBase
import CircuitParser

import CircuitSimulator
-- import CircuitC

import Data.List

import Data.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"


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

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"

test_key_circ :: Circuit -> Bool
test_key_circ circ = checkcirc circ input key

factory0 = parseCircuit "0L:X0R0#X0R:0L"
fact0_output = readstream "02120112100002120"
test0 = fact0_output == execcirc factory0

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)


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

execCirc c input = execfactory (circfactory c) input
execcirc c = execCirc c input
ec circ = execfactory (circfactory circ) (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
- 0
CircuitBase.hs 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
- 0
CircuitC.hs 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
- 0
CircuitParser.hs 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
- 0
CircuitSimulator.hs 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
- 0
Encoding.hs 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
- 0
circsim.c 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
- 0
circsim.h 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