Skip to content

Instantly share code, notes, and snippets.

@gogotanaka
Created January 15, 2016 03:44
Show Gist options
  • Save gogotanaka/c5ac4786386807b2c609 to your computer and use it in GitHub Desktop.
Save gogotanaka/c5ac4786386807b2c609 to your computer and use it in GitHub Desktop.
brcil.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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment