Navigation Menu

Skip to content

Instantly share code, notes, and snippets.

@kilon

kilon/rlx.el

Forked from dto/rlx.el
Created November 19, 2012 18:54
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save kilon/4112846 to your computer and use it in GitHub Desktop.
Save kilon/4112846 to your computer and use it in GitHub Desktop.
Download ZIP
RLX, early elisp prototype of Blocky
Raw
rlx.el
;;; rlx.el --- RLX development tools for GNU Emacs
;; Copyright (C) 2006, 2007, 2008 David O'Toole
;; Author: David O'Toole <dto@gnu.org>
;; Keywords: multimedia, games
;; Version: 0.81
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; This file 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 General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;; This file is NOT part of GNU Emacs.
;;; User configuration variables
(defvar rlx-cache-directory "~/.rlx/"
"Directory where cached images and savegames are stored.")
(defvar rlx-data-directory "~/rlx/"
"Base directory for installed games.")
(defvar rlx-convert-program "convert"
"Name of convert program.")
(defvar rlx-mode-map nil "Mode keymap for rlx-mode.
This is filled in by (rlx-load-keymap)")
;; (@* "Resetting the engine and loading a game")
(defun rlx-reset ()
"Reset the game console, clear all caches, and prepare to load a new game."
(interactive)
(setf rlx-tiles (make-hash-table :test 'equal))
(setf rlx-prototypes (make-hash-table :test 'equal))
(setf rlx-maps (make-hash-table :test 'equal))
(setf rlx-current-world nil)
;;
;; register some built-in prototypes
(rlx-register-prototype "BlueAsterisk" rlx-blue-asterisk)
;;
;; create cache directory if it doesn't exist
(if (not (file-exists-p rlx-cache-directory))
(make-directory rlx-cache-directory)
(if (not (file-directory-p rlx-cache-directory))
(error "Cache %S must be a directory." rlx-cache-directory))))
(defun rlx-set-game-paths (game-name)
(rlx-reset)
(setf rlx-current-game game-name)
(setf rlx-current-game-data-directory
(file-name-as-directory (concat (file-name-as-directory rlx-data-directory)
game-name))))
(defun rlx-load-game (game-name)
"Load resources for game GAME-NAME."
(interactive "sGame name: ")
(rlx-reset)
(rlx-set-game-paths game-name)
;;
;; load the .rlx.el file
(load (concat rlx-current-game-data-directory game-name ".rlx")))
(defun rlx-start-game (game-name)
(interactive)
(rlx-load-game game-name)
(funcall rlx-current-game-start-function))
(defun rlx-load-start-function (start-function)
(setf rlx-current-game-start-function start-function))
;; (@* "The RLX Universe")
;;
;; Play occurs in a rectangular grid of cells. Cells represent all
;; game objects, events, and interactions. Cells may be stacked on top
;; of one another and may even contain other cells. The properties of
;; cells determine their appearance and behavior. Cells interact by
;; sending messages to one another.
;;
;; Aggregates of cells (other than simple aggregates like containers)
;; fit into a hierarchy:
;;
;; A "map" is a rectangular grid of cells meant to be pieced together
;; at the edges with other maps in order to construct a building,
;; dungeon, or some other such structure based on arranging patterns
;; according to a fixed set of rules.
;;
;; A "metamap" is a grid of maps generated according to rules set by
;; the map designer. These are expanded into full grids, and can be
;; painted onto a world under construction. See (@> "Metamaps")
;;
;; A "world" is a playable grid with attached information regarding
;; current players, lighting, rendering, elapsed turns, narration, and
;; a heads-up display (hud). RLX is designed to display and compute
;; one world at a time, which is generally about all the machine can
;; handle. See (@> "Worlds")
;;
;; A "metaworld" is a grid of worlds, each of which may be generated,
;; loaded from disk, and saved on-demand as the player enters and
;; leaves different parts of the metaworld. See (@> "Metaworlds")
;;
;; RLX cells are simply lisp property lists. As such, they may contain
;; any number of named properties whose values may be any lisp object
;; with read syntax. (This restriction is important for saved game
;; state.)
;;
;; Certain properties are interpreted specially by the engine. These
;; are described in the section (@> "Cells")
;;
;; Except for the property :type, which is described in the following
;; section.
;;
;; (@* "Cell types")
;;
;; A cell's type is a set of keyword symbols identifying its
;; membership in particular categories. A cell may have any number of
;; category symbols in this set.
;; The following special types are interpreted by the engine:
;; :player
;; (@> "players")
;;
;; This cell is a player character, and is controlled by the user.
;; :item
;; (@> "inventorying")
;;
;; This cell is a potential inventory item. Of course, other factors
;; defined by the game logic may prevent a player from picking up a
;; particular item (insufficient strength, for example.)
;; :builtin
;;
;; This cell cannot be moved out of inventory or equipment. This is used
;; to define innate capabilities of character cells.
;; :obstacle
;; (find-function 'rlx-grid-move-cell)
;;
;; The cell blocks player/enemy movement and cannot have objects dropped
;; on it.
;; :opaque
;; (@> "line-of-sight")
;; (find-function 'rlx-sight)
;;
;; The cell blocks line-of-sight and casts shadows when in the field of a
;; point light source.
;; :proxy
;; (@> "proxies")
;;
;; The cell is a proxy for another cell.
;; :container
;; (@> "Containers")
;;
;; The cell contains other cells.
;; :light-source
;; (@> "lighting")
;;
;; The cell is a light source. See also the cell property :light-radius.
(defsubst rlx-type (cell)
(getf cell :type))
(defsubst rlx-in-category (cell category)
(memq category (getf cell :type)))
(defsubst rlx-put-category (cell category)
(setf (getf cell :type) (union (list category) (getf cell :type))))
(defsubst rlx-delete-category (cell category)
(setf (getf cell :type) (delq category (getf cell :type))))
(defsubst rlx-first-in-category (cells category)
"Return the first cell in CELLS in category CATEGORY, otherwise nil."
(find-if (lambda (c)
(memq category (getf c :type)))
cells))
;; (@* "Cell prototypes")
(defvar rlx-prototypes nil
"Hash table mapping string prototype names to prototype cells.")
(defun rlx-register-prototype (prototype-name cell &optional IGNORE)
(puthash prototype-name cell rlx-prototypes))
(defun rlx-get-prototype (prototype-name)
(gethash prototype-name rlx-prototypes))
(defun rlx-clone (prototype-name)
(let ((prototype (gethash prototype-name rlx-prototypes)))
(when (null prototype)
(error "No such prototype %s" prototype-name))
(copy-tree prototype)))
;; The following macro processes cell definitions into something RLX
;; can understand, save, and load. For prototype Foo we create a
;; symbol --RLX-Foo to hold the event function.
(defmacro defcell (name &rest properties)
(labels ((RLX-process-cell (N C)
`(progn
(let* ((--cell ',C)
(--edec (getf --cell :event)))
(when (getf --cell :event)
;;
;; replace declaration in plist with symbol --RLX-Foo
;;
(plist-put --cell :event ',(intern (concat "--RLX-" N)))
;;
;; define --RLX-Foo by processing declaration
;;
(progn
(defun ,(intern (concat "--RLX-" N)) (self action other detail world)
(let ((--result nil))
(cond
;;
;; try elements of declaration until one processes the event.
;; now we produce clauses of the cond from the declaration list.
;; the lambda below processes each in turn.
;;
,@(append (mapcar (lambda (E)
(let* ((T (car E))
(B (cdr E))
(action (car B))
(body (cdr B))
(inner-wrapped
;;
;; determine what kind of spec it is, and process it
;;
(cond
((eq 'import T)
`(setf --result (funcall ',(intern (concat "--RLX-B-" (symbol-name action)))
self action other detail world)))
((eq 'override T)
`(setf --result (if (eq action ,action)
(list :no-default (progn ,@body))
:does-not-understand)))
((eq 'respond T)
`(setf --result (if (eq action ,action)
(progn ,@body)
:does-not-understand))))))
;;
;; compose a clause for the output cond
;;
(list `(not (eq :does-not-understand ,inner-wrapped)) `--result)))
;;
;; map over event declaration
;;
(getf C :event))
;;
;; compose default clause for the output cond
;;
(list (list t :does-not-understand))))))))
;;
;; register (possibly modified) prototype with RLX at run time
;;
(rlx-register-prototype ,N --cell)))))
;;
;;
(RLX-process-cell `,name `,properties)))
;; to debug the expansion, change that last line to
;; `(RLX-process-cell ,name ',properties)))
;; and use cl-prettyexpand
;; The following macro is used to write stand-alone behavior functions
;; that are to be composed with other behavior functions using the
;; IMPORT directive in a defcell declaration's event portion.
(defmacro defbehavior (name &rest body)
`(defun ,(intern (concat "--RLX-B-" (symbol-name name))) (self action other detail world)
,@body))
(defmacro defmap (name grid properties)
`(rlx-register-map ,name ,(make-rlx-map :properties properties :grid grid)))
;; (@* "Grid operations")
(defun rlx-make-grid (rows cols)
(let ((grid (make-vector rows nil)))
(dotimes (row rows)
(setf (aref grid row) (make-vector cols nil)))
grid))
(defsubst rlx-grid-get (grid row col)
(aref (aref grid row) col))
(defsubst rlx-grid-set (grid row col value)
(let ((row (aref grid row)))
(setf (aref row col) value)))
(defsubst rlx-grid-columns (grid)
(length (aref grid 0)))
(defsubst rlx-grid-rows (grid)
(length grid))
(defsubst rlx-bounds-check (grid row column)
(not (or (< row 0) (< column 0)
(>= row (rlx-grid-rows grid))
(>= column (rlx-grid-columns grid)))))
;; (@* "More advanced grid operations")
(defsubst rlx-grid-put-property (grid row column cell property value)
(let ((new-cell (plist-put cell property value)))
(rlx-grid-replace grid row column cell new-cell)))
(defun rlx-grid-drop (grid row col cell &optional no-collisions)
"Drop a CELL onto the GRID at element ROW COL, going on top of
any cells already there. Update CELL's location. Return CELL. If
NO-COLLISIONS is set, fail and return nil when trying to drop an
object on top of an obstacle."
;; bounds check
(if (or (< row 0) (>= row (rlx-grid-rows grid))
(< col 0) (>= col (rlx-grid-columns grid)))
(progn
(message "Placing object off of map.")
nil)
;; drop it!
(let ((element (rlx-grid-get grid row col))
(placed nil))
(if (null element)
;; make it the only cell on that element
(setf element (list cell))
;; drop the cell on top of existing cells,
;; possibly checking for collisions
(cond
((and no-collisions (not (rlx-first-in-category element :obstacle)))
(setf element (append element (list cell)))
(setf placed t))
((not no-collisions)
(setf element (append element (list cell)))
(setf placed t))
(t nil)))
;;
;; place object if everything is ok
(if placed
(progn
(rlx-grid-set grid row col element)
(plist-put cell :row row)
(plist-put cell :column col)
cell)
nil))))
(defun rlx-grid-drop-under-top (grid row col cell)
"Drop a CELL onto GRID at location ROW COL, going just
underneath the top cell."
(let ((top-cell (rlx-grid-top-cell grid row col)))
;; pop the top
(rlx-grid-delete grid row col top-cell)
;; drop the cell
(rlx-grid-drop grid row col cell)
;; replace the top
(rlx-grid-drop grid row col top-cell)))
(defun rlx-grid-replace (grid row column old-cell new-cell &optional no-holes)
"Replace OLD-CELL with NEW-CELL at ROW, COLUMN. Update position
of NEW-CELL. When NO-HOLES is set, don't replace ground cells, instead
dropping the item on top of the ground."
;; bounds check
(if (or (< row 0) (>= row (rlx-grid-rows grid))
(< column 0) (>= column (rlx-grid-columns grid)))
(message "Placing object off of map.")
(let* ((element (rlx-grid-get grid row column))
(pos (position old-cell element)))
(plist-put new-cell :row row)
(plist-put new-cell :column column)
(cond
;; set as only element
((null element)
(setf element (list new-cell)))
;; avoid holes; drop on ground
((and no-holes (eq 1 (length element)))
(setf element (append element (list new-cell))))
;; insert into list
(t (setcar (nthcdr pos element) new-cell)))
(rlx-grid-set grid row column element))))
(defun rlx-grid-replace-top-no-holes (grid row column new-cell)
"Replace the topmost cell at ROW, COLUMN in GRID. Don't replace
ground cells."
(rlx-grid-replace grid row column
(rlx-grid-top-cell grid row column)
new-cell
'no-holes))
(defun rlx-grid-replace-top (grid row column new-cell)
"Replace the topmost cell at ROW, COLUMN in GRID."
(rlx-grid-replace grid row column
(rlx-grid-top-cell grid row column)
new-cell))
(defun rlx-grid-replace-all (grid row column cells)
"Replace all cells at position ROW, COLUMN in GRID with CELLS.
Updates position of CELLS."
(rlx-grid-set grid row column
(mapc (lambda (c)
(plist-put c :row row)
(plist-put c :column column))
cells)))
(defun rlx-grid-delete (grid row column cell)
"Delete the CELL from GRID at ROW COLUMN."
(let ((element (rlx-grid-get grid row column)))
(rlx-grid-set grid row column (delq cell element))))
(defsubst rlx-grid-delete-cell (grid cell)
(rlx-grid-delete grid (getf cell :row) (getf cell :column) cell)
(setf (getf cell :row) nil)
(setf (getf cell :column) nil))
(defun rlx-grid-top-cell (grid row column)
"Obtain a reference to the topmost cell at ROW, COLUMN in GRID."
;; bounds check
(when (not (or (< row 0) (>= row (rlx-grid-rows grid))
(< column 0) (>= column (rlx-grid-columns grid))))
(car (last (rlx-grid-get grid row column)))))
(defun rlx-grid-top-cell-in-direction (grid row column direction)
"Obtain a reference to the topmost cell a step in DIRECTION from ROW, COLUMN."
(destructuring-bind (r c) (rlx-step-in-direction row column direction)
(rlx-grid-top-cell grid r c)))
(defun rlx-grid-move-cell (grid cell from-row from-column to-row to-column)
"Move a CELL from one location to another within GRID, checking
to see if the destination blocks movement."
(if (or (< to-row 0) (>= to-row (rlx-grid-rows grid))
(< to-column 0) (>= to-column (rlx-grid-columns grid)))
nil
(progn
(let ((from-cells (rlx-grid-get grid from-row from-column))
(to-cells (rlx-grid-get grid to-row to-column))
(blocked nil))
;;
;; trap errors; don't move cell away from wrong grid location
(if (member cell from-cells)
;;
;; if not blocked, move the cell
(when (not (rlx-first-in-category to-cells :obstacle))
(setf from-cells (delq cell from-cells))
(rlx-grid-set grid from-row from-column from-cells)
(rlx-grid-drop grid to-row to-column cell)
(plist-put cell :row to-row)
(plist-put cell :column to-column))
)))))
(defun rlx-grid-underneath (grid cell)
(let ((cells (rlx-grid-get grid (getf cell :row) (getf cell :column)))
(current-cell nil)
(previous-cell nil))
(while (car-safe cells)
(setf previous-cell current-cell)
(setf current-cell (pop cells)))
previous-cell))
;; (@* "Painting one grid onto another")
(defun rlx-grid-paint-map (grid map row column)
"Drop the elements of MAP onto GRID starting at ROW, COLUMN."
(let ((cells nil)
(cell nil))
(dotimes (r (rlx-grid-rows map))
(dotimes (c (rlx-grid-columns map))
(setf cells (rlx-grid-get map r c))
(when cells
(while (setf cell (pop cells))
(rlx-grid-drop grid
(+ r row)
(+ c column)
(copy-tree cell))))))))
;; (@* "Measuring distances in the grid")
;; The ordinary distance formula\footnote{http://en.wikipedia.org/wiki/Distance}
;; is used.
(defsubst rlx-distance (x1 y1 x2 y2)
(let ((delta-x (- x2 x1))
(delta-y (- y2 y1)))
(sqrt (+ (* delta-x delta-x) (* delta-y delta-y)))))
;; (@* "Compass directions")
(defvar rlx-compass-directions (list :north :south :east :west
:northeast :southeast
:northwest :southwest))
(defvar rlx-compass-opposites (list :north :south
:south :north
:east :west
:west :east
:northeast :southwest
:southwest :northeast
:southeast :northwest
:northwest :southeast))
(defsubst rlx-opposite-direction (direction)
(getf rlx-compass-opposites direction))
(defsubst rlx-step-in-direction (row column direction)
"Return the point ROW, COLUMN moved by one square in DIRECTION
as a list (row2 column2)."
(case direction
(:north (list (- row 1) column))
(:south (list (+ row 1) column))
(:east (list row (+ column 1)))
(:west (list row (- column 1)))
(:northeast (list (- row 1) (+ column 1)))
(:northwest (list (- row 1) (- column 1)))
(:southeast (list (+ row 1) (+ column 1)))
(:southwest (list (+ row 1) (- column 1)))
(t (error "Direction not valid: %S" direction))))
(defsubst rlx-cells-in-direction (world cell direction)
(let ((pt (rlx-step-in-direction (getf cell :row)
(getf cell :column)
direction)))
(destructuring-bind (r c) pt
(rlx-grid-get (rlx-world-grid world) r c))))
(defsubst rlx-top-cell-in-direction (world cell direction)
"Return the top cell in WORLD in direction DIRECTION from CELL.
Cells can use this to check out their local environment."
(car-safe (last (rlx-cells-in-direction world cell direction))))
(defsubst rlx-direction-to (r1 c1 r2 c2)
"Return general direction of ray from R1,C1 to R2,C2."
;;
(if (< r1 r2) ; definitely to the south
(if (< c1 c2)
:southeast
(if (> c1 c2)
:southwest
:south))
(if (> r1 r2) ;; definitely to the north
(if (< c1 c2)
:northeast
(if (> c1 c2)
:northwest
:north))
;; rows are equal; it's either east or west
(if (< c1 c2)
:east
:west))))
;; (@* "Functions that trace shapes")
;;
;; rlx-trace-* These functions accept a TRACE-FUNCTION as the first
;; argument. TRACE-FUNCTION should accept 2 arguments:
;; ROW and COLUMN, and return NIL if tracing should continue,
;; non-nil if tracing should terminate.
;;
;; rlx-fill-* Like rlx-trace-*, but fill the shape.
;;
;; rlx-paint Generic function for combining trace functions and paint
;; functions that actually paint with cells.
;; In this case the paint functions are things like
;; (rlx-grid-drop) and (rlx-grid-replace-top-no-holes)
(defun rlx-trace-rectangle (trace-function row column height width)
"Call TRACE-FUNCTION for each point on the rectangle of HEIGHT
and WIDTH with top left corner at ROW COLUMN."
(block tracing
(dotimes (r height)
;; Are we painting a horizontal?
(if (or (equal r 0) (equal r (- height 1)))
(dotimes (c width)
(when (funcall trace-function (+ r row) (+ c column))
(return-from tracing)))
;; no, it's a row with only verticals
(when (or (funcall trace-function (+ r row) column)
(funcall trace-function (+ r row) (+ width column -1)))
(return-from tracing))))))
(defun rlx-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."
;;
;; 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)))))
(defsubst rlx-paint (grid cell paint-function trace-with &rest args)
"Call PAINT-FUNCTION for each point in set traced by TRACE-WITH to paint CELL in GRID.
CELL is cloned for each point traced."
(apply trace-with (cons (lambda (rowx colx)
(funcall paint-function grid rowx colx (copy-tree cell))
nil)
args)))
(defsubst rlx-collect-points (trace-with &rest args)
"Collect into a list the points traced by TRACE-WITH when
called with ARGS."
(lexical-let ((points nil))
(apply trace-with (cons (lambda (r c)
(push (list r c) points)
nil)
args))
(nreverse points)))
;;;; (@* "Line of sight")
;;
;; We use Bresenham's line
;; algorithm\footnote{http://en.wikipedia.org/wiki/Bresenham's\_line\_algorithm}
;; to trace out the player's field of vision and determine where
;; shadows should go.
(defun rlx-trace-line (trace-function x0 y0 x1 y1)
"Trace a line between X0,Y0 and X1,Y1.
executing TRACE-FUNCTION at each point of the line.
Returns non-nil if tracing was successful, and nil if failed."
(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
(when (> x0 x1)
(rotatef x0 x1)
(rotatef y0 y1))
;;
;; set up variables
(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
(block tracing
(while (/= x x1)
;; 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 nil))
(incf err delta-err)
(when (>= err 0.5)
(incf y step-y)
(decf err 1.0))
;; for next iteration
(incf x))
;;
;; success
(return-from tracing t)))))
(defun rlx-sight (grid r0 c0 r1 c1)
"Determine whether a line of sight exists between r0, c0
and r1, c1 in GRID."
;; every cell has a line of sight to itself
(if (and (eq r0 r1) (eq c0 c1))
t
(funcall 'rlx-trace-line
;; test traced cells for opaqueness
(lambda (r c)
(if (rlx-first-in-category (rlx-grid-get grid r c)
:opaque)
;; we want to always allow opaque cells to
;; themselves be targets, so ignore last cell's opaqueness
(if (and (eq r1 r) (eq c1 c))
nil
t)
nil))
;; note: rlx-trace-line takes arguments in x,y order
c0 r0 c1 r1)))
(defsubst rlx-sight-cells (grid from to)
"Determine whether a line of sight exists between cell FROM and cell TO."
(rlx-sight grid
(getf from :row)
(getf from :column)
(getf to :row)
(getf to :column)))
;; (@* "Rendering terrain with plasma fractals")
;;
;; The following routines create random midpoint displacement
;; fractals\footnote{http://www2.vo.lu/homepages/phahn/fractals/plasma.htm}
;; on a grid. This can be used to render relatively smooth terrain.
;;
;; First comes the midpoint
;; formula\footnote{http://en.wikipedia.org/wiki/Midpoint}
(defsubst rlx-midpoint (A B)
(list (/ (+ (first A) (first B)) 2)
(/ (+ (second A) (second B)) 2)))
;; We need an representation for a rectangle that is appropriate to
;; our problem. Then we must allow recursive subdivision of
;; rectangles.
(defstruct rect
A B C D)
(defsubst rlx-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 (rect-A R))
(B (rect-B R))
(C (rect-C R))
(D (rect-D R)))
;; are they too small?
(if (> 2 (abs (- (first C) (first A))))
nil
(let
((R1 (make-rect :A A
:B (rlx-midpoint A B)
:C (rlx-midpoint A C)
:D (rlx-midpoint A D)))
;;
(R2 (make-rect :A (rlx-midpoint A B)
:B B
:C (rlx-midpoint B C)
:D (rlx-midpoint B D)))
;;
(R3 (make-rect :A (rlx-midpoint A C)
:B (rlx-midpoint B C)
:C C
:D (rlx-midpoint C D)))
;;
(R4 (make-rect :A (rlx-midpoint A D)
:B (rlx-midpoint B D)
:C (rlx-midpoint C D)
:D D)))
(list R1 R2 R3 R4)))))
(defun rlx-plasma (grid graininess)
"Fill GRID with floats representing plasma of GRAININESS."
(let* ((A (list 0 0))
(B (list 0 (- (rlx-grid-rows grid) 1)))
(C (list (- (rlx-grid-columns grid) 1) 0))
(D (list (- (rlx-grid-columns grid) 1) (- (rlx-grid-rows grid) 1)))
(Rs (list (make-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
;;
(mapc (lambda (P)
(rlx-grid-set grid (second P) (first P) (random* graininess)))
(list A B C D))
;;
;; begin processing rectangles and painting plasma
;;
(while (setf R (pop Rs))
;;
;; subdivide rectangle R and push results onto the rectangle list Rs
(setf Ss (rlx-subdivide-rect R))
(when Ss
(while (setf S (pop Ss))
(push S Rs)))
;;
;; calculate values for midpoints and center of current rectangle R
(setf A (rect-A R))
(setf B (rect-B R))
(setf C (rect-C R))
(setf D (rect-D R))
(setf rect-width (abs (- -1 (first C) (first A))))
;;
(mapc (lambda (pair)
(let* ((P1 (first pair))
(P2 (second pair))
(M (rlx-midpoint P1 P2))
(V (+
;; average value of values at P1 and P2
(* 0.5
(+ (rlx-grid-get grid (second P1) (first P1))
(rlx-grid-get 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
(rlx-grid-set grid (second M) (first M) V)))
;;
;; map over all four edge midpoints and the center
(list (list A B) (list A C) (list B D) (list C D) (list A D))))))
;; (@* "Metamaps")
;;
;; Maps are grids of cells with a bit of attached information about
;; how the map can be made to fit together with other maps.
;;
;; Metamaps are grids of maps. The following routines can piece
;; together a metamap out of maps, joining the pieces together
;; according to the properties you set, and then expanding the metamap
;; into a grid suitable for overlaying onto an rlx-world structure.
(defvar rlx-maps nil "Hash table mapping map names to map objects.")
(defstruct rlx-map
grid ; a grid structure holding lists of cells, as with rlx-world
properties ; property list with properties :north :south :east
; :west. The values are lists of keyword symbols. Two
; maps can join when their matching edges have at least
; one symbol in common (see rlx-map-match below.)
; Optional properties are :terminator (which tells
; whether a given map would cleanly close off a branch of
; the building), :probability, an integer between 0 and
; 100 that controls the frequency of appearance, and
; :max-appearances, which determines the maximum number
; of times a map may appear in a given metamap.
;; now comes some bookkeeping variables for the metamap routines.
appearances
)
(defun rlx-register-map (name map)
(puthash name map rlx-maps))
(defun rlx-get-map (name)
(gethash name rlx-maps))
(defun rlx-map-match (metamap new-map row column &optional terminating)
"Return NEW-MAP if NEW-MAP can fit into METAMAP at ROW, COLUMN,
nil otherwise. When TERMINATING is non-nil, only match with terminating tiles."
(let* ((null-map (make-rlx-map :grid nil :properties '(:north nil :south nil :east nil :west nil)))
(current-location nil)
(locations
(delq nil
(mapcar (lambda (dir)
(let* ((loc (rlx-step-in-direction row column dir))
(r (first loc))
(c (second loc)))
(list dir r c)))
(list :north :south :east :west)))))
;;
;; attempt to match each edge by checking edges of adjacent cells
(block matching
(while (setf current-location (pop locations))
(let* ((edge (first current-location))
(r (second current-location))
(c (third current-location))
(map (if (and (<= 0 r) (<= 0 c)
(> (rlx-grid-columns metamap) c)
(> (rlx-grid-rows metamap) r))
(rlx-grid-get metamap r c)
null-map)))
(when map
;; can we match here?
(if (and
;; don't match non-terminating tiles if we are terminating
(if terminating
(getf (rlx-map-properties new-map) :terminator)
(not (getf (rlx-map-properties new-map) :terminator)))
;;
(or
;; nil means it can match other nils
(and (equal nil (getf (rlx-map-properties map)
(rlx-opposite-direction edge)))
(equal nil (getf (rlx-map-properties new-map)
edge)))
;; otherwise check if they have any symbols in common.
(intersection (getf (rlx-map-properties new-map) edge)
(getf (rlx-map-properties map)
(rlx-opposite-direction edge)))))
(progn
(message "MATCH: ---- %S //// %S"
(getf (rlx-map-properties new-map) edge)
(getf (rlx-map-properties map)
(rlx-opposite-direction edge)))
;; we have a match on this edge.
new-map)
;; no match. die now.
(return-from matching nil)))))
;;
;; we examined all the edges and none failed. yay!
(return-from matching new-map))))
(defun rlx-build-metamap (maps seed-map num-steps &optional
metamap-rows metamap-columns seed-row seed-column)
"Grow a map of size METAMAP-ROWS x METAMAP-COLUMNS from the set
MAPS for NUM-STEP generations, starting with SEED-MAP at
SEED-ROW, SEED-COLUMN. Return the resulting composed grid, or nil
if arrangement failed."
(let* ((step num-steps)
(map-size (rlx-grid-rows (rlx-map-grid seed-map)))
(metamap-rows (or metamap-rows num-steps))
(metamap-columns (or metamap-columns num-steps))
(seed-row (or seed-row 0))
(seed-column (or seed-column 0))
(metamap (rlx-make-grid metamap-rows metamap-columns))
(final-grid-rows (* map-size metamap-rows))
(final-grid-columns (* map-size metamap-columns))
(final-grid (rlx-make-grid final-grid-rows final-grid-columns))
(current-metamap-row nil)
(current-metamap-column nil)
(current-metamap-location nil)
(remaining nil)
(terminating nil))
;;
;; reset appearance counts of maps
(dolist (m maps)
(setf (rlx-map-appearances m) 0))
;;
;; place seed in metamap
;;
(setf current-metamap-row seed-row)
(setf current-metamap-column seed-column)
(rlx-grid-set metamap
seed-row
seed-column
seed-map)
;;
(incf (rlx-map-appearances seed-map))
;;
(push (list current-metamap-row current-metamap-column) remaining)
;;
;; do additions to grow out from seed
;;
(block building
(while (setf current-metamap-location (pop remaining))
;;
(setf current-metamap-row (first current-metamap-location))
(setf current-metamap-column (second current-metamap-location))
;;
;; fill any blank adjacent cells in metamap with matching stuff
;;
(mapc (lambda (direction)
(let* ((matches nil)
(location (rlx-step-in-direction current-metamap-row
current-metamap-column
direction))
(r (first location))
(c (second location)))
;; bounds check
(when (and (<= 0 r) (<= 0 c)
(> metamap-columns c)
(> metamap-rows r))
;;
;; check if the square can connect to anything useful in this direction.
;; this keeps buildings connected internally.
(when (getf (rlx-map-properties (grid-get metamap
current-metamap-row
current-metamap-column)) direction)
;;
;; is the square already filled?
(when (null (rlx-grid-get metamap r c))
;;
;; find out which maps match
(setf matches (delq nil (mapcar (lambda (m)
(rlx-map-match metamap m r c terminating))
maps)))
;;
;; remove maps from candidate list when
;; they've appeared the maximum number of
;; times
(setf matches (remove-if (lambda (m)
(if (getf (rlx-map-properties m) :max-appearances)
(if (>= (rlx-map-appearances m)
(getf (rlx-map-properties m) :max-appearances))
t
nil)
;; don't remove when there is no max
nil))
matches))
(when (null matches)
(message "No match for map at %S %S" r c))
;;
;; choose one randomly and paint it
(when matches
(let ((index (random* (length matches))))
(rlx-grid-set metamap r c (nth index matches))
;;
;; handle the painted location
(setf remaining (append remaining (list location)))
;;
;; update appearance count
(incf (rlx-map-appearances (nth index matches)))
(if (>= 1 step)
(setf terminating t)
(decf step)))))))))
;;
;; map over compass directions
(list :north :south :east :west))
))
;;
;; expand metamap into final grid
(let ((element nil))
(dotimes (r (rlx-grid-rows metamap))
(dotimes (c (rlx-grid-columns metamap))
(let* ((M (rlx-grid-get metamap r c))
(final-row (* map-size r))
(final-column (* map-size c)))
(when M
(dotimes (Mr (rlx-grid-rows (rlx-map-grid M)))
(dotimes (Mc (rlx-grid-columns (rlx-map-grid M)))
(setf element (rlx-grid-get (rlx-map-grid M) Mr Mc))
(when element
(rlx-grid-set final-grid
(+ final-row Mr)
(+ final-column Mc)
(rlx-grid-get (rlx-map-grid M) Mr Mc))))))))))
;;
;; return final grid
final-grid))
;; (@* "Asterisks")
;;
;; Asterisks are cells used to mark and modify maps. Asterisk cells
;; can be defined and placed into maps using rlx-studio.
;;
;; On its first turn, a blue asterisk cell replaces itself with a cell
;; randomly chosen from a set of prototype names stored in its
;; :replacements property. This is used to make sure that random items
;; go in certain places, and that each place may have a particular set
;; of items from which the random selection is made.
;;
;; Red asterisks can represent special event cells that should be
;; invisible to the player---for example, a timer cell could be placed
;; in the world to start some event happening after a certain period
;; is elapsed. Or you may want to mark a certain doorway as impassable
;; to vehicles, so you put an asterisk on the floor that blocks
;; movement if the player is a vehicle. In any case, the asterisks
;; should be visible in the editor but not to the player.
;;
;; I might implement more asterisk types in the future.
(defun rlx-blue-asterisk-event (self action other detail world)
(when (equal action :turn)
(let* ((replacements (getf self :replacements))
(new-object nil))
(if replacements
(progn
(setf new-object (rlx-clone (nth (random* (length replacements))
replacements)))
`(:to ,self :from ,new-object :action :replace-self))
nil))))
(defvar rlx-blue-asterisk '(:tile
"blue-asterisk"
:event
rlx-blue-asterisk-event
:replacements nil))
;; (@* "Metaworlds")
;;
;; Metaworlds are grids of (@> "worlds"). You can use this to
;; implement an entire planet to explore. For something this size,
;; generating and expanding the entire grid at once would take too
;; long and might cause Emacs to explode. Instead we generate a sketch
;; of the planet by filling in each square with a function and a list
;; of arguments. Together these describe a process for generating the
;; appropriate world (or loading it from disk, when it has already
;; been generated.) When the square is first visited by the player,
;; the function is applied to its arguments, and returns the new world
;; structure for play.
;;
;; To generate a semi-realistic planet surface, you could map the
;; output values from rlx-plasma onto a set of world generation
;; functions and appropriate argument lists, which are stored in the
;; squares of the metaworld. These functions can then in turn generate
;; plasma terrain appropriate for the latitude and longitude within
;; the metaworld, overlaying buildings, objects, and whatever else is
;; required.
;; (@* "Graphical tiles to represent cells")
;; We need an indexed cache of tiles, and several routines to find
;; tiles on disk.
(defvar rlx-tiles nil
"A hash table mapping tile names to image objects. Tile names
may be combined with an underscore as the delimiter, in which
case the images are composited and the composite name maps to the
composite image.")
(defsubst rlx-tile-composite-p (tile-name)
"Returns t if TILE-NAME is composite, nil otherwise."
(equal "_" (substring tile-name 0 1)))
(defsubst rlx-tile-filename (tile-name)
"Get the filename for a given tile."
(let ((directory (if (rlx-tile-composite-p tile-name)
rlx-cache-directory
rlx-current-game-data-directory)))
(expand-file-name (concat (file-name-as-directory directory)
tile-name
".png"))))
;; The graphics library
;; ImageMagick\footnote{http://www.imagemagick.org} must be installed
;; for RLX to display properly. The following routines maintain a
;; cache of such tiles, and a mapping from lists of tiles to composite
;; tiles (i.e. tiles whose pixels have been composited together with
;; ImageMagick.)
(defsubst rlx-compose-tile-name (cells)
"Compose a tile name from all the tiles in the list CELLS. The
result may or may not be a composite tile name (i.e. a tile name
starting with an underscore.)"
(let* ((tile-names (delq nil (mapcar (lambda (e)
(getf e :tile))
cells)))
(tiles-count (length tile-names)))
(cond
((equal 0 tiles-count)
"Black")
((equal 1 tiles-count)
(car tile-names))
((> tiles-count 1)
(apply 'concat (mapcar (lambda (e)
(concat "_" e))
tile-names))))))
(defsubst rlx-compose-tile (cells)
"Compose a PNG image from all the tiles in the list CELLS. The syntax is
convert 1.png 2.png -composite 3.png -composite 4.png -composite ..."
(let* ((input-tiles (delq nil (mapcar (lambda (e)
(rlx-tile-filename (getf e :tile)))
cells)))
(output-tile (rlx-tile-filename (rlx-compose-tile-name cells)))
(im-commands (append (list (first input-tiles))
(mapcan (lambda (f)
(list f "-composite"))
(rest input-tiles)))))
(apply 'call-process
`(,rlx-convert-program nil nil nil
,@im-commands
,output-tile))))
(defsubst rlx-tile-image (tile-name &optional cells)
"Return the image object for a given tile. Images are loaded on
demand. If the tile is composite, render and cache the composite
image based on the CELLS."
(let ((image (gethash tile-name rlx-tiles)))
(when (null image)
(when (rlx-tile-composite-p tile-name)
;; render composite image
(rlx-compose-tile cells))
;; load image into cache
(let ((tile-file (rlx-tile-filename tile-name)))
(progn
(setf image (create-image tile-file nil nil
:ascent 'center))
(puthash tile-name image rlx-tiles))))
;; return image object
image))
;; (@* "Rendering a grid of tiles into a buffer")
;; I wrote my own insert-image function when it turned out that
;; rlx-render-world is just about the most time-consuming function in
;; RLX. I adapted this code from {\tt image.el} so that i could
;; simplify it and make it inline. (According to the Emacs Lisp
;; Manual, function calls are slow in emacs lisp, even between
;; compiled functions.)
(defsubst rlx-insert-image (image)
(let ((start (point)))
(insert " ")
;; cons up a new image spec; see emacs' image.el.gz
(setq image (cons 'image (cdr image)))
(add-text-properties start (point)
(list 'display image 'rear-nonsticky t))))
(defsubst rlx-insert-blank ()
(rlx-insert-image (rlx-tile-image "Black")))
;; I use the function below after tiles are already rendered once in a
;; buffer, because: 1. it doesn't insert anything 2. it replaces text
;; properties where they already exist, instead of adding them to new
;; text, which seems faster.
(defvar rlx-render-cursor nil)
(defsubst rlx-replace-image-with (image)
(set-text-properties rlx-render-cursor (incf rlx-render-cursor)
(list 'display (cons 'image (cdr image))
'rear-nonsticky t)))
;; (@* "Rendering transparent overlays on the map")
;;
;; Sometimes we want to display a targeting reticle or some other such
;; overlay on the map without disturbing the grid structure. The
;; following functions do just that.
(defun rlx-overlay (world tile cells row column)
"Call after rendering the grid to overlay tile TILE on CELLS at
ROW, COLUMN in WORLD."
(when (rlx-world-rendered-p world)
(let* ((inhibit-read-only t)
(grid (rlx-world-grid world))
(under-cells (rlx-grid-get grid row column))
(final-cells (append under-cells (list (list :tile tile))))
(final-image (rlx-tile-image (rlx-compose-tile-name final-cells)
final-cells))
(buffer-position (+ 1 column (* row (+ 1 (rlx-grid-columns grid))))))
(with-current-buffer (rlx-world-display-buffer world)
(set-text-properties buffer-position (+ 1 buffer-position)
(list
'display
(cons 'image (cdr final-image))
'rear-nonsticky t))))))
;; (@* "Events")
;;
;; Events are a way of sending a message to a cell, in order to
;; trigger some response. In fact, all cell interactions are modeled
;; as events.
;;
;; The value of a cell's :event property controls its response to
;; events. If its value is a function, the function is invoked with
;; the event details as arguments. When its value is a list, each
;; function is called in turn until one of them handles the event.
;;
;; The result of an event function may be:
;; \begin{enumerate}
;; \item nil, when there are no resulting events.
;; \item an event cell, which is executed
;; \item a list of event cells, which are executed in order
;; \item :does-not-understand, to signal that the event function did not
;; recognize the event. In this case, the
;; next event function is executed.
;;
;; \item :default, in which case the RLX default action is executed, and
;; no further event functions are called. see also
;; (@> "Default events")
;;
;; \item list of the form (:no-default events). no further event
;; functions are executed, and no default action is
;; done. the result EVENTS are processed.
;; see also (@> "Default events")
;;
;; \item for value cells, a list of the form (:value foo
;; :formatted-value bar). see also (@> "Values")
;; \end{enumerate}
;;
;; Event cells have just the following properties: {\tt :to}
;; {\tt :to,} {\tt :from,} {\tt :action,} and {\tt :detail.}
;;
;; {\tt :to} is the target of the message. {\tt :from} is the sender
;; of the message. (When its value is nil, the sender is considered to
;; be the current player.) {\tt :action} encodes the action to be
;; taken. This may be any keyword symbol. Some examples are {\tt
;; :push,} {\tt :take,} and {\tt :damage.} Finally, {\tt :detail}
;; represents an optional quality, such as the direction to be moved,
;; or the strength of a damage effect, et cetera.
(defsubst rlx-invoke-event (world event)
"Invoke and narrate the single event EVENT in world WORLD.
If there are multiple event functions at the destination cell,
we execute each in turn until one handles the event. Result
events (if any) are returned.
This is the primitive function for event invocation. You
probably want to use rlx-run-events instead, as it handles event
propagation and message sends."
(when event
(when (not (memq (getf event :action) rlx-narration-excluded-actions))
(rlx-narrate-event (rlx-world-narration-buffer world) event))
;;
(destructuring-bind (&key from action to detail) event
(let* ((event-function (getf to :event))
(result nil))
(when event-function
(setf result (funcall event-function to action from detail world)))
(if (eq result :does-not-understand)
nil
;; otherwise we may have events.
;; handle single events as well as lists of events, always
;; returning lists of events
(if (symbolp (car-safe result))
;; single event
(list result)
;; list of events
result))))))
(defsubst rlx-resolve-to-cell (grid from to)
"A destination cell reference may be a direction keyword, a
list of the form (ROW COLUMN), or a cell. Resolve it if needed."
(cond
((null from)
;; we'll never figure it out.
nil)
;;
;;
((eq to :player)
(rlx-world-player rlx-current-world))
;;
;; it's a direction keyword
((symbolp to)
(let ((step (rlx-step-in-direction
(getf from :row) (getf from :column) to)))
(destructuring-bind (tr tc) step
(rlx-grid-top-cell
grid tr tc))))
;;
;; it's an absolute row,column reference
((numberp (car-safe to))
(destructuring-bind (tr tc)
to
(rlx-grid-top-cell grid tr tc)))
;;
;; it's an ordinary cell reference
(t to)))
(defsubst rlx-resolve-from-cell (grid from to)
(let ((resolved-to (if (eq :player to)
(rlx-world-player rlx-current-world)
to)))
(cond
;;
((or (null from) (eq :player from))
(or (rlx-world-player rlx-current-world)
(car (rlx-world-players rlx-current-world))))
;;
((symbolp from)
(let ((step (rlx-step-in-direction
(getf resolved-to :row) (getf resolved-to :column) from)))
(destructuring-bind (tr tc) step
(rlx-grid-top-cell
grid tr tc))))
;;
((numberp (car-safe from))
(destructuring-bind (tr tc)
from
(rlx-grid-top-cell grid tr tc)))
;;
(t from))))
(defun rlx-run-events (world events)
"Execute EVENTS in WORLD, and any resulting events.
Will properly handle chains of events, like one explosion
triggering the next and the next which damages a player, etc."
(let ((result-events nil)
(next-events nil)
(current-event nil)
(processing-events nil)
(selected-cell (rlx-world-selected-cell world))
(grid (rlx-world-grid world))
(player (or (rlx-world-player world)
(car (rlx-world-players world))))
(from-row nil) ; where is current event's source?
(from-column nil)
(to-row nil) ; where is the current event's destination?
(to-column nil))
;;
(setf processing-events events)
;;
(block processing
(while (setf current-event (pop processing-events))
(destructuring-bind (&key from action to detail &allow-other-keys) current-event
;;
;; if event does not have both :from and :to as cell references,
;; find out the referent cells and fill in the blank.
;;
;; assume current player if :from is blank.
;;
(setf from (rlx-resolve-from-cell grid from to))
;;
;; the value of :to can be a direction keyword,
;; (ROW COLUMN), or a cell. resolve it.
;;
(setf to (rlx-resolve-to-cell grid from to))
;;
;; Now, either this is a :send event, or something else.
;; Sends are handled specially here.
;;
;; (@> "sending")
;;
(if (eq :send action)
;; detail is the "real" event to be sent. unpack it.
(let* ((x-from (getf detail :from))
(x-detail (getf detail :detail))
(x-action (getf detail :action))
(x-to (getf detail :to)))
;; resolve cell references. the new :x-from is relative to the sender :from
(setf x-from (rlx-resolve-from-cell grid x-from x-to))
(setf x-to (rlx-resolve-to-cell grid from x-to))
(setf result-events (rlx-invoke-event world (list
:to x-to
:from x-from
:action x-action
:detail x-detail))))
;;
;; it's a regular old event. see how the cell responds to the event
;;
(setf result-events (rlx-invoke-event world current-event)))
;;
;; now decide what to do.
(cond
;;
;; the cell responded without generating events.
((or (null result-events) (eq :does-not-understand result-events))
;; execute the default event and process resulting events
(setf result-events (rlx-default-event from to action detail world))
(when result-events
(setf next-events (append next-events (list result-events)))))
;;
;; (@> "default-events")
;; the cell responded, and requests no default event be executed.
;; this happens when you use (override :foo BODY) in an event declaration.
((and (listp result-events) (eq :no-default (car (car result-events))))
(setf next-events (append next-events (list (cdr result-events)))))
;;
;; the cell responded; there are events to be processed
((listp result-events)
;; add any resulting events to the queue to be processed the next round
(setf next-events (append next-events (list result-events)))
(let ((default-result (rlx-default-event from to action detail world)))
(when default-result
(setf next-events (append next-events (list default-result))))))))
;;
;; grab next set of events to process, and repeat.
(when (null processing-events)
(setf processing-events (pop next-events)))))))
;; (@* "Default events")
;;
;; Certain events have a default action\footnote{To avoid the default
;; action getting executed, use (override) in your event declaration.}
;; implemented in RLX. These built-in actions implement the basic play
;; mechanics of a roguelike game.
;;
;; \begin{description}
;; \item [:move]
;; Move a cell from one location to another. In this case, :detail should
;; be a direction keyword like :north or a list of the form (row column).
;; \item [:send]
;; Send an event to another cell. In this case, :detail should be the
;; event to be sent, and :to should be the cell to receive the
;; event. As with the special event :move, the value of :to may be a
;; direction keyword or list of coordinates.
;; \item [:stat-effect]
;; Change a stat by a particular amount. In this case, :detail should
;; be a list of the form (stat-keyword-symbol delta)
;; \item [:add-effect]
;; Attach an effect cell. The value of :detail is the effect cell.
;; \item [:remove-effects]
;; Remove effect cells. The value of :detail is the category of effect
;; cells to remove. Cells should be categorized carefully so that you
;; can remove them.
;; \item [:destroy-self]
;; Remove the cell from the game world.
;; \item [:proxy]
;; See also (@> "Proxies")
;; Become the proxy for another cell.
;; \item [:unproxy]
;; See also (@> "Proxies").
;; Release a cell from proxy.
;; \item [:inspect ]
;; Show information about the cells underneath the current player. This
;; shows more information than the player should see, so it is mostly
;; for debugging purposes.
;; \item [:inspect-target]
;; Same as :inspect, but inspect the currently selected cell.
;; \item [:look]
;; Show names of objects under the player, and allow user to select one
;; for pickup.
;; \item [:look-target]
;; Show names of objects at the targeted location.
;; See also (@> "Heads-up display").
;; \item [:inventory-target]
;; Look at the inventory of the selected object.
;; See also (@> "Heads-up display")
;; and (@> "Inventory")
;; \item [:inventory-self]
;; Look at the inventory of the current player.
;; See also (@> "Heads-up display")
;; and (@> "Inventory")
;; \item[:take]
;; Take the object if it is in category :item.
;; \item[:drop]
;; Drop the object from inventory.
;; \item[:equip]
;; The character should equip the item. See also (@> "Equipment").
;; \item [:dequip]
;; The character should dequip the given slot.
;; \item [:equipment]
;; Display the equipment screen for character.
;; \item [:replace-self]
;; Replace the cell with another.
;; \item [:put-knowledge]
;; Add knowledge to a character. See also (@> "Knowledge")
;; \item [:turn]
;; The action :turn is sent whenever it is time for the cell to ``take
;; initiative'' and do something, such as move or attack. (Player cells
;; are not sent :turn; instead the engine waits for user input.)
;; The default action for :turn is to do nothing.
;; \end{description}
(defvar rlx-default-events '(:move
:send
:stat-effect
:add-effect
:remove-effects
:destroy-self
:proxy
:unproxy
:inspect
:inspect-target
:look
:look-target
:inventory-target
:inventory-self
:take
:drop
:equip
:dequip
:equipment
:put-knowledge
:replace-self
:describe
:describe-target))
(defun rlx-default-event (from to action detail world)
;;
;; grab relevant cell coordinates
;;
(let ((to-row (getf to :row))
(to-column (getf to :column))
(from-row (getf from :row))
(from-column (getf from :column))
(grid (rlx-world-grid world))
(selected-cell (rlx-world-selected-cell world))
(result-events nil))
;;
(case action
;;
(:move
(destructuring-bind (dest-row dest-column)
(rlx-step-in-direction to-row to-column detail)
(rlx-grid-move-cell grid to to-row to-column
dest-row dest-column)
;; blank hud when player moves away from an inventoried location
;; (@> "looking")
(when (and (eq to (rlx-world-player rlx-current-world)) (eq :look rlx-current-hud-type))
(rlx-blank-hud rlx-current-world)
(rlx-redraw-hud rlx-current-world "Moved out of range..."))
;; FIXME: resulting events could happen if we synthesize a :step
(setf result-events nil)))
;;
(:stat-effect
(destructuring-bind (stat-name change &optional which) detail
(rlx-stat-effect to stat-name change which)))
;;
(:add-effect
(rlx-add-effect to detail))
;;
(:remove-effects
(rlx-remove-effects-in-category to detail))
;;
(:destroy-self
(let ((item to))
(if (rlx-in-category item :contained)
;; (@> "Containers")
;; properly remove item from container
(rlx-container-delete (getf item :contained-in)
item)
;;
;; otherwise remove from map
(rlx-grid-delete grid to-row to-column item))))
;;
(:proxy
(when (rlx-in-category to :proxy)
(rlx-proxy world from to)))
;;
(:unproxy
(when (rlx-in-category to :proxy)
(rlx-unproxy world to)))
;;
(:inspect
(rlx-inspect (rlx-grid-get grid from-row from-column)))
;;
(:inspect-target
(rlx-inspect (list (rlx-world-selected-cell world))
"Target:"))
;;
(:look
(rlx-look (rlx-grid-get grid from-row from-column)
from
"Current location: "))
;;
(:look-target
(when selected-cell
(if (rlx-sight-cells grid from to)
(rlx-look (list selected-cell)
from
"Targeting: ")
(rlx-blank-hud world))))
;;
(:inventory-target
;; FIXME
nil)
(:inventory-self
(rlx-inventory-container to to)
;;
nil)
;;
(:take
(let ((taker to)
(item from))
;; check if it's an item
(if (not (rlx-in-category item :item))
(rlx-narrate "You cannot pick that up.")
;; check if it's already in a container
(if (rlx-in-category item :contained)
;; remove it from its container, which is passed as :detail
(rlx-container-delete detail item)
;; otherwise remove it from the world
(rlx-grid-delete grid
(getf item :row)
(getf item :column)
item))
;; put in new container
(rlx-container-put taker item)
;;
;; update hud display
(rlx-look (rlx-grid-get grid from-row from-column)
taker
"Current location:")
;;
;; tell the object it was taken
(setf result-events `((:from ,taker :to ,item :action :taken))))))
;;
(:drop
(let ((dropper to)
(item from))
;; drop on map
(rlx-grid-drop-under-top grid to-row to-column item)
;; remove from inventory
(rlx-container-delete dropper item)
;; tell the item it was dropped
(setf result-events `((:from ,dropper :to ,item :action :dropped)))
;; update inventory display
(rlx-inventory-container dropper dropper))
nil)
;;
;; (@> "equipping")
(:equip
(let* ((item (rlx-hud-selected-cell))
(character to)
(potential-slots (rlx-equipment-match character item))
(slot (car-safe potential-slots))) ;; FIMXE: allow choices
(when (rlx-equip character item slot)
;;
;; redraw the inventory
(rlx-inventory-container character character)
;;
;; tell the object it's been equipped
(setf result-events `((:to ,item :from ,character :action :equipped)))
)))
;;
;; (@> "dequipping")
(:dequip
(let* ((character to)
(slot detail)
(item (getf (rlx-equipment character) slot)))
(rlx-dequip character slot)
(rlx-narrate "You dequipped the item from %s." (substring slot 1))
;; display equipment again
(rlx-hud-equipment character)
;;
;; tell the object it's been dequipped
(setf result-events `((:to ,item :from ,character :action :dequipped)))
))
;;
;; (@> "equipment")
(:equipment
(let ((character to))
(rlx-hud-equipment character)))
;;
;; (@> "replacing-self")
;; see also (@> "asterisks")
(:replace-self
(let ((old to)
(new from))
(rlx-grid-replace grid
(getf old :row)
(getf old :column)
old new)))
;;
;; (@> "knowledge")
(:put-knowledge
(let ((character to)
(knowledge-groups detail))
(rlx-put-knowledge character knowledge-groups)))
;;
;; <describing> <find-next>
(:describe
(let ((character to)
(item (rlx-hud-selected-cell)))
(when item
(rlx-narrate (rlx-describe character item)))))
;;
;; <describing> <find-next>
(:describe-target
(let ((character to)
(item (rlx-world-selected-cell world)))
(when item
(rlx-narrate (rlx-describe character item)))))
;;
;;
;; new actions go here
;;
) ;; end of cond
;;
;; return any result events
result-events))
;; (@* "Properties of cells")
;;
;; This section describes the basic set of properties understood by the
;; engine, and its interpretation of their values.
;;
;; \begin{description}
;; \item [:tile]
;; String name of tile to be
;; displayed for this object. You can change this property as needed
;; for animations or to reflect state changes. For example you could
;; draw two tiles for a door's two states (open and closed).
;; Names should use only alphanumeric characters and
;; dashes.
;; \item [:type]
;; The set of categories a cell belongs to. See also (@> "Cell types")
;; \item [:event]
;; Function(s) to be called whenever events occur.
;; See also (@> "Events")
;; \item [:effects]
;; List of effect cells to be executed on each turn. Things like poisoning
;; are modeled as effect cells that subtract from your hit points each
;; turn. See also (@> "effects")
;; \item [:inventory]
;; List of cells contained within. This is used to implement various
;; container objects. The cell should be in category :container.
;; See also (@> "Inventory")
;; and (@> "Containers")
;; \item [:capacity]
;; Maximum weight that can be put inside container.
;; \item [:weight]
;; Weight of the item. Default is 0, meaning ``negligible.''
;; \item [:equipment]
;; Property list of cells representing current equipment slots whose
;; values are equipped item cells. The acceptable keywords are those
;; in the set :equipment-slots.
;; See also (@> "Equipment").
;; \item [:equipment-slots]
;; Set of keyword symbols identifying the available equipment slots.
;; Example: (:left-hand :right-hand :feet :legs :body :head)
;; See also (@> "Equipment")
;; \item [:equip-for]
;; Set of keyword symbols identifying where an item is allowed to be
;; equipped. Example: (:left-hand :right-hand) which is the default.
;; See also (@> "Equipment")
;; \item [:speed]
;; Speed is a stat representing how fast a player moves.
;; See also (@> "Speed")
;; \item [:attacking-with]
;; Identifies the current slot to use for default attack.
;; \item [:light-radius]
;; For objects in category :light-source, the radius of the cast light.
;; See also (@> "lighting")
;; \item [:knowledge-groups]
;; List of keyword symbols identifying knowledge groups that would
;; grant the player knowledge of this item. See also (@> "Knowledge")
;; \end{description}
;;
;; Certain special properties are bookkeeping data for the engine. You should
;; consider these read-only.
;;
;; \begin{description}
;; \item [:row and :column]
;; These record the docation of the cell.
;; \item [:turn-number]
;; This is compared with the world's turn number to ensure all objects
;; are up to date on a given turn.
;; \item [:turn-energy]
;; An integer representing the ability of a player to take turn(s) in
;; a round. See also (@> "speed").
;; \end{description}
;; (@* "Values")
;;
;; Some attributes of a cell should be computed when they are looked
;; up. In this case, you can store a value cell as the value of a
;; property of your cell, and use (rlx-value CELL PROPERTY-NAME) as a
;; shortcut for computing its value.
;;
;; Value cells should have an event function that responds to :compute
;; events with the containing cell as :from and, as always, the value
;; cell itself as :to. It should return a list of the form (:value
;; foo). The containing cell is passed to the value cell's compute
;; function as :other so that values may depend on one another and on
;; other properties of the containing cell.
(defun rlx-compute-value (value-cell containing-cell &optional detail)
"Compute VALUE-CELL's value on CONTAINING-CELL and return it.
When DETAIL is set, send as the detail argument to the compute
function. This feature is used to modify the request in ways
specific to the particular value cell, and is used to specialize
value cells. See the function (rlx-stat-value) for an example of this."
(let ((event-function (getf value-cell :event)))
(if event-function
(let ((result
(funcall event-function value-cell :compute containing-cell detail nil)))
(getf result :value)))))
(defsubst rlx-value (cell value-name)
"Compute value of property VALUE-NAME for cell CELL."
(rlx-compute-value (getf cell value-name) cell))
;; (@* "Statistics")
;;
;; Your characters may have numeric-valued attributes like Strength
;; that have a minimum and maximum, as well as temporary and permanent
;; effects. In this case you want to store a base value, minimum,
;; maximum, and current delta, and compute the value at run time.
;;
;; Stats are just numeric value cells with the properties :base :min
;; :max and :delta.
;;
;; These are used to implement skills, attributes, hitpoints, etc.
;; There isn't much here but it helps standardize something that most
;; games will need and provides shortcut functions for handling them.
;;
;; Value cells have no event function; instead, rlx-stat-value does
;; the computation.
(defsubst rlx-stat-value (cell stat-name &optional which)
"Compute the current value of stat named STAT-NAME in CELL.
If WHICH is set, return the value of WHICH part of the stat
instead of computing a value. Returns minimum or maximum value as
appropriate when current computed value is out of range."
(if which
(getf (getf cell stat-name) which)
;;
;; compute current total value
(if (getf cell stat-name)
(destructuring-bind (&key base delta min max &allow-other-keys)
(getf cell stat-name)
(let ((value (+ base delta)))
(cond
((< value min) min)
((> value max) max)
(t value))))
;;
;; no such stat. return nil
nil
)))
(defsubst rlx-stat-effect (cell stat-name new &optional which)
"Add NEW, which may be negative, to CELL's STAT's base value.
When optional argument WHICH is set, effect WHICH part of the stat. This
is used to alter the maximum or base value."
(let ((stat (getf cell stat-name)))
(incf (getf stat (or which :base)) new)
;;
;; ensure base stays within bounds.
(destructuring-bind (&key base min max delta) stat
(setf base (max min base))
(setf base (min max base))
(setf (getf stat :base) base))))
;; (@* "Sensors")
;;
;; Value cells may compute their value based on environmental factors,
;; like properties of nearby cells or distance from a player, using
;; helper functions like those below. Sensors may also update the HUD
;; when neccessary, for example to alert the player to a radiation
;; danger or the identity of a nearby monster.
;;
;; Sensor cells are often :builtin cells but can also be equippable
;; items (for example, a geiger counter.)
(defun rlx-nearest-player (row column)
"Get the nearest player to grid location ROW, COLUMN."
(let* ((players (rlx-world-players rlx-current-world))
(nearest-player (car players))
(distance nil))
(if (eq 1 (length players))
(car players)
;; else calculate who is nearest
(setf distance (rlx-distance column row
(getf nearest-player :column)
(getf nearest-player :row)))
(dolist (p (cdr players))
(when (< (rlx-distance column row
(getf p :column)
(getf p :row))
distance)
(setf nearest-player p)))
nearest-player)))
(defsubst rlx-nearest-player-to-cell (cell)
(rlx-nearest-player (getf cell :row) (getf cell :column)))
(defsubst rlx-distance-to-nearest-player-to-cell (cell)
(let* ((player (rlx-nearest-player-to-cell cell))
(distance (rlx-distance (getf player :row)
(getf player :column)
(getf cell :row)
(getf cell :column))))
distance))
(defun rlx-seek (seeker target)
"Return the direction to move in if SEEKER seeks TARGET.
Uses a simple calculation and doesn't think about obstacles. Not
very realistic."
(rlx-direction-to (getf seeker :row) (getf seeker :column)
(getf target :row) (getf target :column)))
;; (@* "Effects")
;;
;; Sometimes you want value computation to have side effects like
;; changing the value of some property of the containing-cell. This is
;; used to implement temporary effects like poisoning, which could
;; return the event:
;;
;; (:to other :action :stat-effect :detail '(:hit-points -5))
;;
;; A traditional "confusion" effect could cause the player to wander
;; around. This could be implemented with
;;
;; (let ((direction (nth (random 4) '(:north :south :east :west))))
;; (:to other :action :send :detail `(:action :move :detail ,direction)))
;;
;; Such values should be computed before each turn so that they will
;; have a chance to do their nasty work on the player. The engine will
;; look for these in the containing cell's :effects and execute them
;; before handing control to the containing cell (i.e. player or cpu.)
(defun rlx-run-effects (world cell)
"Run all CELL's effects on CELL in WORLD."
(mapc
(lambda (e)
(let ((result-events (rlx-invoke-event world (list
:to e
:action :compute
:from cell))))
(rlx-run-events world result-events)))
(getf cell :effects)))
(defsubst rlx-add-effect (cell effect)
"Add EFFECT to CELL."
(push effect (getf cell :effects)))
(defsubst rlx-remove-effects-in-category (cell category)
(setf (getf cell :effects)
(remove-if (lambda (e)
(rlx-in-category e category))
(getf cell :effects))))
;; (@* "Proxies")
;; A proxy cell stands in for another cell and filters all messages sent to it.
;; This can be used to implement drivable vehicles.
;; The proxied cell is stored as the :occupant property of the proxy.
(defun rlx-proxy (world cell proxy)
"Make PROXY the proxy of CELL. Replaces CELL with PROXY in the gameworld."
(rlx-grid-replace (rlx-world-grid world)
(getf proxy :row) (getf proxy :column)
cell proxy 'no-holes)
(plist-put proxy :occupant cell)
;; handle proxied players
(when (rlx-in-category cell :player)
;; when a proxy is also a player, make it an obstacle
(when (rlx-in-category proxy :player)
(rlx-put-category proxy :obstacle))
;; replace player
(rlx-register-player proxy world)
(rlx-unregister-player cell world)))
(defun rlx-unproxy (world proxy)
"Empty PROXY of its contents by dropping the occupant cell on top of it."
(let ((occupant (getf proxy :occupant))
(row (getf proxy :row))
(column (getf proxy :column)))
(rlx-grid-drop (rlx-world-grid world)
row column occupant)
;; handle proxied players
(when (rlx-in-category occupant :player)
(rlx-unregister-player proxy world)
(rlx-register-player occupant world)
;; update player position
(setf (getf occupant :row) row)
(setf (getf occupant :column) column)
;; handle proxies that are themselves players.
(rlx-delete-category proxy :obstacle))
;;
(setf (getf proxy :occupant) nil)))
;; (@* "Containers")
;; These should be in category :container. Contents are stored in the
;; :inventory property.
(defun rlx-container-put (container item)
(rlx-put-category item :contained)
(plist-put container :inventory
(cons item (getf container :inventory)))
(plist-put item :contained-in container))
(defsubst rlx-container-delete (container item)
(setf (getf container :inventory)
(delq item (getf container :inventory)))
(rlx-delete-category item :contained)
(plist-put item :contained-in nil))
(defsubst rlx-contents (container)
(getf container :inventory))
(defsubst rlx-weight (cell)
"Weight, without contents."
(or (getf cell :weight) 0))
(defun rlx-container-weight (container &optional no-count-container-weight)
(let ((total (if no-count-container-weight
0
(rlx-weight container)))
(contents (getf container :inventory)))
(mapc (lambda (c)
(incf total (if (rlx-in-category c :container)
(rlx-container-weight c)
(rlx-weight c))))
contents)
total))
;; (@* "Equipment")
(defsubst rlx-equip-for (cell)
(or (getf cell :equip-for) '(:left-hand :right-hand)))
(defsubst rlx-equipment (cell)
(getf cell :equipment))
(defsubst rlx-equipment-slots (cell)
(getf cell :equipment-slots))
(defsubst rlx-equipment-slot (cell slot)
(getf (getf cell :equipment) slot))
(defsubst rlx-equipment-match (cell item)
(intersection (rlx-equipment-slots cell)
(rlx-equip-for item)))
(defun rlx-equip (cell item slot)
"Attempt to equip ITEM on character CELL in SLOT. Returns non-nil if successful."
;; it it an item?
(if (rlx-in-category item :item)
;; does it fit?
(if (rlx-equipment-match cell item)
;;
;; equip it, placing any previous item back into inventory
(let ((previous-equipment (rlx-equipment-slot cell slot)))
(when previous-equipment
(rlx-container-put cell previous-equipment))
;; deal with empty plists
(if (null (rlx-equipment cell))
(plist-put cell :equipment (list slot item)))
;; deal with empty value for slot
(setf (getf cell :equipment)
(plist-put (getf cell :equipment) slot item))
;; remove from inventory
(rlx-container-delete cell item)
(rlx-narrate "You equip the %s." (rlx-name cell item))
;; return t to indicate success
t)
;;
;; doesn't fit
(rlx-narrate "You cannot equip that there.")
nil)
;;
;; it's not an item
(rlx-narrate "You cannot equip that.")
nil))
(defun rlx-dequip (cell slot)
(let ((equipment (rlx-equipment-slot cell slot)))
;; is there equipment in the slot?
(if equipment
(progn
;;
;; put it back into inventory
(rlx-container-put cell equipment)
;; clear slot
(setf (getf cell :equipment)
(plist-put (getf cell :equipment) slot nil)))
;;
;; error message
(rlx-narrate "Nothing to dequip."))))
;; (@* "Speed")
;;
;; ``Turn energy'' controls one'ss ability to take turns during a
;; phase. It begins at zero.
;;
;; At the beginning of a phase, the player's current speed value is
;; added to their turn energy. While his turn energy is at least 10,
;; he may take a turn. With each turn, his turn energy is decremented
;; by 10 points. According to this scheme, a character with a speed
;; of 10 would get exactly one turn per phase. A player with a speed
;; of 5 would only get a turn every other phase. And a character with
;; a speed of 20 would get to go twice in a phase.
;;
;; The following functions calculate speed and turn energy.
(defsubst rlx-cell-needs-turn (cell world-turn-number &optional first-turn-of-round)
"Determine whether CELL needs another turn. When its last turn
is reached, update CELL's turn number. When it's the
FIRST-TURN-OF-ROUND, give cell its allotment of speed."
(let ((turn-number (getf cell :turn-number))
(turn-energy (getf cell :turn-energy))
(turn-speed (or (rlx-stat-value cell :speed) 10))
(turn-needed nil))
;; set up defaults
;;
(setf turn-number (or turn-number 0))
(setf turn-speed (or turn-speed 10))
(setf turn-energy (or turn-energy 0))
;;
;; now calculate!
(when (< turn-number world-turn-number)
;;
(when first-turn-of-round
(incf turn-energy turn-speed))
;;
;; is there enough energy to move?
(if (>= turn-energy 10)
(progn
(setf turn-needed t)
(decf turn-energy 10)
(when (<= turn-energy 10)
;; ok, the cell is taking its last turn. update its turn number
(plist-put cell :turn-number world-turn-number))))
;;
;; update cell values for next round
(plist-put cell :turn-energy turn-energy))
;;
;; return result
turn-needed))
(defsubst rlx-cell-needs-another-turn (cell world-turn-number)
"Determine whether CELL will need another turn at the next round.
Don't update anything."
(let ((turn-number (getf cell :turn-number))
(turn-energy (getf cell :turn-energy)))
(if (<= turn-energy 10)
nil
t)))
;; (@* "Worlds")
(defvar rlx-current-world nil "The current world.")
(defvar rlx-world-of-current-buffer)
(defstruct rlx-world
rendered-p ; whether the map has been rendered
selected-cell ; what cell is currently targeted by the user
name ; name of level or map
grid ; underlying grid structure for the universe
properties ; property list used for various things
turn-number ; keeping track of time
phase ; which team is currently going?
;;
light-map ; keep track of what is visible
light-sources ; list of light sources to be rendered
;;
path-map ; grid of pathfinding nodes
path-heap ; heap of open pathfinding nodes
path-heap-end
path-turn-number ; use to avoid clearing old data between path calls
;;
last-player ; the last player to take a turn.
player ; current player
players ; current set of players
;;
effects ; cells to be executed before each turn
display-buffer ; where to render the world
narration-buffer ; where to output messages
hud-buffer ; where to put heads-up-display
hud-sheet ; cell-mode sheet where hud is displayed
)
(defun rlx-make-world (name rows columns)
"Create and properly initialize a new world with ROWS rows and
COLUMNS columns. Returns the world object."
(let ((world (make-rlx-world
:name name
:grid (rlx-make-grid rows columns)
:light-map (rlx-make-grid rows columns)
:path-map (rlx-make-grid rows columns)
:path-heap (make-vector (* rows columns) nil)
:path-turn-number 1
:turn-number 10
:display-buffer (get-buffer-create "*RLX*")
:narration-buffer (get-buffer-create "*RLX-Narration*"))))
;;
;; initialize the pathfinding map
(dotimes (r rows)
(dotimes (c columns)
(rlx-grid-set (rlx-world-path-map world) r c (make-rlx-node
:row r
:column c))))
;;
;; set up the buffer to look and act properly
(with-current-buffer (rlx-world-display-buffer world)
(rlx-mode)
(setf truncate-lines t)
(buffer-disable-undo (current-buffer))
(make-local-variable 'rlx-world-of-current-buffer)
(setf rlx-world-of-current-buffer world)
(setf buffer-read-only t)
(setf cursor-type nil))
;; set up HUD buffer
(rlx-make-hud world)
world))
(defun rlx-set-selected-cell (world cell)
(setf (rlx-world-selected-cell world) cell))
(defun rlx-start-world (world)
"Do some initialization needed to get the world running. Finds
the first player and prepares for input."
(when (null (rlx-world-phase world))
(setf (rlx-world-phase world) :player)
(setf rlx-current-world world)
(rlx-initialize-light-map world)
(rlx-render-world world)
(let ((player (car (rlx-world-players world))))
(rlx-render-world world (getf player :row) (getf player :column)))))
(defun rlx-run-world (world)
"Calculate the next click in time for the game
world. Alternates between player phase and enemy phase. Returns
nil if computation of the phase finished. Returns current player
if it is that player's turn. This is the inner loop of RLX."
(let* ((grid (rlx-world-grid world))
(rows (rlx-grid-rows grid))
(columns (rlx-grid-columns grid))
;;
(world-turn-number (rlx-world-turn-number world))
(phase (rlx-world-phase world))
;;
(turn-row 0)
(turn-column 0)
(cells nil)
(event-function nil)
;; optimization
(row-vector nil)
(first-turn-for-cpu-p nil)
(first-turn-for-player-p nil))
;;
(case phase
;;
;; player phase
;;
(:player
(let* ((current-player (or (rlx-world-player world)
(car (rlx-world-players world))))
(next-player (rlx-next-player current-player world))
(last-player (rlx-world-last-player world)))
;; is this the first turn? if so we need to update his turn energy
(setf first-turn-for-player-p (or (null last-player)
(not (eq current-player last-player))))
;;
;; if current player still needs turn, then give it to him
;;
(when (rlx-cell-needs-turn current-player
world-turn-number
first-turn-for-player-p)
(progn
;; first apply effects
(rlx-run-effects world current-player)
;; keep track of who went last
(setf (rlx-world-last-player world) current-player)
(setf (rlx-world-player world) current-player)
))
;;
;; does this player need another turn?
(if (rlx-cell-needs-another-turn current-player world-turn-number)
;; if so, exit and wait for input
nil
;; otherwise, see if there's a next player
(if next-player
;; if so, apply effects and exit
(progn
(rlx-run-effects world next-player)
(setf (rlx-world-player world) next-player))
;; otherwise the player phase is done.
;; clear last player, switch to cpu phase and incr world turn number
(setf (rlx-world-last-player world) nil)
(incf (rlx-world-turn-number world))
(setf (rlx-world-phase world) :cpu)))
;;
;; return next-player
next-player
))
;;
;; cpu phase
;;
(:cpu
(while (< turn-row rows)
;;
;; optimization; load each row just once instead of using grid-get
(setf row-vector (aref grid turn-row))
(while (< turn-column columns)
;;
(setf cells (aref row-vector turn-column))
(dolist (cell cells)
;;
;; give all non-player cells their turn(s)
(when (not (rlx-in-category cell :player))
(setf event-function (getf cell :event))
;;
;; (@> "speed")
;; don't bother computing turns for cells that don't have event functions.
(when event-function
;;
;; while the cell needs turns, give it its turns.
;; we handle the first turn differently because turn energy needs to be alloted.
;; see also: (find-function 'rlx-cell-needs-turn)
;;
(setf first-turn-for-cpu-p t)
(while (rlx-cell-needs-turn cell world-turn-number first-turn-for-cpu-p)
;; effects are run every turn!
(rlx-run-effects world cell)
;; now invoke the event function and process results
(rlx-run-events world (list (list :action :turn :to cell)))
(setf first-turn-for-cpu-p nil)))))
;; next
(incf turn-column))
(setf turn-column 0)
(incf turn-row))
;;
;; flip phase and update world turn number
(setf (rlx-world-phase world) :player)
(incf (rlx-world-turn-number world))
nil))))
;; (@* "Rendering worlds")
(defun rlx-render-world (world &optional row column)
"Draw the contents of the world to the world's associated
buffer. When ROW and COLUMN are non-nil, leave point at ROW,
COLUMN when finished."
(let* ((inhibit-read-only t)
(grid (rlx-world-grid world))
(light-map (rlx-world-light-map world))
(turn-number (rlx-world-turn-number world))
(light-turn-number nil)
(buffer (rlx-world-display-buffer world))
(rows (rlx-grid-rows grid))
(row-vector nil) ; for optimization
(columns (rlx-grid-columns grid))
(selected-cell (rlx-world-selected-cell world))
(selected-row (getf selected-cell :row))
(selected-column (getf selected-cell :column))
(player (rlx-world-player world))
(full-lighting (eq -1 (rlx-ambient-lighting world)))
(element nil))
(when (null player)
(setf player (car (rlx-world-players world))))
;;
;; do ambient lighting on player.
;; (@> "lighting")
(rlx-light world player)
;;
;;
(with-current-buffer buffer
;; has the world been rendered yet?
(if (rlx-world-rendered-p world)
;; yes, replace images on existing text
(progn
(setf rlx-render-cursor 1)
(goto-char (point-min))
(dotimes (r rows)
(setf row-vector (aref grid r))
(dotimes (c columns)
(setf element (aref row-vector c))
(rlx-replace-image-with
(if full-lighting
;; don't bother checking lightmap. everything is lit
(rlx-tile-image (rlx-compose-tile-name element)
element)
;; we need to check the lightmap.
;; is the square currently lit?
(progn
(setf light-turn-number (rlx-grid-get light-map r c))
(if (> light-turn-number turn-number)
;; yes, draw the tile
(rlx-tile-image (rlx-compose-tile-name element)
element)
;; no, draw black
(rlx-tile-image "Black")
)))))
(when (not (eobp)) (forward-char 1))
(incf rlx-render-cursor))
;;
;; now draw the reticle
;; (@> "reticle")
(when selected-cell
(let* ((reticle
(if (rlx-sight-cells grid player selected-cell)
"reticle"
"reticle-blocked")))
(rlx-overlay world reticle (rlx-grid-get grid
selected-row
selected-column)
selected-row selected-column))))
;;
;; no, render black background
(progn
(delete-region (point-min) (point-max))
(dotimes (r rows)
(setf row-vector (aref grid r))
(dotimes (c columns)
(rlx-insert-blank))
(insert "\n"))
(setf (rlx-world-rendered-p world) t)))
;; now move point to keep player in focus
(when row (goto-line (+ row 1)))
(when column (forward-char column)))))
;; (@* "Pathfinding with A*")
;;
;; What follows is an implementation of the well-known A* pathfinding
;; algorithm\footnote{http://en.wikipedia.org/wiki/A-star\_search\_algorithm}
;; on a rectangular grid.
;;
;; The nodes are implemented as structures with the following slots:
(defstruct rlx-node
row
column
parent ; previous node along generated path
F ; node 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 world's path-turn-number when on closed list
open ; equal to world's path-turn-number when on open list
)
(defun rlx-print-heap (heap heap-end)
(let ((output "HEAP: "))
(dotimes (i heap-end)
(setf output (concat output (format " %S" (rlx-node-F (aref heap (+ 1 i)))))))
output))
;; The following routines maintain the open and closed sets. We
;; use a minheap to store the open set.
(defun rlx-open-node (world node)
(let* ((path-heap-end (if (null (rlx-world-path-heap-end world))
(setf (rlx-world-path-heap-end world) 1)
(incf (rlx-world-path-heap-end world))))
(path-heap (rlx-world-path-heap world))
(ptr path-heap-end)
(parent nil)
(finished nil))
;;
;; make it easy to check whether node is open
(setf (rlx-node-open node) (rlx-world-path-turn-number world))
;;
;; add node to end of heap
(setf (aref path-heap path-heap-end) node)
;;
;; let node rise to appropriate place in heap
(while (and (not finished) (< 1 ptr))
(setf parent (/ ptr 2))
;; should it rise?
(if (< (rlx-node-F node) (rlx-node-F (aref path-heap parent)))
;;
;; yes. swap parent and node
(progn
(setf (aref path-heap ptr) (aref path-heap parent))
(setf ptr parent))
;;
;; no. we're done.
(setf finished t)
(setf (aref path-heap ptr) node)))
;;
;; do we need to set node as the new root?
(if (and (not finished) (equal 1 ptr))
(setf (aref path-heap 1) node))))
(defun rlx-close-node (world)
(let* ((path-heap (rlx-world-path-heap world))
;; save root of heap to return to caller
(node (aref path-heap 1))
(last nil)
(path-heap-end (rlx-world-path-heap-end world))
(ptr 1)
(left 2)
(right 3)
(finished nil))
;; is there only one node?
(if (equal 1 path-heap-end)
(setf (rlx-world-path-heap-end world) nil)
(if (null path-heap-end)
nil
;;
;; remove last node of heap and install as root of heap
(setf last (aref path-heap path-heap-end))
(setf (aref path-heap 1) last)
;;
;; shrink heap
(decf (rlx-world-path-heap-end world))
(decf path-heap-end)
;;
(setf (rlx-node-closed node) (rlx-world-path-turn-number world))
;;
;; figure out where former last element should go
;;
(while (and (not finished) (>= path-heap-end right))
; (message "HEAPING /// %s" (rlx-print-heap path-heap path-heap-end))
;;
;; does it need to sink?
(if (and (< (rlx-node-F last) (rlx-node-F (aref path-heap left)))
(< (rlx-node-F last) (rlx-node-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 (>= (rlx-node-F (aref path-heap left))
(rlx-node-F (aref path-heap right)))
;;
;; yes
(progn
(setf (aref path-heap ptr) (aref path-heap right))
(setf ptr right))
;;
;; no, sink leftward
(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)
(> (rlx-node-F last)
(rlx-node-F (aref path-heap left))))
(setf ptr left))))
;;
;; save former last element in its new place
(setf (aref path-heap ptr) last)
node))
;; The ordinary distance algorithm is used to score nodes.
(defun rlx-score-node (world node path-turn-number new-parent-node goal-row goal-column)
"Update scores for NODE. Update heap position if necessary."
(let* ((direction (rlx-direction-to (rlx-node-row new-parent-node)
(rlx-node-column new-parent-node)
(rlx-node-row node)
(rlx-node-column node)))
(G (+ 1 (rlx-node-G new-parent-node)))
(H (* (max (abs (- (rlx-node-row node) goal-row))
(abs (- (rlx-node-column node) goal-column)))
1.001))
(F (+ G H)))
;;
;; is this a new node, i.e. not on the open list?
(if (not (equal path-turn-number (rlx-node-open node)))
;;
;; yes, update its scores and parent
(progn
(setf (rlx-node-G node) G)
(setf (rlx-node-H node) H)
(setf (rlx-node-F node) F)
(setf (rlx-node-parent node) new-parent-node))
;;
;; no, it's already open. is the path through NEW-PARENT-NODE
;; better than through the old parent?
(if (and (rlx-node-G node)
(< G (rlx-node-G node)))
;;
;; yes. update scores and re-heap.
(let ((heap (rlx-world-path-heap world))
(heap-end (rlx-world-path-heap-end world))
(ptr 1)
(par nil)
(finished nil))
(setf (rlx-node-G node) G)
(setf (rlx-node-H node) H)
(setf (rlx-node-F node) F)
(setf (rlx-node-parent node) new-parent-node)
;;
(message "Better score found.")
;;
;; find current location of node in heap
(while (and (not finished) (< ptr heap-end))
(when (equal node (aref heap ptr))
(message "Found node.")
;;
;; its score could only go down, so move it up in the
;; heap if necessary.
(while (and (not finished) (< 1 ptr))
(setf par (/ ptr 2))
;;
;; should it rise?
(if (< (rlx-node-F node) (rlx-node-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 node in its new place.
(setf finished t)
(setf (aref heap ptr) node)))
;;
;; do we need to install the new node as heap root?
(when (and (not finished) (equal 1 ptr))
(setf (aref heap 1) node)))
;;
;; keep scanning heap for the node
(incf ptr)))
;;
;; new score is not better. do nothing.
;(setf (rlx-node-parent node) new-parent-node)
))))
(defun rlx-node-successors (world node path-turn-number goal-row goal-column)
(delq nil
(mapcar
(lambda (direction)
(let* ((grid (rlx-world-grid world))
(path-map (rlx-world-path-map world))
(new-G (+ 1 (rlx-node-G node)))
(step (rlx-step-in-direction
(rlx-node-row node)
(rlx-node-column node)
direction))
(r (first step))
(c (second step))
(successor nil))
;;
(if (rlx-bounds-check grid r c)
(progn
(setf successor (rlx-grid-get path-map 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 (rlx-first-in-category (rlx-grid-get grid r c)
:obstacle))
(not (equal path-turn-number (rlx-node-closed successor)))))
;; if successor is open and existing path is better
;; or as good as new path, discard the successor
;; if successor is not open, proceed
(if (equal path-turn-number (rlx-node-open successor))
(if (< new-G (rlx-node-G successor))
successor
nil)
successor)
nil))
nil)))
rlx-compass-directions)))
;; Now we come to the pathfinding algorithm itself.
(defun rlx-path (world starting-row starting-column goal-row goal-column)
"Generate a path from the starting point to the goal in WORLD.
Returns a list of directional keywords an AI can follow to reach
the goal."
(let ((selected-node nil)
(path-turn-number (incf (rlx-world-path-turn-number world)))
(pos nil)
(found nil)
(target-node nil)
(path nil)
(F 0) (G 0) (H 0))
;;
;; reset the pathfinding heap
(setf (rlx-world-path-heap-end world) nil)
;;
;; add the starting node 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-node (make-rlx-node :row starting-row
:column starting-column
:old-G 0
:parent nil :G G :F F :H H))
;;
(rlx-open-node world selected-node)
;;
;; start pathfinding
(setq target-node
(block finding
;;
;; select and close the node with smallest F score
(while (setf selected-node (rlx-close-node world))
;;
;; did we fail to reach the goal?
(when (null selected-node)
(return-from finding nil))
;;
;; are we at the goal square?
(when (and (equal goal-row (rlx-node-row selected-node))
(equal goal-column (rlx-node-column selected-node)))
(return-from finding selected-node))
;;
;; process adjacent walkable non-closed nodes
(mapc (lambda (node)
;;
;; is this cell already on the open list?
(if (equal path-turn-number (rlx-node-open node))
;;
;; yes. update scores if needed
(rlx-score-node world node path-turn-number
selected-node goal-row goal-column)
;;
;; it's not on the open list. add it to the open list
(rlx-score-node world node path-turn-number selected-node
goal-row goal-column)
(rlx-open-node world node)))
;;
;; map over adjacent nodes
(rlx-node-successors world selected-node
path-turn-number
goal-row goal-column)))))
;;
;; did we find a path?
(if (rlx-node-p target-node)
;;
;; save the path by walking backwards from the target
(let ((previous-node target-node)
(current-node nil))
(while (setf current-node (rlx-node-parent previous-node))
;;
;; what direction do we travel to get from current to previous?
(push (rlx-direction-to (rlx-node-row current-node)
(rlx-node-column current-node)
(rlx-node-row previous-node)
(rlx-node-column previous-node))
path)
(setf previous-node current-node))
;;
;; return the finished path
path)
;;
;; return nil
nil)))
(defsubst rlx-path-to (grid from to)
(rlx-path grid
(getf from :row)
(getf from :column)
(getf to :row)
(getf to :column)))
;; (@* "Player characters")
(defun rlx-register-player (player &optional world)
"Register cell PLAYER as a player character to be controlled by
the user. When WORLD is not set, use rlx-current-world."
(let ((w (or world rlx-current-world)))
(when (not (member player (rlx-world-players w)))
(push player (rlx-world-players w)))))
(defun rlx-unregister-player (player &optional world)
"Unregister cell PLAYER as a player character to be controlled by the user.
When WORLD is not set, use rlx-current-world."
(let ((w (or world rlx-current-world)))
(when (member player (rlx-world-players w))
(setf (rlx-world-players w)
(delete player (rlx-world-players w))))))
(defun rlx-next-player (player world)
"Find out whose turn it is (after PLAYER) among the player characters in WORLD."
(let* ((players (rlx-world-players world))
(pos (position player players)))
(if (null pos)
(car players)
(nth (+ 1 pos) players))))
;; (@* "Lighting")
(defun rlx-register-light-source (light &optional world)
(let ((w (or world rlx-current-world)))
(when (not (member light (rlx-world-light-sources w)))
(push light (rlx-world-light-sources w)))))
(defun rlx-unregister-light-source (light &optional world)
(let ((w (or world rlx-current-world)))
(when (member light (rlx-world-light-sources w))
(setf (rlx-world-light-sources w)
(delete light (rlx-world-light-sources w))))))
(defun rlx-set-ambient-lighting (world radius)
(setf (rlx-world-properties world) (plist-put (rlx-world-properties world) :ambient-light radius)))
(defun rlx-ambient-lighting (world)
(or (getf (rlx-world-properties world) :ambient-light) 0))
(defun rlx-initialize-light-map (world)
(let* ((turn-number (rlx-world-turn-number world))
(light-map (rlx-world-light-map world))
(rows (rlx-grid-rows light-map))
(columns (rlx-grid-columns light-map)))
(dotimes (r rows)
(dotimes (c columns)
(rlx-grid-set light-map r c turn-number)))))
(defun rlx-light (world light-source)
(let* ((turn-number (rlx-world-turn-number world))
(lit-turn-number (+ 2 (rlx-world-turn-number world)))
(light-map (rlx-world-light-map world))
(light-map-rows (rlx-grid-rows light-map))
(light-map-columns (rlx-grid-columns light-map))
(grid (rlx-world-grid world))
(ambient-light (rlx-ambient-lighting world))
(light (or (getf light-source :light-radius) 0))
(light-row (getf light-source :row))
(light-column (getf light-source :column))
(total-light (+ ambient-light light))
(final-light (if (evenp total-light)
(+ 1 total-light)
total-light))
(octagon-points (rlx-collect-points
'rlx-trace-octagon
light-row
light-column
final-light
'thicken))
(line-points nil)
(pt nil)
(cells nil))
;; don't bother lighting if everything is lit.
(when (>= ambient-light 0)
;;
;; trace each point on the thickened octagon
;;
(dolist (point octagon-points)
;;
;;
(setf line-points (rlx-collect-points 'rlx-trace-line
light-column
light-row
(second point)
(first point)))
;;
;; Bresenham's swaps the input points around when x0 is to the
;; right of x1. We need to reverse the list of points if this
;; happens, otherwise shadows will be cast the wrong way.
;;
;; Furthermore, when a non-flipped line is drawn, the endpoint
;; isn't actually visited, so we append it to the list. (Maybe this
;; is a bug in my implementation?)
;;
(if (not (equal (car line-points)
(list light-row light-column)))
(setf line-points (nreverse line-points))
;; make sure endpoint of ray is traced.
(nconc line-points (list (list (first point) (second point)))))
;;
;; now light the line, stopping when we reach an obstacle
;;
(setf pt (pop line-points))
(while (and pt
(destructuring-bind (r c) pt
;; bounds check
(if (or (< r 0) (< c 0)
(>= r light-map-rows)
(>= c light-map-columns))
nil ;; stop tracing
;;
;; otherwise, light the square...
(setf cells (rlx-grid-get grid r c))
(setf pt (pop line-points))
(rlx-grid-set light-map r c lit-turn-number)
;; is it an opaque square?
(if (rlx-first-in-category cells :opaque)
;; yes, stop tracing
nil
t)))))))))
;; (@* "Narrating events")
(defvar rlx-narration-excluded-actions (list :move :send :turn :command
:inventory-self :look :replace-self
:equipped :dequipped :taken :dropped)
"List of action keywords to be excluded from narration.
Usually it should contain at least :move.")
(defvar rlx-narration-passive-voice-actions (list :attack :defend :damage :destroy-self)
"List of action keywords where passive voice is employed. In
this case, the :to and :from values are displayed in the
opposite order to make sense for the viewer.")
(defun rlx-narrate-event (buffer event &optional force)
"Narrate EVENT in BUFFER and make sure the narration is visible.
When FORCE is non-nil, disregard the value of rlx-narration-excluded-actions."
;;
(with-current-buffer buffer
(destructuring-bind (&key from action to detail) event
;;
;; flip when using passive voice
(when (memq action rlx-narration-passive-voice-actions)
(rotatef from to))
;;
;; now render!
(when (or force
(not (memq action rlx-narration-excluded-actions)))
(let ((black-bg '(:tile "Black")))
(labels ((with-black-bg (c)
(rlx-tile-image (rlx-compose-tile-name (list black-bg
c))
(list black-bg
c))))
(goto-char (point-max))
(when from
(insert-image (with-black-bg from)))
(when action
(insert-image (with-black-bg
`(:tile ,(substring (symbol-name action) 1)))))
(if to
(insert-image (with-black-bg to))
(insert-image (rlx-tile-image "Black")))
;;
;; some values for :detail are handled specially
;;
(when detail
(cond
;; (@> "defending")
((eq action :defend)
(insert-image (with-black-bg (getf detail :weapon)))
(insert (format " %d" (getf detail :damage))))
(t
(insert (format " %S" detail)))))
;;
(insert "\n")))
;;
;; now make sure it's visible
(ignore-errors
(save-selected-window
(when (select-window (get-buffer-window buffer nil))
(goto-char (point-max))
(recenter -1)
)))))))
(defun rlx-narrate (&rest args)
(with-current-buffer (rlx-world-narration-buffer rlx-current-world)
(goto-char (point-max))
(insert (concat (apply 'format args) "\n"))
(ignore-errors
(save-selected-window
(when (select-window (get-buffer-window (current-buffer) nil))
(goto-char (point-max))
(recenter -1))))))
;; (@* "Modeling player knowledge")
;;
;; Game objects can be known to the player, or unknown and mysterious.
;; When they are known, you see the true :name and
;; :description. Otherwise, you will see the :unknown-name and
;; :unknown-description.
(defun rlx-name (player cell)
"Return a string naming CELL from the point of view of PLAYER.
If the player knows any of the :knowledge-groups that CELL is a
member of, return the true :name of the CELL. Otherwise, return the
:unknown-name."
(let ((kgs (getf cell :knowledge-groups)))
(if (or (null kgs) (intersection kgs
(getf player :knowledge-groups)))
(getf cell :name)
(getf cell :unknown-name))))
(defun rlx-describe (player cell)
"Return a string describing CELL from the point of view of PLAYER.
If the player knows any of the :knowledge-groups that CELL is a
member of, return the :description. Otherwise, return the
:unknown-description."
(let ((kgs (getf cell :knowledge-groups)))
(if (or (null kgs) (intersection kgs
(getf player :knowledge-groups)))
(getf cell :description)
(getf cell :unknown-description))))
(defun rlx-put-knowledge (player knowledge-groups)
"Add the groups in KNOWLEDGE-GROUPS to the PLAYER."
(plist-put player :knowledge-groups
(union knowledge-groups (getf player :knowledge-groups))))
;; (@* "Handling user commands")
(defun rlx-command (command)
"Send COMMAND to the current player in the current buffer,
handle result events, and continue computing. You might not
suspect it from the name, but since everything happens in
response to user commands, this is sort of RLX's main loop."
(let* ((world rlx-current-world)
(grid (rlx-world-grid world))
(player (rlx-world-player world))
(display-buffer (rlx-world-display-buffer world))
(narration-buffer (rlx-world-narration-buffer world))
(focus-row nil)
(focus-column nil))
;;
;; if there's no current player set, the phase is starting over.
(when (null player)
(setf player (car (rlx-world-players world))))
(if (listp command)
(rlx-run-events world (list command))
(rlx-run-events world (list (list :to player
:action :command
:detail command))))
;; save coordinates of player, we need them after rendering
(setf focus-row (getf player :row))
(setf focus-column (getf player :column))
;;
;; continue player phase, get next player (if any)
(setf player (rlx-run-world world))
;;
;; did we finish?
(if player
(progn
;; no. render the world to show results of player action.
(rlx-render-world world (getf player :row) (getf player :column))
;; indicate whose turn it is
(rlx-narrate-event narration-buffer (list :from player
:action :turn)
'force)
;;
;; show status
(rlx-character-status player)
)
;;
;; we finished the player phase. now compute cpu phase.
(rlx-run-world world)
;; now render and restart player phase
;; to wait for input
(rlx-render-world world focus-row focus-column)
;;
;; show status
(rlx-character-status (car (rlx-world-players world))))
nil))
;; (@* "Heads-up display and control inteface")
;; The HUD features of RLX are provided by {\bf cell-mode}. Keep in
;; mind, cell-mode's notion of a cell is different from RLX's. This
;; isn't much of a problem in practice as one can wrap the other.
(defvar rlx-current-hud-type nil)
(defun rlx-make-hud (world)
;;
;; create a cell sheet for the HUD.
(let ((sheet (cell-sheet-constructor "*RLX-HUD*" 10 2)))
(setf (cell-sheet-headers-p sheet) nil)
(setf (rlx-world-hud-buffer world) (cell-sheet-buffer sheet))
(setf (rlx-world-hud-sheet world) sheet)
;; switch to cell-menu-mode, making sure to save cell-of-current-buffer
(with-current-buffer (cell-sheet-buffer sheet)
(let ((cell cell-of-current-buffer))
(cell-menu-mode)
(make-local-variable 'cell-of-current-buffer)
(setf cell-of-current-buffer cell)
(setf cursor-type nil)))
(rlx-redraw-hud world)))
(defun rlx-redraw-hud (world &optional header)
(with-current-buffer (rlx-world-hud-buffer world)
; (setf (cell-sheet-cursor sheet) '(0 1))
(cell-sheet-do-compute)
(cell-sheet-do-redraw)
(when header
(setf header-line-format header))))
(defun rlx-blank-hud (world)
(with-current-buffer (rlx-world-hud-buffer world)
(setf rlx-current-hud-type nil)
(cell-sheet-blank (rlx-world-hud-sheet world) 1 2)))
(defun rlx-fill-hud (world menu-data &optional header hud-type)
"Fill WORLD's hud with menu cells. The menu is constructed from MENU-DATA
which must be of the following form:
( (L R) (L R) ... )
Where the L and R are property lists with
keywords :default-action, :alt-action,
:text, :width, and optionally :image. L is for the left cell of
the menu item, R is for the right cell.
:default-action is called when you hit RET
:alt-action is called when you hit M-RET
:width is the maximum width of the cell to be displayed
:text is the text (possibly with properties) to be displayed
:image is an optional image spec."
(let* ((sheet (rlx-world-hud-sheet world))
(buffer (rlx-world-hud-buffer world))
(menu-items menu-data)
(num-items (length menu-items))
(menu-item nil)
(current-row 0))
(rlx-blank-hud world)
(with-current-buffer buffer
;;
(if hud-type
(progn
(setf (cell-sheet-properties cell-of-current-buffer)
`(:hud-type ,hud-type))
(setf rlx-current-hud-type hud-type))
(setf rlx-current-hud-type nil))
;;
(while (> num-items (rlx-grid-rows (cell-sheet-grid sheet)))
(cell-sheet-insert-row))
(while (setf menu-item (pop menu-items))
(let ((left-cell (make-menu-cell (first menu-item)))
(right-cell (make-menu-cell (second menu-item))))
(rlx-grid-set (cell-sheet-grid sheet) current-row 0 left-cell)
(rlx-grid-set (cell-sheet-grid sheet) current-row 1 right-cell))
(incf current-row))
;; don't select images
(setf (cell-sheet-cursor sheet) (list 0 1))
(rlx-redraw-hud world header))))
(defun rlx-hud-status (hud-buffer text)
(with-current-buffer hud-buffer
(setf header-line-format text)))
(defvar rlx-hud-blank-row '((nil nil nil nil) (nil nil nil nil)))
(defun rlx-hud-selected-cell ()
"Find and return the selected RLX cell in the HUD."
(with-current-buffer
(rlx-world-hud-buffer rlx-current-world)
(with-current-cell-sheet
(getf (cell-state cell) :cell))))
(defvar rlx-inspect-shown-properties '(:name :description))
(defun rlx-cell-inspect-menu (cell)
"Generate HUD data for cell CELL."
(let ((menu-data nil)
(el nil))
(while (not (null cell))
(setf el (cons (pop cell) (pop cell)))
(push `((:default-action nil :alt-action nil :text ,(format "%S" (car el)) :width 30)
(:default-action nil :alt-action nil :text ,(format "%S" (cdr el)) :width 50))
menu-data))
(nreverse menu-data)))
(defun rlx-cells-inspect-menu (cells)
(mapcan (lambda (cell)
(cons rlx-hud-blank-row
(rlx-cell-inspect-menu cell)))
cells))
(defun rlx-inspect (cells &optional header)
"Display cells on the grid GRID at row, column in the hud."
(rlx-fill-hud rlx-current-world (rlx-cells-inspect-menu cells)
header))
(defun rlx-inspect-at (grid row column)
(rlx-inspect
(rlx-grid-get grid row column)))
;; (@* "Inventory")
(defun rlx-cell-inventory-menu-item (cell player default-action alt-action &optional container-cell)
"Generate HUD data showing tile and object name. Return the
menu item data suitable for (rlx-fill-hud). When container-cell
is set, store a reference to the container cell in the data."
;;
;;
(let* ((composed-tile
`((:tile "Black") ,cell))
(menu-data
(list `(
;; display image on left side
(:default-action
,default-action
:alt-action
,alt-action
:text nil
:image ,(rlx-tile-image
(rlx-compose-tile-name composed-tile)
composed-tile)
:width 10
:cell ,cell
:container-cell ,container-cell
)
;; display name/desc on right side
(:default-action
,default-action
:alt-action
,alt-action
:text ,(concat (rlx-name player cell)
(if (rlx-in-category cell :container)
"/"
" "))
:image nil
:width 30
:cell ,cell
:container-cell ,container-cell)))))
;;
menu-data))
(defun rlx-look (cells player &optional header)
"Display an inventory of CELLS from point of view of PLAYER,
with options for picking up and using the items."
(let ((cells-without-player (remove player cells)))
(rlx-fill-hud rlx-current-world
(nreverse (mapcan (lambda (cell)
(rlx-cell-inventory-menu-item
cell
player
`(lambda ()
(rlx-command '(:to
,player
:from
,cell
:action
:take)))
`(lambda ()
(rlx-command '(:to
,cell
:from
,player
:action
:use)))
player))
;;
cells-without-player))
(or header "Looking: ")
:look)))
(defun rlx-inventory-container (container player)
(rlx-fill-hud rlx-current-world
(nreverse (mapcan (lambda (cell)
(rlx-cell-inventory-menu-item
cell
player
`(lambda ()
(rlx-command '(:to
,player
:from
,cell
:action
:drop)))
`(lambda ()
(rlx-command '(:to
,cell
:from
,player
:action
:use)))
container))
;;
(rlx-contents container)))
(concat "Inventory: "
(rlx-name player container)
(format " -- %d total weight"
(rlx-container-weight container)))
:inventory))
;; (@* "Interactive HUD commands")
(defun rlx-hud-move-cursor-up ()
(interactive)
(with-current-buffer
(rlx-world-hud-buffer rlx-current-world)
(cell-sheet-move-cursor-up)))
(defun rlx-hud-move-cursor-down ()
(interactive)
(with-current-buffer
(rlx-world-hud-buffer rlx-current-world)
(cell-sheet-move-cursor-down)))
(defun rlx-hud-select ()
(interactive)
(with-current-buffer
(rlx-world-hud-buffer rlx-current-world)
(with-current-cell-sheet
(cell-sheet-send-bang :default-action))))
(defun rlx-hud-select-alt ()
(interactive)
(with-current-buffer
(rlx-world-hud-buffer rlx-current-world)
(with-current-cell-sheet
(cell-sheet-send-bang :alt-action))))
(defun rlx-hud-move-item-up (&optional into-container)
(interactive)
(with-current-buffer
(rlx-world-hud-buffer rlx-current-world)
(with-current-cell-sheet
;;
;; find out which item we are moving
;; see also (find-function 'rlx-cell-inventory-menu)
(let* ((menu-data (cell-state cell))
(item (getf menu-data :cell))
(event (getf menu-data :event))
(container (getf menu-data :container-cell))
;;
;; the menu data is in the reverse order from the contents
(contents (reverse (rlx-contents container)))
(pos (position item contents :test 'eq)))
;;
;; is it already the first item in the container?
(if (eq 0 pos)
nil ;; do nothing
(let ((other-item (elt contents (- pos 1))))
;; are we moving it into a container, or swapping it with a
;; container?
(if into-container
;; is it really a container
(if (rlx-in-category other-item :container)
;; then put the item in
(progn
;; will it fit?
(if (<= (+ (rlx-weight item)
(rlx-container-weight other-item 'no-count-container))
(or (getf other-item :capacity) 999999))
(progn
(rlx-container-delete container item)
(rlx-container-put other-item item))
(rlx-narrate "The container is full.")))
;; tell the user no!
(rlx-narrate "That is not a container."))
;;
;; otherwise, swap item with container
(rotatef (elt contents pos) (elt contents (- pos 1)))
;; save contents to container cell, reversing again
(setf (getf container :inventory) (reverse contents)))
;; re-render hud data
(rlx-inventory-container container (rlx-world-player rlx-current-world))
;; move cursor to follow item
(dotimes (i (- pos 1))
(cell-sheet-move-cursor-down))))))))
(defun rlx-hud-move-item-down (&optional into-container)
(interactive)
(with-current-buffer
(rlx-world-hud-buffer rlx-current-world)
(with-current-cell-sheet
;;
;; find out which item we are moving
;; see also (find-function 'rlx-cell-inventory-menu)
(let* ((menu-data (cell-state cell))
(item (getf menu-data :cell))
(event (getf menu-data :event))
(container (getf menu-data :container-cell))
;;
;; the menu data is in the reverse order from the contents
(contents (reverse (rlx-contents container)))
(pos (position item contents :test 'eq)))
;;
;; is it already the last item in the container?
(if (eq (- (length contents) 1) pos)
nil ;; do nothing
(let ((other-item (elt contents (+ pos 1))))
;; are we moving it into a container, or swapping it with a
;; container?
(if into-container
;; is it really a container
(if (rlx-in-category other-item :container)
;; then try putting the item in
(progn
;; will it fit?
(if (<= (+ (rlx-weight item) (rlx-container-weight other-item 'no-count-container))
(or (getf other-item :capacity) 999999))
(progn
(rlx-container-delete container item)
(rlx-container-put other-item item))
(rlx-narrate "The container is full.")))
;; tell the user no!
(rlx-narrate "That is not a container."))
;;
;; otherwise, swap item with container
(rotatef (elt contents pos) (elt contents (+ pos 1)))
;; save contents to container cell, reversing again
(setf (getf container :inventory) (reverse contents)))
;; re-render hud data
(rlx-inventory-container container (rlx-world-player rlx-current-world))
;; move cursor down to follow item
(dotimes (i (+ pos 1))
(cell-sheet-move-cursor-down))))))))
(defun rlx-hud-open-container ()
(interactive)
(let ((container (rlx-hud-selected-cell)))
(if (not (rlx-in-category container :container))
(rlx-narrate "That is not a container.")
;;
;; open it up
(rlx-inventory-container container
(rlx-world-player rlx-current-world)))))
(defun rlx-hud-move-item-down-into-container ()
(interactive)
(rlx-hud-move-item-down 'into-container))
(defun rlx-hud-move-item-up-into-container ()
(interactive)
(rlx-hud-move-item-up 'into-container))
(defun rlx-hud-equipment (character)
(rlx-fill-hud rlx-current-world
(mapcan (lambda (slot)
(rlx-equipment-menu-item character slot))
(rlx-equipment-slots character))
(concat "Equipment: " (getf :name character))
:equipment))
(defun rlx-equipment-menu-item (character slot)
"Generate HUD menu item for slot SLOT in equipment of character CHARACTER."
;;
(let* ((item (rlx-equipment-slot character slot))
(default-action `(lambda ()
(rlx-command '(:to
,character
:action
;; (@> "dequipping")
:dequip
:detail
,slot))))
(alt-action `(lambda ()
(rlx-command '(:to
,item
:from
,character
:action
:use))))
(composed-tile
`((:tile "Black") ,item))
(menu-data
(list `(
;; display image on left side
(:default-action
,default-action
:alt-action
,alt-action
:text nil
:cell ,item
:slot ,slot
:image ,(rlx-tile-image
(rlx-compose-tile-name composed-tile)
composed-tile)
:width 10
)
;; display name/desc on right side
(:default-action
,default-action
:alt-action
,alt-action
:cell ,item
:slot ,slot
:text ,(concat (substring (symbol-name slot) 1) ": " (getf item :name))
:image nil
:width 30)))))
;; return menu data
menu-data))
;; (@* "Player status display")
(defun rlx-status (message)
(with-current-buffer (rlx-world-display-buffer rlx-current-world)
(setf header-line-format message)))
(defun rlx-character-status (character)
(let ((message
(mapconcat (lambda (pair) ;; each element is (format-string value)
(if (second pair)
(format (first pair) (second pair))
""))
`(("%s " ,(plist-get character :name))
("HP:%d/" ,(rlx-stat-value character :hit-points))
("%d " ,(rlx-stat-value character :hit-points :max))
("AC:%d " ,(rlx-stat-value character :armor-class))
("ST:%d " ,(rlx-stat-value character :strength))
("DX:%d " ,(rlx-stat-value character :dexterity))
("IN:%d " ,(rlx-stat-value character :intelligence))
("CO:%d " ,(rlx-stat-value character :constitution)))
"")))
(rlx-status message)))
;; (@* "Selecting a cell with the Reticle")
;; All roguelikes need a way of choosing cells to interact with,
;; especially when dealing with enemies and ranged attacks. RLX uses a
;; {\it reticle} to indicate the selected cell. The following functions move
;; the reticle around.
;;
;; The reticle is rendered transparently with
;; (find-function 'rlx-overlay)
(defun rlx-move-reticle (direction)
(let* ((selected-cell (rlx-world-selected-cell rlx-current-world))
(new-cell nil))
(when (null selected-cell)
(setf selected-cell (rlx-world-player rlx-current-world)))
(when (null selected-cell)
(setf selected-cell (car (rlx-world-players rlx-current-world))))
(setf new-cell (destructuring-bind (r c)
(rlx-step-in-direction (getf selected-cell :row)
(getf selected-cell :column)
direction)
(rlx-grid-top-cell (rlx-world-grid rlx-current-world)
r c)))
(setf (rlx-world-selected-cell rlx-current-world) new-cell)
(rlx-render-world rlx-current-world (getf selected-cell :row) (getf selected-cell :column) )))
(defun rlx-move-reticle-west ()
(interactive)
(rlx-move-reticle :west))
(defun rlx-move-reticle-east ()
(interactive)
(rlx-move-reticle :east))
(defun rlx-move-reticle-north ()
(interactive)
(rlx-move-reticle :north))
(defun rlx-move-reticle-south ()
(interactive)
(rlx-move-reticle :south))
(defun rlx-move-reticle-northwest ()
(interactive)
(rlx-move-reticle :northwest))
(defun rlx-move-reticle-northeast ()
(interactive)
(rlx-move-reticle :northeast))
(defun rlx-move-reticle-southwest ()
(interactive)
(rlx-move-reticle :southwest))
(defun rlx-move-reticle-southeast ()
(interactive)
(rlx-move-reticle :southeast))
(defun rlx-cancel-reticle ()
(interactive)
(let ((player (rlx-world-player rlx-current-world)))
(setf (rlx-world-selected-cell rlx-current-world) nil)
(rlx-render-world rlx-current-world (getf player :row) (getf player :column))))
;; (@* "RLX major mode")
(defvar rlx-global-keys `(([(mouse-1)] . rlx-mouse-1)
;;
;; reticle
([(control left)] . rlx-move-reticle-west)
([(control right)] . rlx-move-reticle-east)
([(control up)] . rlx-move-reticle-north)
([(control down)] . rlx-move-reticle-south)
(,(kbd "C-\\") . rlx-cancel-reticle)
(,(kbd "<C-kp-1>") . rlx-move-reticle-southwest)
(,(kbd "<C-kp-2>") . rlx-move-reticle-south)
(,(kbd "<C-kp-3>") . rlx-move-reticle-southeast)
(,(kbd "<C-kp-4>") . rlx-move-reticle-west)
(,(kbd "<C-kp-6>") . rlx-move-reticle-east)
(,(kbd "<C-kp-7>") . rlx-move-reticle-northwest)
(,(kbd "<C-kp-8>") . rlx-move-reticle-north)
(,(kbd "<C-kp-9>") . rlx-move-reticle-northeast)
(,(kbd "<C-kp-divide>") . rlx-cancel-reticle)
;;
;; hud
(,(kbd "RET") . rlx-hud-select)
(,(kbd "<M-kp-enter>") . rlx-hud-select-alt)
(,(kbd "<kp-multiply>") . rlx-hud-move-cursor-down)
(,(kbd "<kp-divide>") . rlx-hud-move-cursor-up)
(,(kbd "<M-kp-multiply>") . rlx-hud-move-item-down)
(,(kbd "<M-kp-divide>") . rlx-hud-move-item-up)
(,(kbd "<C-kp-multiply>") . rlx-hud-move-item-down-into-container)
(,(kbd "<C-kp-divide>") . rlx-hud-move-item-up-into-container)
(,(kbd "<C-kp-enter>") . rlx-hud-open-container)
)
"Alist mapping key combos to interactive functions. These are
global commands that are common to all RLX games.")
;; Here we map each key combo to a command. In RLX a command is either:
;; - a single keyword symbol naming the command
;; - an event cell to be sent from the current player
;; In each case the symbol is passed to (rlx-command), which passes it
;; on to the current player. Commands not handled by the player are
;; handled by (rlx-handle-other-command) which generally handles
;; "global" commands that aren't meant for a player.
(defun rlx-load-keymap (alist)
"Define the rlx-mode-map keymap based on ALIST. ALIST should
map key combos to keyword symbols (or events cells) that
represent commands."
(setf rlx-mode-map
(let ((parent-keymap (make-sparse-keymap))
(keymap (make-sparse-keymap)))
;;
;; first define some things that are common to all RLX games
(mapcar (lambda (mapping)
(destructuring-bind (from . to) mapping
(funcall 'define-key parent-keymap from to)))
rlx-global-keys)
;;
;; now grab the keymap from the game
(mapcar (lambda (mapping)
(destructuring-bind (from . to) mapping
(apply 'define-key
(list keymap
from
`(lambda ()
(interactive)
(rlx-command ,to))))))
alist)
;;
;; now merge them
(set-keymap-parent keymap parent-keymap)
;;
keymap)))
(define-derived-mode rlx-mode nil "RLX"
"RLX Game Console."
())
;; (@* "Mouse support")
(defun rlx-mouse-1 (event)
"Set the selected cell."
(interactive "e")
(destructuring-bind (event-type position &optional ignore) event
(let* ((world rlx-current-world)
(grid (rlx-world-grid world))
(clicked-position (posn-point position))
(columns (rlx-grid-columns (rlx-world-grid rlx-current-world)))
;; calculate which row, column was clicked.
;; each row has (+ 1 columns) characters because of the \n
(clicked-column (- (% clicked-position (+ 1 columns)) 1))
(clicked-row (/ clicked-position (+ 1 columns))))
(let ((clicked-cell (rlx-grid-top-cell
(rlx-world-grid rlx-current-world)
clicked-row clicked-column)))
(rlx-set-selected-cell rlx-current-world clicked-cell)
(rlx-render-world world clicked-row clicked-column)))))
;; (@* "Managing Emacs window configurations")
(defvar rlx-narration-window-size 10 "Height of narration window, in lines.")
(defvar rlx-hud-window-size 14 "Height of heads-up-display window, in lines.")
(defun rlx-arrange-windows ()
(interactive)
(let ((world rlx-current-world))
(delete-other-windows)
(switch-to-buffer (rlx-world-display-buffer world))
(set-window-fringes (selected-window) 0 0)
(split-window-vertically)
(other-window 1)
(switch-to-buffer (rlx-world-hud-buffer world))
(split-window-vertically)
(other-window 1)
(switch-to-buffer (rlx-world-narration-buffer world))
(shrink-window (abs (- rlx-narration-window-size (window-height))))
(other-window 1)))
(provide 'rlx)
;;; rlx.el ends here
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment