/[gamelib]/source/maps.lisp
ViewVC logotype

Contents of /source/maps.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Sat Sep 2 10:54:20 2006 UTC (7 years, 7 months ago) by imattsson
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +1 -1 lines
Minor changes to maps.lisp.
Documentation changes for maps.html
1 (in-package :net.hexapodia.maps-2d)
2
3 (defvar *maps* nil "Array of maps")
4 (defvar *mapcount* 0 "Map count")
5 (defvar *map-path* #p"*.map" "Map path specifier")
6 (defvar *current-map* nil)
7 (defvar *symbol-map* nil "Hash table mapping map symbol to pixmap-family")
8 (defvar *symbol-map-data* '((#\S :floor)) "List of lists (CHAR SYMBOL) for map data")
9 (defvar *tile-map* nil "Hash table mapping map pixmap-family to symbol")
10 (defconstant +east+ 8)
11 (defconstant +north+ 4)
12 (defconstant +south+ 2)
13 (defconstant +west+ 1)
14
15 (defvar *tiles-with-direction* nil "List of lists (BASE TESTFUN) for tiles that should connect to something else but doesn't fill the tile on its own.")
16
17 (defvar *generator-map* (make-hash-table :test 'equal))
18 (defvar *tile-generator-data* nil "List of lists, like *SYMBOL-MAP-DATA*, but for generators")
19 (defvar *multi-tile-function-map* (make-hash-table))
20
21 (defclass map ()
22 ((seq :reader seq :initarg :seq)
23 (width :reader width :initarg :width)
24 (height :reader height :initarg :height)
25 (mapdata :reader mapdata :initarg :mapdata)
26 ))
27
28 (defun make-map (width height seq)
29 (let ((ar (make-array (list width height)
30 :element-type 'character
31 :initial-element #\space)))
32 (setf (aref *maps* seq)
33 (make-instance 'map
34 :seq seq
35 :width width :height height
36 :mapdata ar))))
37
38 (defun read-map (fname)
39 (with-open-file (map (merge-pathnames fname
40 net.hexapodia.games-2d:*file-path*)
41 :direction :input)
42 (let* ((seq (read map))
43 (w (read map))
44 (h (read map)))
45 (let ((mapobj (make-map w h seq)))
46 (loop for line from 0 below h
47 for ldata = (read-line map)
48 do (loop for pos from 0 below w
49 do (setf (aref (mapdata mapobj) pos line)
50 (aref ldata pos))))
51 mapobj))))
52
53 (defun read-all-maps (&optional spec)
54 (let ((basepath (or spec
55 (merge-pathnames *map-path*
56 net.hexapodia.games-2d:*file-path*))))
57 (let ((files (directory basepath)))
58 (setf *mapcount* (length files))
59 (setf *maps* (make-array *mapcount*))
60 (loop for file in files
61 do (read-map file)))))
62
63 (defun activate-generators ()
64 (clrhash *generator-map*)
65 (let ((w (width *current-map*))
66 (h (height *current-map*))
67 (md (mapdata *current-map*)))
68 (loop for x from 0 below w
69 do (loop for y from 0 below h
70 do (let* ((c (aref md x y))
71 (tv (member c *tile-generator-data* :key #'car)))
72 (when tv
73 (let ((gen (second (first tv))))
74 (net.hexapodia.games-2d:make-generator
75 (gethash c *tile-map*)
76 gen x y))))))))
77
78 (defun activate-map (seq)
79 (when (and (<= 0 seq)
80 (< seq *mapcount*))
81 (setf *current-map* (aref *maps* seq))
82 (activate-generators)))
83
84 (defun multi-tile-from-map (x y char)
85 (let ((indicator 0)
86 (map (mapdata *current-map*))
87 (w (1- (width *current-map*)))
88 (h (1- (height *current-map*))))
89 (when (< 0 x)
90 (if (char= (aref map (1- x) y) char)
91 (incf indicator +west+)))
92 (when (< 0 y)
93 (if (char= (aref map x (1- y)) char)
94 (incf indicator +north+)))
95 (when (< x w)
96 (if (char= (aref map (1+ x) y) char)
97 (incf indicator +east+)))
98 (when (< y h)
99 (if (char= (aref map x (1+ y)) char)
100 (incf indicator +south+)))
101 indicator))
102
103 (defun make-keyword (name)
104 (read-from-string (format nil ":~s" name)))
105
106 (defmacro define-type-from-map (key &rest chars)
107 (let ((keys (loop for end in '("" -w -s -sw -n -nw -ns -nsw -e -ew -es
108 -esw -en -enw -ens -ensw)
109 collect (make-keyword
110 (concatenate 'string
111 (string key) (string end)))))
112 (fun-name (intern (concatenate 'string (string key)
113 (string '-from-map)))))
114 (push keys *tiles-with-direction*)
115 `(progn
116 (defun ,fun-name (x y)
117 (nth (logior ,@ (loop for char in chars
118 collect (list 'multi-tile-from-map
119 'x 'y char)))
120 ',keys))
121 (setf (gethash (nth 0 ',keys) *multi-tile-function-map*)
122 (function ,fun-name)))))
123
124 (defmacro define-tile (char type)
125 (let ((tile-type (make-keyword (string type))))
126 `(push (list ,char ,tile-type) *symbol-map*)))
127
128 (defmacro define-generator (char tile-type generator-type)
129 (let ((tile-type (make-keyword (string tile-type))))
130 `(progn
131 (push (list ,char ,tile-type) *symbol-map*)
132 (push (list ,char ',generator-type) *tile-generator-data*))))
133
134 (defun tile-from-map (x y &optional actual-type)
135 (unless *symbol-map*
136 (setf *symbol-map* (make-hash-table))
137 (loop for (char tile) in *symbol-map-data*
138 do (setf (gethash char *symbol-map*) tile)))
139 (let* ((char (aref (mapdata *current-map*) x y))
140 (tile-type (gethash char *symbol-map*)))
141 (cond ((null tile-type)
142 (error
143 "Unknown map symbol ~C, map reference (~D,~D), map sequence #~D~%"
144 char x y (seq *current-map*)))
145 ((gethash tile-type *multi-tile-function-map*)
146 (funcall (gethash tile-type *multi-tile-function-map*) x y))
147 ((member char *tile-generator-data* :key #'car)
148 (if actual-type
149 tile-type
150 (gethash (list x y) *generator-map*)))
151 (t tile-type))))
152
153 (defun set-tile-from-map (x y new)
154 (unless *tile-map*
155 (setf *tile-map* (make-hash-table))
156 (loop for (char tile) in *symbol-map-data*
157 do (setf (gethash tile *tile-map*) char))
158
159 (setf *tiles-with-direction*
160 (remove-duplicates *tiles-with-direction*
161 :key 'car))
162 (loop for tile-map in *tiles-with-direction*
163 do (loop with base = (car tile-map)
164 for other in (cdr tile-map)
165 do (setf (gethash other *tile-map*)
166 (gethash base *tile-map*)))))
167
168 (let ((char (gethash new *tile-map*)))
169 (when char
170 (setf (aref (mapdata *current-map*) x y) char))))
171
172 (defsetf tile-from-map set-tile-from-map)
173
174 (defun find-starting-position (map)
175 (let ((width (width map))
176 (height (height map))
177 (ar (mapdata map)))
178 (loop for y from 0 below height
179 do (loop for x from 0 below width
180 if (char= (aref ar x y) #\S)
181 do (return-from find-starting-position (list x y))))))

  ViewVC Help
Powered by ViewVC 1.1.5