Commit df223f5d authored by David O'Toole's avatar David O'Toole

export and reformat lisp files from org-babel

parent e6620195
(defun make-vector (n i)
(make-array n :initial-element i :adjustable t))
(defun make-grid (rows cols)
(let ((grid (make-vector rows nil)))
(dotimes (row rows)
(setf (aref grid row) (make-vector cols nil)))
grid))
(defun grid-get (grid row col)
(aref (aref grid row) col))
(defun grid-set (grid row col value)
(let ((row (aref grid row)))
(setf (aref row col) value)))
(defun grid-columns (grid)
(length (aref grid 0)))
(defun grid-rows (grid)
(length grid))
(defun vector-insert (oldvec pos elt)
"Insert ELT into VECTOR at POS, moving elements at POS and
afterward down the list."
(let* ((len (length oldvec))
(newvec (make-vector (+ len 1) nil)))
(dotimes (i (+ 1 len))
(setf (aref newvec i) (cond
(( < i pos)
(aref oldvec i))
(( equal i pos)
elt)
(( > i pos)
(aref oldvec (- i 1))))))
newvec))
(defun vector-delete (oldvec pos)
"Remove position POS from OLDVEC."
(let* ((len (length oldvec))
(newvec (make-vector (- len 1) nil)))
(dotimes (i (- len 1))
(setf (aref newvec i) (cond
(( < i pos)
(aref oldvec i))
(( >= i pos)
(aref oldvec (+ i 1))))))
newvec))
(defun grid-insert-row (grid row)
"Returns a new grid with a row inserted at row ROW. You should
replace the original grid with this one."
(let* ((newrow (make-vector (grid-columns grid) nil)))
(vector-insert grid row newrow)))
(defun grid-insert-column (grid col)
"Returns a new grid with a column inserted at column COL. You
should replace the original grid with this one."
(dotimes (i (grid-rows grid))
(setf (aref grid i) (vector-insert (aref grid i) col nil)))
grid)
(defun grid-delete-row (grid row)
"Returns a new grid with the row ROW removed. You should replace the original
grid with this one."
(vector-delete grid row))
(defun grid-delete-column (grid col)
"Returns a new grid with the column COL removed. You should
replace the original grid with this one."
(dotimes (i (grid-rows grid))
(setf (aref grid i) (vector-delete (aref grid i) col)))
grid)
(defclass sheet (buffer)
(top-margin :initform 18 :initarg :top-margin :accessor top-margin)
(node-spacing :initform 10 :initarg :node-spacing :accessor node-spacing)
(node-size :initform *default-node-size* :initarg :node-size :accessor node-size)
(snap-to-grid-p :initform t :initarg :snap-to-grid-p :accessor snap-to-grid-p)
(x-offset :initform 0 :initarg :x-offset :accessor x-offset)
(y-offset :initform 0 :initarg :x-offset :accessor x-offset))
(defmethod find-methods append ((sheet sheet)) '(arrange auto-arrange))
(defmethod node-stride ((sheet sheet))
(+ (node-size sheet)
(node-spacing sheet)))
(defmethod initialize-instance :after ((sheet sheet) &key)
(resize sheet *screen-width* *screen-height*)
(open-shell sheet)
(populate sheet))
(defmethod grid-position ((sheet sheet) x y)
(let ((stride (node-stride sheet))
(spacing (node-spacing sheet))
(top-margin (top-margin sheet)))
(values (+ spacing (* x stride))
(+ top-margin spacing (* y stride)))))
(defmethod place-node ((sheet sheet) (node node) x y)
;; (multiple-value-bind (ix iy) (grid-position sheet x y)
(move-to node x y))
(defmethod auto-resize ((node node) (sheet sheet))
(let ((size (node-size sheet)))
(resize node size size)))
(defmethod last-column ((sheet sheet))
(1- (length (aref (grid sheet) 0))))
(defmethod last-row ((sheet sheet))
(1- (length (grid sheet))))
(defmethod last-screen-column ((sheet sheet))
(1- (truncate (/ *screen-width* (node-stride sheet)))))
(defmethod last-screen-row ((sheet sheet))
(1- (truncate (/ *screen-height* (node-stride sheet))) 2))
(defmethod snap-to-grid ((node node) (sheet sheet))
(with-slots (x y) node
(place-node sheet node
(truncate (/ x (node-stride sheet)))
(truncate (/ y (node-stride sheet))))))
(defclass cell-sheet (sheet)
((grid :initform (make-grid 24 80) :accessor grid :initarg :grid)
(cursor-row :initform 0 :initarg :cursor-row :accessor cursor-row)
(cursor-column :initform 0 :initarg :cursor-column :accessor cursor-column)
(borders-p :initform nil :initarg :borders-p :accessor borders-p)
(headers-p :initform nil :initarg :headers-p :accessor headers-p)
(column-stops :initform nil :initarg :column-stops :accessor column-stops)))
(defmethod set-cell ((sheet sheet) (node node) row column)
(add-node sheet node)
(grid-set (grid sheet) row column node))
(defmethod get-cell ((sheet sheet) row column)
(grid-get (grid sheet) row column))
(defmethod cell ((sheet sheet) row column)
(get-cell sheet row column))
(defmethod (setf cell) ((node node) (sheet sheet) row column)
(set-cell sheet node row column))
;; (defmethod auto-arrange ((sheet cell-sheet))
(defmethod insert-row ((sheet sheet))
(with-slots (grid cursor-row) sheet
(setf grid (grid-insert-column grid cursor-row))))
(defmethod insert-column ((sheet sheet))
(with-slots (grid cursor-column) sheet
(setf grid (grid-insert-column grid cursor-column))))
(defmethod delete-row ((sheet sheet))
(with-slots (grid cursor-row) sheet
(setf grid (grid-delete-column grid cursor-row))))
(defmethod delete-column ((sheet sheet))
(with-slots (grid cursor-column) sheet
(setf grid (grid-delete-column grid cursor-column))))
(defmethod set-cursor ((sheet sheet) row column)
(setf (cursor-row sheet) row)
(setf (cursor-column sheet) column))
(defmethod move-cursor ((sheet sheet) direction)
(with-slots (grid cursor-row cursor-column) sheet
(let* ((rows (grid-rows grid))
(cols (grid-columns grid))
(new-cursor
(case direction
(:up (if (/= 0 cursor-row)
(list (- cursor-row 1) cursor-column)
cursor))
(:left (if (/= 0 cursor-column)
(list cursor-row (- cursor-column 1))
cursor))
(:down (if (< cursor-row (- rows 1))
(list (+ cursor-row 1) cursor-column)
cursor))
(:right (if (< cursor-column (- cols 1))
(list cursor-row (+ cursor-column 1))
cursor)))))
(destructuring-bind (row column) new-cursor
(set-cursor sheet row column)))))
(defmethod move-cursor-up ((sheet sheet))
(interactive)
(move-cursor sheet :up))
(defmethod move-cursor-left ((sheet sheet))
(interactive)
(move-cursor sheet :left))
(defmethod move-cursor-down ((sheet sheet))
(interactive)
(move-cursor sheet :down))
(defmethod move-cursor-right ((sheet sheet))
(interactive)
(move-cursor sheet :right))
(defmethod all-cells ((sheet sheet))
(let ((grid (grid sheet))
(cell nil)
(cells nil))
(dotimes (r (grid-rows grid))
(dotimes (c (grid-columns grid))
(when (setf cell (grid-get grid r c))
(push cell cells))))
(nreverse cells)))
(defparameter *sheet-header-font* "sans-9")
(defmethod header-width ((sheet sheet))
(font-text-width (format nil "~d" (grid-rows (grid sheet))) :font *sheet-header-font*))
(defmethod header-height ((sheet sheet))
(font-height *sheet-header-font*))
(defparameter *minimum-column-width* 12)
(defparameter *minimum-row-height* 12)
(defmethod layout ((sheet sheet))
(with-slots (grid cursor-row cursor-column headers-p borders-p) sheet
(let* ((rows (grid-rows grid))
(columns (grid-columns grid))
(column-width 0)
(row-height 0)
(cell-width 0)
(cell nil)
(row-header-width 0)
(column-header-height 0)
(widths (make-vector columns 0))
(heights (make-vector rows 0)))
;; compute row header width for along left side
(when headers-p
(setf row-header-width (header-width sheet))
(setf column-header-height (header-height sheet)))
;; compute widths of columns
(dotimes (col columns)
(setf column-width *minimum-column-width*)
(dotimes (row rows)
(setf cell (cell sheet row col))
(when cell
(layout cell)
(setf column-width (max column-width (width cell)))))
(setf (aref widths col) column-width))
;; compute heights of rows
(dotimes (row rows)
(setf row-height *minimum-row-height*)
(dotimes (col columns)
(setf cell (cell sheet row col))
(when cell
(setf row-height (max row-height (height cell)))))
(setf (aref heights row) row-height))
;; move objects
(dotimes (col columns)
(let ((x 0)
(y column-header-height))
(dotimes (row rows)
(setf x row-header-width)
(let ((cell (cell sheet row col)))
(when cell
(move-to cell x y)))
(incf x (aref widths col)))
(incf y (aref heights row)))))))
This diff is collapsed.
This diff is collapsed.
#+TITLE: Dave's guide to Common Lisp game development
#+OPTIONS: toc:2 *:nil
#+PROPERTY: header-args:lisp :results silent
#+PROPERTY: header-args:lisp :results silent :comments org
#+INFOJS_OPT: view:info mouse:underline up:index.html home:http://xelf.me toc:t ftoc:t ltoc:t
* Overview
......
......@@ -3,7 +3,7 @@
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en">
<head>
<!-- 2017-04-12 Wed 06:34 -->
<!-- 2017-05-03 Wed 16:01 -->
<meta http-equiv="Content-Type" content="text/html;charset=utf-8" />
<meta name="viewport" content="width=device-width, initial-scale=1" />
<title>The game of Squareball</title>
......@@ -357,7 +357,7 @@ for the JavaScript code in this tag.
</li>
<li><a href="#org5fbc7be">Player robots</a>
<ul>
<li><a href="#org05d4117">Properties</a></li>
<li><a href="#org0654956">Properties</a></li>
<li><a href="#orga78f7de">Utilities</a></li>
<li><a href="#orgc5faa6b">Kicking the Squareball</a></li>
<li><a href="#org29bc0ce">Friction modification</a></li>
......@@ -417,7 +417,7 @@ for the JavaScript code in this tag.
<li><a href="#org4bbae53">Building the Arena buffer</a>
<ul>
<li><a href="#orga0483d0">A border around the playfield</a></li>
<li><a href="#org0654956">Properties</a></li>
<li><a href="#orgc3e74cb">Properties</a></li>
<li><a href="#org234d62d">Updating timers</a></li>
<li><a href="#org3d7bed4">Adding keybindings</a></li>
<li><a href="#org9e18cdd">Populating the board with objects</a></li>
......@@ -575,8 +575,8 @@ Networking and Setup sections below.)
<div class="org-src-container">
<pre class="src src-lisp"> (<span style="color: #f47321;">defun</span> <span style="color: #9370db;">show-copyright-notice</span> ()
(<span style="color: #f47321;">dolist</span> (line (split-string-on-lines *squareball-copyright-notice*))
(message line))
(show-terminal))
(message line)))
<span style="color: #999999; font-style: italic;">;;</span><span style="color: #7f7f7f; font-style: italic;">(show-terminal))</span>
</pre>
</div>
</div>
......@@ -595,15 +595,16 @@ These should be set before the window opens, i.e. before <a href="dictionary/WIT
(<span style="color: #f47321;">defparameter</span> <span style="color: #da70d6;">*height*</span> 720)
(<span style="color: #f47321;">defun</span> <span style="color: #9370db;">configure-screen</span> ()
(setf *font* <span style="color: #8b7d7b;">"sans-11"</span>)
(setf *frame-rate* 60)
(setf *font-texture-scale* 2)
(setf *font-texture-scale* 1)
(setf *font-texture-filter* <span style="color: #db7093;">:linear</span>)
(setf *window-title* *title-string*)
(setf *screen-width* *width*)
(setf *screen-height* *height*)
(setf *nominal-screen-width* *width*)
(setf *nominal-screen-height* *height*)
(setf *scale-output-to-window* t))
(setf *scale-output-to-window* nil))
</pre>
</div>
</div>
......@@ -1589,9 +1590,9 @@ startup.
<div id="outline-container-org5fbc7be" class="outline-2">
<h2 id="org5fbc7be">Player robots</h2>
<div class="outline-text-2" id="text-org5fbc7be">
</div><div id="outline-container-org05d4117" class="outline-3">
<h3 id="org05d4117">Properties</h3>
<div class="outline-text-3" id="text-org05d4117">
</div><div id="outline-container-org0654956" class="outline-3">
<h3 id="org0654956">Properties</h3>
<div class="outline-text-3" id="text-org0654956">
<div class="org-src-container">
<pre class="src src-lisp">(<span style="color: #f47321;">defparameter</span> <span style="color: #da70d6;">*max-speed*</span> 2.4)
(<span style="color: #f47321;">defparameter</span> <span style="color: #da70d6;">*max-carry-speed*</span> 2.3)
......@@ -2649,9 +2650,9 @@ Pathfinding for Player 1 is turned off.
</div>
</div>
<div id="outline-container-org0654956" class="outline-3">
<h3 id="org0654956">Properties</h3>
<div class="outline-text-3" id="text-org0654956">
<div id="outline-container-orgc3e74cb" class="outline-3">
<h3 id="orgc3e74cb">Properties</h3>
<div class="outline-text-3" id="text-orgc3e74cb">
<div class="org-src-container">
<pre class="src src-lisp">(<span style="color: #f47321;">defclass</span> <span style="color: #83a525;">arena</span> (xelf:buffer)
((resetting <span style="color: #db7093;">:initform</span> nil)
......@@ -2705,7 +2706,7 @@ See also <a href="dictionary/BIND-EVENT.html">BIND-EVENT</a> and <a href="dictio
<pre class="src src-lisp">(<span style="color: #f47321;">defmethod</span> <span style="color: #9370db;">initialize-instance</span> <span style="color: #db7093;">:after</span> ((arena arena) <span style="color: #83a525;">&amp;key</span>)
(setf *arena* arena)
(resize arena *width* *height*)
(bind-event arena '(<span style="color: #db7093;">:space</span>) 'spacebar)
<span style="color: #999999; font-style: italic;">;; </span><span style="color: #7f7f7f; font-style: italic;">(bind-event arena '(:space) 'spacebar)</span>
(bind-event arena '(<span style="color: #db7093;">:return</span>) 'spacebar)
(bind-event arena '(<span style="color: #db7093;">:pageup</span>) 'select-variation)
(bind-event arena '(<span style="color: #db7093;">:escape</span>) 'setup)
......@@ -3132,7 +3133,7 @@ These strings are segregated here for easier localization and editing.
(logging <span style="color: #8b7d7b;">"~S"</span> c))))
(<span style="color: #f47321;">defun</span> <span style="color: #9370db;">show-prompt</span> ()
(show-terminal)
<span style="color: #999999; font-style: italic;">;;</span><span style="color: #7f7f7f; font-style: italic;">(show-terminal)</span>
(setf *prompt* (make-instance 'ip-prompt))
(move-to *prompt* *terminal-left* *terminal-bottom*))
......@@ -3252,7 +3253,8 @@ These strings are segregated here for easier localization and editing.
<pre class="src src-lisp"> (<span style="color: #f47321;">defun</span> <span style="color: #9370db;">squareball</span> (<span style="color: #83a525;">&amp;rest</span> args)
(setf *use-fortresses* nil)
(setf *use-bumpers* nil)
(setf *use-antialiased-text* nil)
(setf *scale-output-to-window* nil)
(setf *use-antialiased-text* t)
(setf *variation* 4)
(configure-screen)
(<span style="color: #f47321;">with-session</span>
......@@ -3262,7 +3264,7 @@ These strings are segregated here for easier localization and editing.
(index-pending-resources)
(preload-resources)
<span style="color: #999999; font-style: italic;">;; </span><span style="color: #7f7f7f; font-style: italic;">preload music </span>
(setf *default-texture-filter* <span style="color: #db7093;">:nearest</span>)
(setf *default-texture-filter* <span style="color: #db7093;">:linear</span>)
(mapc #'find-resource '(<span style="color: #8b7d7b;">"rhythm.ogg"</span> <span style="color: #8b7d7b;">"fanfare-1.ogg"</span> <span style="color: #8b7d7b;">"fanfare-2.ogg"</span> <span style="color: #8b7d7b;">"vixon.ogg"</span> <span style="color: #8b7d7b;">"end.ogg"</span> <span style="color: #8b7d7b;">"beatdown.ogg"</span>))
(initialize-sounds)
(apply #'play-squareball args)))
......@@ -3424,7 +3426,7 @@ These strings are segregated here for easier localization and editing.
</div>
<div id="postamble" class="status">
<p class="author">Author: David O'Toole</p>
<p class="date">Created: 2017-04-12 Wed 06:34</p>
<p class="date">Created: 2017-05-03 Wed 16:01</p>
<p class="validation"><a href="http://validator.w3.org/check?uri=referer">Validate</a></p>
</div>
</body>
......
#+TITLE: The game of Squareball
#+OPTIONS: toc:3 *:nil
#+PROPERTY: header-args:lisp :results silent :noweb yes :tangle ../squareball/squareball.lisp :comments both
#+PROPERTY: header-args:lisp :results silent :noweb yes :tangle ../squareball/squareball.lisp :comments org
#+INFOJS_OPT: view:info mouse:underline up:index.html home:http://xelf.me toc:t ftoc:t ltoc:t
* Overview
......
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment