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
89 lines
3.7 KiB
|
|
module GoalTransform ( |
|
Goal (..), |
|
moveGoal, |
|
evalMoves, |
|
subgoals, |
|
satGoal, |
|
satGoals, |
|
) where |
|
|
|
import Eval |
|
import Lambda |
|
|
|
import System.IO |
|
import qualified Data.Array.IO as A |
|
|
|
type Goal = (Maybe Int, Term) |
|
|
|
type Goals = [(Int, Term)] |
|
|
|
applyMove :: Term -> Move -> Term |
|
applyMove t (MoveLeft Card_Zero _) = Prim Card_I |
|
applyMove t (MoveLeft Card_I _) = t |
|
applyMove (Const n) (MoveLeft Card_Succ _) = Const (n+1) |
|
applyMove (Const n) (MoveLeft Card_Dbl _) = Const (n*2) |
|
applyMove (Prim Card_I) (MoveRight _ Card_Zero) = Const 0 |
|
applyMove (Prim Card_I) (MoveRight _ c) = Prim c |
|
applyMove (Prim Card_Succ) (MoveRight _ Card_Zero) = Const 1 |
|
applyMove (Prim Card_Dbl) (MoveRight _ Card_Zero) = Const 0 |
|
applyMove t (MoveLeft c _) = Apply (Prim c) t |
|
applyMove t (MoveRight _ c) = Apply t (Prim c) |
|
|
|
evalMoves :: Goals -> Int -> Maybe Term -> [Move] -> [(Goals, Move)] |
|
evalMoves current pos = _eval where |
|
_eval _ [] = [] |
|
_eval Nothing moves = ((pos, Prim Card_I):current, MoveLeft Card_Zero pos):_eval (Just $ Prim Card_I) moves |
|
_eval (Just t) (m:xm) = let t' = (applyMove t m) in ((pos, t'):current, m):_eval (Just t') xm |
|
|
|
copyTo :: Goals -> Int -> Int -> Term -> [(Goals, Move)] |
|
copyTo current src dst t = if (src == dst) then [] else evalMoves current dst Nothing (storeInt dst src) ++ [((dst, t):current,MoveLeft Card_Get dst)] |
|
|
|
_subgoals current pos (Const n) = evalMoves current pos Nothing (storeInt pos n) |
|
_subgoals current pos (Apply (Prim c) t) = let m = MoveLeft c pos in _subgoals current pos t ++ [((pos, applyMove t m):current, m)] |
|
_subgoals current pos (Apply (Const 0) t) = let m = MoveLeft Card_Zero pos in _subgoals current pos t ++ [((pos, applyMove t m):current, m)] |
|
_subgoals current pos (Apply t (Prim c)) = let m = MoveRight pos c in _subgoals current pos t ++ [((pos, applyMove t m):current, m)] |
|
_subgoals current pos (Apply t (Const 0)) = let m = MoveRight pos Card_Zero in _subgoals current pos t ++ [((pos, applyMove t m):current, m)] |
|
_subgoals current pos (Prim c) = evalMoves current pos Nothing [MoveRight pos c] |
|
_subgoals current 0 (Apply a b) = _subgoals current 1 (Apply a b) ++ copyTo ((1, Apply a b):current) 1 0 (Apply a b) |
|
_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)] |
|
|
|
subgoals pos t = reverse $ _subgoals [] pos t |
|
|
|
termEqVal :: Term -> Value -> Bool |
|
termEqVal (Const a) (ValInt b) = (a == b) |
|
termEqVal (Prim Card_Zero) (ValInt 0) = True |
|
termEqVal t (ValFunction s _) = (show t) == s |
|
termEqVal _ _ = False |
|
|
|
satGoal :: (Int, Term) -> Turn Bool |
|
satGoal (pos, t) = do |
|
game <- getGame |
|
(val, vit) <- liftIO $ A.readArray (fields $ proponent game) pos |
|
return (vit > 0 && termEqVal t val) |
|
|
|
satGoals :: Goals -> Turn Bool |
|
satGoals [] = return True |
|
satGoals (g:xg) = satGoal g >>= \r -> if (r) then satGoals xg else return False |
|
|
|
_pickMove :: [(Goals, Move)] -> Turn (Maybe Move) |
|
_pickMove [] = return Nothing |
|
_pickMove ((g,m):xs) = do |
|
found <- satGoals g |
|
if (found) then return Nothing else do |
|
r <- _pickMove xs |
|
case r of Nothing -> return $ Just m; _ -> return r |
|
|
|
pickMove :: [(Goals, Move)] -> Turn (Move, Bool) |
|
pickMove l@((_,m):_) = do |
|
r <- _pickMove l |
|
case r of Nothing -> return (m, True); Just m -> return (m, False) |
|
|
|
moveGoal :: Goal -> Turn Move |
|
moveGoal (Nothing, t) = moveGoal (Just 0, t) |
|
moveGoal (Just pos, t) = do |
|
let subs = subgoals pos t |
|
(move, finished) <- pickMove subs |
|
liftIO $ hPutStrLn stderr $ "Trying to reach Goal " ++ show (pos, t) |
|
liftIO $ hPutStrLn stderr $ "Next step: " ++ show move |
|
return move
|
|
|