You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

Lambda.hs 3.5KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100
  1. {-# OPTIONS -XTypeSynonymInstances #-}
  2. module Lambda (
  3. Term (..),
  4. store, storeInt,
  5. command, callresult, loop,
  6. printMove
  7. ) where
  8. import Eval
  9. import System.IO
  10. import Text.ParserCombinators.ReadP
  11. import Data.Char
  12. import Control.Monad
  13. data Term = Const Int | Prim Card | Seq Term Term | Apply Term Term
  14. ptConst :: ReadP Term
  15. ptConst = readS_to_P reads >>= return . Const
  16. ptPrim = do
  17. c <- pCard
  18. return $ Prim c
  19. ptGroup = do
  20. char '('
  21. t <- ptTerm
  22. skipSpaces; char ')'
  23. return t
  24. ptEnd = eof <++ do
  25. c:_ <- look
  26. when (isAlphaNum c || c == ';' || c == '(') pfail
  27. ptApply f = do
  28. skipSpaces
  29. (ptEnd >> return f) <++
  30. (char ';' >> ptTerm >>= \g -> return $ Seq f g) <++
  31. (ptTerm1 >>= \x -> ptApply (Apply f x))
  32. ptTerm1 = skipSpaces >> (ptConst <++ ptPrim <++ ptGroup)
  33. ptTerm = ptTerm1 >>= ptApply
  34. instance Show Term where
  35. show (Const i) = show i
  36. show (Prim c) = show c
  37. show (Seq f g) = show f ++ ";" ++ show g
  38. {- show (Apply f (Const i)) = show f ++ " " ++ show i
  39. show (Apply f (Prim c)) = show f ++ " " ++ show c-}
  40. show (Apply f x) = show f ++ "(" ++ show x ++ ")"
  41. instance Read Term where
  42. readsPrec _ = readP_to_S ptTerm
  43. cI = Prim Card_I
  44. cGet n = Apply (Prim Card_Get) (Const n)
  45. cPut = Prim Card_Put
  46. cS [f, g] = Apply (Apply (Prim Card_S) f) g
  47. cS [f, g, x] = Apply (Apply (Apply (Prim Card_S) f) g) x
  48. cK x = Apply (Prim Card_K) x
  49. cInc i = Apply (Prim Card_Inc) (Const i)
  50. cDec i = Apply (Prim Card_Dec) (Const i)
  51. cAttack [i, j] = Apply (Apply (Prim Card_Attack) (Const i)) (Const j)
  52. cAttack [i, j, n] = Apply (Apply (Apply (Prim Card_Attack) (Const i)) (Const j)) (Const n)
  53. cHelp [i, j] = Apply (Apply (Prim Card_Help) (Const i)) (Const j)
  54. cHelp [i, j, n] = Apply (Apply (Apply (Prim Card_Help) (Const i)) (Const j)) (Const n)
  55. cCopy i = Apply (Prim Card_Copy) (Const i)
  56. cRevive i = Apply (Prim Card_Revive) (Const i)
  57. cZombie i x = Apply (Apply (Prim Card_Zombie) (Const i)) x
  58. test1 = cAttack [9, 8, 4000]
  59. storeInt :: Int -> Int -> [Move]
  60. storeInt pos = _store where
  61. _store :: Int -> [Move]
  62. _store 0 = [MoveLeft Card_Zero pos, MoveRight pos Card_Zero]
  63. _store n = if (n `mod` 2 == 0) then _store (n `div` 2) ++ [MoveLeft Card_Dbl pos] else _store (n-1) ++ [MoveLeft Card_Succ pos]
  64. command (Apply f x) = Apply (Apply (Prim Card_S) (Apply (Prim Card_K) f)) (Apply (Prim Card_K) x)
  65. callresult t = cS [t, cI]
  66. loop :: Term -> [Move]
  67. loop cmd = store 0 (cS [cmd, callresult $ Prim Card_Get]) ++ c1 where
  68. c1 = copyTo 1 0 ++ (MoveRight 0 Card_Zero):c1
  69. copyTo :: Int -> Int -> [Move]
  70. copyTo src dst = if (src == dst) then [] else storeInt dst src ++ [MoveLeft Card_Get dst]
  71. store :: Int -> Term -> [Move]
  72. store pos (Const n) = storeInt pos n
  73. store pos (Apply (Prim c) t) = store pos t ++ [MoveLeft c pos]
  74. store pos (Apply (Const 0) t) = store pos t ++ [MoveLeft Card_Zero pos]
  75. store pos (Apply t (Prim c)) = store pos t ++ [MoveRight pos c]
  76. store pos (Apply t (Const 0)) = store pos t ++ [MoveRight pos Card_Zero]
  77. store pos (Prim c) = [MoveLeft Card_Zero pos, MoveRight pos c]
  78. store pos (Seq a b) = store pos (Apply (Apply (Apply (Prim Card_S) a) b) (Prim Card_Zero))
  79. 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]
  80. printMove :: Move -> IO ()
  81. printMove (MoveLeft c pos) = putStr ("1\n" ++ show c ++ "\n" ++ show pos ++ "\n") >> hFlush stdout
  82. printMove (MoveRight pos c) = putStr ("2\n" ++ show pos ++ "\n" ++ show c ++ "\n") >> hFlush stdout
  83. main = (mapM_ printMove $ loop (Prim Card_Dec)) >> mapM_ (const getLine) [0..]