examples/ggp-paip-compiled.lisp @ 8cd3257c58e3
Name the subterm-handling instructions something not completely stupid
The `unify-*` instructions in the original WAM are used both in both program
mode and query mode. In program mode, they are used to unify subterms of
arguments with things. In query mode, they are used to write the subterms of
the arguments into the head.
You may have noticed the common word in both of these descriptions is "subterm"
and not "unify". Let's use that word to name the instructions so it's less
confusing.
author |
Steve Losh <steve@stevelosh.com> |
date |
Sun, 10 Jul 2016 14:28:48 +0000 |
parents |
a696be29e830 |
children |
(none) |
(defpackage #:paiprolog-test
(:use #:cl #:paiprolog))
(in-package #:paiprolog-test)
(defvar *state* nil)
(defvar *actions* nil)
(defun paiprolog::true/1 (?thing cont)
(loop :with tr = (fill-pointer paiprolog::*trail*)
:for item :in *state*
:when (paiprolog::unify! ?thing item)
:do
(funcall cont)
(paiprolog::undo-bindings! tr)))
(defun paiprolog::does/1 (?action cont)
(loop :with tr = (fill-pointer paiprolog::*trail*)
:for action :in *actions*
:when (paiprolog::unify! ?action action)
:do
(funcall cont)
(paiprolog::undo-bindings! tr)))
(<-- (member ?x (?x . ?)))
(<- (member ?x (?y . ?rest))
(member ?x ?rest))
(<-- (role robot))
(<-- (init (off p)))
(<- (init (off q)))
(<- (init (off r)))
(<- (init (off s)))
(<- (init (step num1)))
(<-- (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 (off s))
(does (robot a))
(true (off s)))
(<- (next (off s))
(does (robot b))
(true (off s)))
(<- (next (off s))
(does (robot c))
(true (off s)))
(<- (next (on s))
(does (robot a))
(true (on s)))
(<- (next (on s))
(does (robot b))
(true (on s)))
(<- (next (on s))
(does (robot c))
(true (on s)))
(<- (next (off s))
(does (robot d))
(true (on s)))
(<- (next (on s))
(does (robot d))
(true (off s)))
(<- (next (on p))
(does (robot d))
(true (on p)))
(<- (next (off p))
(does (robot d))
(true (off p)))
(<- (next (on q))
(does (robot d))
(true (on q)))
(<- (next (off q))
(does (robot d))
(true (off q)))
(<- (next (on r))
(does (robot d))
(true (on r)))
(<- (next (off r))
(does (robot d))
(true (off r)))
(<- (next (step ?y))
(true (step ?x))
(succ ?x ?y))
(<-- (succ num1 num2))
(<- (succ num2 num3))
(<- (succ num3 num4))
(<- (succ num4 num5))
(<- (succ num5 num6))
(<- (succ num6 num7))
(<- (succ num7 num8))
(<-- (legal robot a))
(<- (legal robot b))
(<- (legal robot c))
(<- (legal robot d))
(<-- (goal robot num100)
(true (on p))
(true (on q))
(true (on r))
(true (on s)))
(<- (goal robot num0)
(true (off p)))
(<- (goal robot num0)
(true (off q)))
(<- (goal robot num0)
(true (off r)))
(<- (goal robot num0)
(true (off s)))
(<-- (terminal)
(true (step num8)))
(<- (terminal)
(true (on p))
(true (on q))
(true (on r))
(true (on s)))
(<-- (lol 1))
(defvar *count* 0)
(defun initial-state ()
(prolog-collect (?what) (init ?what)))
(defun terminalp ()
(not (null (prolog-first (?lol)
(terminal)
(lol ?lol)))))
(defun legal-moves (state)
(declare (ignore state))
(prolog-collect (?role ?move) (legal ?role ?move)))
(defun roles ()
(prolog-collect (?role) (role ?role)))
(defun goal-value ()
(prolog-first (?goal) (goal robot ?goal)))
(defun next-state (move)
(setf *actions* (list move))
(prolog-collect (?what) (next ?what)))
(defstruct search-path state (path nil) (previous nil))
(defun tree-search (states goal-p children combine)
(labels
((recur (states)
(if (null states)
nil
(destructuring-bind (state . remaining) states
(incf *count*)
; (format t "Searching: ~S (~D remaining)~%" state (length remaining))
(if (funcall goal-p state)
state
(recur (funcall combine
(funcall children state)
remaining)))))))
(let ((result (recur states)))
(when result
(reverse (search-path-path result))))))
(defun buttons-goal-p (search-path)
(setf *state* (search-path-state search-path))
(and (terminalp)
(eql (goal-value) 'num100)))
(defun buttons-children (search-path)
(let ((state (search-path-state search-path))
(path (search-path-path search-path)))
(setf *state* state)
(when (not (terminalp))
(loop :for move :in (legal-moves state)
:collect (make-search-path :state (next-state move)
:path (cons move path)
:previous search-path)))))
(defun never (&rest args)
(declare (ignore args))
nil)
(defun dfs ()
(tree-search (list (make-search-path :state (initial-state)))
#'buttons-goal-p
#'buttons-children
#'append))
(defun dfs-exhaust ()
(let ((*count* 0))
(prog1
(tree-search (list (make-search-path :state (initial-state)))
#'never
#'buttons-children
#'append)
(format t "Searched ~D nodes.~%" *count*))))
(defun bfs ()
(tree-search (list (make-search-path :state (initial-state)))
#'buttons-goal-p
#'buttons-children
(lambda (x y)
(append y x))))
(declaim (sb-ext:muffle-conditions sb-ext:compiler-note))
#+no
(progn
(require :sb-sprof)
(sb-sprof:with-profiling (:max-samples 10000
:sample-interval 0.01
:loop nil)
(dfs-exhaust))
(sb-sprof:report :type :flat :max 100))