The game of Squareball

Table of Contents


Use the N and P keys to flip to the Next and Previous pages, or click the links in the header. Press B to go Back or "?" for help. This document can also be browsed as a single large web page without Javascript.

In this document we will implement a small multiplayer game in Common Lisp (called "Squareball") using my game engine Xelf. You can download and play the game from, or compile it using Xelf as you go along with the tutorial.

This document is part of Dave's guide to Common Lisp game development. It will help to have completed reading the "2D Sprites with Xelf" example on that page before continuing.

The Lisp code and documentation below are interwoven in an Emacs Org-mode file, which is exported to both HTML (for reading) and to plain Lisp (for compilation) in a manner similar to "literate programming". (The raw source can be seen on Gitlab.)

My purpose in documenting a complete game is to help others learn about using Xelf and to impart general knowledge about game development in Common Lisp.

This document is a work in progress; the headings marked with a red "TODO" still need documentation to be written.

System and package definitions

As usual we must write SQUAREBALL.ASD:

 (asdf:defsystem #:squareball
  :depends-on (:xelf)
  :components ((:file "squareball")))

Then in our main source file:

(defpackage #:squareball
  (:use #:cl #:xelf)
  (:export squareball))

(in-package :squareball)

Showing the copyright notice

Your game should include a copyright notice that is printed to the terminal, and ideally displayed onscreen. Here we set up a variable with the appropriate text.

(defparameter *squareball-copyright-notice*
Welcome to Squareball. 
Squareball and Xelf are Copyright (C) 2006-2017 by David T. O'Toole 
email: <>   website:

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

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of

Full license text of the GNU Lesser General Public License is in the
enclosed file named 'COPYING'. Full license texts for compilers,
assets, libraries, and other items are contained in the LICENSES
directory included with this application.


The function SHOW-COPYRIGHT-NOTICE uses MESSAGE to print the successive lines of text. The output can be seen in the REPL or in your game's STANDARD-OUTPUT stream. The Xelf Terminal is an in-game tool for viewing these messages as an overlay on top of your game window, somewhat like the old Quake Terminal.

(The Terminal can also be used for data and command input; see the Networking and Setup sections below.)

  (defun show-copyright-notice ()
    (dolist (line (split-string-on-lines *squareball-copyright-notice*))
      (message line))

Display properties

Setting up the screen in Xelf mostly involves setting some variables. These should be set before the window opens, i.e. before WITH-SESSION.

  (defparameter *width* 1280)
  (defparameter *height* 720)

  (defun configure-screen ()
    (setf *frame-rate* 60)
    (setf *font-texture-scale* 2)
    (setf *font-texture-filter* :linear)
    (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))

Establishing grid unit size

(defparameter *unit* 20)
(defun units (n) (* n *unit*))

Color definitions

Xelf offers built-in X11 color names for convenience, but it's best to sequester color choices behind variables too so that things can be easily reconfigured to accommodate users with color-vision impairment. This nicely gets you theme support, too.

(defparameter *player-1-color* "hot pink")
(defparameter *player-2-color* "orange")

(defparameter *player-1-fortress-colors* '("dark orchid" "medium orchid" "orchid"))
(defparameter *player-2-fortress-colors* '("dark orange" "orange" "gold"))
(defparameter *traditional-robot-colors* '("gold" "olive drab" "RoyalBlue3" "dark orchid"))

(defparameter *neutral-color* "white")
(defparameter *arena-color* "gray24")
(defparameter *wall-color* "gray20")

Music resources

The player should be able to turn off the game's background music. We use a variable to track whether the music is on or off.

  (defvar *use-music* nil)

Then we bring in some Ogg Vorbis music files from the project directory, using DEFRESOURCE.

  (defresource "beatdown.ogg" :volume 63)
  (defresource "rhythm.ogg" :volume 28)
  (defresource "fanfare-1.ogg" :volume 50)
  (defresource "fanfare-2.ogg" :volume 50)
  (defresource "vixon.ogg" :volume 50)
  (defresource "end.ogg" :volume 50)

Notice how you can adjust the volume of a sample by providing the :VOLUME keyword and a value. This should be an integer between 0 and 127.

Now we define some functions to play a background rhythm and various other musical cues, using the PLAY-MUSIC function.

  (defun play-rhythm ()
    (when *use-music* (play-music "rhythm.ogg" :loop t)))

  (defun play-fanfare-1 () 
    (when *use-music* (play-music "fanfare-1.ogg" :loop nil)))

  (defun play-fanfare-2 ()
    (when *use-music* (play-music "fanfare-2.ogg" :loop nil)))

  (defun play-end-music ()
    (when *use-music* (play-music "end.ogg" :loop nil)))

The function TOGGLE-MUSIC turns the music on or off, depending on the current setting of the variable.

  (defun toggle-music ()
    (setf *use-music* (if *use-music* nil t))
    (if *use-music*

You can also fade out the music; see the documentation for HALT-MUSIC.

Sound resources

Now we pull in the sound effects, in the form of WAV files.

(defresource "go.wav" :volume 23)
(defresource "serve.wav" :volume 23)
(defresource "grab.wav" :volume 23)
(defresource "bounce.wav" :volume 10)
(defresource "newball.wav" :volume 20)
(defresource "return.wav" :volume 20)
(defresource "error.wav" :volume 40)

      (:name "boop1.wav" :type :sample :file "boop1.wav" :properties (:volume 20))
      (:name "boop2.wav" :type :sample :file "boop2.wav" :properties (:volume 20))
    (:name "boop3.wav" :type :sample :file "boop3.wav" :properties (:volume 20)))

(defparameter *bounce-sounds* '("boop1.wav" "boop2.wav" "boop3.wav"))

    (:name "doorbell1.wav" :type :sample :file "doorbell1.wav" :properties (:volume 23))
    (:name "doorbell2.wav" :type :sample :file "doorbell2.wav" :properties (:volume 23))
  (:name "doorbell3.wav" :type :sample :file "doorbell3.wav" :properties (:volume 23)))

(defparameter *doorbell-sounds* '("doorbell1.wav" "doorbell2.wav" "doorbell3.wav"))

(defparameter *slam-sounds*
      (:name "slam1.wav" :type :sample :file "slam1.wav" :properties (:volume 52))
      (:name "slam2.wav" :type :sample :file "slam2.wav" :properties (:volume 52))
    (:name "slam3.wav" :type :sample :file "slam3.wav" :properties (:volume 52))))

    (:name "whack1.wav" :type :sample :file "whack1.wav" :properties (:volume 42))
    (:name "whack2.wav" :type :sample :file "whack2.wav" :properties (:volume 42))
  (:name "whack3.wav" :type :sample :file "whack3.wav" :properties (:volume 42)))

(defparameter *whack-sounds* '("whack1.wav" "whack2.wav" "whack3.wav"))

    (:name "color1.wav" :type :sample :file "color1.wav" :properties (:volume 32))
    (:name "color2.wav" :type :sample :file "color2.wav" :properties (:volume 32))
  (:name "color3.wav" :type :sample :file "color3.wav" :properties (:volume 32)))

(defparameter *color-sounds* '("color1.wav" "color2.wav" "color3.wav"))

The reason for keeping lists of variants for WHACK, SLAM, BOUNCE, and so on is so that we can choose from several samples randomly and create a variety of sound patterns.

Features and variations

Several optional features are available: Fortresses, Bumpers, and high AI difficulty. Each numbered Variation decides which of these features are present and which are absent in a given play session. (I am planning to add more features to the game, for more gameplay variations.)

(defvar *use-fortresses* nil)
(defvar *use-bumpers* nil)
(defvar *difficult* nil)

(defun fortresses-p () *use-fortresses*)
(defun bumpers-p () *use-bumpers*)
(defun difficult-p () *difficult*)

Each row in the following table is one of the available play variations.

(defparameter *variations* 
  '(() ;; 1
    (:fortresses) ;; 2
    (:bumpers) ;; 3
    (:fortresses :bumpers) ;; 4
    (:difficult) ;; 5
    (:fortresses :difficult) ;; 6
    (:bumpers :difficult) ;; 7
    (:fortresses :bumpers :difficult)))

The default Variation is to have both Fortresses and Bumpers, but easy AI.

(defvar *variation* 4)

Now we write CONFIGURE-GAME, whose function is to actually set up the variation's variables for each play session.

(defun variation-features (n)
  (let ((index (mod (1- n) (length *variations*))))
    (nth index *variations*)))

(defun configure-game (&optional (variation *variation*))
  (setf *use-fortresses* nil)
  (setf *use-bumpers* nil)
  (setf *difficult* nil)
  (dolist (feature (variation-features variation))
    (case feature
      (:difficult (setf *difficult* t))
      (:bumpers (setf *use-bumpers* t))
      (:fortresses (setf *use-fortresses* t)))))

Global objects

The main objects of the game are the playfield itself (called the Arena), the two players, their respective goals, the Squareball, and the end-zone barriers.

In the following section, we set up some global variables and functions we can use to access these basic objects at any time in implementing the game.

(We will develop a method later on called POPULATE which sets these variables correctly for each play session.)

(defvar *ball* nil)
(defun ball () *ball*)
(defvar *arena* nil)
(defun arena () *arena*)
(defvar *player-1* nil)
(defvar *player-2* nil)
(defvar *goal-1* nil)
(defvar *goal-2* nil)
(defun player-1 () *player-1*)
(defun player-2 () *player-2*)
(defun set-player-1 (x) (setf *player-1* x))
(defun set-player-2 (x) (setf *player-2* x))

(defvar *barrier-1* nil)
(defvar *barrier-2* nil)
(defun barrier-1 () *barrier-1*)
(defun barrier-2 () *barrier-2*)
(defun set-barrier-1 (x) (setf *barrier-1* x))
(defun set-barrier-2 (x) (setf *barrier-2* x))

(defun player-1-p (x) (eq (find-object x) (find-object *player-1*)))
(defun player-2-p (x) (eq (find-object x) (find-object *player-2*)))
(defun goal-1 () *goal-1*)
(defun goal-2 () *goal-2*)
(defun set-goal-1 (x) (setf *goal-1* x))
(defun set-goal-2 (x) (setf *goal-2* x))
(defun goal-1-p (x) (eq (find-object x) (find-object *goal-1*)))
(defun goal-2-p (x) (eq (find-object x) (find-object *goal-2*)))
(defun opponent (x) (cond ((player-1-p x) (player-2)) 
                          ((player-2-p x) (player-1))))

(defun either-goal-flashing-p ()
  (or (slot-value (goal-1) 'timer)
      (slot-value (goal-2) 'timer)))

(defun find-robots ()
  (find-instances (arena) 'robot))

(defun ball-carrier ()
  (find-if #'carrying-ball-p (find-robots)))

Game clock

(defparameter *game-length* (minutes 8))

(defvar *game-clock* 0)

(defun reset-game-clock ()
  (setf *game-clock* (if *use-fortresses* (minutes 8) *game-length*)))

(defun update-game-clock ()
  (when (plusp *game-clock*)
    (decf *game-clock*)))

(defun game-on-p () (plusp *game-clock*))

(defun game-clock () *game-clock*)

(defun game-clock-string (&optional (clock *game-clock*))
  (let ((minutes (/ clock (minutes 1)))
        (seconds (/ (rem clock (minutes 1)) 
                    (seconds 1))))
    (format nil "~D~A~2,'0D" (truncate minutes) ":" (truncate seconds))))

The serve period is the first second of a match

(defvar *serve-period-timer* 0)
(defparameter *serve-period* 60)

(defun update-serve-period-timer ()
  (when (plusp *serve-period-timer*)
    (decf *serve-period-timer*)))

(defun serve-period-p ()
  (plusp *serve-period-timer*))

(defun begin-serve-period ()
  (setf *serve-period-timer* *serve-period*))

Keeping score

(defvar *score-1* 0)
(defvar *score-2* 0)

(defun reset-score () (setf *score-1* 0 *score-2* 0))

(defmethod score-point (player)
  (ecase player
    (1 (incf *score-1*) (play-fanfare-1))
    (2 (incf *score-2*) (play-fanfare-2))))

Defining objects with simple physics

Base class

 (defclass thing (xelf:node)
   ((color :initform *neutral-color*)
    (heading :initform 0.0)
    (obstacle-p :initform nil :accessor obstacle-p)
    ;; thrust magnitudes
    (tx :initform 0.0) ;; x axis thrust
    (ty :initform 0.0) ;; y axis thrust
    ;; physics state 
    (dx :initform 0.0) ;; x axis speed 
    (dy :initform 0.0) ;; y axis speed
    (ddx :initform 0.0) ;; x axis acceleration
    (ddy :initform 0.0) ;; y axis acceleration
    ;; physics parameters
    (max-dx :initform 100)
    (max-dy :initform 100)
    (max-ddx :initform 4)
    (max-ddy :initform 4)
    ;; pathfinding state
    (path :initform nil :accessor path)
    (waypoints :initform nil :accessor waypoints)
    (goal-x :initform nil :accessor goal-x)
    (goal-y :initform nil :accessor goal-y)))

(defmethod layout ((self thing)) nil) ;; ignore layout in editor

(See the section "Pathfinding" below for more information on the last few entries in this list.)

Handle all collisions symmetrically

When colliding two objects U and V, there is the question whether to invoke COLLIDE U,V or COLLIDE V,U. By default only the first pairing will be invoked. The following definition overrides HANDLE-COLLISION for THING objects to ensure both orders are invoked.

(defmethod xelf:handle-collision ((u thing) (v thing))
  (collide u v)
  (collide v u))

This may become the default behavior in the future.

Physics parameters and utilities


  (defparameter *dead-zone* 0.1 "Minimum speed (dx) to consider as motion.")

  (defmethod max-speed ((thing thing)) (slot-value thing 'max-dx))
  (defmethod max-acceleration ((thing thing)) (slot-value thing 'max-ddx))

  (defun clamp (x bound)
    (max (- bound)
         (min x bound)))

  (defun clamp0 (x bound)
    (let ((value (clamp x bound)))
      (if (< (abs value) *dead-zone*)

Finding the center of the Arena

  (defmethod center-of-arena ()
    (values (/ *width* 2) (/ *height* 2)))

  (defmethod heading-to-center ((thing thing))
    (multiple-value-bind (tx ty) (center-point thing)
      (multiple-value-bind (cx cy) (center-of-arena)
        (find-heading tx ty cx cy))))

Restricting objects to the buffer boundaries

This shows how to get an object's BOUNDING-BOX and compare bounding boxes with BOUNDING-BOX-CONTAINS.

  (defmethod knock-toward-center ((thing thing))
    (multiple-value-bind (gx gy) (center-point thing)
      (multiple-value-bind (cx cy) (center-point (current-buffer))
        (let ((jerk-distance (/ (distance cx cy gx gy) 16)))
          (with-slots (heading) thing
            (setf heading (find-heading gx gy cx cy))
            (move thing heading jerk-distance))))))

  (defmethod restrict-to-buffer ((thing thing))
    (unless (bounding-box-contains (multiple-value-list (bounding-box (current-buffer)))
                                   (multiple-value-list (bounding-box thing)))
      (reset-physics thing)
      (knock-toward-center thing)))

Objects at rest

  (defmethod at-rest-p ((thing thing))
    (with-slots (dx dy) thing
      (and (> *dead-zone* (abs dx))
           (> *dead-zone* (abs dy)))))

  (defmethod slow-p ((thing thing))
    (with-slots (dx dy) thing
      (and (> 1 (abs dx))
           (> 1 (abs dy)))))

  (defmethod reset-physics ((self thing))
    (with-slots (dx dy ddx ddy) self
      (setf dx 0 dy 0 ddx 0 ddy 0)))

Impulse movements with IMPEL

(defmethod impel ((self thing) &key speed heading)
  (with-slots (tx ty dx dy ddx ddy) self
    (setf (slot-value self 'heading) heading)
    (setf ddx 0 ddy 0)
    (setf dx (* speed (cos heading)))
    (setf dy (* speed (sin heading)))))
(defmethod repel ((this thing) (that thing) &optional (speed 5))
  (impel that :speed speed :heading (heading-between this that)))

Playing a sound when impelling

Notice how we play a sound resource: using the function PLAY-SAMPLE.

(defmethod impel :after ((self thing) &key speed heading)
  (play-sample (random-choose *whack-sounds*)))

Thrust movement

The function MOVEMENT-HEADING is the first domino for our robots' ability to move. When the output value is a number, the robot is pushing toward the given heading. (While we focus on the bare mechanics for the time being, in later sections these will be mapped successively to keyboard, joystick, AI, and network inputs so that many gameplay options are possible.)

(defmethod movement-heading ((self thing)) nil)

(defmethod update-heading ((self thing))
  (with-slots (heading) self
    (setf heading (or (movement-heading self) heading))))

(defparameter *thrust* 0.52 "Base amount of acceleration (ddx)" )

(defmethod current-heading ((self thing)) 
  (slot-value self 'heading))

(defmethod thrust-x ((self thing)) 
  (when (movement-heading self) *thrust*))

(defmethod thrust-y ((self thing)) 
  (when (movement-heading self) *thrust*))

Now we feed the thrust input into the physics system. The slots TX and TY are the amount of X-axis and Y-axis thrust. A point on the unit circle is used to compute the X and Y thrust amounts.

(defmethod update-thrust ((self thing))
  (with-slots (tx ty) self
    (let ((heading (current-heading self))
          (thrust-x (thrust-x self))
          (thrust-y (thrust-y self)))
      (setf tx (if thrust-x (* thrust-x (cos heading)) nil))
      (setf ty (if thrust-y (* thrust-y (sin heading)) nil)))))


The DECAY method is used in UPDATE-PHYSICS to attenuate movement in the absence of thrust or other impulse. It is analogous to air or fluid resistance caused by friction. DECAY is made into a method so that the classes for ROBOT and BALL can have slightly different resistances.

(defun decay-more (x)
  (let ((z (* 0.94 x)))

(defmethod decay ((self thing) value)
  (decay-more value))

Core physics definitions

This is where everything comes together: Thrust is applied to acceleration, which is applied to speed, which becomes finally a new position for the object.

(defmethod update-physics ((self thing))
  (with-slots (x y dx dy ddx ddy tx ty
                  max-dx max-ddx max-dy max-ddy) self
    (setf ddx (clamp (or tx (decay self ddx))
                     (max-acceleration self)))
    (setf dx (clamp (if tx (+ dx ddx) (decay self dx))
                    (max-speed self)))
    (setf ddy (clamp (or ty (decay self ddy))
                     (max-acceleration self)))
    (setf dy (clamp (if ty (+ dy ddy) (decay self dy))
                    (max-speed self)))))

(defmethod update-position ((self thing))
  (with-slots (x y dx dy) self
    (move-to self 
             (+ x dx)
             (+ y dy))))

Physics update hook

Now we add a :BEFORE method to make sure objects physics are updated properly once per frame, just before the objects' UPDATE methods run.

(defmethod update :before ((thing thing))
  (unless (eq :passive (slot-value thing 'collision-type))
    (update-thrust thing)
    (update-physics thing)
    (update-position thing)
    (update-heading thing)))

Generic draw method


 (defmethod draw ((self thing))
   (with-slots (color image heading) self
     (multiple-value-bind (top left right bottom)
         (bounding-box self)
       (draw-textured-rectangle-* left top 0
                                  (- right left) (- bottom top)
                                  (find-texture image)
                                  ;; apply shading
                                  :vertex-color color
                                  :blend :alpha
                                  ;; adjust angle to normalize for up-pointing sprites 
                                  :angle (+ 90 (heading-degrees heading))))))

The bouncing Squareball

(defun random-serve-heading ()
  (direction-heading (random-choose '(:up :down))))

(defclass ball (thing)
  ((max-dx :initform 100)
   (max-dy :initform 100)
   (max-ddx :initform 0.01)
   (max-ddy :initform 0.01)
   (image :initform "ball-5.png")
   (kick-clock :initform 0)
   (color :initform *neutral-color*)
   (count :initform 0)
   (last-collision :initform nil :accessor last-collision)
   (heading :initform (random-serve-heading))))

(defmethod go-to ((ball ball) x y)
  (move-to ball (- x (/ *ball-size* 2)) (- y (/ *ball-size* 2))))

Make the ball a certain size

(defparameter *ball-size* (units 0.64))

(defmethod initialize-instance :after ((ball ball) &key)
  (setf *ball* ball)
  (resize ball *ball-size* *ball-size*))

A basic bounce method

(defmethod bounce ((ball ball) &optional (speed 8))
  (with-slots (heading) ball
    (reset-physics ball)
    (setf heading (+ (random 0.08) (opposite-heading heading)))
    (move ball heading 10)
    (impel ball :speed speed :heading heading)))

Keeping the kicks spaced out

The KICK-CLOCK is a counter used to prevent the ball from being kicked repeatedly in a short time.

(defparameter *kick-disabled-time* 40)

(defmethod disable-kicking ((ball ball))
  (setf (slot-value ball 'kick-clock) *kick-disabled-time*))

(defmethod recently-kicked-p ((ball ball))
  (plusp (slot-value ball 'kick-clock)))

Maintain the KICK-CLOCK and keep the ball onscreen

(defmethod update ((ball ball))
  (with-slots (x y kick-clock heading speed color) ball
    (when (plusp kick-clock)
      (decf kick-clock))
    (restrict-to-buffer ball)))

Don't draw the ball when a goal has been made

(defmethod draw :around ((ball ball))
  (unless (either-goal-flashing-p)

Playfield border walls

These are impenetrable, indestructible walls that surround the playfield on all sides of the screen.

(defclass wall (thing)
  ((color :initform *wall-color*)
   (obstacle-p :initform nil)))

(defmethod draw ((wall wall))
  (with-slots (x y width height color) wall
    (draw-box x y width height :color color)))

(defun make-wall (x y width height)
  (let ((wall (make-instance 'wall)))
    (xelf:resize wall width height)
    (xelf:move-to wall x y)

Note that OBSTACLE-P here means only that WALL objects are not considered obstacles for the purpose of AI "feelers"; it has no effect on collision detection or pathfinding. See also "Pathfinding" below, and WILL-OBSTRUCT-P.

The ball should simply bounce off of the walls.

(defmethod collide ((ball ball) (wall wall))
  (unless (ball-carrier) 
    (bounce ball)))

Breakable bricks

(defparameter *brick-width* (units 1.8))
(defparameter *brick-height* (units 1.2))

(defclass brick (thing)
  ((collision-type :initform :passive)
   (color :initform "white")
   (height :initform *brick-height*)
   (width :initform *brick-width*)))

(defmethod draw ((brick brick))
  (with-slots (x y width height color) brick
    (draw-box x y width height :color color)))

Notice the slot named COLLISION-TYPE. The default is T, which means to process all collisions. But when COLLISION-TYPE is set to :PASSIVE, the object is not actively checked for collisions each frame, instead only showing up as the 2nd argument in a call to (COLLIDE CLASS-1 CLASS-2). (The main purpose of this is efficiency; using COLLISION-TYPE is optional.)

Bricks also don't collide with each other, so there is no need to do anything during HANDLE-COLLISION.

(defmethod handle-collision ((this brick) (that brick)) nil)

Limit destruction per trip into end-zone

The Squareball can sometimes do too much damage to the enemy fortress in one kick, bouncing and destroying many bricks. Here when defining the BALL, BRICK collision we limit the number of bricks that can be destroyed in one trip to the end-zone.

(defparameter *maximum-bricks-destroyed* 13)

(defmethod collide ((ball ball) (brick brick))
  (with-slots (count) ball
    (if (< count *maximum-bricks-destroyed*)
        (progn (destroy brick)
               (play-sample (random-choose *color-sounds*))
               (bounce ball 10)
               (incf count))
        (eject ball))))

(defmethod update :before ((ball ball))
  (when (not (zonep ball))
    (setf (slot-value ball 'count) 0)))

Making fortresses out of bricks

Here we define some utility functions for placing groups of bricks into a buffer. These will be combined into the final game board during startup.

(defun make-brick (x y &optional (color "cyan"))
  (let ((brick (make-instance 'brick)))
    (resize brick *brick-width* *brick-height*)
    (move-to brick x y)
    (setf (slot-value brick 'color) color)

(defun make-column (x y count &optional (color "cyan"))
    (dotimes (n count)
      (add-node (current-buffer) (make-brick x y color) x y)
      (incf y *brick-height*))

(defparameter *fortress-height* 28)

(defun make-fortress (x y colors)
    (dolist (color colors)
      (paste-from (current-buffer) (make-column x y *fortress-height* color))
      (incf x *brick-width*)

Player robots


(defparameter *max-speed* 2.4)
(defparameter *max-carry-speed* 2.3)

(defclass robot (thing)
  ((max-dx :initform *max-speed*)
   (max-dy :initform *max-speed*)
   (max-ddx :initform 1.5)
   (max-ddy :initform 1.5)
   (image :initform "robot.png")
   (color :initform *neutral-color*)
   (carrying :initform nil)
   (kick-clock :initform 0)
   ;; see the Networking section for info on these two slots
   (input-heading :initform nil :accessor input-heading)
   (input-kicking-p :initform nil :accessor input-kicking-p)))

(defparameter *robot-size* 20)

(defmethod initialize-instance :after ((robot robot) &key)
  (resize robot *robot-size* *robot-size*))

(defmethod humanp ((robot robot)) nil)

(defparameter *robot-reload-frames* 30)


  (defmethod can-reach-ball ((self robot))
    (and (ball) (colliding-with-p self (ball))))

  (defmethod ball-centered-p ((robot robot))
    (> 0.4 (abs (wobble))))

  (defparameter *robot-shoot-distance* 320)

  (defmethod ready-to-kick-p ((robot robot)) 
    (zerop (slot-value robot 'kick-clock)))

  (defparameter *kick-speed* 25)
  (defparameter *steal-speed* 22)
  (defparameter *kick-range* (units 2.8))

  (defmethod ball-within-range-p ((robot robot))
    (< (distance-between robot (ball))

  (defparameter *repel-range* (units 4))

  (defmethod opponent-within-range-p ((robot robot))
    (< (distance-between robot (opponent robot))

  (defmethod opponent-carrying-p ((robot robot))
    (with-slots (carrying) robot
      (and (not carrying)

  (defparameter *player-1-joystick* 0)
  (defparameter *player-2-joystick* nil)

  (defun both-joysticks-connected ()
    (numberp *player-2-joystick*))

  (defmethod stick-heading ((self robot)) nil)

  (defmethod trajectory-heading ((thing thing))
    (with-slots (x y last-x last-y) thing
      (if last-x
          (find-heading last-x last-y x y)

  (defmethod fast-p ((thing thing))
    (with-slots (x y last-x last-y) thing
      (when (and last-x last-y)
        (> (distance last-x last-y x y)

  (defmethod heading-to-opponent ((robot robot))
    (heading-between robot (opponent robot)))

  (defmethod heading-to-ball ((robot robot))
    (if (ball) (heading-between robot (ball)) 0))

  (defmethod distance-to-opponent ((robot robot))
    (distance-between robot (opponent robot)))

  (defmethod distance-to-ball ((robot robot))
    (if (ball) (distance-between robot (ball)) 10000))

Kicking the Squareball

(defmethod kick ((self robot))
  (with-slots (carrying kick-clock) self
    (play-sample (random-choose *bounce-sounds*))
    (setf kick-clock *robot-reload-frames*)
    (when (or carrying (ball-within-range-p self))
      (let ((speed (if (opponent-carrying-p self)
        (when (opponent-carrying-p self)
          (play-sample "grab.wav"))
        (disable-kicking (ball))
        (impel (ball) 
               (if (opponent-carrying-p self)
                   (* 0.5 (+ (heading-to-ball self) 
                             (heading-to-opponent self)))
                   (heading-between self (ball)))
               :speed speed)
        (play-sample "serve.wav")
        (when (opponent-within-range-p self)
          (repel self (opponent self) 5))))))

Friction modification

Using a different DECAY method here prevents the robots' control feeling too "floaty".

(defun decay-less (x)
  (let ((z (* 0.8 x)))

(defmethod decay ((self robot) value)
  (decay-less value))

Scoring and goals

(defmethod find-score ((robot robot)) (slot-value robot 'score))

(defmethod find-goal ((robot robot)) (goal-1))

(defmethod carrying-ball-p ((robot robot))
  (slot-value robot 'carrying))

(defmethod max-speed ((robot robot))
  (if (carrying-ball-p robot) 
      (slot-value robot 'max-dx)))

Updating the robot

(defmethod update ((self robot))
  (with-slots (kick-clock) self
    (when (plusp kick-clock)
      (decf kick-clock))
    (when (and (ready-to-kick-p self)
               ;; whether to allow spamming the ball when you don't have it
               ;; (ball-carrier)
               (kicking-p self))
      (kick self))))

Robots repel each other

(defmethod collide ((this robot) (that robot))
  (repel this that))

Robots can't pass through walls or bricks

(defmethod collide ((wall wall) (robot robot))
  (impel robot :speed 10 :heading (heading-to-center robot)))

(defmethod collide ((brick brick) (robot robot))
  (impel robot :speed 10 :heading (heading-to-center robot)))

Robots can grab and lose the ball

(defmethod lose-ball ((robot robot))
  (with-slots (carrying) robot
    (setf carrying nil)))

(defun free-ball ()
  (when (game-on-p) (play-rhythm))
  (dolist (robot (find-robots))
    (lose-ball robot)))
(defmethod grab ((robot robot))
  (when (and (not (recently-kicked-p (ball)))
             (ready-to-kick-p robot))
    (play-sample (random-choose *doorbell-sounds*))
    (with-slots (carrying) robot
      (setf carrying t))))

Can't grab ball if it was just kicked, or is being carried

(defmethod collide ((robot robot) (ball ball))
  (unless (or (ball-carrier) (recently-kicked-p ball))
    (grab robot)))

Ball snaps to position when player is carrying


(defun wobble () (sin (/ xelf:*updates* 10)))

(defmethod carry-location ((robot robot))
  (with-slots (heading) robot
    (multiple-value-bind (cx cy) (center-point robot)
      (multiple-value-bind (tx ty) 
          (step-coordinates cx cy heading (units 2))
        (multiple-value-bind (wx wy)
            (step-coordinates tx ty (- heading (/ pi 2)) (* 8 (wobble)))
          (values (- wx (* *ball-size* 0.12))
                  (- wy (* *ball-size* 0.12))))))))

(defmethod update :after ((ball ball))
  (let ((carrier (ball-carrier)))
    (when carrier
      (multiple-value-bind (x y) 
          (carry-location carrier)
        (go-to ball x y))
      ;; don't allow camping in own end zone
      (when (zonep carrier)
        (eject ball)))))

Custom draw method

(defmethod draw :after ((self robot))
  (with-slots (color heading kick-clock waypoints) self
    (multiple-value-bind (top left right bottom)
        (bounding-box self)
      (when (plusp kick-clock)
        (draw-textured-rectangle-* (- left (units 1))
                                   (- top (units 1))
                                   60 60
                                   (find-texture (random-choose '("field-1.png" "field-2.png")) )
                                   :vertex-color (random-choose '("yellow" "magenta" "cyan"))
                                   :blend :additive :opacity 0.8))))
  ;; reset brush
  (xelf::set-vertex-color "white")
  (xelf::set-blending-mode :alpha))

End-zone barriers

The EXCLUDED-PLAYER slot is used to REPEL only the correct player for that end-zone.

(defparameter *barrier-width* (units 0.2))
(defparameter *barrier-height* (- *height* (units 2.2)))

(defclass barrier (thing)
  ((collision-type :initform :passive)
   (obstacle-p :initform nil)
   (color :initform "white")
   (excluded-player :initform nil)))

(defmethod draw ((barrier barrier))
  (with-slots (x y width height color) barrier
    (draw-box x y width height :color color)))

(defun make-barrier (x y excluded-player)
  (let ((barrier (make-instance 'barrier)))
    (resize barrier *barrier-width* *barrier-height*)
    (move-to barrier x y)
    (setf (slot-value barrier 'excluded-player) excluded-player)

(defmethod collide ((barrier barrier) (robot robot))
  (with-slots (excluded-player) barrier
    (when (eq robot excluded-player)
      (repel barrier excluded-player 10))))

(defmethod zonep ((thing thing))
  (multiple-value-bind (x y) (center-point thing)
    (or (< x (slot-value (barrier-1) 'x))
        (> x (slot-value (barrier-2) 'x)))))

Eject ball from end-zone when it comes to rest

(defmethod eject ((thing thing))
  (multiple-value-bind (gx gy) (center-point thing)
    (multiple-value-bind (cx cy) (center-point (current-buffer))
      (let ((jerk-distance (/ (distance cx cy gx gy) 20)))
        (with-slots (heading) thing
          (setf heading (find-heading gx gy cx cy))
          (impel thing :heading heading :speed jerk-distance))))))

(defmethod eject :after ((ball ball))
  (play-sample "return.wav"))

(defmethod update :around ((ball ball))
  (unless (either-goal-flashing-p)
    (when (and (at-rest-p ball)
               (not (ball-carrier))
               (zonep ball))
      (eject ball))))

Bumper walls

These add interest and strategy to the playfield in between the fortresses.

(defparameter *bumper-width* (units 0.3))
(defparameter *bumper-height* (- (/ *height* 2) (units 7)))
(defparameter *bumper-thickness* (units 0.3))

(defclass bumper (thing) 
  ((color :initform "white")
   (obstacle-p :initform t)))

(defmethod draw ((bumper bumper))
  (with-slots (x y width height color) bumper
    (draw-box x y width height :color color)))

(defun make-bumper (x y &optional (width *bumper-width*) (height *bumper-height*))
  (let ((bumper (make-instance 'bumper)))
    (resize bumper width height)
    (move-to bumper x y)

(defun make-horizontal-bumper (x y width)
  (make-bumper x y width *bumper-thickness*))

(defun make-vertical-bumper (x y height)
  (make-bumper x y *bumper-thickness* height))

Ball bounces off bumpers

(defmethod collide ((ball ball) (bumper bumper))
  (bounce ball))

A little extra work is required to keep the ball from getting stuck on a bumper.

(defmethod collide :before ((ball ball) (bumper bumper))
  (setf (last-collision ball) bumper))

(defmethod collide :after ((ball ball) (bumper bumper))
  (when (eq bumper (last-collision ball))
    (repel bumper ball 12)))

Ball doesn't react with bumpers when being carried

(defmethod collide :around ((ball ball) (bumper bumper))
  (when (not (ball-carrier))

Discard some waypoints upon colliding with bumper

See the section on Pathfinding below.

(defmethod collide ((bumper bumper) (robot robot))
  (dotimes (n 3) (next-waypoint robot))
  (repel bumper robot))


(defclass goal (thing)
  ((colors :initform (list "hot pink" "cyan"))
   (player :initform  nil)
   (timer :initform nil)
   (direction :initform :up)))

(defmethod set-scoring-player ((goal goal) p)
  (with-slots (player colors) goal
    (setf player p)
    (if (= 1 p) 
        (setf colors (list *player-2-color* "yellow"))
        (setf colors (list *player-1-color* "purple")))))

Draw flashing goal when player scores

(defmethod draw ((goal goal))
  (with-slots (x y width height colors timer) goal
    (let ((color2 (if timer (random-choose '("hot pink" "magenta" "yellow")) 
                      (first colors))))
      (draw-box x y width height :color color2))))

Player bounces off goal

(defmethod collide ((goal goal) (robot robot))
  (impel robot :speed 10 :heading (heading-to-center robot)))

Goal moves slowly back and forth

(defparameter *goal-speed* 1)

(defmethod collide ((goal goal) (wall wall))
  (with-slots (direction) goal
    (setf direction (opposite-direction direction))
    (move-toward goal direction (+ *goal-speed* 5))))

The following method also handles resetting the game board after a score; see also AT-NEXT-UPDATE.

(defmethod update :after ((goal goal))
  (when (game-on-p)
    (with-slots (timer direction) goal
      (when timer
        (when (plusp timer)
          (decf timer))
        (when (zerop timer)
          (at-next-update (proceed (arena)))
          (decf timer)))
      (move goal (direction-heading direction) *goal-speed*))))

Scoring a goal

(defmethod collide ((goal goal) (ball ball))
  (when (and (game-on-p)
             (not (ball-carrier)))
    (reset-physics ball)
    (with-slots (timer player) goal
      (when (null timer)
        (score-point player)
        (play-sample "newball.wav")
        (setf timer (seconds 3))))))

(defun make-goal ()
  (let ((goal (make-instance 'goal)))
    (resize goal (units 1) (units 6))

(defmethod clear ((goal goal))
  (setf (slot-value goal 'timer) nil))

(defun clear-goals ()
  (clear (goal-1))
  (clear (goal-2)))

Player classes

PLAYER-1 basic definitions

(defclass player-1 (robot) 
  ((color :initform *player-1-color*)
   (player-id :initform 1)))

(defmethod humanp ((self player-1))
  (not (clientp (arena))))

(defmethod find-goal ((self player-1))

The slot PLAYER-ID and the function CLIENTP are used for networking purposes. See the section on Networking below.

PLAYER-2 basic definitions

(defclass player-2 (robot) 
  ((color :initform *player-2-color*)
   (player-id :initform 2)))

(defmethod humanp ((self player-2))
  (or *netplay*

(defmethod find-goal ((robot player-2)) 

See also *NETPLAY*.

Player 1 input control

(defun keyboard-heading () 
  (let ((dir (arrow-keys-direction)))
    (when dir (direction-heading dir))))

(defmethod stick-heading ((self player-1))
   (when (not (clientp (arena)))
   (if (and *player-1-joystick*
            (left-analog-stick-pressed-p *player-1-joystick*))
       (left-analog-stick-heading *player-1-joystick*)

(defmethod movement-heading ((self player-1))
  (stick-heading self))

(defmethod kicking-p ((robot player-1))
  (or (when (not (clientp (arena)))
      (holding-button-p *player-1-joystick*)))

See also:

Hide terminal overlay after any player-1 input

   (defmethod kick :after ((self player-1))

   (defmethod update :after ((self player-1))
     (when (movement-heading self)

Player 2 AI/input control

(defmethod stick-heading ((self player-2))
  (if *player-2-joystick*
      (when (left-analog-stick-pressed-p *player-2-joystick*)
        (left-analog-stick-heading *player-2-joystick*))
        (path-heading self))))

(defmethod stick-heading :around ((self player-2))
  (if (clientp (arena))
      (or (keyboard-heading)

(defmethod kicking-p ((robot robot))
  (cond ((and (both-joysticks-connected)
              (not *netplay*))
         (holding-button-p *player-2-joystick*))
        ((not (game-on-p)) nil)
        ((colliding-with-p (ball) (goal-1)) nil)
        ((carrying-ball-p robot)
             (if (< (distance-between robot (find-goal robot)) 240)
                 (if (not (difficult-p)) 15 19)
                 (if (not (difficult-p)) 17 20))
           (and (ball-centered-p robot)
                (< (distance-between robot (find-goal robot)) 
                   (if (not (difficult-p)) 
                       (+ *robot-shoot-distance* 30)
                       (+ *robot-shoot-distance* 70))))))
        ((carrying-ball-p (opponent robot))
         (percent-of-time (if (not (difficult-p)) 0.9 1.3)
                           (opponent-within-range-p robot)
                           (ball-within-range-p robot))))))


Artificial Intelligence

Steering behaviors

In order to steer somewhere we must have a target. When the AI has the ball, it seeks out the opponent's goal; when it doesn't have the ball, it seeks the ball.

  (defparameter *target-margin* (units 4))

  (defmethod find-ball-target ((robot robot))
    (multiple-value-bind (cx cy) (center-point (arena))
      (let ((rx (center-point robot))
            (bx (center-point (ball)))
            (left (- cx *target-margin* (units 2)))
            (right (+ cx *target-margin* (units 2)))
            (b1x (center-point (barrier-1)))
            (b2x (center-point (barrier-2))))
        (if (and (zonep (ball))
                 (slow-p (ball)))
            (cond ((< (abs (- rx b1x))
                      (abs (- rx bx)))
                   (values (- cx *target-margin*) cy))                 
                  ((< (abs (- rx b2x))
                      (abs (- rx bx)))
                   (values (+ cx *target-margin*) cy))
                  (t (center-point (ball))))
                (center-point (ball))))))

  (defmethod target ((robot robot))
    (multiple-value-bind (ax ay) (center-point (arena))
      (if (not (carrying-ball-p robot))
          (center-point (ball))
          (center-point (find-goal robot)))))

  (defun jitter (heading)
    (+ heading (* (if (difficult-p) 0.5 0.1) (sin (/ *updates* 24)))))

  (defun course-correction ()
    (if (difficult-p) 
        (if (serve-period-p) 0.3 0.2)
        (if (serve-period-p) 0.33 0.22)))

This method needs to be refactored; it controls how aggressively (and how accurately) the bot steers. A future version of this document will feature a refactored version.

  (defmethod movement-heading ((robot robot))
    (if (or *netplay* (both-joysticks-connected))
        (stick-heading robot)
        (when (and (game-on-p)
                   (not (either-goal-flashing-p)))
              (if (serve-period-p)
                  (if (not (difficult-p)) 55 67)
                  (if (and (zonep (ball))
                           (slow-p (ball)))
                      ;; anticipate eject but don't superspeed
                      (if (not (difficult-p)) 50 65)
                      (if (and 
                           (not (carrying-ball-p robot))
                           (at-rest-p (ball))
                           (ball-within-range-p robot))
                          ;; slow down to catch ball
                          (if (slow-p robot) 60 65)
                          ;; default 
                          (if (not (difficult-p)) 77 88))))
                  (when (and (not (colliding-with-p (ball) (goal-1))) 
                             (not (colliding-with-p (ball) (goal-2))))
                    ;; follow pathfinding nodes whenever possible
                    (or (path-heading robot)
                        (multiple-value-bind (cx cy) (center-point robot)
                          (multiple-value-bind (wx wy) (target robot)
                            (if (carrying-ball-p robot)
                                (jitter (find-heading cx cy wx wy))
                                (if (fast-p robot)
                                    ;; correct path to not overshoot ball
                                    (let ((delta (- (find-heading cx cy wx wy)
                                                    (trajectory-heading robot))))
                                      (if (plusp delta)
                                          (jitter (+ (find-heading cx cy wx wy) (course-correction)))
                                          (jitter (- (find-heading cx cy wx wy) (course-correction)))))
                                    (jitter (find-heading cx cy wx wy))))))))))))

Sensing the environment with "feelers"

By using the Xelf quadtree facility to peek at a series of points along a line, we can see if a wall or other obstacle is nearby. Notice that the OBSTACLE-P slot is checked here.

(defmethod can-see-point-p ((self robot) x y)
    (block colliding
      (multiple-value-bind (x0 y0) (center-point self)
        (let ((d (/ (distance x0 y0 x y) 30))
              (w 0)
              (h (find-heading x0 y0 x y)))
          (dotimes (n 30)
            (incf w d)
            (multiple-value-bind (x1 y1)
                (step-toward-heading self h w)
              (let* ((vtop (- y1 1))
                     (vleft (- x1 1))
                     (vright (+ vleft 2))
                     (vbottom (+ vtop 2)))
                (flet ((check (object)
                         (when (obstacle-p object)
                           (return-from colliding nil))))
                  (prog1 t
                    (xelf::quadtree-map-collisions *quadtree*
                                                   (cfloat vtop)
                                                   (cfloat vleft)
                                                   (cfloat vright)
                                                   (cfloat vbottom)
          (return-from colliding t)))))

Now we can use these "feelers" like cat whiskers to detect walls on either side of the current trajectory.

(defmethod heading-to-waypoint ((self robot))
  (multiple-value-bind (cx cy) (center-point self)
    (with-slots (goal-x goal-y heading) self
      (if (null goal-x)
          (find-heading cx cy goal-x goal-y)))))

(defmethod facing-wall-p ((self robot))
  (with-slots (heading) self
    (multiple-value-bind (cx cy) (center-point self)
      (multiple-value-bind (px py)
          (step-coordinates cx cy heading 60)
        (not (can-see-point-p self px py))))))

(defmethod facing-wall-left-p ((self robot))
  (with-slots (heading) self
    (multiple-value-bind (cx cy) (center-point self)
      (multiple-value-bind (px py)
          (step-coordinates cx cy (+ heading 0.3) 60)
        (not (can-see-point-p self px py))))))

(defmethod facing-wall-right-p ((self robot))
  (with-slots (heading) self
    (multiple-value-bind (cx cy) (center-point self)
      (multiple-value-bind (px py)
          (step-coordinates cx cy (- heading 0.3) 60)
        (not (can-see-point-p self px py))))))

When these feelers are triggered, we steer away.

  (defmethod update :before ((self player-2))
    ;; re-path if needed
    (with-slots (goal-x goal-y) self
      (when (or (null goal-x) (zerop (mod *updates* 10)))
        (multiple-value-bind (x y) (target self)
          (setf goal-x nil goal-y nil)
          (seek-to self x y))))
    ;; steer away from walls 
    (with-slots (heading) self
      (if (facing-wall-left-p self)
          (progn ;; steer right
            (next-waypoint self)
            (incf heading -0.0001))
          (if (facing-wall-right-p self)
              (progn ;; steer left
                (next-waypoint self)
                (incf heading 0.0001))))))


The method SEEK-TO creates a 50x50 grid for pathfinding (if needed) and attempts to build a path to the destination at X,Y. See also CREATE-PATH and FIND-PATH-WAYPOINTS.

(defmethod seek-to ((self thing) x y)
  (multiple-value-bind (cx cy) (location self)
    (with-slots (waypoints path) self
      (when (null path)
        (setf path (create-path self :width 50 :height 50 :buffer (arena))))
      (setf waypoints (rest (rest (find-path-waypoints path cx cy x y)))))))

The result is a list of waypoints, of the form ((X Y) (X Y) (X Y) …) We can get the CURRENT-WAYPOINT or switch to the NEXT-WAYPOINT.

(defmethod current-waypoint ((self thing))
  (with-slots (goal-x goal-y) self
    (if goal-x
        (values goal-x goal-y)
        (target self))))

(defmethod next-waypoint ((self thing))
  (with-slots (waypoints goal-x goal-y) self
    (if (not (null waypoints))
        (destructuring-bind (wx wy) (pop waypoints)
          (setf goal-x (- wx 6) goal-y (- wy 6)))
        (setf goal-x nil goal-y nil))))

The steering AI will need to be able to find the current waypoint.

(defmethod path-target ((self thing))
  (with-slots (goal-x goal-y) self
    (if goal-x
        (values goal-x goal-y)
          (multiple-value-bind (x y) (target self)
            (seek-to self x y))
          (next-waypoint self)))))

(defmethod path-heading ((self thing))
  (with-slots (x y goal-x goal-y waypoints) self
    (when (and goal-x goal-y)
      (if (< 10 (distance x y goal-x goal-y))
          ;; keep walking 
          (find-heading x y goal-x goal-y)
          (if waypoints
              (find-heading x y goal-x goal-y)
              (setf goal-x nil goal-y nil))))))

Pathfinding for Player 1 is turned off.

(defmethod seek-to ((self player-1) x y) nil)

Pathfinding obstruction definitions

(defmethod will-obstruct-p ((this thing) (that thing))
(defmethod will-obstruct-p ((bumper bumper) (robot robot)) t)
(defmethod will-obstruct-p ((p1 player-1) (p2 player-2)) t)
(defmethod will-obstruct-p ((p1 player-2) (p2 player-1)) t)

Building the Arena buffer

A border around the playfield

(defun make-border (x y width height)
  (let ((left x)
        (top y)
        (right (+ x width))
        (bottom (+ y height)))
      ;; top wall
      (insert (make-wall left top (- right left) (units 1)))
      ;; bottom wall
      (insert (make-wall left bottom (- right left (units -1)) (units 1)))
      ;; left wall
      (insert (make-wall left top (units 1) (- bottom top)))
      ;; right wall
      (insert (make-wall right top (units 1) (- bottom top (units -1))))
      ;; send it back


(defclass arena (xelf:buffer)
  ((resetting :initform nil)
   (ended :initform nil)
   (quadtree-depth :initform 9)))

(defvar *reset-clock* nil)

(defmethod quit-game ((arena arena))

Updating timers

(defmethod update :after ((arena arena))
  (when (zerop *game-clock*)
    (when (null (slot-value arena 'ended))
      (setf (slot-value arena 'ended) t)
      (play-sample "error.wav")
  (when *reset-clock*
    (decf *reset-clock*)
    (unless (plusp *reset-clock*)
      (setf *reset-clock* nil)))
  (when (keyboard-down-p :pagedown)
    (when (null *reset-clock*)
      (setf *reset-clock* (seconds 1))
      (at-next-update (reset-game arena)))))

Adding keybindings


(defmethod initialize-instance :after ((arena arena) &key)
  (setf *arena* arena)
  (resize arena *width* *height*)
  (bind-event arena '(:space) 'spacebar)
  (bind-event arena '(:return) 'spacebar)
  (bind-event arena '(:pageup) 'select-variation)
  (bind-event arena '(:escape) 'setup)
  (bind-event arena '(:m :control) 'start-or-stop-music)
  (bind-event arena '(:q :control) 'quit-game)
  (setf *inhibit-splash-screen* t))

Populating the board with objects

(defun drop-player-1 ()
  (add-node (current-buffer) (player-1) (units 11) (units 3))
  (reset-physics (player-1)))

(defun drop-player-2 ()
  (add-node (current-buffer) (player-2) (- *width* (units 12)) (- *height* (units 4)))
  (reset-physics (player-2)))

(defun drop-ball ()
  (reset-physics (ball))
  (multiple-value-bind (x y) (center-point (current-buffer))
    (add-node (current-buffer) (ball) (- x (/ *ball-size* 2)) (- y (/ *ball-size* 2)))))

(defmethod populate ((arena arena))
  (with-buffer arena
    (multiple-value-bind (x y) (center-point (arena))
      (add-node (current-buffer) (make-instance 'ball) x y)
      (set-player-1 (make-instance 'player-1))
      (set-player-2 (make-instance 'player-2))
      (set-goal-1 (make-goal))
      (set-goal-2 (make-goal))
      (set-scoring-player (goal-1) 2)
      (set-scoring-player (goal-2) 1)
      (add-node (current-buffer) (goal-1) (units 1.1) (units 4))
      (add-node (current-buffer) (goal-2) (- *width* (units 2.1)) (- *height* (units 10)))

      (when (fortresses-p)
        (paste-from (current-buffer) (make-fortress (units 3) (units 1.2) *player-1-fortress-colors*))
        (paste-from (current-buffer) (make-fortress (- *width* (units
                                                                8.5)) (units 1.2) *player-2-fortress-colors*)))

      (when (bumpers-p)
        (add-node (current-buffer) (make-bumper (- (/ *width* 2) (units 4.5)) (units 1.2)))
        (add-node (current-buffer) (make-bumper (+ (/ *width* 2) (units 4.5)) (- *height* *bumper-height* (units 1.1))))

        (add-node (current-buffer) (make-horizontal-bumper (* 2 (/ *width* 7)) (- (/ *height* 2) (units 2)) (units 9)))
        (add-node (current-buffer) (make-horizontal-bumper (* 4 (/ *width* 7)) (+ (/ *height* 2) (units 2)) (units 9)))
        (add-node (current-buffer) (make-vertical-bumper (+ (units 0.5) (* 2 (/ *width* 3))) (units 8) (units 7)))
        (add-node (current-buffer) (make-vertical-bumper (- (/ *width* 3) (units 0.5)) (units 21) (units 7))))

      (set-barrier-1 (make-barrier 0 0 (player-2)))
      (set-barrier-2 (make-barrier 0 0 (player-1)))
      (add-node (current-buffer) (barrier-1) (units 10) (units 1.1)) 
      (add-node (current-buffer) (barrier-2) (- *width* (units 10.2)) (units 1.1))
      (setf (slot-value (current-buffer) 'background-color) *arena-color*)

Running the game session

We need a function to create a game session for a given variation. The function MAKE-GAME configures game features, creates a matching game level as a new buffer, and returns that buffer.

  (defun make-game (&optional (variation 1))
    ;; The use of FIND-ARENA-CLASS relates to Networking, see the
    ;; section below.
    (with-buffer (make-instance (find-arena-class *netplay*))
      (configure-game variation)
      (play-sample "go.wav")
      (paste-from (current-buffer) 
             (make-border 0 0 (- *width* (units 1)) (- *height* (units 1))))
      (trim (current-buffer))
      (populate (current-buffer))
      (trim (current-buffer))))

Notice the functions PASTE and TRIM. TRIM is used to remove empty border space from a buffer, and is often useful after combining buffers with PASTE or other operators such as COMPOSE.

Now we write the method PROCEED, which starts an Arena game session going.

  (defun do-reset ()
    (dotimes (n 100)
      (halt-sample n))
    (switch-to-buffer (make-game *variation*)))

  (defmethod proceed ((arena arena))
    (play-sample "go.wav")

Several commands are defined here.

  (defmethod reset-game ((self arena))
    (stop self)
    (at-next-update (destroy self)))

  (defmethod select-variation ((arena arena))
    (let ((v *variation*))
      (incf v)
      (setf v (mod v (length *variations*)))
      (setf *variation* v)
      (reset-game arena)))

  (defmethod start-or-stop-music ((self arena))

User Interface

We need to draw the score, game clock, and help strings on top of the arena.

First we choose from the preset named font styles declared in index.xelf. (That file shows how to make custom styles, as (for example) for the remainder of the included Bitstream Vera fonts.

(defparameter *score-font* "sans-mono-bold-12")
(defparameter *big-font* "sans-mono-bold-16")

The default DRAW method for a buffer renders the background and game objects. After this, we'd like to overlay our user interface.


(defmethod draw :after ((arena arena))
  (draw-string (format nil "~S" *score-1*)
               (units 2) 3
               :color *player-1-color* 
               :font *score-font*)
  (draw-string (format nil "~S" *score-2*)
               (- *width* (units 5)) 3
               :color *player-2-color* 
               :font *score-font*)
  (draw-string (game-clock-string) 
               (units 31.6) 3
               :color "white"
               :font *score-font*)
  (draw-string "[Arrows/NumPad] move     [Shift] kick      [Escape] game setup     [PageDown] reset game     [PageUp] select variation     [Control-Q] quit      [Control-M] music on/off"
               (units 2.6) (- *height* 17)
               :color "white"
               :font *score-font*)
  (unless (game-on-p)
    (draw-string "END OF REGULATION"
                 (units 36) (units 2)
                 :color "white"
                 :font *big-font*))
  (when (and (not (both-joysticks-connected))
             (not *netplay*))
    (draw-string (if (not (difficult-p)) "NORMAL AI" "ADVANCED AI")
                 (units 48) 3
                 :color *player-2-color*
                 :font *score-font*))
  (when *netplay*
    (draw-string (ecase *netplay*
                   (:client "CLIENT: PLAYER 2")
                   (:server "SERVER: PLAYER 1"))
                 (units 48) 3
                 :color (ecase *netplay*
                          (:client *player-2-color*)
                          (:server *player-1-color*))
                 :font *score-font*))
  ;; draw gray bars under goal slot to prevent color problems
  (when (connectedp arena)
    (let ((x1 (slot-value (goal-1) 'x))
          (x2 (slot-value (goal-2) 'x))
          (y (units 1))
          (width (units 1.3))
          (height (units 34)))
      ;;(draw-box (- x1 3) y width height :color "gray30")
      (draw (goal-1))
      ;;(draw-box (- x2 3) y width height :color "gray30")
      (draw (goal-2))
      (draw (ball))
      (draw (player-1))
      (draw (player-2)))))

Setup screen

A special buffer for displaying text

  (defparameter *button-time* 30)
  (defparameter *ready-time* 120)

  (defclass setup (buffer)
    ((timer :initform 0)
     (player :initform 1)
     (background-color :initform "CornflowerBlue")))

  (defmethod update :after ((setup setup))
    (with-slots (timer player) setup
      (when (plusp timer) 
        (decf timer))
      (when (and (zerop timer)
                 (null player))
        (stop setup)

Arena command for opening the setup screen

(defmethod setup ((arena arena))
  (stop arena)
    (switch-to-buffer (make-instance 'setup))
    (destroy arena)))

Binding key commands at initialization

(defmethod initialize-instance :after ((setup setup) &key)
  (bind-event setup '(:s :control) 'start-server)
  (bind-event setup '(:c :control) 'start-client-prompt)
  (bind-event setup '(:u :control) 'toggle-upnp)
  (resize setup *width* *height*))

Prompt message strings

These strings are segregated here for easier localization and editing.

(defparameter *p1-prompt* "Press any button on Gamepad 1, or Spacebar to use the keyboard.")
(defparameter *p2-prompt-1* "To play against a friend, press any button on Gamepad 2.")
(defparameter *p2-prompt-2* "Or, press any button on Gamepad 1 to play against the computer.")

(defun ready-prompt ()
  (if *netplay*
      "Local player versus network. Get ready!"
      (if (null *player-2-joystick*)
          "Player 1 versus the computer. Get ready!"
          "Player 1 versus Player 2. Get Ready!")))
(defparameter *must* "(Gamepads must be plugged in before the application is started.)")
(defparameter *net* "Online Play: Press Control-S to start server,  Control-C for client. Press Control-U to toggle UPnP before starting.")

Highlighted prompt line is rendered with a flicker effect

(defun flicker () (random-choose '("white" "cyan")))

Drawing the setup screen

(defmethod draw :after ((setup setup))
  (when (null *prompt*)
    (with-slots (timer player) setup
      (draw-string "Game setup" (units 28.3) (units 2) :color "white" :font "sans-mono-bold-22")
      (draw-string *must* (units 20) (units 5) :color "white" :font "sans-mono-bold-12")
      (draw-string (if *use-upnp* "UPnP Enabled" "UPnP Disabled") (units 20) (units 9) :color "white" :font "sans-mono-bold-12")
       (if *netplay* 
           (format nil "Online play enabled in ~S mode." *netplay*)
       (units 10) (units 7) :color "white" :font "sans-mono-bold-12")
      (case player 
        (1 (draw-string *p1-prompt* (units 12) (units 12) :color (flicker) :font *big-font*))
        (2 (draw-string *p2-prompt-1* (units 12) (units 14) :color (flicker) :font *big-font*)
         (draw-string *p2-prompt-2* (units 12) (units 16) :color "white" :font *big-font*)))
      (when (null player)
        (draw-string (ready-prompt) (units 12) (units 18) :color "white" :font *big-font*))))
  (when *prompt*
    (draw *prompt*)))

Handling key and button presses

(defmethod handle-event :after ((setup setup) event)
  (with-slots (timer player) setup
    (when (and (consp (first event))
               (eq :space (first (first event))))
      (setf timer *ready-time*)
      (setf player nil))
    (when (and (eq :joystick (first event))
               (not (plusp timer)))
      (destructuring-bind (which button direction) (rest event)
        (case player
           (if (not (clientp (arena)))
               (progn (setf *player-1-joystick* which)
                      (setf *player-2-joystick* nil)
                      (setf timer *button-time*)
                      (setf player 2))
               (progn (setf *player-1-joystick* nil)
                      (setf *player-2-joystick* which)
                      (setf timer *ready-time*)
                      (setf player nil))))
           (if (= which *player-1-joystick*)
               ;; player chose vs AI 
                 (setf *player-2-joystick* nil)
                 (setf timer *ready-time*)
                 (setf player nil))
                 (setf *player-2-joystick* which)
                 (setf timer *ready-time*)
                 (setf player nil)))))))))

TODO Prompt widget for entering IP address at keyboard

(This section is not yet documented.)

(defclass ip-prompt (prompt)
  ((prompt-string :initform "Type the IP server address and then press ENTER.")))

(defmethod read-expression ((prompt ip-prompt) input-string)

(defmethod enter :before ((prompt ip-prompt) &optional no-clear)
      (let ((*read-eval* nil))
        (let ((result (parse-ip (slot-value prompt 'line))))
          (if (null result)
              (logging "Error: not a valid IP address.")
                (setf *server-host* (reformat-ip result))
                (start-client (current-buffer))))))
    (condition (c)
      (logging "~S" c))))

(defun show-prompt ()
  (setf *prompt* (make-instance 'ip-prompt))
  (move-to *prompt* *terminal-left* *terminal-bottom*))

(defun hide-prompt ()
  (setf *prompt* nil))

TODO Networking functions

(This section is not yet documented.)

(defmethod toggle-upnp ((setup setup))
  (setf *use-upnp* (if *use-upnp* nil t)))

(defmethod start-server ((setup setup))
  (play-squareball :netplay :server 
              :use-upnp *use-upnp*))

(defmethod start-client-prompt ((setup setup))

(defmethod start-client ((setup setup))
  (play-squareball :netplay :client 
              :use-upnp *use-upnp* 
              :server-host *server-host*))

TODO Prompt widget gets events first

(defmethod handle-event :around ((setup setup) event)
  (if *prompt*
      (prog1 t (handle-event *prompt* event))

Application startup

Set window title

  (defparameter *title-string* "Squareball 2.6")

TODO Switch to game buffer

  (defun play-squareball (&key (use-upnp nil) (netplay *netplay*) (server-host *server-host*) (client-host *client-host*) (base-port *base-port*) verbose-logging)

    ;; this first section is related to netplay, see the chapter on
    ;; Networking below.
    (setf *inhibit-splash-screen* nil)
    (when netplay 
    (setf xelf::*use-upnp* use-upnp)
    (setf *degrade-stream-p* nil)
    (setf *server* nil)
    (setf *client* nil)
    (setf *verbose-p* verbose-logging)
    (setf *server-port* (or base-port *base-port*))
    (setf *netplay* netplay)
    (setf *server-host* server-host)
    (setf *client-host* client-host)
    (setf *sent-messages-count* 0)
    (setf *received-messages-count* 0)
    (setf *remote-host* nil)
    (setf *remote-port* nil)
    (setf *last-message-timestamp* 0)
    (setf *flag-received-p* nil)
    (setf *flag-sent-p* nil)
    (setf *use-music* t) 
    (setf *player-1-joystick* 
          (if (eq *netplay* :client)
      (switch-to-buffer (make-game *variation*))
      (unless (or *netplay* *inhibit-splash-screen*)

Main program entry point

  (defun squareball (&rest args)
    (setf *use-fortresses* nil)
    (setf *use-bumpers* nil)
    (setf *use-antialiased-text* nil)
    (setf *variation* 4)
      (open-project "squareball")
      ;; preload music 
      (setf *default-texture-filter* :nearest)
      (mapc #'find-resource '("rhythm.ogg" "fanfare-1.ogg" "fanfare-2.ogg" "vixon.ogg" "end.ogg" "beatdown.ogg"))
      (apply #'play-squareball args)))

TODO Networking support

(defmethod find-identifier ((thing thing))
  (xelf:make-keyword (xelf:uuid thing)))

(defun find-thing-from-id (id)
  (xelf:find-object (symbol-name id) t))

(setf *identifier-search-function* 

(setf xelf:*game-variables* 
      '(xelf:*updates* *game-clock* *score-1* *score-2*
        *difficult* *variation* *use-fortresses* *use-bumpers* *use-music*
       *serve-period-timer* *reset-clock*))

(setf xelf:*object-variables* 
      '(*player-1* *player-2* *goal-1* *goal-2*
        *barrier-1* *barrier-2* *ball*))

(setf xelf:*safe-variables* 
      (append *game-variables* 

(setf xelf:*terminal-bottom* (- *height* (units 1.5)))

(setf xelf:*prompt-font* xelf:*terminal-font*)

(setf xelf:*terminal-left* (units 10.4))

(defmethod find-player ((arena arena) n)
  (ecase n
    (1 (player-1))
    (2 (player-2))
    (3 (player-3))
    (4 (player-4))))

(defmethod spacebar ((arena arena)) 

(defclass client-arena (client-buffer arena) ())

(defmethod initialize-instance :after ((arena client-arena) &key)

(defmethod proceed ((arena client-arena)) 
  (play-sample "go.wav"))

(defmethod populate ((arena client-arena))

(defmethod find-input ((robot robot))
   :time (current-time)
   :player-id (slot-value robot 'player-id)
   :stick-heading (stick-heading robot)
   :kicking-p (kicking-p robot)))

(defmethod find-local-inputs ((arena client-arena))
  (mapcar #'find-input (remove-if-not #'humanp (list *player-1* *player-2*))))

(defmethod update-input-state :after ((robot robot) plist time)
  (destructuring-bind (&key stick-heading kicking-p player-id time) plist
    (setf (input-heading robot) stick-heading)
    (setf (input-kicking-p robot) kicking-p)))

(defmethod kicking-p :around ((robot robot))
  (if (and (serverp (arena))
           (input-p robot) 
           (input-update-p robot))
      (input-kicking-p robot)

(defmethod kicking-p ((player-2 player-2))
  (if (and *netplay* (clientp (arena)))
      (or (holding-shift-p)
          (when *player-2-joystick* 
            (holding-button *player-2-joystick*)))

(defmethod stick-heading :around ((robot robot))
  (if (and 
       (serverp (arena))
       (input-p robot)
       (input-update-p robot))
      (input-heading robot)

(defmethod find-netplay-joystick ((arena arena)) nil)
(defmethod find-netplay-id ((arena arena)) nil)

(defclass server-arena (server-buffer arena) ())

(defmethod find-netplay-joystick ((arena server-arena)) *player-1-joystick*)
(defmethod find-netplay-joystick ((arena client-arena)) *player-2-joystick*)

(defmethod find-netplay-id ((arena server-arena)) 1)
(defmethod find-netplay-id ((arena client-arena)) 2)

(defmethod make-census ((arena arena))
  (let ((uuids (make-hash-table :test 'equal :size 64)))
    (do-nodes (node arena)
      (setf (gethash (slot-value node 'xelf::uuid) uuids)
            (slot-value node 'xelf::uuid)))
    (setf *census* uuids)
    ;; (verbosely "Created census with ~S/~S uuids." (hash-table-count uuids)
    ;;         (length (get-nodes arena)))

(defmethod background-stream ((arena server-arena))
  (mapc #'(lambda (x) (slot-value x 'xelf::uuid))
        (nconc (find-instances arena 'wall)
               (find-instances arena 'brick)
               (find-instances arena 'bumper)
               (find-instances arena 'barrier))))
(defmethod initialize-instance :after ((arena server-arena) &key)
  (setf *use-fortresses* t))

(defmethod ambient-stream ((arena server-arena))
  (let ((stream (copy-tree (make-node-stream))))
    (dolist (var *object-variables*)
      (let ((thing (symbol-value var)))
        (when (or (find thing stream :test #'object-eq)
                  (typep thing (find-class 'ball))
                  (typep thing (find-class 'robot))
                  (typep thing (find-class 'goal))
                  (typep thing (find-class 'barrier))
                  (typep thing (find-class 'bumper)))
          (setf stream (delete (slot-value thing 'xelf::uuid)
          (verbosely "Removed ~S from ambient stream." thing))))

(defun find-arena-class (&optional netplay)
  (case netplay
    (:client 'client-arena)
    (:server 'server-arena)
    (otherwise 'arena)))

(defmethod remove-node :after ((arena client-arena) (brick brick))
  (play-sample (random-choose *color-sounds*)))

Author: David O'Toole

Created: 2017-04-12 Wed 06:32