path: root/turbo.scm

(use-modules (chickadee)
	     (chickadee graphics sprite)
	     (chickadee graphics viewport)
	     (chickadee graphics texture)
	     (chickadee graphics color)
	     (chickadee graphics text)
	     (chickadee math vector)
	     (chickadee math rect)
	     (srfi srfi-9)
	     (chickadee audio)
	     (ice-9 pretty-print)
	     (ice-9 format)
	     (srfi srfi-1))


(define-record-type <animated-sprite>
  (make-animated-sprite sprites fps timer running?)
  animated-sprite?
  (sprites animated-sprite-sprites)
  (fps animated-sprite-fps)
  (timer animated-sprite-timer set-animated-sprite-timer!)
  (running? animated-sprite-running? set-animated-sprite-running!))

(define (make-asprite sprites fps)
  (make-animated-sprite sprites fps 0 #t))

(define (animated-sprite-frame-time sprite)
  (/ 1 (animated-sprite-fps sprite)))

(define (animated-sprite-max-timer sprite)
  (let ((frame-time (animated-sprite-frame-time sprite)))
    (* frame-time (length (animated-sprite-sprites sprite)))))

(define (animated-sprite-animate! sprite elapsed-time)
  (let ((timer (+ (animated-sprite-timer sprite) elapsed-time))
	(max-timer (animated-sprite-max-timer sprite)))
    (set-animated-sprite-timer! sprite (if (>= timer max-timer)
					   (- max-timer timer)
					   timer))))

(define (animated-sprite->sprite sprite)
  (if (animated-sprite-running? sprite)
      (let* ((timer (animated-sprite-timer sprite))
	     (frame-time (animated-sprite-frame-time sprite))
	     (index (inexact->exact (floor (/ timer frame-time))))
	     (sprite-ref (min (max 0 index) (- (length (animated-sprite-sprites sprite)) 1))))
	(list-ref (animated-sprite-sprites sprite) sprite-ref))
      (list-ref (animated-sprite-sprites sprite) 0)))

;;;; Vehicles module
(define vehicle-height 44)
(define vehicle-length 100)
(define vehicle-steering-speed 4.0)

(define-record-type <vehicle>
  (make-vehicle id sprite position speed active?)
  vechicle?
  (id vehicle-id)
  (sprite vehicle-sprite)
  (position vehicle-position set-vehicle-position!)
  (speed vehicle-speed set-vehicle-speed!)
  (active? vehicle-active? set-vehicle-active!))

(define (make-inactive-vehicle id tile initial-position)
  (make-vehicle id tile initial-position 4 #f))

(define (vehicle-hitbox vehicle)
  (rect (vec2-x (vehicle-position vehicle))
	(vec2-y (vehicle-position vehicle))
	vehicle-length
	vehicle-height))

(define (vehicle-safety-distance? vehicle1 vehicle2)
  (let ((vehicle1-x (vec2-x (vehicle-position vehicle1)))
	(vehicle2-x (vec2-x (vehicle-position vehicle2))))
    (> (abs (- vehicle2-x vehicle1-x))
       (+ (* 3 vehicle-length)))))

(define (vehicle-speed- vehicle1 vehicle2)
  (- (vehicle-speed vehicle1) (vehicle-speed vehicle2)))

(define (vehicle-move! vehicle translation)
  (set-vehicle-position!
   vehicle
   (vec2+ (vehicle-position vehicle) translation)))

(define (vehicle-inactive? vehicle)
  (not (vehicle-active? vehicle)))

(define (vehicle= vehicle1 vehicle2)
  (= (vehicle-id vehicle1) (vehicle-id vehicle2)))
;;;; End vehicles module

;;;; Constants and variables

(define assets-root (if (getenv "APPDIR")
			(format #f "~a/usr/share/turbo/" (getenv "APPDIR"))
			""))
(define (asset-path asset)
  (format #f "~a~a" assets-root asset))

(define the-font #f)
(define font-7-segments #f)

(define lane-height 65)
(define lane-length 192)
(define road-start-y 80)
(define road-section-position 0)
(define road #f)
(define lamps #f)
(define road-num-lanes 5)
(define road-end-y (+ road-start-y (* road-num-lanes lane-height)))
(define road-top #f)
(define road-bottom #f)
(define road-lane #f)
(define grass #f)
(define dashboard-set #f)
(define dash-background #f)
(define dash-7seg-background #f)

(define grass-height 96)

(define vehicles-sprites #f)
(define vehicles '())

(define player-velocity (vec2 0 0))
(define player-min-speed 250)
(define player-max-speed 1072)
(define player-rotation 0)
;; 2px/s/s acceleration
(define player-car-acceleration 100)
;; 4px/s/s deceleration
(define player-car-deceleration -500)
(define player-current-acceleration 0)
(define player-distance-travelled 0)
(define player-time-travelled 0)
(define (distance-in-miles)
  (/ player-distance-travelled 12440))

(define (speed-in-mph)
  (* (vehicle-speed player-car) 0.11187))

(define level-difficulty 1)
(define max-level 20)

(define music-res #f)
(define music #f)
(define engine-res #f)
(define engine-sound #f)

(define (calculate-vehicle-position lane)
  (vec2 (window-width (current-window))
	(+ road-start-y
	   (* 65 (- lane 1))
	   (floor (/ (- lane-height vehicle-height) 2)))))

(define (random-lane-start-pos)
  (calculate-vehicle-position (+ 1 (random road-num-lanes))))

(define (make-vehicle-list vehicle-list tile-ref)
  (if (< tile-ref (texture-atlas-size vehicles-sprites))
      (cons (make-inactive-vehicle
	     tile-ref
	     (make-asprite
	      (list (texture-atlas-ref vehicles-sprites tile-ref)
		    (texture-atlas-ref vehicles-sprites (+ 1 tile-ref))
		    (texture-atlas-ref vehicles-sprites (+ 2 tile-ref))
		    (texture-atlas-ref vehicles-sprites (+ 3 tile-ref)))
	      6)
	     (random-lane-start-pos))
	    (make-vehicle-list vehicle-list (+ tile-ref 4)))
      vehicle-list))

(define (vehicle-reset-ahead veh)
  (let ((lane-num (random road-num-lanes)))
    (set-vehicle-position! veh (calculate-vehicle-position
				(+ 1 lane-num)))
    (set-vehicle-speed! veh (+ player-min-speed (* 75 lane-num)) )
    (set-vehicle-active! veh #f)))

(define game-started? #f)
(define game-over? #f)
(define show-credits? #f)
(define show-help? #f)
(define menu-items (list 'new-game 'credits 'help 'quit))
(define menu-selection 0)

(define (vehicle-has-spawn-space? vehicle)
  (define (vehicle-in-the-way? v)
    (and (not (vehicle= vehicle v))
	 (vehicle-active? v)
	 (not (vehicle-safety-distance? v vehicle))))
  (not (any vehicle-in-the-way? vehicles)))


;;;; Game functions

(define (draw-lanes x y num-lanes)
  (when (> num-lanes 0)
      (draw-sprite road-lane (vec2 x y))
      (draw-lanes x (+ lane-height y) (- num-lanes 1))))

(define (draw-road-section startx starty num-lanes)
  (draw-sprite road-bottom (vec2 startx starty))
  (draw-lanes startx (+ lane-height starty) (- num-lanes 2))
  (draw-sprite road-top (vec2 startx (+ starty (* lane-height (- num-lanes 1))))))

(define (draw-grass-down x y)
  (draw-sprite grass (vec2 x (- y grass-height))))

(define (draw-grass-up x y)
  (draw-sprite grass (vec2 x y)))

(define (draw-road startx starty num-lanes)
  (when (< startx (window-width (current-window)))
      (draw-grass-down startx starty)
      (draw-road-section startx starty num-lanes)
      (draw-road (+ startx lane-length) starty num-lanes)
      (draw-grass-up startx (+ starty (* lane-height num-lanes)))))

(define (draw-lamps startx starty num-lanes)
  (when (< startx (window-width (current-window)))
    (draw-sprite (texture-atlas-ref lamps 0) (vec2 startx starty))
    (draw-sprite (texture-atlas-ref lamps 1) (vec2 startx (+ starty (* lane-height (- num-lanes 1)))))
    (draw-lamps (+ startx lane-length) starty num-lanes)))

(display "KOIN\n")

(define (lane-y num-lane)
  (+ road-start-y
     (* lane-height (- num-lane 1))))

(define initial-player-position (vec2 0 0))

(define player-car #f)

(define (level-min-speed)
  (+ player-min-speed (* (- level-difficulty 1) 36)))

(define car-gears 5)

(define (gearing-range)
  (/ (* 1.05 player-max-speed) car-gears))

(define (speed->gear speed)
  (let ((gear-range (gearing-range)))
    (floor (/ speed gear-range))))

(define (speed->engine-power speed)
  (let* ((gear (speed->gear speed))
	 (speed-range (* gear (gearing-range))))
    (/ (- speed speed-range) speed-range)))

(define (set-player-speed! new-speed)
  (let* ((min-speed (level-min-speed))
	 (player-speed (max (min new-speed player-max-speed) min-speed))
	 (engine-power (speed->engine-power player-speed))
	 (pitch-factor (+ 1 engine-power)))
    (set-vehicle-speed! player-car player-speed)
    (set-source-pitch! engine-sound (+ 1 pitch-factor))))

(define (player-on-road?)
  (and (> (vec2-y (vehicle-position player-car)) road-start-y)
       (< (+ (vec2-y (vehicle-position player-car)) vehicle-height) road-end-y)))

(define (crash-player top?)
  (set! player-rotation (if top? 1 -1))
  (set-vehicle-position! player-car (vec2+ (vehicle-position player-car) (vec2 0 (if top? 30 10))))
  (set-vehicle-speed! player-car 0)
  (source-stop engine-sound))

(define (off-road-player-top)
  (crash-player #t))

(define (off-road-player-bottom)
  (crash-player #f))

(define (off-road-player)
  "Moves the player off-road"
  (if (> (vec2-y (vehicle-position player-car)) road-start-y)
      (off-road-player-top)
      (off-road-player-bottom)))

(define (player-collides?)
  (let ((player-hitbox (vehicle-hitbox player-car)))
    (any (lambda (vehicle)
	   (rect-intersects? player-hitbox (vehicle-hitbox vehicle)))
	 vehicles)))


(define (vehicle-off-screen? veh)
  (and vehicle-active?
       (>= (- vehicle-length) (vec2-x (vehicle-position veh)))))

(define (reset-game!)
  (set! player-distance-travelled 0)
  (set! player-time-travelled 0)
  (set! level-difficulty 1)
  (set-vehicle-position! player-car initial-player-position)
  (set-player-speed! (level-min-speed))
  (set! player-rotation 0)
  (source-play engine-sound)
  (for-each vehicle-reset-ahead vehicles)
  ;; Reset all vehicles
  (set! game-over? #f)
  (set! game-started? #t))

(define (game-won?)
  (and game-started? (> level-difficulty max-level)))

;;;; Chickadee hooks

(define (load)
  (set! the-font (load-bitmap-font (asset-path "fonts/thick_8x8.xml")))
  (set! font-7-segments (load-font (asset-path "fonts/DSEG7Classic-Regular.ttf") 24))
  (set! road (load-tileset (asset-path "sprites/road.png") lane-length lane-height))
  (set! lamps (load-tileset (asset-path "sprites/lamps.png") lane-length lane-height))
  (set! road-top (texture-atlas-ref road 2))
  (set! road-bottom (texture-atlas-ref road 0))
  (set! road-lane (texture-atlas-ref road 1))
  (set! grass (load-image (asset-path "sprites/grass.png")))
  (set! dashboard-set (load-tileset (asset-path "sprites/dash-background.png") 64 64))
  (set! dash-background (texture-atlas-ref dashboard-set 0))
  (set! dash-7seg-background (texture-atlas-ref dashboard-set 1))
  (set! vehicles-sprites (load-tileset (asset-path "sprites/vehicles.png") vehicle-length vehicle-height))

  (set! initial-player-position
    (vec2 (/ (- (window-width (current-window)) vehicle-length) 6)
	  (+ (lane-y 3)
	     (/ (- lane-height vehicle-height) 2))))
  (set! player-car (make-vehicle
		    0
		    (make-asprite
		     (list 
		      (texture-atlas-ref vehicles-sprites 0)
		      (texture-atlas-ref vehicles-sprites 1)
		      (texture-atlas-ref vehicles-sprites 2)
		      (texture-atlas-ref vehicles-sprites 3))
		     8)
		    initial-player-position
		    (+ 1 player-min-speed)
		    #t))

  ;; Audio
  (set! music-res (load-audio (asset-path "sound/music.ogg")))
  (set! music (make-source #:audio music-res #:loop? #t))
  (set! engine-res (load-audio (asset-path "sound/engine-loop-1.ogg")))
  (set! engine-sound (make-source #:audio engine-res #:loop? #t))
  (set-source-volume! music 0.3)

  (set! vehicles (make-vehicle-list (list) 4))
  (for-each vehicle-reset-ahead vehicles)
  (set-vehicle-active! (car vehicles) #t)

  (source-play music)
  (source-play engine-sound))

(define (update interval)
  (unless game-over?
    (unless (player-on-road?)
      (off-road-player)
      (set! game-over? #t))


    (set! player-distance-travelled (+ player-distance-travelled (* interval (vehicle-speed player-car))))
    (set! player-time-travelled (+ player-time-travelled interval))

    ;; Increase level every 2 miles
    (when (and (< level-difficulty max-level) (> (distance-in-miles) (* 2 level-difficulty)))
      (set! level-difficulty (+ 1 level-difficulty)))
    
    (if (game-won?)
	(set! game-over? #t))

    (let ((new-speed (+ (vehicle-speed player-car)
			(* player-current-acceleration interval))))
      (set-player-speed! new-speed))

    (animated-sprite-animate! (vehicle-sprite player-car) interval)

    (when (and game-started? (player-collides?))
      (off-road-player)
      ;; TODO: Think of different animation for this game over
      (set! game-over? #t))

    (set! road-section-position
	  (if (< road-section-position (- lane-length))
	      (- (+ road-section-position lane-length) (* interval (vehicle-speed player-car)))
	      (- road-section-position (* interval (vehicle-speed player-car)))))

    (set-vehicle-position! player-car (vec2+ (vehicle-position player-car)
					     player-velocity))

    (for-each (lambda (veh)
		(animated-sprite-animate! (vehicle-sprite veh) interval)
		(vehicle-move! veh (vec2 (- (* interval (vehicle-speed- player-car veh))) 0)))
	      (filter vehicle-active? vehicles))

    ;; Reset vehicles that have gone off screen
    (for-each vehicle-reset-ahead (filter vehicle-off-screen? vehicles))

    ;; Randomly respawn vehicles based on level difficulty
    (let ((challenge (- (round (/ (* max-level 10) level-difficulty)) 9)))
      (when (= 0 (random challenge))
	(let* ((inactive-vehicles (filter vehicle-inactive? vehicles))
	       (spawnable-vehicles (filter vehicle-has-spawn-space? inactive-vehicles)))
	  (if (not (null? spawnable-vehicles))
	      (set-vehicle-active! (list-ref
				    spawnable-vehicles
				    (random (length spawnable-vehicles)))
				   #t)))))
    ;; End (unless game-over?)
    ))

(define (draw alpha)
  (draw-road road-section-position road-start-y road-num-lanes)

  (for-each (lambda (veh)
	      (draw-sprite (animated-sprite->sprite (vehicle-sprite veh))
			   (vehicle-position veh)))
	    (filter vehicle-active? vehicles))

  (let loop ((index 0))
    (draw-sprite dash-background (vec2 index 0))
    (when (< (+ index (texture-width dash-background)) (window-width (current-window)))
      (loop (+ index (texture-width dash-background)))))

  (draw-sprite (animated-sprite->sprite (vehicle-sprite player-car))
	       (vehicle-position player-car)
	       #:rotation player-rotation)

  (draw-lamps road-section-position road-start-y road-num-lanes)
  
  (unless game-started?
    (let ((window-top (window-height (current-window))))
      (cond
       (show-credits?
	(let ((left-margin 60)
	      (top-start 125)
	      (gap 25))
	  (draw-text "TURBO RACER 3000!"
		     (vec2 left-margin (-  window-top top-start))
		     #:font the-font
		     #:scale (vec2 4 4)
		     #:color red)
	  (draw-text "DEVELOPMENT: Gene Pasquet"
		     (vec2 left-margin (- window-top (+ top-start gap)))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text "DESIGN: Owen Pasquet"
		     (vec2 left-margin (- window-top (+ top-start (* 2 gap))))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text "PLAY TESTING: Owen Pasquet"
		     (vec2 left-margin (- window-top (+ top-start (* 3 gap))))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text "MUSIC: Instrumental by Aries Beats"
		     (vec2 left-margin (- window-top (+ top-start (* 4 gap))))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text "FONTS: Keshikan"
		     (vec2 left-margin (- window-top (+ top-start (* 5 gap))))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text "SOUND: qubodup"
		     (vec2 left-margin (- window-top (+ top-start (* 6 gap))))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text "BACK"
		     (vec2 250 (- window-top 330))
		     #:font the-font
		     #:scale (vec2 2 2)
		     #:color yellow)))
       (show-help?
	(let ((left-margin 60)
	      (top-start 125)
	      (gap 25))
	  (draw-text "TURBO RACER 3000!"
		     (vec2 left-margin (-  window-top top-start))
		     #:font the-font
		     #:scale (vec2 4 4)
		     #:color red)
	  (draw-text "Complete 10miles fast!"
		     (vec2 left-margin (- window-top (+ top-start gap)))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text "Arrow keys or WASD control the car."
		     (vec2 left-margin (- window-top (+ top-start (* 2 gap))))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text "ESCAPE for the main menu"
		     (vec2 left-margin (- window-top (+ top-start (* 3 gap))))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text ""
		     (vec2 left-margin (- window-top (+ top-start (* 4 gap))))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text ""
		     (vec2 left-margin (- window-top (+ top-start (* 5 gap))))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text ""
		     (vec2 left-margin (- window-top (+ top-start (* 6 gap))))
		     #:font the-font
		     #:scale (vec2 2 2))
	  (draw-text "BACK"
		     (vec2 250 (- window-top 330))
		     #:font the-font
		     #:scale (vec2 2 2)
		     #:color yellow)))
       (else
	;; Draw the menu
	(draw-text "TURBO RACER 3000!"
		   (vec2 60 (-  window-top 125))
		   #:font the-font
		   #:scale (vec2 4 4)
		   #:color red)
	(draw-text "NEW GAME"
		   (vec2 250 (- window-top 250))
		   #:font the-font
		   #:scale (vec2 2 2)
		   #:color (if (= menu-selection 0) yellow white))
	(draw-text "CREDITS"
		   (vec2 250 (- window-top 270))
		   #:font the-font
		   #:scale (vec2 2 2)
		   #:color (if (= menu-selection 1) yellow white))
	(draw-text "HELP"
		   (vec2 250 (- window-top 290))
		   #:font the-font
		   #:scale (vec2 2 2)
		   #:color (if (= menu-selection 2) yellow white))
	(draw-text "QUIT"
		   (vec2 250 (- window-top 350))
		   #:font the-font
		   #:scale (vec2 2 2)
		   #:color (if (= menu-selection 3) yellow white))))))

  
  (draw-sprite dash-7seg-background (vec2 270 0))
  (draw-sprite dash-7seg-background (vec2 324 0))
  (draw-text (format #f "~5,1,,,'0f" (distance-in-miles))
	     (vec2 275 20)
	     #:font font-7-segments
	     #:color red)
  (draw-text "MI"
	     (vec2 395 12)
	     #:font the-font
	     #:scale (vec2 2 2))

  
  (draw-sprite dash-7seg-background (vec2 450 0))
  (draw-sprite dash-7seg-background (vec2 503 0))
  (draw-text (format #f "~5,1,,,'0f" (speed-in-mph))
	     (vec2 455.0 20.0)
	     #:font font-7-segments
	     #:color red)
  (draw-text "MPH"
	     (vec2 570 12)
	     #:font the-font
	     #:scale (vec2 2 2))

  (draw-sprite dash-7seg-background (vec2 20 0))
  (draw-sprite dash-7seg-background (vec2 72 0))
  (draw-text (format #f "~5,1,,,'0f" player-time-travelled)
	     (vec2 25 20)
	     #:font font-7-segments
	     #:color red)
  (draw-text "TIME"
	     (vec2 142 12)
	     #:font the-font
	     #:scale (vec2 2 2))

  (if game-over?
      (if (game-won?)
	  (let ((player-score (+ 10000 (* (- 900 player-time-travelled) 1000))))
	    (draw-text "THE END" (vec2 260 (/ (window-width (current-window)) 2))
		       #:font the-font
		       #:scale (vec2 2 2))
	    (draw-text (format #f "SCORE: ~,0f" player-score)
		       (vec2 200 (- (/ (window-width (current-window)) 2) 25))
		       #:font the-font
		       #:scale (vec2 2 2))
	    (draw-text "TRY AGAIN" (vec2 230 (- (/ (window-width (current-window)) 2) 100))
		       #:font the-font
		       #:scale (vec2 2 2)
		       #:color yellow))
	  (begin
	    (draw-text "GAME OVER" (vec2 260 (/ (window-width (current-window)) 2))
		       #:font the-font
		       #:scale (vec2 2 2))
	    (draw-text "TRY AGAIN" (vec2 260 (- (/ (window-width (current-window)) 2) 25))
		       #:font the-font
		       #:scale (vec2 2 2)
		       #:color yellow)))))


(define (key-press key modifiers repeat?)
  (cond
   ((or (eq? key 'w) (eq? key 'up))
    (if game-started?
	(set! player-velocity (vec2 0 vehicle-steering-speed))
	(set! menu-selection (max 0 (- menu-selection 1)))))
   ((or (eq? key 's) (eq? key 'down))
    (if game-started?
	(set! player-velocity (vec2 0 (- vehicle-steering-speed)))
	(set! menu-selection (min (- (length menu-items) 1) (+ menu-selection 1)))))
   ((or (eq? key 'd) (eq? key 'right))
    (set! player-current-acceleration player-car-acceleration))
   ((or (eq? key 'a) (eq? key 'left))
    (set! player-current-acceleration player-car-deceleration))
   ((eq? key 'escape)
    (set! game-over? #f)
    (set! game-started? #f))
   ((and (eq? key 'return) game-over?)
    (reset-game!))
   ((and (eq? key 'return) (not game-started?))
    (cond
     (show-credits?
      (set! show-credits? #f))
     (show-help?
	 (set! show-help? #f))
     (else
      (cond
       ((= menu-selection 0)
	(reset-game!))
       ((= menu-selection 1)
	(set! show-credits? #t))
       ((= menu-selection 2)
	(set! show-help? #t))
       ((= menu-selection 3)
	(abort-game))))))))

(define (key-release key modifiers)
  (cond
   ((or (eq? key 'a)
	(eq? key 'd)
	(eq? key 'left)
	(eq? key 'right))
    (set! player-current-acceleration 0))
   ((or (eq? key 'w)
	(eq? key 's)
	(eq? key 'up)
	(eq? key 'down))
    (set! player-velocity (vec2 0 0)))))

(run-game #:window-title "Turbo Racer 3000"
	  #:load load
	  #:update update
	  #:draw draw
	  #:key-press key-press
	  #:key-release key-release)