Xelf: eXtensible Emacs-Like Facility

Table of Contents

About this document

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.

This is the documented program source code for Xelf, a simple and free 2D game engine written in Common Lisp.

The Lisp code and documentation below are interwoven in an Emacs Org-mode file, which is exported to both xelf.html (for reading) and to xelf.lisp (for compilation) in a manner similar to "literate 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 available here.

The pieces of documentation surrounding the Lisp source blocks are not intended to duplicate the content of Lisp documentation strings; 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.

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

The documentation extraction code is included. Hierarchical organization of the source code helps both browsing and coding via 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 this Orgmode manual page. See also the org-babel-lisp documentation.

This program and its documentation are works in progress, and many source sections need documentation. These are marked with red TODO tags.

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 reading about the classes' implementations. You may also visit the SVG (Scalable Vector Graphic) version

class-diagram-1.0.png

Lisp package

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".

  (in-package :xelf)

Xelf version information

We use a string to identify the current version of Xelf. To test compatibilty, use the integer *XELF-SERIES*.

(defvar *xelf-version* "4.8"
  "A string giving the version number of Xelf.")

(defvar *xelf-series* 4
  "An integer giving the major API version of Xelf.")

Copyright notices

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 given.

User or application specific notices

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.

(defvar *author* nil "Name of the application author.")

(defvar *author-contact* 
  "URL or email address of application author.")

(defvar *author-copyright-notice* nil
  "Text of user or application specific copyright notice.")

Compiler-specific notices   sbcl ccl ecl

(defvar *ccl-copyright-notice*
  "This distribution of Xelf is compiled with Clozure Common Lisp.
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* 
"This distribution of Xelf is compiled with Steel Bank Common Lisp (SBCL).
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*
"This distribution of Xelf is compiled with Embeddable Common-Lisp (ECL).
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*)

Xelf copyright notices

Xelf includes its own license (GNU Lesser General Public License, 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.

Here is the copyright notice for Xelf and its components:

(defvar *xelf-copyright-notice*
"Welcome to Xelf. 
Xelf is Copyright (C) 2006-2017 by David T O'Toole <dto@xelf.me>
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.

")

Assembling a full copyright notice

By default, the full copyright notice constructed here is printed to two locations via the MESSAGE function:

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

By setting the above variables and displaying the terminal with SHOW-TERMINAL, you can easily show your copyright notice, like a good programmer should. You can hide the terminal again with HIDE-TERMINAL, and clear the text if needed with the function CLEAR-TERMINAL.

See also the section "System terminal" below.

(defvar *copyright-notice*
  (concatenate 'string *xelf-copyright-notice* *compiler-copyright-notice*)
  "Copyright notices for Xelf, its dependencies, and the current Lisp
  implementation.")

(defun full-copyright-notice ()
  (concatenate 'string
               (or *author-copyright-notice* "")
               *copyright-notice*))

Trivia

Queue mechanism

We implement a simple queue-as-list system using a tail pointer.

(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)))

Muffling various warnings   sbcl

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.

   #+sbcl (declaim (sb-ext:muffle-conditions style-warning))

   (defvar *suppress-warnings* nil "When non-nil, suppress spurious style warnings.")

   (defun quiet-warning-handler (c)
     (when *suppress-warnings*
       (let ((r (find-restart 'muffle-warning c)))
        (when r (invoke-restart r)))))

   (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)))

Org-babel patch

This patch is required to work around a bug in Org Babel's source block editing in Lisp mode.

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
+++ /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

Emacs Lisp compatibility macro   emacs

This is used for some parts of Xelf that were originally written in Emacs Lisp, such as the pathfinding.

   (defmacro while (test &body body)
     `(loop while ,test do ,@body))

Allow restart after Lisp error   emacs

The following definition is necessary when using SLIME with SDL to allow restarting of the main game event loop after handling a Lisp error.

   (defmacro restartably (&body body)
     `(restart-case
        (progn ,@body)
       (continue () :report "Continue"  )))

Miscellaneous variables

These need to be filed in their proper places.

(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*)
(defvar *title* nil)

User initialization file

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)".

You can set screen and window parameters here, since this is executed just before the application window is opened.

  (defparameter *user-init-file-name* "xelf-init.lisp"
    "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))))))

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.

  ;; Contributed material:

  ;; 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.

  ;; You can find more information on Norvig's book at his website:

  ;; http://www.norvig.com/paip.html

  ;; The full license for the PAIP code, which governs the terms of
  ;; said redistribution under the GPL, can be found at norvig.com:

  ;; http://www.norvig.com/license.html
  (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))

  (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))))))))))

  (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)))

  (defun clear-memoize (fn-name)
    "Clear the hash table from a memo function."
    (let ((table (get fn-name 'memo)))
      (when table (clrhash table))))

  (defun get-memo-table (fn-name)
    (get fn-name 'memo))
(defmacro callf (function place &rest arguments)
  `(setf ,place (apply #',function ,place (list ,@arguments))))

String and symbol utility functions

For GUI purposes it is useful to tidy strings by pretty-printing them, shortening long strings, and filtering out non-printable characters.

Splitting multi-line strings

  (defun split-string-on-lines (string)
    (with-input-from-string (stream string)
      (loop for line = (read-line stream nil)
            while line collect line)))

Formatting nicer symbols

  (defun-memo pretty-string (thing)
      (:key #'first :test 'equal :validator #'identity)
    (let ((name (etypecase thing
                  (symbol (symbol-name thing))
                  (string thing))))
      (coerce 
        (string-downcase 
          (string-trim " " name))
        'simple-string)))

  (defun-memo ugly-symbol (string)
      (:key #'first :test 'equal :validator #'identity)
    (intern 
     (string-upcase
      (substitute #\- #\Space 
                  (string-trim " " string)))))

  (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))))

  (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)))))

Removing non-printing characters

  (defun control-character-p (character)
    (let ((code (char-code character)))
      (or (< code 32) 
          (= code 127))))

  (defun remove-control-characters (string)
    (remove-if #'control-character-p (coerce string 'vector)))

  (defun truncate-string (string)
    (subseq string 0 (min 118 (length string))))

  (defun clean-string (string)
    (truncate-string (remove-control-characters string)))

Filtering out long or empty strings

  (defun short-string (string)
    (subseq string 0 (min 12 (length string))))

  (defun nice-string (string)
    (if (zerop (length string))
        " "
        string))

Math and geometry functions

Randomly choosing an item from a list

  (defun random-choose (set)
    "Randomly choose one element of the list SET and return it."
    (nth (random (length set)) set))

Randomly scramble a list

  (defun derange (things)
    "Randomly scramble the order of the elements in the list THINGS.
Returns a newly allocated list."
    (let ((len (length things))
          (things2 (coerce things 'vector)))
      (dotimes (n len)
        (rotatef (aref things2 n)
                 (aref things2 (random len))))
      (coerce things2 'list)))

Running code a percentage of the time

  (defmacro percent-of-time (percent &body body)
    "Evaluate the BODY forms PERCENT percent of the time."
    `(when (< (random 100.0) ,percent)
       ,@body))

Rolling dice

  (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)))))))

  (defun roll-under (n sides)
    (< n (random sides)))

Geometry

Converting degrees to radians

In Xelf, angle values (i.e. "headings") are always given in radians. If you need radians from degrees, use RADIAN-ANGLE:

  (defun radian-angle (degrees)
    "Convert DEGREES to radians."
    (* degrees (cfloat (/ pi 180))))

Converting radians to degrees

If you have a radian heading and want degrees, use HEADING-DEGREES:

  (defun heading-degrees (radians)
    "Convert RADIANS to degrees."
    (* radians (cfloat (/ 180 pi))))

Euclidean distance function

  (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)))))

Test point against rectangle

  (defun within-extents (x y x0 y0 x1 y1)
     (and (>= x x0) 
          (<= x x1)
          (>= y y0)
          (<= y y1)))

Find angle between two points

  (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)))

Reversing a heading

  (defun opposite-heading (heading)
    "Return the heading angle opposite to HEADING."
    (mod (+ pi heading)
         (* 2 pi)))

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.

   ;; 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)))))

Cardinal directions

These are useful for grid-based games.

  (defvar
  *directions* (list :right :upright :up :upleft :left :downleft :down :downright)
    "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*))
         *directions*))

  (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)))
  (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)))))

Grid-based line-of-sight lighting

   (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
       (when thicken
        ;; 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
       (when thicken
        ;; 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)))))

Bresenham's line algorithm

We use 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.

   (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)))
     ;;   (funcall trace-function x (+ y0 n)))

   (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))))

Midpoint-displacement noise

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 the Diamond-square algorithm.

First comes the midpoint formula.

  (defun midpoint (A B)
    (list (truncate (/ (+ (first A) (first B)) 2))
          (truncate (/ (+ (second A) (second B)) 2))))

Defining rectangles

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

  (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)))))

Rendering the noise

  (defun render-noise (width height &key (graininess 1.0) array)
    "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))

Hooks

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.

See also AT-NEXT-UPDATE.

  (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))))

Object database

Each object is given a UUID (universally unique identifier.) These are used as keys into the database, a hash table.

Database variable

  (defvar *database* nil)

Generating UUIDs

We use the UUID library from Quicklisp.

  (defun make-uuid ()
    (with-output-to-string (s)
      (uuid:print-bytes s (uuid:make-v4-uuid))))

Creating the database

  (defun initialize-database ()
    (setf *database* 
          (make-hash-table :test 'equal :size 8192)))

Adding and removing objects

  (defun add-object-to-database (object)
    (when (null *database*)
      (initialize-database))
    (setf (gethash 
           (the simple-string (uuid object))
           *database*)
          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))
       *database*)))

Searching for objects by UUID

  (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))))
(defun find-uuid (object)
  (when object
    (uuid (find-object object))))
  (defun find-object (thing &optional no-error)
    (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)))))))

Object identity tests

  (defun object-eq (a b)
    (when (and a b (xelfp a) (xelfp b))
      (eq (find-object a)
          (find-object b))))
  (defun xelfp (x)
    (when x (typecase x
              (xelf::quadrille (find-object (uuid x) :no-error))
              (string (find-object x :no-error)))))

Time and frame-rate computations

See also SET-FRAME-RATE, and the section "Frame rate" below.

  (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
  yourself; use SET-FRAME-RATE instead.")

  (defun seconds (n) 
    "Returns the number of updates in N seconds."
    (* *time-base* n))

  (defun minutes (n) 
    "Returns the number of updates in N minutes."
    (* (seconds +seconds-per-minute+) n))

Quadtrees

Xelf uses a 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" (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.

(This is handled transparently by all objects in the wrapper class NODE. See "Node class" below.)

The active quadtree

Only one quadtree can be active at a time.

(defvar *quadtree* nil "The active quadtree.")

(defmacro with-quadtree (quadtree &body body)
  "Evaluate BODY forms with *QUADTREE* bound to QUADTREE."
  `(let* ((*quadtree* ,quadtree))
     ,@body))

(defvar *quadtree-depth* 0 "Current depth of the quadtree.")
(defparameter *default-quadtree-depth* 6 "Default quadtree depth.")

Data structure

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.

  (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)))

Quadrille: base class for collidable objects

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 *QUADTREE* and the section "Object base class operations" below.

   (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)))

Finding collidable objects by UUID

  (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)
    (funcall *identifier-search-function* x t))

Quadtree operations

Computing subtree coordinates

Each quadtree node's space is subdivided equally into four quadrants. These recursively smaller bounding boxes define the spatial partitioning of the quadtree.

   (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)))

Building a quadtree structure recursively

  (defun build-quadtree (bounding-box0 &optional (depth
  *default-quadtree-depth*))
    "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))))))

User-level MAKE-QUADTREE function

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 *DEFAULT-QUADTREE-DEPTH*.

  (defun make-quadtree (x y width height 
  &key objects (depth *default-quadtree-depth*))
    "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))

Testing whether a quadtree node is a leaf node

  (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)))

Testing quadtree nodes against points and rectangles

  (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)))

Traversing the quadtree

  (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)))

Bounding-box search

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).

  (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))))

Inserting objects

  (defgeneric quadtree-insert (object tree)
    (:documentation
  "Insert the object OBJECT into the quadtree TREE."))

  (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))))

  (defmethod quadtree-insert-maybe ((object quadrille) tree)
    (when tree
      (quadtree-insert object tree)))

Deleting objects

  (defgeneric quadtree-delete (object tree)
    (:documentation
  "Delete the object OBJECT from the quadtree TREE."))

  (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)))

  (defmethod quadtree-delete-maybe ((object quadrille) tree)
    (when (and tree (quadtree-node object))
      (quadtree-delete object tree)))

Moving objects

The method UPDATE-BOUNDING-BOX is invoked automatically by the engine whenever an object's bounding box changes. See also "Object base class operations" below.

  (defgeneric update-bounding-box (object quadtree)
    (:documentation 
  "Update the OBJECT's new bounding box and position in QUADTREE."))

  (defmethod update-bounding-box ((object quadrille) tree)
    (with-quadtree tree
      (quadtree-delete-maybe object tree)
      (quadtree-insert-maybe object tree)))

Inserting many objects into a quadtree

  (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))))

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.

(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))

QBuffer: base class for groups of colliding objects

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.)

The current buffer

Only one buffer can be active at a time.

  (defvar *buffer* nil "The currently active buffer.")

  (defun current-buffer () 
    "Return the currently active buffer object."
    *buffer*)

  (defvar *clear-cached-fonts-on-buffer-switch* t
    "When non-nil, clear font metrics and texture caches upon switching buffers.")

  (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*
                 (clear-cached-fonts))
               (when *clear-cached-images-on-buffer-switch*
                 (clear-cached-images))
               (visit buffer)
                 ))
        ;; make sure shell stays open when switching
        (if *interactive-p*
            (at-next-update 
              (do-it)
              (with-shell (open-shell (current-buffer))))
            (do-it)))))

  (defmacro with-buffer (buffer &rest body)
    "Evaluate the BODY forms in the given BUFFER."
    `(let* ((*buffer* ,buffer))
       ,@body))

  (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))))))

Creating buffers

The base class QBUFFER defines basic operations for buffers, and hooks them into the quadtree system by managing QUADRILLE objects.

  (defclass qbuffer (quadrille)
    ((objects :accessor objects :initform nil)
     (paused :accessor paused-p :initform nil)
     (quadtree :initform nil :accessor quadtree)
     (quadtree-depth :initform 4 :accessor quadtree-depth)))

  (defmethod visit ((qbuffer qbuffer)) nil)

  (defmethod initialize-instance :after ((qbuffer qbuffer) &key)
    (setf (objects qbuffer)
          (make-hash-table :test 'equal)))

  (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)))

Installing the quadtree

  (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
        *default-quadtree-depth*)))
        (assert quadtree)
        (let ((objects (get-nodes buffer)))
          (when objects
            (quadtree-fill objects quadtree))))))

Scaling the buffer's bounding box

  (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)))))

Checking whether a buffer contains a given node

  (defmethod contains-node-p ((qbuffer qbuffer) (quadrille quadrille))
    (gethash (uuid quadrille) (objects qbuffer)))

Adding and removing nodes from a buffer

  (defmethod add-node 
      ((buffer qbuffer) (node quadrille) &optional x y (z 0))
    (declare (ignore z))
    (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))))))

  (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))))

Resizing buffers

  (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))))

Measuring a group of objects

  (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)))))

