{-# 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..]