prolog: copy_term/2 + functor/3 + arg/3, 14 tests; =.. deferred

lib/prolog/runtime.sx

@@ -470,6 +470,90 @@
               ((rl (pl-mk-list-term sorted (pl-nil-term))))
               (pl-solve-eq! third-rt rl trail k))))))))
 
+(define
+  pl-solve-eq2!
+  (fn
+    (a1 b1 a2 b2 trail k)
+    (let
+      ((mark (pl-trail-mark trail)))
+      (cond
+        ((and (pl-unify! a1 b1 trail) (pl-unify! a2 b2 trail))
+          (let
+            ((r (k)))
+            (cond
+              (r true)
+              (true (begin (pl-trail-undo-to! trail mark) false)))))
+        (true (begin (pl-trail-undo-to! trail mark) false))))))
+
+(define
+  pl-make-fresh-args
+  (fn
+    (n)
+    (cond
+      ((<= n 0) (list))
+      (true (cons (pl-mk-rt-var "_") (pl-make-fresh-args (- n 1)))))))
+
+(define
+  pl-solve-functor-construct!
+  (fn
+    (term-rt name-rt arity-rt trail k)
+    (let
+      ((wn (pl-walk name-rt)) (wa (pl-walk arity-rt)))
+      (cond
+        ((and (pl-num? wa) (= (pl-num-val wa) 0))
+          (cond
+            ((or (pl-atom? wn) (pl-num? wn))
+              (pl-solve-eq! term-rt wn trail k))
+            (true false)))
+        ((and (pl-num? wa) (> (pl-num-val wa) 0) (pl-atom? wn))
+          (let
+            ((new-args (pl-make-fresh-args (pl-num-val wa))))
+            (pl-solve-eq!
+              term-rt
+              (list "compound" (pl-atom-name wn) new-args)
+              trail
+              k)))
+        (true false)))))
+
+(define
+  pl-solve-functor!
+  (fn
+    (term-rt name-rt arity-rt trail k)
+    (let
+      ((wt (pl-walk term-rt)))
+      (cond
+        ((pl-var? wt)
+          (pl-solve-functor-construct! term-rt name-rt arity-rt trail k))
+        ((pl-atom? wt)
+          (pl-solve-eq2! name-rt wt arity-rt (list "num" 0) trail k))
+        ((pl-num? wt)
+          (pl-solve-eq2! name-rt wt arity-rt (list "num" 0) trail k))
+        ((pl-compound? wt)
+          (pl-solve-eq2!
+            name-rt
+            (list "atom" (pl-fun wt))
+            arity-rt
+            (list "num" (len (pl-args wt)))
+            trail
+            k))
+        (true false)))))
+
+(define
+  pl-solve-arg!
+  (fn
+    (n-rt term-rt arg-rt trail k)
+    (let
+      ((wn (pl-walk n-rt)) (wt (pl-walk term-rt)))
+      (cond
+        ((and (pl-num? wn) (pl-compound? wt))
+          (let
+            ((idx (pl-num-val wn)) (args (pl-args wt)))
+            (cond
+              ((and (>= idx 1) (<= idx (len args)))
+                (pl-solve-eq! arg-rt (nth args (- idx 1)) trail k))
+              (true false))))
+        (true false)))))
+
 (define
   pl-retract-try-each
   (fn
@@ -622,6 +706,26 @@
             (nth (pl-args g) 2)
             trail
             k))
+        ((and (pl-compound? g) (= (pl-fun g) "copy_term") (= (len (pl-args g)) 2))
+          (pl-solve-eq!
+            (nth (pl-args g) 1)
+            (pl-deep-copy (first (pl-args g)) {})
+            trail
+            k))
+        ((and (pl-compound? g) (= (pl-fun g) "functor") (= (len (pl-args g)) 3))
+          (pl-solve-functor!
+            (first (pl-args g))
+            (nth (pl-args g) 1)
+            (nth (pl-args g) 2)
+            trail
+            k))
+        ((and (pl-compound? g) (= (pl-fun g) "arg") (= (len (pl-args g)) 3))
+          (pl-solve-arg!
+            (first (pl-args g))
+            (nth (pl-args g) 1)
+            (nth (pl-args g) 2)
+            trail
+            k))
         (true (pl-solve-user! db g trail cut-box k))))))
 
 (define