;;; block.lisp -- Program Assignment 1
;;; Simplified Blocks World
;;; Jason Kantz CIS 579 (Maxim)
(in-package "CL-USER")

(defparameter *database*
  '((B1 SHAPE BRICK)
    (B1 COLOR GREEN)
    (B1 SIZE SMALL)
    (B1 SUPPORTED-BY B2)
    (B1 SUPPORTED-BY B3)
    (B2 SHAPE BRICK)
    (B2 COLOR RED)
    (B2 SIZE SMALL)
    (B2 SUPPORTS B1)
    (B2 LEFT-OF B3)
    (B3 SHAPE BRICK)
    (B3 COLOR RED)
    (B3 SIZE SMALL)
    (B3 SUPPORTS B1)
    (B3 RIGHT-OF B2)
    (B4 SHAPE PYRAMID)
    (B4 COLOR BLUE)
    (B4 SIZE LARGE)
    (B4 SUPPORTED-BY B5)
    (B5 SHAPE CUBE)
    (B5 COLOR GREEN)
    (B5 SIZE LARGE)
    (B5 SUPPORTS B4)
    (B6 SHAPE BRICK)
    (B6 COLOR PURPLE)
    (B6 SIZE LARGE))
  "A list of assertions about blocks.")

(defun match-element (sym1 sym2)
  "Return T if same symbol, and T if sym2 is '?"
  (or (eql sym1 sym2) (eql sym2 '?)))

(defun match-triple (assertion query)
  "Return T if query matches assertion."
  (every #'match-element assertion query))

(defun fetch (query)
  "Return all assertions that match query."
  (remove-if-not #'(lambda (assertion)
		     (match-triple assertion query))
		 *database*))

(defun supporters (b)
  "Return all blocks that are supporing block b."
  (mapcar #'third (fetch `(,b supported-by ?))))
  
(defun desc1 (b)
  "Return all assertions about block b."
  (fetch `(,b ? ?)))

(defun desc2 (b)
  "Return an alist for block b."
  (mapcar #'cdr (desc1 b)))

(defun description (b)
  "Return a plist for block b."
  (apply #'append (desc2 b)))


(defmacro test (form value &key (test #'equal))
  "Test that form evaluates to value."
  (let ((val (gensym)))
    `(let ((,val ,value)) ;Prevent eval'ing value more than once.
       (cond ((funcall ,test ,form ,val)
	      (format t "~&;; ~s ~%;; ... passed!" ',form)
	      t)
	     (t (error "~&~s does not evaluate to ~s." ',form ,val))))))

(defun test-all ()
  "Test all functions in the assignment."
  ;; 1
  (test (match-element 'red 'red) t)
  (test (match-element 'red '?) t)
  (test (match-element 'red 'blue) nil)
  ;; 2
  (test (match-triple '(b2 color red) '(b2 color ?)) t)
  (test (match-triple '(b2 color red) '(b2 color green)) nil)
  ;; 3
  (test (fetch '(b2 color ?)) '((b2 color red)))
  (test (fetch '(? supports b1)) '((b2 supports b1) (b3 supports b1)))
  ;; 4
  (test (supporters 'b1) '(b2 b3))
  ;; 5
  (test (desc1 'b6) '((B6 SHAPE BRICK) (B6 COLOR PURPLE) (B6 SIZE LARGE)))
  ;; 6
  (test (desc2 'b6) '((SHAPE BRICK) (COLOR PURPLE) (SIZE LARGE)))
  ;; 7
  (test (description 'b6) '(SHAPE BRICK COLOR PURPLE SIZE LARGE)))


;;; Testing results ...

;* (test-all)
;; (MATCH-ELEMENT 'RED 'RED) 
;; ... passed!
;; (MATCH-ELEMENT 'RED '?) 
;; ... passed!
;; (MATCH-ELEMENT 'RED 'BLUE) 
;; ... passed!
;; (MATCH-TRIPLE '(B2 COLOR RED) '(B2 COLOR ?)) 
;; ... passed!
;; (MATCH-TRIPLE '(B2 COLOR RED) '(B2 COLOR GREEN)) 
;; ... passed!
;; (FETCH '(B2 COLOR ?)) 
;; ... passed!
;; (FETCH '(? SUPPORTS B1)) 
;; ... passed!
;; (SUPPORTERS 'B1) 
;; ... passed!
;; (DESC1 'B6) 
;; ... passed!
;; (DESC2 'B6) 
;; ... passed!
;; (DESCRIPTION 'B6) 
;; ... passed!
;T

#|

This code defines a data structure and some accessors.  The data
structure is a list that contains sub-lists that are each an assertion
about a particular block.  For each accessor I looked at the function
description, and I tried to choose the most specific built-in Common
Lisp function to do the job.

The function, DESCRIPTION, cannot use mapcan because destructively
modifying the database would break everything, including description
itself.

|#

;;; block.lisp ends here