Write a program that is to reason about stacking blocks on a table. We might have a situation like:
Each block that records its properties will be represented by "defstruct" as follows:
(defstruct block
(name nil)
(color nil)
(ison 'table)
(isunder nil))
1. We keep a list of all the block records in the global variable *BLOCKS*. The function "start-world" (10 pts) initializes the global variable *BLOCKS*.
2. The function "new-block" (10 pts) sets up a block record, adds it to the block’s world model, and makes sure that it starts out sitting on the table.
3. The function "clear-top?" (20 pts) is used to check whether a block has nothing on top of it.
4. The function "lift-off" (20 pts) picks up a block which has nothing on top of it and puts it on the table.
5. The function "(put-on 'A 'B)" checks whether the block already exists in the *BLOCKS* (10 pts) and, if they exist, put block A on block B (10 pts).
6. Further, the functions "put-on" and "lift-off" are to return error messages if they are made to refer to a block with something on top of it, or to one that cannot be moved (10 pts).
7. The function "print-world" (20 pts) is to display the state of our block’s world. With these functions, we can set up a model of our block’s world.
(defparameter *blocks* nil)
(defstruct *block*
(name nil)
(color nil)
(ison 'table)
(isunder nil))
(defun start-world ()
(cond ((null *blocks*)
*blocks*)
(t
(setq *blocks* nil))))
(defun new-block (name color)
(let ((*new-block*
(make-*block* :name name :color color)))
(setf *blocks* (append *blocks* (list *new-block*)))))
(defun find-block (blocks-list name)
(cond ((null blocks-list)
nil
)
((equal (*block*-name (car blocks-list)) name)
(car blocks-list))
(t
(find-block (cdr blocks-list) name))))
(defun clear-top? (name)
(let ((finded-block (find-block *blocks* name)))
(null (*block*-isunder finded-block))))
(defun helper-block (name new-name check ison isunder)
(let ((found-block (find-block *blocks* name))
(new-found-block (find-block *blocks* new-name)))
(cond ((null found-block)
(format nil "Unkown block named: ~s" name))
((null new-found-block)
(format nil "Unkown block named: ~s" new-name))
((clear-top? check)
(setf (*block*-ison found-block) ison)
(setf (*block*-isunder new-found-block) isunder)
t )
(t
(format nil "Block ~s supports something." check)))))
(defun put-on (name new-name)
(helper-block name new-name new-name new-name name))
(defun lift-off (name)
(if (eq (*block*-ison (find-block *blocks* name)) 'table)
(format nil "Block ~s supports something." name)
(helper-block name (*block*-ison (find-block *blocks* name)) name 'table nil)))
(defun print-world ()
(labels ((list-helper (blocks-list)
(cond ((null blocks-list)
nil)
(t
(let* ((current-block (car blocks-list))
(name (*block*-name current-block))
(color (*block*-color current-block))
(ison (*block*-ison current-block))
(isunder (*block*-isunder current-block))
)
(format t "Block ~S (~S) is on ~S and supports ~S" name color (ison-helper ison) (null-helper isunder))
(list-helper (cdr blocks-list))))))
(null-helper (isunder)
(if (null isunder)
'nothing
isunder))
(ison-helper (ison)
(if (eq ison 'table)
"the table"
ison)))
(list-helper *blocks*)))
谁帮我解释下。标注一下。我有点不明白。
