# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1474892846 0
# Node ID 167ffd6a7a6a4f8c486a1d7779223e1ea525975c
# Parent  39b13193bce2ad6632829384539c6d64e737f76c
Lisp grounder, work-in-progress

diff -r 39b13193bce2 -r 167ffd6a7a6a gdl/buttons.gdl
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gdl/buttons.gdl	Mon Sep 26 12:27:26 2016 +0000
@@ -0,0 +1,85 @@
+(role robot)
+(init (off p))
+(init (off q))
+(init (off r))
+(init (step 1))
+(<= (next (on p))
+    (does robot a)
+    (true (off p)))
+(<= (next (on q))
+    (does robot a)
+    (true (on q)))
+(<= (next (on r))
+    (does robot a)
+    (true (on r)))
+(<= (next (off p))
+    (does robot a)
+    (true (on p)))
+(<= (next (off q))
+    (does robot a)
+    (true (off q)))
+(<= (next (off r))
+    (does robot a)
+    (true (off r)))
+(<= (next (on p))
+    (does robot b)
+    (true (on q)))
+(<= (next (on q))
+    (does robot b)
+    (true (on p)))
+(<= (next (on r))
+    (does robot b)
+    (true (on r)))
+(<= (next (off p))
+    (does robot b)
+    (true (off q)))
+(<= (next (off q))
+    (does robot b)
+    (true (off p)))
+(<= (next (off r))
+    (does robot b)
+    (true (off r)))
+(<= (next (on p))
+    (does robot c)
+    (true (on p)))
+(<= (next (on q))
+    (does robot c)
+    (true (on r)))
+(<= (next (on r))
+    (does robot c)
+    (true (on q)))
+(<= (next (off p))
+    (does robot c)
+    (true (off p)))
+(<= (next (off q))
+    (does robot c)
+    (true (off r)))
+(<= (next (off r))
+    (does robot c)
+    (true (off q)))
+(<= (next (step ?y))
+    (true (step ?x))
+    (succ ?x ?y))
+(succ 1 2)
+(succ 2 3)
+(succ 3 4)
+(succ 4 5)
+(succ 5 6)
+(succ 6 7)
+(legal robot a)
+(legal robot b)
+(legal robot c)
+(<= (goal robot 100)
+    (true (on p))
+    (true (on q))
+    (true (on r)))
+(<= (goal robot 0) (or
+    (not (true (on p)))
+    (not (true (on q)))
+    (not (true (on r)))))
+(<= terminal
+    (true (step 7)))
+(<= terminal
+    (true (on p))
+    (true (on q))
+    (true (on r)))
diff -r 39b13193bce2 -r 167ffd6a7a6a package.lisp
--- a/package.lisp	Sat Sep 24 15:56:44 2016 +0000
+++ b/package.lisp	Mon Sep 26 12:27:26 2016 +0000
@@ -1,3 +1,16 @@
+(defpackage #:scully.gdl
+  (:use
+    #:cl
+    #:losh
+    #:iterate
+    #:cl-arrows
+    #:temperance
+    #:scully.quickutils)
+  (:export
+    #:read-gdl
+    #:load-rules
+    ))
+
 (defpackage #:scully.reasoners.prolog
   (:use
     #:cl
@@ -18,6 +31,18 @@
     #:roles
     ))
 
+(defpackage #:scully.grounders.prolog
+  (:use
+    #:cl
+    #:losh
+    #:iterate
+    #:trivia
+    #:cl-arrows
+    #:temperance
+    #:scully.quickutils)
+  (:export
+    ))
+
 (defpackage #:scully.players.random
   (:use
     #:cl
diff -r 39b13193bce2 -r 167ffd6a7a6a scully.asd
--- a/scully.asd	Sat Sep 24 15:56:44 2016 +0000
+++ b/scully.asd	Mon Sep 26 12:27:26 2016 +0000
@@ -11,6 +11,7 @@
                #:losh
                #:temperance
                #:hunchentoot
+               #:trivia
                #:cl-arrows
                #:cl-ggp)
 
@@ -20,7 +21,10 @@
                              (:file "quickutils")))
                (:file "package")
                (:module "src" :serial t
-                :components ((:module "reasoners" :serial t
+                :components ((:file "gdl")
+                             (:module "reasoners" :serial t
+                              :components ((:file "prolog")))
+                             (:module "grounders" :serial t
                               :components ((:file "prolog")))
                              (:module "players" :serial t
                               :components ((:file "random")
diff -r 39b13193bce2 -r 167ffd6a7a6a src/gdl.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/gdl.lisp	Mon Sep 26 12:27:26 2016 +0000
@@ -0,0 +1,19 @@
+(in-package #:scully.gdl)
+
+(defun read-gdl (filename)
+  (let ((*package* (find-package :ggp-rules)))
+    (with-open-file (stream filename)
+      (loop
+        :with done = (gensym)
+        :for form = (read stream nil done)
+        :while (not (eq form done))
+        :collect form))))
+
+(defun load-rules (database rules)
+  (push-logic-frame-with database
+    (mapc (lambda (rule)
+            (if (and (consp rule)
+                     (eq (car rule) 'ggp-rules::<=))
+              (apply #'invoke-rule database (cdr rule))
+              (invoke-fact database rule)))
+          rules)))
diff -r 39b13193bce2 -r 167ffd6a7a6a src/grounders/prolog.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/grounders/prolog.lisp	Mon Sep 26 12:27:26 2016 +0000
@@ -0,0 +1,181 @@
+(in-package #:scully.grounders.prolog)
+
+
+;;;; Utils
+(defun fixed-point (function data &key (test 'eql))
+  "Find the fixed point of `function`, starting with `data`."
+  (let ((next (funcall function data)))
+    (if (funcall test data next)
+      data
+      (fixed-point function next :test test))))
+
+(defun gensyms (n prefix)
+  (iterate (repeat n) (collect (gensym prefix))))
+
+
+;;;; Sanitization
+(defun clause-is-p (clause functor-name)
+  (and (consp clause)
+       (eql (first clause) functor-name)))
+
+(defun clause-is-not-p (clause)
+  (clause-is-p clause 'ggp-rules::not))
+
+(defun clause-is-distinct-p (clause)
+  (clause-is-p clause 'ggp-rules::distinct))
+
+(defun clause-is-and-p (clause)
+  (clause-is-p clause 'ggp-rules::and))
+
+(defun clause-is-or-p (clause)
+  (clause-is-p clause 'ggp-rules::or))
+
+
+(defun split-ors (rule)
+  (labels ((split (body)
+             ;; take the body of a clause and return a list of the bodies that
+             ;; result after splitting up any `(or ...)`s inside it.
+             (match body
+               (nil (list nil))
+
+               ((list* (list* 'ggp-rules::or args) remaining)
+                (mapcan (lambda (arg)
+                          (mapcar (curry #'cons arg)
+                                  (split remaining)))
+                        args))
+
+               ((list* other remaining)
+                (mapcar (curry #'cons other) (split remaining))))))
+    (destructuring-bind (head . body) rule
+      (mapcar (curry #'cons head) (split body)))))
+
+(defun strip-ands (rule)
+  (labels ((flatten-ands (body)
+             (match body
+               (nil nil)
+               ((list* first-clause remaining)
+                (append (if (clause-is-and-p first-clause)
+                          (flatten-ands (rest first-clause))
+                          (list first-clause))
+                        (flatten-ands remaining))))))
+    (destructuring-bind (head . body) rule
+      (cons head (flatten-ands body)))))
+
+(defun strip-nots (rule)
+  (destructuring-bind (head . body) rule
+    (cons head (remove-if #'clause-is-not-p body))))
+
+(defun strip-distincts (rule)
+  (destructuring-bind (head . body) rule
+    (cons head (remove-if #'clause-is-distinct-p body))))
+
+
+(defun sanitize-rule (rule)
+  (match rule
+    ((list* 'ggp-rules::<= contents)
+     (->> contents
+       split-ors
+       (mapcar #'strip-ands)
+       (mapcar #'strip-nots)
+       (mapcar #'strip-distincts)
+       (mapcar (curry #'cons 'ggp-rules::<=))))
+    (fact (list fact))))
+
+(defun sanitize-rules (rules)
+  (mapcan #'sanitize-rule rules))
+
+
+;;;; Fluents
+(defun find-initial-state (database)
+  (query-map database
+             (lambda (result)
+               `(ggp-rules::true ,(getf result '?what)))
+             (ggp-rules::init ?what)))
+
+(defun find-trues (database)
+  (query-map database
+             (lambda (result)
+               `(ggp-rules::true ,(getf result '?what)))
+             (ggp-rules::next ?what)))
+
+(defun find-moves (database)
+  (query-map database
+             (lambda (result)
+               `(ggp-rules::does
+                 ,(getf result '?role)
+                 ,(getf result '?move)))
+             (ggp-rules::legal ?role ?move)))
+
+(defun push-fluents (database fluents)
+  (push-logic-frame-with database
+    (map nil (curry #'invoke-fact database) fluents)))
+
+(defun pop-fluents (database)
+  (pop-logic-frame database))
+
+(defun find-more-fluents (database fluents)
+  (push-fluents database fluents)
+  (prog1
+      (-> fluents
+        (union (find-moves database) :test #'equal)
+        (union (find-trues database) :test #'equal)) 
+    (pop-fluents database)))
+
+(defun ground-fluents (rules)
+  (let ((database (make-database)))
+    (scully.gdl:load-rules database rules)
+    (fixed-point (curry #'find-more-fluents database)
+                 (find-initial-state database)
+                 :test (rcurry #'set-equal :test #'equal))))
+
+
+;;;; Axioms
+(defun find-functor (rule)
+  (ematch rule
+    ((list* 'ggp-rules::<= (list* functor arguments) _)
+     (cons functor (length arguments)))
+
+    ((list* 'ggp-rules::<= bare-functor _)
+     (cons bare-functor 0))
+
+    ((list* functor arguments)
+     (cons functor (length arguments)))))
+
+(defun find-axioms (rules)
+  (-<> rules
+    (mapcar #'find-functor <>)
+    (remove-duplicates <> :test #'equal)))
+
+(defun ground-single-axiom (database functor arity)
+  (let ((vars (gensyms arity "?")))
+    (remove-duplicates
+      (invoke-query-map database
+                        (lambda (result)
+                          (if (zerop arity)
+                            functor
+                            `(,functor ,@(mapcar (curry #'getf result) vars))))
+                        `(,functor ,@vars))
+      :test #'equal)))
+
+(defun find-all-axioms (database functors)
+  (iterate (for (functor . arity) :in functors)
+           (unioning (ground-single-axiom database functor arity)
+                     :test #'equal)))
+
+(defun ground-axioms (rules grounded-fluents)
+  (let ((database (make-database)))
+    (scully.gdl:load-rules database rules)
+    (push-fluents database grounded-fluents)
+    (find-all-axioms database (find-axioms rules))))
+
+
+;;;; API
+(defun ground-rules (rules)
+  (let* ((rules (sanitize-rules rules))
+         (fluents (ground-fluents rules))
+         (axioms (ground-axioms rules fluents)))
+    fluents
+    axioms))
+
+
+; (map nil #'print (ground-rules (scully.gdl:read-gdl "gdl/buttons.gdl")))
diff -r 39b13193bce2 -r 167ffd6a7a6a src/reasoners/prolog.lisp
--- a/src/reasoners/prolog.lisp	Sat Sep 24 15:56:44 2016 +0000
+++ b/src/reasoners/prolog.lisp	Mon Sep 26 12:27:26 2016 +0000
@@ -150,14 +150,8 @@
 
 ;;;; API ----------------------------------------------------------------------
 (defun load-rules (reasoner rules)
-  (let ((db (pr-database reasoner)))
-    (push-logic-frame-with db
-      (mapc (lambda (rule)
-              (if (and (consp rule)
-                       (eq (car rule) 'ggp-rules::<=))
-                (apply #'invoke-rule db (cdr rule))
-                (invoke-fact db rule)))
-            (clean-gdl rules)))))
+  (scully.gdl:load-rules (pr-database reasoner)
+                         (clean-gdl rules)))
 
 (defun initial-state (reasoner)
   (normalize-state