251 lines
8.5 KiB
Haskell
251 lines
8.5 KiB
Haskell
import Data.Maybe
|
|
import Text.ParserCombinators.ReadP
|
|
import Data.List
|
|
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
|
|
|
|
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 = fromLists . map (map fromIntegral)
|
|
createFuel = map createTank
|
|
|
|
evalChamber :: Fuel -> Chamber -> Matrix Double
|
|
evalChamber tanks (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
|
|
diff = evalChamber tanks c
|
|
|
|
evalFuel :: Fuel -> Car -> [Matrix Double]
|
|
evalFuel = map . evalChamber
|
|
|
|
checkFuel :: Fuel -> Car -> Bool
|
|
checkFuel fuel car = checkfuel && all (checkChamber fuel) 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)
|
|
|
|
-- 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
|
|
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
|
|
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
|