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.
 
 

90 lines
3.7 KiB

  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