--- /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))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- 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)
--- 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)
--- 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")
--- 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")
--- 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 ;;;;