# HG changeset patch # User Steve Losh # Date 1474980796 0 # Node ID db764ac2697b653310540d8b752e774a1c87344f # Parent b261c086fa4eeb6bef15a76dd6d2e41a6a91b682 Wrap up the fluxplayer based grounding diff -r b261c086fa4e -r db764ac2697b gdl/tictactoe.gdl --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gdl/tictactoe.gdl Tue Sep 27 12:53:16 2016 +0000 @@ -0,0 +1,135 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Tictactoe +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Roles +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (role xplayer) + (role oplayer) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Initial State +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (init (cell 1 1 b)) + (init (cell 1 2 b)) + (init (cell 1 3 b)) + (init (cell 2 1 b)) + (init (cell 2 2 b)) + (init (cell 2 3 b)) + (init (cell 3 1 b)) + (init (cell 3 2 b)) + (init (cell 3 3 b)) + (init (control xplayer)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Dynamic Components +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Cell + + (<= (next (cell ?m ?n x)) + (does xplayer (mark ?m ?n)) + (true (cell ?m ?n b))) + + (<= (next (cell ?m ?n o)) + (does oplayer (mark ?m ?n)) + (true (cell ?m ?n b))) + + (<= (next (cell ?m ?n ?w)) + (true (cell ?m ?n ?w)) + (distinct ?w b)) + + (<= (next (cell ?m ?n b)) + (does ?w (mark ?j ?k)) + (true (cell ?m ?n b)) + (or (distinct ?m ?j) (distinct ?n ?k))) + + (<= (next (control xplayer)) + (true (control oplayer))) + + (<= (next (control oplayer)) + (true (control xplayer))) + + + (<= (row ?m ?x) + (true (cell ?m 1 ?x)) + (true (cell ?m 2 ?x)) + (true (cell ?m 3 ?x))) + + (<= (column ?n ?x) + (true (cell 1 ?n ?x)) + (true (cell 2 ?n ?x)) + (true (cell 3 ?n ?x))) + + (<= (diagonal ?x) + (true (cell 1 1 ?x)) + (true (cell 2 2 ?x)) + (true (cell 3 3 ?x))) + + (<= (diagonal ?x) + (true (cell 1 3 ?x)) + (true (cell 2 2 ?x)) + (true (cell 3 1 ?x))) + + + (<= (line ?x) (row ?m ?x)) + (<= (line ?x) (column ?m ?x)) + (<= (line ?x) (diagonal ?x)) + + + (<= open + (true (cell ?m ?n b))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (<= (legal ?w (mark ?x ?y)) + (true (cell ?x ?y b)) + (true (control ?w))) + + (<= (legal xplayer noop) + (true (control oplayer))) + + (<= (legal oplayer noop) + (true (control xplayer))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (<= (goal xplayer 100) + (line x)) + + (<= (goal xplayer 50) + (not (line x)) + (not (line o)) + (not open)) + + (<= (goal xplayer 0) + (line o)) + + (<= (goal oplayer 100) + (line o)) + + (<= (goal oplayer 50) + (not (line x)) + (not (line o)) + (not open)) + + (<= (goal oplayer 0) + (line x)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (<= terminal + (line x)) + + (<= terminal + (line o)) + + (<= terminal + (not open)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff -r b261c086fa4e -r db764ac2697b package.lisp --- a/package.lisp Mon Sep 26 15:11:52 2016 +0000 +++ b/package.lisp Tue Sep 27 12:53:16 2016 +0000 @@ -36,7 +36,7 @@ #:cl #:losh #:iterate - #:trivia + #:optima #:cl-arrows #:temperance #:scully.quickutils) diff -r b261c086fa4e -r db764ac2697b scully.asd --- a/scully.asd Mon Sep 26 15:11:52 2016 +0000 +++ b/scully.asd Tue Sep 27 12:53:16 2016 +0000 @@ -11,7 +11,7 @@ #:losh #:temperance #:hunchentoot - #:trivia + #:optima #:smug #:cl-arrows #:cl-ggp) diff -r b261c086fa4e -r db764ac2697b src/grounders/fluxplayer.lisp --- a/src/grounders/fluxplayer.lisp Mon Sep 26 15:11:52 2016 +0000 +++ b/src/grounders/fluxplayer.lisp Tue Sep 27 12:53:16 2016 +0000 @@ -23,6 +23,7 @@ (.let* ((digits (.first (.map 'string (.digit radix))))) (.identity (parse-integer digits :radix radix)))) + (defun .eof () (.or (.not (.item)) (.fail))) @@ -53,11 +54,16 @@ (.identity (cons el rest))))) +(defun read-gdl-term (string) + (let ((*package* (find-package :ggp-rules))) + (read-from-string string))) + (defun .index-line () (.let* ((id (.positive-integer)) (_ (.whitespace)) (term (.line))) - (.identity (make-index-entry :id id :term (read-from-string term))))) + (.identity (make-index-entry :id id + :term (read-gdl-term term))))) (defun .rule-line () (.let* ((_ (.positive-integer)) ; type, not used here @@ -83,15 +89,32 @@ (.let* ((rules (.first (.map 'list (.rule-line)))) (_ (.delimiter-line)) (index (.first (.map 'list (.index-line)))) - (_ (.delimiter-line)) - ) - (.identity (list :rules rules :index index)))) + (_ (.delimiter-line))) + (.identity (list rules index)))) (defun parse-raw-grounded (raw) (values (parse (.grounded-gdl) raw))) +;;;; Rebuilding --------------------------------------------------------------- +(defun rebuild-rules (rule-entries index-entries) + (let ((index (make-hash-table))) + (iterate (for entry :in index-entries) + (setf (gethash (index-entry-id entry) index) + (index-entry-term entry))) + (flet ((get-rule (id) + (ensure-gethash id index (gensym)))) + (iterate + (for entry :in rule-entries) + (for rule = (get-rule (rule-id entry))) + (for pos = (mapcar #'get-rule (rule-positive entry))) + (for neg = (mapcar #'get-rule (rule-negative entry))) + (collect (if (or pos neg) + `(ggp-rules::<= ,rule ,@pos ,@neg) + (ensure-list rule))))))) + + ;;;; API ---------------------------------------------------------------------- (defun ground-raw (filename) (uiop/run-program:run-program @@ -100,7 +123,11 @@ :output :string)) (defun ground-gdl (filename) - (parse-raw-grounded (ground-raw filename))) + (->> filename + ground-raw + parse-raw-grounded + (apply #'rebuild-rules))) ; (ground-gdl "gdl/buttons.gdl") +; (ground-gdl "gdl/tictactoe.gdl") diff -r b261c086fa4e -r db764ac2697b vendor/make-quickutils.lisp --- a/vendor/make-quickutils.lisp Mon Sep 26 15:11:52 2016 +0000 +++ b/vendor/make-quickutils.lisp Tue Sep 27 12:53:16 2016 +0000 @@ -4,12 +4,14 @@ "quickutils.lisp" :utilities '( + :curry + :ensure-gethash + :ensure-list + :map-product :once-only - :with-gensyms - :map-product - :curry :rcurry :set-equal + :with-gensyms ) :package "SCULLY.QUICKUTILS") diff -r b261c086fa4e -r db764ac2697b vendor/quickutils.lisp --- a/vendor/quickutils.lisp Mon Sep 26 15:11:52 2016 +0000 +++ b/vendor/quickutils.lisp Tue Sep 27 12:53:16 2016 +0000 @@ -2,7 +2,7 @@ ;;;; See http://quickutil.org for details. ;;;; To regenerate: -;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:ONCE-ONLY :WITH-GENSYMS :MAP-PRODUCT :CURRY :RCURRY :SET-EQUAL) :ensure-package T :package "SCULLY.QUICKUTILS") +;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:CURRY :ENSURE-GETHASH :ENSURE-LIST :MAP-PRODUCT :ONCE-ONLY :RCURRY :SET-EQUAL :WITH-GENSYMS) :ensure-package T :package "SCULLY.QUICKUTILS") (eval-when (:compile-toplevel :load-toplevel :execute) (unless (find-package "SCULLY.QUICKUTILS") @@ -13,10 +13,11 @@ (in-package "SCULLY.QUICKUTILS") (when (boundp '*utilities*) - (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ONCE-ONLY - :STRING-DESIGNATOR :WITH-GENSYMS - :ENSURE-FUNCTION :CURRY :MAPPEND - :MAP-PRODUCT :RCURRY :SET-EQUAL)))) + (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION + :CURRY :ENSURE-GETHASH :ENSURE-LIST + :MAPPEND :MAP-PRODUCT :ONCE-ONLY + :RCURRY :SET-EQUAL :STRING-DESIGNATOR + :WITH-GENSYMS)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun make-gensym-list (length &optional (x "G")) "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`, @@ -25,6 +26,86 @@ (loop repeat length collect (gensym g)))) ) ; eval-when +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;; To propagate return type and allow the compiler to eliminate the IF when + ;;; it is known if the argument is function or not. + (declaim (inline ensure-function)) + + (declaim (ftype (function (t) (values function &optional)) + ensure-function)) + (defun ensure-function (function-designator) + "Returns the function designated by `function-designator`: +if `function-designator` is a function, it is returned, otherwise +it must be a function name and its `fdefinition` is returned." + (if (functionp function-designator) + function-designator + (fdefinition function-designator))) + ) ; eval-when + + (defun curry (function &rest arguments) + "Returns a function that applies `arguments` and the arguments +it is called with to `function`." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + ;; Using M-V-C we don't need to append the arguments. + (multiple-value-call fn (values-list arguments) (values-list more))))) + + (define-compiler-macro curry (function &rest arguments) + (let ((curries (make-gensym-list (length arguments) "CURRY")) + (fun (gensym "FUN"))) + `(let ((,fun (ensure-function ,function)) + ,@(mapcar #'list curries arguments)) + (declare (optimize (speed 3) (safety 1) (debug 1))) + (lambda (&rest more) + (apply ,fun ,@curries more))))) + + + (defmacro ensure-gethash (key hash-table &optional default) + "Like `gethash`, but if `key` is not found in the `hash-table` saves the `default` +under key before returning it. Secondary return value is true if key was +already in the table." + `(multiple-value-bind (value ok) (gethash ,key ,hash-table) + (if ok + (values value ok) + (values (setf (gethash ,key ,hash-table) ,default) nil)))) + + + (defun ensure-list (list) + "If `list` is a list, it is returned. Otherwise returns the list designated by `list`." + (if (listp list) + list + (list list))) + + + (defun mappend (function &rest lists) + "Applies `function` to respective element(s) of each `list`, appending all the +all the result list to a single list. `function` must return a list." + (loop for results in (apply #'mapcar function lists) + append results)) + + + (defun map-product (function list &rest more-lists) + "Returns a list containing the results of calling `function` with one argument +from `list`, and one from each of `more-lists` for each combination of arguments. +In other words, returns the product of `list` and `more-lists` using `function`. + +Example: + + (map-product 'list '(1 2) '(3 4) '(5 6)) + => ((1 3 5) (1 3 6) (1 4 5) (1 4 6) + (2 3 5) (2 3 6) (2 4 5) (2 4 6))" + (labels ((%map-product (f lists) + (let ((more (cdr lists)) + (one (car lists))) + (if (not more) + (mapcar f one) + (mappend (lambda (x) + (%map-product (curry f x) more)) + one))))) + (%map-product (ensure-function function) (cons list more-lists)))) + (defmacro once-only (specs &body forms) "Evaluates `forms` with symbols specified in `specs` rebound to temporary @@ -65,6 +146,29 @@ ,@forms))))) + (defun rcurry (function &rest arguments) + "Returns a function that applies the arguments it is called +with and `arguments` to `function`." + (declare (optimize (speed 3) (safety 1) (debug 1))) + (let ((fn (ensure-function function))) + (lambda (&rest more) + (declare (dynamic-extent more)) + (multiple-value-call fn (values-list more) (values-list arguments))))) + + + (defun set-equal (list1 list2 &key (test #'eql) (key nil keyp)) + "Returns true if every element of `list1` matches some element of `list2` and +every element of `list2` matches some element of `list1`. Otherwise returns false." + (let ((keylist1 (if keyp (mapcar key list1) list1)) + (keylist2 (if keyp (mapcar key list2) list2))) + (and (dolist (elt keylist1 t) + (or (member elt keylist2 :test test) + (return nil))) + (dolist (elt keylist2 t) + (or (member elt keylist1 :test test) + (return nil)))))) + + (deftype string-designator () "A string designator type. A string designator is either a string, a symbol, or a character." @@ -109,93 +213,7 @@ `(with-gensyms ,names ,@forms)) (eval-when (:compile-toplevel :load-toplevel :execute) - ;;; To propagate return type and allow the compiler to eliminate the IF when - ;;; it is known if the argument is function or not. - (declaim (inline ensure-function)) - - (declaim (ftype (function (t) (values function &optional)) - ensure-function)) - (defun ensure-function (function-designator) - "Returns the function designated by `function-designator`: -if `function-designator` is a function, it is returned, otherwise -it must be a function name and its `fdefinition` is returned." - (if (functionp function-designator) - function-designator - (fdefinition function-designator))) - ) ; eval-when - - (defun curry (function &rest arguments) - "Returns a function that applies `arguments` and the arguments -it is called with to `function`." - (declare (optimize (speed 3) (safety 1) (debug 1))) - (let ((fn (ensure-function function))) - (lambda (&rest more) - (declare (dynamic-extent more)) - ;; Using M-V-C we don't need to append the arguments. - (multiple-value-call fn (values-list arguments) (values-list more))))) - - (define-compiler-macro curry (function &rest arguments) - (let ((curries (make-gensym-list (length arguments) "CURRY")) - (fun (gensym "FUN"))) - `(let ((,fun (ensure-function ,function)) - ,@(mapcar #'list curries arguments)) - (declare (optimize (speed 3) (safety 1) (debug 1))) - (lambda (&rest more) - (apply ,fun ,@curries more))))) - - - (defun mappend (function &rest lists) - "Applies `function` to respective element(s) of each `list`, appending all the -all the result list to a single list. `function` must return a list." - (loop for results in (apply #'mapcar function lists) - append results)) - - - (defun map-product (function list &rest more-lists) - "Returns a list containing the results of calling `function` with one argument -from `list`, and one from each of `more-lists` for each combination of arguments. -In other words, returns the product of `list` and `more-lists` using `function`. - -Example: - - (map-product 'list '(1 2) '(3 4) '(5 6)) - => ((1 3 5) (1 3 6) (1 4 5) (1 4 6) - (2 3 5) (2 3 6) (2 4 5) (2 4 6))" - (labels ((%map-product (f lists) - (let ((more (cdr lists)) - (one (car lists))) - (if (not more) - (mapcar f one) - (mappend (lambda (x) - (%map-product (curry f x) more)) - one))))) - (%map-product (ensure-function function) (cons list more-lists)))) - - - (defun rcurry (function &rest arguments) - "Returns a function that applies the arguments it is called -with and `arguments` to `function`." - (declare (optimize (speed 3) (safety 1) (debug 1))) - (let ((fn (ensure-function function))) - (lambda (&rest more) - (declare (dynamic-extent more)) - (multiple-value-call fn (values-list more) (values-list arguments))))) - - - (defun set-equal (list1 list2 &key (test #'eql) (key nil keyp)) - "Returns true if every element of `list1` matches some element of `list2` and -every element of `list2` matches some element of `list1`. Otherwise returns false." - (let ((keylist1 (if keyp (mapcar key list1) list1)) - (keylist2 (if keyp (mapcar key list2) list2))) - (and (dolist (elt keylist1 t) - (or (member elt keylist2 :test test) - (return nil))) - (dolist (elt keylist2 t) - (or (member elt keylist1 :test test) - (return nil)))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(once-only with-gensyms with-unique-names map-product curry rcurry - set-equal))) + (export '(curry ensure-gethash ensure-list map-product once-only rcurry + set-equal with-gensyms with-unique-names))) ;;;; END OF quickutils.lisp ;;;;