diff options
Diffstat (limited to 'app')
| -rw-r--r-- | app/Builtins.hs | 49 |
1 files changed, 42 insertions, 7 deletions
diff --git a/app/Builtins.hs b/app/Builtins.hs index b81d298..64838bb 100644 --- a/app/Builtins.hs +++ b/app/Builtins.hs @@ -16,7 +16,7 @@ import Control.Monad.Trans.State.Lazy (get, gets, modify) import Data.Functor.Identity (runIdentity) import Data.List (intercalate) import qualified Data.Map as M -import Env (PrlgEnv(..), findStruct) +import Env (PrlgEnv(..), findAtom, findStruct) import qualified IR import Interpreter (backtrack) import qualified Operators as O @@ -49,6 +49,13 @@ printLocals = do promptRetry :: BuiltinFn promptRetry = do + last <- gets (null . cho) + if last + then return Nothing + else promptRetry' + +promptRetry' :: BuiltinFn +promptRetry' = do x <- lift $ getInputChar "? " case x of Just ';' -> backtrack @@ -74,11 +81,26 @@ assertFact :: BuiltinFn assertFact = do scope <- gets (hvar . cur) heap <- gets (heap . cur) - case Co.compileGoal . Co.struct2goal . Co.squashVars <$> + case Co.compileGoal . Co.squashVars <$> Co.heapStructPrlgInt Nothing heap (fst $ scope M.! 0) of Just (U (Struct s):head) -> do addClause s $ head ++ [NoGoal] return Nothing + _ -> backtrack --TODO actually throw + +assertClause :: BuiltinFn +assertClause = do + scope <- gets (hvar . cur) + heap <- gets (heap . cur) + commaId <- findStruct "," 2 + cut <- findAtom "!" + case Co.squashVars . IR.CallI (IR.Id 0 0) <$> + traverse (Co.heapStructPrlgInt Nothing heap . fst . (M.!) scope) [0, 1] of + Just (IR.CallI (IR.Id 0 0) [hs, gs]) -> + let (U (Struct s):cs) = + Co.compileGoal hs ++ Co.seqGoals (Co.compileGoals commaId cut gs) + in do addClause s cs + return Nothing _ -> backtrack retractall :: BuiltinFn @@ -88,9 +110,10 @@ retractall = do {- adding the builtins -} addOp op = modify $ \s -> s {ops = op : ops s} -addClause struct head = +addClause struct code = do + lift . outputStrLn $ "Adding " ++ show struct ++ " with code " ++ show code modify $ \s -> - s {defs = M.alter (Just . maybe [head] (\hs -> head : hs)) struct $ defs s} + s {defs = M.alter (Just . maybe [code] (\hs -> code : hs)) struct $ defs s} addProcedure struct heads = modify $ \s -> s {defs = M.insert struct heads $ defs s} @@ -112,12 +135,24 @@ addPrelude = do {- clauses -} addOp $ O.xfy "," 1000 addOp $ O.xfx ":-" 1200 - addOp $ O.fx ":-" 1200 - addProc "assert" 1 [[U (LocalRef 0 0), Invoke (bi assertFact)]] + horn2 <- findStruct ":-" 2 + --addOp $ O.fx ":-" 1200 + addProc + "assert" + 1 + [ [ U (Struct horn2) + , U (LocalRef 0 0) + , U (LocalRef 1 0) + , Cut + , Invoke (bi assertClause) + ] + , [U (LocalRef 0 0), Invoke (bi assertFact)] + ] addProc "retractall" 1 [[U (LocalRef 0 0), Invoke (bi retractall)]] {- query tools -} addBi0 "print_locals" printLocals - addBi0 "prompt_retry" promptRetry + addBi0 "prompt_retry" promptRetry' + addBi0 "query" (printLocals >> promptRetry) {- IO -} addProc "write" 1 [[U (LocalRef 0 0), Invoke (bi write)]] addProc "writeln" 1 [[U (LocalRef 0 0), Invoke (bi writeln)]] |