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.

100 lines
3.5 KiB

10 years ago
10 years ago
10 years ago
10 years ago
10 years ago
10 years ago
10 years ago
10 years ago
10 years ago
10 years ago
10 years ago
10 years ago
10 years ago
10 years ago
  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..]