expand like a prohuman

1 files changed, 40 insertions, 3 deletions

diff --git a/app/Builtins.hs b/app/Builtins.hs
index b5993a2..2de3f89 100644
--- a/app/Builtins.hs
+++ b/app/Builtins.hs
@@ -231,8 +231,8 @@ var = do
     Just (FreeRef _) -> continue
     _ -> backtrack
 
-same_term :: InterpFn
-same_term = do
+sameTerm :: InterpFn
+sameTerm = do
   heap <- gets (heap . cur)
   scope <- gets (hvar . cur)
   case map (fmap (derefHeap heap) . (scope M.!?)) [0, 1] of
@@ -240,6 +240,18 @@ same_term = do
       | a == b -> continue
     _ -> backtrack
 
+currentPredicate :: InterpFn
+currentPredicate =
+  withArgs [0] $ \[arg] -> do
+    heap <- gets (heap . cur)
+    ds <- gets defs
+    case derefHeap heap arg of
+      BoundRef _ (Struct s) ->
+        if s `M.member` ds
+          then continue
+          else backtrack
+      _ -> prlgError "not a predicate"
+
 {- operator management -}
 op :: InterpFn
 op =
@@ -386,7 +398,8 @@ addPrelude = do
   {- terms -}
   addBi struct "struct" 3
   addBi var "var" 1
-  addBi same_term "same_term" 2
+  addBi sameTerm "same_term" 2
+  addBi currentPredicate "current_predicate" 1
   {- code loading -}
   addBi (load False) "load" 1
   addBi (load True) "source" 1
@@ -398,6 +411,30 @@ addPrelude = do
   {- macroenvironment -}
   addBi stashExpansions "stash_expansions" 0
   addBi popExpansions "pop_expansions" 0
+  let expandCode q = do
+        s <- findStruct (q ++ "_expansion") 2
+        cp <- findStruct "current_predicate" 1
+        addProc
+          [ [ U (LocalRef 0)
+            , U (LocalRef 1)
+            , Goal -- current_predicate(expand_something(_,_)),
+            , U (Struct cp)
+            , U (Struct s)
+            , U VoidRef
+            , U VoidRef
+            , Call -- no cut!
+            , Goal -- expand_something(Arg1, Arg2).
+            , U (Struct s)
+            , U (LocalRef 0)
+            , U (LocalRef 1)
+            , LastCall
+            ]
+          , [U (LocalRef 0), U (LocalRef 0), NoGoal]
+          ]
+          ("expand_" ++ q)
+          2
+  expandCode "load"
+  expandCode "query"
   {- query tools -}
   addBi printLocals "print_locals" 0
   addBi promptRetry' "prompt_retry" 0