xelf.org 217 KB
Newer Older
David O'Toole's avatar
David O'Toole committed
1
#+TITLE: Xelf: eXtensible Emacs-Like Facility
David O'Toole's avatar
David O'Toole committed
2
#+AUTHOR: David O'Toole <dto@xelf.me>
David O'Toole's avatar
David O'Toole committed
3
#+OPTIONS: toc:3 *:nil
4
#+PROPERTY: header-args:lisp :results silent :noweb no :tangle xelf.lisp :package "xelf" :comments both
David O'Toole's avatar
David O'Toole committed
5
#+INFOJS_OPT: view:info mouse:underline up:index.html home:http://xelf.me toc:t ftoc:t ltoc:t
David O'Toole's avatar
David O'Toole committed
6
# (setq org-confirm-babel-evaluate nil)
David O'Toole's avatar
David O'Toole committed
7

David O'Toole's avatar
David O'Toole committed
8 9
* About this document

10
#+BEGIN_QUOTE
David O'Toole's avatar
David O'Toole committed
11 12
Use the N and P keys to flip to the Next and Previous pages, or click
the links in the header. Press B to go Back or "?" for help.
13
#+END_QUOTE
David O'Toole's avatar
David O'Toole committed
14

15 16 17
This is the documented program source code for [[http://xelf.me][Xelf]], a simple and free
2D game engine written in Common Lisp.

David O'Toole's avatar
David O'Toole committed
18 19
The Lisp code and documentation below are interwoven in an [[http://orgmode.org/][Emacs
Org-mode]] file, which is exported to both xelf.html (for reading) and
20
to xelf.lisp (for compilation) in a manner similar to "literate
David O'Toole's avatar
David O'Toole committed
21 22 23 24
programming". (However, no code re-ordering or text substitutions are
performed---all Lisp blocks are simply concatenated to produce the
final output file.) The raw Org source for this page is [[https://gitlab.com/dto/xelf/raw/master/xelf.org][available
here.]]
25

David O'Toole's avatar
David O'Toole committed
26 27
The pieces of documentation surrounding the Lisp source blocks are not
intended to duplicate the content of Lisp documentation strings;
28 29 30 31
instead they provide context and explain how the definitions in a
section are used together. Cross references are provided by linking to
individual HTML pages with extracted Lisp documentation strings, and
by referring the reader to related sections of the document. 
32 33 34 35

In places where a source block's forms already include documentation
strings, a section might be left without commentary on purpose.

36 37
The [[https://gitlab.com/dto/xelf/blob/master/doc.lisp][documentation extraction code]] is included. Hierarchical
organization of the source code helps both browsing and coding via
38 39 40 41
[[http://orgmode.org/worg/org-contrib/babel/][org-babel]]. Debugger and browser references to tangled output can be
instantly redirected to the correct location in the literate Org file
(see the notes at the bottom of [[http://orgmode.org/manual/Extracting-source-code.html#Extracting-source-code][this Orgmode manual page]]. See also [[http://orgmode.org/worg/org-contrib/babel/languages/ob-doc-lisp.html][the
org-babel-lisp]] documentation.
42

David O'Toole's avatar
David O'Toole committed
43 44 45 46
#+BEGIN_QUOTE
This program and its documentation are works in progress, and many
source sections need documentation. These are marked with red TODO
tags.
47 48
#+END_QUOTE

David O'Toole's avatar
David O'Toole committed
49 50 51 52
* Class diagram 

The following diagram shows the inheritance hierarchy for most of the
classes in Xelf. It may be useful to refer back to this diagram when
David O'Toole's avatar
David O'Toole committed
53 54
reading about the classes' implementations. You may also visit the [[file:class-diagram-1.0-paths-only.svg][SVG
(Scalable Vector Graphic) version]]
David O'Toole's avatar
David O'Toole committed
55

David O'Toole's avatar
David O'Toole committed
56
file:class-diagram-1.0.png
David O'Toole's avatar
David O'Toole committed
57

David O'Toole's avatar
David O'Toole committed
58
* Lisp package
David O'Toole's avatar
David O'Toole committed
59

David O'Toole's avatar
David O'Toole committed
60 61 62 63
Here we declare the rest of this file to be in the Xelf package. The
actual package definition is stored in the accompanying file
"package.lisp". 

David O'Toole's avatar
David O'Toole committed
64
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
65
  (in-package :xelf)
David O'Toole's avatar
David O'Toole committed
66 67
#+end_src

68 69 70 71
* Xelf version information

We use a string to identify the current version of Xelf. To test
compatibilty, use the integer [[file:dictionary/_XELF-SERIES_.html][*XELF-SERIES*]].
David O'Toole's avatar
David O'Toole committed
72 73

#+begin_src lisp
74 75
(defvar *xelf-version* "4.8"
  "A string giving the version number of Xelf.")
76

77 78
(defvar *xelf-series* 4
  "An integer giving the major API version of Xelf.")
David O'Toole's avatar
David O'Toole committed
79 80
#+end_src

David O'Toole's avatar
David O'Toole committed
81 82
* Copyright notices

David O'Toole's avatar
David O'Toole committed
83 84 85 86
Your game or application should show a copyright notice for your own
work, as well as the required copyright notices for various components
such as the Common Lisp implementation used, libraries such as Xelf,
and so on. The names of accompanying license files should also be
87
given.
David O'Toole's avatar
David O'Toole committed
88

David O'Toole's avatar
David O'Toole committed
89 90
** User or application specific notices

David O'Toole's avatar
David O'Toole committed
91 92 93 94
You can use the following variables to identify yourself as author,
provide a basic contact link, and a properly formatted copyright
notice of your own.

David O'Toole's avatar
David O'Toole committed
95
#+begin_src lisp
96
(defvar *author* nil "Name of the application author.")
David O'Toole's avatar
David O'Toole committed
97

98 99
(defvar *author-contact* 
  "URL or email address of application author.")
David O'Toole's avatar
David O'Toole committed
100

101 102
(defvar *author-copyright-notice* nil
  "Text of user or application specific copyright notice.")
David O'Toole's avatar
David O'Toole committed
103
#+end_src
David O'Toole's avatar
David O'Toole committed
104

David O'Toole's avatar
David O'Toole committed
105
** Compiler-specific notices                                   :sbcl:ccl:ecl:
David O'Toole's avatar
David O'Toole committed
106

David O'Toole's avatar
David O'Toole committed
107
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
108
(defvar *ccl-copyright-notice*
David O'Toole's avatar
David O'Toole committed
109
  "This distribution of Xelf is compiled with Clozure Common Lisp.
David O'Toole's avatar
David O'Toole committed
110 111 112 113 114 115 116 117
Clozure CL is (C) 2009 by Clozure Associates. Starting with version
1.11, Clozure CL is distributed under the terms of the Apache
License, version 2.0.More information on Clozure CL, and complete
source code, may be found at the Clozure Associates website:
http://ccl.clozure.com/
")

(defvar *sbcl-copyright-notice* 
David O'Toole's avatar
David O'Toole committed
118
"This distribution of Xelf is compiled with Steel Bank Common Lisp (SBCL).
David O'Toole's avatar
David O'Toole committed
119 120 121 122 123 124 125 126 127 128
Steel Bank Common Lisp (SBCL) is free software, and comes with
absolutely no warranty. Please see the file named
./licenses/COPYING.SBCL.txt The PCL implementation is (C) 1985-1990
Xerox Corporation.Portions of LOOP are Copyright (c) 1986 by the
Massachusetts Institute of Technology. Portions of LOOP are
Copyright (c) 1989-1992 by Symbolics, Inc.More information on SBCL
and complete source code may be found at the SBCL website: http://sbcl.org
")

(defvar *ecl-copyright-notice*
David O'Toole's avatar
David O'Toole committed
129
"This distribution of Xelf is compiled with Embeddable Common-Lisp (ECL).
David O'Toole's avatar
David O'Toole committed
130 131 132 133 134 135 136 137 138 139 140 141 142
Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya
Copyright (C) 1993 Giuseppe Attardi
Copyright (C) 2000 Juan J. Garcia-Ripoll
Copyright (C) 2016 Daniel Kochmanski
ECL is free software, and you are welcome to redistribute it
under certain conditions; see file 'Copyright' for details.
https://common-lisp.net/project/ecl/
")

(defvar *compiler-copyright-notice*
  #+ecl *ecl-copyright-notice*
  #+ccl *ccl-copyright-notice*
  #+sbcl *sbcl-copyright-notice*)
David O'Toole's avatar
David O'Toole committed
143 144
#+end_src

David O'Toole's avatar
David O'Toole committed
145
** Xelf copyright notices
David O'Toole's avatar
David O'Toole committed
146

David O'Toole's avatar
David O'Toole committed
147
Xelf includes its own license (GNU Lesser General Public License,
David O'Toole's avatar
David O'Toole committed
148 149 150
version 3) in the file xelf/COPYING, and the license texts for its
dependencies in the folder "xelf/licenses" which you can ship with
your application.
David O'Toole's avatar
David O'Toole committed
151 152 153

Here is the copyright notice for Xelf and its components:

David O'Toole's avatar
David O'Toole committed
154
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
155
(defvar *xelf-copyright-notice*
David O'Toole's avatar
David O'Toole committed
156 157
"Welcome to Xelf. 
Xelf is Copyright (C) 2006-2017 by David T O'Toole <dto@xelf.me>
David O'Toole's avatar
David O'Toole committed
158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197
http://xelf.me/

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation, either version 3 of the License, or
 (at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 
See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License
along with this program, in the included file named \"COPYING\".
If not, see <http://www.gnu.org/licenses/>.

On some platforms, Xelf is distributed along with libSDL 1.2 (Simple
Direct Media Layer), which is provided under the terms of the GNU
Lesser General Public License. See the included file
xelf/licenses/README-SDL.txt for more details.

Some functions in the file xelf.lisp are based on code written by
Peter Norvig in his book 'Paradigms of Artificial Intelligence
Programming'. See logic.lisp for details.

Some of the OpenGL functions in console.lisp are derived from code in
Bart Botta's CL-OPENGL tutorials; see http://3bb.cc/tutorials/cl-opengl/

Portions of this software are copyright (C) 1996-2006 The FreeType
Project (www.freetype.org) Full license text is in the xelf/licenses
included subdirectory.

This program includes the free DejaVu fonts family in the subdirectory
./standard/. For more information, see the file named
DEJAVU-FONTS-LICENSE.txt in the xelf/licenses subdirectory.

Please see the included text files \"COPYING\" and \"CREDITS\" for
more information.

")
David O'Toole's avatar
David O'Toole committed
198 199
#+end_src

David O'Toole's avatar
David O'Toole committed
200
** Assembling a full copyright notice
201

David O'Toole's avatar
David O'Toole committed
202 203 204 205 206 207 208 209
By default, the full copyright notice constructed here is printed to
two locations via the [[file:dictionary/MESSAGE.html][MESSAGE]] function:

 - the application's STANDARD-OUTPUT stream
 - the in-engine Xelf terminal

By setting the above variables and displaying the terminal with
[[file:dictionary/SHOW-TERMINAL.html][SHOW-TERMINAL]], you can easily show your copyright notice, like a good
David O'Toole's avatar
David O'Toole committed
210 211
programmer should. You can hide the terminal again with [[file:dictionary/HIDE-TERMINAL.html][HIDE-TERMINAL]],
and clear the text if needed with the function [[file:dictionary/CLEAR-TERMINAL.html][CLEAR-TERMINAL]].
David O'Toole's avatar
David O'Toole committed
212

David O'Toole's avatar
David O'Toole committed
213 214
See also the section "System terminal" below.

215
#+begin_src lisp
216
(defvar *copyright-notice*
217
  (concatenate 'string *xelf-copyright-notice* *compiler-copyright-notice*)
218
  "Copyright notices for Xelf, its dependencies, and the current Lisp
David O'Toole's avatar
David O'Toole committed
219 220
  implementation.")

221 222 223 224
(defun full-copyright-notice ()
  (concatenate 'string
	       (or *author-copyright-notice* "")
	       *copyright-notice*))
David O'Toole's avatar
David O'Toole committed
225
#+end_src
226

David O'Toole's avatar
David O'Toole committed
227
* Trivia 
228

229 230
** Queue mechanism

David O'Toole's avatar
David O'Toole committed
231 232
We implement a simple queue-as-list system using a tail pointer.

233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270
#+begin_src lisp
(defstruct queue head tail count max)

(define-condition empty-queue (error) ())

(defun unqueue (Q)
  (when (null (queue-head Q))
    (error 'empty-queue))
  (when (eq (queue-head Q)
	    (queue-tail Q))
    ;; only one item is in the queue; kill the tail pointer
    (setf (queue-tail Q) nil))
  ;; now unqueue
  (decf (queue-count Q))
  (pop (queue-head Q)))

(defun queue (item Q)
  (let ((element (cons item nil)))
    (if (null (queue-tail Q))
	;; handle empty queue
	(progn 
	  (setf (queue-tail Q) element
		(queue-head Q) (queue-tail Q)
		(queue-count Q) 1))
	;; handle nonempty queue
	(progn 
	  (setf (cdr (queue-tail Q))
		element)
	  (pop (queue-tail Q))
	  (incf (queue-count Q)))))
  ;; now prevent exceeding any max that's been set. this is useful to
  ;; prevent allocating all memory when you don't care about throwing
  ;; away old objects.
  (when (and (numberp (queue-max Q))
	     (< (queue-max Q) (queue-count Q)))
    (unqueue Q)))
#+end_src

David O'Toole's avatar
David O'Toole committed
271 272
** Muffling various warnings                                           :sbcl:

David O'Toole's avatar
David O'Toole committed
273 274 275 276
For usage of SLIME, command prompt evaluation, and in some other
limited situations, we want to disable some warnings. Here are a few
related definitions.

David O'Toole's avatar
David O'Toole committed
277
 #+begin_src lisp
David O'Toole's avatar
David O'Toole committed
278
   #+sbcl (declaim (sb-ext:muffle-conditions style-warning))
279

David O'Toole's avatar
David O'Toole committed
280
   (defvar *suppress-warnings* nil "When non-nil, suppress spurious style warnings.")
281

David O'Toole's avatar
David O'Toole committed
282 283 284 285
   (defun quiet-warning-handler (c)
     (when *suppress-warnings*
       (let ((r (find-restart 'muffle-warning c)))
        (when r (invoke-restart r)))))
David O'Toole's avatar
David O'Toole committed
286

David O'Toole's avatar
David O'Toole committed
287 288 289 290 291
   (defmacro without-style-warnings (&body body)
     `(locally
 	(declare #+sbcl(sb-ext:muffle-conditions sb-kernel:redefinition-warning))
        (handler-bind (#+sbcl(sb-kernel:redefinition-warning #'muffle-warning))
 	,@body)))
David O'Toole's avatar
David O'Toole committed
292 293
 #+end_src

David O'Toole's avatar
David O'Toole committed
294 295
** Org-babel patch

David O'Toole's avatar
David O'Toole committed
296 297
This patch is required to work around a bug in Org Babel's source
block editing in Lisp mode.
David O'Toole's avatar
David O'Toole committed
298

David O'Toole's avatar
David O'Toole committed
299 300 301
#+begin_example
diff -u /home/dto/.emacs.d/elpa/org-20170210/org-src.el /home/dto/.emacs.d/elpa/org-20170210/org-src.el
--- /home/dto/.emacs.d/elpa/org-20170210/org-src.original.el     2017-03-30 21:19:03.843491158 -0400
David O'Toole's avatar
David O'Toole committed
302 303 304 305 306 307 308 309 310 311 312 313
+++ /home/dto/.emacs.d/elpa/org-20170210/org-src.el	2017-04-07 08:57:58.423774223 -0400
@@ -394,7 +394,7 @@
     (with-temp-buffer
       (insert (org-no-properties contents))
       (goto-char (point-min))
-      (when (functionp write-back) (funcall write-back))
+      ;;(when (functionp write-back) (funcall write-back))
       (unless (or preserve-indentation (= indentation 0))
 	(let ((ind (make-string indentation ?\s)))
 	  (goto-char (point-min))

Diff finished.  Fri Apr  7 08:59:33 2017
David O'Toole's avatar
David O'Toole committed
314
#+end_example
David O'Toole's avatar
David O'Toole committed
315

David O'Toole's avatar
David O'Toole committed
316 317
** Emacs Lisp compatibility macro                                     :emacs:

David O'Toole's avatar
David O'Toole committed
318 319
This is used for some parts of Xelf that were originally written in
Emacs Lisp, such as the pathfinding.
David O'Toole's avatar
David O'Toole committed
320

David O'Toole's avatar
David O'Toole committed
321
 #+begin_src lisp
David O'Toole's avatar
David O'Toole committed
322 323
   (defmacro while (test &body body)
     `(loop while ,test do ,@body))
David O'Toole's avatar
David O'Toole committed
324 325
 #+end_src

David O'Toole's avatar
David O'Toole committed
326
** Allow restart after Lisp error                                     :emacs:
David O'Toole's avatar
David O'Toole committed
327 328 329 330

The following definition is necessary when using SLIME with SDL to
allow restarting of the main game event loop after handling a Lisp
error.
David O'Toole's avatar
David O'Toole committed
331 332

 #+begin_src lisp
David O'Toole's avatar
David O'Toole committed
333 334 335 336
   (defmacro restartably (&body body)
     `(restart-case
 	(progn ,@body)
       (continue () :report "Continue"  )))
David O'Toole's avatar
David O'Toole committed
337 338
 #+end_src

David O'Toole's avatar
David O'Toole committed
339
** Miscellaneous variables
David O'Toole's avatar
David O'Toole committed
340

David O'Toole's avatar
David O'Toole committed
341 342
These need to be filed in their proper places.

David O'Toole's avatar
David O'Toole committed
343
 #+begin_src lisp
344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360
(defparameter *field-of-view* 45)
(defparameter *compose-buffers-destructively* t)
(defvar *blocks* nil)
(defparameter *unit* 20)
(defun units (n) (* n *unit*))
(defvar *debug-on-error* nil)
(defvar *quitting* nil)
(defvar *self* nil)
(defparameter *user-keyboard-layout* :qwerty)
(defparameter *use-sound* t "Non-nil (the default) is to use sound. Nil disables sound.")
(defvar *interactive-p* nil)
(defvar *notification* nil)
(defvar *use-notifications* nil)
(defmacro with-notifications (&body body)
  `(let ((*use-notifications* t)) ,@body))
(defvar *menubar* nil)
(defun menubar () *menubar*)
David O'Toole's avatar
David O'Toole committed
361 362
 #+end_src

363 364
* User initialization file

David O'Toole's avatar
David O'Toole committed
365 366 367 368 369 370
After initializing itself, Xelf looks for a Lisp file called
"$HOME/xelf-init.lisp" where $HOME is your user's home directory, and
tries to load it. This is the place to set preferences for the map
editor, or add your own functions in the manner of Emacs.

Your init file should begin with the form "(in-package :xelf)".
371

David O'Toole's avatar
David O'Toole committed
372 373 374 375
You can set screen and window parameters here, since this is executed
just before the application window is opened.

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
376
  (defparameter *user-init-file-name* "xelf-init.lisp"
David O'Toole's avatar
David O'Toole committed
377 378 379 380 381 382 383 384 385
    "Filename for the user initialization script.")

  (defun load-user-init-file ()
    (let ((type :unspecific)) ;; possible sbcl non-compliant behavior
      (let ((file (merge-pathnames (make-pathname :name *user-init-file-name*
						  :type type)
				   (user-homedir-pathname))))
	(when (cl-fad:file-exists-p file)
	  (load (cl-fad:pathname-as-file file))))))
386 387
#+end_src

David O'Toole's avatar
David O'Toole committed
388 389 390 391 392 393 394 395 396
* Memoization facility

These functions are used to cache many kinds of data in Xelf: font and
string metrics, GL color values, TrueType font bitmaps, various tables
of strings and symbols, and so on.

These are originally written by Peter Norvig, see copyright
information below. I added the VALIDATOR feature because it made it
possible to trap stale data from OpenGL, and other uses.
David O'Toole's avatar
David O'Toole committed
397 398

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
399
  ;; Contributed material:
David O'Toole's avatar
David O'Toole committed
400

David O'Toole's avatar
David O'Toole committed
401 402 403 404
  ;; The "memoization" functions below are originally written by Peter
  ;; Norvig for his book "Paradigms of Artificial Intelligence
  ;; Programming". The modified versions are redistributed here under
  ;; the terms of the General Public License as given above.
David O'Toole's avatar
David O'Toole committed
405

David O'Toole's avatar
David O'Toole committed
406
  ;; You can find more information on Norvig's book at his website:
David O'Toole's avatar
David O'Toole committed
407

David O'Toole's avatar
David O'Toole committed
408
  ;; http://www.norvig.com/paip.html
David O'Toole's avatar
David O'Toole committed
409

David O'Toole's avatar
David O'Toole committed
410 411
  ;; The full license for the PAIP code, which governs the terms of
  ;; said redistribution under the GPL, can be found at norvig.com:
David O'Toole's avatar
David O'Toole committed
412

David O'Toole's avatar
David O'Toole committed
413
  ;; http://www.norvig.com/license.html
David O'Toole's avatar
David O'Toole committed
414 415 416
#+end_src

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
417 418 419 420 421 422
  (defmacro defun-memo (name args memo-args &body body)
    "Define a memoized function named NAME.
  ARGS is the lambda list giving the memoized function's arguments.
  MEMO-ARGS is a list with optional keyword arguments for the
  memoization process: :KEY, :VALIDATOR, and :TEST."
    `(memoize (defun ,name ,args . ,body) ,@memo-args))
David O'Toole's avatar
David O'Toole committed
423

David O'Toole's avatar
David O'Toole committed
424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440
  (defun memo (fn &key (key #'first) (test #'eql) validator name)
    "Return a memo-function of fn."
  ;;  (declare (optimize (speed 3) (safety 2)))
    (let ((table (make-hash-table :test test)))
      (setf (get name 'memo) table)
      #'(lambda (&rest args)
          (let ((k (funcall key args)))
            (multiple-value-bind (val found-p)
		(gethash k table)
              (if found-p 
		  val
		  ;; only cache if value is valid
		  (let ((candidate-value (apply fn args)))
		    (prog1 candidate-value
		      (when (or (null validator)
				(funcall validator candidate-value))
			(setf (gethash k table) candidate-value))))))))))
David O'Toole's avatar
David O'Toole committed
441

David O'Toole's avatar
David O'Toole committed
442 443 444 445 446 447
  (defun memoize (fn-name &key (key #'first) (test #'eql) validator)
    "Replace fn-name's global definition with a memoized version."
    (clear-memoize fn-name)
    (setf (symbol-function fn-name)
          (memo (symbol-function fn-name)
		:name fn-name :key key :test test :validator validator)))
David O'Toole's avatar
David O'Toole committed
448

David O'Toole's avatar
David O'Toole committed
449 450 451 452
  (defun clear-memoize (fn-name)
    "Clear the hash table from a memo function."
    (let ((table (get fn-name 'memo)))
      (when table (clrhash table))))
David O'Toole's avatar
David O'Toole committed
453

David O'Toole's avatar
David O'Toole committed
454 455
  (defun get-memo-table (fn-name)
    (get fn-name 'memo))
David O'Toole's avatar
David O'Toole committed
456 457
#+end_src

David O'Toole's avatar
David O'Toole committed
458 459 460 461 462
#+begin_src lisp
(defmacro callf (function place &rest arguments)
  `(setf ,place (apply #',function ,place (list ,@arguments))))
#+end_src

463
* String and symbol utility functions
David O'Toole's avatar
David O'Toole committed
464

465 466
For GUI purposes it is useful to tidy strings by pretty-printing them,
shortening long strings, and filtering out non-printable characters.
David O'Toole's avatar
David O'Toole committed
467 468

** Splitting multi-line strings
469

David O'Toole's avatar
David O'Toole committed
470
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
471 472 473 474
  (defun split-string-on-lines (string)
    (with-input-from-string (stream string)
      (loop for line = (read-line stream nil)
	    while line collect line)))
David O'Toole's avatar
David O'Toole committed
475
#+end_src
David O'Toole's avatar
David O'Toole committed
476

David O'Toole's avatar
David O'Toole committed
477 478 479
** Formatting nicer symbols

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
480 481 482 483 484 485 486 487 488 489
  (defun-memo pretty-string (thing)
      (:key #'first :test 'equal :validator #'identity)
    (let ((name (etypecase thing
		  (symbol (symbol-name thing))
		  (string thing))))
      (coerce 
       (substitute #\Space #\- 
		   (string-downcase 
		    (string-trim " " name)))
       'simple-string)))
David O'Toole's avatar
David O'Toole committed
490

David O'Toole's avatar
David O'Toole committed
491 492 493 494 495 496
  (defun-memo ugly-symbol (string)
      (:key #'first :test 'equal :validator #'identity)
    (intern 
     (string-upcase
      (substitute #\- #\Space 
		  (string-trim " " string)))))
David O'Toole's avatar
David O'Toole committed
497

David O'Toole's avatar
David O'Toole committed
498 499 500 501 502
  (defun-memo make-keyword (S) (:test 'eq) 
    "Make the symbol or string S into a keyword symbol."
    (etypecase S
      (string (intern (string-upcase S) :keyword))
      (symbol (intern (symbol-name S) :keyword))))
David O'Toole's avatar
David O'Toole committed
503

David O'Toole's avatar
David O'Toole committed
504 505 506 507 508
  (defun make-non-keyword (S)
    "Make the symbol or string S into a non-keyword symbol."
    (etypecase S
      (symbol (intern (symbol-name S)))
      (string (intern (string-upcase S)))))
David O'Toole's avatar
David O'Toole committed
509 510
#+end_src

David O'Toole's avatar
David O'Toole committed
511 512
** Removing non-printing characters

513
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
514 515 516 517
  (defun control-character-p (character)
    (let ((code (char-code character)))
      (or (< code 32) 
	  (= code 127))))
518

David O'Toole's avatar
David O'Toole committed
519 520
  (defun remove-control-characters (string)
    (remove-if #'control-character-p (coerce string 'vector)))
521

David O'Toole's avatar
David O'Toole committed
522 523
  (defun truncate-string (string)
    (subseq string 0 (min 118 (length string))))
524

David O'Toole's avatar
David O'Toole committed
525 526
  (defun clean-string (string)
    (truncate-string (remove-control-characters string)))
David O'Toole's avatar
David O'Toole committed
527 528 529
#+end_src

** Filtering out long or empty strings
530

David O'Toole's avatar
David O'Toole committed
531
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
532 533
  (defun short-string (string)
    (subseq string 0 (min 12 (length string))))
534

David O'Toole's avatar
David O'Toole committed
535 536 537 538
  (defun nice-string (string)
    (if (zerop (length string))
	" "
	string))
539 540
#+end_src

David O'Toole's avatar
David O'Toole committed
541 542
* Math and geometry functions

David O'Toole's avatar
David O'Toole committed
543 544 545
** Randomly choosing an item from a list

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
546 547 548
  (defun random-choose (set)
    "Randomly choose one element of the list SET and return it."
    (nth (random (length set)) set))
David O'Toole's avatar
David O'Toole committed
549 550
#+end_src

David O'Toole's avatar
David O'Toole committed
551
** Randomly scramble a list
552 553

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
554
  (defun derange (things)
555 556
    "Randomly scramble the order of the elements in the list THINGS.
Returns a newly allocated list."
David O'Toole's avatar
David O'Toole committed
557 558 559 560 561 562
    (let ((len (length things))
	  (things2 (coerce things 'vector)))
      (dotimes (n len)
	(rotatef (aref things2 n)
		 (aref things2 (random len))))
      (coerce things2 'list)))
563 564
#+end_src

David O'Toole's avatar
David O'Toole committed
565
** Running code a percentage of the time
David O'Toole's avatar
David O'Toole committed
566 567

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
568 569 570 571
  (defmacro percent-of-time (percent &body body)
    "Evaluate the BODY forms PERCENT percent of the time."
    `(when (< (random 100.0) ,percent)
       ,@body))
David O'Toole's avatar
David O'Toole committed
572 573 574 575 576
#+end_src

** Rolling dice

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
577 578 579 580 581 582 583
  (defun roll (rolls &optional (sides 6) (adds 0))
    "Total ROLLS rolls of a SIDES-sided die, then add ADDS.
  So 2d6+2 would be (roll 2 6 2)."
    (let ((total 0))
      (+ adds
	 (dotimes (r rolls total)
	   (incf total (+ 1 (random sides)))))))
David O'Toole's avatar
David O'Toole committed
584

David O'Toole's avatar
David O'Toole committed
585 586
  (defun roll-under (n sides)
    (< n (random sides)))
David O'Toole's avatar
David O'Toole committed
587 588
#+end_src

David O'Toole's avatar
David O'Toole committed
589
** Geometry 
David O'Toole's avatar
David O'Toole committed
590

David O'Toole's avatar
David O'Toole committed
591 592
*** Converting degrees to radians

David O'Toole's avatar
David O'Toole committed
593
In Xelf, angle values (i.e. "headings") are always given in radians.
David O'Toole's avatar
David O'Toole committed
594 595 596
If you need radians from degrees, use RADIAN-ANGLE:

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
597 598 599
  (defun radian-angle (degrees)
    "Convert DEGREES to radians."
    (* degrees (cfloat (/ pi 180))))
David O'Toole's avatar
David O'Toole committed
600 601
#+end_src

David O'Toole's avatar
David O'Toole committed
602 603
*** Converting radians to degrees

David O'Toole's avatar
David O'Toole committed
604 605 606
If you have a radian heading and want degrees, use HEADING-DEGREES:

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
607 608 609
  (defun heading-degrees (radians)
    "Convert RADIANS to degrees."
    (* radians (cfloat (/ 180 pi))))
David O'Toole's avatar
David O'Toole committed
610 611
#+end_src

David O'Toole's avatar
David O'Toole committed
612
*** Euclidean distance function
David O'Toole's avatar
David O'Toole committed
613

David O'Toole's avatar
David O'Toole committed
614 615 616 617 618 619
#+begin_src lisp
  (defun distance (x1 y1 x2 y2)
   "Compute the distance between the points X1,Y1 and X2,Y2."
    (let ((delta-x (- x2 x1))
	  (delta-y (- y2 y1)))
      (sqrt (+ (* delta-x delta-x) (* delta-y delta-y)))))
David O'Toole's avatar
David O'Toole committed
620 621
#+end_src

David O'Toole's avatar
David O'Toole committed
622
*** Test point against rectangle
David O'Toole's avatar
David O'Toole committed
623 624

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
625 626 627 628 629
  (defun within-extents (x y x0 y0 x1 y1)
     (and (>= x x0) 
	  (<= x x1)
	  (>= y y0)
	  (<= y y1)))
David O'Toole's avatar
David O'Toole committed
630 631 632
#+end_src

*** Find angle between two points
David O'Toole's avatar
David O'Toole committed
633

David O'Toole's avatar
David O'Toole committed
634
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
635 636 637 638 639
  (defun find-heading (x0 y0 x1 y1)
    "Return the angle in radians of the ray from the point X0,Y0 to the
  point X1,Y1."
    (atan (- y1 y0) 
	  (- x1 x0)))
David O'Toole's avatar
David O'Toole committed
640 641 642
#+end_src

*** Reversing a heading
David O'Toole's avatar
David O'Toole committed
643

David O'Toole's avatar
David O'Toole committed
644
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
645 646 647 648
  (defun opposite-heading (heading)
    "Return the heading angle opposite to HEADING."
    (mod (+ pi heading)
	 (* 2 pi)))
David O'Toole's avatar
David O'Toole committed
649 650 651 652 653 654 655 656
#+end_src

** Bounding box data

Below you can see that bounding boxes are always given in the order
TOP, LEFT, RIGHT, BOTTOM, whether provided in a list or as multiple
return values. 

David O'Toole's avatar
David O'Toole committed
657
 #+begin_src lisp
David O'Toole's avatar
David O'Toole committed
658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679
   ;; used for optimization
   (defun cfloat (f) (coerce f 'single-float))

   (defun valid-bounding-box-p (box)
     "Return non-nil if BOX is a spatially valid bounding box.
   Bounding boxes are lists of the form (TOP LEFT RIGHT BOTTOM)."
     (and (listp box)
 	(= 4 (length box))
 	(destructuring-bind (top left right bottom) box
  	  (and (<= left right) (<= top bottom)))))

   (defun bounding-box-contains (box0 box1)
     "Test whether BOX0 contains BOX1. The bounding boxes are provided as
   lists of the form (TOP LEFT RIGHT BOTTOM)."
     (destructuring-bind (top0 left0 right0 bottom0) box0
       (destructuring-bind (top1 left1 right1 bottom1) box1
        (declare (single-float top0 left0 right0 bottom0 top1 left1 right1 bottom1) 
  		(optimize (speed 3)))
        (and (<= top0 top1)
  	    (<= left0 left1)
  	    (>= right0 right1)
  	    (>= bottom0 bottom1)))))
David O'Toole's avatar
David O'Toole committed
680
#+end_src
David O'Toole's avatar
David O'Toole committed
681

David O'Toole's avatar
David O'Toole committed
682 683 684
** Cardinal directions

These are useful for grid-based games.
David O'Toole's avatar
David O'Toole committed
685

David O'Toole's avatar
David O'Toole committed
686
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
687
  (defvar
David O'Toole's avatar
David O'Toole committed
688
  *directions* (list :right :upright :up :upleft :left :downleft :down :downright)
David O'Toole's avatar
David O'Toole committed
689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735
    "List of keywords representing the eight compass directions.")

  (defvar *opposites* (list :up :down
			    :down :up
			    :right :left
			    :left :right
			    :upright :downleft
			    :downleft :upright
			    :downright :upleft
			    :upleft :downright
			    :here :here)
    "Property list mapping direction keywords to their 180-degree
  opposites.")

  (defparameter *left-turn* 
    '(:up :upleft
      :upleft :left
      :left :downleft
      :downleft :down
      :down :downright
      :downright :right
      :right :upright
      :upright :up))

  (defparameter *right-turn*
    '(:up :upright
      :upright :right
      :right :downright
      :downright :down
      :down :downleft
      :downleft :left
      :left :upleft
      :upleft :up))

  (defun left-turn (direction)
    (getf *left-turn* direction))

  (defun right-turn (direction)
    (getf *right-turn* direction))

  (defun opposite-direction (direction)
    "Return the direction keyword that is the opposite direction from
  DIRECTION."
    (getf *opposites* direction))

  (defun random-direction ()
    (nth (random (length *directions*))
David O'Toole's avatar
David O'Toole committed
736
	 *directions*))
David O'Toole's avatar
David O'Toole committed
737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798

  (defun direction-degrees (direction)
    "Return the angle (in degrees) which DIRECTION points."
    (ecase direction
      (:up -90)
      (:down 90)
      (:right 0)
      (:left -180)
      (:upright -45)
      (:upleft -135) 
      (:downright 45)
      (:downleft 135)
      (:here 0)))
#+end_src

#+begin_src lisp
  (defun direction-heading (direction)
    "Return the angle (in radians) of the keyword DIRECTION."
    (radian-angle (direction-degrees direction)))

  (defun heading-direction (heading)
    (flet ((pointing (direction)
  	     (when (<= (abs (- heading
  			      (direction-heading direction)))
		       (/ pi 7))
  	       direction)))
      (some #'pointing *directions*)))

  (defun step-in-direction (x y direction &optional (n 1))
    "Return the point X Y moved by n squares in DIRECTION."
    (ecase direction
      (:here (values x y))
      (:up (values x (- y n)))
      (:down (values x (+ y n)))
      (:right  (values (+ x n) y))
      (:left  (values (- x n) y))
      (:upright (values (+ x n) (- y n)))
      (:upleft (values (- x n) (- y n)))
      (:downright (values (+ x n) (+ y n)))
      (:downleft (values (- x n) (+ y n)))))

  (defun find-direction (x1 y1 x2 y2)
    "Return the heading (in radians) of the ray from Y1,X1 to Y2,X2."
    (if (or (some #'null (list y1 x1 y2 x2))
	    (and (= y1 y2) (= x1 x2)))
	:here
	(if (< y1 y2) ; definitely to the down
	    (if (< x1 x2)
		:downright
		(if (> x1 x2)
		    :downleft
		    :down))
	    (if (> y1 y2) ;; definitely to the up
		(if (< x1 x2)
		    :upright
		    (if (> x1 x2)
			:upleft
			:up))
		;; rows are equal; it's either right or left
		(if (< x1 x2)
		    :right
		    :left)))))
David O'Toole's avatar
David O'Toole committed
799
 #+end_src
David O'Toole's avatar
David O'Toole committed
800

801
** Grid-based line-of-sight lighting
David O'Toole's avatar
David O'Toole committed
802 803

 #+begin_src lisp
David O'Toole's avatar
David O'Toole committed
804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858
   (defun trace-rectangle (trace-function row column height width
   &optional fill)
     "Call TRACE-FUNCTION for each point on the rectangle of HEIGHT and
   WIDTH with top left corner at ROW COLUMN. When FILL is non-nil, fill
   the rectangle."
     (block tracing
       (dotimes (r height)
        ;; Are we painting a full horizontal? (always the case when filling)
        (if (or fill (equal r 0) (equal r (- height 1)))
 	(dotimes (c width)
     	  (if (funcall trace-function (+ r row) (+ c column))
     	      (return-from tracing)))
 	;; no, it's a row with only verticals. just paint the left and right.
 	(if (or (funcall trace-function (+ r row) column)
     		(funcall trace-function (+ r row) (+ width column -1)))
     	    (return-from tracing))))))

   (defun trace-octagon (trace-function center-row center-column radius
   &optional thicken )
     "Call TRACE-FUNCTION for each point on the octagon of radius RADIUS
   centered at row ROW, column COLUMN. When THICKEN is non-nil, thicken
   the diagonals of the rectangle in order to facilitate raycasting.
   It's an ugly hack, but it helps reduce artifacts."
     ;; calculate
     (let* ((origin-row (- center-row radius))
        (origin-column (- center-column radius))
        (side-length radius)
        (angle-length (floor (/ (float radius) 2.0)))
        (starting-x (+ 1 angle-length)))
       ;; draw top line
       (dotimes (i side-length)
        (funcall trace-function
     	     origin-row
     	     (+ origin-column starting-x i)))
       ;; draw top angles
       (dotimes (i angle-length)
        ;; left side
        (funcall trace-function
     	     (+ 1 origin-row i)
     	     (- center-column angle-length i 1))
        ;; right side
        (funcall trace-function
     	     (+ 1 origin-row i)
     	     (+ center-column angle-length i 1))
        ;;
        (when thicken
        ;; left side
        (funcall trace-function
     	       (+ 1 origin-row i)
     	       (- center-column angle-length i))
        ;; right side
        (funcall trace-function
     	       (+ 1 origin-row i)
     	       (+ center-column angle-length i))))
       ;; fill in diagonal points that are along the sides
David O'Toole's avatar
David O'Toole committed
859
       (when thicken
David O'Toole's avatar
David O'Toole committed
860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878
        ;; left side
        (funcall trace-function
     	     (+ 1 origin-row angle-length)
     	     (+ origin-column 1))
        ;; right side
        (funcall trace-function
     	     (+ 1 origin-row angle-length)
     	     (+ center-column side-length -1)))
       ;; draw side lines
       (dotimes (i side-length)
        ;; leftside
        (funcall trace-function
     	     (+ 1 origin-row angle-length i)
     	     origin-column)
        ;; right side
        (funcall trace-function
     	     (+ 1 origin-row angle-length i)
     	     (+ origin-column (* 2 side-length))))
       ;; fill in diagonal points that are along the sides
David O'Toole's avatar
David O'Toole committed
879
       (when thicken
David O'Toole's avatar
David O'Toole committed
880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911
 	;; left side
 	(funcall trace-function
     		 (+ origin-row side-length angle-length)
     		 (+ origin-column 1))
 	;; right side
 	(funcall trace-function
     		 (+ origin-row side-length angle-length)
     		 (+ center-column side-length -1)))
       ;; draw bottom angles
       (dotimes (i angle-length)
        ;; left side
        (funcall trace-function
     	     (+ 1 origin-row angle-length side-length i)
     	     (- center-column angle-length (- angle-length i)))
        ;; right side
        (funcall trace-function
     	     (+ 1 origin-row angle-length side-length i)
     	     (+ center-column angle-length (- angle-length i)))
        (when thicken
        ;; left side
        (funcall trace-function
     	       (+ 1 origin-row angle-length side-length i)
     	       (+ 1 (- center-column angle-length (- angle-length i))))
        ;; right side
        (funcall trace-function
     	       (+ 1 origin-row angle-length side-length i)
     	       (+ center-column angle-length (- angle-length i 1)))))
       ;; draw bottom line
       (dotimes (i side-length)
        (funcall trace-function
     	     (+ 1 origin-row side-length (* 2 angle-length))
     	     (+ origin-column starting-x i)))))
David O'Toole's avatar
David O'Toole committed
912 913 914 915
 #+end_src

** Bresenham's line algorithm

David O'Toole's avatar
David O'Toole committed
916 917 918 919
We use [[http://en.wikipedia.org/wiki/Bresenham's\_line\_algorithm][Bresenham's line algorithm]] 
to trace out the player's field of
vision and determine which squares are lit. This can also be used to
trace the enemy's line of sight in a roguelike.
David O'Toole's avatar
David O'Toole committed
920 921

 #+begin_src lisp
David O'Toole's avatar
David O'Toole committed
922 923 924 925 926 927
   (defun trace-column (trace-function column y0 y1)
     (let* ((diff (- y1 y0))
  	  (fact (if (minusp diff) 1 -1)))
       (dotimes (n (abs diff))
        (funcall trace-function (+ y1 (* n fact)) column))))
     ;; (dotimes (n (abs (- y1 y0)))
David O'Toole's avatar
David O'Toole committed
928
     ;;   (funcall trace-function x (+ y0 n)))
David O'Toole's avatar
David O'Toole committed
929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002

   (defun trace-row (trace-function row x0 x1)
     (let* ((diff (- x1 x0))
  	  (fact (if (minusp diff) 1 -1)))
       (dotimes (n (abs diff))
        (funcall trace-function row (+ x1 (* n fact))))))

   (defun trace-line (trace-function x0 y0 x1 y1)
     "Trace a line between X0,Y0 and X1,Y1.
   calling TRACE-FUNCTION at each point of the line."
     ;; analyze coordinates and prepare them for bresenham's
     (let ((steep (> (abs (- y1 y0))
  		   (abs (- x1 x0)))))
       ;; reflect steep lines through line y=x
       (when steep
        (rotatef x0 y0)
        (rotatef x1 y1))
       ;; swap points if line is backwards
       (let ((flipped (> x0 x1)))
        (when flipped
 	 (rotatef x0 x1)
 	 (rotatef y0 y1))
        (values flipped 
 	 (if (= x1 x0)
  	     ;; just trace a vertical line.
  	     (if flipped
  		 (trace-column trace-function x1 y0 y1)
  		 (trace-column trace-function x1 y1 y0))
  	     ;; ok, use bresenham's
  	     (let* ((delta-x (- x1 x0))
  		    (delta-y (abs (- y1 y0)))
  		    (err 0.0)
  		    (delta-err (/ (float delta-y) (float delta-x)))
  		    (y y0)
  		    (x x0)
  		    (step-y (if (< y0 y1) 1 -1)))
  	       ;; main loop
  	       (labels ((update-xy ()
  			  (incf err delta-err)
  			  (when (>= err 0.5)
  			    (incf y step-y)
  			    (decf err 1.0))
  			  (incf x)))
  		 (block tracing
  		   (update-xy)
  		   (loop while (= x x1) do
  		     ;; call the supplied trace function.
  		     ;; note that trace functions get args in order (row column).
  		     ;; terminate with result = nil if it returns non-nil.
  		     (when (if steep
  			       (funcall trace-function x y)
  			       (funcall trace-function y x))
  		       (return-from tracing t))
  		     (update-xy))))))))))

   (defmacro with-trace-line ((row-sym col-sym) x0 y0 x1 y1 &rest body)
     (let ((tracer-sym (gensym)))
       `(labels ((,tracer-sym ,(list row-sym col-sym)
  		 ,@body))
 	(trace-line #',tracer-sym ,x0 ,y0 ,x1 ,y1))))

   (defmacro with-trace-rectangle ((row-sym col-sym)
  				 row column height width &rest body)
     (let ((tracer-sym (gensym)))
       `(labels ((,tracer-sym ,(list row-sym col-sym)
  		 ,@body))
 	(trace-rectangle #',tracer-sym ,row ,column ,height ,width))))

   (defmacro with-trace-octagon ((row-sym col-sym) center-row center-column 
  			       radius thicken-p &rest body)
     (let ((tracer-sym (gensym)))
       `(labels ((,tracer-sym ,(list row-sym col-sym)
  		 ,@body))
 	(trace-octagon #',tracer-sym ,center-row ,center-column ,radius ,thicken-p))))
David O'Toole's avatar
David O'Toole committed
1003 1004
 #+end_src

David O'Toole's avatar
David O'Toole committed
1005
* Midpoint-displacement noise
David O'Toole's avatar
David O'Toole committed
1006

David O'Toole's avatar
David O'Toole committed
1007 1008 1009 1010
The following routines create random midpoint displacement noise on a
grid, also called "plasma". This is useful for creating somewhat
natural-looking terrain; the noise can be processed in many ways to
simulate other phenomena. See also wikipedia's page on [[http://en.wikipedia.org/wiki/Diamond-square_algorithm][the
David O'Toole's avatar
David O'Toole committed
1011
Diamond-square algorithm]].
David O'Toole's avatar
David O'Toole committed
1012

David O'Toole's avatar
David O'Toole committed
1013
First comes the [[http://en.wikipedia.org/wiki/Midpoint][midpoint formula]].
David O'Toole's avatar
David O'Toole committed
1014 1015

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1016 1017 1018
  (defun midpoint (A B)
    (list (truncate (/ (+ (first A) (first B)) 2))
	  (truncate (/ (+ (second A) (second B)) 2))))
David O'Toole's avatar
David O'Toole committed
1019 1020 1021 1022 1023 1024 1025 1026
#+end_src

** Defining rectangles

We need a representation for a rectangle that is appropriate to our
problem. Then we must allow recursive subdivision of rectangles.

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060
  (defstruct plasma-rect A B C D)

  (defun subdivide-rect (R)
    "Subdivide rectangle R into four rectangles joined at the center
  point of the original R, and return the list of four rectangles, or
  NIL if they would be smaller than one pixel."
    (let* ((A (plasma-rect-A R))
	   (B (plasma-rect-B R))
	   (C (plasma-rect-C R))
	   (D (plasma-rect-D R)))
      ;; are they too small?
      (if (> 2 (abs (- (first C) (first A))))
	  nil
	  (let
	      ((R1 (make-plasma-rect :A A
				     :B (midpoint A B)
				     :C (midpoint A C)
				     :D (midpoint A D)))
	       ;;
	       (R2 (make-plasma-rect :A (midpoint A B)
				     :B B
				     :C (midpoint B C)
				     :D (midpoint B D)))
	       ;;
	       (R3 (make-plasma-rect :A (midpoint A C)
				     :B (midpoint B C)
				     :C C
				     :D (midpoint C D)))
	       ;;
	       (R4 (make-plasma-rect :A (midpoint A D)
				     :B (midpoint B D)
				     :C (midpoint C D)
				     :D D)))
	    (list R1 R2 R3 R4)))))
David O'Toole's avatar
David O'Toole committed
1061 1062
#+end_src

David O'Toole's avatar
David O'Toole committed
1063
** Rendering the noise 
David O'Toole's avatar
David O'Toole committed
1064 1065

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1066
  (defun render-noise (width height &key (graininess 1.0) array)
David O'Toole's avatar
David O'Toole committed
1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111
    "Return a rectangle subdivision noise field with WIDTH,HEIGHT."
    (let* ((grid (or array (make-array (list height width))))
	   (A (list 0 0))
	   (B (list 0 (- height 1)))
	   (C (list (- width 1) 0))
	   (D (list (- width 1) (- height 1)))
	   (Rs (list (make-plasma-rect :A A :B B :C C :D D)))
	   (Ss nil)
	   (S nil)
	   (R nil)
	   (rect-width nil))
      ;; assign random values to corners of grid to prime the algorithm
      (dolist (P (list A B C D))
	(setf (aref grid (second P) (first P)) (random graininess)))
      ;; begin processing rectangles and painting plasma
      (loop while (setf R (pop Rs))
	 do
	 ;; subdivide rectangle R and push results onto the rectangle list Rs
	   (setf Ss (subdivide-rect R))
	   (if Ss
	       (loop while (setf S (pop Ss)) do
		    (push S Rs)))
	 ;; calculate values for midpoints and center of current rectangle R
	   (setf A (plasma-rect-A R))
	   (setf B (plasma-rect-B R))
	   (setf C (plasma-rect-C R))
	   (setf D (plasma-rect-D R))
	   (setf rect-width (abs (- -1 (first C) (first A))))
	 ;; do for all edge midpoints and center:
	   (dolist (pair (list (list A B) (list A C)
			       (list B D) (list C D) (list A D)))
	     (let* ((P1 (first pair)) 
		    (P2 (second pair)) 
		    (M (midpoint P1 P2))
		    (V (+
			;; average value of values at P1 and P2
			(* 0.5
			   (+ (aref grid (second P1) (first P1))
			      (aref grid (second P2) (first P2))
			      ;; random part smaller as rects get smaller
			      (* graininess (- 0.5 (random 1.0))
				 (sqrt (float rect-width))))))))
	       ;; paint the point
	       (setf (aref grid (second M) (first M)) V))))
      grid))
David O'Toole's avatar
David O'Toole committed
1112 1113
#+end_src

David O'Toole's avatar
David O'Toole committed
1114
* Hooks 
David O'Toole's avatar
David O'Toole committed
1115

David O'Toole's avatar
David O'Toole committed
1116 1117
This is a simple Emacs-like hook facility. A hook is a variable whose
value is a list of no-argument functions to call at a certain time. 
1118

David O'Toole's avatar
David O'Toole committed
1119
See also [[file:dictionary/AT-NEXT-UPDATE.html][AT-NEXT-UPDATE]].
David O'Toole's avatar
David O'Toole committed
1120

David O'Toole's avatar
David O'Toole committed
1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158
#+begin_src lisp
  (defvar *after-startup-hook* nil "Hook run after startup.")
  (defvar *next-update-hook* nil 
  "Hook run after each update. Value is erased each time.")

  (defun add-hook (hook func)
    "Hooks are special variables whose names are of the form
  `*foo-hook*' and whose values are lists of functions taking no
  arguments. The functions of a given hook are all invoked (in list
  order) whenever the hook is run with `run-hook'.

  This function arranges for FUNC to be invoked whenever HOOK is triggered with
  `run-hook'. The function should have no arguments."
    (pushnew func (symbol-value hook)))

  (defun remove-hook (hook func)
    "Stop calling FUNC whenever HOOK is triggered."
    (setf (symbol-value hook)
	  (delete func (symbol-value hook))))

  (defun run-hook (hook)
    "Call all the functions in HOOK, in list order."
    (dolist (func (symbol-value hook))
      (funcall func)))

  (defmacro at-next-update (&body body)
    "Run the forms in BODY at the next game loop update."
    `(prog1 nil 
       (add-hook '*next-update-hook*
		 #'(lambda () ,@body))))

  (defun add-to-list (list element)
    "Add the item ELEMENT to the list LIST."
    (assert (and (symbolp list)
		 (not (null list))))
    (setf (symbol-value list)
	  (append (symbol-value list)
		  (list element))))
David O'Toole's avatar
David O'Toole committed
1159 1160
#+end_src

David O'Toole's avatar
David O'Toole committed
1161
* Object database 
David O'Toole's avatar
David O'Toole committed
1162

David O'Toole's avatar
David O'Toole committed
1163 1164 1165
Each object is given a UUID (universally unique identifier.) These
are used as keys into the database, a hash table.

David O'Toole's avatar
David O'Toole committed
1166 1167 1168 1169 1170 1171
** Database variable

#+begin_src lisp
  (defvar *database* nil)
#+end_src

David O'Toole's avatar
David O'Toole committed
1172 1173 1174
** Generating UUIDs

We use the UUID library from Quicklisp.
David O'Toole's avatar
David O'Toole committed
1175

David O'Toole's avatar
David O'Toole committed
1176 1177 1178 1179
#+begin_src lisp
  (defun make-uuid ()
    (with-output-to-string (s)
      (uuid:print-bytes s (uuid:make-v4-uuid))))
David O'Toole's avatar
David O'Toole committed
1180 1181
#+end_src

David O'Toole's avatar
David O'Toole committed
1182
** Creating the database
David O'Toole's avatar
David O'Toole committed
1183 1184

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1185 1186 1187
  (defun initialize-database ()
    (setf *database* 
	  (make-hash-table :test 'equal :size 8192)))
David O'Toole's avatar
David O'Toole committed
1188 1189
#+end_src

David O'Toole's avatar
David O'Toole committed
1190
** Adding and removing objects
David O'Toole's avatar
David O'Toole committed
1191

David O'Toole's avatar
David O'Toole committed
1192
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1193 1194 1195 1196 1197
  (defun add-object-to-database (object)
    (when (null *database*)
      (initialize-database))
    (setf (gethash 
	   (the simple-string (uuid object))
David O'Toole's avatar
David O'Toole committed
1198
	   *database*)
David O'Toole's avatar
David O'Toole committed
1199 1200 1201 1202 1203 1204 1205 1206
	  object))

  (defun remove-object-from-database (object)
    (let ((total (hash-table-count *database*)))
      (assert (hash-table-p *database*))
      (assert (plusp total))
      (remhash 
       (the simple-string (uuid object))
David O'Toole's avatar
David O'Toole committed
1207
       *database*)))
David O'Toole's avatar
David O'Toole committed
1208
#+end_src
David O'Toole's avatar
David O'Toole committed
1209

David O'Toole's avatar
David O'Toole committed
1210
** Searching for objects by UUID
David O'Toole's avatar
David O'Toole committed
1211 1212

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1213 1214 1215 1216
  (defun find-object-by-uuid (uuid &optional noerror)
    (or (gethash (the simple-string uuid) *database*)
	(unless noerror
	  (error "Cannot find object for uuid ~S" uuid))))
David O'Toole's avatar
David O'Toole committed
1217 1218
#+end_src

David O'Toole's avatar
David O'Toole committed
1219 1220 1221 1222 1223 1224
#+begin_src lisp
(defun find-uuid (object)
  (when object
    (uuid (find-object object))))
#+end_src

David O'Toole's avatar
David O'Toole committed
1225
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1226
  (defun find-object (thing &optional no-error)
David O'Toole's avatar
David O'Toole committed
1227 1228 1229 1230 1231 1232 1233 1234 1235
    (when (not (null thing))
      (let ((result 
	      (etypecase thing
		(string (find-object-by-uuid thing :noerror))
		(quadrille thing))))
	(prog1 result
	  (unless no-error
	    (when (null result)
	      (error "Cannot find object: ~S" thing)))))))
David O'Toole's avatar
David O'Toole committed
1236 1237 1238
#+end_src

** Object identity tests
David O'Toole's avatar
David O'Toole committed
1239

David O'Toole's avatar
David O'Toole committed
1240
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1241
  (defun object-eq (a b)
David O'Toole's avatar
David O'Toole committed
1242
    (when (and a b (xelfp a) (xelfp b))
David O'Toole's avatar
David O'Toole committed
1243 1244 1245
      (eq (find-object a)
	  (find-object b))))
#+end_src
David O'Toole's avatar
David O'Toole committed
1246

David O'Toole's avatar
David O'Toole committed
1247 1248 1249 1250 1251 1252
#+begin_src lisp
  (defun xelfp (x)
    (when x (typecase x
	      (xelf::quadrille (find-object (uuid x) :no-error))
	      (string (find-object x :no-error)))))
#+end_src
David O'Toole's avatar
David O'Toole committed
1253

David O'Toole's avatar
David O'Toole committed
1254
* Time and frame-rate computations
David O'Toole's avatar
David O'Toole committed
1255

David O'Toole's avatar
David O'Toole committed
1256 1257
See also [[file:dictionary/SET-FRAME-RATE.html][SET-FRAME-RATE]], and the section "Frame rate" below.

David O'Toole's avatar
David O'Toole committed
1258
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1259 1260 1261 1262 1263 1264
  (defvar *updates* 0 "The number of times the Xelf system has been
  updated since startup.")
  (defconstant +60fps+ 60 "Sixty frames per second.")
  (defconstant +30fps+ 30 "Thirty frames per second.")
  (defconstant +seconds-per-minute+ 60)
  (defparameter *time-base* +60fps+ "Default time base. Don't set this
David O'Toole's avatar
David O'Toole committed
1265
  yourself; use SET-FRAME-RATE instead.")
David O'Toole's avatar
David O'Toole committed
1266

David O'Toole's avatar
David O'Toole committed
1267 1268 1269
  (defun seconds (n) 
    "Returns the number of updates in N seconds."
    (* *time-base* n))
David O'Toole's avatar
David O'Toole committed
1270

David O'Toole's avatar
David O'Toole committed
1271 1272 1273
  (defun minutes (n) 
    "Returns the number of updates in N minutes."
    (* (seconds +seconds-per-minute+) n))
David O'Toole's avatar
David O'Toole committed
1274 1275
#+end_src

David O'Toole's avatar
David O'Toole committed
1276 1277
* Quadtrees

David O'Toole's avatar
David O'Toole committed
1278 1279 1280 1281
Xelf uses a [[https://en.wikipedia.org/wiki/Quadtree][quadtree]] data structure to perform efficient collision
detection on objects having axis-aligned bounding boxes. The quadtree
partitions the buffer's space to a configurable tree depth; it uses
the bounding box of each object as a key whose value is the "bucket"
David O'Toole's avatar
David O'Toole committed
1282 1283 1284 1285 1286
(or quadtree node) of items with which that object could possibly
collide. In this way redundant collision checks are
eliminated. Whenever an object moves or is resized, this change in its
bounding box will automatically trigger its re-insertion into the
quadtree at the proper bucket location.
David O'Toole's avatar
David O'Toole committed
1287

David O'Toole's avatar
David O'Toole committed
1288
(This is handled transparently by all objects in the wrapper class
David O'Toole's avatar
David O'Toole committed
1289
NODE. See "Node class" below.)
David O'Toole's avatar
David O'Toole committed
1290 1291 1292 1293

** The active quadtree

Only one quadtree can be active at a time.
David O'Toole's avatar
David O'Toole committed
1294 1295

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1296
(defvar *quadtree* nil "The active quadtree.")
David O'Toole's avatar
David O'Toole committed
1297

David O'Toole's avatar
David O'Toole committed
1298 1299 1300 1301
(defmacro with-quadtree (quadtree &body body)
  "Evaluate BODY forms with *QUADTREE* bound to QUADTREE."
  `(let* ((*quadtree* ,quadtree))
     ,@body))
David O'Toole's avatar
David O'Toole committed
1302

David O'Toole's avatar
David O'Toole committed
1303 1304
(defvar *quadtree-depth* 0 "Current depth of the quadtree.")
(defparameter *default-quadtree-depth* 6 "Default quadtree depth.")
David O'Toole's avatar
David O'Toole committed
1305 1306 1307 1308
#+end_src

** Data structure

David O'Toole's avatar
David O'Toole committed
1309 1310 1311
In each quadtree node we need a bucket of objects, an integer tree
level ID, a bounding box, and downward links to the child quadtree
nodes.
David O'Toole's avatar
David O'Toole committed
1312 1313

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324
  (defclass quadtree ()
    ((objects :initform nil :accessor quadtree-objects :initarg :objects)
     (level :initform nil :accessor quadtree-level :initarg :level)
     (top :initform nil :accessor quadtree-top :initarg :top)
     (left :initform nil :accessor quadtree-left :initarg :left)
     (right :initform nil :accessor quadtree-right :initarg :right)
     (bottom :initform nil :accessor quadtree-bottom :initarg :bottom)
     (southwest :initform nil :accessor quadtree-southwest :initarg :southwest)
     (northeast :initform nil :accessor quadtree-northeast :initarg :northeast)
     (northwest :initform nil :accessor quadtree-northwest :initarg :northwest)
     (southeast :initform nil :accessor quadtree-southeast :initarg :southeast)))
David O'Toole's avatar
David O'Toole committed
1325 1326
#+end_src

David O'Toole's avatar
David O'Toole committed
1327
** Quadrille: base class for collidable objects
David O'Toole's avatar
David O'Toole committed
1328

David O'Toole's avatar
David O'Toole committed
1329 1330 1331 1332
A QUADRILLE is an object which maintains a constant relationship to
the currently active quadtree. With the classes QUADTREE and QUADRILLE
we are establishing Xelf's notion of two-dimensional space. See also
[[file:dictionary/_QUADTREE_.html][*QUADTREE*]] and the section "Object base class operations" below.
David O'Toole's avatar
David O'Toole committed
1333

David O'Toole's avatar
David O'Toole committed
1334
 #+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347
   (defclass quadrille ()
     ((quadtree-node :initform nil :initarg :quadtree-node :accessor quadtree-node)
      (collision-type :initform t :initarg :collision-type :accessor collision-type)
      (uuid :initform nil :accessor uuid :initarg :uuid)
      (heading :initform 0.0 :accessor heading)
      (width :initform 32 :accessor width)
      (height :initform 32 :accessor height)
      (x :initform (cfloat 0) :accessor x)
      (y :initform (cfloat 0) :accessor y)
      (z :initform (cfloat 0) :accessor z)
      (last-x :initform nil :accessor last-x)
      (last-y :initform nil :accessor last-y)
      (last-z :initform nil :accessor last-z)))
David O'Toole's avatar
David O'Toole committed
1348 1349
 #+end_src

David O'Toole's avatar
David O'Toole committed
1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368
** Finding collidable objects by UUID

#+begin_src lisp
  (defgeneric find-identifier (object)
    (:documentation
  "Return an opaque identifier that is #'EQ across calls.
  The default is to simply return the object. Customizing this is not
  currently documented."))

  (defmethod update ((quadrille quadrille)) nil)

  (defmethod find-identifier ((quadrille quadrille)) 
    (uuid quadrille))

  (defvar *identifier-search-function* #'find-object
  "Value must be a function accepting an opaque ID and returning the
  corresponding object. Used by SEARCH-IDENTIFIER.")

  (defun search-identifier (x)
David O'Toole's avatar
David O'Toole committed
1369
    (funcall *identifier-search-function* x t))
David O'Toole's avatar
David O'Toole committed
1370 1371
#+end_src

David O'Toole's avatar
David O'Toole committed
1372 1373
** Quadtree operations

David O'Toole's avatar
David O'Toole committed
1374 1375
*** Computing subtree coordinates

David O'Toole's avatar
David O'Toole committed
1376 1377 1378
Each quadtree node's space is subdivided equally into four
quadrants. These recursively smaller bounding boxes define the spatial
partitioning of the quadtree.
David O'Toole's avatar
David O'Toole committed
1379 1380

 #+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399
   (defun northeast-quadrant (bounding-box)
     (destructuring-bind (top left right bottom) bounding-box
       (list top (cfloat (/ (+ left right) 2)) right (cfloat (/ (+ top
  	   bottom) 2)))))

   (defun southeast-quadrant (bounding-box)
     (destructuring-bind (top left right bottom) bounding-box
       (list (cfloat (/ (+ top bottom) 2)) (cfloat (/ (+ left right) 2))
  	   right bottom)))

   (defun northwest-quadrant (bounding-box)
     (destructuring-bind (top left right bottom) bounding-box
       (list top left
  	   (cfloat (/ (+ left right) 2)) (cfloat (/ (+ top bottom) 2)))))

   (defun southwest-quadrant (bounding-box)
     (destructuring-bind (top left right bottom) bounding-box
       (list (cfloat (/ (+ top bottom) 2)) left
  	   (cfloat (/ (+ left right) 2)) bottom)))
David O'Toole's avatar
David O'Toole committed
1400 1401
 #+end_src

David O'Toole's avatar
David O'Toole committed
1402 1403
*** Building a quadtree structure recursively

David O'Toole's avatar
David O'Toole committed
1404
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1405
  (defun build-quadtree (bounding-box0 &optional (depth
David O'Toole's avatar
David O'Toole committed
1406
  *default-quadtree-depth*))
David O'Toole's avatar
David O'Toole committed
1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417
    "Build a complete quadtree structure inside BOUNDING-BOX0 with DEPTH levels."
    (let ((bounding-box (mapcar #'cfloat bounding-box0)))
      (destructuring-bind (top left right bottom) bounding-box
	(decf depth)
	(if (zerop depth)
	    (make-instance 'quadtree :top top :left left :right right :bottom bottom)
	    (make-instance 'quadtree :top top :left left :right right :bottom bottom
			   :northwest (build-quadtree (northwest-quadrant bounding-box) depth)
			   :northeast (build-quadtree (northeast-quadrant bounding-box) depth)
			   :southwest (build-quadtree (southwest-quadrant bounding-box) depth)
			   :southeast (build-quadtree (southeast-quadrant bounding-box) depth))))))
David O'Toole's avatar
David O'Toole committed
1418 1419
#+end_src

David O'Toole's avatar
David O'Toole committed
1420
*** User-level MAKE-QUADTREE function
David O'Toole's avatar
David O'Toole committed
1421 1422 1423 1424 1425 1426

Building quadtrees of depths between 5 and 8 works well for most
games; depths larger than 10 may be more efficient for large-sized
buffers and/or when many small objects are being simulated, but such
quadtrees will take much more memory. See also [[file:dictionary:_DEFAULT-QUADTREE-DEPTH_.html][*DEFAULT-QUADTREE-DEPTH*]].

David O'Toole's avatar
David O'Toole committed
1427
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1428 1429
  (defun make-quadtree (x y width height 
  &key objects (depth *default-quadtree-depth*))
David O'Toole's avatar
David O'Toole committed
1430 1431 1432 1433 1434
    "Make a new quadtree with the given dimensions, OBJECTS, and DEPTH."
    (let ((quadtree (build-quadtree (list y x (+ x width) (+ y height)) depth)))
      (when objects
	(quadtree-fill objects quadtree))
      quadtree))
David O'Toole's avatar
David O'Toole committed
1435
#+end_src
David O'Toole's avatar
David O'Toole committed
1436

David O'Toole's avatar
David O'Toole committed
1437 1438 1439
*** Testing whether a quadtree node is a leaf node

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1440 1441 1442 1443
  (defmethod leafp ((node quadtree))
    "Return non-nil if NODE has no children."
    ;; this is a complete tree, so testing any quadrant will suffice
    (null (quadtree-southwest node)))
David O'Toole's avatar
David O'Toole committed
1444
#+end_src
David O'Toole's avatar
David O'Toole committed
1445

David O'Toole's avatar
David O'Toole committed
1446
*** Testing quadtree nodes against points and rectangles 
David O'Toole's avatar
David O'Toole committed
1447 1448

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1449 1450 1451 1452 1453 1454 1455 1456
  (defmethod quadtree-contains ((quadtree quadtree) top left right
  bottom)
    "Return non-nil if the node QUADTREE contains the given bounding box."
    (declare (single-float top left right bottom) (optimize (speed 3)))
    (and (<= (the single-float (quadtree-top quadtree)) top)
	 (<= (the single-float (quadtree-left quadtree)) left)
	 (>= (the single-float (quadtree-right quadtree)) right)
	 (>= (the single-float (quadtree-bottom quadtree)) bottom)))
David O'Toole's avatar
David O'Toole committed
1457 1458 1459
#+end_src

*** Traversing the quadtree
David O'Toole's avatar
David O'Toole committed
1460

David O'Toole's avatar
David O'Toole committed
1461
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1462 1463 1464 1465 1466 1467 1468 1469 1470 1471
  (defmethod quadtree-process ((node quadtree) top left right bottom
  processor)
    "Call the function PROCESSOR on each quadtree node containing the bounding box."
    (when (quadtree-contains node top left right bottom)
      (when (not (leafp node))
	(quadtree-process (quadtree-northwest node) top left right bottom processor)
	(quadtree-process (quadtree-northeast node) top left right bottom processor)
	(quadtree-process (quadtree-southwest node) top left right bottom processor)
	(quadtree-process (quadtree-southeast node) top left right bottom processor))
      (funcall processor node)))
David O'Toole's avatar
David O'Toole committed
1472
#+end_src
David O'Toole's avatar
David O'Toole committed
1473

David O'Toole's avatar
David O'Toole committed
1474
*** Bounding-box search
David O'Toole's avatar
David O'Toole committed
1475

David O'Toole's avatar
David O'Toole committed
1476 1477 1478
QUADTREE-SEARCH is the hashing function in our spatial hash; the
bounding box is the key and the value is the correct bucket
(i.e. quadtree node).
David O'Toole's avatar
David O'Toole committed
1479

David O'Toole's avatar
David O'Toole committed
1480
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496
  (defun quadtree-search (top left right bottom node)
    "Return the smallest quadrant enclosing TOP LEFT RIGHT BOTTOM at or
  below NODE, if any."
    (when (quadtree-contains node top left right bottom)
      ;; ok, it's in the overall bounding-box.
      (if (leafp node)
	  ;; there aren't any quadrants to search. stop here.
	  node
	  (or
	   ;; search the quadrants.
	   (or (quadtree-search top left right bottom (quadtree-northwest node))
	       (quadtree-search top left right bottom (quadtree-northeast node))
	       (quadtree-search top left right bottom (quadtree-southwest node))
	       (quadtree-search top left right bottom (quadtree-southeast node)))
	   ;; none of them are suitable. stay here
	   node))))
David O'Toole's avatar
David O'Toole committed
1497 1498 1499 1500 1501
#+end_src

*** Inserting objects

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1502 1503 1504
  (defgeneric quadtree-insert (object tree)
    (:documentation
  "Insert the object OBJECT into the quadtree TREE."))
David O'Toole's avatar
David O'Toole committed
1505

David O'Toole's avatar
David O'Toole committed
1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516
  (defmethod quadtree-insert ((object quadrille) (tree quadtree))
    (let ((node0 
	    (multiple-value-bind (top left right bottom) (bounding-box object)
	      (quadtree-search top left right bottom tree))))
      (let ((node (or node0 tree)))
	(pushnew (find-identifier object)
		 (quadtree-objects node)
		 :test 'eq)
	;; save pointer to node so we can avoid searching when it's time
	;; to delete (i.e. move) the object later.
	(setf (quadtree-node object) node))))
David O'Toole's avatar
David O'Toole committed
1517

David O'Toole's avatar
David O'Toole committed
1518 1519 1520
  (defmethod quadtree-insert-maybe ((object quadrille) tree)
    (when tree
      (quadtree-insert object tree)))
David O'Toole's avatar
David O'Toole committed
1521 1522 1523 1524 1525
#+end_src

*** Deleting objects

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1526 1527 1528
  (defgeneric quadtree-delete (object tree)
    (:documentation
  "Delete the object OBJECT from the quadtree TREE."))
David O'Toole's avatar
David O'Toole committed
1529

David O'Toole's avatar
David O'Toole committed
1530 1531 1532 1533 1534 1535
  (defmethod quadtree-delete ((object quadrille) (tree quadtree))
    ;; grab the cached quadtree node
    (let ((node (or (quadtree-node object) tree)))
      (setf (quadtree-objects node)
	    (delete (find-identifier object) (quadtree-objects node) :test 'eq))
      (setf (quadtree-node object) nil)))
David O'Toole's avatar
David O'Toole committed
1536

David O'Toole's avatar
David O'Toole committed
1537 1538 1539
  (defmethod quadtree-delete-maybe ((object quadrille) tree)
    (when (and tree (quadtree-node object))
      (quadtree-delete object tree)))
David O'Toole's avatar
David O'Toole committed
1540
#+end_src
David O'Toole's avatar
David O'Toole committed
1541

David O'Toole's avatar
David O'Toole committed
1542 1543
*** Moving objects

David O'Toole's avatar
David O'Toole committed
1544
The method [[file:dictionary/UPDATE-BOUNDING-BOX.html][UPDATE-BOUNDING-BOX]] is invoked automatically by the engine
David O'Toole's avatar
David O'Toole committed
1545 1546
whenever an object's bounding box changes. See also "Object base class
operations" below.
David O'Toole's avatar
David O'Toole committed
1547

David O'Toole's avatar
David O'Toole committed
1548
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1549 1550 1551
  (defgeneric update-bounding-box (object quadtree)
    (:documentation 
  "Update the OBJECT's new bounding box and position in QUADTREE."))
David O'Toole's avatar
David O'Toole committed
1552

David O'Toole's avatar
David O'Toole committed
1553 1554 1555 1556
  (defmethod update-bounding-box ((object quadrille) tree)
    (with-quadtree tree
      (quadtree-delete-maybe object tree)
      (quadtree-insert-maybe object tree)))
David O'Toole's avatar
David O'Toole committed
1557
#+end_src
David O'Toole's avatar
David O'Toole committed
1558

David O'Toole's avatar
David O'Toole committed
1559
*** Inserting many objects into a quadtree
David O'Toole's avatar
David O'Toole committed
1560

David O'Toole's avatar
David O'Toole committed
1561
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1562 1563 1564 1565 1566 1567 1568 1569
  (defun quadtree-fill (set quadtree)
    "Insert the objects in SET (a list or hashtable) into QUADTREE."
    (let ((objects (etypecase set
		     (list set)
		     (hash-table (loop for object being the hash-keys in set collect object)))))
      (dolist (object objects)
	(setf (quadtree-node object) nil)
	(quadtree-insert object quadtree))))
David O'Toole's avatar
David O'Toole committed
1570 1571
#+end_src

David O'Toole's avatar
David O'Toole committed
1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600
* Shell access control

By default, the Shell is disabled, and the results of mouse, keyboard,
and joystick events are delivered to the buffer (or buffer subclass,
as when using BIND-EVENT during INITIALIZE-INSTANCE :AFTER) instead of
the shell and its command line and menus. 

But when you do:

: (setf *shell-enabled-p* t)

and create a new buffer, that buffer will have access to the Shell by
pressing Alt-X. 

#+begin_src lisp
(defvar *shell* nil)
(defvar *shell-enabled-p* nil "When non-nil, new buffers have a shell.")

(defun shell-enabled-p () *shell-enabled-p*)
(defun enable-shell () (setf *shell-enabled-p* t))
(defun disable-shell () (setf *shell-enabled-p* nil))

;; lazily initialize the shell; never happens in shipped game
(defmacro with-shell (&body body)
  `(when (shell-enabled-p)
     (create-shell-maybe)
     ,@body))
#+end_src

David O'Toole's avatar
David O'Toole committed
1601
* QBuffer: base class for groups of colliding objects
David O'Toole's avatar
David O'Toole committed
1602

David O'Toole's avatar
David O'Toole committed
1603 1604 1605 1606 1607
The base class QBUFFER implements a collection of QUADRILLE objects
and collides them within an associated quadtree. (Later we will
implement a second layer of classes caled BUFFER and NODE with
additional functionality.)

David O'Toole's avatar
David O'Toole committed
1608 1609 1610
** The current buffer

Only one buffer can be active at a time. 
David O'Toole's avatar
David O'Toole committed
1611

David O'Toole's avatar
David O'Toole committed
1612
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1613
  (defvar *buffer* nil "The currently active buffer.")
David O'Toole's avatar
David O'Toole committed
1614

David O'Toole's avatar
David O'Toole committed
1615 1616
  (defun current-buffer () 
    "Return the currently active buffer object."
David O'Toole's avatar
David O'Toole committed
1617
    *buffer*)
David O'Toole's avatar
David O'Toole committed
1618

David O'Toole's avatar
David O'Toole committed
1619 1620 1621
  (defvar *clear-cached-fonts-on-buffer-switch* t
    "When non-nil, clear font metrics and texture caches upon switching buffers.")

David O'Toole's avatar
David O'Toole committed
1622 1623 1624 1625 1626 1627 1628 1629 1630 1631
  (defun switch-to-buffer (buffer-or-name)
    "Set the currently active buffer to BUFFER-OR-NAME."
    (let ((buffer (if (stringp buffer-or-name)
		      (find-buffer buffer-or-name :create t)
		      buffer-or-name)))
      (assert (xelfp buffer))
      (flet ((do-it () 
	       (setf *buffer* buffer)
	       (setf *blocks* (list buffer))
	       (when *clear-cached-fonts-on-buffer-switch*
David O'Toole's avatar
David O'Toole committed
1632 1633 1634 1635
		 (clear-cached-fonts))
	       (when *clear-cached-images-on-buffer-switch*
		 (clear-cached-images))
		 ))
1636
        ;; make sure shell stays open when switching
David O'Toole's avatar
David O'Toole committed
1637 1638 1639
	(if *interactive-p*
	    (at-next-update 
              (do-it)
1640
	      (with-shell (open-shell (current-buffer))))
David O'Toole's avatar
David O'Toole committed
1641
	    (do-it)))))
David O'Toole's avatar
David O'Toole committed
1642

David O'Toole's avatar
David O'Toole committed
1643 1644 1645 1646
  (defmacro with-buffer (buffer &rest body)
    "Evaluate the BODY forms in the given BUFFER."
    `(let* ((*buffer* ,buffer))
       ,@body))
1647

David O'Toole's avatar
David O'Toole committed
1648 1649 1650 1651 1652 1653 1654 1655
  (defun find-instances (buffer class-name)
    "Return a list of all instances of CLASS-NAME within BUFFER."
    (when (typep buffer (find-class 'buffer))
      (let ((objects (objects buffer)))
	(when objects
	  (loop for thing being the hash-keys in objects
		when (typep (find-object thing t) (find-class class-name))
		  collect (find-object thing t))))))
David O'Toole's avatar
David O'Toole committed
1656 1657
#+end_src

David O'Toole's avatar
David O'Toole committed
1658
** Creating buffers
David O'Toole's avatar
David O'Toole committed
1659 1660

The base class QBUFFER defines basic operations for buffers, and hooks
David O'Toole's avatar
David O'Toole committed
1661
them into the quadtree system by managing QUADRILLE objects.
David O'Toole's avatar
David O'Toole committed
1662 1663

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1664 1665
  (defclass qbuffer (quadrille)
    ((objects :accessor objects :initform nil)
David O'Toole's avatar
David O'Toole committed
1666
     (paused :accessor paused-p :initform nil)
David O'Toole's avatar
David O'Toole committed
1667 1668
     (quadtree :initform nil :accessor quadtree)
     (quadtree-depth :initform 4 :accessor quadtree-depth)))
David O'Toole's avatar
David O'Toole committed
1669

David O'Toole's avatar
David O'Toole committed
1670 1671 1672
  (defmethod initialize-instance :after ((qbuffer qbuffer) &key)
    (setf (objects qbuffer)
	  (make-hash-table :test 'equal)))
David O'Toole's avatar
David O'Toole committed
1673

David O'Toole's avatar
David O'Toole committed
1674 1675 1676 1677
  (defmethod get-nodes ((buffer qbuffer)) 
    (loop for object being the hash-keys in (objects buffer)
       when (find-object object :no-error)
       collect (find-object object)))
David O'Toole's avatar
David O'Toole committed
1678
#+end_src
David O'Toole's avatar
David O'Toole committed
1679

David O'Toole's avatar
David O'Toole committed
1680 1681 1682
** Installing the quadtree

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1683 1684 1685 1686
  (defmethod install-quadtree ((buffer qbuffer))
    (let ((box (multiple-value-list (bounding-box buffer))))
      (with-slots (quadtree quadtree-depth) buffer
	(setf quadtree (build-quadtree box (or quadtree-depth
David O'Toole's avatar
David O'Toole committed
1687
	*default-quadtree-depth*)))
David O'Toole's avatar
David O'Toole committed
1688 1689 1690 1691
	(assert quadtree)
	(let ((objects (get-nodes buffer)))
	  (when objects
	    (quadtree-fill objects quadtree))))))
David O'Toole's avatar
David O'Toole committed
1692 1693
#+end_src

David O'Toole's avatar
David O'Toole committed
1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714
** Scaling the buffer's bounding box

#+begin_src lisp
  (defparameter *buffer-bounding-box-scale* 1.01
    "Actual size of bounding box used for quadtree. The buffer is bordered
  around on all sides by a thin margin designed to prevent objects near
  the edge of the universe piling up into the top quadrant and causing
  slowdown. See also quadtree.lisp")

  (defun scale-bounding-box (box factor)
    (destructuring-bind (top left right bottom) box
      (let ((margin-x (* (- right left)
			 (- factor 1.0)))
	    (margin-y (* (- bottom top)
			 (- factor 1.0))))
	(values (- top margin-y)
		(- left margin-x)
		(+ right margin-x)
		(+ bottom margin-y)))))
#+end_src

David O'Toole's avatar
David O'Toole committed
1715 1716 1717
** Checking whether a buffer contains a given node

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1718 1719
  (defmethod contains-node-p ((qbuffer qbuffer) (quadrille quadrille))
    (gethash (uuid quadrille) (objects qbuffer)))
David O'Toole's avatar
David O'Toole committed
1720 1721 1722 1723 1724
#+end_src

** Adding and removing nodes from a buffer

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1725
  (defmethod add-node 
David O'Toole's avatar
David O'Toole committed
1726 1727
      ((buffer qbuffer) (node quadrille) &optional x y (z 0))
    (declare (ignore z))
David O'Toole's avatar
David O'Toole committed
1728 1729 1730 1731 1732 1733 1734 1735
    (with-buffer buffer
      (with-quadtree (quadtree buffer)
	(let ((uuid (uuid node)))
	    (declare (simple-string uuid))
	    (setf (gethash uuid (objects buffer))
		  (find-identifier node))
	    (when (and (numberp x) (numberp y))
	      (move-to node x y))))))
David O'Toole's avatar
David O'Toole committed
1736

David O'Toole's avatar
David O'Toole committed
1737 1738 1739 1740 1741
  (defmethod remove-node ((buffer qbuffer) (node quadrille))
    (with-buffer buffer
      (quadtree-delete-maybe node (quadtree-node node))
      (remhash (the simple-string (uuid node))
	       (objects buffer))))
David O'Toole's avatar
David O'Toole committed
1742
#+end_src
David O'Toole's avatar
David O'Toole committed
1743

David O'Toole's avatar
David O'Toole committed
1744
** Resizing buffers
David O'Toole's avatar
David O'Toole committed
1745

David O'Toole's avatar
David O'Toole committed
1746
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1747 1748 1749 1750 1751 1752 1753 1754
  (defmethod resize ((buffer qbuffer) new-width new-height)
    (assert (and (plusp new-height)
		 (plusp new-width)))
    (with-slots (height width quadtree) buffer
      (setf height new-height)
      (setf width new-width)
      (when quadtree
	(install-quadtree buffer))))
David O'Toole's avatar
David O'Toole committed
1755 1756
#+end_src

David O'Toole's avatar
David O'Toole committed
1757
** Measuring a group of objects
David O'Toole's avatar
David O'Toole committed
1758

David O'Toole's avatar
David O'Toole committed
1759
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774
  (defun find-bounding-box (nodes)
    "Return as multiple values the minimal bounding box 
  containing the NODES."
    ;; calculate the bounding box of a list of nodes
    (labels ((left (thing) (slot-value thing 'x))
	     (right (thing) (+ (slot-value thing 'x)
			       (slot-value thing 'width)))
	     (top (thing) (slot-value thing 'y))
	     (bottom (thing) (+ (slot-value thing 'y)
				(slot-value thing 'height))))
      ;; let's find the bounding box.
      (values (reduce #'min (mapcar #'top nodes))
	      (reduce #'min (mapcar #'left nodes))
	      (reduce #'max (mapcar #'right nodes))
	      (reduce #'max (mapcar #'bottom nodes)))))
David O'Toole's avatar
David O'Toole committed
1775
#+end_src
David O'Toole's avatar
David O'Toole committed
1776

David O'Toole's avatar
David O'Toole committed
1777 1778 1779
** Iterating over all nodes in a buffer

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1780 1781 1782 1783 1784 1785
  (defmacro do-nodes (spec &body body)
    "Iterate over the nodes in BUFFER, binding VAR to each node and
  evaluating the forms in BODY for each. SPEC is of the form (VAR
  BUFFER)."
    (let ((node (gensym)))
      (destructuring-bind (var buffer) spec 
David O'Toole's avatar
David O'Toole committed
1786
	`(loop for ,node being the hash-values in (slot-value ,buffer 'objects)
David O'Toole's avatar
David O'Toole committed
1787 1788
	       do (let ((,var (find-object ,node)))
		    ,@body)))))
David O'Toole's avatar
David O'Toole committed
1789 1790
#+end_src

David O'Toole's avatar
David O'Toole committed
1791
* Quadrille operations
David O'Toole's avatar
David O'Toole committed
1792 1793 1794

** Using UUIDs

David O'Toole's avatar
David O'Toole committed
1795 1796 1797
Each object is assigned a UUID upon creation and is registered with
the object database (see "Object database" above.)

David O'Toole's avatar
David O'Toole committed
1798
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1799 1800
  (defmethod register-uuid ((quadrille quadrille))
    (add-object-to-database quadrille))
David O'Toole's avatar
David O'Toole committed
1801

David O'Toole's avatar
David O'Toole committed
1802 1803 1804 1805
  (defmethod initialize-instance :after ((quadrille quadrille) &key)
    (when (null (uuid quadrille))
      (setf (uuid quadrille) (make-uuid))
      (register-uuid quadrille)))
David O'Toole's avatar
David O'Toole committed
1806 1807
#+end_src

David O'Toole's avatar
David O'Toole committed
1808
** Destroying objects
David O'Toole's avatar
David O'Toole committed
1809

1810 1811 1812
A destroyed object is removed from any associated buffer, quadtree
structure, and the Object Database.

David O'Toole's avatar
David O'Toole committed
1813
#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1814 1815 1816 1817
  (defmethod remove-node-maybe ((buffer qbuffer) (node quadrille))
    (with-buffer buffer
      (when (contains-node-p buffer node)
	(remove-node buffer node))))
David O'Toole's avatar
David O'Toole committed
1818

David O'Toole's avatar
David O'Toole committed
1819 1820 1821 1822 1823 1824 1825 1826
  (defmethod destroy ((quadrille quadrille))
    (with-slots (quadtree-node uuid) quadrille
      (quadtree-delete-maybe quadrille quadtree-node)
      (remove-node-maybe (current-buffer) quadrille)
      (setf quadtree-node nil)
      (remove-object-from-database quadrille)
      (prog1 t
	(assert (not (find-object uuid :no-error))))))
David O'Toole's avatar
David O'Toole committed
1827 1828
#+end_src

1829
** Bounding box method 
David O'Toole's avatar
David O'Toole committed
1830 1831

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847
  (defgeneric bounding-box (object)
    (:documentation 
  "Return the bounding-box of this OBJECT as multiple values.
  The proper VALUES ordering is (TOP LEFT RIGHT BOTTOM), which could
  also be written (Y X (+ X WIDTH) (+ Y HEIGHT)) if more convenient."))

  (defmethod bounding-box ((quadrille quadrille))
    "Return this object's bounding box as multiple values.
  The order is (TOP LEFT RIGHT BOTTOM)."
    (with-slots (x y width height) quadrille
      (values 
       (cfloat y)
       (cfloat x)
       (cfloat (+ x width))
       (cfloat (+ y height)))))

1848 1849 1850 1851 1852
  (defmethod bounding-box* ((quadrille quadrille))
    (multiple-value-bind (top left right bottom) (bounding-box quadrille)
      (values left top (- right left) (- bottom top))))
#+end_src

1853 1854 1855 1856 1857
** Layout

#+begin_src lisp
  (defmethod layout ((self quadrille)) nil)
#+end_src
David O'Toole's avatar
David O'Toole committed
1858

1859 1860 1861
** Geometry utilities

#+begin_src lisp
David O'Toole's avatar
David O'Toole committed
1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897
  (defmethod center-point ((quadrille quadrille))
    (multiple-value-bind (top left right bottom)
	(the (values float float float float) (bounding-box quadrille))
      (let ((half (cfloat 0.5)))
	(declare (single-float half top left right bottom) (optimize (speed 3)))
	(values (* half (+ left right))
		(* half (+ top bottom))))))

  (defmethod heading-to-thing2 ((self quadrille) thing)
    (multiple-value-bind (x1 y1) (center-point thing)
      (multiple-value-bind (x0 y0) (center-point self)
	(find-heading x0 y0 x1 y1))))

  (defmethod heading-to-thing ((self quadrille) thing)
    (with-slots (x y) self 
      (multiple-value-bind (x0 y0) (center-point thing)
	(find-heading x y x0 y0))))

  (defmethod direction-to ((self quadrille) thing)
    (with-slots (x y) self
      (with-slots (x0 y0) thing
	(find-direction x y x0 y0))))

  (defmethod heading-between ((self quadrille) thing)
    (multiple-value-bind (x y) (center-point self)
      (multiple-value-bind (x0 y0) (center-point thing)
	(find-heading x y x0 y0))))

  (defmethod aim-at  ((self quadrille) node)
    (setf (heading self) (heading-between self node)))

  (defmethod aim  ((self quadrille) heading)
    (assert (numberp heading))
    (setf (heading self) heading))

  (defmethod distance-between  ((self quadrille) (thing quadrille))
David O'Toole's avatar
David O'Toole committed
1898
    (multiple-value-bind (x0 y0) (center-point self)
David O'Toole's avatar
David O'Toole committed
1899 1900
      (multiple-value-bind (x y) (center-point thing)
	(dis