From 3eb6125609245c6588df2cacc3102b8e78093ea5 Mon Sep 17 00:00:00 2001
From: Mirek Kratochvil <exa.exa@gmail.com>
Date: Sat, 18 Feb 2023 22:50:38 +0100
Subject: [PATCH] expand like a prohuman

---
 app/Builtins.hs | 43 ++++++++++++++++++++++++++++++++++++++++---
 app/Load.hs     |  4 ++--
 2 files changed, 42 insertions(+), 5 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
diff --git a/app/Load.hs b/app/Load.hs
index b1ad0a5..23b92fe 100644
--- a/app/Load.hs
+++ b/app/Load.hs
@@ -60,9 +60,9 @@ expansion noexpand expander output x = do
              ]
       else noexpand o x
 
-queryExpansion = expansion (\_ -> id) "query_expansion" "call"
+queryExpansion = expansion (\_ -> id) "expand_query" "call"
 
-loadExpansion = expansion (\o x -> IR.CallI o [x]) "load_expansion" "assert"
+loadExpansion = expansion (\o x -> IR.CallI o [x]) "expand_load" "assert"
 
 processInput fn queryMode input = do
   asts <- except $ tokenize fn input >>= parse fn