├── maze.txt ├── matrix.el ├── server-maze.el ├── 3dmaze.el └── client-maze.el /maze.txt: -------------------------------------------------------------------------------- 1 | ************************** 2 | *S* * * 3 | * * * * ************* * 4 | * * * ************ * 5 | * * * 6 | ************** *********** 7 | * * 8 | ** *********************** 9 | * * G * 10 | * * *********** * * 11 | * * ******* * * 12 | * * * 13 | ************************** 14 | -------------------------------------------------------------------------------- /matrix.el: -------------------------------------------------------------------------------- 1 | (require 'cl) 2 | 3 | ;;; Vector 4 | 5 | (defstruct mt:v dim x) 6 | 7 | (defsubst mt:vnew (elms) 8 | (make-mt:v :dim (length elms) :x elms)) 9 | 10 | (defsubst mt:vcp (v) 11 | (mt:vnew (vconcat (mt:v-x v)))) 12 | 13 | ;; getter and setter 14 | 15 | (defsubst mt:vref (v i) 16 | (aref (mt:v-x v) i)) 17 | 18 | (defsubst mt:vset (v i a) 19 | (aset (mt:v-x v) i a)) 20 | 21 | (defun mt:vset2d (v x y) 22 | (let ((ar (mt:v-x v))) 23 | (aset ar 0 x) (aset ar 1 y) v)) 24 | 25 | ;; scalar multiply 26 | 27 | (defun mt:sxv (s v) 28 | "scalar multiply. return new value." 29 | (loop for i from 0 below (mt:v-dim v) 30 | with r = (mt:vcp v) 31 | do (mt:vset r i (* s (mt:vref v i))) 32 | finally return r)) 33 | 34 | (defun mt:sxv2d (s v) 35 | (let ((ar (mt:v-x v))) 36 | (make-mt:v 37 | :dim 2 38 | :x (vector (* s (aref ar 0)) 39 | (* s (aref ar 1)))))) 40 | 41 | (defun mt:sxv= (s v) 42 | "scalar multiply. return value." 43 | (loop for i from 0 below (mt:v-dim v) 44 | do (mt:vset v i (* s (mt:vref v i))) 45 | finally return v)) 46 | 47 | (defun mt:sxv2d= (s v) 48 | (let ((ar (mt:v-x v))) 49 | (aset ar 0 (* s (aref ar 0))) 50 | (aset ar 1 (* s (aref ar 1)))) 51 | v) 52 | 53 | ;; add and subtract 54 | 55 | (defun mt:vbin (op a b) 56 | "binary operator. return new value." 57 | (let ((r (mt:vcp a)) (dim (mt:v-dim a))) 58 | (loop for i from 0 below dim 59 | do (mt:vset r i (funcall op (mt:vref a i) (mt:vref b i)))) 60 | r)) 61 | 62 | (defun mt:vbin= (op a b) 63 | "binary operator. substitute a." 64 | (let ((dim (mt:v-dim a))) 65 | (loop for i from 0 below dim 66 | do (mt:vset a i (funcall op (mt:vref a i) (mt:vref b i)))) 67 | a)) 68 | 69 | (defmacro mt:def-vbin2d (name op) 70 | `(defun ,name (a b) 71 | (let ((aa (mt:v-x a)) (bb (mt:v-x b))) 72 | (make-mt:v 73 | :dim 2 74 | :x (vector (,op (aref aa 0) (aref bb 0)) 75 | (,op (aref aa 1) (aref bb 1))))))) 76 | 77 | (defmacro mt:def-vbin2d= (name op) 78 | `(defun ,name (a b) 79 | (let ((aa (mt:v-x a)) (bb (mt:v-x b))) 80 | (aset aa 0 (,op (aref aa 0) (aref bb 0))) 81 | (aset aa 1 (,op (aref aa 1) (aref bb 1))) 82 | a))) 83 | 84 | (defun mt:v+v (a b) 85 | "plus. return new value." 86 | (mt:vbin '+ a b)) 87 | 88 | (defun mt:v-v (a b) 89 | "minus. return new value." 90 | (mt:vbin '- a b)) 91 | 92 | (defun mt:v+v= (a b) 93 | "plus. substitute a." 94 | (mt:vbin= '+ a b)) 95 | 96 | (defun mt:v-v= (a b) 97 | "minus. substitute a." 98 | (mt:vbin= '- a b)) 99 | 100 | (mt:def-vbin2d mt:v+v2d +) 101 | (mt:def-vbin2d mt:v-v2d -) 102 | (mt:def-vbin2d= mt:v+v2d= +) 103 | (mt:def-vbin2d= mt:v-v2d= -) 104 | 105 | ;; vector operations 106 | 107 | (defun mt:vlen (a) 108 | "return a length of vector a." 109 | (let ((sq 0) (dim (mt:v-dim a))) 110 | (loop for i from 0 below dim 111 | for ii = (mt:vref a i) 112 | do (incf sq (* ii ii))) 113 | (sqrt (float sq)))) 114 | 115 | (defun mt:vlen2d (a) 116 | (let* ((aa (mt:v-x a)) 117 | (ax (aref aa 0)) (ay (aref aa 1))) 118 | (sqrt (float (+ (* ax ax) (* ay ay)))))) 119 | 120 | (defun mt:vip (a b) 121 | "return inner product." 122 | (loop for i from 0 below (mt:v-dim a) 123 | with ret = 0 do 124 | (incf ret (* (mt:vref a i) (mt:vref b i))) 125 | finally return ret)) 126 | 127 | (defun mt:vop (a b) 128 | "return outer product." 129 | (cond 130 | ((and (eql (mt:v-dim a) 2) (eql (mt:v-dim b) 2)) 131 | (- (* (mt:vref a 0) (mt:vref b 1)) (* (mt:vref a 1) (mt:vref b 0)))) 132 | (t 133 | (error "Not supported outer product. %S %S" a b)))) 134 | 135 | (defun mt:vunit (a) 136 | "return new unit vector along the vector a." 137 | (mt:sxv (/ 1.0 (mt:vlen a)) a)) 138 | 139 | (defun mt:vnorm (a) 140 | (cond 141 | ((eql (mt:v-dim a) 2) 142 | (mt:vnew (vector (- (mt:vref a 1)) (mt:vref a 0)))) 143 | (t 144 | (error "Not supported normal vector. %S" a)))) 145 | 146 | (defun mt:vzero (dim) 147 | (mt:vnew (make-vector dim 0))) 148 | 149 | (defun mt:vfloor (a) 150 | (loop for i from 0 below (mt:v-dim a) 151 | do 152 | (mt:vset a i (floor (mt:vref a i))) 153 | finally return a)) 154 | 155 | (defun mt:vfloor2d (a) 156 | (let ((aa (mt:v-x a))) 157 | (aset aa 0 (floor (aref aa 0))) 158 | (aset aa 1 (floor (aref aa 1))) 159 | a)) 160 | 161 | 162 | ;;; Matrix 163 | 164 | (defstruct mt:m dim v) 165 | 166 | (defun mt:mnew (dim elms) 167 | (make-mt:m :dim dim :v elms)) 168 | 169 | (defun mt:mcp (m) 170 | (make-mt:m :dim (mt:m-dim m) :v (vconcat (mt:m-v m)))) 171 | 172 | ;; getter and setter 173 | 174 | (defun mt:mref (m i j) 175 | (aref (mt:m-v m) (+ (* j (mt:m-dim m)) i))) 176 | 177 | (defun mt:mset (m i j a) 178 | (aset (mt:m-v m) (+ (* j (mt:m-dim m)) i) a)) 179 | 180 | ;; add and subtract 181 | 182 | (defun mt:mbin (op a b) 183 | (let ((r (mt:mcp a)) (dim (mt:m-dim a))) 184 | (loop for i from 0 below dim do 185 | (loop for j from 0 below dim do 186 | (mt:mset r i j 187 | (funcall op (mt:mref a i j) (mt:mref b i j))))) 188 | r)) 189 | 190 | (defun mt:mbin= (op a b) 191 | (let ((dim (mt:m-dim a))) 192 | (loop for i from 0 below dim do 193 | (loop for j from 0 below dim do 194 | (mt:mset a i j 195 | (funcall op (mt:mref a i j) (mt:mref b i j))))) 196 | a)) 197 | 198 | (defun mt:m+m (a b) 199 | (mt:mbin '+ a b)) 200 | 201 | (defun mt:m-m (a b) 202 | (mt:mbin '- a b)) 203 | 204 | (defun mt:m+m= (a b) 205 | (mt:mbin= '+ a b)) 206 | 207 | (defun mt:m-m= (a b) 208 | (mt:mbin= '- a b)) 209 | 210 | ;; multiply 211 | 212 | (defun mt:mxm (a b) 213 | (let ((r (mt:mcp a)) (dim (mt:m-dim a)) s) 214 | (loop for i from 0 below dim do 215 | (loop for j from 0 below dim do 216 | (setq s 0) 217 | (loop for k from 0 below dim 218 | for av = (mt:mref a k j) 219 | for bv = (mt:mref b i k) do 220 | (incf s (* av bv))) 221 | (mt:mset r i j s))) 222 | r)) 223 | 224 | (defun mt:sxm (s m) 225 | (let ((r (mt:mcp m)) (dim (mt:m-dim m))) 226 | (loop for i from 0 below dim do 227 | (loop for j from 0 below dim do 228 | (mt:mset r i j (* s (mt:mref m i j))))) 229 | r)) 230 | 231 | (defun mt:sxm2d (s m) 232 | (let ((aa (mt:m-v m))) 233 | (make-mt:m 234 | :dim 2 235 | :v (vector 236 | (* s (aref aa 0)) 237 | (* s (aref aa 1)) 238 | (* s (aref aa 2)) 239 | (* s (aref aa 3)))))) 240 | 241 | (defun mt:sxm= (s m) 242 | (let ((dim (mt:m-dim m))) 243 | (loop for i from 0 below dim do 244 | (loop for j from 0 below dim do 245 | (mt:mset m i j (* s (mt:mref m i j))))) 246 | m)) 247 | 248 | (defun mt:sxm2d= (s m) 249 | (let ((aa (mt:m-v m))) 250 | (aset aa 0 (* s (aref aa 0))) 251 | (aset aa 1 (* s (aref aa 1))) 252 | (aset aa 2 (* s (aref aa 2))) 253 | (aset aa 3 (* s (aref aa 3))))) 254 | 255 | (defun mt:mxv (m v) 256 | "multiply matrix and vector. return new vector." 257 | (let ((r (mt:vcp v)) (dim (mt:v-dim v))) 258 | (loop for i from 0 below dim 259 | do (mt:vset r i 260 | (loop for j from 0 below dim 261 | with s = 0 262 | do (incf s (* (mt:vref v j) (mt:mref m j i))) 263 | finally return s))) 264 | r)) 265 | 266 | (defun mt:vxm (v m) 267 | "multiply matrix and vector. return new vector." 268 | (let ((r (mt:vcp v)) (dim (mt:v-dim v))) 269 | (loop for i from 0 below dim 270 | do (mt:vset r i 271 | (loop for j from 0 below dim 272 | with s = 0 273 | do (incf s (* (mt:vref v j) (mt:mref m i j))) 274 | finally return s))) 275 | r)) 276 | 277 | (defun mt:mxv2d (m v) 278 | (let* ((mm (mt:m-v m)) (vv (mt:v-x v)) 279 | (v1 (aref vv 0)) (v2 (aref vv 1))) 280 | (make-mt:v 281 | :dim 2 282 | :x (vector 283 | (+ (* v1 (aref mm 0)) (* v2 (aref mm 1))) 284 | (+ (* v1 (aref mm 2)) (* v2 (aref mm 3))))))) 285 | 286 | (defun mt:vxm2d (v m) 287 | (let* ((mm (mt:m-v m)) (vv (mt:v-x v)) 288 | (v1 (aref vv 0)) (v2 (aref vv 1))) 289 | (make-mt:v 290 | :dim 2 291 | :x (vector 292 | (+ (* v1 (aref mm 0)) (* v2 (aref mm 2))) 293 | (+ (* v1 (aref mm 1)) (* v2 (aref mm 3))))))) 294 | 295 | (defun mt:mxv= (m v r) 296 | "multiply matrix and vector. return new vector." 297 | (let ((dim (mt:v-dim v))) 298 | (loop for i from 0 below dim 299 | do (mt:vset r i 300 | (loop for j from 0 below dim 301 | with s = 0 302 | do (incf s (* (mt:vref v j) (mt:mref m j i))) 303 | finally return s))) 304 | r)) 305 | 306 | (defun mt:vxm= (v m r) 307 | "multiply matrix and vector. return new vector." 308 | (let ((dim (mt:v-dim v))) 309 | (loop for i from 0 below dim 310 | do (mt:vset r i 311 | (loop for j from 0 below dim 312 | with s = 0 313 | do (incf s (* (mt:vref v j) (mt:mref m i j))) 314 | finally return s))) 315 | r)) 316 | 317 | (defun mt:mxv2d= (m v r) 318 | (let* ((mm (mt:m-v m)) (vv (mt:v-x v)) (rr (mt:v-x r)) 319 | (v1 (aref vv 0)) (v2 (aref vv 1))) 320 | (aset rr 0 (+ (* v1 (aref mm 0)) (* v2 (aref mm 1)))) 321 | (aset rr 1 (+ (* v1 (aref mm 2)) (* v2 (aref mm 3)))) 322 | r)) 323 | 324 | (defun mt:vxm2d= (v m r) 325 | (let* ((mm (mt:m-v m)) (vv (mt:v-x v)) (rr (mt:v-x r)) 326 | (v1 (aref vv 0)) (v2 (aref vv 1))) 327 | (aset rr 0 (+ (* v1 (aref mm 0)) (* v2 (aref mm 2)))) 328 | (aset rr 1 (+ (* v1 (aref mm 1)) (* v2 (aref mm 3)))) 329 | r)) 330 | 331 | ;; matrix utility 332 | 333 | (defun mt:mzero (dim) 334 | (mt:mnew dim (make-vector (* dim dim) 0))) 335 | 336 | (defun mt:munit (dim) 337 | (let ((ret (mt:mzero dim))) 338 | (loop for i from 0 below dim do 339 | (mt:mset ret i i 1)) 340 | ret)) 341 | 342 | (defun mt:mrot2d (rad) 343 | (let ((c (cos rad)) (s (sin rad))) 344 | (mt:mnew 345 | 2 (vector c (- s) s c)))) 346 | 347 | (defun mt:mfloor (a) 348 | (let* ((ar (mt:m-v a)) (len (length ar))) 349 | (loop for i from 0 below len 350 | do 351 | (aset ar i (floor (aref ar i))) 352 | finally return a))) 353 | 354 | (defun mt:mfloor2d (a) 355 | (let* ((ar (mt:m-v a))) 356 | (aset ar 0 (floor (aref ar 0))) 357 | (aset ar 1 (floor (aref ar 1))) 358 | (aset ar 2 (floor (aref ar 2))) 359 | (aset ar 3 (floor (aref ar 3))) 360 | a)) 361 | 362 | 363 | ;;; test 364 | 365 | (defvar mt:test-counter nil) 366 | 367 | (defun mt:begin-test () 368 | (when (get-buffer "*matrix:test*") 369 | (kill-buffer "*matrix:test*")) 370 | (setq mt:test-counter (cons 0 0))) 371 | 372 | (defun mt:end-test () 373 | (mt:test-output 374 | (format "--------------------\nPass: %s Error: %s" 375 | (car mt:test-counter) (cdr mt:test-counter)))) 376 | 377 | (defun mt:test-output (msg) 378 | (pop-to-buffer "*matrix:test*") 379 | (goto-char (point-max)) 380 | (insert msg "\n")) 381 | 382 | (defun mt:ok (msg left right) 383 | (cond 384 | ((equal left right) 385 | (mt:test-output (format "OK: %s" msg)) 386 | (incf (car mt:test-counter))) 387 | (t 388 | (mt:test-output 389 | (let ((text (format "NG: %s : %S : %S" msg left right))) 390 | (put-text-property 0 (length text) 'face 'compilation-error text) 391 | text)) 392 | (incf (cdr mt:test-counter))))) 393 | 394 | (defun mt:test () 395 | (interactive) 396 | (mt:begin-test) 397 | 398 | ;; vector - vector 399 | (let* ((a (mt:vnew [1 2])) (al (sqrt 5)) 400 | (b (mt:vnew [3 -1]))) 401 | (mt:ok "v+v" (mt:v+v a b) (mt:vnew [4 1])) 402 | (mt:ok "v-v" (mt:v-v a b) (mt:vnew [-2 3])) 403 | (mt:ok "sxv" (mt:sxv 4 a) (mt:vnew [4 8])) 404 | (mt:ok "v+v=" (mt:v+v= (mt:vcp a) b) (mt:vnew [4 1])) 405 | (mt:ok "v-v=" (mt:v-v= (mt:vcp a) b) (mt:vnew [-2 3])) 406 | (mt:ok "sxv=" (mt:sxv= 4 (mt:vcp a)) (mt:vnew [4 8])) 407 | (mt:ok "vip" (mt:vip a b) 1) 408 | (mt:ok "vop" (mt:vop a b) -7) 409 | (mt:ok "vlen" (mt:vlen a) al) 410 | (mt:ok "vunit" (mt:vunit a) (mt:vnew (vector (/ 1.0 al) (/ 2 al)))) 411 | (mt:ok "vnorm" (mt:vnorm a) (mt:vnew (vector -2 1 ))) 412 | (mt:ok "vip norm" (mt:vip a (mt:vnorm a)) 0) 413 | (mt:ok "vzero" (mt:vzero 2) (mt:vnew [0 0])) 414 | (mt:ok "vfloor" (mt:vfloor (mt:vnew [0.1 1.1])) (mt:vnew [0 1])) 415 | ) 416 | 417 | ;; 2D / vector - vector 418 | (let* ((a (mt:vnew [1 2])) (al (sqrt 5)) 419 | (b (mt:vnew [3 -1]))) 420 | (mt:ok "v+v2d" (mt:v+v2d a b) (mt:vnew [4 1])) 421 | (mt:ok "v-v2d" (mt:v-v2d a b) (mt:vnew [-2 3])) 422 | (mt:ok "sxv2d" (mt:sxv2d 4 a) (mt:vnew [4 8])) 423 | (mt:ok "v+v2d=" (mt:v+v2d= (mt:vcp a) b) (mt:vnew [4 1])) 424 | (mt:ok "v-v2d=" (mt:v-v2d= (mt:vcp a) b) (mt:vnew [-2 3])) 425 | (mt:ok "sxv2d=" (mt:sxv2d= 4 (mt:vcp a)) (mt:vnew [4 8])) 426 | (mt:ok "vlen2d" (mt:vlen2d a) al) 427 | (mt:ok "vfloor2d" (mt:vfloor2d (mt:vnew [0.1 1.1])) (mt:vnew [0 1])) 428 | ) 429 | 430 | ;; matrix - matrix 431 | (let* ((a (mt:mnew 2 [1 2 3 4])) 432 | (b (mt:mnew 2 [5 6 7 8])) 433 | (c (mt:mnew 2 [7 6 3 2]))) 434 | (mt:ok "m+m1" (mt:m+m a b) (mt:mnew 2 [6 8 10 12])) 435 | (mt:ok "m-m1" (mt:m-m a b) (mt:mnew 2 [-4 -4 -4 -4])) 436 | (mt:ok "m+m2" (mt:m+m a c) (mt:mnew 2 [8 8 6 6])) 437 | (mt:ok "m-m2" (mt:m-m a c) (mt:mnew 2 [-6 -4 0 2])) 438 | (mt:ok "m+m=1" (mt:m+m (mt:mcp a) b) (mt:mnew 2 [6 8 10 12])) 439 | (mt:ok "m-m=1" (mt:m-m (mt:mcp a) b) (mt:mnew 2 [-4 -4 -4 -4])) 440 | (mt:ok "sxm" (mt:sxm 2 a) (mt:mnew 2 [2 4 6 8])) 441 | (mt:ok "sxm=" (mt:sxm 2 (mt:mcp a)) (mt:mnew 2 [2 4 6 8])) 442 | (mt:ok "mxm1" (mt:mxm a b) (mt:mnew 2 [19 22 43 50])) 443 | (mt:ok "mxm2" (mt:mxm a c) (mt:mnew 2 [13 10 33 26])) 444 | (mt:ok "munit" (mt:munit 2) (mt:mnew 2 [1 0 0 1])) 445 | (mt:ok "mzero" (mt:mzero 2) (mt:mnew 2 [0 0 0 0])) 446 | (mt:ok "mfloor" (mt:mfloor (mt:mnew 2 [0.1 -0.1 1.1 -1.1])) (mt:mnew 2 [0 -1 1 -2]))) 447 | 448 | ;; 2D matrix - matrix 449 | (let* ((a (mt:mnew 2 [1 2 3 4])) 450 | (b (mt:mnew 2 [5 6 7 8])) 451 | (c (mt:mnew 2 [7 6 3 2]))) 452 | (mt:ok "sxm/2d" (mt:sxm2d 2 a) (mt:mnew 2 [2 4 6 8])) 453 | (mt:ok "sxm=/2d" (mt:sxm2d 2 (mt:mcp a)) (mt:mnew 2 [2 4 6 8])) 454 | (mt:ok "mfloor/2d" (mt:mfloor2d (mt:mnew 2 [0.1 -0.1 1.1 -1.1])) (mt:mnew 2 [0 -1 1 -2]))) 455 | 456 | ;;matrix - vector 457 | (let* ((m1 (mt:mnew 2 [1 -2 5 3])) 458 | (m2 (mt:mnew 2 [3 1 -2 7])) 459 | (v1 (mt:vnew [2 3]))) 460 | (mt:ok "mxm " (mt:mxm m1 m2) (mt:mnew 2 [7 -13 9 26])) 461 | (mt:ok "mxv1" (mt:mxv m1 v1) (mt:vnew [-4 19])) 462 | (mt:ok "vxm1" (mt:vxm v1 m1) (mt:vnew [17 5])) 463 | (mt:ok "mxv=1" (mt:mxv= m1 v1 (mt:vcp v1)) (mt:vnew [-4 19])) 464 | (mt:ok "vxm=1" (mt:vxm= v1 m1 (mt:vcp v1)) (mt:vnew [17 5])) 465 | (mt:ok "mxv2" (mt:mxv m2 v1) (mt:vnew [9 17])) 466 | (mt:ok "vxm2" (mt:vxm v1 m2) (mt:vnew [0 23]))) 467 | 468 | ;; 2D matrix - vector 469 | (let* ((m1 (mt:mnew 2 [1 -2 5 3])) 470 | (m2 (mt:mnew 2 [3 1 -2 7])) 471 | (v1 (mt:vnew [2 3]))) 472 | (mt:ok "mxv1/2d" (mt:mxv2d m1 v1) (mt:vnew [-4 19])) 473 | (mt:ok "vxm1/2d" (mt:vxm2d v1 m1) (mt:vnew [17 5])) 474 | (mt:ok "mxv=1/2d" (mt:mxv2d= m1 v1 (mt:vcp v1)) (mt:vnew [-4 19])) 475 | (mt:ok "vxm=1/2d" (mt:vxm2d= v1 m1 (mt:vcp v1)) (mt:vnew [17 5])) 476 | (mt:ok "mxv2/2d" (mt:mxv2d m2 v1) (mt:vnew [9 17])) 477 | (mt:ok "vxm2/2d" (mt:vxm2d v1 m2) (mt:vnew [0 23]))) 478 | 479 | (mt:end-test)) 480 | 481 | ;; (progn (eval-current-buffer) (mt:test)) 482 | 483 | (provide 'matrix) 484 | -------------------------------------------------------------------------------- /server-maze.el: -------------------------------------------------------------------------------- 1 | ;;; server-maze.el --- server for maze clients 2 | 3 | ;; Copyright (C) 2011 SAKURAI Masashi 4 | 5 | ;; Author: SAKURAI Masashi 6 | ;; Keywords: games 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; TODO 24 | ;; メインのスレッド化 25 | ;; 移動まとめる 26 | 27 | ;; ■プロトコル 28 | 29 | ;; S:Server, Ca:Target Client, Cn:All Clients 30 | 31 | ;; ○接続時 32 | ;; Ca > S | (name string:name) 33 | ;; S > Ca | (map int:width int:height string:maptext int:id float:init-x float:init-y float:angle) ; マップ生成 34 | ;; S > Ca | (move list:(int:id string:name float:x float:y float:angle)) ; 移動通知でみんなのデータもらう。ここで更新 35 | ;; 36 | ;; ○接続通知 37 | ;; S > Cn | (connect int:id string:name float:x float:y float:angle) 38 | ;; 39 | ;; ○移動時 40 | ;; Ca > S | (move float:x float:y float:angle) 41 | ;; 42 | ;; ○移動通知 43 | ;; S > Cn | (move list:(int:id string:name float:x float:y float:angle)) 44 | ;; 45 | ;; ○切断通知 46 | ;; S > Cn | (disconnect int:id string:name) 47 | 48 | 49 | 50 | ;;; Code: 51 | 52 | (require 'cl) 53 | (require 'derived) 54 | (require 'concurrent) 55 | (require 'matrix) 56 | 57 | (defstruct ssm:map width height maptext map objects) 58 | (defstruct ssm:client id name x y angle) 59 | 60 | (defvar ssm:scale 10.0 "MAP上の1文字のサイズ。壁の高さ。") 61 | (defvar ssm:server-process-name "server-maze") 62 | (defvar ssm:server-port 8765) 63 | (defvar ssm:server-address nil "ホストのアドレス") 64 | 65 | ;; 現在保持している地図 66 | (defvar ssm:map nil) 67 | 68 | ;; クライアント一覧 (list (process . client)...) 69 | (defvar ssm:client-processes nil) 70 | 71 | ;; signal-channel ここに送るとクライアント全員にメッセージを送る 72 | (defvar ssm:message-server nil) 73 | 74 | 75 | 76 | ;;================================================== 77 | ;; Utilities 78 | 79 | (defvar ssm:debug-out t) 80 | (defvar ssm:debug-buffer "*ssm log*") 81 | 82 | (defun ssm:log-init () 83 | (when (get-buffer ssm:debug-buffer) 84 | (kill-buffer ssm:debug-buffer))) 85 | 86 | (defun ssm:log (&rest args) 87 | (when ssm:debug-out 88 | (with-current-buffer 89 | (get-buffer-create ssm:debug-buffer) 90 | (buffer-disable-undo) 91 | (goto-char (point-max)) 92 | (insert (apply 'format args) "\n")))) 93 | 94 | (defun ssm:define-keymap (keymap-list) 95 | (let ((map (make-sparse-keymap))) 96 | (mapc 97 | (lambda (i) 98 | (define-key map 99 | (if (stringp (car i)) 100 | (read-kbd-macro (car i)) (car i)) 101 | (cdr i))) 102 | keymap-list) 103 | map)) 104 | 105 | 106 | ;;================================================== 107 | ;; Map utilities 108 | 109 | (defun ssm:build-map (src) 110 | (let* ((lines (split-string src "\n")) 111 | (width (loop for i in lines maximize (length i))) 112 | (height (length lines)) 113 | (ret (make-vector (* width height) 1))) 114 | (loop for line in lines 115 | for j from 0 below (length lines) 116 | do 117 | (loop for c across line 118 | for s = (char-to-string c) 119 | for i from 0 below (length line) 120 | for idx = (+ i (* width j)) 121 | do 122 | (aset ret idx 123 | (if (or (eql c ?#) (eql c ?*)) 1 0)))) 124 | (make-ssm:map :width width :height height 125 | :maptext 126 | (loop for i across ret 127 | concat (if (< 0 i) "#" " ")) 128 | :map ret))) 129 | 130 | (defun ssm:search-blank-pos (map) 131 | (mt:sxv 132 | ssm:scale 133 | (mt:v+v (mt:vnew [0.5 0.5]) 134 | (loop with w = (ssm:map-width map) 135 | with h = (ssm:map-height map) 136 | for i from 0 to 1000 137 | for x = (random w) for y = (random h) 138 | for idx = (+ x (* y w)) 139 | do 140 | (when (= 0 (aref (ssm:map-map map) idx)) 141 | (return (mt:vnew (vector x y)))) 142 | finally return (mt:vnew (vector 1 1)))))) 143 | 144 | (defun ssm:search-open-angle (map posv) 145 | (let* ((pos (mt:vfloor (mt:sxv (/ 1.0 ssm:scale) posv))) 146 | (x0 (mt:vref pos 0)) (y0 (mt:vref pos 1)) 147 | (array (ssm:map-map map)) 148 | (w (ssm:map-width map))) 149 | (labels 150 | ((check (x y) 151 | (let ((idx (+ x (* y w)))) 152 | (and (< idx (length array)) 153 | (= 0 (aref array idx)))))) 154 | (cond 155 | ((check (1+ x0) y0) 0) 156 | ((check (1- x0) y0) 180) 157 | ((check x0 (1+ y0)) 90) 158 | ((check x0 (1- y0)) 270) 159 | (t 90))))) 160 | 161 | ;; (ssm:search-open-angle ssm:map (mt:vnew (vector 35 15))) 162 | 163 | 164 | ;;================================================== 165 | ;; Client process 166 | 167 | (defvar ssm:uid 1) 168 | 169 | (defun ssm:uid () 170 | (incf ssm:uid)) 171 | 172 | (defun ssm:client-get-by-process (proc) 173 | (loop for (pp . client) in ssm:client-processes 174 | if (eq pp proc) 175 | do (return client) 176 | finally return nil)) 177 | 178 | (defun ssm:client-get-by-id (id) 179 | (loop for (pp . client) in ssm:client-processes 180 | if (eq id (ssm:client-id client)) 181 | do (return client) 182 | finally return nil)) 183 | 184 | (defun ssm:process-get-by-id (id) 185 | (loop for (pp . client) in ssm:client-processes 186 | if (eq id (ssm:client-id client)) 187 | do (return pp) 188 | finally return nil)) 189 | 190 | (defun ssm:make-msg-init (map client) 191 | (format "%S\n" 192 | (list 'map 193 | (ssm:map-width map) 194 | (ssm:map-height map) 195 | (ssm:map-maptext map) 196 | (ssm:client-id client) 197 | (ssm:client-x client) 198 | (ssm:client-y client) 199 | (ssm:client-angle client)))) 200 | 201 | (defun ssm:make-msg-move (clients) 202 | (format 203 | "%S\n" 204 | (list 'move 205 | (loop for i in clients 206 | collect 207 | (list (ssm:client-id i) 208 | (ssm:client-name i) 209 | (ssm:client-x i) 210 | (ssm:client-y i) 211 | (ssm:client-angle i)))))) 212 | 213 | (defun ssm:make-msg-connect (client) 214 | (format "%S\n" (list 'connect 215 | (ssm:client-id client) 216 | (ssm:client-name client) 217 | (ssm:client-x client) 218 | (ssm:client-y client) 219 | (ssm:client-angle client)))) 220 | 221 | (defun ssm:make-msg-disconnect (client) 222 | (format "%S\n" (list 'disconnect 223 | (ssm:client-id client) 224 | (ssm:client-name client)))) 225 | 226 | (defun ssm:client-connect (message proc) 227 | (ssm:log "++ CONNECT [%s] %S" message proc) 228 | (let* ((content (read message)) 229 | (name (cadr content)) 230 | (posv (ssm:search-blank-pos ssm:map)) 231 | (client (make-ssm:client 232 | :id (ssm:uid) 233 | :name name 234 | :x (mt:vref posv 0) 235 | :y (mt:vref posv 1) 236 | :angle (ssm:search-open-angle ssm:map posv)))) 237 | (ssm:log " [%S]" client) 238 | (process-send-string 239 | proc (ssm:make-msg-init ssm:map client)) 240 | (process-send-string 241 | proc (ssm:make-msg-move (mapcar 'cdr ssm:client-processes))) 242 | (cc:signal-send ssm:message-server 243 | 'ssm:all (ssm:make-msg-connect client)) 244 | (setq ssm:client-processes 245 | (cons (cons proc client) 246 | ssm:client-processes)))) 247 | 248 | (defun ssm:client-move (proc client message) 249 | (ssm:log "<< RECEIVE %s : %s" (ssm:client-name client) line) 250 | (let* ((content (read message)) 251 | (x (nth 1 content)) 252 | (y (nth 2 content)) 253 | (a (nth 3 content))) 254 | (setf (ssm:client-x client) x) 255 | (setf (ssm:client-y client) y) 256 | (setf (ssm:client-angle client) a) 257 | (cc:signal-send 258 | ssm:message-server 259 | 'ssm:all (ssm:make-msg-move (list client))))) 260 | 261 | (defun ssm:client-disconnect (client) 262 | (ssm:log "DISCONNECT %s" (ssm:client-name client)) 263 | (cc:signal-send 264 | ssm:message-server 265 | 'ssm:all (ssm:make-msg-disconnect client))) 266 | 267 | (defun ssm:client-ban (client) 268 | (ssm:log "BAN %s" (ssm:client-name client)) 269 | (ssm:client-abort (ssm:process-get-by-id (ssm:client-id client)))) 270 | 271 | (defun ssm:client-abort (process) 272 | (ssm:log "ABORT %S" process) 273 | (when process 274 | (delete-process process))) 275 | 276 | 277 | ;;================================================== 278 | ;; Server 279 | 280 | (defun ssm:client-listener (process message) 281 | (let ((client (ssm:client-get-by-process process)) 282 | (line (substring message 0 -1))) 283 | (cond 284 | ((null client) 285 | (condition-case err 286 | (ssm:client-connect line process) 287 | ('error 288 | (ssm:log "Protocol error: %S" err) 289 | (ssm:client-abort process)))) 290 | (t 291 | (condition-case err 292 | (ssm:client-move process client line) 293 | ('error 294 | (ssm:log "Protocol error: %S" err))))))) 295 | 296 | (defun ssm:client-sentinel (process msg) 297 | (setq ssm:client-processes 298 | (loop for (proc . client) in ssm:client-processes 299 | unless (eq process proc) 300 | collect (cons proc client) 301 | else 302 | do 303 | (ssm:client-disconnect client)))) 304 | 305 | (defun ssm:client-send-message (args) 306 | (destructuring-bind (event (message)) args 307 | (cond 308 | ((eq 'ssm:all event) 309 | (loop for (prc . client) in ssm:client-processes 310 | do 311 | (process-send-string prc (concat message "\n")) 312 | (ssm:log ">> SENT %s" (ssm:client-name client)))) 313 | (t 314 | (ssm:log "!! Not supported message type: %s / %S" event message))))) 315 | 316 | (defun ssm:server-start () 317 | (interactive) 318 | (ssm:log-init) 319 | (let ((maze-buf (find-file-noselect "maze.txt"))) 320 | (setq ssm:map 321 | (ssm:build-map 322 | (with-current-buffer maze-buf 323 | (buffer-string))))) 324 | (setq ssm:client-processes nil) 325 | (setq ssm:message-server (cc:signal-channel 'ssm:server)) 326 | (cc:signal-connect ssm:message-server 327 | 'ssm:all 'ssm:client-send-message) 328 | (make-network-process 329 | :name ssm:server-process-name 330 | :buffer "*message-server*" 331 | :family 'ipv4 :server t 332 | :host ssm:server-address :service ssm:server-port 333 | :sentinel 'ssm:client-sentinel 334 | :filter 'ssm:client-listener) 335 | (ssm:log "SERVER START") 336 | (ssm:open-management-buffer)) 337 | 338 | (defun ssm:server-stop () 339 | (interactive) 340 | (loop for (proc . client) in ssm:client-processes 341 | do (delete-process proc) 342 | (ssm:log "DELETE CLIENT : %s" (ssm:client-name client))) 343 | (setq ssm:client-processes nil) 344 | (delete-process ssm:server-process-name) 345 | (ssm:log "SERVER STOP")) 346 | 347 | 348 | ;;================================================== 349 | ;; Management buffer 350 | 351 | ;; run で動作中 stop で停止指示 nil で停止中 352 | (defvar ssm:management-thread nil) 353 | (defvar ssm:management-thread-on-finish nil) 354 | 355 | (defun ssm:management-thread-start () 356 | (when (null ssm:management-thread) 357 | (setq ssm:management-thread 'run) 358 | (ssm:log ">> Management Thread Start:") 359 | (cc:thread 360 | 1000 361 | (while (eq ssm:management-thread 'run) 362 | (with-current-buffer 363 | (get-buffer ssm:management-buffer) 364 | (ssm:management-update-buffer))) 365 | (progn 366 | (ssm:log "<< Management Thread Stop:") 367 | (setq ssm:management-thread nil) 368 | (funcall ssm:management-thread-on-finish))))) ; 停止処理 369 | 370 | (defun ssm:management-thread-stop (on-finish-task) 371 | (cond 372 | ((eq ssm:management-thread 'run) 373 | (setq ssm:management-thread-on-finish on-finish-task) 374 | (setq ssm:management-thread 'stop)) 375 | (t (funcall on-finish-task)))) 376 | 377 | (defvar ssm:management-mode-map 378 | (ssm:define-keymap 379 | '( 380 | ("g" . ssm:management-update-buffer) 381 | ("b" . ssm:management-ban-client) 382 | ("q" . ssm:management-quit) 383 | ))) 384 | 385 | (define-derived-mode ssm:management-mode 386 | fundamental-mode 387 | "Maze Management mode" 388 | "Maze Management mode" 389 | ) 390 | 391 | (defvar ssm:management-buffer "*maze server management*") 392 | 393 | ;; サーバー構築後に呼ばれる 394 | (defun ssm:open-management-buffer () 395 | (let ((buf (get-buffer-create ssm:management-buffer))) 396 | (with-current-buffer buf 397 | (ssm:management-mode) 398 | (buffer-disable-undo) 399 | (setq buffer-read-only t) 400 | (ssm:management-update-buffer)) 401 | (switch-to-buffer buf) 402 | (ssm:management-thread-start))) 403 | 404 | (defface ssm:face-title 405 | '((((class color) (background light)) 406 | :foreground "MediumBlue" :height 1.5 :inherit variable-pitch) 407 | (((class color) (background dark)) 408 | :foreground "yellow" :weight bold :height 1.5 :inherit variable-pitch) 409 | (t :height 1.5 :weight bold :inherit variable-pitch)) 410 | "" :group 'ssm) 411 | 412 | (defface ssm:face-subtitle 413 | '((((class color)) 414 | :foreground "Gray10" :height 1.2 :inherit variable-pitch) 415 | (t :height 1.2 :inherit variable-pitch)) 416 | "" :group 'ssm) 417 | 418 | (defface ssm:face-item 419 | '((t :inherit variable-pitch :foreground "DarkSlateBlue")) 420 | "" :group 'ssm) 421 | 422 | (defface ssm:face-mark-client 423 | '((t :foreground "DarkOliveGreen" :background "Darkseagreen1")) 424 | "" :group 'ssm) 425 | 426 | (defface ssm:face-mark-floor 427 | '((t :foreground "white" :background "Rosybrown2")) 428 | "" :group 'ssm) 429 | 430 | (defface ssm:face-mark-wall 431 | '((t :foreground "LightBlue" :background "MediumBlue")) 432 | "" :group 'ssm) 433 | 434 | (defun ssm:rt (text face) 435 | (unless (stringp text) (setq text (format "%s" text))) 436 | (put-text-property 0 (length text) 'face face text) text) 437 | 438 | (defun ssm:rt-format (text &rest args) 439 | (apply 'format (ssm:rt text 'ssm:face-item) 440 | (loop for i in args 441 | if (consp i) 442 | collect (ssm:rt (car i) (cdr i)) 443 | else 444 | collect (ssm:rt i 'ssm:face-subtitle)))) 445 | 446 | (defun ssm:management-ip-address () 447 | (mapconcat 'identity 448 | (loop for (name . addr) in (network-interface-list) 449 | unless (equal name "lo") 450 | collect (format-network-address addr t)) 451 | ", ")) 452 | 453 | ;; 内容を更新する 454 | (defun ssm:management-update-buffer () 455 | (interactive) 456 | (save-excursion 457 | (let (buffer-read-only (EOL "\n")) 458 | (erase-buffer) 459 | (insert (ssm:rt "Maze Server Management:" 'ssm:face-title) EOL EOL) 460 | (insert (ssm:rt-format 461 | "IP Address: %s Port: %s" 462 | (ssm:management-ip-address) 463 | ssm:server-port) EOL EOL) 464 | (insert (ssm:management-layout-map) EOL EOL) 465 | (insert (ssm:rt "Client List:" 'ssm:face-subtitle) EOL) 466 | (insert (format "%03s %6s (position) angle" 'id 'name) EOL) 467 | (insert 468 | (or 469 | (loop for (p . c) in ssm:client-processes 470 | concat 471 | (format "%03d %6s (%2.3f %2.3f) %3.1f\n" 472 | (ssm:client-id c) (ssm:client-name c) 473 | (ssm:client-x c) (ssm:client-y c) (ssm:client-angle c))) 474 | "No clients"))))) 475 | 476 | (defun ssm:management-layout-map () 477 | (let* ((width (ssm:map-width ssm:map)) 478 | (height (ssm:map-height ssm:map)) 479 | (org (ssm:map-map ssm:map)) 480 | (WALL (ssm:rt (substring "#" 0) 'ssm:face-mark-wall)) 481 | (FLR (ssm:rt (substring " " 0) 'ssm:face-mark-floor)) 482 | (scr (make-vector (* width height) FLR))) 483 | (loop for y from 0 below height do 484 | (loop for x from 0 below width 485 | for idx = (+ x (* y width)) 486 | if (= (aref org idx) 1) 487 | do (aset scr idx WALL))) 488 | (loop for (p . c) in ssm:client-processes 489 | for x = (floor (/ (ssm:client-x c) ssm:scale)) 490 | for y = (floor (/ (ssm:client-y c) ssm:scale)) 491 | for idx = (+ x (* y width)) 492 | if (and (<= 0 idx) (< idx (length org))) 493 | do 494 | (aset scr idx 495 | (ssm:rt 496 | (substring-no-properties 497 | (format "%s" (ssm:client-name c)) 498 | 0 1) 'ssm:face-mark-client))) 499 | (mapconcat 'identity 500 | (loop for y from 0 below height 501 | collect 502 | (loop for x from 0 below width 503 | for idx = (+ x (* y width)) 504 | concat (aref scr idx))) 505 | "\n"))) 506 | 507 | (defun ssm:management-quit () 508 | (interactive) 509 | (when (y-or-n-p "Disconnect all clients and shutdown server ?") 510 | (lexical-let ((buf (current-buffer))) 511 | (ssm:management-thread-stop 512 | (lambda () 513 | (ssm:server-stop) 514 | (kill-buffer buf) 515 | (ssm:log "<< Finish task: ok.")))))) 516 | 517 | (defun ssm:management-ban-client (id) 518 | (interactive "Mclient id:") 519 | (let ((client (ssm:client-get-by-id (string-to-number id)))) 520 | (if client 521 | (progn 522 | (when (y-or-n-p (format "Do you ban the client [%s]?" (ssm:client-name client))) 523 | (ssm:client-ban client) 524 | (message "Client [%s] banned." (ssm:client-name client)))) 525 | (message "Client [%s] not found." id)))) 526 | 527 | ;; (global-set-key (kbd "M-0") 'ssm:server-start) 528 | 529 | ;; (eval-current-buffer) 530 | ;; (ssm:server-start) 531 | ;; (ssm:server-stop) 532 | ;; (list-processes) 533 | ;; (setq ssm:server-address "127.0.0.1") 534 | 535 | ;; (setq ssm:debug-out nil) 536 | ;; (setq ssm:debug-out t) 537 | 538 | (provide 'server-maze) 539 | 540 | -------------------------------------------------------------------------------- /3dmaze.el: -------------------------------------------------------------------------------- 1 | ;;; 3dmaze.el --- 3D maze explorer 2 | 3 | ;; Copyright (C) 2011 SAKURAI Masashi 4 | 5 | ;; Author: SAKURAI Masashi 6 | ;; Keywords: games 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; TODO: 24 | ;; 読み書き禁止 25 | ;; 時間差描画 26 | 27 | ;; デモなので効率優先。 28 | ;; なるべくチェックを省くため、パラメーター、計算式の妥当性はプログラマの責任。 29 | ;; 整数、小数、defstruct、型エラー、配列範囲エラーをコンパイルエラーと思ってバグ発見する。 30 | 31 | ;; 単位系まとめ 32 | ;; 角度： 基本 degree 整数 0-359。ローカル内でradianや小数で扱っても良い。 33 | ;; 位置： 基本 マップ上の1文字が d3m:scale となるサイズの長さで扱う。 34 | ;; 基本座標系：↑ 35 | ;; マップ座標系：マップ上の文字のインデックスに対応する座標、整数。 36 | ;; 固定小数座標系：基本座標系に d3m:fx をかけて整数で扱う。 37 | ;; 整数演算をするため、乗除、演算順序に注意。変数の後ろに -f をつけて表す。 38 | ;; スクリーン座標系：d3m:buf構造体で保持する幅と高さの整数。zバッファは固定小数座標系での距離。 39 | 40 | 41 | ;;; Code: 42 | 43 | (require 'cl) 44 | (require 'derived) 45 | (require 'concurrent) 46 | (require 'matrix) 47 | 48 | (defstruct d3m:map width height map objects) 49 | (defstruct d3m:buf width height tbuf zbuf) 50 | (defstruct d3m:pos x y) 51 | (defstruct d3m:object def pos) 52 | 53 | ;; 全体の見え方に対するパラメーター 54 | (defvar d3m:scale 10.0 "MAP上の1文字のサイズ。壁の高さ。") 55 | (defvar d3m:aperture-size 30.0 "描画すべき画角。単位degree。") 56 | 57 | ;; d3m:map-tbuf に入れるオブジェクトのタイプ 58 | (defconst d3m:tbuf-none 00) 59 | (defconst d3m:tbuf-air 01) 60 | (defconst d3m:tbuf-floor 02) 61 | (defconst d3m:tbuf-floor2 03) 62 | (defconst d3m:tbuf-wall 04) 63 | (defconst d3m:tbuf-out 08) 64 | (defconst d3m:tbuf-other 16) 65 | (defconst d3m:tbuf-me 64) 66 | 67 | (defconst d3m:zbuf-inf 1e10 "Zバッファの無限遠") 68 | (defvar d3m:zbuf-fogout 80.0 "fogで完全に消えてしまう距離（d3m:zlimitよりも遠い方が良い）") 69 | (defvar d3m:zlimit 60.0 "スキャン打ち切り距離") 70 | 71 | (defconst d3m:chr ?\ "bufferに実際にinsertする文字") 72 | 73 | (defvar d3m:debug-out nil) 74 | (defvar d3m:debug-buffer "*maze log*") 75 | 76 | (defun d3m:log-init () 77 | (when (get-buffer d3m:debug-buffer) 78 | (kill-buffer d3m:debug-buffer))) 79 | 80 | (defun d3m:log (&rest args) 81 | (when d3m:debug-out 82 | (with-current-buffer 83 | (get-buffer-create d3m:debug-buffer) 84 | (buffer-disable-undo) 85 | (insert (apply 'format args) "\n")))) 86 | 87 | (defun d3m:define-keymap (keymap-list) 88 | (let ((map (make-sparse-keymap))) 89 | (mapc 90 | (lambda (i) 91 | (define-key map 92 | (if (stringp (car i)) 93 | (read-kbd-macro (car i)) (car i)) 94 | (cdr i))) 95 | keymap-list) 96 | map)) 97 | 98 | (defun d3m:str2map (src) 99 | (let* ((lines (split-string src "\n")) 100 | (width (loop for i in lines maximize (length i))) 101 | (height (length lines)) 102 | (ret (make-vector (* width height) 0)) 103 | objects) 104 | (loop for line in lines 105 | for j from 0 below (length lines) 106 | do 107 | (loop for c across line 108 | for s = (char-to-string c) 109 | for i from 0 below (length line) 110 | for idx = (+ i (* width j)) 111 | do 112 | (aset ret idx 113 | (if (or (eql c ?#) (eql c ?*)) 1 0)) 114 | (when (string-match 115 | "[a-zA-Z0-9();:{}<>?!@$%&=+-~]" s) 116 | (push 117 | (make-d3m:object 118 | :def (d3m:object-get s) 119 | :pos 120 | (mt:sxv d3m:scale 121 | (mt:v+v 122 | (mt:vnew [0.5 0.5]) 123 | (mt:vnew (vector i j))))) 124 | objects)) 125 | (incf idx))) 126 | (make-d3m:map :width width :height height 127 | :map ret :objects objects))) 128 | 129 | (defun d3m:world-new (map screen pos angle) 130 | (list map screen pos angle)) 131 | 132 | (defsubst d3m:world-map (world) 133 | (car world)) 134 | 135 | (defsubst d3m:world-screen (world) 136 | (cadr world)) 137 | 138 | (defsubst d3m:world-pos (world) 139 | (nth 2 world)) 140 | 141 | (defsubst d3m:world-set-pos (world pos) 142 | (setf (nth 2 world) pos)) 143 | 144 | (defsubst d3m:world-angle (world) 145 | (nth 3 world)) 146 | 147 | (defsubst d3m:world-set-angle (world angle) 148 | (setf (nth 3 world) angle)) 149 | 150 | (defsubst d3m:d2r (deg) 151 | (/ (* pi deg) 180.0)) 152 | 153 | (defsubst d3m:degree (d) 154 | (setq d (floor d)) 155 | (cond 156 | ((< d 0) (+ d 360)) 157 | ((>= d 360) (- d 360)) 158 | (t d))) 159 | 160 | ;; 固定小数点演算を仮定 161 | ;; 値を1024倍して保持しておく 162 | ;; 固定小数点の変数は -f をつける 163 | ;; 30bit整数まで扱えるので、掛け算1回ぐらいならオーバーフローしないはず 164 | 165 | (defvar d3m:fx 1024.0 "固定小数基数") 166 | (defvar d3m:fxi 1024 "固定小数基数") 167 | 168 | (defsubst d3m:tofx (v) 169 | (floor (* v d3m:fx))) 170 | 171 | (defsubst d3m:fromfx (v) 172 | (/ v d3m:fx)) 173 | 174 | (defsubst d3m:tofxv (v) 175 | (mt:vfloor2d (mt:sxv2d d3m:fx v))) 176 | 177 | (defsubst d3m:fromfxv (v) 178 | (mt:sxv2d (/ 1.0 d3m:fx) v)) 179 | 180 | (defvar d3m:table-num 360 "三角関数テーブルの要素数。1度1つで360個。") 181 | 182 | (defun d3m:table-init (func) 183 | (loop for i from 0 below d3m:table-num 184 | with array = (make-vector d3m:table-num 0) 185 | do (aset array i 186 | (d3m:tofx 187 | (min 1048576 ;1024*1024 188 | (funcall func (d3m:d2r i))))) 189 | finally return array)) 190 | 191 | (defvar d3m:table-sin (d3m:table-init 'sin) "三角関数テーブル sin") 192 | (defvar d3m:table-cos (d3m:table-init 'cos) "三角関数テーブル cos") 193 | (defvar d3m:table-tan (d3m:table-init 'tan) "三角関数テーブル tab") 194 | 195 | (defsubst d3m:sin-f (degree) 196 | (aref d3m:table-sin degree)) 197 | 198 | (defsubst d3m:cos-f (degree) 199 | (aref d3m:table-cos degree)) 200 | 201 | (defsubst d3m:tan-f (degree) 202 | (aref d3m:table-tan degree)) 203 | 204 | (defun d3m:init-table-scanz () 205 | (vconcat 206 | (loop with zf = (d3m:tofx 1) 207 | until (> zf (d3m:tofx d3m:zlimit)) 208 | collect 209 | (let ((ret zf)) 210 | (cond 211 | ((< zf (/ (d3m:tofx d3m:scale) 2)) 212 | (incf zf (/ (d3m:tofx d3m:scan-scale) 4))) 213 | ((< zf (d3m:tofx d3m:scale)) 214 | (incf zf (/ (d3m:tofx d3m:scan-scale) 3))) 215 | ((< zf (d3m:tofx (* 2 d3m:scale))) 216 | (incf zf (d3m:tofx d3m:scan-scale))) 217 | (t 218 | (incf zf (d3m:tofx (* 2 d3m:scan-scale))))) 219 | ret)))) 220 | 221 | (defvar d3m:scan-scale 1.6 "動径方向のスキャンサイズ単位") 222 | (defvar d3m:table-scanz (d3m:init-table-scanz) 223 | "Zスキャンの距離配列。近くはきめ細かく、遠くは荒くを表現。") 224 | ;;(length d3m:table-scanz) 225 | 226 | 227 | (defvar d3m:table-wall-num 80 228 | "距離→壁の高さを変換するテーブル（個数）") 229 | (defvar d3m:table-wall-delta-f nil 230 | "距離→壁の高さを変換するテーブルの変換単位 ( zf / delta -> index ) 231 | FIXME: should be buffer local") 232 | (defvar d3m:table-wall nil "距離→壁の高さを変換するテーブル。 233 | スクリーン高さに依存するのでバッファ初期化時に決まる。 234 | FIXME: should be buffer local") 235 | 236 | (defun d3m:init-table-wall (window-height) 237 | (setq d3m:table-wall-delta-f (d3m:tofx (/ d3m:zlimit d3m:table-wall-num))) 238 | (setq d3m:table-wall 239 | (loop for i from 0 below d3m:table-wall-num 240 | with delta = (/ d3m:zlimit d3m:table-wall-num) 241 | with ret = (make-vector d3m:table-wall-num 0) 242 | for z = (* delta (max i 1)) 243 | do (aset ret i (round (* (/ d3m:scale z) window-height 0.8))) 244 | finally return ret))) 245 | 246 | (defsubst d3m:wall-f (zf) 247 | (let ((idx (/ zf d3m:table-wall-delta-f))) 248 | (cond 249 | ((< idx 0) (setq idx 0)) 250 | ((>= idx d3m:table-wall-num) 251 | (setq idx (1- d3m:table-wall-num)))) 252 | (aref d3m:table-wall idx))) 253 | 254 | 255 | ;;================================================== 256 | 257 | (defun d3m:search-blank-pos (map) 258 | (loop with w = (d3m:map-width map) 259 | with h = (d3m:map-height map) 260 | for i from 0 to 1000 261 | for x = (random w) for y = (random h) 262 | for idx = (+ x (* y w)) 263 | do 264 | (when (= 0 (aref (d3m:map-map map) idx)) 265 | (return (mt:vnew (vector x y)))) 266 | finally return (mt:vnew (vector 1 1)))) 267 | 268 | (defun d3m:open-buffer (map &optional screen-width screen-height) 269 | (let ((buf (get-buffer-create "*3d maze*")) 270 | (scr (d3m:init-screen screen-width screen-height)) 271 | world) 272 | (setq world 273 | (d3m:world-new 274 | map scr 275 | (d3m:tofxv 276 | (mt:sxv d3m:scale 277 | (mt:v+v 278 | (mt:vnew [0.5 0.5]) 279 | (d3m:search-blank-pos map)))) 280 | 90)) 281 | (with-current-buffer buf 282 | (d3m:init-table-wall (d3m:buf-height scr)) 283 | (d3m:explorer-mode) 284 | (buffer-disable-undo) 285 | (setq d3m-world world) 286 | (d3m:draw-world world) 287 | (d3m:init-buffer buf world) 288 | (d3m:update-buffer buf world)) 289 | (switch-to-buffer buf))) 290 | 291 | (defun d3m:init-screen (&optional screen-width screen-height) 292 | "裏画面バッファの準備" 293 | (let* ((ww (or screen-width (window-width))) 294 | (wh (or screen-height (window-height)))) 295 | (make-d3m:buf :width ww :height wh 296 | :tbuf (make-vector (* ww wh) d3m:tbuf-none) 297 | :zbuf (make-vector (* ww wh) (d3m:tofx d3m:zbuf-inf))))) 298 | 299 | (defun d3m:draw-world (world) 300 | (d3m:clear-screen (d3m:world-screen world)) 301 | (d3m:draw-wall world) 302 | (d3m:draw-objects world) 303 | ) 304 | 305 | 306 | (defun d3m:clear-screen (scr) 307 | (fillarray (d3m:buf-tbuf scr) d3m:tbuf-none) 308 | (fillarray (d3m:buf-zbuf scr) (d3m:tofx d3m:zbuf-inf))) 309 | 310 | (defun d3m:draw-wall (world) 311 | (let* ((scr (d3m:world-screen world)) (map (d3m:world-map world)) 312 | (tbuf (d3m:buf-tbuf scr)) (zbuf (d3m:buf-zbuf scr)) 313 | (ww (d3m:buf-width scr)) (wh (d3m:buf-height scr)) wwe 314 | (hww (/ ww 2)) (hwh (/ wh 2)) 315 | (angle-f (d3m:tofx (d3m:world-angle world))) 316 | (pos-f (d3m:world-pos world)) 317 | (posxf (mt:vref pos-f 0)) (posyf (mt:vref pos-f 1)) 318 | (dt-f (/ (d3m:tofx d3m:aperture-size) hww)) 319 | (zlimit-f (d3m:tofx d3m:zlimit)) 320 | (start-f (d3m:tofx 1.0)) obj (rn-f (mt:vcp pos-f))) 321 | (setq wwe (- ww 1)) ; for loop step 322 | (loop for i from 0 below wwe by 2 323 | for px = (- i hww) 324 | for th = (d3m:degree (d3m:fromfx (+ angle-f (* dt-f px)))) 325 | for cosf = (d3m:cos-f th) for sinf = (d3m:sin-f th) 326 | do 327 | ;;(d3m:log ">>> Scan way th: %04f cosf: %S sinf: %S" th cosf sinf) 328 | (loop for zf across d3m:table-scanz 329 | do 330 | (mt:vset2d rn-f 331 | (+ posxf (/ (* zf cosf) d3m:fxi)) 332 | (+ posyf (/ (* zf sinf) d3m:fxi))) 333 | (setq obj (d3m:draw-wall-find-object map rn-f)) 334 | ;;(d3m:log "Scan ?: %s d: %04f rn: %S" obj zf rn-f) 335 | (cond 336 | ((eq obj d3m:tbuf-wall) 337 | (d3m:draw-wall-draw-wall i zf) 338 | (d3m:draw-wall-draw-wall (1+ i) zf) 339 | (return)) 340 | ((eq obj d3m:tbuf-out) 341 | (d3m:draw-wall-draw-out i zf) 342 | (d3m:draw-wall-draw-out (1+ i) zf) 343 | (return)) 344 | (t 345 | (d3m:draw-wall-draw-floor i zf obj) 346 | (d3m:draw-wall-draw-floor (1+ i) zf obj))))))) 347 | 348 | (defun d3m:draw-wall-find-object (map v-f) 349 | (let* ((x (floor (d3m:fromfx (/ (mt:vref v-f 0) d3m:scale)))) 350 | (y (floor (d3m:fromfx (/ (mt:vref v-f 1) d3m:scale))))) 351 | (cond 352 | ((or (< x 0) (< y 0) 353 | (>= x (d3m:map-width map)) 354 | (>= y (d3m:map-height map))) 355 | d3m:tbuf-out) 356 | (t 357 | (let* ((idx (+ x (* y (d3m:map-width map))))) 358 | (cond 359 | ((= 0 (aref (d3m:map-map map) idx)) 360 | (if (< 0 (logand (+ x y) 1)) 361 | d3m:tbuf-floor d3m:tbuf-floor2)) 362 | (t d3m:tbuf-wall))))))) 363 | 364 | (defun d3m:draw-wall-draw-wall (x z-f) 365 | (let* ((wall (d3m:wall-f z-f)) 366 | (hwall (ceiling (/ wall 2.0))) 367 | (top (max 0 (- hwh hwall))) 368 | (btm (min (1- wh) (+ hwh hwall)))) 369 | ;;(d3m:log "# x: %2s z: %06f" x z-f) 370 | (loop for i from top to btm 371 | for idx = (+ x (* i ww)) 372 | do 373 | (aset tbuf idx d3m:tbuf-wall) 374 | (aset zbuf idx z-f)))) 375 | 376 | (defun d3m:draw-wall-draw-out (x z-f) 377 | ;; DO NOTHING 378 | ) 379 | 380 | (defun d3m:draw-wall-draw-floor (x z-f obj) 381 | (let* ((wall (d3m:wall-f z-f)) 382 | (hwall (/ wall 2)) 383 | (btm (min wh (+ hwall hwh)))) 384 | ;;(d3m:log "F x: %2s z: %06f" x z-f) 385 | (loop for i from btm below wh 386 | for idx = (+ x (* i ww)) 387 | for floorz = (aref zbuf idx) 388 | do 389 | (when (< z-f floorz) 390 | (aset tbuf idx obj) 391 | (aset zbuf idx z-f))))) 392 | 393 | (defun d3m:draw-objects (world) 394 | (loop for obj in (d3m:map-objects 395 | (d3m:world-map world)) 396 | do 397 | (d3m:draw-objects-one world obj))) 398 | 399 | (defvar d3m:letter-def-table (make-hash-table :test 'equal) 400 | "文字 -> mapのハッシュ") 401 | 402 | (defun d3m:object-get (chr) 403 | (let ((map (gethash chr d3m:letter-def-table))) 404 | (unless map 405 | (setq map (d3m:init-letter chr)) 406 | (puthash chr map d3m:letter-def-table)) 407 | map)) 408 | 409 | (defvar d3m:program-banner 410 | (cond 411 | ((eq 'darwin system-type) "/usr/bin/banner") 412 | ((eq 'gnu/linux system-type) "/usr/bin/printerbanner") 413 | (t "banner")) 414 | "文字プログラム") 415 | 416 | (defun d3m:init-letter (letter) 417 | (let* ((src 418 | (with-temp-buffer 419 | (call-process d3m:program-banner nil t nil "-w" "40" letter) 420 | (buffer-string))) 421 | (lines (split-string src "\n")) 422 | (height (loop for i in lines maximize (length i))) 423 | (width (* 4 (length lines))) 424 | (ret (make-vector (* width height) 0))) 425 | (loop for line in lines 426 | for x from 0 below (length lines) 427 | do 428 | (loop for c across line 429 | for y from 0 below (length line) 430 | for val = (if (eql c ?#) 1 0) 431 | for idx = (+ (* x 4) (* (- height y 1) width)) 432 | do 433 | (aset ret idx val) 434 | (aset ret (incf idx) val) 435 | (aset ret (incf idx) val) 436 | (aset ret (incf idx) val))) 437 | (make-d3m:map :width width :height height :map ret))) 438 | 439 | (defun d3m:object-debug-out (object) 440 | (d3m:log-init) 441 | (with-current-buffer (get-buffer-create d3m:debug-buffer) 442 | (loop for y from 0 below (d3m:map-height object) do 443 | (loop for x from 0 below (d3m:map-width object) do 444 | (insert (if (= 1 (aref (d3m:map-map object) 445 | (+ x (* y (d3m:map-width object))))) 446 | "#" " "))) 447 | (insert "\n"))) 448 | (pop-to-buffer d3m:debug-buffer)) 449 | ;; (d3m:object-debug-out (d3m:init-letter "@")) 450 | 451 | (defun d3m:draw-objects-one (world object) 452 | (let* 453 | ((scr (d3m:world-screen world)) (map (d3m:world-map world)) 454 | (tbuf (d3m:buf-tbuf scr)) (zbuf (d3m:buf-zbuf scr)) 455 | (ww (d3m:buf-width scr)) (wh (d3m:buf-height scr)) 456 | (hww (/ ww 2)) (hwh (/ wh 2)) 457 | (angle (d3m:world-angle world)) 458 | (posv (mt:sxv2d (/ 1.0 d3m:fx) (d3m:world-pos world))) 459 | (tposv (d3m:object-pos object)) 460 | (relv (mt:v-v2d tposv posv)) 461 | (rad (atan (mt:vref relv 1) (mt:vref relv 0))) 462 | (degree (d3m:degree (- angle (* 180 (/ rad pi))))) 463 | (vlen (mt:vlen2d relv)) 464 | (aplimit (* 1.6 d3m:aperture-size)) 465 | (dw (/ wh d3m:aperture-size)) cx) 466 | (cond 467 | ((and (<= 0 degree) (< degree aplimit)) 468 | (setq cx (floor (- hww (* dw degree))))) 469 | ((and (< (- 360 aplimit) degree) (< degree 360)) 470 | (setq cx (floor (+ hww (* dw (- 360 degree))))))) 471 | (when (or (< vlen 3.0) (> vlen d3m:zlimit)) (setq cx nil)) 472 | ;;(message "deg: %s dist: %2.3f cx: %s" degree vlen cx) 473 | (when cx 474 | (let* ((def (d3m:object-def object)) 475 | (lw (d3m:map-width def)) 476 | (lh (d3m:map-height def)) 477 | (lmap (d3m:map-map def)) 478 | (hlw (/ lw 2)) (hlh (/ lh 2)) 479 | (delta (* (/ d3m:scale vlen) (/ d3m:scale hlw))) ; 文字サイズ調整（適当） 480 | (vlenf (d3m:tofx vlen))) 481 | (loop for ly from 0 below lh 482 | for scry = (floor (+ (* 1.2 hwh) (* delta (- ly hlh)))) do 483 | (loop for lx from 0 below lw 484 | for scrx = (floor (+ cx (* delta (- lx hlw)))) 485 | for scridx = (+ scrx (* ww scry)) 486 | for sczf = (if (and (<= 0 scrx) (< scrx ww) (<= 0 scry) (< scry wh)) 487 | (aref zbuf scridx)) 488 | for val = (aref lmap (+ lx (* ly lw))) do 489 | (when (and sczf (= 1 val) (< vlenf sczf)) 490 | (aset tbuf scridx object) 491 | (aset zbuf scridx vlenf)))))))) 492 | 493 | 494 | ;;================================================== 495 | 496 | (defvar d3m:2dmap-display t "display switch 2D map") 497 | (defvar d3m:2dmap-radial 3.0 "map size") 498 | (defvar d3m:2dmap-rect-left 0.7 "left-top (0.0-1.0)") 499 | (defvar d3m:2dmap-rect-top 0.0 "left-top (0.0-1.0)") 500 | (defvar d3m:2dmap-rect-width 0.3 "width (0.0-1.0)") 501 | (defvar d3m:2dmap-rect-height 0.3 "height (0.0-1.0)") 502 | 503 | (defun d3m:draw-2dmap (world) 504 | (when d3m:2dmap-display 505 | (let* 506 | ((scr (d3m:world-screen world)) (map (d3m:world-map world)) 507 | (lmap (d3m:map-map map)) 508 | (mapw (d3m:map-width map)) (maph (d3m:map-height map)) 509 | (tbuf (d3m:buf-tbuf scr)) (zbuf (d3m:buf-zbuf scr)) 510 | (ww (d3m:buf-width scr)) (wh (d3m:buf-height scr)) 511 | (angle (d3m:world-angle world)) 512 | (posv (mt:sxv2d (/ 1.0 d3m:fx) (d3m:world-pos world))) 513 | (scrx (floor (* ww d3m:2dmap-rect-left))) 514 | (scry (floor (* wh d3m:2dmap-rect-top))) 515 | (scrw (floor (* ww d3m:2dmap-rect-width))) (scrwe (1- scrw)) ; for loop step 516 | (scrh (floor (* wh d3m:2dmap-rect-height))) 517 | (scrhw (/ scrw 2)) (scrhh (/ scrh 2)) 518 | (scrxe (+ scrx scrw)) (scrye (+ scry scrh)) 519 | (rot (mt:mrot2d (d3m:d2r (+ angle 90)))) 520 | ) 521 | ;;(d3m:log "=====================") 522 | (loop for scryi from 0 below scrh 523 | for scryii = (- scryi scrhh) 524 | with basev0 = (mt:vnew [0 0]) 525 | do 526 | (loop for scrxi from 0 below scrwe by 2 527 | for scrxii = (- scrxi scrhw) 528 | for basev = (mt:vset2d 529 | basev0 530 | (* d3m:2dmap-radial scrxii) 531 | (* 2 d3m:2dmap-radial scryii)) 532 | for mapv = (mt:v+v2d= (mt:mxv2d rot basev) posv) 533 | for mapx = (floor (/ (mt:vref mapv 0) d3m:scale)) 534 | for mapy = (floor (/ (mt:vref mapv 1) d3m:scale)) 535 | for idx = 536 | (if (and (<= 0 mapx) (< mapx mapw) 537 | (<= 0 mapy) (< mapy maph)) 538 | (+ mapx (* mapy mapw)) nil) 539 | for val = (if idx (aref lmap idx) nil) 540 | for scridx = (+ scrxi scrx (* ww (+ scry scryi))) 541 | for vlenz = (d3m:tofx (mt:vlen2d basev)) 542 | do 543 | ;;(d3m:log "mapx:%s mapy:%s idx:%s val:%s" mapx mapy idx val) 544 | (cond 545 | ((and (= 0 scrxii) (= 0 scryii)) 546 | (aset tbuf scridx d3m:tbuf-me) 547 | (aset zbuf scridx vlenz) 548 | (aset tbuf (1+ scridx) d3m:tbuf-me) 549 | (aset zbuf (1+ scridx) vlenz)) 550 | ((null val) 551 | (aset tbuf scridx d3m:tbuf-out) 552 | (aset zbuf scridx vlenz) 553 | (aset tbuf (1+ scridx) d3m:tbuf-out) 554 | (aset zbuf (1+ scridx) vlenz)) 555 | ((= 1 val) 556 | (aset tbuf scridx d3m:tbuf-wall) 557 | (aset zbuf scridx vlenz) 558 | (aset tbuf (1+ scridx) d3m:tbuf-wall) 559 | (aset zbuf (1+ scridx) vlenz)) 560 | (t 561 | (aset tbuf scridx d3m:tbuf-floor) 562 | (aset zbuf scridx vlenz) 563 | (aset tbuf (1+ scridx) d3m:tbuf-floor) 564 | (aset zbuf (1+ scridx) vlenz)))))))) 565 | 566 | 567 | ;;================================================== 568 | 569 | (defun d3m:init-buffer (buf world) 570 | "バッファに文字列を書き込み" 571 | (erase-buffer) 572 | (let* ((scr (d3m:world-screen world)) 573 | (ww (d3m:buf-width scr)) 574 | (wh (d3m:buf-height scr)) 575 | (line (make-string ww d3m:chr))) 576 | (loop for i from 0 below wh do 577 | (insert line "\n")) 578 | (goto-char (point-min)) 579 | (d3m:screen-bitblt buf world))) 580 | 581 | (defstruct d3m:color-set num delta array) 582 | 583 | (defun d3m:color-set-generate (base fog num) 584 | (let ((delta (/ d3m:zbuf-fogout num)) cl) 585 | (make-d3m:color-set 586 | :num num 587 | :delta (d3m:tofx delta) 588 | :array 589 | (vconcat 590 | (loop for i from 0 below num 591 | for d = (* delta i) 592 | for param = (/ (- d3m:zbuf-fogout d) d3m:zbuf-fogout) 593 | for cl = 594 | (cond 595 | ((< d3m:zbuf-fogout d) fog) 596 | ((< d 1.0) base) 597 | (t 598 | (mt:v+v 599 | (mt:sxv param base) 600 | (mt:sxv (- 1.0 param) fog)))) 601 | collect 602 | (list ':background 603 | (format "#%2x%2x%2x" 604 | (mt:vref cl 0) 605 | (mt:vref cl 1) 606 | (mt:vref cl 2)))))))) 607 | 608 | (defvar d3m:color-set-floor 609 | (d3m:color-set-generate (mt:vnew [130 71 51]) (mt:vnew [255 255 255]) 32)) 610 | (defvar d3m:color-set-floor2 611 | (d3m:color-set-generate (mt:vnew [ 70 31 30]) (mt:vnew [255 255 255]) 32)) 612 | (defvar d3m:color-set-wall 613 | (d3m:color-set-generate (mt:vnew [ 51 51 204]) (mt:vnew [255 255 255]) 32)) 614 | (defvar d3m:color-set-friend 615 | (d3m:color-set-generate (mt:vnew [ 90 255 90]) (mt:vnew [255 255 255]) 32)) 616 | (defvar d3m:color-set-other 617 | (d3m:color-set-generate (mt:vnew [255 90 90]) (mt:vnew [255 255 255]) 32)) 618 | (defvar d3m:color-default '(:background "white")) 619 | (defvar d3m:color-out '(:background "lightgray")) 620 | (defvar d3m:color-me '(:background "pink")) 621 | 622 | (defun d3m:color-set-get (set z-f) 623 | (let* ((idx (/ z-f (d3m:color-set-delta set))) 624 | (array (d3m:color-set-array set))) 625 | (cond 626 | ((< idx 0) (aref array 0)) 627 | ((< idx (d3m:color-set-num set)) 628 | (aref array idx)) 629 | (t (aref array (1- (length array))))))) 630 | 631 | (defun d3m:screen-color (type z-f) 632 | (cond 633 | ((eq type d3m:tbuf-floor) (d3m:color-set-get d3m:color-set-floor z-f)) 634 | ((eq type d3m:tbuf-floor2) (d3m:color-set-get d3m:color-set-floor2 z-f)) 635 | ((eq type d3m:tbuf-wall) (d3m:color-set-get d3m:color-set-wall z-f)) 636 | ((d3m:object-p type) (d3m:color-set-get d3m:color-set-other z-f)) 637 | ((eq type d3m:tbuf-me) d3m:color-me) 638 | ((eq type d3m:tbuf-out) d3m:color-out) 639 | ((eq type d3m:tbuf-none) d3m:color-default) 640 | (t d3m:color-default))) 641 | 642 | (defun d3m:screen-bitblt (buf world) 643 | "裏画面からバッファのテキストプロパティを書き換え" 644 | (let* ((map (d3m:world-map world)) 645 | (scr (d3m:world-screen world)) 646 | (tbuf (d3m:buf-tbuf scr)) 647 | (zbuf (d3m:buf-zbuf scr)) 648 | (ww (d3m:buf-width scr)) 649 | (wh (d3m:buf-height scr)) 650 | (line (make-string ww d3m:chr))) 651 | (loop for y from 0 below wh 652 | with bpos = (point-min) 653 | with spos = 0 654 | do 655 | (loop for x from 0 below ww 656 | do 657 | (put-text-property 658 | bpos (1+ bpos) 'face 659 | (d3m:screen-color (aref tbuf spos) 660 | (aref zbuf spos)) 661 | buf) 662 | (incf bpos) (incf spos)) 663 | (incf bpos) ; line separator 664 | ))) 665 | 666 | (defun d3m:update-mode-line (&optional msg) 667 | (let* ((world d3m-world) 668 | (pos (mt:sxv 0.1 (d3m:fromfxv (d3m:world-pos world)))) 669 | (map (d3m:world-map world)) 670 | (msg-line (if msg (list "---" msg)))) 671 | (setq mode-line-format 672 | `("-" mode-line-mule-info 673 | " " 674 | ,(format "Pos: (%3.1f, %3.1f)" 675 | (mt:vref pos 0) (mt:vref pos 1)) 676 | ,@msg-line 677 | "-%-")) 678 | (force-mode-line-update))) 679 | 680 | (defun d3m:update-buffer (buf world) 681 | (let ((start-time (float-time)) map-time bitblt-time gc-time fin-time) 682 | (d3m:draw-world world) 683 | (setq map-time (float-time)) 684 | (d3m:draw-2dmap world) 685 | (setq bitblt-time (float-time)) 686 | (d3m:screen-bitblt buf world) 687 | (setq gc-time (float-time)) 688 | (garbage-collect) 689 | (setq fin-time (float-time)) 690 | (d3m:update-mode-line 691 | (format "[geo:%2.3f map:%2.3f bitblt:%2.3f gc:%2.3f" 692 | (- map-time start-time) 693 | (- bitblt-time map-time) 694 | (- gc-time bitblt-time) 695 | (- fin-time gc-time))))) 696 | 697 | 698 | ;;================================================== 699 | 700 | ;; バッファローカル変数 701 | ;; d3m-command-event : キー入力の指示内容 702 | ;; d3m-event-status : 処理中 d3m:state-busy, 入力待ち d3m:state-wait 703 | 704 | (defun d3m:explorer-command-event-task () 705 | "d3m-command-event を読み取って実行する" 706 | ;;(message "TASK") 707 | (when (and d3m-command-event 708 | (eq d3m-event-status 'd3m:state-wait)) 709 | (lexical-let ((buf (current-buffer))) 710 | (deferred:try 711 | (deferred:$ 712 | (deferred:next 713 | (lambda (x) 714 | (with-current-buffer buf 715 | (setq d3m-event-status 'd3m:state-busy) 716 | (let ((command d3m-command-event)) 717 | ;;(message "EXEC: %S" command) 718 | (setq d3m-command-event nil) 719 | (d3m:explorer-command-exec command)))))) 720 | :finally 721 | (lambda (x) 722 | (cond 723 | ((buffer-local-value 'd3m-command-event buf) 724 | ;;(message "TRY NEXT: %S" d3m-command-event) 725 | (deferred:$ 726 | (deferred:wait 50) 727 | (deferred:nextc it 728 | (lambda (x) 729 | (with-current-buffer buf 730 | (setq d3m-event-status 'd3m:state-wait) 731 | (d3m:explorer-command-event-task)))))) 732 | (t 733 | ;;(message "FINISH:") 734 | (deferred:$ 735 | (deferred:wait 40) 736 | (deferred:nextc it 737 | (lambda (x) 738 | (with-current-buffer buf 739 | (setq d3m-event-status 'd3m:state-wait)))))))))))) 740 | 741 | (defun d3m:explorer-command-exec (event) 742 | (when event 743 | (funcall event))) 744 | 745 | (defun d3m:explorer-move-gen (move turn) 746 | (let* ((world d3m-world) 747 | (buf (current-buffer)) 748 | (pos-f (d3m:world-pos world)) 749 | (angle (d3m:world-angle world)) 750 | (npos-f (mt:v+v pos-f 751 | (d3m:tofxv 752 | (mt:mxv 753 | (mt:mrot2d (d3m:d2r angle)) move)))) 754 | (nangle (d3m:degree (+ angle turn)))) 755 | (when (< 0 (logand (d3m:draw-wall-find-object 756 | (d3m:world-map world) npos-f) 757 | d3m:tbuf-floor)) 758 | (d3m:world-set-pos world npos-f)) 759 | (d3m:world-set-angle world nangle) 760 | (d3m:update-buffer buf world))) 761 | 762 | (defvar d3m:move-scale 2) 763 | (defvar d3m:turn-scale 15) 764 | 765 | (defun d3m:explorer-move-forward () 766 | (interactive) 767 | (d3m:explorer-move-gen (mt:vnew (vector d3m:move-scale 0)) 0)) 768 | 769 | (defun d3m:explorer-move-backward () 770 | (interactive) 771 | (d3m:explorer-move-gen (mt:vnew (vector (- d3m:move-scale) 0)) 0)) 772 | 773 | (defun d3m:explorer-move-left () 774 | (interactive) 775 | (d3m:explorer-move-gen (mt:vnew (vector 0 (- d3m:move-scale))) 0)) 776 | 777 | (defun d3m:explorer-move-right () 778 | (interactive) 779 | (d3m:explorer-move-gen (mt:vnew (vector 0 d3m:move-scale)) 0)) 780 | 781 | (defun d3m:explorer-turn-left () 782 | (interactive) 783 | (d3m:explorer-move-gen (mt:vnew [0 0]) (- d3m:turn-scale))) 784 | 785 | (defun d3m:explorer-turn-right () 786 | (interactive) 787 | (d3m:explorer-move-gen (mt:vnew [0 0]) d3m:turn-scale)) 788 | 789 | (defun d3m:explorer-turn-back () 790 | (interactive) 791 | (d3m:explorer-move-gen (mt:vnew [0 0]) 180)) 792 | 793 | (defun d3m:explorer-update () 794 | (d3m:update-buffer (current-buffer) d3m-world)) 795 | 796 | 797 | ;;================================================== 798 | 799 | (defvar d3m:explorer-mode-map 800 | (d3m:define-keymap 801 | '( 802 | ("" . d3m:command-move-forward) 803 | ("" . d3m:command-move-backward) 804 | ("" . d3m:command-turn-left) 805 | ("" . d3m:command-turn-right) 806 | ("a" . d3m:command-move-left) 807 | ("s" . d3m:command-move-right) 808 | ("b" . d3m:command-turn-back) 809 | ("m" . d3m:command-toggle-map) 810 | ))) 811 | 812 | (define-derived-mode d3m:explorer-mode 813 | fundamental-mode 814 | "3D Maze Explorer mode" 815 | "3D Maze Explorer mode" 816 | (set (make-local-variable 'd3m-world) nil) 817 | (set (make-local-variable 'd3m-event-status) 'd3m:state-wait) 818 | (set (make-local-variable 'd3m-command-event) nil)) 819 | 820 | (defun d3m:command-toggle-map () 821 | (interactive) 822 | (setq d3m:2dmap-display (not d3m:2dmap-display)) 823 | (setq d3m-command-event 'd3m:explorer-update) 824 | (d3m:explorer-command-event-task)) 825 | 826 | (defun d3m:command-move-forward () 827 | (interactive) 828 | (setq d3m-command-event 'd3m:explorer-move-forward) 829 | (d3m:explorer-command-event-task)) 830 | 831 | (defun d3m:command-move-backward () 832 | (interactive) 833 | (setq d3m-command-event 'd3m:explorer-move-backward) 834 | (d3m:explorer-command-event-task)) 835 | 836 | (defun d3m:command-move-left () 837 | (interactive) 838 | (setq d3m-command-event 'd3m:explorer-move-left) 839 | (d3m:explorer-command-event-task)) 840 | 841 | (defun d3m:command-move-right () 842 | (interactive) 843 | (setq d3m-command-event 'd3m:explorer-move-right) 844 | (d3m:explorer-command-event-task)) 845 | 846 | (defun d3m:command-turn-left () 847 | (interactive) 848 | (setq d3m-command-event 'd3m:explorer-turn-left) 849 | (d3m:explorer-command-event-task)) 850 | 851 | (defun d3m:command-turn-right () 852 | (interactive) 853 | (setq d3m-command-event 'd3m:explorer-turn-right) 854 | (d3m:explorer-command-event-task)) 855 | 856 | (defun d3m:command-turn-back () 857 | (interactive) 858 | (setq d3m-command-event 'd3m:explorer-turn-back) 859 | (d3m:explorer-command-event-task)) 860 | 861 | 862 | ;;================================================== 863 | 864 | (defun d3m:open-maze-buffer () 865 | (interactive) 866 | (d3m:log-init) 867 | (setq d3m:debug-out nil) 868 | (let ((ww (min (window-width) 90))) 869 | (d3m:open-buffer 870 | (d3m:str2map (buffer-string)) 871 | ww (/ ww 3)))) 872 | 873 | ;; (global-set-key (kbd "M-0") 'd3m:open-maze-buffer) 874 | 875 | ;; (setq d3m:debug-out nil) 876 | ;; (setq d3m:debug-out t) 877 | 878 | (defun d3m:test-exec () 879 | (interactive) 880 | (d3m:log-init) 881 | (progn 882 | (eval-current-buffer) 883 | (d3m:open-buffer 884 | (d3m:str2map "#####\n#S#G#\n# #\n#####") 885 | 30 10))) 886 | 887 | (provide '3dmaze) 888 | ;;; 3dmaze.el ends here 889 | -------------------------------------------------------------------------------- /client-maze.el: -------------------------------------------------------------------------------- 1 | ;;; client-maze.el --- maze clients 2 | 3 | ;; Copyright (C) 2011 SAKURAI Masashi 4 | 5 | ;; Author: SAKURAI Masashi 6 | ;; Keywords: games 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; TODO 24 | 25 | ;; ICON表示 26 | ;; ICON取得、キャッシュ 27 | ;; 表示（文字の上に表示？） 28 | ;; 一覧表示 29 | ;; 地図に表示 30 | 31 | ;; See 3dmaze.el for details. 32 | 33 | 34 | ;;; Code: 35 | 36 | (require 'cl) 37 | (require 'derived) 38 | (require 'concurrent) 39 | (require 'widget) 40 | (require 'wid-edit) 41 | (require 'matrix) 42 | 43 | (defstruct csm:map width height map objects) 44 | (defstruct csm:buf width height tbuf zbuf) 45 | (defstruct csm:object id name def pos angle) 46 | 47 | ;; 全体の見え方に対するパラメーター 48 | (defvar csm:scale 10.0 "MAP上の1文字のサイズ。壁の高さ。") 49 | (defvar csm:aperture-size 30.0 "描画すべき画角。単位degree。") 50 | 51 | ;; csm:map-tbuf に入れるオブジェクトのタイプ 52 | (defconst csm:tbuf-none 00) 53 | (defconst csm:tbuf-air 01) 54 | (defconst csm:tbuf-floor 02) 55 | (defconst csm:tbuf-floor2 03) 56 | (defconst csm:tbuf-wall 04) 57 | (defconst csm:tbuf-out 08) 58 | (defconst csm:tbuf-other 16) 59 | (defconst csm:tbuf-other-side 17) 60 | (defconst csm:tbuf-other-back 18) 61 | (defconst csm:tbuf-me 64) 62 | 63 | (defconst csm:zbuf-inf 1e10 "Zバッファの無限遠") 64 | (defvar csm:zbuf-fogout 80.0 "fogで完全に消えてしまう距離（csm:zlimitよりも遠い方が良い）") 65 | (defvar csm:zlimit 60.0 "スキャン打ち切り距離") 66 | 67 | (defconst csm:chr ?\ "bufferに実際にinsertする文字") 68 | 69 | (defvar csm:debug-out nil) 70 | (defvar csm:debug-buffer "*maze log*") 71 | 72 | (defun csm:log-init () 73 | (when (get-buffer csm:debug-buffer) 74 | (kill-buffer csm:debug-buffer))) 75 | 76 | (defun csm:log (&rest args) 77 | (when csm:debug-out 78 | (with-current-buffer 79 | (get-buffer-create csm:debug-buffer) 80 | (buffer-disable-undo) 81 | (goto-char (point-max)) 82 | (insert (apply 'format args) "\n")))) 83 | 84 | (defun csm:define-keymap (keymap-list) 85 | (let ((map (make-sparse-keymap))) 86 | (mapc 87 | (lambda (i) 88 | (define-key map 89 | (if (stringp (car i)) 90 | (read-kbd-macro (car i)) (car i)) 91 | (cdr i))) 92 | keymap-list) 93 | map)) 94 | 95 | (defun csm:world-new (map screen pos angle) 96 | (list map screen pos angle)) 97 | 98 | (defsubst csm:world-map (world) 99 | (car world)) 100 | 101 | (defsubst csm:world-screen (world) 102 | (cadr world)) 103 | 104 | (defsubst csm:world-pos (world) 105 | (nth 2 world)) 106 | 107 | (defsubst csm:world-set-pos (world pos) 108 | (setf (nth 2 world) pos)) 109 | 110 | (defsubst csm:world-angle (world) 111 | (nth 3 world)) 112 | 113 | (defsubst csm:world-set-angle (world angle) 114 | (setf (nth 3 world) angle)) 115 | 116 | (defsubst csm:d2r (deg) 117 | (/ (* pi deg) 180.0)) 118 | 119 | (defsubst csm:d2f (deg) 120 | (/ (* 1024 deg) 360)) 121 | 122 | (defsubst csm:f2d (deg) 123 | (/ (* 360.0 deg) csm:table-num)) 124 | 125 | (defsubst csm:degree (d) 126 | (setq d (floor d)) 127 | (cond 128 | ((< d 0) (+ d 360)) 129 | ((>= d 360) (- d 360)) 130 | (t d))) 131 | 132 | (defsubst csm:degreef (d) 133 | (setq d (floor d)) 134 | (cond 135 | ((< d 0) (+ d csm:table-num)) 136 | ((>= d csm:table-num) (- d csm:table-num)) 137 | (t d))) 138 | 139 | ;; 固定小数点演算を仮定 140 | ;; 値を1024倍して保持しておく 141 | ;; 固定小数点の変数は -f をつける 142 | ;; 30bit整数まで扱えるので、掛け算1回ぐらいならオーバーフローしないはず 143 | 144 | (defvar csm:fx 1024.0 "固定小数基数") 145 | (defvar csm:fxi 1024 "固定小数基数") 146 | 147 | (defsubst csm:tofx (v) 148 | (floor (* v csm:fx))) 149 | 150 | (defsubst csm:fromfx (v) 151 | (/ v csm:fx)) 152 | 153 | (defsubst csm:tofxv (v) 154 | (mt:vfloor2d (mt:sxv2d csm:fx v))) 155 | 156 | (defsubst csm:fromfxv (v) 157 | (mt:sxv2d (/ 1.0 csm:fx) v)) 158 | 159 | ;; 角度について 160 | ;; - 入出力：0-360 161 | ;; - テーブル参照： csm:table-num 162 | 163 | 164 | (defvar csm:table-num 1024 "三角関数テーブルの要素数。1度1つで360個。") 165 | 166 | (defun csm:table-init (func) 167 | (loop for i from 0 below csm:table-num 168 | with array = (make-vector csm:table-num 0) 169 | do (aset array i 170 | (csm:tofx 171 | (min 1048576 ;1024*1024 172 | (funcall func (csm:d2r (/ (* 360.0 i) csm:table-num)))))) 173 | finally return array)) 174 | 175 | (defvar csm:table-sin (csm:table-init 'sin) "三角関数テーブル sin") 176 | (defvar csm:table-cos (csm:table-init 'cos) "三角関数テーブル cos") 177 | (defvar csm:table-tan (csm:table-init 'tan) "三角関数テーブル tab") 178 | 179 | (defsubst csm:sin-f (degree) 180 | (aref csm:table-sin degree)) 181 | 182 | (defsubst csm:cos-f (degree) 183 | (aref csm:table-cos degree)) 184 | 185 | (defsubst csm:tan-f (degree) 186 | (aref csm:table-tan degree)) 187 | 188 | (defun csm:init-table-scanz () 189 | (vconcat 190 | (loop with zf = (csm:tofx 1) 191 | until (> zf (csm:tofx csm:zlimit)) 192 | collect 193 | (let ((ret zf)) 194 | (cond 195 | ((< zf (/ (csm:tofx csm:scale) 2)) 196 | (incf zf (/ (csm:tofx csm:scan-scale) 4))) 197 | ((< zf (csm:tofx csm:scale)) 198 | (incf zf (/ (csm:tofx csm:scan-scale) 3))) 199 | ((< zf (csm:tofx (* 2 csm:scale))) 200 | (incf zf (csm:tofx csm:scan-scale))) 201 | (t 202 | (incf zf (csm:tofx (* 2 csm:scan-scale))))) 203 | ret)))) 204 | 205 | (defvar csm:scan-scale 1.6 "動径方向のスキャンサイズ単位") 206 | (defvar csm:table-scanz (csm:init-table-scanz) 207 | "Zスキャンの距離配列。近くはきめ細かく、遠くは荒くを表現。") 208 | ;;(length csm:table-scanz) 209 | 210 | 211 | (defvar csm:table-wall-num 80 212 | "距離→壁の高さを変換するテーブル（個数）") 213 | (defvar csm:table-wall-delta-f nil 214 | "距離→壁の高さを変換するテーブルの変換単位 ( zf / delta -> index ) 215 | FIXME: should be buffer local") 216 | (defvar csm:table-wall nil "距離→壁の高さを変換するテーブル。 217 | スクリーン高さに依存するのでバッファ初期化時に決まる。 218 | FIXME: should be buffer local") 219 | 220 | (defun csm:init-table-wall (window-height) 221 | (setq csm:table-wall-delta-f (csm:tofx (/ csm:zlimit csm:table-wall-num))) 222 | (setq csm:table-wall 223 | (loop for i from 0 below csm:table-wall-num 224 | with delta = (/ csm:zlimit csm:table-wall-num) 225 | with ret = (make-vector csm:table-wall-num 0) 226 | for z = (* delta (max i 1)) 227 | do (aset ret i (round (* (/ csm:scale z) window-height 0.8))) 228 | finally return ret))) 229 | 230 | (defsubst csm:wall-f (zf) 231 | (let ((idx (/ zf csm:table-wall-delta-f))) 232 | (cond 233 | ((< idx 0) (setq idx 0)) 234 | ((>= idx csm:table-wall-num) 235 | (setq idx (1- csm:table-wall-num)))) 236 | (aref csm:table-wall idx))) 237 | 238 | 239 | ;;================================================== 240 | ;; 接続情報入力 241 | 242 | (defvar csm:dialog-buffer-name "*maze dialog*") 243 | (defvar csm:dialog-value-name nil) 244 | (defvar csm:dialog-value-server nil) 245 | (defvar csm:dialog-value-port nil) 246 | (defvar csm:dialog-window-num nil) 247 | 248 | (defun csm:dialog-startup () 249 | (let (buf) 250 | (setq csm:dialog-window-num (length (window-list))) 251 | (when (get-buffer csm:dialog-buffer-name) 252 | (kill-buffer csm:dialog-buffer-name)) 253 | (setq buf (get-buffer-create csm:dialog-buffer-name)) 254 | (with-current-buffer buf 255 | (buffer-disable-undo) 256 | (widget-insert "Maze Client: Connect to\n\n") 257 | (lexical-let (fname fserver fport) 258 | (setq fname (widget-create 259 | 'editable-field 260 | :size 20 :format " Name: %v \n" 261 | :value (or csm:dialog-value-name user-real-login-name "")) 262 | fserver (widget-create 263 | 'editable-field 264 | :size 20 :format " Server Address: %v \n" 265 | :value (or csm:dialog-value-server "")) 266 | fport (widget-create 267 | 'editable-field 268 | :size 10 :format " Server Port: %v \n" 269 | :value (or csm:dialog-value-port ""))) 270 | ;; OK / Cancel 271 | (widget-insert "\n") 272 | (widget-create 273 | 'push-button 274 | :notify (lambda (&rest ignore) 275 | (setq csm:dialog-value-name (widget-value fname)) 276 | (setq csm:dialog-value-server (widget-value fserver)) 277 | (setq csm:dialog-value-port (widget-value fport)) 278 | (if (and (< 0 (length csm:dialog-value-name)) 279 | (< 0 (length csm:dialog-value-server)) 280 | (< 0 (length csm:dialog-value-port))) 281 | (csm:dialog-on-ok) 282 | (message "The fields should not be null!"))) 283 | "Ok") 284 | (widget-insert " ") 285 | (widget-create 286 | 'push-button 287 | :notify (lambda (&rest ignore) 288 | (csm:dialog-kill-buffer)) 289 | "Cancel") 290 | (widget-insert "\n") 291 | (use-local-map widget-keymap) 292 | (widget-setup) 293 | (goto-char (point-min)) 294 | (widget-forward 1)) 295 | (pop-to-buffer buf)))) 296 | 297 | (defun csm:dialog-kill-buffer () 298 | (let ((win-num (length (window-list)))) 299 | (when (and (not (one-window-p)) 300 | (> win-num csm:dialog-window-num)) 301 | (delete-window)) 302 | (kill-buffer csm:dialog-buffer-name))) 303 | 304 | (defun csm:dialog-on-ok () 305 | (csm:dialog-kill-buffer) 306 | (csm:connect-server csm:dialog-value-name 307 | csm:dialog-value-server 308 | csm:dialog-value-port)) 309 | 310 | 311 | ;;================================================== 312 | ;; Server 通信関係 313 | 314 | (defvar csm:connection-process nil "TCP接続オブジェクト") ; should be buffer local 315 | (defvar csm:connection-map nil "現在稼働中のマップデータなど") ; should be buffer local 316 | (defvar csm:connection-myid nil "自分のID") ; should be buffer local 317 | (defvar csm:server-info (cc:dataflow-environment) "サーバーからもらう情報") 318 | (defvar csm:filter-buffer nil "未処理データ") 319 | 320 | (defun csm:connect-server (name server-address server-port) 321 | (csm:log ">> Connection start: %s / %s : %s" name server-address server-port) 322 | (when csm:connection-process 323 | (delete-process csm:connection-process)) 324 | (cc:dataflow-clear csm:server-info 'map) 325 | (setq csm:connection-process 326 | (open-network-stream "maze connection" "*maze connection*" 327 | server-address (string-to-number server-port))) 328 | (setq csm:filter-buffer (get-buffer-create "*maze buffer*")) 329 | (with-current-buffer csm:filter-buffer 330 | (erase-buffer) (buffer-disable-undo)) 331 | (set-process-filter csm:connection-process 'csm:client-process-filter) 332 | (set-process-sentinel csm:connection-process 'csm:client-process-sentinel) 333 | (process-send-string csm:connection-process (format "%S\n" (list 'name name))) 334 | (deferred:$ 335 | (cc:dataflow-get csm:server-info 'map) 336 | (deferred:nextc it 337 | (lambda (data) 338 | (destructuring-bind (map pos angle) data 339 | (csm:open-buffer map pos angle)))))) 340 | 341 | (defun csm:client-process-filter (process message) 342 | (csm:log "INCOMING: [%S]" message) 343 | (let (content) 344 | (with-current-buffer csm:filter-buffer 345 | (when message 346 | (goto-char (point-max)) 347 | (insert message)) 348 | (goto-char (point-min)) 349 | (let ((pos (condition-case err 350 | (scan-lists (point-min) 1 0) 351 | ('scan-error (message "%S" err) nil)))) 352 | (when pos 353 | (setq content (car (read-from-string (buffer-substring (point-min) pos)))) 354 | (delete-region (point-min) pos)))) 355 | (when content 356 | (csm:log "MGS: [%S]" content) 357 | (condition-case err 358 | (let* ((tag (car content))) 359 | (cond 360 | ((eq tag 'map) 361 | (csm:build-map-from-server content)) 362 | ((eq tag 'move) 363 | (csm:notify-move content csm:connection-map)) 364 | ((eq tag 'connect) 365 | (csm:notify-connect content csm:connection-map)) 366 | ((eq tag 'disconnect) 367 | (csm:notify-disconnect content csm:connection-map)) 368 | (t 369 | (csm:log "!!Unknown Protocol Message : %s" tag))) 370 | (deferred:call 'csm:client-process-filter process nil)) 371 | ('error (message "MsgError: %S / <= %S" err content)))))) 372 | 373 | (defun csm:client-process-sentinel (process msg) 374 | "切断された場合など" 375 | (csm:log "!! Process Sentinel : %S : %S" process msg) 376 | (if (y-or-n-p "Disconnected. Try to re-connect ?") 377 | (csm:connect-server csm:dialog-value-name 378 | csm:dialog-value-server 379 | csm:dialog-value-port) 380 | (csm:command-quit))) 381 | 382 | (defun csm:build-map-from-server (data) 383 | (destructuring-bind 384 | (tag width height src id ix iy angle) data 385 | (let* ((mapdata 386 | (loop with ret = (make-vector (length src) 0) 387 | for i from 0 below (length src) 388 | for d across src 389 | do (aset ret i (if (= (aref src i) ?#) 1 0)) 390 | finally return ret)) 391 | (map (make-csm:map 392 | :width width :height height 393 | :map mapdata))) 394 | (setq csm:connection-myid id) ; fix me 395 | (setq csm:connection-map map) ; fix me 396 | (cc:dataflow-set csm:server-info 'map 397 | (list map (mt:vnew (vector ix iy)) angle)) 398 | map))) 399 | 400 | (defun csm:other-get-by-id (id map) 401 | (if (eq id csm:connection-myid) nil ; fix me 402 | (loop for i in (csm:map-objects map) 403 | if (eq id (csm:object-id i)) 404 | do (return i) 405 | finally return nil))) 406 | 407 | (defun csm:other-add (obj map) 408 | (push obj (csm:map-objects map))) 409 | 410 | (defun csm:notify-move (data map) 411 | (let ((moves (cadr data))) 412 | (loop for (id name x y angle) in moves 413 | for obj = (csm:other-get-by-id id map) 414 | if obj do 415 | (setf (csm:object-pos obj) (mt:vnew (vector x y))) 416 | (setf (csm:object-angle obj) angle) 417 | else do 418 | (unless (eq id csm:connection-myid) ; fix me 419 | (csm:other-add 420 | (make-csm:object :id id :name name :def (csm:object-def-get name) 421 | :pos (mt:vnew (vector x y)) :angle angle) map)))) 422 | (csm:post-event-task 'csm:explorer-update)) 423 | 424 | (defun csm:notify-connect (data map) 425 | (destructuring-bind (tag id name x y angle) data 426 | (message "Joined: %s" name) 427 | (csm:post-event-task 'csm:explorer-update))) 428 | 429 | (defun csm:notify-disconnect (data map) 430 | (destructuring-bind (tag id name) data 431 | (setf (csm:map-objects map) 432 | (remove-if (lambda (i) (eq id (csm:object-id i))) 433 | (csm:map-objects map))) 434 | (csm:post-event-task 'csm:explorer-update) 435 | (message "Disconnected: %s" name))) 436 | 437 | (defun csm:server-send-move (posv angle) 438 | (process-send-string 439 | csm:connection-process 440 | (format "%S\n" (list 'move (mt:vref posv 0) (mt:vref posv 1) angle)))) 441 | 442 | (defun csm:server-disconnect () 443 | (when csm:connection-process 444 | (set-process-sentinel csm:connection-process nil) 445 | (delete-process csm:connection-process) 446 | (setq csm:connection-process nil) 447 | (setq csm:connection-map nil))) 448 | 449 | 450 | ;;================================================== 451 | ;; メイン 画面表示 452 | 453 | (defvar csm:buffer-main "*3d maze*") 454 | 455 | (defun csm:open-buffer (map init-posv init-angle &optional screen-width screen-height) 456 | (let ((buf (get-buffer-create csm:buffer-main)) 457 | (scr (csm:init-screen screen-width screen-height)) 458 | world) 459 | (setq world (csm:world-new map scr (csm:tofxv init-posv) init-angle)) 460 | (with-current-buffer buf 461 | (csm:init-table-wall (csm:buf-height scr)) 462 | (csm:explorer-mode) 463 | (buffer-disable-undo) 464 | (setq d3m-world world) 465 | (csm:draw-world world) 466 | (csm:init-buffer buf world) 467 | (csm:update-buffer buf world)) 468 | (switch-to-buffer buf))) 469 | 470 | (defun csm:init-screen (&optional screen-width screen-height) 471 | "裏画面バッファの準備" 472 | (let* ((ww (or screen-width (window-width))) 473 | (wh (or screen-height (window-height)))) 474 | (make-csm:buf :width ww :height wh 475 | :tbuf (make-vector (* ww wh) csm:tbuf-none) 476 | :zbuf (make-vector (* ww wh) (csm:tofx csm:zbuf-inf))))) 477 | 478 | (defun csm:draw-world (world) 479 | (csm:clear-screen (csm:world-screen world)) 480 | (csm:draw-wall world) 481 | (csm:draw-objects world) 482 | ) 483 | 484 | 485 | (defun csm:clear-screen (scr) 486 | (fillarray (csm:buf-tbuf scr) csm:tbuf-none) 487 | (fillarray (csm:buf-zbuf scr) (csm:tofx csm:zbuf-inf))) 488 | 489 | (defun csm:draw-wall (world) 490 | (let* ((scr (csm:world-screen world)) (map (csm:world-map world)) 491 | (tbuf (csm:buf-tbuf scr)) (zbuf (csm:buf-zbuf scr)) 492 | (ww (csm:buf-width scr)) (wh (csm:buf-height scr)) wwe 493 | (hww (/ ww 2)) (hwh (/ wh 2)) 494 | (angle-f (csm:tofx (csm:d2f (csm:world-angle world)))) 495 | (pos-f (csm:world-pos world)) 496 | (posxf (mt:vref pos-f 0)) (posyf (mt:vref pos-f 1)) 497 | (dt-f (/ (csm:tofx (csm:d2f csm:aperture-size)) hww)) 498 | (zlimit-f (csm:tofx csm:zlimit)) 499 | (start-f (csm:tofx 1.0)) obj (rn-f (mt:vcp pos-f))) 500 | (setq wwe (- ww 1)) ; for loop step 501 | (loop for i from 0 below wwe by 2 502 | for px = (- i hww) 503 | for th = (csm:degreef (csm:fromfx (+ angle-f (* dt-f px)))) 504 | for cosf = (csm:cos-f th) for sinf = (csm:sin-f th) 505 | do 506 | ;;(csm:log ">>> Scan way th: %04f cosf: %S sinf: %S" th cosf sinf) 507 | (loop for zf across csm:table-scanz 508 | do 509 | (mt:vset2d rn-f 510 | (+ posxf (/ (* zf cosf) csm:fxi)) 511 | (+ posyf (/ (* zf sinf) csm:fxi))) 512 | (setq obj (csm:draw-wall-find-object map rn-f)) 513 | ;;(csm:log "Scan ?: %s d: %04f rn: %S" obj zf rn-f) 514 | (cond 515 | ((eq obj csm:tbuf-wall) 516 | (csm:draw-wall-draw-wall i zf) 517 | (csm:draw-wall-draw-wall (1+ i) zf) 518 | (return)) 519 | ((eq obj csm:tbuf-out) 520 | (csm:draw-wall-draw-out i zf) 521 | (csm:draw-wall-draw-out (1+ i) zf) 522 | (return)) 523 | (t 524 | (csm:draw-wall-draw-floor i zf obj) 525 | (csm:draw-wall-draw-floor (1+ i) zf obj))))))) 526 | 527 | (defun csm:draw-wall-find-object (map v-f) 528 | (let* ((x (floor (csm:fromfx (/ (mt:vref v-f 0) csm:scale)))) 529 | (y (floor (csm:fromfx (/ (mt:vref v-f 1) csm:scale))))) 530 | (cond 531 | ((or (< x 0) (< y 0) 532 | (>= x (csm:map-width map)) 533 | (>= y (csm:map-height map))) 534 | csm:tbuf-out) 535 | (t 536 | (let* ((idx (+ x (* y (csm:map-width map))))) 537 | (cond 538 | ((= 0 (aref (csm:map-map map) idx)) 539 | (if (< 0 (logand (+ x y) 1)) 540 | csm:tbuf-floor csm:tbuf-floor2)) 541 | (t csm:tbuf-wall))))))) 542 | 543 | (defun csm:draw-wall-draw-wall (x z-f) 544 | (let* ((wall (csm:wall-f z-f)) 545 | (hwall (ceiling (/ wall 2.0))) 546 | (top (max 0 (- hwh hwall))) 547 | (btm (min (1- wh) (+ hwh hwall)))) 548 | ;;(csm:log "# x: %2s z: %06f" x z-f) 549 | (loop for i from top to btm 550 | for idx = (+ x (* i ww)) 551 | do 552 | (aset tbuf idx csm:tbuf-wall) 553 | (aset zbuf idx z-f)))) 554 | 555 | (defun csm:draw-wall-draw-out (x z-f) 556 | ;; DO NOTHING 557 | ) 558 | 559 | (defun csm:draw-wall-draw-floor (x z-f obj) 560 | (let* ((wall (csm:wall-f z-f)) 561 | (hwall (/ wall 2)) 562 | (btm (min wh (+ hwall hwh)))) 563 | ;;(csm:log "F x: %2s z: %06f" x z-f) 564 | (loop for i from btm below wh 565 | for idx = (+ x (* i ww)) 566 | for floorz = (aref zbuf idx) 567 | do 568 | (when (< z-f floorz) 569 | (aset tbuf idx obj) 570 | (aset zbuf idx z-f))))) 571 | 572 | (defun csm:draw-objects (world) 573 | (loop for obj in (csm:map-objects 574 | (csm:world-map world)) 575 | do 576 | (csm:draw-objects-one world obj))) 577 | 578 | (defvar csm:letter-def-table (make-hash-table :test 'equal) 579 | "文字 -> mapのハッシュ") 580 | 581 | (defun csm:object-def-get (chr) 582 | (let ((map (gethash chr csm:letter-def-table))) 583 | (unless map 584 | (setq map (csm:init-letter chr)) 585 | (puthash chr map csm:letter-def-table)) 586 | map)) 587 | 588 | (defvar csm:program-banner 589 | (cond 590 | ((eq 'darwin system-type) "/usr/bin/banner") 591 | ((eq 'gnu/linux system-type) "/usr/bin/printerbanner") 592 | (t "banner")) 593 | "文字プログラム") 594 | 595 | (defun csm:init-letter (letter) 596 | (let* ((src 597 | (with-temp-buffer 598 | (call-process csm:program-banner nil t nil 599 | "-w" "60" (format "%s" letter)) 600 | (buffer-string))) 601 | (lines (split-string src "\n")) 602 | (height (loop for i in lines maximize (length i))) 603 | (width (* 4 (length lines))) 604 | (ret (make-vector (* width height) 0))) 605 | (loop for line in lines 606 | for x from 0 below (length lines) 607 | do 608 | (loop for c across line 609 | for y from 0 below (length line) 610 | for val = (if (eql c ?#) 1 0) 611 | for idx = (+ (* x 4) (* (- height y 1) width)) 612 | do 613 | (aset ret idx val) 614 | (aset ret (incf idx) val) 615 | (aset ret (incf idx) val) 616 | (aset ret (incf idx) val))) 617 | (make-csm:map :width width :height height :map ret))) 618 | 619 | (defun csm:object-debug-out (object) 620 | (csm:log-init) 621 | (with-current-buffer (get-buffer-create csm:debug-buffer) 622 | (loop for y from 0 below (csm:map-height object) do 623 | (loop for x from 0 below (csm:map-width object) do 624 | (insert (if (= 1 (aref (csm:map-map object) 625 | (+ x (* y (csm:map-width object))))) 626 | "#" " "))) 627 | (insert "\n"))) 628 | (pop-to-buffer csm:debug-buffer)) 629 | ;; (csm:object-debug-out (csm:init-letter "@")) 630 | 631 | (defun csm:draw-objects-one (world object) 632 | (let* 633 | ((scr (csm:world-screen world)) (map (csm:world-map world)) 634 | (tbuf (csm:buf-tbuf scr)) (zbuf (csm:buf-zbuf scr)) 635 | (ww (csm:buf-width scr)) (wh (csm:buf-height scr)) 636 | (hww (/ ww 2)) (hwh (/ wh 2)) 637 | (angle (csm:world-angle world)) 638 | (posv (mt:sxv2d (/ 1.0 csm:fx) (csm:world-pos world))) 639 | (tposv (csm:object-pos object)) 640 | (relv (mt:v-v2d tposv posv)) 641 | (rad (atan (mt:vref relv 1) (mt:vref relv 0))) 642 | (degree (csm:degree (- angle (* 180 (/ rad pi))))) 643 | (vlen (mt:vlen2d relv)) 644 | (aplimit (* 1.6 csm:aperture-size)) 645 | (dw (/ wh csm:aperture-size)) cx) 646 | (cond 647 | ((and (<= 0 degree) (< degree aplimit)) 648 | (setq cx (floor (- hww (* dw degree))))) 649 | ((and (< (- 360 aplimit) degree) (< degree 360)) 650 | (setq cx (floor (+ hww (* dw (- 360 degree))))))) 651 | (when (or (< vlen 3.0) (> vlen csm:zlimit)) (setq cx nil)) 652 | ;;(message "deg: %s dist: %2.3f cx: %s" degree vlen cx) 653 | (when cx 654 | (let* ((def (csm:object-def object)) 655 | (trad (csm:d2r (csm:object-angle object))) 656 | (ip (mt:vip (mt:vunit relv) 657 | (mt:vnew (vector (cos trad) (sin trad))))) 658 | (lw (csm:map-width def)) 659 | (lh (csm:map-height def)) 660 | (lmap (csm:map-map def)) 661 | (hlw (/ lw 2)) (hlh (/ lh 2)) 662 | (delta (* (/ csm:scale vlen) (/ csm:scale hlh))) ; 文字サイズ調整（適当） 663 | (vlenf (csm:tofx vlen)) 664 | (type 665 | (cond 666 | ((< ip -0.7071) ; (cos (/ pi 4)) 667 | csm:tbuf-other) 668 | ((< ip 0.7071) ; (cos (/ (* 3 pi) 4)) 669 | csm:tbuf-other-side) 670 | (t csm:tbuf-other-back)))) 671 | (csm:log "OBJ: ip:%s z-f:%S" ip vlenf) 672 | (loop for ly from 0 below lh 673 | for scry = (floor (+ (* 1.2 hwh) (* delta (- ly hlh)))) do 674 | (loop for lx from 0 below lw 675 | for scrx = (floor (+ cx (* delta (- lx hlw)))) 676 | for scridx = (+ scrx (* ww scry)) 677 | for sczf = (if (and (<= 0 scrx) (< scrx ww) (<= 0 scry) (< scry wh)) 678 | (aref zbuf scridx)) 679 | for val = (aref lmap (+ lx (* ly lw))) do 680 | (when (and sczf (= 1 val) (< vlenf sczf)) 681 | (aset tbuf scridx type) 682 | (aset zbuf scridx vlenf)))))))) 683 | 684 | 685 | ;;================================================== 686 | 687 | (defvar csm:2dmap-display t "display switch 2D map") 688 | (defvar csm:2dmap-radial 3.0 "map size") 689 | (defvar csm:2dmap-rect-left 0.7 "left-top (0.0-1.0)") 690 | (defvar csm:2dmap-rect-top 0.0 "left-top (0.0-1.0)") 691 | (defvar csm:2dmap-rect-width 0.3 "width (0.0-1.0)") 692 | (defvar csm:2dmap-rect-height 0.3 "height (0.0-1.0)") 693 | 694 | (defun csm:draw-2dmap (world) 695 | (when csm:2dmap-display 696 | (let* 697 | ((scr (csm:world-screen world)) (map (csm:world-map world)) 698 | (lmap (csm:map-map map)) 699 | (mapw (csm:map-width map)) (maph (csm:map-height map)) 700 | (tbuf (csm:buf-tbuf scr)) (zbuf (csm:buf-zbuf scr)) 701 | (ww (csm:buf-width scr)) (wh (csm:buf-height scr)) 702 | (angle (csm:world-angle world)) 703 | (posv (mt:sxv2d (/ 1.0 csm:fx) (csm:world-pos world))) 704 | (scrx (floor (* ww csm:2dmap-rect-left))) 705 | (scry (floor (* wh csm:2dmap-rect-top))) 706 | (scrw (floor (* ww csm:2dmap-rect-width))) (scrwe (1- scrw)) ; for loop step 707 | (scrh (floor (* wh csm:2dmap-rect-height))) 708 | (scrhw (/ scrw 2)) (scrhh (/ scrh 2)) 709 | (scrxe (+ scrx scrw)) (scrye (+ scry scrh)) 710 | (rot (mt:mrot2d (csm:d2r (+ angle 90)))) 711 | ) 712 | ;;(csm:log "=====================") 713 | (loop for scryi from 0 below scrh 714 | for scryii = (- scryi scrhh) 715 | with basev0 = (mt:vnew [0 0]) 716 | do 717 | (loop for scrxi from 0 below scrwe by 2 718 | for scrxii = (- scrxi scrhw) 719 | for basev = (mt:vset2d 720 | basev0 721 | (* csm:2dmap-radial scrxii) 722 | (* 2 csm:2dmap-radial scryii)) 723 | for mapv = (mt:v+v2d= (mt:mxv2d rot basev) posv) 724 | for mapx = (floor (/ (mt:vref mapv 0) csm:scale)) 725 | for mapy = (floor (/ (mt:vref mapv 1) csm:scale)) 726 | for idx = 727 | (if (and (<= 0 mapx) (< mapx mapw) 728 | (<= 0 mapy) (< mapy maph)) 729 | (+ mapx (* mapy mapw)) nil) 730 | for val = (if idx (aref lmap idx) nil) 731 | for scridx = (+ scrxi scrx (* ww (+ scry scryi))) 732 | for vlenz = (csm:tofx (mt:vlen2d basev)) 733 | do 734 | ;;(csm:log "mapx:%s mapy:%s idx:%s val:%s" mapx mapy idx val) 735 | (cond 736 | ((and (= 0 scrxii) (= 0 scryii)) 737 | (aset tbuf scridx csm:tbuf-me) 738 | (aset zbuf scridx vlenz) 739 | (aset tbuf (1+ scridx) csm:tbuf-me) 740 | (aset zbuf (1+ scridx) vlenz)) 741 | ((null val) 742 | (aset tbuf scridx csm:tbuf-out) 743 | (aset zbuf scridx vlenz) 744 | (aset tbuf (1+ scridx) csm:tbuf-out) 745 | (aset zbuf (1+ scridx) vlenz)) 746 | ((= 1 val) 747 | (aset tbuf scridx csm:tbuf-wall) 748 | (aset zbuf scridx vlenz) 749 | (aset tbuf (1+ scridx) csm:tbuf-wall) 750 | (aset zbuf (1+ scridx) vlenz)) 751 | (t 752 | (aset tbuf scridx csm:tbuf-floor) 753 | (aset zbuf scridx vlenz) 754 | (aset tbuf (1+ scridx) csm:tbuf-floor) 755 | (aset zbuf (1+ scridx) vlenz)))))))) 756 | 757 | 758 | ;;================================================== 759 | 760 | (defun csm:init-buffer (buf world) 761 | "バッファに文字列を書き込み" 762 | (erase-buffer) 763 | (let* ((buffer-read-only nil) 764 | (scr (csm:world-screen world)) 765 | (ww (csm:buf-width scr)) 766 | (wh (csm:buf-height scr)) 767 | (line (make-string ww csm:chr))) 768 | (loop for i from 0 below wh do 769 | (insert line "\n")) 770 | (goto-char (point-min)) 771 | (csm:screen-bitblt buf world))) 772 | 773 | (defstruct csm:color-set num delta array) 774 | 775 | (defun csm:color-set-generate (base fog num) 776 | (let ((delta (/ csm:zbuf-fogout num)) cl) 777 | (make-csm:color-set 778 | :num num 779 | :delta (csm:tofx delta) 780 | :array 781 | (vconcat 782 | (loop for i from 0 below num 783 | for d = (* delta i) 784 | for param = (/ (- csm:zbuf-fogout d) csm:zbuf-fogout) 785 | for cl = 786 | (cond 787 | ((< csm:zbuf-fogout d) fog) 788 | ((< d 1.0) base) 789 | (t 790 | (mt:v+v 791 | (mt:sxv param base) 792 | (mt:sxv (- 1.0 param) fog)))) 793 | collect 794 | (list ':background 795 | (format "#%02x%02x%02x" 796 | (mt:vref cl 0) 797 | (mt:vref cl 1) 798 | (mt:vref cl 2)))))))) 799 | 800 | (defvar csm:color-set-floor 801 | (csm:color-set-generate (mt:vnew [130 71 51]) (mt:vnew [255 255 255]) 32)) 802 | (defvar csm:color-set-floor2 803 | (csm:color-set-generate (mt:vnew [ 70 31 30]) (mt:vnew [255 255 255]) 32)) 804 | (defvar csm:color-set-wall 805 | (csm:color-set-generate (mt:vnew [ 51 51 204]) (mt:vnew [255 255 255]) 32)) 806 | 807 | (defvar csm:color-set-other 808 | (csm:color-set-generate (mt:vnew [255 90 90]) (mt:vnew [255 255 255]) 32)) 809 | (defvar csm:color-set-other-side 810 | (csm:color-set-generate (mt:vnew [230 230 80]) (mt:vnew [255 255 255]) 32)) 811 | (defvar csm:color-set-other-back 812 | (csm:color-set-generate (mt:vnew [ 50 255 50]) (mt:vnew [255 255 255]) 32)) 813 | 814 | (defvar csm:color-default '(:background "white")) 815 | (defvar csm:color-out '(:background "lightgray")) 816 | (defvar csm:color-me '(:background "pink")) 817 | 818 | (defun csm:color-set-get (set z-f) 819 | (let* ((idx (/ z-f (csm:color-set-delta set))) 820 | (array (csm:color-set-array set)) 821 | (len (csm:color-set-num set))) 822 | (cond 823 | ((< idx 0) (aref array 0)) 824 | ((< idx len) (aref array idx)) 825 | (t (aref array (- len 2)))))) 826 | 827 | (defun csm:screen-color (type z-f) 828 | (cond 829 | ((eq type csm:tbuf-floor) (csm:color-set-get csm:color-set-floor z-f)) 830 | ((eq type csm:tbuf-floor2) (csm:color-set-get csm:color-set-floor2 z-f)) 831 | ((eq type csm:tbuf-wall) (csm:color-set-get csm:color-set-wall z-f)) 832 | ((eq type csm:tbuf-other) (csm:color-set-get csm:color-set-other z-f)) 833 | ((eq type csm:tbuf-other-side) (csm:color-set-get csm:color-set-other-side z-f)) 834 | ((eq type csm:tbuf-other-back) (csm:color-set-get csm:color-set-other-back z-f)) 835 | ((eq type csm:tbuf-me) csm:color-me) 836 | ((eq type csm:tbuf-out) csm:color-out) 837 | ((eq type csm:tbuf-none) csm:color-default) 838 | (t csm:color-default))) 839 | 840 | (defun csm:screen-bitblt (buf world) 841 | "裏画面からバッファのテキストプロパティを書き換え" 842 | (let* ((buffer-read-only nil) 843 | (map (csm:world-map world)) 844 | (scr (csm:world-screen world)) 845 | (tbuf (csm:buf-tbuf scr)) 846 | (zbuf (csm:buf-zbuf scr)) 847 | (ww (csm:buf-width scr)) 848 | (wh (csm:buf-height scr)) 849 | (line (make-string ww csm:chr))) 850 | (loop for y from 0 below wh 851 | with bpos = (point-min) 852 | with spos = 0 853 | do 854 | (loop for x from 0 below ww 855 | do 856 | (put-text-property 857 | bpos (1+ bpos) 'face 858 | (csm:screen-color (aref tbuf spos) (aref zbuf spos)) 859 | buf) 860 | (incf bpos) (incf spos)) 861 | (incf bpos) ; line separator 862 | ))) 863 | 864 | (defun csm:update-mode-line (&optional msg) 865 | (let* ((world d3m-world) 866 | (pos (mt:sxv 0.1 (csm:fromfxv (csm:world-pos world)))) 867 | (map (csm:world-map world)) 868 | (msg-line (if msg (list "---" msg)))) 869 | (setq mode-line-format 870 | `("-" mode-line-mule-info 871 | " " 872 | ,(format "Pos: (%3.1f, %3.1f)" 873 | (mt:vref pos 0) (mt:vref pos 1)) 874 | ,@msg-line 875 | "-%-")) 876 | (force-mode-line-update))) 877 | 878 | (defun csm:update-buffer (buf world) 879 | (let ((start-time (float-time)) map-time bitblt-time gc-time fin-time) 880 | (csm:draw-world world) 881 | (setq map-time (float-time)) 882 | (csm:draw-2dmap world) 883 | (setq bitblt-time (float-time)) 884 | (csm:screen-bitblt buf world) 885 | (setq gc-time (float-time)) 886 | (garbage-collect) 887 | (setq fin-time (float-time)) 888 | (csm:update-mode-line 889 | (format "[geo:%2.3f map:%2.3f bitblt:%2.3f gc:%2.3f" 890 | (- map-time start-time) 891 | (- bitblt-time map-time) 892 | (- gc-time bitblt-time) 893 | (- fin-time gc-time))))) 894 | 895 | 896 | ;;================================================== 897 | 898 | ;; バッファローカル変数 899 | ;; d3m-command-event : キー入力の指示内容 900 | ;; d3m-event-status : 処理中 csm:state-busy, 入力待ち csm:state-wait 901 | 902 | (defun csm:post-event-task (event) 903 | "非同期に実行させたいイベントを登録する。最後にpostされたものだけが残る" 904 | (let ((buf (get-buffer csm:buffer-main))) 905 | (when buf 906 | (with-current-buffer buf 907 | (if (or 908 | (null d3m-command-event) ;; 何もなければ登録 909 | (and d3m-command-event ;; update(再描画)イベントは上書きしない 910 | (not (eq event 'csm:explorer-update)))) 911 | (setq d3m-command-event event)) 912 | (csm:explorer-command-event-task))))) 913 | 914 | (defun csm:explorer-command-event-task () 915 | "d3m-command-event を読み取って実行する" 916 | ;;(message "TASK") 917 | (when (and d3m-command-event 918 | (eq d3m-event-status 'csm:state-wait)) 919 | (lexical-let ((buf (current-buffer))) 920 | (deferred:try 921 | (deferred:$ 922 | (deferred:next 923 | (lambda (x) 924 | (with-current-buffer buf 925 | (setq d3m-event-status 'csm:state-busy) 926 | (let ((command d3m-command-event)) 927 | ;;(message "EXEC: %S" command) 928 | (setq d3m-command-event nil) 929 | (csm:explorer-command-exec command)))))) 930 | :finally 931 | (lambda (x) 932 | (cond 933 | ((buffer-local-value 'd3m-command-event buf) 934 | ;;(message "TRY NEXT: %S" d3m-command-event) 935 | (deferred:$ 936 | (deferred:wait 50) 937 | (deferred:nextc it 938 | (lambda (x) 939 | (with-current-buffer buf 940 | (setq d3m-event-status 'csm:state-wait) 941 | (csm:explorer-command-event-task)))))) 942 | (t 943 | ;;(message "FINISH:") 944 | (deferred:$ 945 | (deferred:wait 40) 946 | (deferred:nextc it 947 | (lambda (x) 948 | (with-current-buffer buf 949 | (setq d3m-event-status 'csm:state-wait)))))))))))) 950 | 951 | (defun csm:explorer-command-exec (event) 952 | (when event 953 | (funcall event))) 954 | 955 | (defun csm:explorer-move-gen (move turn) 956 | (let* ((world d3m-world) 957 | (buf (current-buffer)) 958 | (pos-f (csm:world-pos world)) 959 | (angle (csm:world-angle world)) 960 | (npos-f (mt:v+v pos-f 961 | (csm:tofxv 962 | (mt:mxv 963 | (mt:mrot2d (csm:d2r angle)) move)))) 964 | (nangle (csm:degree (+ angle turn)))) 965 | (when (< 0 (logand (csm:draw-wall-find-object 966 | (csm:world-map world) npos-f) 967 | csm:tbuf-floor)) 968 | (csm:world-set-pos world npos-f)) 969 | (csm:world-set-angle world nangle) 970 | (csm:server-send-move (csm:fromfxv npos-f) nangle) 971 | (csm:update-buffer buf world))) 972 | 973 | (defvar csm:move-scale 2) 974 | (defvar csm:turn-scale 15) 975 | 976 | (defun csm:explorer-move-forward () 977 | (interactive) 978 | (csm:explorer-move-gen (mt:vnew (vector csm:move-scale 0)) 0)) 979 | 980 | (defun csm:explorer-move-backward () 981 | (interactive) 982 | (csm:explorer-move-gen (mt:vnew (vector (- csm:move-scale) 0)) 0)) 983 | 984 | (defun csm:explorer-move-left () 985 | (interactive) 986 | (csm:explorer-move-gen (mt:vnew (vector 0 (- csm:move-scale))) 0)) 987 | 988 | (defun csm:explorer-move-right () 989 | (interactive) 990 | (csm:explorer-move-gen (mt:vnew (vector 0 csm:move-scale)) 0)) 991 | 992 | (defun csm:explorer-turn-left () 993 | (interactive) 994 | (csm:explorer-move-gen (mt:vnew [0 0]) (- csm:turn-scale))) 995 | 996 | (defun csm:explorer-turn-right () 997 | (interactive) 998 | (csm:explorer-move-gen (mt:vnew [0 0]) csm:turn-scale)) 999 | 1000 | (defun csm:explorer-turn-back () 1001 | (interactive) 1002 | (csm:explorer-move-gen (mt:vnew [0 0]) 180)) 1003 | 1004 | (defun csm:explorer-update () 1005 | (csm:update-buffer (current-buffer) d3m-world)) 1006 | 1007 | 1008 | ;;================================================== 1009 | 1010 | (defvar csm:explorer-mode-map 1011 | (csm:define-keymap 1012 | '( 1013 | ("" . csm:command-move-forward) 1014 | ("" . csm:command-move-backward) 1015 | ("" . csm:command-turn-left) 1016 | ("" . csm:command-turn-right) 1017 | ("a" . csm:command-move-left) 1018 | ("s" . csm:command-move-right) 1019 | ("b" . csm:command-turn-back) 1020 | ("m" . csm:command-toggle-map) 1021 | ("q" . csm:command-quit) 1022 | ))) 1023 | 1024 | (define-derived-mode csm:explorer-mode 1025 | fundamental-mode 1026 | "3D Maze Explorer mode" 1027 | "3D Maze Explorer mode" 1028 | (set (make-local-variable 'd3m-world) nil) 1029 | (set (make-local-variable 'd3m-event-status) 'csm:state-wait) 1030 | (set (make-local-variable 'd3m-command-event) nil) 1031 | (setq buffer-read-only t)) 1032 | 1033 | (defun csm:command-toggle-map () 1034 | (interactive) 1035 | (setq csm:2dmap-display (not csm:2dmap-display)) 1036 | (csm:post-event-task 'csm:explorer-update)) 1037 | 1038 | (defun csm:command-move-forward () 1039 | (interactive) 1040 | (csm:post-event-task 'csm:explorer-move-forward)) 1041 | 1042 | (defun csm:command-move-backward () 1043 | (interactive) 1044 | (csm:post-event-task 'csm:explorer-move-backward)) 1045 | 1046 | (defun csm:command-move-left () 1047 | (interactive) 1048 | (csm:post-event-task 'csm:explorer-move-left)) 1049 | 1050 | (defun csm:command-move-right () 1051 | (interactive) 1052 | (csm:post-event-task 'csm:explorer-move-right)) 1053 | 1054 | (defun csm:command-turn-left () 1055 | (interactive) 1056 | (csm:post-event-task 'csm:explorer-turn-left)) 1057 | 1058 | (defun csm:command-turn-right () 1059 | (interactive) 1060 | (csm:post-event-task 'csm:explorer-turn-right)) 1061 | 1062 | (defun csm:command-turn-back () 1063 | (interactive) 1064 | (csm:post-event-task 'csm:explorer-turn-back)) 1065 | 1066 | (defun csm:command-update () 1067 | (interactive) 1068 | (csm:post-event-task 'csm:explorer-update)) 1069 | 1070 | (defun csm:command-quit () 1071 | (interactive) 1072 | (setq d3m-command-event nil) 1073 | (when (get-buffer csm:buffer-main) 1074 | (kill-buffer csm:buffer-main)) 1075 | (csm:server-disconnect)) 1076 | 1077 | 1078 | ;;================================================== 1079 | 1080 | (defun csm:client-start () 1081 | (interactive) 1082 | (csm:log-init) 1083 | (csm:dialog-startup)) 1084 | 1085 | ;; (global-set-key (kbd "M-0") 'csm:client-start) 1086 | 1087 | ;; (eval-current-buffer) 1088 | ;; (csm:log-init) 1089 | ;; (csm:connect-server csm:dialog-value-name "liza2.local" csm:dialog-value-port) 1090 | ;; (setq csm:debug-out nil) 1091 | ;; (setq csm:debug-out t) 1092 | ;; (list-processes) 1093 | 1094 | (provide 'client-maze) 1095 | ;;; client-maze.el ends here 1096 | --------------------------------------------------------------------------------