diff options
Diffstat (limited to 'app/Interpreter.hs')
| -rw-r--r-- | app/Interpreter.hs | 21 |
1 files changed, 17 insertions, 4 deletions
diff --git a/app/Interpreter.hs b/app/Interpreter.hs index 5d1e2ab..2ad0118 100644 --- a/app/Interpreter.hs +++ b/app/Interpreter.hs @@ -35,6 +35,7 @@ prove g = do , _heap = emptyHeap , _stk = [] , _cut = [] + , _hcut = [] } cho .= [] loop @@ -54,10 +55,14 @@ proveStep = do import Control.Monad.Trans.Class (lift) import System.Console.Haskeline g <- use (cur . gol) + cho <- use cho + cut <- use (cur . cut) lift $ do outputStrLn $ "STEP (unis="++show u++")" outputStrLn $ "head = "++ show h outputStrLn $ "goal = "++ show g + outputStrLn $ "cut = " ++ show cut + outputStrLn $ "cho = " ++ show cho -} case (u, h) of (0, []) -> goalStep @@ -92,7 +97,7 @@ headStep h = do case (h, g) of ([Done], _) -> succeedHead (Cut:_, _) -> cutHead - (Invoke (Builtin bf):_, _) -> advanceHead >> bf + (Invoke (Builtin bf):_, _) -> cur . hed .= [Done] >> bf (_, [Done]) -> tailCall (_, [Cut, Done]) -> tailCut (_, _) -> pushCall @@ -134,7 +139,9 @@ retCut = do doCut cur . retcut .= False -cutHead = doCut >> advanceHead +cutHead = do + use (cur . hcut) >>= assign cho + advanceHead cutGoal = doCut >> advance @@ -147,7 +154,8 @@ openGoal fn = do cur . hvar .= emptyScope cur . unis .= arity fn cc <- use cur - let (newcur:newcho) = [cc & hed .~ h | h <- hs] + oldcho <- use cho + let (newcur:newcho) = [cc & hcut .~ oldcho & hed .~ h | h <- hs] cur .= newcur cho %= (newcho ++) continue @@ -162,12 +170,15 @@ pushCall = do ngol <- use (cur . hed) ngvar <- use (cur . hvar) scut <- use (cur . cut) + ncut <- use (cur . hcut) sretcut <- use (cur . retcut) cur . stk %= ((sgol, sgvar, scut, sretcut) :) cur . gol .= ngol cur . gvar .= ngvar + cur . cut .= ncut cur . hed .= [] cur . hvar .= emptyScope + cur . hcut .= [] cur . retcut .= False continue @@ -179,6 +190,7 @@ tailCall = do cur . gvar .= ngvar cur . hed .= [] cur . hvar .= emptyScope + cur . hcut .= [] continue tailCut :: InterpFn @@ -189,8 +201,9 @@ tailCut = do succeedHead :: InterpFn succeedHead = do - cur . hvar .= emptyScope cur . hed .= [] + cur . hvar .= emptyScope + cur . hcut .= [] continue succeedGoal :: InterpFn |