101 lines
3.5 KiB
Haskell
101 lines
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..]
|