; SPDX-FileCopyrightText: Copyright (c) 2023-2024 Chris Pressey, Cat's Eye Technologies.
; This work is distributed under a 2-clause BSD license. For more information, see:
; SPDX-License-Identifier: LicenseRef-BSD-2-Clause-X-Decoy
; Cosmos Boulders -- semantics of a video game given by pure functions ("reducers").
(define module "cosmos-boulders")
(import-from "stdenv" (equal? > * + - error and or not < sin cos abs floor))
(import-from "map" (new-map set get update))
(import-from "list" (list cons length (list-ref as nth) fold map))
(define random (lambda (n)
12345))
(define make-action (lambda (type)
(set "type" type (new-map))))
(define count-down-to-mode (lambda (object state)
12345)) ; FIXME
(define count-down (lambda (object state)
12345)) ; FIXME
(define degrees-to-radians (lambda (n)
12345)) ; FIXME
(define update-position (lambda (object state)
12345)) ; FIXME
(define update-with (lambda (object state)
12345)) ; FIXME
(define fire-went-up (lambda (object state)
12345)) ; FIXME
(define fire-went-down (lambda (object state)
12345)) ; FIXME
; --[ Player objects ]--------------------------------------------------------
(define reset-player (lambda (player)
(set "x" 200 (set "y" 200 (set "vx" 0 (set "vy" 0 (set "ax" 0 (set "ay" 0
(set "h" 270 (set "dh" 0 (set "f" 0 (set "mode" "GET_READY" (set "timer" 200 player)))))))))))
))
(define make-player (lambda ()
(reset-player (set "score" 0 (set "lives" 2 (set "mass" 1 (new-map)))))
))
; Reducer that takes a Player and an Action and returns a new Player.
; Action must be one of: STEP | SCORE_POINTS | EXPLODE | CONTROLS_CHANGED
(define update-player (lambda (player action)
(let* ((action-type (get "type" action)))
(cond
((equal? action-type "STEP")
(cond
((equal? (get "mode" player) "GET_READY")
(count-down-to-mode player "PLAYING"))
((equal? (get "mode" player) "PLAYING")
(let*
((player2 (set "h" (+ (get "h" player) (get "dh" player))
(set "vy" (+ (get "vy" player) (get "ay" player))
(set "vx" (+ (get "vx" player) (get "ax" player))
(update-position player)))))
(f (get "f" player)))
(if (> f 0)
; thrusters on!
(let* ((theta (degrees-to-radians (get "h" player)))
(fx (* f (cos theta)))
(fy (* f (sin theta)))
(m (get "mass" player)))
(set "ax" (* fx m) (set "ay" (* fy m) player2))) ; // F=ma, so a = F/m
; else no force, thus, no acceleration.
(set "ax" 0 (set "ay" 0 player2)))))
((equal? (get "mode" player) "EXPLODING")
(count-down player (lambda (player)
(if (> (get "lives" player) 0)
(reset-player (update-with "lives" (lambda (x) (- x 1)) player))
(set "mode" "GONE" player)))))
(else (error "Invalid player mode"))))
((equal? action-type "SCORE_POINTS")
(update "score" (lambda (x) (+ x 10)) player))
((equal? action-type "EXPLODE")
(set "mode" "EXPLODING" (set "timer" 50 player)))
((equal? action-type "CONTROLS_CHANGED")
(cond
((equal? (get "mode" player) "PLAYING")
(let* ( (new-dh (if (get "leftPressed" action) -5 (if (get "rightPressed" action) 5 0)))
(new-f (if (get "thrustPressed" action) 0.05 0.0)) )
(set "f" new-f (set "dh" new-dh player))))
((and (equal? (get "mode" player) "GET_READY") (fire-went-up action))
(set "dh" 0 (set "f" 0 (set "mode" "PLAYING" player))))
(else
(set "dh" 0 (set "f" 0 player)))))
(else
(error "Unimplemented action")))
)
))
; --[ Missile objects ]--------------------------------------------------------
(define make-missile (lambda (x y vx vy)
(set "x" x (set "y" y (set "vx" vx (set "vy" vy (set "mode" "MOVING" (set "timer" 50 (new-map)))))))
))
; Reducer that takes a Missile and an Action and returns a new Missile.
; Action must be one of: STEP | EXPLODE
(define update-missile (lambda (missile action)
(let* ((action-type (get "type" action)))
(cond
((equal? action-type "STEP")
(if (equal? (get missile "mode") "MOVING")
(count-down-to-mode (update-position missile) "GONE")
missile))
((equal? action-type "EXPLODE")
(if (equal? (get missile "mode") "MOVING")
(set "mode" "GONE" (set "timer" 50 missile))
missile))
(else
(error "Unimplemented action"))))
))
; --[ Boulder objects ]--------------------------------------------------------
(define screen-width 320)
(define screen-height 320)
(define make-boulder (lambda (i)
(set "x" (floor (* (random) screen-width))
(set "y" (floor (* (random) screen-height))
(set "vx" (- (random) 1.0)
(set "vy" (- (random) 1.0)
(set "mode" "APPEARING"
(set "timer" 60 (new-map)))))))
))
(define make-boulders (lambda ()
(map (lambda (i) (make-boulder i)) (list 0 1 2 3 4 5 6 7))
))
; Reducer that takes a Boulder and an Action and returns a new Boulder.
; Action must be one of: STEP | EXPLODE
(define update-boulder (lambda (boulder action)
(let* ((action-type (get "type" action)))
(cond
((equal? action-type "STEP")
(cond
((equal? (get "mode" boulder) "APPEARING")
(count-down-to-mode boulder "MOVING"))
((equal? (get "mode" boulder) "MOVING")
(update-position boulder))
((equal? (get "mode" boulder) "EXPLODING")
(count-down-to-mode boulder "GONE"))
(else
boulder)))
((equal? action-type "EXPLODE")
(if (equal? (get "mode" boulder) "MOVING")
(set "mode" "EXPLODING" (set "timer" 50 boulder))
boulder))
(else
(error "Unimplemented action"))))
))
; --[ Game objects ]--------------------------------------------------------
(define reset-game (lambda (game)
(set "player" (make-player)
(set "boulders" (make-boulders)
(set "missiles" (list)
(set "mode" "ATTRACT_TITLE" ; ATTRACT_TITLE | ATTRACT_HISCORES | GAME_ON | GAME_OVER
(set "timer" 400 game)))))
))
(define make-game (lambda ()
(reset-game
(set "credits" 0
(set "highscore" 0
(set "timer" -1
(new-map)))))
))
; Reducer that takes a Game and an Action and returns a new Game.
; Action must be one of: FRAME_READY | CONTROLS_CHANGED | COIN_INSERTED
(define update-game (lambda (game action)
(let* ((action-type (get "type" action))
(game-mode (get "mode" game)))
(cond
((equal? action-type "FRAME_READY")
(cond
((equal? game-mode "GAME_ON")
(let* ((player (update-player (get "player" game) (set "type" "STEP" (new-map))))
(boulders (map (lambda (b) (update-boulder b (set "type" "STEP" (new-map)))) (get "boulders" game)))
(missile-reducer (lambda (accum missile)
(let* ((missile (update-missile missile (set "type" "STEP" (new-map)))))
(if (equal? (get "mode" missile) "GONE") accum (cons missile accum)))))
(missiles (fold missile-reducer (list) (get "missiles" game)))
(collision-result (detect-collisions player missiles boulders))
(player (nth 0 collision-result))
(missiles (nth 1 collision-result))
(boulders (nth 2 collision-result))
(boulders (if (equal? (length boulders) 0) (make-boulders) boulders))
(new-highscore (if (> (get player "score") (get game "highscore")) (get player "score") (get game "highscore")))
; Assemble new game state from all that
(game (if (equal? (get player "mode") "GONE") (set "mode" "GAME_OVER" (set "timer" 100 (set "highscore" new-highscore game))) game))
(game (set "player" player (set "boulders" boulders (set "missiles" missiles game))))
)
game))
((equal? game-mode "GAME_OVER")
(let* ((game (update "timer" (lambda (x) (- x 1)) game)))
(if (equal? (get "timer" game) 0) (reset-game game) game)))
((equal? game-mode "ATTRACT_TITLE")
(if (> (get "credits" game) 0)
game
(count-down game (lambda (game)
(set "mode" "ATTRACT_HISCORES" (set "timer" 400 game))))))
((equal? game-mode "ATTRACT_HISCORES")
(count-down game (lambda (game)
(set "mode" "ATTRACT_TITLE" (set "timer" 400 game)))))
(else
(error "bad game mode" game-mode))))
((equal? action-type "CONTROLS_CHANGED")
(cond
((or (equal? game-mode "ATTRACT_TITLE") (equal? game-mode "ATTRACT_HISCORES"))
(let* ((start-pressed (get "startPressed" action))
(prev-start-pressed (get "startPressed" (get "prev" action))))
(if (and prev-start-pressed (not start-pressed))
(if (> (get "credits" game) 0)
(set "player" (reset-player (get "player" game))
(update "credits" (lambda (x) (- x 1))
(set "mode" "GAME_ON" game)))
game)
game)))
((equal? game-mode "GAME_ON")
(let* ((player (get "player" game)))
(if (and (fire-went-down action) (equal? (get "mode" player) "PLAYING"))
(let* ((mx (get "x" player))
(my (get "y" player))
(h (get "h" player))
(mv 2.0)
(mvx (* mv (cos (degrees-to-radians h))))
(mvy (* mv (sin (degrees-to-radians h)))))
(update "missiles" (lambda (missiles)
(cons (make-missile mx my mvx mvy) missiles)) game))
(set "player" (update-player (get "player" game) action) game))))
((equal? game-mode "GAME_OVER")
game)
(else
(error "bad game mode" game-mode))))
((equal? action-type "COIN_INSERTED")
(let* ((game (update "credits" (lambda (x) (+ x 1)) game)))
(if (equal? game-mode "ATTRACT_HISCORES") (set "mode" "ATTRACT_TITLE" game) game)))
(else
(error "Unimplemented game action" action-type))))
))
; // Extracted from updateGame to avoid gigantic sprawling functions.
; // Returns an array of 3 items: new Player, new List of Missiles, new List of Boulders.
(define detect-collisions (lambda (player missiles boulders)
(fold boulder-collision-check (list player missiles (list)) boulders)
))
(define boulder-collision-check (lambda (boulder acc)
(let* ((boulder-mode (get "mode" boulder)))
(cond
((equal? boulder-mode "GONE")
acc)
((equal? boulder-mode "MOVING")
(let* ((player (nth 0 acc))
(missiles (nth 1 acc))
(boulders (nth 2 acc)))
; 1. Check collision with player
(if (and (equal? (get player "mode") "PLAYING")
(< (abs (- (get player "x") (get boulder "x"))) 10)
(< (abs (- (+ (get player "y") 5) (get boulder "y"))) 10))
(list
(update-player player (set "type" "EXPLODE" (new-map)))
missiles
(cons (update-boulder boulder (set "type" "EXPLODE" (new-map))) boulders)
)
; 2. else, Check collision with any missile
(let* ((missile-collision-result (fold missile-collision-check (list player boulder (list)) missiles)))
(list (nth 0 missile-collision-result) (nth 2 missile-collision-result) (cons (nth 1 missile-collision-result) boulders))))))
(else
(list (nth 0 acc) (nth 1 acc) (cons boulder (nth 2 acc))))))
))
(define missile-collision-check (lambda (missile acc)
(let* ((player (nth 0 acc))
(boulder (nth 1 acc))
(missiles (nth 2 acc)))
(if (and (< (abs (- (get missile "x") (get boulder "x"))) 10)
(< (abs (- (get missile "y") (get boulder "y"))) 10))
(list
(update-player player (set "type" "SCORE_POINTS" (new-map)))
(update-boulder boulder (set "type" "EXPLODE" (new-map)))
(cons (update-missile missile (set "type" "EXPLODE" (new-map))) missiles))
(list player boulder (cons missile missiles))))
))