fork download
copy 
  1. ; your code goes here
  2. (defparameter *width* 12)
  3. (defparameter *height* 8)
  4. (defparameter *elements* '(:none :wall :start :goal :passed))
  5.  
  6. (defparameter *around* '((1 0) (-1 0) (0 1) (0 -1)))
  7.  
  8. (defun gen-field (data)
  9.   (labels ((index (x y)
  10. 	     (+ x (* y *width*))))
  11.     (let ((field (make-array (list *width* *height*))))
  12.       (dotimes (y *height*)
  13. 	(dotimes (x *width*)
  14. 	  (let ((elt (aref data (index x y))))
  15. 	    (setf (aref field x y)
  16. 		  (cond ((eq elt 'S) :start)
  17. 			((eq elt 'G) :goal)
  18. 			((= elt 0) :none)
  19. 			((= elt 1) :wall))))))
  20.       field)))
  21.  
  22. (defun init-field ()
  23.   (gen-field #(0 0 0 1 0 0 1 0 0 0 0 0
  24. 	       0 0 0 1 0 0 1 0 G 0 0 0
  25. 	       0 0 0 1 0 0 1 0 0 0 0 0
  26. 	       0 S 0 0 0 0 1 0 0 0 0 0
  27. 	       0 0 0 1 0 0 1 0 0 0 0 0
  28. 	       0 0 0 1 0 0 1 1 1 1 0 1
  29. 	       0 0 0 1 0 0 0 0 0 0 0 0
  30. 	       0 0 0 1 0 0 0 0 0 0 0 0)))
  31.  
  32. (defun find-element (field elt)
  33.   (dotimes (y *height*)
  34.     (dotimes (x *width*)
  35.       (when (eq (aref field x y) elt)
  36. 	(return-from find-element (list x y))))))
  37.  
  38. (defun find-start (field)
  39.   (find-element field :start))
  40.  
  41. (defun find-goal (field)
  42.   (find-element field :goal))
  43.  
  44. (defun draw-field (field)
  45.   (dotimes (y *height*)
  46.     (dotimes (x *width*)
  47.       (princ (case (aref field x y)
  48. 	       (:none "_ ")
  49. 	       (:wall "# ")
  50. 	       (:start "S ")
  51. 	       (:goal "G ")
  52. 	       (:passed "@ ")
  53. 	       )))
  54.     (terpri)))
  55.  
  56. (defun range-p (x y)
  57.   (and (<= 0 x (1- *width*))
  58.        (<= 0 y (1- *height*))))
  59.  
  60. (defun distance (start goal)
  61.   (round
  62.    (sqrt
  63.     (+ (expt (- (first goal) (first start)) 2)
  64.        (expt (- (second goal) (second start)) 2)))))
  65.  
  66. (defun collect-around (fn pos)
  67.   (let (around)
  68.     (dolist (a *around*)
  69.       (let ((x (+ (first pos) (first a)))
  70. 	    (y (+ (second pos) (second a))))
  71. 	(when (range-p x y)
  72. 	  (let ((it (funcall fn x y)))
  73. 	    (when it
  74. 	      (push it around))))))
  75.     around))
  76.  
  77. (defparameter *attrs* '(:none :open :close))
  78.  
  79. (defstruct a*
  80.   attr
  81.   cost
  82.   pos
  83.   parent)
  84.  
  85. (defparameter *astar-field* (make-hash-table :test #'equal))
  86.  
  87. (defun add (attr cost pos parent)
  88.   (multiple-value-bind (val win)
  89.       (gethash pos *astar-field*)
  90.     (if win
  91. 	val
  92. 	(setf (gethash pos *astar-field*)
  93. 	      (make-a* :attr attr :cost cost :pos pos :parent parent)))))
  94.  
  95. (defun make-around (field goal pos cost)
  96.   (sort (collect-around
  97. 	 (lambda (x y)
  98. 	   (unless (eq (aref field x y) :wall)
  99. 	     (let* ((hcost (distance (list x y) goal))
  100. 		    (elt (add :open (+ cost hcost) (list x y) pos)))
  101. 	       (unless (eq (a*-attr elt) :close)
  102. 		 elt))))
  103. 	 pos)
  104. 	(lambda (a b)
  105. 	  (< (a*-cost a) (a*-cost b)))))
  106.  
  107. (defun a*-recur (field goal pos cost)
  108.   (if (equal pos goal)
  109.       (throw 'found t)
  110.       (let ((around (make-around field goal pos (1+ cost))))
  111. 	(setf (a*-attr (gethash pos *astar-field*)) :close)
  112. 	(dolist (elt around)
  113. 	  (a*-recur field goal (a*-pos elt) (a*-cost elt))))))
  114.  
  115. (defun a*-backtrace (field start goal)
  116.   (labels ((rec (a*)
  117. 	     (let ((pos (a*-pos a*)))
  118. 	       (unless (equal pos start)
  119. 		 (destructuring-bind (x y) pos
  120. 		   (setf (aref field x y) :passed)
  121. 		   (rec (gethash (a*-parent a*) *astar-field*)))))))
  122.     (rec (gethash goal *astar-field*))
  123.     field))
  124.  
  125. (defun a*-start (field start goal)
  126.   (setf *astar-field* (make-hash-table :test #'equal))
  127.   (add :close 0 start nil)
  128.   (catch 'found
  129.     (a*-recur field goal start 0))
  130.   (a*-backtrace field start goal))
  131.  
  132. (defun test ()
  133.   (let* ((field (init-field))
  134. 	 (start (find-start field))
  135. 	 (goal (find-goal field)))
  136.     (draw-field (a*-start field start goal))))
  137.  
  138. (test)
  139.  
Success #stdin #stdout 0.03s 10728KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
_ _ _ # _ _ # _ _ _ _ _ 
_ _ _ # _ _ # _ @ _ _ _ 
_ _ _ # _ _ # _ @ @ @ _ 
_ S @ @ @ @ # _ _ _ @ _ 
_ _ _ # _ @ # _ _ _ @ _ 
_ _ _ # _ @ # # # # @ # 
_ _ _ # _ @ @ @ @ @ @ _ 
_ _ _ # _ _ _ _ _ _ _ _
https://ideone.com/bueWdz
language:
Common Lisp (clisp 2.49.92)
created:
10 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!