logic.lisp

;;; logic.lisp --- some useful functions adapted from PAIP

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see http://www.gnu.org/licenses/.

;;; Licensed material:

;; Some functions in this file are originally written by Peter Norvig
;; for his book "Paradigms of Artificial Intelligence
;; Programming". The modified versions are redistributed here under
;; the terms of the General Public License as given above.

;; You can find more information on Norvig's book at his website:

;; http://www.norvig.com/paip.html

;; The full license for the PAIP code, which governs the terms of
;; said redistribution under the GPL, can be found at norvig.com:

;; http://www.norvig.com/license.html

(in-package :blocky)

;;; Miscellaneous

(defmacro callf (function place &rest arguments)
  `(setf ,place (apply #',function ,place (list ,@arguments))))

;;; Grammars

;; http://en.wikipedia.org/wiki/Context-free_grammar

;; Generate random sentences from context-free grammars, and then
;; interpret them how you want. 

(defvar *grammar* nil
  "The current context-free grammar used for sentence generation.
This is an association list of the form:

    ((VARIABLE >> EXPANSIONS)
     (VARIABLE >> EXPANSIONS)
     ...)

Where EXPANSIONS is a list of alternatives, each of which may be
either (1) single symbols or (2) a list of symbols, representing
concatenation.")

(defun one-of (set)
  (list (nth (random (length set)) set)))

(defun left-hand-side (rule)
  (first rule))

(defun right-hand-side (rule)
  (rest (rest rule)))

(defun expansions (variable)
  (right-hand-side (assoc variable *grammar*)))

(defun generate (phrase)
  "Generate a random phrase using the grammar in `*grammar*'."
  (cond ((listp phrase)
	 (apply #'append (mapcar #'generate phrase)))
	((expansions phrase)
	 (generate (one-of (expansions phrase))))
	(t (list phrase))))

;;; Memoization facility

(defmacro defun-memo (name args memo-args &body body)
  "Define a memoized function named NAME.
ARGS is the lambda list giving the memoized function's arguments.
MEMO-ARGS is a list with optional keyword arguments for the
memoization process: :KEY, :VALIDATOR, and :TEST."
  `(memoize (defun ,name ,args . ,body) ,@memo-args))

(defun memo (fn &key (key #'first) (test #'eql) validator name)
  "Return a memo-function of fn."
  (let ((table (make-hash-table :test test)))
    (setf (get name 'memo) table)
    #'(lambda (&rest args)
        (let ((k (funcall key args)))
          (multiple-value-bind (val found-p)
              (gethash k table)
            (if found-p 
		val
		;; only cache if value is valid
		(let ((candidate-value (apply fn args)))
		  (prog1 candidate-value
		    (when (or (null validator)
			      (funcall validator candidate-value))
		      (setf (gethash k table) candidate-value))))))))))

(defun memoize (fn-name &key (key #'first) (test #'eql) validator)
  "Replace fn-name's global definition with a memoized version."
  (clear-memoize fn-name)
  (setf (symbol-function fn-name)
        (memo (symbol-function fn-name)
              :name fn-name :key key :test test :validator validator)))

(defun clear-memoize (fn-name)
  "Clear the hash table from a memo function."
  (let ((table (get fn-name 'memo)))
    (when table (clrhash table))))

(defun get-memo-table (fn-name)
  (get fn-name 'memo))

;;; logic.lisp ends here