brcil.lsp

gistfile1.lsp

(load "blockdata.lsp")
(load "helper.lsp")

(defun match-element (x y)
  (or (equal x y) (equal y '?)))

(defun match-triple (x pat)
  (every #'match-element x pat))

(defun fetch (pat)
  (remove-if-not #'(lambda (x) (match-triple x pat)) blockdata))

(defun color-pattern (blk) (list blk 'color '?))

(defun flatten (ls)
  (cond ((null ls) nil)
        ((atom ls) (list ls))
        (t (append (flatten (car ls)) (flatten (cdr ls))))))

(defun add-brick (lst)
  (setq blockdata
    (cons lst blockdata)))

(defun add-support (x y)
  (if (equal (relation x y) 'non)
      (list (add-brick (list x 'supported-by y)) (add-brick (list y 'supports x)))
      (format t "~a has already relationship~%" x)))


(defun supporters (blk)
  (mapcar #'car
    (fetch (list '? 'supports blk))))

(defun description (blk)
  (flatten
    (mapcar #'cdr
      (fetch (list blk '? '?)))))

(defun removalbe-p (blk)
  (null (fetch (list blk 'supports '?))))

(defun add-supports (blk blks)
  (cond ((null blks) NIL)
        (t (add-support blk (car blks)) (add-supports blk (cdr blks)))))

(defun relation (x y)
  (cond ((fetch (list x 'supports y)) 'supports)
        ((fetch (list x 'supported-by y)) 'supported-by)
        (t 'non)))

(defun remove-blk (blk)
  (if (removalbe-p blk)
        (setq blockdata (remove-if #'(lambda (x)
          (or (match-triple x (list blk '? '?))
              (match-triple x (list '? '? blk))))
          blockdata))

        (format t "~a is not removable.~%" blk)))


(load "main.lsp")

(defun asser-equal (x y)
  (format t (if (equal x y) "OK~%" "NG~%")))

(defun print (x) (format t "~a" x))
(asser-equal (match-element "A" "A") T)
(asser-equal (match-element "A" '?) T)
(asser-equal (match-element '? "A") NIL)
(asser-equal (match-element '? '?) T)
(asser-equal (match-triple '(b2 color red) '(b2 color ?)) T)
(asser-equal (match-triple '(b2 color red) '(b2 color blue)) NIL)
(asser-equal (fetch '(? supports b1)) '((b2 supports b1) (b3 supports b1)))
(asser-equal (color-pattern 'b1) '(b1 color ?))
(asser-equal (supporters 'b1) '(b2 b3))
(asser-equal (description 'b2) '(shape brick color red size small supprots b1 left-of b3))
(asser-equal (removalbe-p 'b2) NIL)
(asser-equal (removalbe-p 'b1) T)

(asser-equal (relation 'b1 'b2) 'supported-by)
(asser-equal (relation 'b2 'b1) 'supports)
(asser-equal (relation 'b2 'b3) 'non)

(add-brick '(b4 shape brick))
(add-supports 'b4 '(b1))
(add-supports 'b1 '(b4))

(asser-equal (removalbe-p 'b1) NIL)

(remove-blk 'b1)
(remove-blk 'b4)

(asser-equal (removalbe-p 'b1) T)