icfp14/Lambda.hs

101 рядки
3.5 KiB
Haskell

{-# OPTIONS -XTypeSynonymInstances #-}
module Lambda (
Term (..),
store, storeInt,
command, callresult, loop,
printMove
) where
import Eval
import System.IO
import Text.ParserCombinators.ReadP
import Data.Char
import Control.Monad
data Term = Const Int | Prim Card | Seq Term Term | Apply Term Term
ptConst :: ReadP Term
ptConst = readS_to_P reads >>= return . Const
ptPrim = do
c <- pCard
return $ Prim c
ptGroup = do
char '('
t <- ptTerm
skipSpaces; char ')'
return t
ptEnd = eof <++ do
c:_ <- look
when (isAlphaNum c || c == ';' || c == '(') pfail
ptApply f = do
skipSpaces
(ptEnd >> return f) <++
(char ';' >> ptTerm >>= \g -> return $ Seq f g) <++
(ptTerm1 >>= \x -> ptApply (Apply f x))
ptTerm1 = skipSpaces >> (ptConst <++ ptPrim <++ ptGroup)
ptTerm = ptTerm1 >>= ptApply
instance Show Term where
show (Const i) = show i
show (Prim c) = show c
show (Seq f g) = show f ++ ";" ++ show g
{- show (Apply f (Const i)) = show f ++ " " ++ show i
show (Apply f (Prim c)) = show f ++ " " ++ show c-}
show (Apply f x) = show f ++ "(" ++ show x ++ ")"
instance Read Term where
readsPrec _ = readP_to_S ptTerm
cI = Prim Card_I
cGet n = Apply (Prim Card_Get) (Const n)
cPut = Prim Card_Put
cS [f, g] = Apply (Apply (Prim Card_S) f) g
cS [f, g, x] = Apply (Apply (Apply (Prim Card_S) f) g) x
cK x = Apply (Prim Card_K) x
cInc i = Apply (Prim Card_Inc) (Const i)
cDec i = Apply (Prim Card_Dec) (Const i)
cAttack [i, j] = Apply (Apply (Prim Card_Attack) (Const i)) (Const j)
cAttack [i, j, n] = Apply (Apply (Apply (Prim Card_Attack) (Const i)) (Const j)) (Const n)
cHelp [i, j] = Apply (Apply (Prim Card_Help) (Const i)) (Const j)
cHelp [i, j, n] = Apply (Apply (Apply (Prim Card_Help) (Const i)) (Const j)) (Const n)
cCopy i = Apply (Prim Card_Copy) (Const i)
cRevive i = Apply (Prim Card_Revive) (Const i)
cZombie i x = Apply (Apply (Prim Card_Zombie) (Const i)) x
test1 = cAttack [9, 8, 4000]
storeInt :: Int -> Int -> [Move]
storeInt pos = _store where
_store :: Int -> [Move]
_store 0 = [MoveLeft Card_Zero pos, MoveRight pos Card_Zero]
_store n = if (n `mod` 2 == 0) then _store (n `div` 2) ++ [MoveLeft Card_Dbl pos] else _store (n-1) ++ [MoveLeft Card_Succ pos]
command (Apply f x) = Apply (Apply (Prim Card_S) (Apply (Prim Card_K) f)) (Apply (Prim Card_K) x)
callresult t = cS [t, cI]
loop :: Term -> [Move]
loop cmd = store 0 (cS [cmd, callresult $ Prim Card_Get]) ++ c1 where
c1 = copyTo 1 0 ++ (MoveRight 0 Card_Zero):c1
copyTo :: Int -> Int -> [Move]
copyTo src dst = if (src == dst) then [] else storeInt dst src ++ [MoveLeft Card_Get dst]
store :: Int -> Term -> [Move]
store pos (Const n) = storeInt pos n
store pos (Apply (Prim c) t) = store pos t ++ [MoveLeft c pos]
store pos (Apply (Const 0) t) = store pos t ++ [MoveLeft Card_Zero pos]
store pos (Apply t (Prim c)) = store pos t ++ [MoveRight pos c]
store pos (Apply t (Const 0)) = store pos t ++ [MoveRight pos Card_Zero]
store pos (Prim c) = [MoveLeft Card_Zero pos, MoveRight pos c]
store pos (Seq a b) = store pos (Apply (Apply (Apply (Prim Card_S) a) b) (Prim Card_Zero))
store pos (Apply a b) = if (pos == 0) then store 1 (Apply a b) ++ copyTo 1 0 else store pos a ++ store (pos+1) b ++ copyTo (pos+1) 0 ++ [MoveLeft Card_K pos, MoveLeft Card_S pos, MoveRight pos Card_Get, MoveRight pos Card_Zero]
printMove :: Move -> IO ()
printMove (MoveLeft c pos) = putStr ("1\n" ++ show c ++ "\n" ++ show pos ++ "\n") >> hFlush stdout
printMove (MoveRight pos c) = putStr ("2\n" ++ show pos ++ "\n" ++ show c ++ "\n") >> hFlush stdout
main = (mapM_ printMove $ loop (Prim Card_Dec)) >> mapM_ (const getLine) [0..]