asteroids-2.rkt

#lang racket
;; An Asteroids game in Racket

;; Copyright (c) 2021 Alex Harsányi (AlexHarsanyi@gmail.com)

;; Permission is hereby granted, free of charge, to any person obtaining a
;; copy of this software and associated documentation files (the "Software"),
;; to deal in the Software without restriction, including without limitation
;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;; and/or sell copies of the Software, and to permit persons to whom the
;; Software is furnished to do so, subject to the following conditions:

;; The above copyright notice and this permission notice shall be included in
;; all copies or substantial portions of the Software.

;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;; DEALINGS IN THE SOFTWARE.

(require racket/gui racket/random)


;;...................................................... the game engine ....

;; A game engine will manage a "scene" of objects.  Here is out scene,
;; initially empty.  We represent the scene as a list of actors.
(define the-scene '())

;; Here are some functions to add and remove actors from the scene.  Since the
;; scene is a list, these functions just use `cons` and `remove` to operate on
;; lists.
(define (add-actor actor)
  (set! the-scene (cons actor the-scene)))

(define (remove-actor actor)
  (set! the-scene (remove actor the-scene)))

;; Here are some basic operations on the scene itself: paining it onto the
;; canvas, updating the scene as time passes and handling keyboard events.
;; This is a simple "game engine", so all we do here is simply pass on the
;; information to every actor in the scene.

(define (paint-scene scene canvas dc)
  (for ([actor (in-list scene)])
    (send actor paint canvas dc)))

(define (update-scene scene collision-handlers delta-time)
  (handle-collisions scene collision-handlers)
  (for ([actor (in-list scene)])
    (send actor update/delta-time delta-time)))

(define (handle-keyboard-event scene event)
  (for ([actor (in-list scene)])
    (send actor keyboard-event event)))

;; Actors are objects and, while we don't yet know what each actor will do,
;; they need to provide some common methods so the game engine can operate on
;; them, so we define an `actor<%>` interface.  Our actors must provide:
;;
;; * a way to draw themselves onto the canvas -- a `paint` method
;;
;; * a way to update their state (e.g. move) -- an `update/delta-time` method
;;
;; * a way to respond to user input (e.g to move the ship) -- an
;; `keyboard-event` method
;;
;; * a way to check for collisions with other objects -- an
;; `maybe-collide-with` method.
;;
(define actor<%>
  (interface ()
    [paint (->m (is-a?/c canvas%) (is-a?/c dc<%>) any/c)]
    [update/delta-time (->m positive? any/c)]
    [keyboard-event (->m (is-a?/c key-event%) any/c)]))

;; Since not all the actors need to supply all methods, we provide a
;; convenient parent class providing empty implementations for all methods, so
;; each actor can override what it needs.
;;
;; For example, only the ship will need to handle keyboard events, but
;; keyboard events are sent to all actors (see `handle-keyboard-event`), so
;; most actors will not need to worry about providing a `keyboard-event`
;; method.
(define actor%
  (class* object% (actor<%>)
    (init)
    (super-new)
    (define/public (paint _canvas _dc) (void))
    (define/public (update/delta-time _dt) (void))
    (define/public (keyboard-event _e) (void))))

;; This is the state of the game and it is used to know when to display the
;; game over overlay, and to exit the game loop.
(define game-outcome 'not-started)

;; We define our own game window, deriving from `frame%` -- this allows us to
;; override the on-close method to set the game outcome to 'abandoned -- this
;; will cause the game loop to exit.  We also intercept keyboard events and
;; send them to the objects in the scene.
(define game-window%
  (class frame%
    (init)
    (super-new)
    (define/augride (on-close)
      (set! game-outcome 'abandoned))
    (define/override (on-subwindow-char receiver event)
      (handle-keyboard-event the-scene event)
      (super on-subwindow-char receiver event))))

;; The GUI frame showing our game
(define the-frame (new game-window% [label "Asteroids"] [width 800] [height 450]))

(define transparent-brush (send the-brush-list find-or-create-brush "black" 'transparent))

;; Handle painting the scene.  We do some setup and delegate painting to all
;; the actors in the scene.  As a special case, if the game state is
;; 'game-over, we display the game over overlay (that could have also been
;; done as an actor)
(define (on-canvas-paint canvas dc)
  (send dc set-smoothing 'smoothed)
  (send dc set-brush transparent-brush)
  (paint-scene the-scene canvas dc))

;; This is the canvas used to draw the actual game scene.
(define the-canvas
  (new canvas%
       [parent the-frame]
       [paint-callback on-canvas-paint]))

;; This is the main game loop, keeping track of time and sending the actors
;; the `update/delta-time` message and refreshing the canvas.  The game loop
;; runs until the game-outcome is set to abandoned -- which is when the user
;; closes the window.
(define (run-game-loop #:frame-rate [frame-rate 60])
  (collect-garbage 'incremental)
  (set! game-outcome 'in-progress)
  (send the-frame show #t)
  (send the-frame focus)

  (define frame-time (* (/ 1.0 frame-rate) 1000.0))

  (let loop ([last-game-time (current-inexact-milliseconds)]
             [current-game-time (current-inexact-milliseconds)])
    (define dt (- current-game-time last-game-time))
    (update-scene the-scene the-collision-handlers dt)
    (send the-canvas refresh-now)
    (define update-duration (- (current-inexact-milliseconds) current-game-time))
    (define remaining-time (- frame-time update-duration))
    (sleep/yield (/ (max 0 remaining-time) 1000.0))
    (unless (equal? game-outcome 'abandoned)
      ;; NOTE: current-game-time becomes last-game-time next iteration
      (loop current-game-time (current-inexact-milliseconds)))))


;;.............................................. two dimensional vectors ....

;; This is a 2D game and we use vectors to represent positions, velocities and
;; acceleration.  For example, when expressed as a vector, the velocity does
;; not only define how fast an object moves, but also in what direction.  This
;; representation makes it convenient to express basic operations in 2D space.

;; https://en.wikipedia.org/wiki/Euclidean_vector

(struct v2 (x y) #:transparent)         ; a vector is a 2D item having an x and y component

(define vzero (v2 0 0))                 ; a convenient "zero vector"
(define vright (v2 1 0)) ; the right unit vector -- a vector pointing to the right
(define vleft (v2 -1 0)) ; the left unit vector
(define vup (v2 0 -1))   ; the up unit vector
(define vdown (v2 0 1))  ; the down unit vector

(define (vplus a b)                     ; vector addition
  (v2 (+ (v2-x a) (v2-x b)) (+ (v2-y a) (v2-y b))))

(define (vminus a b)                    ; vector subtraction
  (v2 (- (v2-x a) (v2-x b)) (- (v2-y a) (v2-y b))))

(define (vnegate a)                     ; vector negation, i.e. (- v)
  (v2 (- (v2-x a)) (- (v2-y a))))

(define (vscale v s)                    ; scaling a vector by a number (Scalar)
  (v2 (* (v2-x v) s) (* (v2-y v) s)))

(define (vdot a b)                      ; dot product (the magic operation)
  ;; https://en.wikipedia.org/wiki/Dot_product
  (+ (* (v2-x a) (v2-x b)) (* (v2-y a) (v2-y b))))

(define (vlength v)                     ; the length of a vector
  (match-define (v2 x y) v)
  (sqrt (+ (* x x) (* y y))))

(define (vnorm v)                       ; normalize: make a unit vector with the same direction as v
  (define l (vlength v))
  (v2 (/ (v2-x v) l) (/ (v2-y v) l)))

(define (vreflect v n)                  ; reflect a vector around a normal 'n'
  (vminus (vscale n (* 2 (vdot v n))) v))

(define (vrotate v theta)               ; rotate counter clockwise theta radians
  (define cos-theta (cos theta))
  (define sin-theta (sin theta))
  (match-define (v2 x y) v)
  (v2 (- (* cos-theta x) (* (- sin-theta) y))
      (+ (* sin-theta x) (* cos-theta y))))

(define (random-direction) ; construct a vector pointing into a random direction
  (define max 10000)
  (define (rnd) (/ (- (random 1 (add1 max)) (/ max 2)) (/ max 2)))
  (vnorm (v2 (rnd) (rnd))))

;; Create a new random number which is around VALUE.  For example, this is
;; used to create velocities which are not the same, but all vary around a
;; value.
(define (random-around value #:precision (precision 1e4) #:nudge (nudge 1e-1))
  (define n (* value nudge))
  (define half-precision (exact-truncate (/ precision 2)))
  (+ value (* n  (/ (random (- half-precision) half-precision) precision))))



;;............................................................... bodies ....

;; a "body" represents an object in a physics engine -- the body has a
;; position, velocity and acceleration (all vectors), a radius (all our
;; physics bodies are circles.  The body also has an orientation and an
;; angular velocity, allowing the body to spin around itself.
;;
;; Finally, the body has a velocity-damping which is used to simulate friction
;; -- a body that has a velocity but no acceleration will slow down according
;; to this parameter
(struct body
  (position
   velocity
   acceleration
   radius
   orientation                          ; orientation for spinning bodies
   angular-velocity
   velocity-damping)
  #:transparent)

;; Create a new body representing the evolution of the body B after a period
;; of time DT.  If the body has acceleration, its velocity will be slightly
;; higher, if the body has velocity, its position will be updated.  Also, the
;; body's orientation will be updated according to its angular velocity.
;;
;; This body simulates the bodys movement in time.
(define (update-body b dt)
  (match-define (body position velocity acceleration radius orientation angular-velocity velocity-damping) b)
  (define new-velocity (vscale (vplus velocity (vscale acceleration dt)) velocity-damping))
  (define new-position (vplus position (vscale new-velocity dt)))
  (define new-orientation (+ orientation (* angular-velocity dt)))
  (body
   new-position
   new-velocity
   acceleration
   radius
   new-orientation
   angular-velocity
   velocity-damping))

;; Bounce the body around a surface with the normal N.  The body's velocity
;; will be reflected around the normal and perturbed slightly.  This is used
;; to implement bouncing of bodies on other objects.
(define (bounce-body b n)
  (define scale
    (if (< (vdot (vnorm (body-velocity b)) n) 0) -1 1))
  (define new-velocity
    (vrotate
     (vreflect (vscale (body-velocity b) scale) n)
     (* (body-angular-velocity b) 16)))
  (struct-copy body b [velocity new-velocity]))



;;........................................................... collisions ....

;; This section defines the basic collision handling mechanism -- actual
;; handlers are defined elsewhere.


;; A list of collision handlers, see `add-collision-handler`
(define the-collision-handlers '())

;; Add a new collision HANDLER between objects of type OBJECT-A and OBJECT-B.
;; OBJECT-A and OBJECT-B are classes (e.g. asteroid%) and the HADNLER function
;; receives two object and it is supposed to detect and handle collisions
;; between the two objects.
(define (add-collision-handler object-a object-b handler)
  (set! the-collision-handlers (cons (list object-a object-b handler) the-collision-handlers)))

;; Handle collisions between two actors using the COLLISION-HANDLERS list of
;; handlers (this is normally THE-COLLISION-HANDLERS), We iterate on the
;; collision handlers and check for a valid one depending on the types of the
;; objects.
(define (handle-collisions-between first-actor second-actor collision-handlers)
  (for/or ([handler (in-list collision-handlers)])
    (match-define (list first-object second-object handler-function) handler)
    
    ;; NOTE: a handler always wants an object of type OBJECT-A first, but we
    ;; also handle the case when the second actor is of type OBJECT-A by
    ;; swapping the arguments to the handler.
    (cond ((and (is-a? first-actor first-object)
                (is-a? second-actor second-object))
           (handler-function first-actor second-actor)
           #t)
          ((and (is-a? first-actor second-object)
                (is-a? second-actor first-object))
           (handler-function second-actor first-actor)
           #t)
          (else
           #f))))

;; Handle collisions in the SCENE (normally THE-SCENE) using
;; COLLISION-HANDLERS (normally THE-COLLISION-HANDLERS).  We simply call
;; `handle-collisions-between` for every pair of actors in the scene, taking
;; special care to not call the handlers twice for the same pair of objects.
(define (handle-collisions scene collision-handlers)
  (let outer-loop ([scene scene])
    (unless (null? scene)
      (define first-actor (first scene))
      ;; Only check for collisions between FIRST-ACTOR and the remaining
      ;; actors -- this ensures that we only call collision handling once for
      ;; each pair.
      (let inner-loop ([remaining-actors (rest scene)])
        (unless (null? remaining-actors)
          (define second-actor (first remaining-actors))
          (handle-collisions-between first-actor second-actor collision-handlers)
          (inner-loop (rest remaining-actors))))
      (outer-loop (rest scene)))))


;;............................................................... models ....

;; Create a pen for drawing a model.  Drawing models is done by scaling up the
;; DC coordinates, and this will scale up pen widths.  This creates a pen that
;; takes scaling into account.
(define (make-scaled-pen color width scale)
  (send the-pen-list find-or-create-pen color (/ width scale) 'solid))

;; Create a dc-path% object from a list of POINTS -- dc-path% objects are
;; easier to draw, but lists of points are easier to define, so this function
;; glues the two.
(define (points->dc-path points)
  (define path (new dc-path%))
  (unless (null? points)
    (match-define (list x y) (first points))
    (send path move-to x y)
    (for ([point (in-list (rest points))])
      (match-define (list x y) point)
      (send path line-to x y)))
  path)

;; Draw a model (a dc-path%) onto the device context DC using a PEN -- the
;; BODY is the physics body and defines the position and size of the model.
;; Since dc-path% objects are fixed, we control the position and orientation
;; by rotating, scaling and offseting the device context itself.
(define (draw-model dc model pen body)
  ;; Save parameters we are about to change
  (define old-transformation (send dc get-transformation))
  (define old-pen (send dc get-pen))

  (define position (body-position body))
  (define scale (body-radius body))
  (define orientation (body-orientation body))

  (send dc set-origin (v2-x position) (v2-y position))
  (send dc set-scale scale scale)
  (send dc set-rotation (- orientation))
  (send dc set-pen pen)
  (send dc draw-path model)

  ;; restore old parameters
  (send dc set-pen old-pen)
  (send dc set-transformation old-transformation))


;;............................................................ asteroid% ....

;; Asteroid `dc-path%` objects, defined around a circle of radius 1. Several
;; paths are defined, to make asteroids look different. When instantiated, an
;; `asteroid%` object will pick a random path to be its model.

(define asteroid-path-1
  (points->dc-path
   '((0/5 5/5) (3/5 4/5) (4/5 3/5) (3/5 1/5) (5/5 0/5) (4/5 -4/5) (1/5 -5/5)
               (-2/5 -4/5) (-4/5 -4/5) (-5/5 -1/5) (-3/5 -1/5) (-5/5 2/5) (-3/5 3/5)
               (-2/5 5/5) (0/5 5/5))))

(define asteroid-path-2
  (points->dc-path
   '((0 -6/5) (-2/5 -4/5) (-4/5 -4/5) (-5/5 -1/5) (-4/5 2/5) (-4/5 3/5)
              (-3/5 3/5) (-1/5 5/5) (4/5 3/5) (4/5 1/5) (5/5 0) (4/5 -3/5)
              (2/5 -4/5) (0 -6/5))))

(define asteroid-path-3
  (points->dc-path
   '((1/5 -4/5) (-2/5 -5/5) (-2/5 -3/5) (-4/5 -4/5) (-4/5 -2/5) (-5/5 0/5)
                (-5/5 3/5) (-3/5 4/5) (-2/5 3/5) (0/5 5/5) (4/5 3/5)
                (3/5 2/5) (3/5 1/5) (5/5 1/5) (4/5 -3/5) (3/5 -5/5)
                (1/5 -4/5))))

(define asteroid-path-4
  (points->dc-path
   '((0/5 -5/5) (-2/5 -4/5) (-4/5 -4/5) (-4/5 -1/5) (-5/5 1/5) (-3/5 4/5)
                (-1/5 5/5) (2/5 5/5) (1/5 3/5) (3/5 4/5) (5/5 1/5)
                (3/5 -2/5) (3/5 -4/5) (0/5 -5/5))))

(define asteroid-paths
  (list asteroid-path-1 asteroid-path-2 asteroid-path-3 asteroid-path-4))

;; The "asteroid%" actor represents asteroids on the screen.  They move
;; around, bounce around other asteroids and walls and are hit by laser shots
;; -- when hit by laser shot, new smaller asteroids are created in their
;; place.
(define asteroid%
  (class actor%
    (init-field [initial-position #f]
                [initial-direction (random-direction)]
                [initial-speed (random-around 0.05)]
                [initial-angular-velocity (random-around 0.0005)]
                [model (random-ref asteroid-paths)]
                [size (random 60 90)])
    (super-new)

    (unless initial-position
      (error "asteroid%: initial position must be specified"))
    

    (define the-body
      (body
       initial-position
       (vscale initial-direction initial-speed)
       vzero                ; no acceleration
       size                 ; radius
       0                    ; orientation
       initial-angular-velocity
       1.0                  ; no velocity damping
       ))

    (define/public (get-body) the-body)

    ;; Handle hitting a wall -- bounce the body around the normal of the wall
    (define/public (reflect-by-normal normal)
      (set! the-body (bounce-body the-body normal)))

    ;; Updating an asteroid means simply updating its physics body
    (define/override (update/delta-time dt)
      (set! the-body (update-body the-body dt)))

    (define pen (make-scaled-pen "firebrick" 3 size))

    ;; Painting an asteroid means simply paining the model.
    (define/override (paint _canvas dc)
      (draw-model dc model pen the-body))))


;;................................................................ wall% ....

;; A "wall%" is a simple actor which serves to as a collision body to keep
;; objects in the scene.  It does not draw itself anything (i.e. the wall is
;; invisible) and does not update itself, i.e. it is not moving anywhere.
;;
;; A wall is a line, which is defined as a normal and a distance from origin.
;; This form is useful in quickly determining how far away a point is from a
;; line.
(define wall%
  (class actor%
    (init-field normal distance)
    (super-new)

    (define/public (get-normal) normal)
    (define/public (get-distance) distance)

    ))


;;................................................... collision-handling ....

;; Determine if a body and a wall collide, i.e the distance from the center of
;; the body to the wall is less than the body radius.
(define (body-wall-collision? b wall-normal wall-distance)
  (define centre-to-wall-distance
    (+ (vdot wall-normal (body-position b)) wall-distance))
  (< centre-to-wall-distance (body-radius b)))

;; Handle an asteroid - wall collision -- if they collide, reflect the
;; asteroid.
(define (handle-asteroid-wall-collision a w)
  (when (body-wall-collision? (send a get-body) (send w get-normal) (send w get-distance))
    (send a reflect-by-normal (send w get-normal))))

;; Add the handler for the asteroid - wall collision
(add-collision-handler asteroid% wall% handle-asteroid-wall-collision)


;; Determine if two bodies collide -- i.e. the distance between their centers
;; is smaller than the sum of their radii.
(define (bodies-collide? b1 b2)
  (define center-direction (vminus (body-position b1) (body-position b2)))
  (define distance-between-centres (vlength center-direction))
  (< distance-between-centres (+ (body-radius b1) (body-radius b2))))

;; Handle an asteroid - asteroid collision -- if they collide, reflect both of
;; them on the collision normal
(define (handle-asteroid-asteroid-collision a b)
  (define a-body (send a get-body))
  (define b-body (send b get-body))
  (when (bodies-collide? a-body b-body)
    (define collision-direction
      (vnorm (vminus (body-position a-body) (body-position b-body))))
    (send a reflect-by-normal collision-direction)
    (send b reflect-by-normal (vscale collision-direction -1))))

(add-collision-handler asteroid% asteroid% handle-asteroid-asteroid-collision)



;;...................................................... setup the scene ....

;; To place actors correctly in the scene we need to know the scene size - the
;; size specified to the frame% object are the outside dimensions, so we need
;; to ask the canvas for its size.  However, GUI widget sizes are only
;; computed when the frame is shown to the user, so we have to call
;; reflow-container before we have valid values for the canvas size.
;;
;; The game uses a fixed canvas size -- we could also have accommodated
;; dynamic sizes by intercepting the on-size method in the canvas and
;; informing all actors of size changes -- this is done in the space invaders
;; implementation, see
;;
;; https://gist.github.com/alex-hhh/da11a5e937960e69dc473be131be732d
;; https://alex-hhh.github.io/2020/11/space-invaders.html
;;
(send the-frame reflow-container)
(define-values (canvas-width canvas-height) (send the-canvas get-size))

;; These are the walls making up the scene, everything bounces inside these
;; walls.
(add-actor (new wall% [normal vright] [distance 0]))
(add-actor (new wall% [normal vleft] [distance canvas-width]))
(add-actor (new wall% [normal vdown] [distance 0]))
(add-actor (new wall% [normal vup] [distance canvas-height]))

(add-actor (new asteroid%
                [initial-position (v2 150 200)]
                [initial-direction (random-direction)]
                [initial-speed 0.05]))
(add-actor (new asteroid%
                [initial-position (v2 350 200)]
                [initial-direction (random-direction)]
                [initial-speed 0.05]))
(add-actor (new asteroid%
                [initial-position (v2 550 200)]
                [initial-direction (random-direction)]
                [initial-speed 0.05]))
(run-game-loop)