Iterating over all nodes in a buffer

  (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 
        `(loop for ,node being the hash-values in (slot-value ,buffer 'objects)
               do (let ((,var (find-object ,node)))
                    ,@body)))))

Quadrille operations

Using UUIDs

Each object is assigned a UUID upon creation and is registered with the object database (see "Object database" above.)

  (defmethod register-uuid ((quadrille quadrille))
    (add-object-to-database quadrille))

  (defmethod initialize-instance :after ((quadrille quadrille) &key)
    (when (null (uuid quadrille))
      (setf (uuid quadrille) (make-uuid))
      (register-uuid quadrille)))

Destroying objects

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

  (defmethod remove-node-maybe ((buffer qbuffer) (node quadrille))
    (with-buffer buffer
      (when (contains-node-p buffer node)
        (remove-node buffer node))))

  (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))))))

Bounding box method

  (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)))))

  (defmethod bounding-box* ((quadrille quadrille))
    (multiple-value-bind (top left right bottom) (bounding-box quadrille)
      (values left top (- right left) (- bottom top))))

Layout

  (defmethod layout ((self quadrille)) nil)

Geometry utilities

  (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))
    (multiple-value-bind (x0 y0) (center-point self)
      (multiple-value-bind (x y) (center-point thing)
        (distance x0 y0 x y))))

Collision geometry tests

  (defun rectangle-in-rectangle-p (x y width height o-top o-left o-width
  o-height)
    (declare (single-float x y width height o-top o-left o-width o-height)
             (optimize (speed 3)))
    (not (or 
          ;; is the top below the other bottom?
          (<= (+ o-top o-height) y)
          ;; is bottom above other top?
          (<= (+ y height) o-top)
          ;; is right to left of other left?
          (<= (+ x width) o-left)
          ;; is left to right of other right?
          (<= (+ o-left o-width) x))))

  (defmethod colliding-with-rectangle-p ((self quadrille) o-top o-left o-width o-height)
    ;; you must pass arguments in Y X order since this is TOP then LEFT
    (multiple-value-bind (x y width height) (bounding-box* self)
      (rectangle-in-rectangle-p (cfloat x) (cfloat y) (cfloat width) (cfloat height) 
                            (cfloat o-top) (cfloat o-left) (cfloat o-width) (cfloat o-height))))

  (defun colliding-with-bounding-box-p (self top left right bottom)
    ;; you must pass arguments in Y X order since this is TOP then LEFT
    (multiple-value-bind (x y width height) (bounding-box* self)
      (when (and width height)
        (rectangle-in-rectangle-p (cfloat x) (cfloat y) (cfloat width) (cfloat height)
                              top left (- right left) (- bottom top)))))

  (defgeneric colliding-with-p (this that)
    (:documentation 
  "Return non-nil when bounding boxes of THIS and THAT are colliding."))

  (defmethod colliding-with-p ((self quadrille) (thing quadrille))
    (multiple-value-bind (top left right bottom) 
        (bounding-box thing)
      (colliding-with-bounding-box-p self top left right bottom)))

Movement

Because an object's bounding box determines its position in the quadtree, we must delete and then re-insert that object whenever its size or position changes. See also "Quadtrees" above.

  (defmethod clear-buffer-data ((self quadrille))
    (clear-saved-location self)
    (setf (slot-value self 'quadtree-node) nil))

  (defmethod move-to ((node quadrille) x0 y0 &optional z0)
    (with-slots (x y z) node
      (setf x x0 y y0)
      (when z (setf z z0)))
    (update-bounding-box node *quadtree*)
    nil)

  (defmethod resize ((quadrille quadrille) width height)
    (quadtree-delete-maybe quadrille (quadtree-node quadrille))
    (setf (height quadrille) height)
    (setf (width quadrille) width)
    (quadtree-insert-maybe quadrille (quadtree-node quadrille)) nil)

All the other movement and resize functions are based on MOVE-TO and RESIZE, so the quadtree data are maintained properly.

  (defun step-coordinates (x y heading &optional (distance 1))
    "Return as multiple values the coordinates of the point DISTANCE
    units away from X,Y in the direction given by HEADING."
    (values (+ x (* distance (cos heading)))
            (+ y (* distance (sin heading)))))

  (defmethod step-toward-heading ((self quadrille) heading &optional (distance 1))
    (multiple-value-bind (x y) (center-point self)
      (step-coordinates x y heading distance)))

  (defmethod move  ((self quadrille) heading distance)
    (with-slots (x y) self
      (multiple-value-bind (x0 y0) (step-coordinates x y heading distance)
        (move-to self x0 y0))))

  (defmethod forward  ((self quadrille) distance)
    (move self (heading self) distance))

  (defmethod backward  ((self quadrille) distance)
    (move self (opposite-heading (heading self)) distance))

  (defmethod move-toward ((self quadrille) direction &optional (steps 1))
    (with-slots (x y) self
      (multiple-value-bind (x0 y0)
          (step-in-direction x y (or direction :up) (or steps 5))
        (move-to self x0 y0))))

  (defmethod turn-left ((self quadrille) radians)
    (decf (heading self) radians))

  (defmethod turn-right ((self quadrille) radians)
    (incf (heading self) radians))

Tracking pre-collision locations

This makes it easy to undo movements that led to collisions.

  (defmethod save-location ((quadrille quadrille))
    (with-slots (x y z last-x last-y last-z) quadrille
      (setf last-x x
            last-y y
            last-z z)))

  (defmethod clear-saved-location ((quadrille quadrille))
    (with-slots (last-x last-y last-z) quadrille
      (setf last-x nil last-y nil last-z nil)))

  (defmethod restore-location ((quadrille quadrille))
    (with-slots (x y z last-x last-y last-z quadtree-node) quadrille
      (when last-x
        (quadtree-delete-maybe quadrille quadtree-node)
        (setf x last-x
              y last-y
              z last-z)
        (quadtree-insert-maybe quadrille quadtree-node))))

Responding to collisions

The main method for an object's collision response is COLLIDE.

    (defgeneric collide (this that)
      (:documentation
    "Trigger defined collision methods for when THIS collides with THAT.
    If a collision method is defined as (COLLIDE CLASS-1 CLASS-2), then
    this COLLIDE will trigger when QUADTREE-COLLIDE is called on instances
    of CLASS-1 that are colliding with instances of CLASS-2. 

    If (COLLIDE CLASS-2 CLASS-1) is also defined, it will be triggered
    only when QUADTREE-COLLIDE is called on colliding instances of
    CLASS-2.

    If you always want both orderings of the class pair's COLLIDE to be
    triggered, then you must call QUADTREE-COLLIDE on every object in the
    scene. This is done by default but can be interfered with if you use
    the slot COLLISION-TYPE."))

    (defmethod collide ((this quadrille) (that quadrille)) nil)

    (defmethod handle-collision ((this quadrille) (that quadrille)) 
      (collide this that)
      (collide that this))

Collision detection operations

Bounding box query

We need a method to check a quadtree bucket against a given bounding box and process all the colliding objects.

  (defmethod quadtree-map-collisions ((tree quadtree) top left right
  bottom processor)
    (quadtree-process tree top left right bottom
     #'(lambda (node)
         (let (garbage)
           (dolist (object (quadtree-objects node))
             (if (search-identifier object)
                 (when (colliding-with-bounding-box-p (search-identifier object) top left right bottom)
                   (funcall processor (search-identifier object)))
                 (push object garbage)))
           (dolist (g garbage)
             (setf (quadtree-objects node)
                   (delete g (quadtree-objects node) :test 'equal)))))))

Top-level collision triggers

  (defgeneric quadtree-collide (object quadtree)
    (:documentation
  "Detect and handle collisions of OBJECT with other objects within the
  QUADTREE. The multimethod COLLIDE will be invoked on each pair of 
  (OBJECT OTHER-OBJECT)"))

  (defmethod quadtree-collide ((object quadrille) (tree quadtree))
    (multiple-value-bind (top left right bottom) (bounding-box object)
      (quadtree-map-collisions tree
       top left right bottom
       #'(lambda (thing)
           (when (and (collision-type thing)
                      (colliding-with-p object thing)
                      (not (eq object thing)))
             (with-quadtree tree
               (handle-collision object thing)))))))

  (defun collide-objects (objects quadtree)
    "Trigger all collisions for OBJECTS within QUADTREE."
    (dolist (object objects)
      (quadtree-collide object quadtree)))

  (defun collide-objects* (objects quadtree)
    "Trigger all collisions for identified OBJECTS within QUADTREE."
    (dolist (id (mapcar #'find-identifier objects))
      ;; object might have been deleted by other collisions
      (when (search-identifier id)
        (quadtree-collide (search-identifier id) quadtree))))

System update loop

This is the inner loop of a Xelf buffer's UPDATE method, which runs every frame. First we update all the objects in the buffer, then detect and handle all collisions.

  (defmethod run ((quadtree quadtree) objects)
    (with-quadtree quadtree
      (loop for uuid being the hash-keys in objects do
           (let ((object? (search-identifier (gethash uuid objects))))
             (if object?
                 (update object?)
                 (remhash (the simple-string uuid) objects))))
      ;; detect collisions
      (loop for uuid being the hash-keys in objects do
           (let ((object? (search-identifier (gethash uuid objects))))
             (when object?
               (unless (eq :passive (slot-value object? 'collision-type))
                 (quadtree-collide object? quadtree)))))))

Triggering the system update loop

Here we hook QBUFFER into the global system update function. See also "SDL event loop adapter" below.

  (defmethod update :before ((buffer qbuffer))
    (with-slots (quadtree objects) buffer
      (when (null quadtree)
        (install-quadtree buffer))
      (assert quadtree)
      (run quadtree objects)))

We don't update the buffer if it's paused.

  (defmethod update :around  ((buffer qbuffer))
    (when (not (paused-p buffer))
      (call-next-method)))

Here is the top-level update function.

  (defun update-system ()
    (handler-case 
        (progn
          (incf *updates*)
          (run-hook '*next-update-hook*)
          (setf *next-update-hook* nil)
          (assert (null *next-update-hook*))
          (when *buffer* (update *buffer*))
          (with-shell (update *shell*)))
      (floating-point-inexact (fpe)
        (error fpe))))

Device driver

Variable for GL window status   obsolete

  (defvar *gl-window-open-p* nil)

Pending resource list

During Lisp loading a number of DEFRESOURCE forms may be evaluated. The system collects these entries into *PENDING-RESOURCES* and indexes them later during system startup. See also "Startup" below.

  (defvar *pending-resources* '() "List of collected DEFRESOURCE entries.")

  (defun add-resource (plist)
    "Add the resource defined by the properties in PLIST."
    (assert (and (consp plist)
                 (keywordp (first plist))))
    (push (expand-resource-description plist) *pending-resources*))

  (defun add-resources (plists)
    "Add the resources defined by PLISTS to the resource queue."
    (mapcar #'add-resource plists))

Keyboard state

See the accompanying file "keys.lisp" for a complete listing of keyboard event symbols.

  (defun-memo keyboard-id (key)
      (:key #'first :test 'eq :validator #'identity)
    "Look up the SDL symbol corresponding to the XELF symbol KEY. See keys.lisp."
    (let* ((entry (find key *key-identifiers* :key #'first))
           (entry2 (find (second entry) *sdl-key-identifiers* :key #'second)))
      (first entry2)))

  (defun-memo keyboard-mod (mod)
      (:key #'first :test 'eq :validator #'identity)
    "Look up the SDL symbol corresponding to the XELF symbol MOD. See keys.lisp."
    (let* ((entry (find mod *key-modifiers* :key #'first))
           (entry2 (find (second entry) *sdl-key-modifiers* :key #'second)))
      (first entry2)))

  (defun keyboard-held-p (key) 
    "Returns the duration in seconds that KEY has been depressed over a
  number of game loops."
    (sdl:key-held-p (keyboard-id key)))

  (defun keyboard-pressed-p (key)
    "Returns t if KEY has just been depressed in the current game loop."
    (sdl:key-pressed-p (keyboard-id key)))

  (defun keyboard-released-p (key)
    "Returns t if KEY has just been released in the current game loop."
    (sdl:key-released-p (keyboard-id key)))

  (defun keyboard-time-in-current-state (key)
    "Returns the duration in seconds that KEY is either pressed or
  depressed."
    (sdl:key-time-in-current-state (keyboard-id key)))

  (defun keyboard-time-in-previous-state (key)
    "Returns the duration in seconds that KEY was in its previous state
  either pressed or depressed."
    (sdl:key-time-in-previous-state (keyboard-id key)))

  (defun keyboard-down-p (key)
    "Returns t if the KEY is depressed."
    (sdl:key-down-p (keyboard-id key)))

  (defun keyboard-modifier-down-p (mod)
    "Returns t if the modifier key MOD is depressed."
    (sdl:mod-down-p (keyboard-mod mod)))

  (defun keyboard-keys-down ()
    "Returns a list of the keys that are depressed."
    (labels ((translate (key)
               (let ((entry (find key *sdl-key-identifiers* :key #'first)))
                 (let ((entry2 (find (second entry) *key-identifiers* :key #'second)))
                   (first entry2)))))
      (mapcar #'translate (sdl:keys-down-p))))

  (defun keyboard-modifiers () 
    "Returns a list of the modifier keys that are depressed."
    (labels ((translate (mod)
               (let ((entry (find mod *sdl-key-modifiers* :key #'first)))
                 (let ((entry2 (find (second entry) *key-modifiers* :key #'second)))
                   (first entry2)))))
      (mapcar #'translate (sdl:mods-down-p))))

Keyboard utilities

  (defun holding-control ()
    "Returns non-nil if one of the CONTROL keys is pressed."
    (or (keyboard-modifier-down-p :lctrl)
        (keyboard-modifier-down-p :rctrl)))

  (defun holding-alt ()
    "Returns non-nil if one of the ALT keys is pressed."
    (or (keyboard-modifier-down-p :lalt)
        (keyboard-modifier-down-p :ralt)))

  (defun holding-shift ()
    "Returns non-nil if one of the SHIFT keys is pressed."
    (or (keyboard-modifier-down-p :lshift)
        (keyboard-modifier-down-p :rshift)))

  (defun holding-down-arrow-p () (or (keyboard-down-p :kp2) (keyboard-down-p :down)))
  (defun holding-up-arrow-p () (or (keyboard-down-p :kp8) (keyboard-down-p :up)))
  (defun holding-left-arrow-p () (or (keyboard-down-p :kp4) (keyboard-down-p :left)))
  (defun holding-right-arrow-p () (or (keyboard-down-p :kp6) (keyboard-down-p :right)))
  (defun holding-shift-p () (xelf::holding-shift))
  (defun holding-enter-p () (or (keyboard-down-p :kp-enter)
                               (keyboard-down-p :return)))
  (defun holding-return-p () (holding-enter))

  (defun arrow-keys-direction ()
    (cond 
      ((and (holding-down-arrow-p) (holding-right-arrow-p)) :downright)
      ((and (holding-down-arrow-p) (holding-left-arrow-p)) :downleft)
      ((and (holding-up-arrow-p) (holding-right-arrow-p)) :upright)
      ((and (holding-up-arrow-p) (holding-left-arrow-p)) :upleft)
      ((holding-down-arrow-p) :down)
      ((holding-up-arrow-p) :up)
      ((holding-left-arrow-p) :left)
      ((holding-right-arrow-p) :right)))

  (defun make-key-modifier-symbol (sdl-mod)
    "Translate from the SDL key modifier symbol SDL-MOD to our own
  key event symbols."
    (if (or (member sdl-mod *joystick-button-symbols*)
            (member sdl-mod *other-modifier-symbols*))
        sdl-mod
        (case sdl-mod
          (:SDL-KEY-MOD-NONE nil)
          (:SDL-KEY-MOD-LSHIFT :shift)
          (:SDL-KEY-MOD-RSHIFT :shift)
          (:SDL-KEY-MOD-LCTRL :control)
          (:SDL-KEY-MOD-RCTRL :control)
          (:SDL-KEY-MOD-LALT :alt)
          (:SDL-KEY-MOD-RALT :alt)
          (:SDL-KEY-MOD-LMETA :meta)
          (:SDL-KEY-MOD-RMETA :meta)
          ;; for compatibility:
          (:SDL-KEY-NONE nil)
          (:SDL-KEY-LSHIFT :shift)
          (:SDL-KEY-RSHIFT :shift)
          (:SDL-KEY-LCTRL :control)
          (:SDL-KEY-RCTRL :control)
          (:SDL-KEY-LALT :alt)
          (:SDL-KEY-RALT :alt)
          (:SDL-KEY-LMETA :meta)
          (:SDL-KEY-RMETA :meta)
          ;; fix for windows
          (:SDL-KEY-MOD-NUM nil)
          (:SDL-KEY-CAPS :caps-lock)
          (:SDL-KEY-MOD-CAPS :caps-lock) ;; macintosh 
          (:SDL-KEY-MODE nil)
          (:SDL-KEY-MOD-MODE :mode)
          (:SDL-KEY-RESERVED nil)
          )))

  (defun make-key-symbol (sdl-key)
    "Translate from :SDL-KEY-X to the symbol :X ."
    (let ((prefix "SDL-KEY-")
          (name (symbol-name sdl-key)))
      (assert (search prefix name))
      (make-keyword (subseq name (length prefix)))))

Key repeat

  (defvar *key-repeat-p* nil)

  (defvar *key-repeat-delay* 9)
  (defvar *key-repeat-interval* 1.2)

  (defun key-repeat-p ()
    "Returns non-nil if key repeat is enabled."
    *key-repeat-p*)

  (defun enable-key-repeat (&optional (delay *key-repeat-delay*) 
                                      (interval *key-repeat-interval*))
    "Enable key repeat after DELAY milliseconds, repeating at INTERVAL
  milliseconds."
    (let ((delay-milliseconds (truncate (* delay (/ 1000.0 *frame-rate*))))
          (interval-milliseconds (truncate (* interval (/ 1000.0 *frame-rate*)))))
      (sdl:enable-key-repeat delay-milliseconds interval-milliseconds)
      (setf *key-repeat-delay* delay)
      (setf *key-repeat-interval* interval)
      (setf *key-repeat-p* t)))

  (defun disable-key-repeat ()
    "Disable key repeat."
    (sdl:disable-key-repeat)
    (setf *key-repeat-p* nil))

Logging messages to the terminal

You can send a message to the user with the function MESSAGE. By default, logged messages go to the application's *STANDARD-OUTPUT* stream and also to the Xelf system terminal. See also the section "System terminal" below.

  (defparameter *message-logging* t)

  (defun message-to-standard-output (message-string)
    (format t "~A" message-string)
    (fresh-line)
    (force-output))

  (defun message-to-terminal (message-string)
    (format-terminal "~A" message-string))

  (defun message-to-standard-output-and-terminal (message-string)
    (message-to-standard-output message-string)
    (message-to-terminal message-string))

  (defparameter *message-function* #'message-to-standard-output-and-terminal)

  (defun reset-message-function ()
    (setf *message-function* #'message-to-standard-output))

  (defvar *message-hook* nil)

  (defvar *message-history* nil)

  (defun message (format-string &rest args)
    "Print a log message by passing the arguments to
  `*message-function'. When the variable `*message-logging*' is nil,
  this output is disabled."
      (let ((message-string (apply #'format nil format-string args)))
        (when *message-logging* 
          (funcall *message-function* message-string))
        (dolist (hook *message-hook*)
          (funcall hook))
        (push message-string *message-history*)))

  (defun print-copyright-notice ()
    (dolist (line (split-string-on-lines (full-copyright-notice)))
      (message line)))

Delivering events

By default, keyboard and joystick button events are sent to the CURRENT-BUFFER. You can do this manually with MAKE-EVENT and SEND-EVENT.

  (defvar *event-hook* nil)

  (defun hit-blocks (x y &optional (blocks *blocks*))
    (when blocks
      (let ((x0 (truncate x))
            (y0 (truncate y))
            (bx blocks));; (if (null *shell*) blocks (cons *shell* blocks))))
        (labels ((try (b)
                   (hit b x0 y0)))
          (let ((parent (find-if #'try bx :from-end t)))
            (when parent
              (try parent)))))))

  (defun send-to-blocks (event &optional (blocks *blocks*))
    (dolist (hook *event-hook*)
      (funcall hook event))
    (labels ((try (block)
               (handle-event block event)))
      (some #'try blocks)))

  (defun send-to-current-buffer (event)
    (dolist (hook *event-hook*)
      (funcall hook event))
    (when (current-buffer)
      (handle-event (current-buffer) event)))

  (defvar *event-handler-function* #'send-to-current-buffer
    "Function to be called with input events. Keyboard, mouse,
  and joystick events are represented as 'event lists' of the form:

    (STRING . MODIFIERS)

  where STRING is a string representing the key or button, and MODIFIERS
  is a list of key modifier symbols like :shift, :control, :alt, and so
  on.

  The modifier list is sorted; thus, events can be compared for
  equality with `equal' and used as hashtable keys.")

  (defun send-event (event)
    "Send the event EVENT to the currently active objects."
    (if (null *event-handler-function*)
        (error "No event handler function installed. 
  Please set the variable xelf:*event-handler-function*")
        (funcall *event-handler-function* event)))

  (defun raw-joystick-event-p (event)
    "Return non-nil if the EVENT is a raw joystick data event."
    (eq :raw-joystick (first event)))

  (defun joystick-event-p (event)
    "Return non-nil if the EVENT is a joystick event."
    (or (raw-joystick-event-p event)
        (eq :joystick (first event))))

  (defun normalize-event (event)
    "Convert EVENT to a normal form suitable for `equal' comparisons."
    ;; don't sort joystick event modifiers
    (if (joystick-event-p event)
        event
        (cons (first event)
              (sort (remove-duplicates (delete nil (rest event)))
                    #'string< :key #'symbol-name))))

  (defvar *joystick-button-symbols*
    '(:a :b :x :y ;; face buttons
      :left :right :up :down ;; directional pad
      :select :start ;; menu buttons
      :left-trigger :left-bumper :right-trigger :right-bumper  ;; shoulder buttons
      :left-click :right-click)) ;; clicking the analog sticks

  (defparameter *other-modifier-symbols* '(:button-down :button-up))

Defining events

  (defun make-event (code modifiers)
    "Create an input event for the key CODE with MODIFIERS pressed.
  The argument CODE may be one of:

     - a keyword symbol naming the keyboard key, such as :RETURN or :SPACE
       (see also `make-key-symbol'.)

     - a one-character string, whose first character is the translated
       Unicode character being bound

     - an integer whose value is the unicode character code from SDL

  or, 

     - a cons of the form (key unicode) will be passed through
       unaltered." 
    ;; pass through joystick events unaltered
    (if (joystick-event-p (cons code modifiers))
        (cons code modifiers)
        (let ((head
                (etypecase code
                  (integer (string (code-char code)))
                  (string (prog1 code
                            (assert (= 1 (length code)))))
                  (symbol code)
                  (cons code))))
          (normalize-event
           (cons head
                 ;; modifiers
                 (cond ((keywordp modifiers)
                        (list modifiers))
                       ((listp modifiers)
                        modifiers)
                       ;; catch apparent lispbuilder-sdl bug?
                       ((eql 0 modifiers)
                        nil)))))))

Joystick data

  (defparameter *default-joystick-profile* '(:name "Unknown Joystick"
      :type :joystick
      :left-analog-stick (0 1)
      :right-analog-stick (3 2)
      :buttons ()))

  (defvar *joystick-profile* *default-joystick-profile*)

  (defvar *user-joystick-profile* nil)

  (defvar *joystick-device* nil 
    "The SDL device id of the current joystick.")

  (defvar *joystick-device-number* nil 
    "The number of the current joystick.")

  (defvar *joystick-b-device* nil 
    "The SDL device id of the current joystick.")

  (defvar *joystick-b-device-number* nil 
    "The number of the current joystick.")

  (defparameter *joystick-profiles*
    '(("DragonRise Inc.   Generic   USB  Joystick  " 
       :name "Generic USB Gamepad" :type :joystick
       :left-analog-stick (0 1)
       :right-analog-stick (3 2)
       :buttons ((2 . :a)
                 (1 . :b)
                 (3 . :x)
                 (0 . :y)
                 (6 . :left-bumper)
                 (7 . :right-bumper)
                 (8 . :select)
                 (9 . :start)
                 (4 . :left-trigger)
                 (5 . :right-trigger)))
      ("GreenAsia Inc.    USB Joystick     "
       :name "Generic USB Gamepad" :type :joystick
       :left-analog-stick (0 1)
       :right-analog-stick (3 2)
       :buttons ((2 . :a)
                 (1 . :b)
                 (3 . :x)
                 (0 . :y)
                 (4 . :left-bumper)
                 (5 . :right-bumper)
                 (8 . :select)
                 (9 . :start)
                 (6 . :left-trigger)
                 (7 . :right-trigger)))
      ("USB Dance Pa" 
       :name "Generic USB Dance Pad" :type :dance 
       :buttons  ((12 . :up)
                  (15 . :left)
                  (13 . :right)
                  (14 . :down)
                  (0 . :downleft)
                  (3 . :downright)
                  (2 . :upleft)
                  (1 . :upright)
                  (8 . :select)
                  (9 . :start)))
      ("GASIA CORP. PS(R) Gamepad Adaptor" 
       :name "Generic USB Gamepad" :type :joystick
       :left-analog-stick (0 1)
       :right-analog-stick (2 3)
       :buttons ((4 . :up)
                 (7 . :left)
                 (5 . :right)
                 (6 . :down)
                 (12 . :downleft)
                 (16 . :downright)
                 (14 . :upleft)
                 (13 . :upright)
                 (14 . :b)
                 (13 . :a)
                 (15 . :y)
                 (12 . :x)
                 (0 . :select)
                 (3 . :start)))))

  (defun find-joystick-profile-by-name (name)
    (let ((entry (assoc name *joystick-profiles* :test 'equal)))
      (when entry (cdr entry))))

  (defun find-joystick-profile (indicator)
    (etypecase indicator
      (string (find-joystick-profile-by-name indicator))
      (list indicator)))

  (defun joystick-profile ()
    (or *user-joystick-profile* *joystick-profile*))

  (defun joystick-name (&optional (profile (joystick-profile)))
    (getf (find-joystick-profile profile) :name))

  (defun joystick-type (&optional (profile (joystick-profile))) 
    (getf (find-joystick-profile profile) :type))

  (defun joystick-buttons (&optional (profile (joystick-profile)))
    (getf (find-joystick-profile profile) :buttons))

  (defun joystick-left-analog-stick (&optional (profile (joystick-profile)))
    (getf (find-joystick-profile profile) :left-analog-stick))

  (defun joystick-right-analog-stick (&optional (profile (joystick-profile)))
    (getf (find-joystick-profile profile) :right-analog-stick))

  (defun button-to-symbol (button)
    (cdr (assoc button (joystick-buttons))))

  (defun symbol-to-button (sym)
    (let ((entry (some #'(lambda (x)
                           (when (eq sym (cdr x))
                             x))
                       (joystick-buttons))))
      (when entry 
        (car entry))))

Analog sticks

  (defparameter *joystick-axis-size* 32768.0)

  (defparameter *joystick-dead-zone* 5000)

  (defvar *joystick-axis-values* 
    (list (make-array 100 :initial-element 0)
          (make-array 100 :initial-element 0)))

  (defun update-joystick-axis (axis value &optional (id 0))
    (setf (aref (nth id *joystick-axis-values*) axis) value))

  (defun joystick-axis-raw-value (axis &optional (id 0))
    (aref (nth id *joystick-axis-values*) axis))

  (defun joystick-axis-pressed-p (axis &optional (id 0))
    (< *joystick-dead-zone* (abs (joystick-axis-raw-value axis id))))

  (defun joystick-axis-value (axis &optional (id 0))
    (/ (joystick-axis-raw-value axis id)
       *joystick-axis-size*))

  (defun analog-stick-pressed-p (&optional (stick (joystick-left-analog-stick)) (id 0))
    (destructuring-bind (horizontal vertical) stick
      (or (joystick-axis-pressed-p horizontal id)
          (joystick-axis-pressed-p vertical id))))

  (defun left-analog-stick-pressed-p (&optional (id 0))
    (analog-stick-pressed-p (joystick-left-analog-stick) id))

  (defun right-analog-stick-pressed-p (&optional (id 0))
    (analog-stick-pressed-p (joystick-right-analog-stick) id))

  (defun analog-stick-heading (&optional (stick (joystick-left-analog-stick)) (id 0))
    (destructuring-bind (horizontal vertical) stick
      (when (analog-stick-pressed-p stick id)
        (find-heading 0 0 
                      (joystick-axis-raw-value horizontal id)
                      (joystick-axis-raw-value vertical id)))))

  (defun analog-stick-pressure (&optional (stick (joystick-left-analog-stick)) (id 0))
    (destructuring-bind (horizontal vertical) stick
      (if (analog-stick-pressed-p stick id)
          (/ (distance 0 0
                       (joystick-axis-value horizontal id)
                       (joystick-axis-value vertical id))
             ;; scale to [0.0, 1.0]
             (sqrt 2))
          0.0)))

  (defun left-analog-stick-heading (&optional (id 0))
    (analog-stick-heading (joystick-left-analog-stick) id))

  (defun right-analog-stick-heading (&optional (id 0))
    (analog-stick-heading (joystick-right-analog-stick) id))

  (defun left-analog-stick-pressure (&optional (id 0))
    (analog-stick-pressure (joystick-left-analog-stick) id))

  (defun right-analog-stick-pressure (&optional (id 0))
    (analog-stick-pressure (joystick-right-analog-stick) id))

Joystick buttons

  (defvar *joystick-button-states* (list nil nil))

  (defun find-device (id)
    (ecase id 
      (0 *joystick-device*)
      (1 *joystick-b-device*)))

  (defun poll-joystick-button (button &optional (id 0))
    "Return 1 if the button numbered BUTTON is pressed, otherwise 0."
    (sdl-cffi::sdl-joystick-get-button (find-device id) button))

  (defun update-joystick-button (button state &optional (id 0))
    "Update the table in `*joystick-button-states*' to reflect the STATE of
  the BUTTON. STATE should be either 1 (on) or 0 (off)."
    (setf (aref (nth id *joystick-button-states*) button) state))

  (defun joystick-button-state (button &optional (id 0))
    (poll-joystick-button button id))

  (defun joystick-button-pressed-p (button &optional (id 0))
    (let ((button-number (if (integerp button) 
                             button
                             (symbol-to-button button))))
      (when button-number 
        (= 1 (joystick-button-state button-number id)))))

  (defun reset-joystick (&optional (device 0))
    "Re-open the joystick device and re-initialize the state."
    (setf *joystick-device* (sdl-cffi::sdl-joystick-open device))
    (setf *joystick-device-number* device)
    (setf *joystick-b-device* (sdl-cffi::sdl-joystick-open (1+ device)))
    (setf *joystick-b-device-number* (1+ device))
    (setf *joystick-button-states* 
          (list (make-array 100 :initial-element nil)
                (make-array 100 :initial-element nil)))
    (setf *joystick-axis-values* 
          (list (make-array 100 :initial-element 0)
                (make-array 100 :initial-element 0))))

  (defun holding-button-p (joystick)
    (when (numberp joystick)
      (some #'(lambda (button) (joystick-button-pressed-p button joystick))
            '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))))

Scanning for joystick devices

  (defun number-of-joysticks ()
    (sdl:num-joysticks))

  (defun scan-for-joysticks ()
    (message "Scanning for connected joysticks...")
    (block scanning
      (when (plusp (sdl:num-joysticks))
        (dotimes (index (sdl:num-joysticks))
          (let ((joystick (sdl:sdl-joystick-name index)))
            (message "Checking joystick ~S, device name: ~S" index joystick)
            (let ((profile (find-joystick-profile joystick)))
              (if (null profile)
                  (message "Could not find joystick profile for ~S. Continuing with default profile..." joystick)
                  (destructuring-bind (&key name type &allow-other-keys) profile
                    (setf *joystick-profile* profile)
                    (message "Found joystick profile ~S for ~S." type name)))))))))

Frame rate and updating

  (defparameter *default-frame-rate* 30)

  (defvar *frame-rate* *default-frame-rate*
    "Requested frame rate.")

  (defun set-frame-rate (&optional (rate *frame-rate*))
    "Set the frame rate for the game to RATE."
    (message "Setting frame rate to ~S" rate)
    (setf (sdl:frame-rate) rate)
    (setf *time-base* rate))

  (defun get-ticks ()
    (sdl:sdl-get-ticks))

  (defun update-blocks ()
    (dolist (block *blocks*)
      (update block)))

  (defvar *update-function* #'update-blocks)

  (defun draw-current-buffer ()
    (when *buffer*
      (draw *buffer*)))

  (defvar *draw-function* #'draw-current-buffer)

  (defun do-update (&rest args) 
    (update-system))

  (defparameter *updates* 0 "The number of game loop updates since startup.")

Screen properties

System window configuration

  (defvar *fullscreen* nil "When non-nil, attempt to use fullscreen
  mode.")

  (defvar *window-title* "xelf" "Title string for OS window.")

  (defvar *window-position* :center
    "Controls the position of the game window. Either a list of coordinates or the symbol :center.")

Physical size and nominal size

  (defparameter *screen-width* 640 "Physical width of the window, in
  pixels.")
  (defparameter *screen-height* 480 "Physical height of the window, in pixels.")

The nominal size of of the window in pixels, in case we just want to scale the scene to match the window instead of showing more of the buffer. If these are the same as the `*screen-' settings above, then more of the buffer will be shown when the window size increases.

  (defparameter *nominal-screen-width* nil "Nominal width of the window,
  in pixels.")
  (defparameter *nominal-screen-height* nil "Nominal height of the window, in pixels.")

Size measured in OpenGL coordinate units

  (defparameter *gl-screen-width* 640 "Width of the window expressed in
  OpenGL coordinates.")
  (defparameter *gl-screen-height* 480 "Height of the window expressed in OpenGL coordinates.")

Scaling output to the system window

  (defparameter *scale-output-to-window* nil
    "When non-nil, always show a fixed amount of the buffer when changing
  window size. Otherwise (the default) one onscreen pixel equals one
  unit of buffer space, so that more of the buffer shows if the window
  becomes larger.")
 
  (defparameter *z-near* 10000)
  (defparameter *z-far* 0)

  (defvar *use-texture-blending* t)

  (defun enable-texture-blending ()
    (gl:enable :texture-2d :blend))

  (defun open-viewport ()
    (gl:matrix-mode :projection)
    (gl:load-identity)
    (gl:viewport 0 0 *screen-width* *screen-height*)
    (when (null *nominal-screen-width*)
      (setf *nominal-screen-width* *screen-width*))
    (when (null *nominal-screen-height*)
      (setf *nominal-screen-height* *screen-height*))
    (if *scale-output-to-window*
        (setf *gl-screen-width* *nominal-screen-width*
              *gl-screen-height* *nominal-screen-height*)
        (setf *gl-screen-width* *screen-width*
              *gl-screen-height* *screen-height*)))

Orthographic projection   linux mac windows

   #+(or linux darwin win32
        (and win32 64-bit) ;; sbcl
        (and windows-target 64-bit-target)) ;; ccl
   (defun project-orthographically (&optional (depth-test t))
     (unless depth-test
       (gl:disable :depth-test))
     (when depth-test
       (gl:enable :depth-test)
       (gl:depth-func :gequal)
       (gl:clear-depth 1.0))
     (gl:clear :color-buffer-bit)
     (enable-texture-blending)
     (set-blending-mode :alpha)
     (gl:matrix-mode :projection)
     (gl:load-identity)
     (gl:ortho 0 *gl-screen-width* *gl-screen-height* 0 *z-near* *z-far*))

Orthographic projection   android

   #+android
   (defun project-orthographically (&optional (depth-test t))
     (unless depth-test
       (gl:disable :depth-test))
     (when depth-test
       (gl:enable :depth-test)
       (gl:depth-func :gequal)
       (gl:clear-depth-f 1.0))
     ;; (gl:clear :color-buffer-bit)
     (enable-texture-blending)
     (set-blending-mode :alpha)
     (gl:matrix-mode :projection)
     (gl:load-identity)
     (let ((aspect (cfloat (/ *gl-screen-width* *gl-screen-height*))))
       (%gl:ortho-f 0 1380 870 -100 *z-near* *z-far*)))

Moving the camera in orthographic projection

  (defvar *window-x* 0)
  (defvar *window-y* 0)
  (defvar *window-z* 100)

  (defun transform-window (&key (x 0) (y 0) (z 0) (scale-x 1.0) (scale-y 1.0) (scale-z 1.0))
    (setf *window-x* x)
    (setf *window-y* y)
    (setf *window-z* z)
    ;; now move viewing volume
    (gl:matrix-mode :modelview)
    (gl:load-identity)
    (gl:translate (- 0 x)
                  (- 0 y)
                  (- 0 z))
    (gl:scale scale-x scale-y scale-z))

Window and pointer

  (defvar *pointer-x* 0 "Current window-relative x-coordinate of the
  mouse pointer." )
  (defvar *pointer-y* 0 "Current window-relative y-coordinate of the mouse pointer.")

  (defun window-pointer-x (&optional (x *pointer-x*))
    "Return the absolute x-coordinate of the mouse pointer."
    (+ *window-x*
       (* x (/ 1 (/ *screen-width* *nominal-screen-width*)))))

  (defun window-pointer-y (&optional (y *pointer-y*))
    "Return the absolute y-coordinate of the mouse pointer."
    (+ *window-y*
       (* y (/ 1 (/ *screen-height* *nominal-screen-height*)))))

System window resize behavior

  (defvar *resizable* t "When non-nil, game window will be resizable.")
  (defparameter *resize-hook* nil "Hook to be run after user resizes window.")

Resources

Default resource names

  (defparameter *font* "sans-11"
  "The current font resource name. See also WITH-FONT.
  See also the file 'xelf/standard/index.xelf' for examples of font
  resource declarations.")

  (defparameter *sans* "sans-11"
    "Name of the default sans-serif font.")

  (defparameter *serif* "serif-11"
    "Name of the default serif font.")

  (defparameter *monospace* "sans-mono-11"
    "Name of the default monospace (fixed-width) font.")

  (defparameter *bold* "sans-bold-11"
  "Resource name of default boldface font.")

  (defparameter *italic* "sans-italic-11"
  "Resource name of default italic font.")

  (defvar *color* "black")

Resource record structure

  (defparameter *resource-file-extension* ".xelf"
  "XELF is a simple Lisp data interchange file format. An XELF file can
  contain one or more data resources. 
   :DATA    Lisp data encoding the resource itself, if any.

  In memory, these will be represented by resource structs (see below).
  On disk, it's Lisp data printed as text. This text should compress very
  well.

  The string '()' is a valid .XELF file; it contains no resources.")

  (defclass resource ()
    ((name :initform nil :accessor resource-name :initarg :name)
     (type :initform nil :accessor resource-type :initarg :type)
     (properties :initform nil :accessor resource-properties :initarg :properties)
     (file :initform nil :accessor resource-file :initarg :file)
     (data :initform nil :accessor resource-data :initarg :data)
     (object :initform nil :accessor resource-object :initarg :object)
     (system-p :initform nil :accessor resource-system-p :initarg :system-p)))

  (defun resource-p (res)
    (typep res (find-class 'resource)))

  ;; The extra `object' field is not saved in .XELF files; it is used to
  ;; store driver-dependent loaded resources (i.e. SDL image surface
  ;; objects and so on). This is used in the resource table.
  ;; The system-p field is likewise not stored. 

  (defun resource-to-plist (res)
    "Convert the resource record RES into a property list.
  This prepares it for printing as part of an XELF file."
    (list :name (resource-name res)
          :type (resource-type res)
          :properties (resource-properties res)
          :file (resource-file res)
          :data (resource-data res)
          :object nil))

Resource database

  (defvar *resources* nil
    "A hash table mapping resource names to resource records. All loaded
  resources go in this one hash table.

  The `resource table' maps resource names to their corresponding
  records. `Indexing' a resource means that its resource record is added
  to the resource table. `Loading' a resource means that any associated
  driver-dependent object (SDL image surface, audio buffer object, etc)
  is created, which may involve reading an image or sound file from the
  disk. This value is stored into the OBJECT field of the resource
  record upon loading; see `load-resource'.

  The loading operation may be driver-dependent, so each resource
  type (i.e. :image, :text, :sound) is handled by its own plugin
  function (see `*resource-handlers*').

  `Finding' a resource means looking up its record in the resource
  table, and loading the resource if it hasn't been loaded already.
  A lookup failure results in an error. See `find-resource'.")

  (defun initialize-resource-table ()
    "Create a new empty resource table."
     (setf *resources* (make-hash-table :test 'equal)))

Reading and writing S-expressions in files

   (defvar *keyword-package* (find-package :keyword))

   (defun write-sexp-to-file (filename sexp)
     (message "Writing data to file ~S" filename)
     (with-open-file (file filename :direction :output 
                          :if-exists :supersede
                          :if-does-not-exist :create)
       (let ((*package* *keyword-package*))
        (with-standard-io-syntax 
          (let ((*print-circle* t))
            (print sexp file)))))
        ;;(format file "~S" sexp)))
     (message "Writing data to file ~S... Done." filename))

   (defvar *eof-value* (gensym))

   (defun read-sexp-from-file (filename)
     (message "Reading data from ~A..." filename)
     (with-open-file (file filename :direction :input)
       (with-standard-io-syntax
        (let ((*read-eval* nil))
          (prog1 (loop as sexp = (read file nil *eof-value*)
                       until (eq *eof-value* sexp)
                       collect sexp)
            (message "Reading data from ~A... Done." filename))))))

   ;; Now tie it all together with routines that read and write
   ;; collections of records into XELF files.

   (defun save-resource-file (filename resources)
     "Write the RESOURCES to the XELF file FILENAME."
     (write-sexp-to-file filename (mapcar #'resource-to-plist resources)))

   (defun load-resource-file (filename &optional system-p)
     "Return a list of resources from the XELF file FILENAME."
     (labels ((resourcep (s)
               (keywordp (first s))))
       ;; read the file
       (let ((sexp (read-sexp-from-file filename)))
        ;; find the resource plists; see `read-sexp-from-file'
        (mapcar #'(lambda (s)
                    (let ((resource (apply #'make-instance 'resource s)))
                      (prog1 resource
                        (setf (resource-system-p resource) system-p))))
                (if (every #'resourcep sexp)
                    sexp
                    (first sexp))))))

Projects and paths

  (defparameter *project-directory-extension* ".xelf")

  (defvar *project-path* nil "The pathname of the currently opened project.")

  (defvar *after-load-project-hook* nil)

  (defvar *executable* nil "Non-nil when running Xelf from a saved binary image.")

  (defparameter *untitled* "XELF")

  (defvar *project* *untitled* 
    "The name of the current project.
  This is set by OPEN-PROJECT; use that instead.")

  (defvar *project-object* nil)

  (defun set-current-project (object)
    (assert (xelfp object))
    (setf *project-object* object))

  (defun current-project ()
    (when (null *project-object*)
      (setf *project-object* (make-instance 'project)))
    *project-object*)

  (defvar *recent-projects* nil)

  ;;; Project packages

  (defun standard-project-p (&optional (project *project*))
    (string= "STANDARD" (string-upcase project)))

  (defun untitled-project-p (&optional (project *project*))
    (string= project *untitled*))

  (defparameter *current-directory* #P"./")

  (eval-when (:load-toplevel) 
    (setf *current-directory*
          (make-pathname
           :directory (pathname-directory #.#P"./"))))
         
           ;; (pathname-directory *load-truename*))))

  (defun current-directory () 
    "Returns the pathname of the current directory."
    *current-directory*)

  (defun xelf-directory ()
    (make-pathname :directory 
                       (pathname-directory 
                        (make-pathname
                         :host (pathname-host #.(or *compile-file-truename*
                                                    *load-truename*))
                         :device (pathname-device #.(or *compile-file-truename*
                                                        *load-truename*))
                         :directory (pathname-directory #.(or *compile-file-truename*
                                                              *load-truename*))))))

  (defun projects-directory ()
    (user-homedir-pathname))

  (defun project-directory-name (project)
    (assert (stringp project))
    (remove #\Space project))

  (defun default-project-pathname (project)
    (assert (stringp project))
    (cl-fad:pathname-as-directory 
     (make-pathname 
      :name (project-directory-name project)
      :defaults (projects-directory)
      :type :unspecific)))

  (defun make-directory-maybe (name)
    (ensure-directories-exist 
     (make-pathname :name "NAME" :type :unspecific
                    :defaults 
                    (cl-fad:pathname-as-directory name))))
                             
  (defun default-project-directories () 
      (list 
       (xelf-directory)
       (or *user-projects-directory* (projects-directory))
       (current-directory)))

  (defvar *user-projects-directory* nil)

  (defvar *project-directories* nil
    "List of directories where XELF will search for projects.
  Directories are searched in list order.")

  (defun project-parent-directory ()
    (when *project* (asdf:system-relative-pathname (intern *project*) "../")))

  (defun full-project-directories ()
    (delete nil
            (append (list
                     (xelf-directory)
                     (asdf:system-relative-pathname 'xelf "")
                     *user-projects-directory*
                     (user-homedir-pathname))
                    (let ((d (project-parent-directory)))
                      (when d (list d))))))

  (defun search-project-path (project)
    "Search the `*project-directories*' path for a directory with the
  name PROJECT. Returns the pathname if found, otherwise nil."
    (let ((dirs *project-directories*))
      (assert (stringp project))
      (or (loop 
            for dir in dirs for path
              = (cl-fad:directory-exists-p 
                 (make-pathname
                  :defaults (cl-fad:pathname-as-directory dir)
                  :name (project-directory-name project)))
            when path return path)
          *current-directory*)))
       ;; (prog1 nil
       ;;   (message "Cannot find project ~s in paths ~S. Try checking your *PROJECTS-DIRECTORIES* settings in the XELF-INIT.LISP configuration file. Continuing..."
       ;;               project dirs)))))

  (defun file-name-extension (name)
    (let ((pos (position #\. name :from-end t)))
      (when (numberp pos)
        (subseq name (1+ pos)))))

Finding the native path string   sbcl ccl ecl

  (defun find-native-namestring (name) 
   #+ecl (namestring name)
   #+ccl (ccl:native-translated-namestring name)
   #+sbcl (sb-ext:native-namestring name))

Resource utilities

  (defparameter *resource-extensions* '(("png" :image)
      ("wav" :sample)
      ("ogg" :music)
      ("xm" :music)
      ("xelf" :buffer)
      ("lisp" :lisp)
      ("ttf" :ttf)))

  (defun resource-type-from-name (name)
    (let ((extension (file-name-extension (if (pathnamep name) (file-namestring name) name))))
      (when extension
        (car (cdr (assoc extension *resource-extensions* :test 'equal))))))

  (defun sample-filename-p (name) 
    (eq :sample (resource-type-from-name name)))

  (defun music-filename-p (name) 
    (eq :music (resource-type-from-name name)))

  (defun image-filename-p (name)
    (eq :image (resource-type-from-name name)))

  (defun scrub-filename (name)
    (let ((pos (search name ".newest")))
      (if (numberp pos)
          (subseq name 0 pos)
          name)))

  (defun index-resource (resource)
    "Add the RESOURCE's record to the resource table.
  If a record with that name already exists, it is replaced."
    (when (resource-file resource)
      (find-resource-pathname resource))
    (setf (gethash (resource-name resource)
                   *resources*)
          resource))

  (defun expand-resource-description (plist)
    (destructuring-bind 
        (&key name type file properties &allow-other-keys) plist
      (list :name name 
            :type (or type (resource-type-from-name name))
            :properties properties
            :file (or file name))))

  (defun resource-entries-to-plists (entries)
    (cond
      ;; variable
      ((and (symbolp (first entries))
            (boundp (first entries)))
       (mapcar #'expand-resource-description 
               (symbol-value (first entries))))
      ;; short form: (defresource "file.ext" &rest PROPERTIES)
      ((stringp (first entries))
       (list 
        (expand-resource-description 
            (list :name (first entries)
                  :properties (rest entries)))))
      ;; inline: (defresource :name ...)
      ((keywordp (first entries))
       (list 
        (expand-resource-description entries)))
      ;; list of property lists
      ((every #'consp entries)
       (mapcar #'expand-resource-description entries))))

Defining resources with DEFRESOURCE

  (defmacro defresource (&rest entries)
  "Define a new resource.

  A Xelf 'resource' is an image, sound, text, color, or font. Most
  resources will depend on a file for their data, such as a .PNG file
  for images and .WAV files for sounds.

  A 'resource record' defines a resource. A resource record is a
  property list with the following elements:

   - :NAME    A string; the name of the resource. (Required)
   - :TYPE    A keyword symbol identifying the data type.
              Valid types are :color :music :image :sample :ttf :font
              If TYPE is not given, Xelf will try to guess the file type
              based on the extension given as the NAME.
   - :PROPERTIES  Property list with extra data specific to resource TYPE.
   - :FILE    Name of file to load data from, if any. 
              Relative to project directory.
              If FILE is not given, use the NAME.

  "
    `(eval-when (:load-toplevel)
       (xelf:add-resources 
        (resource-entries-to-plists ',entries))))

  (defmacro define-resource (&rest entries)
    `(defresource ,@entries))

Project utilities

  (defun directory-samples (dir)
    (remove-if-not #'sample-filename-p 
                   (cl-fad:list-directory dir)))

  (defun project-samples ()
    (directory-samples (find-project-path)))

  (defun directory-images (dir)
    (remove-if-not #'image-filename-p 
                   (cl-fad:list-directory dir)))

  (defun project-images ()
    (directory-images (find-project-path)))

  (defun add-file-resource (filename)
    (add-resource (expand-resource-description 
                   (list :name (find-native-namestring (file-namestring filename))))))

  (defun index-all-samples ()
    "Index all .WAV samples in the project."
    (message "Indexing samples...")
    (dolist (sample (project-samples))
      (add-file-resource sample)))

  (defun index-all-images ()
    "Index all .PNG images in the project."
    (message "Indexing images...")
    (dolist (image (project-images))
      (add-file-resource image)))

  (defun preload-resources () 
    "Preload all currently indexed resources."
    (let ((count 0))
      (message "Preloading resources...")
      (loop for resource being the hash-values in *resources* do
        (when (member (resource-type resource) '(:image :sample))
          (load-resource resource)
          (incf count)))
      (message "Preloaded ~S resources. Done." count)))

  (defun find-project-path (&optional (project-name *project*))
    "Return the current project path."
    (assert (not (null project-name)))
    (or *project-path*
        (search-project-path project-name)))

  (defun find-project-file (project-name file)
    "Make a pathname for FILE within the project PROJECT-NAME."
    (merge-pathnames file (find-project-path project-name)))

  (defun default-project-lisp-file (project-name)
    (find-project-file project-name (concatenate 'string project-name ".lisp")))

  (defparameter *object-index-filename* "index.xelf")

  (defun load-project-objects (project)
    (let ((object-index-file (find-project-file project *object-index-filename*)))
      (when (cl-fad:file-exists-p object-index-file)
        (message "Reading saved objects from ~S" object-index-file)
        (index-resource-file project object-index-file))))

  (defun load-project-lisp (project)
    (unless (or (untitled-project-p project)
                (standard-project-p project))
      (let ((lisp (default-project-lisp-file project)))
        (if (cl-fad:file-exists-p lisp)
            (progn (message "Loading lisp for project ~A..." project)
                   (load lisp))
            (message "No default lisp file found in project ~S. Continuing..." project)))))

  (defun create-project-image (project &key folder-name parent)
    (if (null project)
        (prog1 nil (message "Cannot create project. You must choose a project name."))
        (let* ((directory (or parent (projects-directory)))
               (dirs (mapcar #'string-upcase (find-directories directory))))
          (if (find project dirs :test 'equal)
              (prog1 nil 
                (message "Cannot create project ~A, because a folder with this name already exists in ~A"
                         project directory))
              (let ((dir (if folder-name 
                             (default-project-pathname folder-name)
                             (default-project-pathname project))))
                (message "Creating new project ~A in directory ~A..." project dir)
                (setf *project* project)
                (prog1 dir
                  (make-directory-maybe dir)
                  (message "Finished creating directory ~A." dir)
                  (message "Finished creating project ~A." project)))))))

  (defun project-package ()
    (find-package (make-keyword *project*)))

  (defun find-system-path (project)
    (when (not (string-equal "standard" project))
      (asdf:system-relative-pathname (intern *project*) "")))

  (defun load-project-image (project &key without-database with-database)
    (assert (stringp project))
    (message "Opening project: ~A" (string-upcase project))
    (setf *project* project)
    (setf *project-path*
          (or (unless *executable* (find-system-path project))
              (search-project-path project)))
    ;; check path
    (message "Set project path to ~A" (namestring *project-path*)) 
    ;; load any .xelf files
    (index-project project)
    ;; TODO support :with-database arg as well
    (unless without-database
      (load-database)
      (load-variables))
    (when without-database
      (message "Starting without database or variables loading, due to user command."))
    (message "Started up successfully. Indexed ~A resources." (hash-table-count *resources*)))
 
  (defun open-project (&optional (project *project*) parameters)
    "Set the current project to PROJECT."
    (destructuring-bind (&key (without-database t) with-database) parameters
      (load-project-image (if (stringp project) project (string-downcase (symbol-name project)))
                          :without-database without-database
                          :with-database with-database)))

  (defun index-pending-resources ()
    (message "Indexing ~S pending resources..." (length *pending-resources*))
    (dolist (plist *pending-resources*)
      (index-resource (apply #'make-instance 'resource plist))))

  (defun play-project (&optional (project *project*))
    (initialize-resource-table)
    (start-up)
    ;; load objects and buffers from disk
    (load-project-image project)
    (dolist (plist *pending-resources*)
      (index-resource (apply #'make-instance 'resource plist)))
    (start-session)
    (shut-down))
  
  (defun directory-is-project-p (dir)
    "Test whether a directory has the .xelf suffix."
    (let ((index-filename (concatenate 'string
                                       (file-namestring dir)
                                       *resource-file-extension*)))
      (cl-fad:file-exists-p (make-pathname :name index-filename
                                 :directory (if (stringp dir)
                                                dir
                                                (namestring dir))))))

  (defun find-directories (dir)
    (mapcar #'(lambda (s)
                (subseq s 0 (1- (length s))))
            (mapcar #'find-native-namestring
                    (directory (concatenate 'string (namestring dir) "/*/")))))

  (defun directory-files (dir)
    (sort (mapcar #'find-native-namestring
                  (directory (concatenate 'string (namestring dir) "/*/")))
           #'string<))

  (defun find-projects-in-directory (dir)
    "Search DIR for projects and return a list of their names."
    (remove-if-not #'directory-is-project-p (find-directories dir)))

  (defun find-all-projects ()
    (mapcar #'file-namestring
            (mapcan #'find-projects-in-directory *project-directories*)))

  (defun index-resource-file (project-name resource-file &optional system-p)
    "Add all the resources from the resource-file RESOURCE-FILE to the resource
  table. File names are relative to the project PROJECT-NAME."
    (let ((resources (load-resource-file resource-file system-p)))
      (message "Loading ~A resources from file ~A:~A..." (length resources)
               project-name resource-file)
      (dolist (res resources)
        (if (eq :xelf (resource-type res))
            ;; we're including another xelf file. if :data is specified,
            ;; take this as the name of the project where to look for
            ;; that xelf file and its resources.
            (let ((include-project (or (resource-data res) 
                                       project-name)))
              (index-resource-file include-project (find-project-file include-project
                                                            (resource-file res))))
            ;; we're indexing a single resource.
            (progn (index-resource res)
                   (when (and system-p (member (resource-type res) '(:image :sample)))
                     (load-resource res)))))))

  (defun index-project (project-name)
    "Add all the resources from the project PROJECT-NAME to the resource
  table."
    (let ((index-file (find-project-file project-name *object-index-filename*)))
      (if (cl-fad:file-exists-p index-file)
          (index-resource-file project-name index-file
                               (standard-project-p project-name))
          (message "Did not find index file ~A in project ~A. Continuing..."
                   index-file project-name))))

Writing project data to disk

  ;; See also the documentation string for `*resource-file-extension*'.

  (defun make-object-resource (name object)
    "Make an object resource named NAME (a string) with the Lisp object
  OBJECT as the resource data."
    (message "Creating new object resource ~S." name)
    (let ((resource (make-instance 'resource :name name 
                                   :type :object
                                   :object object)))
      (prog1 resource
        (index-resource resource))))

  (defun save-object-resource (resource &optional (project *project*))
    "Save an object resource to disk as {PROJECT-NAME}/{RESOURCE-NAME}.XELF."
    (save-resource-file (find-project-file project 
                                  (concatenate 'string (resource-name resource)
                                               *resource-file-extension*))
               (list resource))
    (setf (resource-data resource) nil))

  (defun save-buffer (&optional (buffer (current-buffer)))
    (save-object-resource 
     (make-instance 'resource :name (buffer-name buffer)
                    :data (flatten (find-object buffer))
                    :type :buffer)))

  (defun special-resource-p (resource)
    (string= "*" (string (aref (resource-name resource) 0))))

  (defun make-resource-link (resource)
    (make-instance 'resource :type :xelf 
                   :file (concatenate 'string
                                      (resource-name resource)
                                      *resource-file-extension*)))
  
  (defun save-resource (name resource)
    (let ((pathname (resource-file resource))
          (link (make-instance 'resource-link resource)))
      (prog1 link 
        (if (eq :object (resource-type resource))
            ;; we want to index them all, whether or not we save them all.
            ;; make a link resource (i.e. of type :xelf) to pull this in later
            (save-object-resource resource)
            ;; just a normal resource
            (setf (resource-file link) (namestring pathname)
                  (resource-data link) nil)))))

  (defun save-project (&optional force)
    (let ((*already-serialized* (make-hash-table :test 'equal)))
      (let (index)
        (if (or (standard-project-p)
                (untitled-project-p))
            (message "Cannot save this project.")
            (labels ((save (name resource)
                       (unless (resource-system-p resource)
                         (push (save-resource name resource) index))))
              (message "Saving project ~S ..." *project*)
              ;; (maphash #'save *resources*)
              ;; FIXME: allow to save resources in separate file
              (save-resource-file (find-project-file *project* *object-index-filename*)
                                  (nreverse index))
              (save-database)
              (save-variables)
              (prog1 t (message "Saving project ~S ... Done." *project*)))))))

  (defparameter *export-formats* '(:archive :application))

Loading object data

  (defun load-object-resource (resource)
    "Loads a serialized :OBJECT resource from the Lisp data in the 
  :DATA field of the RESOURCE argument. Returns the rebuilt object. See
  also the documentation for DESERIALIZE."
    (let ((object (deserialize (resource-data resource))))
      (assert (object-p object))
      (setf (resource-data resource) nil) ;; no longer needed
      object))

  (defun load-buffer (name)
    (load-object-resource
     (first 
      (load-resource-file
       (concatenate 'string name *resource-file-extension*)))))

Loading images and textures

  (defun set-blending-mode (mode)
    (ecase mode 
      (:additive (gl:blend-func :src-alpha :one))
      (:source (gl:blend-func :src-color :zero))
      (:multiply (gl:blend-func :dst-color :one-minus-src-alpha))
      (:alpha2 (gl:blend-func :one :one-minus-src-alpha))
      (:mask (gl:blend-func :one :zero))
      (:additive2 (gl:blend-func :one :one))
      (:alpha (gl:blend-func :src-alpha :one-minus-src-alpha))))

  (defvar *default-texture-filter* :mipmap
  "Filter used for drawing rendered outline fonts.
  Valid values are :mipmap (the default), :linear, and :nearest.")

  (defvar *font-texture-filter* :linear
  "Filter used for drawing rendered outline fonts.
  Valid values are :linear (the default), :mipmap, and :nearest.")

  (defun use-filter (filter)
    ;; set filtering parameters
    (case filter
      (:linear (gl:tex-parameter :texture-2d :texture-min-filter :linear)
       (gl:tex-parameter :texture-2d :texture-mag-filter :linear))
      (:mipmap 
       (gl:tex-parameter :texture-2d :texture-min-filter :linear-mipmap-linear)
       (gl:tex-parameter :texture-2d :texture-mag-filter :linear)
       (gl:tex-parameter :texture-2d :generate-mipmap t))
      (:nearest (gl:tex-parameter :texture-2d :texture-min-filter :nearest)
       (gl:tex-parameter :texture-2d :texture-mag-filter :nearest))))

  (defun load-texture 
      (surface &key source-format 
                    (internal-format :rgba)
                    (wrap-r :clamp-to-edge)
                    (wrap-s :clamp-to-edge)
                    (filter *default-texture-filter*))
    ;; don't make any bogus textures
    (when *gl-window-open-p*
      (let ((texture (car (gl:gen-textures 1))))
        (gl:bind-texture :texture-2d texture)
        ;; set up filtering
        (use-filter filter)
        ;; set wrapping parameters
        (gl:tex-parameter :texture-2d :texture-wrap-t wrap-r)
        (gl:tex-parameter :texture-2d :texture-wrap-s wrap-s)
        ;; convert image data from SDL surface to GL texture
        (sdl-base::with-pixel (pix (sdl:fp surface))
          (let ((texture-format (ecase (sdl-base::pixel-bpp pix)
                                  (1 :luminance)
                                  (2 :luminance-alpha)
                                  (3 :rgb)
                                  (4 :rgba))))
            (assert (and (= (sdl-base::pixel-pitch pix)
                            (* (sdl:width surface) (sdl-base::pixel-bpp pix)))
                         (zerop (rem (sdl-base::pixel-pitch pix) 4))))
            (gl:tex-image-2d :texture-2d 0 internal-format
                             (sdl:width surface) (sdl:height surface)
                             0 (or source-format texture-format)
                             :unsigned-byte (sdl-base::pixel-data pix))))
        ;; ;; possibly generate mipmaps
        ;; (when (eq :mipmap filter)
        ;;      (gl:generate-mipmap :texture-2d))
        texture)))

  (defvar *textures* nil)

  (defun initialize-textures-maybe (&optional force)
    (when (or force (null *textures*))
      (setf *textures* (make-hash-table :test 'equal))))

  (defun delete-all-textures ()
    (when *textures*
      (maphash #'(lambda (name texture)
                   (let ((resource (find-resource name :noerror)))
                     (when resource
                       (setf (resource-object resource) nil)
                       (gl:delete-textures (list texture)))))
               *textures*)
      (initialize-textures-maybe :force)))

  (defun cache-image-texture (name)
    (initialize-textures-maybe)
    (let* ((resource (find-resource name))
           (properties (resource-properties resource))
           (surface (resource-object resource))
           (filter (getf properties :filter *default-texture-filter*))
           (wrap-r (getf properties :wrap-r :clamp-to-edge))
           (wrap-s (getf properties :wrap-s :clamp-to-edge))
           (source-format (getf (resource-properties resource) :format))
           (internal-format :rgba)
           (texture (load-texture surface
                                  :filter filter
                                  :wrap-r wrap-r :wrap-s wrap-s
                                  :source-format source-format
                                  :internal-format internal-format))
           (old-texture (gethash name *textures*)))
      (when texture
        (prog1 texture
          ;; delete old texture if needed
          (when old-texture
            (gl:delete-textures (list old-texture))
            (remhash name *textures*))))))

  (defun find-texture (name)
    (assert (stringp name))
    (initialize-textures-maybe)
    ;; make sure underlying image is loaded by SDL
    (find-resource name) 
    ;; see if we need to pump it to the video card
    (or (gethash name *textures*)
        ;; store the new texture and return it
        (setf (gethash name *textures*) 
              (cache-image-texture name))))
  
  (defun load-image-resource (resource)
    "Loads an :IMAGE-type XELF resource from a :FILE on disk."
    (initialize-textures-maybe)
    (let ((surface
           (if (null (resource-file resource))
               ;; software-rendered image resource. use the existing surface,
               ;; and skip loading from file
               (resource-object resource)
               ;; image to be loaded from file. load it
               (sdl-image:load-image (find-native-namestring (resource-file resource))
                                 :alpha 255))))
      (prog1 surface
        (when surface
          ;; cache height and width as properties
          (setf (resource-properties resource)
                (append (list :height (sdl:height surface)
                              :width (sdl:width surface))
                        (resource-properties resource)))))))

SDL Sprite sheet support   obsolete

The new sprite sheet system isn't documented or checked into Xelf yet. What that happens, this section will be replaced with the new code.

  (defun load-sprite-sheet-resource (resource)
    "Loads a :SPRITE-SHEET-type XELF resource from a :FILE on disk. Looks
  for :SPRITE-WIDTH and :SPRITE-HEIGHT properties on the resource to
  control the size of the individual frames or subimages."
    (let* ((image (load-image-resource resource))
           (props (resource-properties resource))
           (w (or (getf props :width)
                  (image-width image)))
           (h (or (getf props :height)
                  (image-height image)))
           (sw (getf props :sprite-width))
           (sh (getf props :sprite-height))
           (sprite-cells (loop for y from 0 to (- h sh) by sh
                               append (loop for x from 0 to (- w sw) by sw
                                            collect (list x y sw sh)))))
      (setf (sdl:cells image) sprite-cells)
      (setf (getf props :sprite-cells) sprite-cells)
      image))

Loading and saving object databases

  (defun load-database-resource (resource)
    (let ((database (deserialize (resource-data resource))))
      (assert (hash-table-p database))
      (message "Merging ~S objects from database..." (hash-table-count database))
      (prog1 nil
        (merge-hashes *database* database))))

  (defun make-database-resource (&optional (database *database*))
    (let ((database2 (make-hash-table :test 'equal))
          (garbage 0)
          (saved 0))
      (message "Serializing database...")
      (labels ((store (uuid object)
                 (setf (gethash uuid database2) object)
                 (incf saved)))
        (maphash #'store database) ;; copy into database2
        (message "Saving ~S objects..." saved garbage)
        (values (make-instance 'resource :name "--database--"
                               :type :database
                               :data (serialize database2))
                (hash-table-count database2)))))

  (defun empty-garbage (&optional (database *database*))
    (loop for object being the hash-keys of database do
      (when (garbagep object)
        (remhash object database))))

  (defun database-file ()
    (assert (not (null *project*)))
    (find-project-file *project* "database.xelf"))

  (defun save-database (&optional (database *database*))
    (assert (hash-table-p database))
    (let ((file (database-file)))
      (message "Scanning ~S objects in database..." 
               (hash-table-count database))
      (multiple-value-bind (resource count)
          (make-database-resource database)
        (message "Saving ~S objects from database into ~A..." 
                 count
                 (find-native-namestring file))
        (save-resource-file file (list resource))
        (message "Finished saving database into ~A. Continuing..." file))))
      
  (defun load-database (&optional (file (database-file)))
    (message "Looking for object database ~A..." file)
    (if (cl-fad:file-exists-p file)
        (let ((resources (load-resource-file file)))
          (message "Read ~S resources from ~A" (length resources) file)
          (let ((database (first resources)))
            (assert (eq :database (resource-type database)))
            (load-database-resource database)))
        (message "No database file found. Continuing...")))

Resource file loaders

  (defun load-text-resource (resource)
    (with-open-file (file (resource-file resource)
                          :direction :input
                          :if-does-not-exist nil)
      (loop for line = (read-line file nil)
            while line collect line)))

  (defun load-formatted-text-resource (resource)
    (read-sexp-from-file (resource-file resource)))
    
  (defun load-lisp-resource (resource)
    (let* ((source (resource-file resource))
           (fasl (compile-file-pathname source)))
      ;; do we need recompilation?
      (if (cl-fad:file-exists-p fasl)
          (if (> (file-write-date source)
                 (file-write-date fasl))
              ;; recompile. 
              (load (compile-file source))
              ;; no, just load the fasl
              (load fasl))
          ;; create the fasl for the first time. 
          (load (compile-file source)))))

  (defun load-canvas-resource (resource)
    (destructuring-bind (&key width height background)
        (resource-properties resource)
      (let ((canvas (create-image width height)))
        (prog1 canvas
          (when background
            (draw-box 0 0 width height))))))
                      ;; TODO support arbitrary rgb and other drawing commands
                      ;; :stroke-color background
                      ;; :color background
                      ;; :destination canvas))))))

  (defun load-color-resource (resource)
    (destructuring-bind (red green blue)
        (resource-data resource)
      (sdl:color :r red :g green :b blue)))

  (defun load-font-resource (resource)
    (let ((font-name (string-upcase (concatenate 'string 
                                                 "*font-" 
                                                 (resource-data resource)
                                                 "*"))))
      (sdl:initialise-font (symbol-value (intern font-name :lispbuilder-sdl)))))

  (defun load-ttf-resource (resource)
    (let* ((size (getf (resource-properties resource) :size))
           (definition (make-instance 'sdl:ttf-font-definition
                                      :filename (find-native-namestring (resource-file resource))
                                      :size (* *font-texture-scale* size))))
      (sdl:initialise-font definition)))

  (defun load-music-resource (resource)
    (when *use-sound*
      (sdl-mixer:load-music (find-native-namestring (resource-file resource)))))

  (defun load-sample-resource (resource)
    (when *use-sound*
      (let ((chunk (sdl-mixer:load-sample (find-native-namestring (resource-file resource)))))
        (prog1 chunk
          (when (resource-properties resource)
            (destructuring-bind (&key volume) (resource-properties resource)
              (when (numberp volume)
                (setf (sdl-mixer:sample-volume chunk) volume))))))))

  (defparameter *resource-handlers* 
    (list :image #'load-image-resource
          ;; :variable #'load-variable-resource
          :lisp #'load-lisp-resource
          :buffer #'load-object-resource
          :object #'load-object-resource
          :database #'load-database-resource
          :sprite-sheet #'load-sprite-sheet-resource
          :color #'load-color-resource
          :music #'load-music-resource
          ;; :bitmap-font #'load-bitmap-font-resource
          :text #'load-text-resource
          :formatted-text #'load-formatted-text-resource
          :sample #'load-sample-resource
          :canvas #'load-canvas-resource
          :ttf #'load-ttf-resource
          :font #'load-font-resource)
    "A property list mapping resource type keywords to handler functions.
  Each function should accept one resource record, and return an
  object (possibly driver-dependent). When a resource is loaded (with
  `load-resource'), the appropriate handler is looked up, and invoked on
  the resource record.  The return value is stored in the OBJECT field
  of the record.")

  (defparameter *preloaded-resource-types* '(:image :sample))
  (defparameter *file-resource-types* '(:ttf :image :sample :music))

Saving and loading variable values

  (defvar *system-variables* '(*recent-projects* *joystick-profile*
  *user-joystick-profile* *joystick-axis-size* *joystick-dead-zone*))

  (defvar *safe-variables* '(*frame-rate* *updates* *screen-width*
  *screen-height* *buffer* *blocks* *pointer-x* *author* *project*
  *joystick-profile* *user-joystick-profile* *joystick-axis-size* 
  *joystick-dead-zone* *pointer-y* *resizable* *window-title* *buffers*
  *scale-output-to-window* *persistent-variables*))

  (defvar *persistent-variables* '(*frame-rate* *updates* 
                                 
                                   ;; *screen-width* *screen-height*
                                   *buffer* *blocks* *pointer-x* *author* 
                                   *project* *buffers* *scale-output-to-window* 
                                   *pointer-y* *resizable*
                                   *window-title*
                                   ;; notice that THIS variable is also
                                   ;; persistent!  this is to avoid
                                   ;; unwanted behavior changes in
                                   ;; modules when the default value
                                   ;; changes.
                                   *persistent-variables*))

  (defparameter *persistent-variables-file-name* "variables.xelf")

  (defun persistent-variables-file (&optional (project *project*))
    (find-project-file project *persistent-variables-file-name*))

  (defun make-variable-resource (name &optional nodup)
    (assert (and (symbolp name)
                 (boundp name)))
    (assert (member name *safe-variables*))
    (assert (not (eq name '*safe-variables*)))
    (make-instance 'resource :name name
                   :type :variable
                   :data (serialize (symbol-value name))))

  (defun load-variable-resource (resource)
    (assert (eq :variable (resource-type resource)))
    (let ((name (resource-name resource)))
      (assert (member name *safe-variables*))
      (message "Setting variable: ~S..." name)
      (setf (symbol-value name)
            (deserialize (resource-data resource)))
      (setf (resource-data resource) nil)))

  (defun save-variables (&optional (variables *persistent-variables*))
    (with-standard-io-syntax
      (message "Saving system variables ~A..." variables)
      (save-resource-file (persistent-variables-file)
                 (mapcar #'make-variable-resource variables))
      (message "Finished saving system variables.")))

  (defun load-variables ()
    (with-standard-io-syntax
      (let ((file (persistent-variables-file)))
        (if (cl-fad:file-exists-p file)
            (progn 
              (message "Loading system variables from ~A..." file)
              (mapc #'load-variable-resource 
                    (load-resource-file file))
              (message "Finished loading system variables."))
            (message "No system variables file found in this project. Continuing...")))))

Resource transformations   obsolete

  (defvar *resource-transformation-delimiter* #\:)

  (defun transformable-resource-p (name)
    (eq (aref name 0)
        *resource-transformation-delimiter*))

  (defun next-transformation (name)
    (assert (transformable-resource-p name))
    (let ((delimiter-pos (position *resource-transformation-delimiter* 
                                   (subseq name 1))))
      (when delimiter-pos 
        (let* ((*read-eval* nil)
               (xform-command (subseq name 1 (1+ delimiter-pos))))
          (read-from-string (concatenate 'string 
                                         "(" 
                                         xform-command
                                         ")"))))))

  (defun next-source (name)
    (assert (transformable-resource-p name))
    (let ((delimiter-pos (position *resource-transformation-delimiter*
                                   (subseq name 1))))
      (if (numberp delimiter-pos)
          (subseq name (1+ delimiter-pos))
          (subseq name 1))))

  (defun rotate-image (resource degrees)
    (sdl:rotate-surface degrees :surface (resource-object resource)))

  (defun subsect-image (resource x y w h)
  (let ((image (sdl:copy-surface :cells (sdl:rectangle :x x :y y :w w :h h)
                                 :surface (resource-object resource) :inherit t)))
    (sdl:set-surface-* image :x 0 :y 0)
    image))

  (defun scale-image (image &optional (factor 1)) nil)
  ;;   "Return a scaled version of IMAGE, scaled by FACTOR.
  ;; Allocates a new image."
  ;;   (assert (integerp factor))
  ;;   (lispbuilder-sdl-gfx:zoom-surface factor factor
  ;;                                :surface (resource-object image)
  ;;                                :smooth nil))

  (defvar *resource-transformations* 
    (list :rotate #'rotate-image
          :subimage #'subsect-image
          :scale #'scale-image))

Top-level resource operations

  (defun find-resource-pathname (resource &optional force)
    (when (or force (not (pathnamep (resource-file resource))))
      (when (member (resource-type resource) *file-resource-types*)
        (setf (resource-file resource)
              (make-pathname 
               :name (find-native-namestring 
                      (or (resource-file resource)
                          (resource-name resource)))
               :defaults (find-project-path *project*)
               :version nil)))))

  (defun load-resource (resource)
    "Load the driver-dependent object of RESOURCE into the OBJECT field
  so that it can be fed to the console."
    (let ((handler (getf *resource-handlers* (resource-type resource))))
      (assert (functionp handler))
      ;; fill in the object field by invoking the handler, if needed
      (when (or (null (resource-object resource))
                ;; for software-rendered image resource
                (and (resource-object resource)
                     (null (resource-file resource))))
        (setf (resource-object resource)
              (funcall handler resource))
        (assert (resource-object resource)))
      (when (null (resource-object resource))
        (error "Failed to load resource ~S." (resource-name resource)))))
           
  (defun find-resource (name &optional noerror)
    "Obtain the resource named NAME, performing any necessary
  loading. Unless NOERROR is non-nil, signal an error when NAME cannot
  be found."
    ;; can we find the resource straight off? 
    (when *resources*
      (let ((res (gethash name *resources*)))
        (if (resource-p res)
            ;; yes, return it and possibly load on demand
            (prog1 res
              (when (null (resource-object res))
                (load-resource res)))
            (if noerror
                nil
                (error "Cannot find resource ~S" name))))))

  (defun find-resource-object (name &optional noerror)
    "Obtain the resource object named NAME, or signal an error if not
  found."
    (let ((val (find-resource name noerror)))
      (if (resource-p val)
          (resource-object val)
          (if noerror nil (error "Resource ~S not found." name)))))

  (defun find-resource-property (resource-name property)
    "Read the value of PROPERTY from the resource RESOURCE-NAME."
    (getf (resource-properties (find-resource resource-name))
          property))

  (defun set-resource-system-p (resource &optional (value t))
    (let ((res (find-resource resource)))
      (setf (resource-system-p res) value)))

  (defun delete-all-resources ()
    (loop for resource being the hash-values in *resources*
          do (let ((object (resource-object resource)))
               (when object
                 (case (resource-type resource)
                   (:image (sdl:free object))
                   (:music (sdl-mixer:free object))
                   (:sample (sdl-mixer:free object)))))
             (initialize-resource-table)))

Clearing all cached images

  (defun clear-cached-images ()
    "Clear all cached images and textures."
    (when *resources*
      (loop for resource being the hash-values in *resources*
         do (let ((object (resource-object resource)))
              (when (and object 
                         (eq :image (resource-type resource)))
                (sdl:free object)
                (setf (resource-object resource) nil))))
      (delete-all-textures)))

  (defvar *clear-cached-images-on-resize* t
    "When non-nil, clear caches when window is resized.")

  (defvar *clear-cached-images-on-buffer-switch* t
    "When non-nil, clear caches when switching buffers.")

Clearing cached TrueType bitmaps

  (defun clear-cached-text-images ()
    "Clear the text rendering cache. You may wish to do this
  periodically when *CLEAR-CACHED-FONTS-ON-BUFFER-SWITCH* is set to nil.
  Otherwise it happens automatically upon SWITCH-TO-BUFFER."
    (maphash #'(lambda (key value)
                 (declare (ignore key))
                 (gl:delete-textures (list value)))
             (get-memo-table 'find-text-image))
    (clear-memoize 'find-text-image)
    (maphash #'(lambda (key value)
                 (declare (ignore key))
                 (sdl:free value))
             (get-memo-table 'make-text-surface))
    (clear-memoize 'make-text-surface))

Clearing cached font metrics

  (defun clear-cached-font-metrics ()
    (clear-memoize 'font-height-*)
    (clear-memoize 'font-text-width-*))

Clearing all font caches

  (defun clear-cached-fonts ()
    (clear-cached-font-metrics)
    (clear-cached-text-images))

Clearing all caches

  (defun clear-all-caches ()
    (clear-cached-images)
    (clear-cached-fonts)
    (clear-memoize 'pretty-string)
    (clear-memoize 'ugly-symbol)
    (clear-memoize 'make-keyword)
    (clear-memoize 'keyboard-id)
    (clear-memoize 'keyboard-mod)
    (clear-memoize 'gl-color-values-from-string)
    (clear-memoize 'sdl-color-values-from-string)
    (clear-memoize 'percent-gray)
    (clear-memoize 'modeline-position-string)
    (clear-memoize 'modeline-database-string))

Playing sound and music

  (defvar *frequency* 44100 "Sample rate of output.")

  (defvar *output-chunksize* 2048 "Buffer size. Affects latency.")

  (defvar *output-channels* 2 "Choose mono or stereo output.")

  (defvar *sample-format* SDL-CFFI::AUDIO-S16LSB)

  (defvar *channels* 256 "Number of audio mixer channels to use.")

  (defun set-music-volume (number)
    "Set the mixer music volume between 0 (silent) and 127 (full volume)."
    (when *use-sound*
      (setf (sdl-mixer:music-volume) number)))

  (defun play-music (music-name &rest args)
    "Begin playing the music resource MUSIC-NAME. If the resource
  MUSIC-NAME has the property :volume, its value is used as the volume
  of the music. This should be an integer between 0 and 127."
    (when *use-sound*
      (let ((resource (find-resource music-name))
            (volume (find-resource-property music-name :volume)))
        (assert (eq :music (resource-type resource)))
        (set-music-volume (or volume 255))
        (apply #'sdl-mixer:play-music 
               (resource-object resource)
               args))))

  (defun seek-music (position)
    (sdl-mixer:music-position position))

  (defun halt-music (&optional (fade-milliseconds 0))
    "Stop all music playing, optionally taking FADE-MILLISECONDS to fade out."
    (when *use-sound*
      (sdl-mixer:halt-music fade-milliseconds)))

  (defun play-sample (sample-name &rest args)
    "When sound is enabled, play the sample resource SAMPLE-NAME.
  If successful, returns the integer CHANNEL number playing the sound."
    (when *use-sound*
      (let ((resource (find-resource sample-name)))
      ;;(load-resource resource)
        (assert (eq :sample (resource-type resource)))
        (assert (not (null (resource-object resource))))
        (apply #'sdl-mixer:play-sample 
               (resource-object resource)
               args))))

  (defun halt-sample (channel &rest args)
    "Stop playing the sample on channel CHANNEL."
    (when *use-sound*
      (apply #'sdl-mixer:halt-sample :channel channel args)))

  (defun set-sample-volume (sample volume)
    "Set the default VOLUME (0-127) of the SAMPLE."
    (when *use-sound*
      (load-sample-resource (find-resource sample))
      (let ((chunk (find-resource-object sample)))
        (setf (sdl-mixer:sample-volume chunk) volume))))

  (defun initialize-sound ()
    ;; try opening sound
    (when (null (sdl-mixer:open-audio :frequency *frequency*
                                      :chunksize *output-chunksize*
                                      ;; :enable-callbacks t
                                      :format *sample-format*
                                      :channels *output-channels*))
      ;; if that didn't work, disable effects/music
      (message "Could not open audio driver. Disabling sound effects and music.")
      (setf *use-sound* nil))
    ;; set to mix lots of sounds
    (sdl-mixer:allocate-channels *channels*))

Named colors

  ;; The X11 standard colors are loaded by default into the resource
  ;; table from the raw data in `*x11-color-data*'. See also rgb.lisp.

  (defvar *vertex-color-p* t)

  (defun vertex-color-p ()
    (not (null *vertex-color-p*)))

  (defun-memo gl-color-values-from-string (color-name)
      (:key #'first :test 'equal)
    (let ((color (find-resource color-name)))
      (assert (eq :color (resource-type color)))
      (mapcar #'(lambda (integer)
                  (/ integer 255.0))
              (resource-data color))))

  (defun-memo sdl-color-values-from-string (color-name)
      (:key #'first :test 'equal)
    (let ((color (find-resource color-name)))
      (assert (eq :color (resource-type color)))
      (resource-data color)))

  (defun set-vertex-color (color &optional (alpha 1))
    (apply #'gl:color
           (append
            (if (stringp color)
                (gl-color-values-from-string color)
                (mapcar #'(lambda (integer)
                            (/ integer 255.0))
                        color))
            (list alpha))))

  (defun initialize-colors ()
     "Load the X11 color data into the resource table."
     (dolist (color *x11-color-data*)
       (destructuring-bind (name red green blue) color
         (index-resource (make-instance 'resource :name name
                                       :type :color
                                       :data (list red green blue)))
         (find-resource-object name))))
          ;; (prog1 result
          ;;   (when (emulated-vertex-color-p)
          ;;     (index-resource (make-instance 'resource
          ;;                 :name (swatch-name name)
          ;;                 :type :image
          ;;                 :object (find-swatch name red green blue)))))))))
                 
  (defun-memo percent-gray (percentage)
      (:key #'first :test 'equal :validator #'identity)
    (format nil "gray~S" (truncate (abs percentage))))

  (defun percent-grey (percentage)
    (percent-gray percentage))

Emulated vertex color   android

This is for OpenGL ES 2 on Android, and not currently documented.

  (defun emulated-vertex-color-p ()
    (eq :emulated-vertex-color *vertex-color-p*))

  ;; (defvar *color-swatches* (make-hash-table :test 'equal))

  ;; (defun make-swatch (values &optional (w 32) (h 32))
  ;;   (destructuring-bind (r g b) values
  ;;     (let ((surface (sdl:create-surface w h :alpha 100)))
  ;;       (sdl-gfx:draw-box-* 0 0 w h
  ;;                      :surface surface
  ;;                      :alpha 255
  ;;                      :color (sdl:color :r r :g g :b b :a 255))
  ;;       surface)))

  ;; (defun find-swatch (name &rest values)
  ;;   (setf (gethash name *color-swatches*)
  ;;    (make-swatch values)))

  ;; (defun-memo swatch-name (color)
  ;;     (:key #'first :test 'equal :validator #'identity)
  ;;   (concatenate 'string "_" color))

  ;; (defun-memo colorized-image-name (image color)
  ;;     (:key #'identity :test 'equal :validator #'identity)
  ;;   (concatenate 'string image "_" color))

  ;; (defun colorize-image (image color &optional surface)
  ;;   (let* ((h (if image (image-height image) (sdl:height surface)))
  ;;     (w (if image (image-width image) (sdl:width surface)))
  ;;     (image-surface (or (when surface
  ;;                          (sdl:copy-surface :surface surface :pixel-alpha 255))
  ;;                        (find-resource-object image)))
  ;;     (new-surface (sdl:create-surface w h :pixel-alpha 255)))
  ;;     (destructuring-bind (r g b) (sdl-color-values-from-string color)
  ;;       (dotimes (i w)
  ;;    (dotimes (j h)
  ;;      (let ((color (sdl:read-pixel-* i j :surface image-surface)))
  ;;        (when (> (sdl:a color) 2)
  ;;          (setf (sdl:r color) r
  ;;                (sdl:g color) g
  ;;                (sdl:b color) b))
  ;;        (sdl:draw-pixel-* i j :surface new-surface :color color)))))
  ;;     new-surface))
  ;;     ;; (prog1 new-surface
  ;;     ;;   (sdl:free color-surface)))) 

  ;; (defun find-colorized-texture (image color)
  ;;   (let ((name (colorized-image-name image color)))
  ;;     (if (find-resource name :no-error)
  ;;    (find-texture name)
  ;;    (let ((resource
  ;;           (make-instance 'resource :name name
  ;;                          :type :image
  ;;                          :object (colorize-image (or image "_box.png") color))))
  ;;      (index-resource resource)
  ;;      (find-texture name)))))

  ;; (defun index-emulated-vertex-colors ()
  ;;   (dolist (color (mapcar #'first *x11-color-data*))
  ;;     (let ((_color.png (concatenate 'string "_" color ".png")))
  ;;       (index-resource (make-instance 'resource :name _color.png :file _color.png :type :image)))))

  ;; (defun find-emulated-vertex-color (color)
  ;;   (let ((swatch-name (swatch-name color)))
  ;;     (find-resource swatch-name)
  ;;     swatch-name))

Image objects

  (defun create-image (width height)
    "Create a new XELF image of size (* WIDTH HEIGHT)."
    (assert (and (integerp width) (integerp height)))
    (sdl:create-surface width height))

  (defun image-height (image)
    "Return the height in pixels of IMAGE."
    (find-resource-property image :height))

  (defun image-width (image)
    "Return the width in pixels of IMAGE."
    (find-resource-property image :width))

Drawing images   linux mac windows

   #+(or linux darwin win32
        (and win32 64-bit) ;; sbcl
        (and windows-target 64-bit-target)) ;; ccl

   (defun draw-textured-rectangle (x y z width height texture 
                                  &key (blend :alpha) (opacity 1.0) (vertex-color "white"))
     "Draw an OpenGL textured rectangle at X, Y, Z with width WIDTH and height HEIGHT.
   The argument TEXTURE is a string image name (or a texture returned by
   FIND-TEXTURE). BLEND sets the blending mode and can be one
   of :ALPHA, :ADDITIVE, :MULTIPLY."
     (if (null blend)
        (gl:disable :blend)
        (progn (enable-texture-blending)        
               (set-blending-mode blend)))
     (when (vertex-color-p)
       (if (emulated-vertex-color-p)
          (when (stringp texture)
            (setf texture (find-colorized-texture texture vertex-color)))
          (set-vertex-color (or vertex-color "white"))))
     (when (stringp texture)
       (setf texture (find-texture texture)))
     (gl:bind-texture :texture-2d texture)
     (gl:with-primitive :quads
       (let ((x2 (+ x width))
            (y2 (+ y height)))
        (gl:tex-coord 0 1)
        (gl:vertex x y2 (- 0 z)) 
        (gl:tex-coord 1 1)
        (gl:vertex x2 y2 (- 0 z)) 
        (gl:tex-coord 1 0)
        (gl:vertex x2 y (- 0 z)) 
        (gl:tex-coord 0 0)
        (gl:vertex x y (- 0 z)))))

   #+(or linux darwin win32 
        (and win32 64-bit) ;; sbcl
        (and windows-target 64-bit-target)) ;; ccl
   (defun draw-textured-rectangle-* (x y z width height texture 
                                    &key u1 v1 u2 v2
                                         (window-x (window-origin-x))
                                         (window-y (window-origin-y))
                                         angle
                                         (blend :alpha)
                                         (opacity 1.0) 
                                         (vertex-color "white"))
     "Draw an OpenGL textured rectangle at X, Y, Z with width WIDTH and height HEIGHT.
   The argument TEXTURE is a string image name (or a texture returned by
   FIND-TEXTURE). BLEND sets the blending mode and can be one
   of :ALPHA, :ADDITIVE, :MULTIPLY. OPACITY is 1.0 for opaque, 0.0 for transparent."
     (if (null blend)
        (gl:disable :blend)
        (progn (enable-texture-blending)        
               (set-blending-mode blend)))
     (when (vertex-color-p)
       (if (emulated-vertex-color-p)
          (setf texture (find-colorized-texture texture vertex-color))
          (set-vertex-color (or vertex-color "white"))))
     (when (stringp texture)
       (setf texture (find-texture texture)))
     (gl:bind-texture :texture-2d texture)
     ;; rotate around center
     (let ((cx (- (+ x (/ width 2)) window-x))
          (cy (- (+ y (/ height 2)) window-y))
          (hh (/ height 2))
          (hw (/ width 2)))
       (gl:matrix-mode :modelview)
       (gl:with-pushed-matrix 
        (gl:load-identity)
        (gl:translate cx cy 0)
        (when angle (gl:rotate angle 0 0 1))
        (gl:with-primitive :quads
          (let* ((x1 (- hw))
                 (x2 (+ hw))
                 (y1 (- hh))
                 (y2 (+ hh))
                 (u1* (or u1 x1))
                 (v1* (or v1 y1))
                 (u2* (or u2 x2))
                 (v2* (or v2 y2)))
            (gl:tex-coord 0 1)
            (gl:vertex u1* v2* (- 0 z)) 
            (gl:tex-coord 1 1)
            (gl:vertex u2* v2* (- 0 z)) 
            (gl:tex-coord 1 0)
            (gl:vertex u2* v1* (- 0 z)) 
            (gl:tex-coord 0 0)
            (gl:vertex u1* v1* (- 0 z))))
        (gl:translate (- cx) (- cy) 0))))

Drawing images   android

  #+android
  (defun ensure-arrays ()
    (when (null *vertex-array*)
      (initialize-vertex-arrays)
      (gl:enable-client-state :vertex-array)
      (gl:enable-client-state :texture-coord-array)
      (%gl:vertex-pointer 2 :float 16 (cffi:inc-pointer *vertex-array* 8))
      (%gl:tex-coord-pointer 2 :float 16 *vertex-array*)))

  #+android
  (defun draw-textured-rectangle (x y z width height texture 
                                  &key (blend :alpha) (opacity 1.0) (vertex-color "white"))
    (ensure-arrays)
    (if (null blend)
        (gl:disable :blend)
        (progn (enable-texture-blending)        
               (set-blending-mode blend)))
    (when (vertex-color-p)
      (if (emulated-vertex-color-p)
          (setf texture (find-colorized-texture image vertex-color))
          (set-vertex-color (or vertex-color "white"))))
    (gl:bind-texture :texture-2d texture)
    (update-vertex-arrays x y width height)
    (gl:draw-arrays :triangle-fan 0 4))

  #+android
  (defun draw-textured-rectangle-*
      (x y z width height texture 
       &key u1 v1 u2 v2
            (window-x 0)
            (window-y 0)
            ;; (window-x (window-origin-x))
            ;; (window-y (window-origin-y))
            angle
            (blend :alpha)
            (opacity 1.0) 
            (vertex-color "white"))
    (ensure-arrays)
    (if (null blend)
        (gl:disable :blend)
        (progn (enable-texture-blending)        
               (set-blending-mode blend)))
    (gl:bind-texture :texture-2d texture)
    (when (vertex-color-p)
      (if (emulated-vertex-color-p)
          (setf texture (find-colorized-texture image vertex-color))
          (set-vertex-color (or vertex-color "white"))))
    ;; rotate around center
    (let ((cx (- (+ x (/ width 2)) window-x))
          (cy (- (+ y (/ height 2)) window-y))
          (hh (/ height 2))
          (hw (/ width 2)))
      (gl:matrix-mode :modelview)
      (gl:with-pushed-matrix 
        (gl:load-identity)
        (%gl:translate-f cx cy 0)
        (when angle (%gl:rotate-f angle 0 0 1))
        (let* ((x1 (cfloat (- hw)))
               (x2 (cfloat (+ hw)))
               (y1 (cfloat (- hh)))
               (y2 (cfloat (+ hh)))
               (u1* (cfloat (or u1 x1)))
               (v1* (cfloat (or v1 y1)))
               (u2* (cfloat (or u2 x2)))
               (v2* (cfloat (or v2 y2))))
          ;;
          (setf (cffi:mem-aref *vertex-array* :float 2) u1*)
          (setf (cffi:mem-aref *vertex-array* :float 3) v2*)
          ;;
          (setf (cffi:mem-aref *vertex-array* :float 6) u2*)
          (setf (cffi:mem-aref *vertex-array* :float 7) v2*)
          ;;
          (setf (cffi:mem-aref *vertex-array* :float 10) u2*)
          (setf (cffi:mem-aref *vertex-array* :float 11) v1*)
          ;;
          (setf (cffi:mem-aref *vertex-array* :float 14) u1*)
          (setf (cffi:mem-aref *vertex-array* :float 15) v1*))
        (%gl:translate-f (- cx) (- cy) 0)
        (gl:draw-arrays :triangle-fan 0 4))))

User-level image drawing function

  (defvar *image-opacity* nil)

  (defun draw-image (name x y &key (z 0.0) (blend :alpha) (opacity 1.0) height width)
    "Draw the image named NAME at x,y,z, sized HEIGHT, WIDTH, with blending mode BLEND."
    (let ((image (find-resource-object name)))
      (draw-textured-rectangle
       x y z 
       (cfloat (or width (sdl:width image)))
       (cfloat (or height (sdl:height image)))
       (find-texture name)
       :blend blend 
       :opacity (or *image-opacity* opacity))))

TrueType fonts

  (defparameter *font-texture-scale* 1
  "Scaling factor for rendering of outline fonts.
  Use this when your game window might be enlarged to the point of
  blurring font textures that are too small.")

  (defun-memo font-height-* (font)
      ;; don't cache null results, because these can happen if
      ;; font-height is called before SDL initialization
      (:key #'first :test 'equal :validator #'identity)
    (let ((resource (find-resource font)))
      (ecase (resource-type resource)
        (:font (find-resource-property font :height))
        (:ttf (sdl:get-font-height :font (resource-object resource))))))

  (defun font-height (font)
    "Height of a line of text in font FONT."
    (* (/ 1 *font-texture-scale*)
       (font-height-* font)))
  
  (defun font-width (font)
    "Character with of a bitmap font FONT.
  Signals an error when called on an outline font."
    (* (/ 1 *font-texture-scale*)
       (let ((resource (find-resource font)))
         (ecase (resource-type resource)
           (:font (find-resource-property font :width))
           (:ttf (error "Cannot get width of a TTF font."))))))

  (defun-memo font-text-width-* (string &optional (font *font*))
      (:key #'identity :test 'equal :validator #'identity)
    (sdl:get-font-size string :size :w :font (find-resource-object font)))

  (defun font-text-width (string &optional (font *font*))
    "Width of STRING when rendered in FONT."
    (* (/ 1 *font-texture-scale*)
       (font-text-width-* string font)))

  (defun font-text-extents-* (string font)
    (let ((resource (find-resource font)))  
      (ecase (resource-type resource)
        (:font (values (* (length string)
                          (font-width font))
                       (font-height-* font)))
        (:ttf (values (font-text-width-* string font)
                      (font-height-* font))))))

  (defun font-text-extents (string font)
    (multiple-value-bind (width height)
        (font-text-extents-* string font)
      (values (* width (/ 1 *font-texture-scale*))
              (* height (/ 1 *font-texture-scale*)))))

  (defparameter *use-antialiased-text* t 
  "When non-nil, render outline fonts with antialiasing.
  See also *FONT-TEXTURE-SCALE* and *FONT-TEXTURE-FILTER*.")

  (defun draw-utf8-solid (string x y &key font color surface)
    (let ((surf nil))
      (sdl::with-foreign-color-copy (col-struct color)
        (setf surf (make-instance 'sdl:surface :fp 
                                  (sdl-ttf-cffi::render-utf8-solid 
                                   (sdl:fp font) 
                                   string
                                   (if (cffi:foreign-symbol-pointer "TTF_glue_RenderText_Solid")
                                       col-struct
                                       (+ (ash (sdl:b color) 16)
                                          (ash (sdl:g color) 8)
                                          (sdl:r color)))))))
      (sdl:blit-surface surf surface)
      surface))

  (defun-memo make-text-surface (font string)
      (:key #'identity :test 'equal)
    (multiple-value-bind (width height)
        (font-text-extents-* string font)
      (let ((surface (sdl:create-surface width height :bpp 8))
            (renderer (if *use-antialiased-text*
                          #'sdl:draw-string-blended-*
                          #'sdl:draw-string-solid-*)))
        (funcall renderer string 0 0 
                 :color (find-resource-object "white")
                 :font (find-resource-object font)
                 :surface surface)
        surface)))

  (defun make-text-image (font string &optional other-surface)
    (assert (and (not (null string))
                 (plusp (length string))))
    (let ((texture (first (gl:gen-textures 1)))
          (surface (or other-surface (make-text-surface font string))))
      (gl:bind-texture :texture-2d texture)
      (use-filter *font-texture-filter*)
      (sdl-base::with-pixel (buffer (sdl:fp surface))
        (gl:tex-image-2d :texture-2d 0 :alpha
                         (sdl:width surface)
                         (sdl:height surface)
                         0
                         :alpha :unsigned-byte (sdl-base::pixel-data buffer)))
      texture)) 

  (defun-memo find-text-image (font string) 
    (:key #'identity :test 'equal)
    (make-text-image font string))

  (defun-memo find-colorized-text-image (font string color)
    (:key #'identity :test 'equal)
    (let ((surface (make-text-surface font string)))
      (load-texture (colorize-image nil color surface))))

  (defun draw-string (string x y &key (color *color*)
                                      (font *font*)
                                      (z 0))
    "Render the string STRING at x,y with color COLOR and font FONT."
    (let ((texture
           (if (emulated-vertex-color-p)
               (find-colorized-text-image font string color)
               (find-text-image font string))))
      (multiple-value-bind (width height) 
          (font-text-extents string font)
        (draw-textured-rectangle x y z width height texture :vertex-color color))))

Drawing primitive shapes

  (defun draw-line (x0 y0 x1 y1 &key
                       (color "white"))
    (gl:disable :texture-2d)
    (set-vertex-color color)
    (gl:with-primitive :lines 
      (gl:vertex x0 (+ y0))
      (gl:vertex x1 (+ y1))))

  (defun draw-box (x y width height             
                   &key (color "black") (alpha 1))
    (set-vertex-color color alpha)
    (gl:disable :texture-2d)
    (gl:with-primitive :quads
      (let ((x1 (+ x width))
            (y1 (+ y height)))
        (gl:vertex x y1)
        (gl:vertex x1 y1)
        (gl:vertex x1 y)
        (gl:vertex x y))))

  (defparameter *circle-textures* 
    '(:outline "circle-outline-flat-128"
      :solid "circle-flat-128"))

  (defparameter *circle-mask-textures* 
    '(:outline "circle-outline-flat-128-mask"
      :solid "circle-flat-128-mask"))

  (defun draw-circle (x y radius 
                      &key (color "white") 
                           (type :outline)
                           (blend :alpha)
                           (z 0))
    (let ((texture (find-texture (getf *circle-textures* type)))
          (left (- x radius))
          (top (- y radius))
          (side (* 2 radius)))
      (draw-textured-rectangle left top z side side texture :blend blend :vertex-color color)))

  (defun draw-solid-circle (x y radius &key color (blend :alpha))
    (declare (ignore blend))
    (draw-circle x y radius :color color :type :solid))

TODO SDL event loop adapter

This section needs to be cleaned up.

  (defun start-session ()
    "Initialize the console, open a window, and play.
  We want to process all inputs, update the game state, then update the
  display."
    (handler-bind ((warning #'quiet-warning-handler))
      (let ((fps (make-instance 'sdl:fps-fixed 
                                :target-frame-rate *frame-rate*)))
        (message "Creating OpenGL window...")
        ;; cl-opengl needs platform specific support to be able to load GL
        ;; extensions, so we need to tell it how to do so in lispbuilder-sdl
        (setf cl-opengl-bindings:*gl-get-proc-address* #'sdl-cffi::sdl-gl-get-proc-address)
        (cond (*fullscreen*
               (sdl:window *screen-width* *screen-height*
                         :fps fps 
                         :title-caption *window-title*
                         :flags (logior sdl:SDL-FULLSCREEN sdl:SDL-OPENGL)
                         :position *window-position*))
              (*resizable*
               (sdl:window *screen-width* *screen-height*
                           :fps fps 
                           :title-caption *window-title*
                         :flags (logior sdl:SDL-RESIZABLE sdl:SDL-OPENGL)
                           :position *window-position*))
              (t (sdl:window *screen-width* *screen-height*
                             :fps fps
                             :flags sdl:SDL-OPENGL
                             :title-caption *window-title*
                             :position *window-position*)))
        ;; #+android
        ;; (progn 
        ;;      (sdl:set-gl-attribute #x9126 #x4) ;; request GLES context
        ;;      (sdl:window *screen-width* *screen-height*
        ;;                  :fps fps
        ;;                  :flags (logior sdl:SDL-RESIZABLE sdl:SDL-OPENGL)
        ;;                  :title-caption *window-title*
        ;;                  :position *window-position*))
        ;; get rid of any bogus textures
        (when *textures* (delete-all-textures))
        ;; move along
        (message "Creating OpenGL window... Done.")
        (setf *gl-window-open-p* t)
        (message "SDL driver name: ~A" (sdl:video-driver-name))
        (set-frame-rate *frame-rate*)
        (reset-joystick)
        (scan-for-joysticks)
        (open-viewport)
        (project-orthographically)
        (load-project-lisp "STANDARD") ;; TODO remove
        (run-hook '*after-startup-hook*)
        (message "Finished initializing Xelf for project ~A." *project*)
        (hide-terminal)
        #-ecl (load-user-init-file)
        (sdl:with-events ()
          (:quit-event () (prog1 t (shut-down)))
          (:video-resize-event (:w w :h h)  
                               (setf *screen-width* w
                                     *screen-height* h)
                               (when (not *scale-output-to-window*)
                                 (setf *nominal-screen-width* w
                                       *nominal-screen-height* h))
                               (run-hook '*resize-hook*)
                               (sdl:resize-window w h :title-caption *window-title*
                                                      :flags (logior sdl:SDL-OPENGL sdl:SDL-RESIZABLE))
                               (open-viewport)
                               (project-orthographically)
                               ;; handle any blitzed textures. on some platforms/drivers
                               ;; the textures become invalidated after resize
                               (when *clear-cached-images-on-resize*
                                 (clear-cached-images)
                                 (clear-cached-fonts))
                               )
          (:mouse-motion-event (:x x :y y)
                               (setf *pointer-x* x *pointer-y* y)
                               (let ((block (hit-blocks (window-pointer-x)
                                                        (window-pointer-y) 
                                                        *blocks*)))
                                 (when block
                                   (handle-point-motion block
                                         (window-pointer-x)
                                         (window-pointer-y)))))
          (:mouse-button-down-event (:button button :x x :y y)
                                    (setf *pointer-x* x *pointer-y* y)
                                    (let ((block (hit-blocks 
                                                  (window-pointer-x)
                                                  (window-pointer-y)
                                                  *blocks*)))
                                      (when block
                                        (press block
                                              (window-pointer-x)
                                              (window-pointer-y)
                                              button))))
          (:mouse-button-up-event (:button button :x x :y y)
                                  (setf *pointer-x* x *pointer-y* y)
                                  (let ((block (hit-blocks                                        
                                                (window-pointer-x)
                                                (window-pointer-y)
                                                *blocks*)))
                                    (when block
                                      (release block
                                            (window-pointer-x)
                                            (window-pointer-y)
                                            button))))
          (:joy-button-down-event (:which which :button button :state state)
                                  (send-event (make-event :raw-joystick (list button :button-down)))
                                  (update-joystick-button button state which)
                                  (send-event (make-event :joystick
                                                          (list which button
                                                                :button-down))))
          (:joy-button-up-event (:which which :button button :state state)  
                                (send-event (make-event :raw-joystick (list button :button-up)))
                                (update-joystick-button button state which)
                                (send-event (make-event :joystick
                                                        (list which button
                                                              :button-up))))
          (:joy-axis-motion-event (:which which :axis axis :value value)
                                  (update-joystick-axis axis value which))
          (:video-expose-event () (sdl:update-display))
          (:key-down-event (:key key :mod-key mod :unicode unicode)
                           (send-event
                            (make-event 
                             ;; translate data items from SDL format to internal
                             (cons (make-key-symbol key)
                                   (when (not (zerop unicode))
                                     (string (code-char unicode))))
                             (mapcar #'make-key-modifier-symbol mod))))
  ;      (:key-up-event (:key key :mod-key mod :unicode unicode)
        (:idle ()
               ;; this lets slime keep working while the main loop is running
               ;; in sbcl using the :fd-handler swank:*communication-style*
               #+(and sbcl (not sb-thread)) (restartably
                                             (sb-sys:serve-all-events 0))        
               (do-update)
               ;; (sdl:with-timestep (do-update))
               ;; load pending resources
               ;; (dolist (plist *pending-resources*)
               ;;   (index-resource (apply #'make-instance 'resource plist)))
               ;; (setf *pending-resources* nil)
               (restartably
                 (gl:clear-color 0 0 0 1)
                 (gl:clear)
                 (when (and *buffer*
                            *draw-function*)
                   (funcall *draw-function*))
                 (gl:flush)
                 (gl:finish)
                 (sdl:update-display)))))))

TODO Session startup/shutdown

(defun quit-xelf (&optional shutdown)
    "Exit the game engine."
    (when shutdown 
      (setf *quitting* t))
    (setf *project* nil)
    (sdl:push-quit-event))

Shared library search paths   linux mac

  (defvar *library-search-paths-setup-hook* nil)

  (defun setup-library-search-paths ()
    (run-hook '*library-search-paths-setup-hook*)
    #+linux (when *executable*
              (setf cffi:*foreign-library-directories*
                    (union cffi:*foreign-library-directories*
                           (list *current-directory*)
                           :test #'equal)))
    #+darwin (setf cffi:*foreign-library-directories*
                   (union cffi:*foreign-library-directories*
                          '(#P"/opt/local/lib" #P"/sw/lib/")
                          :test #'equal))
    )
  (defparameter *do-cffi-loading* t)

  (defun do-cffi-loading ()
    (cffi:define-foreign-library sdl
        (:darwin (:or (:framework "SDL")
                      (:default "libSDL")))
        (:unix (:or "libSDL-1.2.so.0.7.2"
                    "libSDL-1.2.so.0"
                    "libSDL-1.2.so"
                    "libSDL.so"
                    "libSDL")))
      (cffi:use-foreign-library sdl)
      ;;
      (cffi:define-foreign-library sdl-mixer
        (:darwin (:or (:framework "SDL_mixer")
                      (:default "libSDL_mixer")))
        (:unix (:or "libSDL_mixer-1.2.so.0.7.2"
                    "libSDL_mixer-1.2.so.0"
                    "libSDL_mixer-1.2.so"
                    "libsdl_mixer-1.2.so.0.2.6" ;; eeebuntu?
                    "libSDL_mixer.so"
                    "libSDL_mixer")))
      (cffi:use-foreign-library sdl-mixer)
      ;;
      ;; (cffi:define-foreign-library sdl-gfx
      ;;   (:darwin (:or (:framework "SDL_gfx")
      ;;                    (:default "libSDL_gfx")))
      ;;   (:unix (:or "libSDL_gfx-1.2.so.0.7.2"
      ;;                  "libSDL_gfx-1.2.so.0"
      ;;                  "libSDL_gfx-1.2.so"
      ;;                  "libSDL_gfx.so.4"
      ;;                  "libSDL_gfx.so.13"
      ;;                  "libSDL_gfx.so"
      ;;                  "libSDL_gfx")))
      ;; (cffi:use-foreign-library sdl-gfx)
    ;;
    (cffi:define-foreign-library sdl-ttf
        (:darwin (:or (:framework "SDL_ttf")
                      (:default "libSDL_ttf")))
        (:unix (:or "libSDL_ttf-1.2.so.0.7.2"
                    "libSDL_ttf-1.2.so.0"
                    "libSDL_ttf-1.2.so"
                    "libSDL_ttf-2.0.so.0"
                    "libSDL_ttf.so.4"
                    "libSDL_ttf.so.13"
                    "libSDL_ttf.so"
                    "libSDL_ttf")))
      (cffi:use-foreign-library sdl-ttf)
    ;;
      (cffi:define-foreign-library sdl-image
        (:darwin (:or (:framework "SDL_image")
                      (:default "libSDL_image")))
        (:unix (:or "libSDL_image-1.2.so.0.7.2"
                    "libSDL_image-1.2.so.0"
                    "libSDL_image-1.2.so.0.1.5" ;; eeebuntu?
                    "libSDL_image-1.2.so"
                    "libSDL_image.so"
                    "libSDL_image")))
      (cffi:use-foreign-library sdl-image))

Loading standard fonts and icons

See also the included file "xelf/standard/index.xelf".

  (defun load-standard-resources ()
    (open-project "standard")
    (when (eq :emulated-vertex-color *vertex-color-p*)
       (index-emulated-vertex-colors)))

Startup

  (defun start-up ()
    (setup-library-search-paths)
    #+linux (do-cffi-loading)
    ;; get going...
    (message "Starting Xelf...")
    (print-copyright-notice)
    (setf *blocks* nil
          *buffer* nil
          *shell* nil
          *quadtree* nil
          *project* nil
          *clipboard* nil
          *event-hook* nil
          *message-hook* nil
          *updates* 0
          *resizable* t
          *random-state* (make-random-state t))
    (clear-all-caches)
    (delete-all-textures)
    (sdl:init-sdl :video t :audio t :joystick t)
    ;; don't overwrite paths from executable toplevel code
    (when (or (null *project-directories*)
              (not *executable*))
      (setf *project-directories* (full-project-directories)))
    (when *executable*
      (setf *project-directories* (list *current-directory*)))
    (initialize-resource-table)
    (initialize-textures-maybe :force)
    (initialize-colors)
    (when *use-sound* (initialize-sound))
    (initialize-database)
    ;;(initialize-clipboard-maybe :force)
    (initialize-buffers)
    (load-standard-resources)
    (setf *next-update-hook* nil)
    (sdl:enable-unicode)
    (enable-key-repeat))

Shutdown

  (defun shut-down ()
    (message "Shutting down Xelf...")
    (clear-all-caches)
    (delete-all-resources)
    (setf *buffers* nil)
    (sdl-mixer:halt-music)
    (sdl-mixer:close-audio t)
    (setf *buffer* nil)
    (setf *blocks* nil)
    (setf *next-update-hook* nil)
    (setf *clipboard* nil)
    (setf *frame-rate* *default-frame-rate*)
    (setf *event-hook* nil)
    (setf *gl-window-open-p* nil)
    (setf *project-directories* nil)
    (message "Quitting SDL...")
    (sdl:quit-sdl))

  (defun exit-xelf () (shut-down))
  
  (defmacro with-session (&body body)
    "Starts up Xelf, runs the BODY forms, and starts the main game loop.
  Xelf will exit after the game loop terminates."
    `(progn
       (start-up)
       ,@body
       (start-session)
       (shut-down)))

Node class

The NODE class builds upon the basic collidable object QUADRILLE defined above. NODE adds event keybindings, extended graphics property slots, and optional GUI menus and drag-and-drop functionality. It also optionally hooks into the Netplay system.

Your game and GUI objects should subclass NODE or one of its subclasses.

(A few of these slot declarations should be moved into appropriate subclasses.)

  (defclass node (quadrille)
    ((tags :initform nil :accessor tags :initarg :tags)
     (selected-p :initform nil :accessor selected-p :initarg :selected-p)
     (events :initform nil :accessor events :initarg :events :documentation "Event bindings, if any. See also `bind-event'.")
     (default-events :initform nil :accessor default-events :initarg :default-events)
     (color :initform "white" :accessor color :initarg :color)
     (parent :initform nil :initarg :parent :accessor parent)
     (inputs :initform nil :initarg :inputs :accessor inputs)
     (results :initform nil :initarg :results :accessor results)
     (fixed-width :initform nil :initarg :fixed-width :accessor fixed-width)
     (input-widths :initform nil :initarg :input-widths :accessor input-widths)
     (focused-p :initform nil :accessor focused-p)
     (label :initform nil :initarg :label :accessor label)
     (category :initform nil :initarg :category :accessor category)
     ;; Netplay
     (player-id :initform nil :accessor player-id)
     (input-p :initform nil :accessor input-p)
     (input-time :initform nil :accessor input-time)
     (input-update-p :initform nil :accessor input-update-p)
     ;; blending and image rotation
     (blend :initform :alpha :accessor blend :initarg :blend)
     (opacity :initform 1.0 :accessor opacity :initarg :blend)
     (image-heading :initform nil :accessor image-heading :initarg :image-heading)
     ;; dimensions
     (width :initform 32 :accessor width :initarg :width :documentation "Width of the block, in GL units.")
     (height :initform 32 :accessor height :initarg :height :documentation "Height of the block, in GL units.")
     (depth :initform 32 :accessor depth :initarg :depth :documentation "Depth of block, in GL units. Currently ignored.")
     (pinned :initform nil) ;; when non-nil, do not allow dragging
     (visible :initform t)
     ;; morphic style halo
     (no-background :initform nil :initarg :no-background :accessor no-background)
     (halo :initform nil)
     (mode :initform nil)
     (name :initform nil :accessor name)
     (needs-layout :initform t :accessor needs-layout)
     (caption :initform nil)
     (tasks :initform nil)
     (read-only :initform nil :accessor read-only :initarg :read-only)
     (image :initform nil :accessor image :initarg :image :documentation "Name of texture to be displayed, if any.")))

Determining whether a node is visible onscreen

  (defun on-screen-p (node)
    "Return non-nil when NODE touches the buffer's window bounding box."
    (contained-in-bounding-box 
     node
     (multiple-value-list (window-bounding-box (current-buffer)))))

Selecting nodes in the editor

(defmethod select ((node node))
  (setf (selected-p node) t))

(defmethod unselect ((node node))
  (setf (selected-p node) nil))

(defmethod toggle-selected ((node node))
  (if (selected-p node)
      (unselect node)
      (select node)))

Finding methods for a context menu

(defgeneric find-methods (object)
  (:method-combination append))

(defmethod find-methods append ((node node))
  '(destroy copy raise lower bring-to-front send-to-back resize-to-image))

Destruction

(defmethod destroy :before ((self node))
  (destroy-halo self))
  ;; (unplug-from-parent self))

Layout

  (defmethod layout :after ((self node))
    (with-slots (halo) self
      (when halo (layout halo))))
  (defmethod invalidate-layout ((self node)) 
    (setf (needs-layout self) t))

Making one or more nodes active   obsolete

These functions are obsolete; please use SWITCH-TO-BUFFER instead.

  (defmethod start ((self node))
    "Add this node to the simulation so that it receives update events."
    (unless (find self *blocks* :test 'eq :key #'find-object)
      (setf *blocks* (adjoin (uuid self) *blocks* :test 'equal))))

  (defmethod start-alone ((self node))
    "Set this node as the only object receiving update and draw events."
    (setf *blocks* (list self)))

  (defmethod stop ((self node))
    "Remove this node from the simulation so that it stops getting update
  events."
    (setf *blocks* (delete (uuid self) *blocks* :test #'equal)))

Automatic node sizing

An object can be automatically resized to fit the value of its IMAGE slot.

(defmethod resize-to-image ((self node))
  (when *resources*
    (with-slots (image height width) self
      (when (find-resource-object image :noerror)
        (setf width (image-width image))
        (setf height (image-height image))))))
(defmethod change-image ((self node) image)
  (when image
    (setf (slot-value self 'image) image)
    (resize-to-image self)))

Scaling a node with respect to its image

(defmethod scale ((self node) x-factor &optional y-factor)
  (let ((image (find-resource-object (slot-value self 'image))))
    (resize self 
            (* (sdl:width image) x-factor)
            (* (sdl:height image) (or y-factor x-factor)))))

Default node DRAW method

The basic node DRAW method will draw the IMAGE slot, or, failing that, a rectangle whose color is the value of the COLOR slot. See also DRAW.

(defmethod draw ((self node))
  (with-slots (image x y z halo inputs image-heading width color height blend opacity) self
    (if image 
        (draw-image image x y :z (or z 0)
                    :blend blend :opacity opacity
                    :height height :width width)
        (draw-box x y width height :color color))
    (mapc #'draw inputs)))
    ;; (when halo (draw halo))))
        ;; (progn (draw-patch self x y (+ x width) (+ y height))
        ;;        (mapc #'draw %inputs)))))

Legacy GUI compatibility   obsolete

This code is for compatibility with older GUI code and will be removed in the future.

   (defun %inputs (x) (slot-value x 'inputs))
   (defun %%inputs (x name) (input-node x name))
   (defvar *block-font* "sans-11")
  (defmethod freeze ((self node)) nil)
  (defmethod cancel ((self node)) nil)

  (defmethod proper-name ((self node))
    (pretty-string (class-name (class-of self))))

    (defmethod initialize-instance :after ((self node) &key))

  (defmacro defblock (spec &body args)
    "Define a new block.
  The first argument SPEC is either a
  symbol naming the new block, or a list of the form
   (SYMBOL . PROPERTIES) Where SYMBOL is similarly a name symbol but
  PROPERTIES is a keyword property list whose valid keys
  are :SUPER (specifying which prototype the newly defined block will
  inherit behavior from) and :DOCUMENTATION (a documentation string.)
  The remaining arguments ARGS are field specifiers, each of which is
  either a symbol naming the field, or a list of the form (SYMBOL
  . PROPERTIES) with :INITFORM and :DOCUMENTATION as valid keys."
    (let ((name0 nil)
          (super0 'xelf:node))
      (etypecase spec
        (symbol (setf name0 spec))
        (list (destructuring-bind (name super) spec
                (setf name0 name)
                (when super (setf super0 super)))))
      `(define-prototype ,name0 
           (:super ,super0)
         ,@(if (keywordp (first args))
            (plist-to-descriptors args)
            args))))

  (defmethod after-paste ((thing node)) nil)

  (defparameter *block-categories*
    '(:system :motion :event :message :looks :sound :structure :data :button
      :expression :menu :hover :control :parameters :comment :sensing :operators :variables)
    "List of keywords used to group blocks into different functionality
  areas.")

  (defun new (class &rest args)
    (apply #'make-instance class args))

  (defmethod create ((self node))
    (make-instance (find-super (find-object self))))

  (defmethod forward-message ((self node) method args)
    (apply #'send method self args))

  (defmethod set-field ((self node) field value)
    (setf (slot-value field (evaluate self)) value))

  (defmethod get-field ((self node) field)
    (slot-value field (evaluate self)))

  (defmethod after-revive ((self node)) nil)

  (defun destroy-maybe (x)
    (when (xelfp x) (destroy (find-object x))))

  (defmethod dismiss ((self node))
    ;; (if (windowp (slot-value self 'parent))
    ;;     (dismiss (slot-value self 'parent))
        (destroy self))

  (defmethod exit ((self node))
    (remove-object *buffer* self))

  (defmethod make-duplicate ((self node))
    (duplicate self))

  (defmethod make-clone ((self node))
    (uuid (clone (find-super self))))

TODO Semantic node trees

  (defmethod adopt ((self node) child)
    (when (get-parent child)
      (unplug-from-parent child))
    (set-parent (find-object child) self))

  (defmethod update-parent-links ((self node))
    (dolist (each (slot-value self 'inputs))
      (set-parent (find-object each) self)))

  (defmethod can-accept ((self node)) nil)

  (defmethod will-accept ((container node) (item node)) nil)

  (defmethod accept ((self node) other-block)
    "Try to accept OTHER-BLOCK as a drag-and-dropped input. Return
  non-nil to indicate that the block was accepted, nil otherwise."
    nil)

  (defmethod finish-drag ((self node))
    (bring-to-front self))

  (defmethod contains ((self node) block)
    (block finding
      (dolist (this (slot-value self 'inputs))
        (when (object-eq block this)
          (return-from finding this)))))

  (defmethod input-position ((self node) input)
    (assert (not (null input)))
    (position (uuid input) (slot-value self 'inputs) :key #'uuid :test 'equal))

  (defun input (self name)
    (with-slots (inputs) self
      (assert (not (null inputs)))
      (nth (input-position self name) inputs)))

  (defun (setf input) (self name node)
    (with-slots (inputs) self
      (assert (not (null inputs)))
      (set-parent (find-object node) self)
      (setf (nth (input-position self name) inputs)
            ;; store the real link
            (find-object node))))

  (defmethod position-within-parent ((self node))
    (input-position (find-tab-parent self) self))

  (defmethod set-parent ((self node) parent)
    "Store a link to the enclosing block PARENT."
    (assert (not (null parent)))
    (assert (valid-connection-p parent self))
    (setf (slot-value self 'parent) 
      (when parent 
      ;; always store uuid to prevent circularity
        (find-object parent))))
               
  (defmethod get-parent ((self node))
    (slot-value self 'parent))

  (defmethod find-parent ((self node))
    (when (slot-value self 'parent) (uuid (slot-value self 'parent))))

  (defun valid-connection-p (sink source)
    (assert (or sink source))
    ;; make sure source is not actually sink's parent somewhere
    (block checking
      (prog1 t
        (let ((pointer sink))
          (loop while pointer do
            (if (eq (find-object pointer)
                    (find-object source))
                (return-from checking nil)
                (setf pointer (find-parent (find-object pointer)))))))))

  (defmethod update-result-lists ((self node))
    (let ((len (length (slot-value self 'inputs))))
      (setf (slot-value self 'input-widths) (make-list len :initial-element 0))
      (setf (slot-value self 'results) (make-list len))))

  (defmethod delete-input ((self node) block)
    (with-slots (inputs) self
      (prog1 t
        (assert (contains self block))
        (setf inputs (remove block inputs
                             :key #'find-object
                             :test 'eq))
        (assert (not (contains self block))))))

  (defmethod default-inputs ((self node))
    nil)

  (defmethod this-position ((self node))
    (with-slots (parent) self
      (when parent
        (input-position parent self))))

  (defmethod plug ((self node) thing n)
    "Connect the block THING as the value of the Nth input."
    (set-parent (find-object thing) self)
    (setf (input self n) (find-object thing)))

  (defmethod after-unplug-hook ((self node) parent))
    ;; (setf (slot-value self 'parent) nil)
    ;; (add-object (current-buffer) self))

  (defmethod after-release-hook ((self node)))

  (defmethod unplug ((self node) input)
    "Disconnect the block INPUT from this node."
    (with-slots (inputs parent) self
      (assert (contains self input))
      (prog1 input
        (setf inputs 
              (delete input inputs 
                      :test 'eq :key #'find-object))
        (after-unplug-hook input self))))

  (defmethod unplug-from-parent ((self node))
    (when (slot-value self 'parent)
      (prog1 t
        (with-slots (parent) self
          (assert (not (null parent)))
          (assert (contains (find-object parent) self))
          (unplug (find-object parent) self)
  ;     (assert (not (contains parent self)))
          (setf parent nil)))))

  (defmethod child-updated ((self node) child))

TODO Read-only status

  (defmethod toggle-read-only ((self node))
    (setf (slot-value self 'read-only) (if (slot-value self 'read-only) nil t)))

  (defmethod read-only-p ((self node)) (slot-value self 'read-only))

  (defmethod set-read-only ((self node) &optional (read-only t))
    (setf (slot-value self 'read-only) read-only))

TODO Visual macros

  (defmacro define-visual-macro (name 
       (&key (super 'node) slots documentation inputs)
       &body body)
    "Define a new block called NAME according to the given options.

  The argument SUPER should be the name (a symbol or string) of the base
  prototype to inherit traits (data and behavior) from. The default is
  `node' so that if you don't specify a SUPER argument, you still
  inherit all the inbuilt behaviors of nodes.

  The argument SLOTS should be a list of slot descriptors, the same as
  would be given to `define-prototype'.

  The INPUTS argument is a list of forms evaluated to produce argument
  blocks. 

  DOCUMENTATION is an optional documentation string for the entire
  macro.

  The BODY forms are evaluated when the resulting block is evaluated;
  they operate by invoking `evaluate' in various ways on the INPUTS.

  The method `recompile' emits Lisp code that has the same result as
  invoking `evaluate', but with zero or more blocks in the entire visual
  expression subtree being replaced by (possibly shorter and more
  efficient) 'plain' Lisp code. This is trivially true for the default
  implementation of `recompile', which emits a statement that just
  invokes `evaluate' when evaluated. When subsequently redefining the
  `recompile' method on a block-macro, the 'equivalence' between the
  results of invoking `recompile' and invoking `evaluate' depends solely
  on the implementor, who can write a `recompile' method which operates
  by invoking `recompile' in various ways on the macro-block's
  `(slot-value self 'inputs'), and emitting Lisp code forms using those
  compiled code streams as a basis.
  "
    (let ((input-names (remove-if-not #'keywordp inputs)))
      `(progn 
         (defclass ,name ,(if (symbolp super) (list super) super)
           ((caption :initform ,(pretty-string name))
            (input-names :initform ',input-names)
            ,@slots))
         (defmethod initialize-instance :after ((self ,name) &key inputs)
           (setf (slot-value self 'inputs) (list ,@(remove-if #'keywordp inputs)))
           (update-parent-links self)
           (mapc #'pin (slot-value self 'inputs))
           ,@body)
         (defmethod recompile ((self ,name)) (evaluate self)))))

  (defun input-node (object input-name)
    (nth (position input-name 
                   (slot-value object 'input-names))
         (slot-value object 'inputs)))

  (defun (setf input-node) (new-value object input-name)
    (setf (nth (position input-name 
                         (slot-value object 'input-names))
               (slot-value object 'inputs))
          new-value))
  
  (defmacro with-visual-slots (slots object &body body)
    (let ((slot-names (mapcar #'make-keyword slots))
          (slot-symbols slots)
          (clauses nil)
          (ob (gensym)))
      (loop while slot-names do
           (push `(,(pop slot-symbols) (input-node ,ob ,(pop slot-names)))
                 clauses))
      `(let ((,ob ,object))
         (symbol-macrolet ,clauses ,@body))))

Categorizing nodes with "tags"

  (defmethod has-tag ((self node) tag)
    "Return non-nil if this node has the specified TAG.

  Nodes may be marked with tags that influence their processing by the
  engine. The field `(slot-value self 'tags') is a set of keyword symbols; if a symbol
  `:foo' is in the list, then the node is in the tag category `:foo'.
  "
    (member tag (slot-value self 'tags)))

  (defmethod add-tag ((self node) tag)
    "Add the specified TAG symbol to this node."
    (pushnew tag (slot-value self 'tags)))

  (defmethod remove-tag ((self node) tag) 
    "Remove the specified TAG symbol from this node."
    (setf (slot-value self 'tags) (remove tag (slot-value self 'tags))))

Serialization hooks   obsolete

These methods are obsolete and will be removed in the future.

  (defmethod before-serialize ((self node)))

  (defmethod after-deserialize ((self node))
    "Prepare a deserialized block for running."
    (bind-any-default-events self)
    (register-uuid self))

Dropping objects at the present location

  (defmethod drop ((self node) new-block &optional (dx 0) (dy 0) (dz 1))
    "Add a new object to the current buffer at the current position.
  Optionally provide an x-offset DX and a y-offset DY. The optional
  z-offset DZ defaults to 1, which stacks the object on top of itself.
  See also `drop-at'."
    (add-node (current-buffer) new-block (+ (slot-value self 'x) dx) (+ (slot-value self 'y) dy) (+ (or (slot-value self 'z) 0) dz)))

  (defmethod drop-at ((self node) new-block x y &optional z)
    "Add the NEW-BLOCK to the current buffer at the location X,Y."
    (assert (and (numberp x) (numberp y)))
    (add-node (current-buffer) new-block x y z))

Binding events to objects

  (defmethod initialize-events-table-maybe ((self node) &optional force)
    (when (null (slot-value self 'events))
      (setf (slot-value self 'events) (make-hash-table :test 'equal))))

  (defmethod bind-event-to-task ((self node) event-name modifiers task)
    "Bind the described event to invoke the action of the TASK.
  EVENT-NAME is either a keyword symbol identifying the keyboard key, or
  a string giving the Unicode character to be bound. MODIFIERS is a list
  of keywords like :control, :alt, and so on."
    (assert (find-object task))
    (initialize-events-table-maybe self)
    (let ((event (make-event event-name modifiers)))
      (setf (gethash event (slot-value self 'events))
            task)))

  (defmethod unbind-event ((self node) event-name modifiers)
    "Remove the described event binding."
    (remhash (normalize-event (cons event-name modifiers))
             (slot-value self 'events)))

  (defmethod handle-event ((self node) event)
    "Look up and invoke the block task (if any) bound to
  EVENT. Return the task if a binding was found, nil otherwise. The
  second value returned is the return value of the evaluated task (if
  any)."
    (with-slots (events) self
      (when events
        (let ((task 
                ;; unpack event
                (destructuring-bind (head &rest modifiers) event
                  ;; if head is a cons, check for symbol binding first,
                  ;; then for unicode binding. we do this because we'll
                  ;; often want to bind keys like ENTER or BACKSPACE
                  ;; regardless of their Unicode interpretation 
                  (if (consp head)
                      (or (gethash (cons (car head) ;; try symbol
                                         modifiers)
                                   events)
                          (gethash (cons (cdr head) ;; try unicode
                                         modifiers)
                                   events))
                      ;; it's not a cons. 
                      ;; just search event as-is
                      (gethash event events)))))
          (if task
              (values (find-object task)
                       (evaluate (find-object task)))
              (values nil nil))))))

  (defmethod handle-text-event ((self node) event)
    "Look up events as with `handle-event', but insert
  unhandled/unmodified keypresses as Unicode characters via the `insert'
  function."
    (unless (joystick-event-p event)
      (with-slots (events) self
        (let ((task
                (destructuring-bind (head &rest modifiers) event
                  (if (consp head)
                      (or (gethash (cons (car head) ;; try symbol
                                         modifiers)
                                   events)
                          (gethash (cons (cdr head) ;; try unicode
                                         modifiers)
                                   events))
                      ;; it's not a cons. 
                      ;; just search event as-is
                      (gethash event events)))))
          (if task 
              (if (symbolp task)
                  (funcall task self)
                  (evaluate (find-object task)))
              (destructuring-bind (key . unicode) (first event)
                ;; treat non-alt-control Unicode characters as self-inserting
                (when 
                    (and (not (eq :return key))
                         unicode 
                         (not (member :alt (rest event)))
                         (not (member :control (rest event))))
                  (prog1 t
                    (insert-string self unicode)))))))))

  (defmethod handle-text-event :around ((self node) event)
    (when (slot-value self 'events)
      (call-next-method)))
  
  (defun bind-event-to-method (block event-name modifiers method-name)
    "Arrange for METHOD-NAME to be sent as a message to this object
  whenever the event (EVENT-NAME . MODIFIERS) is received."
    (destructuring-bind (key . mods) 
        (make-event event-name modifiers)
      (bind-event-to-task block 
                             key
                             mods
                             (make-instance 'task :method-name method-name :target block))))

  (defmethod bind-event ((self node) event binding)
    "Bind the EVENT to invoke the action specified in BINDING.
  EVENT is a list of the form:

         (NAME modifiers...)

  NAME is either a keyword symbol identifying the keyboard key, or a
  string giving the Unicode character to be bound. MODIFIERS is a list
  of keywords like :control, :alt, and so on.

  Examples:
  
    (bind-event self '(:up) 'move-up)
    (bind-event self '(:down) 'move-down)
    (bind-event self '(:q :control) 'quit)
    (bind-event self '(:escape :shift) 'menu)

  See `keys.lisp' for the full table of key and modifier symbols.

  "  (destructuring-bind (name &rest modifiers) event
      (etypecase binding
        (symbol (bind-event-to-method self name modifiers binding))
        (list 
         ;; create a method call 
         (let ((task (make-instance 'task
                          (first binding)
                          self
                          :arguments (rest binding))))
           (bind-event-to-task self name modifiers task))))))

  (defmethod bind-any-default-events ((self node))
    (with-slots (default-events) self
      (when default-events
        (initialize-events-table-maybe self :force)
        (dolist (entry default-events)
          (apply #'bind-event self entry)))))

  (defmethod destroy-events ((self node))
    (when (slot-value self 'events)
      (loop for event being the hash-values of (slot-value self 'events) do 
        (destroy-maybe event))))

Raising and lowering in Z-order

See also Z-SORT.

  (defmethod raise ((self node) distance)
    (incf (slot-value self 'z) distance))

  (defmethod lower ((self node) distance)
    (decf (slot-value self 'z) distance))
  
  (defmethod move-to-depth ((self node) depth)
    (setf (slot-value self 'z) (cfloat depth)))

  (defmethod bring-to-front ((self node))
    (with-slots (z) self
       (setf z (max (or z 1)
       (+ 1 (maximum-z-value (current-buffer)))))))

  (defmethod send-to-back ((self node))
    (setf (slot-value self 'z) 1))

TODO Task scheduler

  (defclass task (node)
    ((method-name :initform nil)
     (target :initform nil)
     (arguments :initform nil)
     (clock :initform nil)
     (subtasks :initform nil)
     (finished :initform nil)))

  (defmethod initialize-instance :after ((self task) 
                         &key method-name target arguments clock subtasks)
      (assert method-name)
      (assert (listp arguments))
      (assert (xelfp target))
      (assert (or (eq t clock)
                  (null clock)
                  (and (integerp clock)
                       (plusp clock))))
      (setf (slot-value self 'method-name) method-name
            (slot-value self 'arguments) arguments
            (slot-value self 'target) (uuid target)
            (slot-value self 'subtasks) subtasks
            (slot-value self 'clock) clock))

  (defmethod finish ((self task))
    (setf (slot-value self 'finished) t))

  (defmethod evaluate ((self task))
    (when (xelfp (slot-value self 'target))
      (apply (symbol-function (slot-value self 'method-name)) (find-object (slot-value self 'target)) (slot-value self 'arguments))))

  (defmethod running ((self task))
    (with-slots (method-name target arguments clock finished) self
      (cond 
        ;; if finished, quit now.
        (finished nil)
        ;; countdown exists and is finished.
        ((and (integerp clock)
              (zerop clock))
         (prog1 nil 
           (evaluate self)
                ))
        ;; countdown not finished. tell manager to keep running, 
        ;; but don't evaluate at this time
        ((and (integerp clock)
              (plusp clock))
         (prog1 t 
           (decf clock)))
        ;; no countdown, but we should test the output.
        ;; if non-nil, manager keeps us running.
        ((eq t clock)
         (let ((result (evaluate self)))
           (prog1 result
             (if result
                 (mapc #'running (slot-value self 'subtasks))
                 (mapc #'finish (slot-value self 'subtasks))))))
        ;; no countdown or testing. just keep running.
        ((null clock)
         (prog1 t (evaluate self)))
        ;; shouldn't reach here
        (t (error "Invalid task.")))))

  (defun seconds->frames (seconds)
    "Return the time in SECONDS as an integer number of frames.
  Based on the current *FRAME-RATE*."
    (truncate (* seconds *frame-rate*)))

  (defun time-until (updates)
    (assert (>= updates *updates*))
    (- updates *updates*))
  
  (defun time-as-frames (value)
    (etypecase value
      (integer value)
      (float (seconds->frames value))))

  (defun make-task-form (delay expression &optional subexpressions)
    (destructuring-bind (method target &rest arguments) expression
      (let ((target-sym (gensym))
            (delay-sym (gensym)))
        `(let ((,target-sym ,target)
               (,delay-sym ,delay))
           (add-task ,target-sym
                     (make-instance 'task 
                          :method ',(make-non-keyword method)
                          :target ,target-sym
                          :subtasks (list ,@(make-tasks delay-sym subexpressions))
                          :arguments (list ,@arguments)
                          :clock ,delay))))))

  (defun make-tasks (delay forms)
    (mapcar #'(lambda (form)
                (make-task-form delay form))
            forms))

  (defmacro later (delay &rest forms)
    (assert (every #'consp forms))
    (let ((clock (time-as-frames delay))) 
      `(progn ,@(make-tasks clock forms))))

  (defmacro later-at (absolute-time &body forms)
    `(later ,(time-until absolute-time) ,@forms))

  (defmacro later-while (test-expression &body subtask-expressions)
    `(later ,(make-task-form t test-expression subtask-expressions)))

  (defmethod after-drop-hook ((self task)))

Adding tasks to nodes

   (defmethod add-task ((self node) task)
     (assert (xelfp task))
     (pushnew (uuid task) (slot-value self 'tasks) :test 'equal))

   (defmethod remove-task ((self node) task)
     (destroy-maybe task)
     (setf (slot-value self 'tasks) (delete task (slot-value self 'tasks) :test 'equal)))
 
   (defmethod run-tasks ((self node))
     ;; don't run tasks on objects that got deleted during UPDATE
     (when (slot-value self 'quadtree-node)
       (dolist (task (slot-value self 'tasks))
         (let ((t2 (find-object task :no-error)))
           (when (xelfp t2)
             (unless (running (find-object t2))
               (remove-task self (find-object t2))))))))

   (defmethod update ((self node)))

TODO Dataflow   experimental

  (defmethod evaluate-inputs ((self node))
    "Evaluate all nodes in (SLOT-VALUE SELF 'INPUTS) from left-to-right. Results are
  placed in corresponding positions of (SLOT-VALUE SELF 'RESULTS). Override this method
  when defining new nodes if you don't want to evaluate all the inputs
  all the time."
    (with-slots (inputs results) self
      (let ((arity (length inputs)))
        (when (< (length results) arity)
          (setf results (make-list arity)))
        (dotimes (n arity)
          (when (nth n inputs)
            (setf (nth n results)
                  (evaluate (nth n inputs))))))
      results))

  (defmethod evaluate ((self node)) self)

  (defmethod evaluate-here ((self node)))

  (defmethod recompile ((self node))
    (mapcar #'recompile (slot-value self 'inputs)))

  (defun count-tree (tree)
    "Return the number of nodes enclosed in this node, including the
  current node. Used for taking a count of all the nodes in a tree."
    (cond ((null tree) 0)
          ;; without inputs, just count the root
          ((null (slot-value tree 'inputs)) 1)
          ;; otherwise, sum up the counts of the children (if any)
          (t (apply #'+ 1 
                    (mapcar #'count-tree 
                            (slot-value tree 'inputs))))))

Pathfinding obstruction declaration

See the section on Pathfinding below.

  (defmethod will-obstruct-p ((self node) path-finder) nil)

Commands and undo/redo

(defvar *command-history* nil)

(defun command-history ()
  *command-history*)

(defun clear-command-history ()
  (mapc #'destroy *command-history*)
  (setf *command-history* nil))

(defun last-command ()
  (first *command-history*))

(defclass command (node)
  ((action :initform nil :initarg :action :accessor action)
   (target :initform nil :initarg :target :accessor target)
   (data :initform nil :initarg :data :accessor data)
   (undo-action :initform nil :initarg :undo-action :accessor undo-action)
   (reversible-p :initform nil :initarg :reversible-p)
   (executed-p :initform nil :accessor executed-p)))

(defmethod execute ((command command))
  (setf (undo-action command)
        (make-undo-action command))
  (apply (symbol-function (action command))
         (cons (target command)
               (data command)))
  (setf (executed-p command) t)
  (push command *command-history*))

(defmethod make-undo-action ((command command)) nil)
  
(defmethod reversible-p ((command command)) 
  (slot-value command 'reversible-p))

(defmethod undo ((command command))
  (when (xelfp (target command))
    (funcall (undo-action command))))

(defclass move-command (command)
  ((action :initform #'move)
   (reversible-p :initform t)))

(defmethod make-undo-action ((command move-command))
  (let ((target (target command)))
    (with-slots (x y) target
      (let ((x0 x)
            (y0 y))
        #'(lambda ()
            (move-to target x0 y0))))))

(defclass resize-command (command)
  ((action :initform #'resize)
   (reversible-p :initform t)))

(defmethod make-undo-action ((command resize-command))
  (let ((target (target command)))
    (with-slots (height width) target
      (let ((h0 height)
            (w0 width))
        #'(lambda ()
            (resize target w0 h0))))))

(defclass destroy-command (command)
  ((action :initform #'destroy)
   (reversible-p :initform t)))

(defmethod make-undo-action ((command destroy-command))
  (let ((copy (duplicate-safely (target command))))
    #'(lambda ()
        (add-node (current-buffer) copy))))

(defmacro with-command (args)
  (destructuring-bind (name target &rest body) args
    (labels ((command-class (n)
               (intern (concatenate 'string (symbol-name n) "-command"))))
      (let ((command (gensym))
            (data (gensym)))
        `(let* ((,data (list ,@body))
                (,command (apply #'make-instance ,(command-class name)
                                 :data ,data :target ,target)))
           (execute ,command))))))

(defun undo-last-command ()
  (let ((command (pop *command-history*)))
    (if (null command)
        (notify "There is no command history to undo.")
        (progn
          (undo command)
          (destroy command)))))
      
;; defclass bring-to-front-command
;; defclass send-to-back-command
;; defclass raise-command
;; defclass lower-command

Buffer class

The Buffer class documentation continues on the GUI page.

Graphical User Interface

Please see the GUI page for code and documentation.

Facade objects

TODO Project object

(defclass project (node)
  ((name :initform *project* :initarg :name :accessor name)
   (path :initform *project-path* :initarg :path :accessor path)
   (scale-output-to-window :initform *scale-output-to-window*)
   (frame-rate :initform *frame-rate*)
   (title :initform *project*)
   (resizable :initform *resizable*)
   (author :initform *author*)
   (author-contact :initform *author-contact*)
   (license :initform "Short license name here.")
   (width :initform *screen-width*)
   (height :initform *screen-height*)
   (open-p :initform nil :accessor open-p)
   (modified-p :initform nil :accessor modified-p)
   (double-tap-time :initform *double-tap-time* :accessor double-tap-time :initarg :double-tap-time)
   (properties :initform nil :initarg :properties :accessor properties)))

(defmethod create-new ((project project) name &optional folder-name parent)
  (setf (name project) name)
  (let ((result (create-project-image name folder-name parent)))
    (if (null result)
        (error "Cannot create project.")
        project)))

(defmethod begin ((project project))
  (when (open-p project)
    (error "Cannot open an already opened project."))
  (open-project project)
  (setf (path project) *project-path*)
  (setf (open-p project) t)
  (set-current-project project)
  (index-pending-resources))

(defmethod save ((project project))
  (when (open-p project)
    (save-project project)
    (set (modified-p project) nil)))

(defmethod find-file ((project project) file)
  (find-project-file (name project) file))

(defmethod all-buffers ((project project))
  (let (buffers)
    (maphash #'(lambda (key value)
                 (push value buffers))
             *buffers*)))

(defmethod all-images ((project project))
  ;;  (when (open-p project)
    (project-images))

(defmethod all-image-names ((project project))
  (let (images)
    (maphash #'(lambda (name resource)
                 (when (eq :image (resource-type resource))
                   (push name images)))
             *resources*)
    images))

(defmethod all-samples ((project project))
  ;;(when (open-p project)
    (project-samples))

(defmethod all-music ((project project))
  (remove-if-not #'music-filename-p
                 (cl-fad:list-directory (path project))))

Pathfinding

We use the well-known A-star search algorithm. The main user-level functions are CREATE-PATH and FIND-PATH-WAYPOINTS. There is also a documented example of usage in the game Squareball; you can find the literate source on that page. See also WILL-OBSTRUCT-P.

Path class

    ;; finder ;; Who is finding this path?  
    ;; buffer ;; Pointer to associated buffer.  
    ;; grid ;; Array of pathfinding data pnodes.
    ;; height ;; Height of the pathfinding area.
    ;; width ;; Width of the pathfinding area.
    ;; heap ;; Heap array of open pathfinding pnodes.
    ;; end ;; Pointer to last heap array position.  
    ;; turn ;; Integer sequence number

  (defclass path ()
    ((finder :initarg :finder :accessor path-finder)
     (buffer :initarg :buffer :accessor path-buffer)
     (grid :initarg :grid :accessor path-grid)
     (height :initarg :height :accessor path-height)
     (width :initarg :width :accessor path-width)
     (heap :initarg :heap :accessor path-heap)
     (end :initarg :end :accessor path-end) 
     (turn :initarg :turn :accessor path-turn)))

Search grid resolution

  (defparameter *path-grid-resolution* 180)

  (defun row-to-y (path row) 
    (let ((cy (/ (slot-value (path-buffer path) 'height)
                 (path-height path))))
      (cfloat (* cy row))))

  (defun column-to-x (path column) 
    (let ((cx (/ (slot-value (path-buffer path) 'width)
                 (path-width path))))
      (cfloat (* cx column))))

Checking a grid square

  (defun within-buffer-boundaries-p (buffer top left right bottom)
    (with-slots (height width) buffer
      (and (<= 0 left right width)
           (<= 0 top bottom height))))

  (defun obstructed (path row column)
    (with-slots (height width) 
        (path-buffer path)
      (let ((*quadtree* (slot-value (path-buffer path) 'quadtree))
            (border 20))
        (multiple-value-bind (top left right bottom)
            (bounding-box (path-finder path))
          (let* ((utop (row-to-y path row))
                 (uleft (column-to-x path column))
                 (vtop (- utop border))
                 (vleft (- uleft border))
                 (vright (+ border vleft (- right left)))
                 (vbottom (+ border vtop (- bottom top))))
            (if 
             (not (within-buffer-boundaries-p (current-buffer) vtop vleft vright vbottom))
             t
             (block colliding
               (flet ((check (object)
                        (when (and ;;(xelfp object)
                                   (slot-value object 'collision-type)
                                   (not (object-eq object (path-finder path)))
                                   (will-obstruct-p object (path-finder path)))
                          (return-from colliding object))))
                 (prog1 nil
                   (quadtree-map-collisions *quadtree*
                    (cfloat vtop)
                    (cfloat vleft)
                    (cfloat vright)
                    (cfloat vbottom)
                    #'check))))))))))

Pathfinding data node

(defstruct pnode 
  row 
  column
  parent ; previous pnode along generated path
  F ; pnode score, equal to G + H
  G ; movement cost to move from starting point
    ; to (row, column) along generated path
  old-G ; previous value of G
  H ; heuristic cost to reach goal from (row, column)
  closed ; equal to path's path-turn-number when on closed list
  open ; equal to path's path-turn-number when on open list
  )

Creating a pathfinding context

  (defun create-path (finder &key
                               (height *path-grid-resolution*)
                               (width *path-grid-resolution*) 
                               (buffer (current-buffer)))
    "Return a new path for the object FINDER in the buffer BUFFER.
  The arguments HEIGHT and WIDTH define the dimensions of the grid of
  cells to be searched for traversability."
    (assert (xelfp buffer))
    (let ((path (make-instance 'path :buffer buffer
                           :finder finder
                           :grid (make-array (list height width))
                           :heap (make-array (* height width))
                           :height height
                           :width width
                           :turn 1 :end 0)))
      (prog1 path
        (dotimes (r height)
          (dotimes (c width)
            (setf (aref (path-grid path) r c)
                  (make-pnode :row r :column c)))))))

Minheap for open and closed node sets

  (defun open-pnode (path pnode)
    (let* ((path-heap-end (if (null (path-end path))
                              (setf (path-end path) 1)
                              (incf (path-end path))))
           (path-heap (path-heap path))
           (ptr path-heap-end)
           (parent nil)
           (finished nil))
      ;; make it easy to check whether pnode is open
      (setf (pnode-open pnode) (path-turn path))
      ;; add pnode to end of heap 
      (setf (aref path-heap path-heap-end) pnode)
      ;; let pnode rise to appropriate place in heap
      (while (and (not finished) (< 1 ptr))
        (setf parent (truncate (/ ptr 2)))
        ;; should it rise? 
        (if (< (pnode-F pnode) (pnode-F (aref path-heap parent)))
            ;; yes. swap parent and pnode
            (progn 
              (setf (aref path-heap ptr) (aref path-heap parent))
              (setf ptr parent))
            ;; no. we're done.
            (progn (setf finished t)
                   (setf (aref path-heap ptr) pnode))))
      ;; do we need to set pnode as the new root? 
      (if (and (not finished) (equal 1 ptr))
          (setf (aref path-heap 1) pnode))))

  (defun close-pnode (path)
    (let* ((path-heap (path-heap path))
           ;; save root of heap to return to caller
           (pnode (aref path-heap 1))
           (last nil)
           (path-heap-end (path-end path))
           (ptr 1)
           (left 2)
           (right 3)
           (finished nil))
      ;; is there only one pnode?
      (if (equal 1 path-heap-end)
          (setf (path-end path) nil)
        (if (null path-heap-end)
            nil
          ;; remove last pnode of heap and install as root of heap
           (progn
             (setf last (aref path-heap path-heap-end))
             (setf (aref path-heap 1) last)
             ;; shrink heap
             (decf (path-end path))
             (decf path-heap-end)
             ;;
             (setf (pnode-closed pnode) (path-turn path))
             ;;
             ;; figure out where former last element should go
             ;;
             (while (and (not finished) (>= path-heap-end right))
               ;;
               ;; does it need to sink? 
               (if (and (< (pnode-F last) (pnode-F (aref path-heap left)))
                        (< (pnode-F last) (pnode-F (aref path-heap right))))
                   ;;
                   ;; no. we're done
                   (progn 
                     (setf finished t)
                     (setf (aref path-heap ptr) last))
                   ;;
                   ;; does it need to sink rightward?
                   (if (>= (pnode-F (aref path-heap left)) 
                           (pnode-F (aref path-heap right)))
                       ;;
                       ;; yes
                       (progn
                         (setf (aref path-heap ptr) (aref path-heap right))
                         (setf ptr right))
                       ;;
                       ;; no, sink leftward
                       (progn
                         (setf (aref path-heap ptr) (aref path-heap left))
                         (setf ptr left))))
               (setf left (* 2 ptr))
               (setf right (+ 1 left)))
             ;;
             ;; 
             (if (and (equal left path-heap-end)
                      (> (pnode-F last)
                         (pnode-F (aref path-heap left))))
                 (setf ptr left)))))
          ;;
          ;; save former last element in its new place
          (setf (aref path-heap ptr) last)
      pnode))

Scoring pathfinding nodes

  (defun score-pnode (path pnode path-turn-number new-parent-pnode
  goal-row goal-column)
    "Update scores for PNODE. Update heap position if necessary."
    (let* ((direction (find-direction (pnode-column new-parent-pnode)
                                      (pnode-row new-parent-pnode)
                                      (pnode-column pnode)
                                      (pnode-row pnode)))
           (G (+ 1 (pnode-G new-parent-pnode)))
         
           (H (* (distance (pnode-column pnode)
                           (pnode-row pnode)
                           goal-column goal-row)
                 ;; (max (abs (- (pnode-row pnode) goal-row))
                 ;;     (abs (- (pnode-column pnode) goal-column)))
                 1))
           (F (+ G H)))
      ;; 
      ;; is this a new pnode, i.e. not on the open list? 
      (if (not (equal path-turn-number (pnode-open pnode)))
          ;;
          ;; yes, update its scores and parent
          (progn 
            (setf (pnode-G pnode) G)
            (setf (pnode-H pnode) H)
            (setf (pnode-F pnode) F)
            (setf (pnode-parent pnode) new-parent-pnode))
        ;;
        ;; no, it's already open. is the path through NEW-PARENT-PNODE
        ;; better than through the old parent?
        (if (and (pnode-G pnode)
                 (< G (pnode-G pnode)))
            ;;
            ;; yes. update scores and re-heap.
            (let ((heap (path-heap path))
                  (heap-end (path-end path))
                  (ptr 1)
                  (par nil)
                  (finished nil))
              (setf (pnode-G pnode) G)
              (setf (pnode-H pnode) H)
              (setf (pnode-F pnode) F)
              (setf (pnode-parent pnode) new-parent-pnode)
              ;;
              ;; Better score found.
              ;; 
              ;; find current location of pnode in heap
              (while (and (not finished) (< ptr heap-end))
                (when (equal pnode (aref heap ptr))
                  ;; Found pnode.
                  ;;
                  ;; its score could only go down, so move it up in the
                  ;; heap if necessary.
                  (while (and (not finished) (< 1 ptr))
                    (setf par (truncate (/ ptr 2)))
                    ;;
                    ;; should it rise? 
                    (if (< (pnode-F pnode) (pnode-F (aref heap par)))
                        ;;
                        ;; yes. swap it with its parent
                        (progn
                          (setf (aref heap ptr) (aref heap par))
                          (setf ptr par))
                      ;;
                      ;; no, we are done. put pnode in its new place.
                        (progn (setf finished t)
                               (setf (aref heap ptr) pnode))))
                  ;;
                  ;; do we need to install the new pnode as heap root?
                  (when (and (not finished) (equal 1 ptr))
                    (setf (aref heap 1) pnode)))
                ;;
                ;; keep scanning heap for the pnode
                (incf ptr)))
          ;;
          ;; new score is not better. do nothing.
                                          ;(setf (pnode-parent pnode) new-parent-pnode)
            ))))

Finding successor nodes in search

  (defun pnode-successors (path pnode path-turn-number goal-row
  goal-column)
    (delete nil 
          (mapcar 
           #'(lambda (direction)
               (let ((grid (path-grid path))
                     (new-G (+ 1 (pnode-G pnode)))
                     (successor nil))
                 (multiple-value-bind (r c) 
                     (step-in-direction 
                      (pnode-row pnode)
                      (pnode-column pnode)
                      direction)
                   ;; 
                   (if (array-in-bounds-p grid r c)
                       (progn 
                         (setf successor (aref grid r c))
                       
                         (if (or 
                              ;; always allow the goal square even when it's an obstacle.
                              (and (equal r goal-row) (equal c goal-column))
                              ;; ignore non-walkable squares and closed squares,
                              (and (not (obstructed path r c))
                                   (not (equal path-turn-number (pnode-closed successor)))))
                             ;; if successor is open and existing path is better
                             ;; or as good as new path, destroy the successor
                             ;; if successor is not open, proceed 
                             (if (equal path-turn-number (pnode-open successor))
                                 (if (< new-G (pnode-G successor))
                                     successor
                                     nil)
                                 successor)
                             nil))
                       nil))))
           *directions*)))

Core pathfinding routine

  (defun address-to-waypoint (path address)
    (destructuring-bind (row column) address
      (list (round (column-to-x path column))
            (round (row-to-y path row)))))

  (defun find-path (path x0 y0 x1 y1)
    (let* ((selected-pnode nil)
           (path-turn-number (incf (path-turn path)))
           (pos nil)
           (found nil)
           (path-height (path-height path))
           (path-width (path-width path))
           (buffer-height 720) ;;(slot-value (path-buffer path) 'width))
           (buffer-width 1280);; (slot-value (path-buffer path) 'height))
           (cx (/ buffer-width path-width))
           (cy (/ buffer-height path-height))
           (target-pnode nil)
           (coordinates nil)
           (F 0) (G 0) (H 0)
           (starting-row (round (/ y0 cy)))
           (starting-column (round (/ x0 cx)))
           (goal-row (round (/ y1 cy)))
           (goal-column (round (/ x1 cx))))
      (if (obstructed path goal-row goal-column)
          (prog1 nil) ;; (message "Not pathfinding to obstructed area.")
          (progn 
            ;; reset the pathfinding heap
            (setf (path-end path) nil)
            ;; add the starting pnode to the open set
            (setf G 0)
            (setf H (max (abs (- starting-row goal-row))
                         (abs (- starting-column goal-column))))
            (setf F (+ G H))
            (setf selected-pnode (make-pnode :row starting-row 
                                           :column starting-column
                                           :old-G 0
                                           :parent nil :G G :F F :H H))
            ;;
            (open-pnode path selected-pnode)
            ;; start pathfinding
            (setf target-pnode
                  (block finding
                    ;; select and close the pnode with smallest F score
                    (while (setf selected-pnode (close-pnode path))
                      ;; did we fail to reach the goal? 
                      (when (null selected-pnode)
                        (return-from finding nil))
                      ;; are we at the goal square?
                      (when (and (equal goal-row (pnode-row selected-pnode))
                                 (equal goal-column (pnode-column selected-pnode)))
                        (return-from finding selected-pnode))
                      ;; process adjacent walkable non-closed pnodes
                      (mapc #'(lambda (pnode)
                                ;; is this cell already on the open list?
                                (if (equal path-turn-number (pnode-open pnode))
                                    ;; yes. update scores if needed
                                    (score-pnode path pnode path-turn-number
                                                selected-pnode goal-row goal-column)
                                    (progn 
                                      ;; it's not on the open list. add it to the open list
                                      (score-pnode path pnode path-turn-number selected-pnode
                                                  goal-row goal-column)
                                      (open-pnode path pnode))))
                            ;; map over adjacent pnodes
                            (pnode-successors path selected-pnode 
                                             path-turn-number
                                             goal-row goal-column)))))
            ;; did we find a path? 
            (if (pnode-p target-pnode)
                ;; save the path by walking backwards from the target
                (let ((previous-pnode target-pnode)
                      (current-pnode nil)
                      (dirs nil))
                  (while (setf current-pnode (pnode-parent previous-pnode))
                    ;; what direction do we travel to get from current to previous? 
                    (push (list (pnode-row current-pnode)
                                (pnode-column current-pnode))
                          coordinates)
                    (push (find-direction
                           (pnode-column current-pnode)
                           (pnode-row current-pnode)
                           (pnode-column previous-pnode)
                           (pnode-row previous-pnode))
                          dirs)
                    (setf previous-pnode current-pnode))
                  ;; return the finished path
                  (values coordinates dirs))
                ;; return nil
                nil)))))
    
  (defun find-path-waypoints (path x0 y0 x1 y1)
    "Find a path from the starting point to the goal in PATH using A*.
  Returns a list of coordinate waypoints an AI can follow to reach the
  goal."
    (mapcar #'(lambda (address)
                (address-to-waypoint path address))
            (find-path path (truncate x0) 
                       (truncate y0)
                       (truncate x1)
                       (truncate y1))))

Optional debug printing

  ;; (defun print-path (foo stream) (format stream "#<% XELF PATH>"))

  ;; (defmethod print-object ((foo xelf::path) stream)
  ;;   (print-path foo stream))

TODO Buffer history

  (defvar *buffer-history* nil)

  (defun browse (name &optional class)
    (let ((page (find-buffer name :class class)))
      (when page
        (push name *buffer-history*)
        (at-next-update (start-alone page)))))

  (defun back ()
    (let ((name (pop *buffer-history*)))
      (when name
        (at-next-update 
         (start-alone (find-buffer name))))))

TODO Networking

Client/server architecture

UPnP (Universal Plug and Play) configuration

Author: David O'Toole <dto@xelf.me>

Created: 2017-05-03 Wed 16:01

Validate