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.

89 lines
3.7 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
  1. module GoalTransform (
  2. Goal (..),
  3. moveGoal,
  4. evalMoves,
  5. subgoals,
  6. satGoal,
  7. satGoals,
  8. ) where
  9. import Eval
  10. import Lambda
  11. import System.IO
  12. import qualified Data.Array.IO as A
  13. type Goal = (Maybe Int, Term)
  14. type Goals = [(Int, Term)]
  15. applyMove :: Term -> Move -> Term
  16. applyMove t (MoveLeft Card_Zero _) = Prim Card_I
  17. applyMove t (MoveLeft Card_I _) = t
  18. applyMove (Const n) (MoveLeft Card_Succ _) = Const (n+1)
  19. applyMove (Const n) (MoveLeft Card_Dbl _) = Const (n*2)
  20. applyMove (Prim Card_I) (MoveRight _ Card_Zero) = Const 0
  21. applyMove (Prim Card_I) (MoveRight _ c) = Prim c
  22. applyMove (Prim Card_Succ) (MoveRight _ Card_Zero) = Const 1
  23. applyMove (Prim Card_Dbl) (MoveRight _ Card_Zero) = Const 0
  24. applyMove t (MoveLeft c _) = Apply (Prim c) t
  25. applyMove t (MoveRight _ c) = Apply t (Prim c)
  26. evalMoves :: Goals -> Int -> Maybe Term -> [Move] -> [(Goals, Move)]
  27. evalMoves current pos = _eval where
  28. _eval _ [] = []
  29. _eval Nothing moves = ((pos, Prim Card_I):current, MoveLeft Card_Zero pos):_eval (Just $ Prim Card_I) moves
  30. _eval (Just t) (m:xm) = let t' = (applyMove t m) in ((pos, t'):current, m):_eval (Just t') xm
  31. copyTo :: Goals -> Int -> Int -> Term -> [(Goals, Move)]
  32. copyTo current src dst t = if (src == dst) then [] else evalMoves current dst Nothing (storeInt dst src) ++ [((dst, t):current,MoveLeft Card_Get dst)]
  33. _subgoals current pos (Const n) = evalMoves current pos Nothing (storeInt pos n)
  34. _subgoals current pos (Apply (Prim c) t) = let m = MoveLeft c pos in _subgoals current pos t ++ [((pos, applyMove t m):current, m)]
  35. _subgoals current pos (Apply (Const 0) t) = let m = MoveLeft Card_Zero pos in _subgoals current pos t ++ [((pos, applyMove t m):current, m)]
  36. _subgoals current pos (Apply t (Prim c)) = let m = MoveRight pos c in _subgoals current pos t ++ [((pos, applyMove t m):current, m)]
  37. _subgoals current pos (Apply t (Const 0)) = let m = MoveRight pos Card_Zero in _subgoals current pos t ++ [((pos, applyMove t m):current, m)]
  38. _subgoals current pos (Prim c) = evalMoves current pos Nothing [MoveRight pos c]
  39. _subgoals current 0 (Apply a b) = _subgoals current 1 (Apply a b) ++ copyTo ((1, Apply a b):current) 1 0 (Apply a b)
  40. _subgoals current pos (Apply a b) = _subgoals current pos a ++ _subgoals ((pos,a):current) (pos+1) b ++ copyTo ((pos,a):(pos+1, b):current) (pos+1) 0 b ++ evalMoves ((0, b):current) pos (Just a) [MoveLeft Card_K pos, MoveLeft Card_S pos, MoveRight pos Card_Get] ++ [((pos, Apply a b):current, MoveRight pos Card_Zero)]
  41. subgoals pos t = reverse $ _subgoals [] pos t
  42. termEqVal :: Term -> Value -> Bool
  43. termEqVal (Const a) (ValInt b) = (a == b)
  44. termEqVal (Prim Card_Zero) (ValInt 0) = True
  45. termEqVal t (ValFunction s _) = (show t) == s
  46. termEqVal _ _ = False
  47. satGoal :: (Int, Term) -> Turn Bool
  48. satGoal (pos, t) = do
  49. game <- getGame
  50. (val, vit) <- liftIO $ A.readArray (fields $ proponent game) pos
  51. return (vit > 0 && termEqVal t val)
  52. satGoals :: Goals -> Turn Bool
  53. satGoals [] = return True
  54. satGoals (g:xg) = satGoal g >>= \r -> if (r) then satGoals xg else return False
  55. _pickMove :: [(Goals, Move)] -> Turn (Maybe Move)
  56. _pickMove [] = return Nothing
  57. _pickMove ((g,m):xs) = do
  58. found <- satGoals g
  59. if (found) then return Nothing else do
  60. r <- _pickMove xs
  61. case r of Nothing -> return $ Just m; _ -> return r
  62. pickMove :: [(Goals, Move)] -> Turn (Move, Bool)
  63. pickMove l@((_,m):_) = do
  64. r <- _pickMove l
  65. case r of Nothing -> return (m, True); Just m -> return (m, False)
  66. moveGoal :: Goal -> Turn Move
  67. moveGoal (Nothing, t) = moveGoal (Just 0, t)
  68. moveGoal (Just pos, t) = do
  69. let subs = subgoals pos t
  70. (move, finished) <- pickMove subs
  71. liftIO $ hPutStrLn stderr $ "Trying to reach Goal " ++ show (pos, t)
  72. liftIO $ hPutStrLn stderr $ "Next step: " ++ show move
  73. return move