;;; tilt-mazes, a Lisp implementation of the game at
;;; http://www.clickmazes.com/newtilt/ixtilt2d.htm
;;;
;;; Copyright Frank Buss
;;; TODO: solve-maze for Multi-Goal mazes
;;; start text mode game with (clim-user::play-maze (number))
;;; and CLIM game with (clim-user::play-maze-clim)
;; prints a maze
(defun print-maze-array (maze-array)
(terpri)
(destructuring-bind (width height) (array-dimensions maze-array)
(loop for y below height do
(loop for x below width do
(princ (case (aref maze-array x y)
(stone #\o)
(target #\T)
(empty #\Space)
(otherwise #\#))))
(terpri))))
;; search a field in the maze and returns (x y) as multiple values
(defun search-maze (maze-array type)
(destructuring-bind (width height) (array-dimensions maze-array)
(loop for y from 0 below height do
(loop for x from 0 below width do
(when (eql (aref maze-array x y) type)
(return-from search-maze (values x y)))))))
;; returns the coordinates of the next wall, starting at (x y), in
;; the direction (dx dy)
(defun search-wall (maze-array x y dx dy)
(loop until (eql (aref maze-array x y) 'wall) do
(incf x dx)
(incf y dy))
(values (- x dx) (- y dy)))
;; returns the number of targets
(defun count-maze-targets (maze-array)
(let ((count 0))
(destructuring-bind (width height) (array-dimensions maze-array)
(loop for y from 0 below height do
(loop for x from 0 below width do
(when (eql (aref maze-array x y) 'target) (incf count)))))
count))
;; moves the stone until it tilts to a wall in direction (dx dy)
;; while moving, it removes all targets
(defun move-stone (maze-array dx dy)
(multiple-value-bind (x y) (search-maze maze-array 'stone)
(setf (aref maze-array x y) 'empty)
(multiple-value-bind (x y) (search-wall maze-array x y dx dy)
(do ((xb x (- xb dx))
(yb y (- yb dy)))
((and (= xb x) (= yb y)))
(setf (aref maze-array xb yb) 'empty))
(setf (aref maze-array x y) 'stone))))
;; create a maze array
(defun make-maze-array (number)
(let* ((maze (car (elt *mazes* number)))
(width (length (car maze)))
(height (length maze))
(maze-array (make-array (list width height)))
(y 0))
(dolist (line maze)
(loop for x from 0 below (length line) do
(let ((char (elt line x)))
(setf (aref maze-array x y)
(case char
(#\o 'stone)
(#\T 'target)
(#\Space 'empty)
(otherwise 'wall)))))
(incf y))
maze-array))
;; interactive game play in text mode
(defun play-maze (number)
(format t "Moving keys are standard VI keys:~%")
(format t "l: right~%")
(format t "k: up~%")
(format t "j: down~%")
(format t "h: left~%")
(format t "q: quit~%")
(do* ((maze-array (make-maze-array number))
(char nil (read-char))
(direction nil (cdr (assoc char *stone-directions*))))
((eql char #\q) "quit")
(format t "~A~%" char)
(if direction
(move-stone maze-array (car direction) (cadr direction)))
(print-maze-array maze-array)
(when (= (count-maze-targets maze-array) 0) (return "won"))))
;;; Solving Algorithm
;;; A path looks like this: (x y "hlkj"), where x and y are the current
;;; endpoint and the string are the movements from start.
;;; The algorithm starts with the path (x y ""), where x and y are the
;;; start position of the stone, and adds every iteration all possible
;;; new movements, but only, if the path is shorter. If there are no more
;;; shorter paths for all possible new movements, the search is finished.
;; get all possible movements as new paths
(defun get-possible-new-paths (maze-array path)
(let ((possible-new-paths nil))
(destructuring-bind (x y path-string) path
(dolist (direction *stone-directions*)
(destructuring-bind (name dx dy) direction
(multiple-value-bind (x-new y-new) (search-wall maze-array x y dx dy)
(when (not (and (= x x-new) (= y y-new)))
(setf possible-new-paths
(cons (list x-new y-new
(concatenate 'string path-string (string name)))
possible-new-paths)))))))
possible-new-paths))
;; search and return the path for the endposition (x y), or return nil
(defun search-path (paths x y)
(if (null paths)
nil
(let* ((path (car paths))
(x2 (car path))
(y2 (cadr path)))
(if (and (= x x2) (= y y2))
paths
(search-path (cdr paths) x y)))))
;; creates a new paths list with all possible new movements, which results
;; in shorter paths for the same endpoint
(defun solve-iteration (maze-array paths)
(let ((new-paths (copy-list paths)))
(dolist (path paths)
(dolist (possible-new-path (get-possible-new-paths maze-array path))
(let* ((existing-path-cons
(search-path new-paths (car possible-new-path) (cadr possible-new-path)))
(existing-path (car existing-path-cons)))
(if existing-path-cons
(let ((existing-path-string (car (last existing-path)))
(possible-path-string (car (last possible-new-path))))
(when (< (length possible-path-string) (length existing-path-string))
(rplaca existing-path-cons possible-new-path)))
(setf new-paths (cons possible-new-path new-paths))))))
new-paths))
;; print the solution, if all targets were found
(defun solve-solution (maze-array paths)
(print-maze-array maze-array)
(multiple-value-bind (x y) (search-maze maze-array 'target)
(let ((solution-path (search-path paths x y)))
(if solution-path
(format t "solution: ~A" (caddar solution-path))
(format t "no solution found")))))
PL 숙제를 리습으로 작성하려고 무진장 애를 쓰는 중입니다. 간만에 다른 언어를 배울 기회라고 생각되어져서 가능하면 지금까지 배웠던 언어와는 완전하 다른 패러다임의 언어를 해보고 싶었는데... -_-;; 진입 장벽이 너무 높네요.
페인터를 구현하려고 하는데 GUI 라이브러리를 구하는게 하늘의 별따기 입니다. LispWorks 는 무료판에서는 아예 GUI 라이브러리는 손도 못대게 되있고... (require :clim) 만 들어가면 무조건 애러를 뱉어내는 대담성... ㅡ.ㅡ; (때릴 수도 없고..)
그래서 지금은 라이브러리를 못구하면 아예 앞으로 계속 써먹을 언어를 배운다 치고... 펄이나 파이선, 델파이 중에서 하나를 골라보려고 생각중입니다.
