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 diff is collapsed.
#+TITLE: Xelf: The Graphical User Interface Toolkit
#+AUTHOR: David O'Toole <dto@xelf.me>
#+OPTIONS: toc:3 *:nil
#+PROPERTY: header-args:lisp :results silent :noweb no :tangle gui.lisp :package "xelf" :comments both
#+PROPERTY: header-args:lisp :results silent :noweb no :tangle gui.lisp :package "xelf" :comments org
#+INFOJS_OPT: view:info mouse:underline up:xelf.html home:http://xelf.me toc:t ftoc:t ltoc:t
# (setq org-confirm-babel-evaluate nil)
......@@ -206,12 +206,20 @@ every BUFFER is also a NODE.)
(add-hook '*resize-hook* #'resize-current-buffer-to-window)
#+end_src
** Buffers can't have halos or be selected
** Only clipped buffers can be selected/haloed
#+begin_src lisp
(defmethod make-halo ((self buffer)) nil)
(defmethod select ((self buffer)) nil)
(defmethod unselect ((self buffer)) nil)
(defmethod make-halo :around ((self buffer))
(when (clipped-p self)
(call-next-method)))
(defmethod select :around ((self buffer))
(when (clipped-p self)
(call-next-method)))
(defmethod unselect :around ((self buffer))
(when (clipped-p self)
(call-next-method)))
#+end_src
** Pausing the action
......@@ -759,21 +767,21 @@ This section is obsolete and will be removed in the future.
(defmethod after-draw-object ((self buffer) object))
(defmethod draw :before ((self buffer))
(defmethod draw :around ((self buffer))
(if (not (clipped-p self))
(project-window self)
(progn (enable-clipping)
(apply #'set-clip-rectangle (clip-rectangle self))
(gl:matrix-mode :projection)
(destructuring-bind (x y w h) (clip-rectangle self)
(gl:translate x y 0)))))
(defmethod draw :after ((self buffer))
(when (clipped-p self)
(gl:matrix-mode :projection)
(destructuring-bind (x y w h) (clip-rectangle self)
(gl:translate (- 0 x) (- 0 y) 0))
(disable-clipping)))
(progn (project-window self)
(call-next-method))
(progn
(apply #'set-clip-rectangle (clip-rectangle self))
(enable-clipping)
(gl:matrix-mode :projection)
(destructuring-bind (x y w h) (clip-rectangle self)
(gl:translate x y 0))
(call-next-method)
(gl:matrix-mode :projection)
(destructuring-bind (x y w h) (clip-rectangle self)
(gl:translate (- 0 x) (- 0 y) 0))
(disable-clipping))))
(defmethod visit :after ((self buffer))
(clip self))
......@@ -1148,7 +1156,9 @@ This section is obsolete and will be removed in the future.
(when selection (mapc #'layout selection))))
(defmethod update :after ((buffer buffer))
(when (and *shell* (shell-p buffer))
(when (and (not (clipped-p buffer))
*shell*
(shell-p buffer))
(layout *shell*)
(update *shell*)))
#+end_src
......@@ -6437,6 +6447,12 @@ PCL, the CLOS implementation written originally by Xerox.
(center frame)
(align-to-pixels frame)
(bring-to-front frame)))
(defun show-cell-sheet* ()
(let ((sheet (find-buffer "*cell sheet*" :create t :class 'cell-sheet)))
(add-node (current-buffer) sheet)
;; (resize sheet 400 400)
(move-to sheet 200 200)))
#+end_src
......
;; Defining a loadable system: the file PLONG.ASD
;; We must create a small .ASD file with your project's name and source
;; file.
;; #+name: plong.asd
(asdf:defsystem #:plong
:depends-on (:xelf)
:components ((:file "plong")))
;; Common Lisp packages
;; Then we must define a Common Lisp "package" for our game's code to
;; inhabit.
(defpackage :plong
(:use :cl :xelf)
(:export plong))
;; Then we declare what package the source file is in.
(in-package :plong)
;; Configuring your space
;; Here we define an arbitrary measurement unit used throughout, and
;; set up some variables to hold the height and width of the game
;; world.
(defparameter *unit* 16)
(defun units (n) (* *unit* n))
(defparameter *width* 640)
(defparameter *height* 480)
;; Defining Xelf game objects
;; Now it's time to define some game objects. Xelf game objects are
;; called "nodes", and they can interact in two dimensions by being
;; grouped into "buffers" of different kinds. Naturally there are base
;; classes called NODE and BUFFER. These classes define the basic
;; behaviors of the game engine. Nodes are endowed with such properties
;; as an (X Y) position, width, height, an image to be displayed, and so
;; on. The default node behaviors also hook all game objects into buffer
;; features, such as collision detection, pathfinding, and serialization.
;; To define nodes of your own, use DEFCLASS and give NODE as a
;; superclass. You can override the default values of NODE slots, as well
;; as add your own.
(defclass ball (node)
((height :initform (units 1))
(width :initform (units 1))
......@@ -16,13 +50,32 @@
(speed :initform 6)
(heading :initform (direction-heading :downright))))
;; The generic function [[file:dictionary/UPDATE.html][UPDATE]] is called on each object once during
;; each game loop.
(defmethod update ((ball ball))
(with-slots (heading speed) ball
(move ball heading speed)))
;; Now we need walls around the game world in order to contain the
;; ball.
(defclass wall (node)
((color :initform "gray50")))
;; Handling collisions
;; We want the ball to bounce off of the walls. The [[file:dictionary/COLLIDE.html][COLLIDE]] method is
;; called for every frame on all pairs of objects whose bounding boxes
;; collide during that frame.
(defmethod collide ((ball ball) (wall wall))
(with-slots (heading speed x y) ball
;; back away from wall
......@@ -32,11 +85,23 @@
;; sometimes choose another direction to prevent getting stuck
(percent-of-time 10 (incf heading (radian-angle 90)))))
;; Making noise
;; The ball should emit a retro beep when colliding with any node. We
;; use [[file:dictionary/DEFRESOURCE.html][DEFRESOURCE]] to let Xelf know about the sound file.
(defresource "bip.wav" :volume 20)
(defmethod collide :after ((ball ball) (node node))
(play-sample "bip.wav"))
;; Destructible colored bricks
;; Now it's time to bash some bricks! First we define the dimensions
;; of a brick and create a class.
(defparameter *brick-width* (units 2))
(defparameter *brick-height* (units 1.2))
......@@ -45,18 +110,41 @@
(height :initform *brick-height*)
(width :initform *brick-width*)))
;; Here's how we can add color to bricks when they're being created.
(defmethod initialize-instance :after ((brick brick) &key color)
(when color
(setf (slot-value brick 'color) color)))
;; Finally, the ball should bounce off the bricks and break them. See
;; also [[file:dictionary/DESTROY.html][DESTROY]] and [[file:dictionary/RADIAN-ANGLE.html][RADIAN-ANGLE]].
(defmethod collide ((ball ball) (brick brick))
(with-slots (heading) ball
(destroy brick)
(incf heading (radian-angle 90))))
;; Referring to global objects
;; Now we define some useful shorthand functions to refer to the ball and
;; paddle.
(defun ball () (slot-value (current-buffer) 'ball))
(defun paddle () (slot-value (current-buffer) 'paddle))
;; Controlling the player
;; The player controls a rectangular paddle which can move left or
;; right within the buffer.
(defclass paddle (node)
((direction :initform nil)
(height :initform (units 1))
......@@ -65,6 +153,14 @@
(defparameter *paddle-speed* 3)
;; Now we define some handy functions to check whether the player is
;; pressing left or right on the keyboard. Numeric keypad is also
;; supported---it's a good idea to check both when using arrows to
;; control your game.
(defun holding-left-arrow ()
(or (keyboard-down-p :kp4)
(keyboard-down-p :left)))
......@@ -88,17 +184,47 @@
(cond ((holding-left-arrow) :left)
((holding-right-arrow) :right))))
;; See also:
;; - [[file:dictionary/KEYBOARD-DOWN-P.html][KEYBOARD-DOWN-P]]
;; - [[file:dictionary/NUMBER-OF-JOYSTICKS.html][NUMBER-OF-JOYSTICKS]]
;; - [[file:dictionary/LEFT-ANALOG-STICK-PRESSED-P.html][LEFT-ANALOG-STICK-PRESSED-P]]
;; - [[file:dictionary/LEFT-ANALOG-STICK-HEADING.html][LEFT-ANALOG-STICK-HEADING]]
;; In the paddle's UPDATE method, we read the inputs and move the
;; paddle accordingly.
(defmethod update ((paddle paddle))
(with-slots (direction) paddle
(setf direction (find-direction))
(when direction
(move paddle (direction-heading direction) *paddle-speed*))))
;; Keeping the paddle in the playfield
;; The paddle should bounce back from the walls, too.
(defmethod collide ((paddle paddle) (wall wall))
(with-slots (direction) paddle
(setf direction (opposite-direction direction))
(move paddle (direction-heading direction) (* *paddle-speed* 2))))
;; See also:
;; - [[file:dictionary/OPPOSITE-DIRECTION.html][OPPOSITE-DIRECTION]]
;; - [[file:dictionary/DIRECTION-HEADING.html][DIRECTION-HEADING]]
;; The "english" is the directional force applied to the ball because
;; of the player's moving the paddle to the left or right at the
;; moment of collision.
(defmethod english ((paddle paddle))
(with-slots (direction) paddle
(case direction
......@@ -107,17 +233,37 @@
(otherwise (+ (slot-value (ball) 'heading)
(radian-angle 90))))))