;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; Example game showing off several common game programming things.
;;;
;;; Code:

(use-modules (dom canvas)
             (dom document)
             (dom element)
             (dom event)
             (dom image)
             (dom media)
             (dom window)
             (game actors)
             (game level)
             (game levels level-1)
             (game levels level-2)
             (game levels level-3)
             (game tileset)
             (goblins core)
             (hoot bytevectors)
             (hoot ffi)
             (hoot hashtables)
             (ice-9 match)
             (local-storage)
             (math)
             (math rect)
             (math vector))

(define game-width 320.0)
(define game-height 240.0)
(define tile-width 16.0)
(define tile-height 16.0)
(define level-width (inexact->exact (floor (/ game-width tile-width))))
(define level-height (inexact->exact (floor (/ game-height tile-height))))

(define *canvas-scale* 0.0)
(define *canvas-width* 0)
(define *canvas-height* 0)

;; Assets
(define tileset
  (make-tileset (make-image "assets/images/cirkoban.png")
                320 240
                (inexact->exact tile-width)
                (inexact->exact tile-height)))
(define* (load-sound-effect name #:key (volume 0.25))
  (let ((audio (make-audio (string-append "assets/sounds/" name ".wav"))))
    (set-media-volume! audio volume)
    audio))
(define audio:bump (load-sound-effect "bump"))
(define audio:push (load-sound-effect "push"))
(define audio:undo (load-sound-effect "undo"))
(define audio:no (load-sound-effect "no"))
(define audio:exit (load-sound-effect "exit"))
(define audio:pickup (load-sound-effect "pickup"))

;; Game state
(define *state* #f)

(define *actormap* (make-whactormap))
(define (call-with-goblins thunk)
  (actormap-churn-run! *actormap* thunk))
(define-syntax-rule (with-goblins body ...)
  (call-with-goblins (lambda () body ...)))

(define levels
  (vector
   load-level-1
   load-level-2
   load-level-3))
(define *level-idx* #f)
(define *gems* #f)
(define *level* #f)
;; Latest representation of all actors in level
(define *objects* #f)

(define *snapshots* '())
(define (clear-snapshots!)
  (set! *snapshots* '()))
(define (save-snapshot!)
  (set! *snapshots* (cons (copy-whactormap *actormap*) *snapshots*)))
(define (rollback-snapshot!)
  (match *snapshots*
    (() (media-play audio:no))
    ((snapshot . older-snapshots)
     (set! *actormap* snapshot)
     (set! *snapshots* older-snapshots)
     (media-play audio:undo))))

(define (sort lst <=)
  (match lst
    (() '())
    ((_) lst)
    ((pivot . rest)
     (let lp ((left '()) (right '()) (pivot pivot) (rest rest))
       (match rest
         (() (append (sort left <=) (list pivot) (sort right <=)))
         ((x . rest)
          (if (<= x pivot)
              (lp (append left (list x)) right pivot rest)
              (lp left (append right (list x)) pivot rest))))))))

(define (filter-map proc lst)
  (let lp ((lst lst))
    (match lst
      (() '())
      ((head . tail)
       (let ((head* (proc head)))
         (if head*
             (cons head* (lp tail))
             (lp tail)))))))

(define (update-objects!)
  (set! *objects*
        ;; Filter out the objects that are baked into the background
        ;; and thus do not need to be rendered repeatedly.  Then,
        ;; z-sort the list so we render in the correct order.
        ;; Finally, convert positions to vec2s for more efficient
        ;; rendering.
        (map (match-lambda
               ((type #(x y _) . properties)
                (pk 'obj `(,type ,(vec2 (* x tile-width) (* y tile-height)) ,@properties))))
             (sort (filter-map (match-lambda
                                 (((or 'wall 'exit) . _) #f)
                                 (desc desc))
                               ($ (level-actor *level*) 'describe))
                   (lambda (a b)
                     (match a
                       ((_ #(_ _ az) . _)
                        (match b
                          ((_ #(_ _ bz) . _)
                           (<= az bz))))))))))

(define (collected-gem? idx)
 (not (memq idx *gems*)))

(define (load-level! idx)
  (set! *state* 'play)
  (set! *actormap* (make-whactormap))
  (clear-snapshots!)
  (with-goblins
   (set! *level* ((vector-ref levels idx) (collected-gem? idx)))
   (update-objects!)))

(define (next-level!)
  (let ((idx (+ *level-idx* 1)))
    (pk 'next-level idx)
    (set! *level-idx* idx)
    (if (< idx (vector-length levels))
        (begin
          (save-game!)
          (load-level! idx))
        (set! *state* 'win))))

;; Auto-save/load to local storage.
(define (save-game!)
  (pk 'save)
  (local-storage-set! "cirkoban-save"
                      (call-with-output-string
                        (lambda (port)
                          (write (list *level-idx* *gems*) port)))))

(define (load-game!)
  (let ((saved
         (match (local-storage-ref "cirkoban-save")
           ("" '(0 ())) ; initial save state
           (str (call-with-input-string str read)))))
    (match saved
      ((idx gems)
       (set! *level-idx* idx)
       (set! *gems* gems)
       (pk 'load *level-idx*)
       (load-level! *level-idx*)))))

(define (reset-game!)
  (set! *level-idx* 0)
  (save-game!)
  (load-level! 0))

;; Update loop
(define (move-player dir)
  (define (do-move)
    (with-goblins
     ($ (level-player *level*) 'move dir)
     ($ (level-actor *level*) 'tick)
     (define result
       (match ($ (level-player *level*) 'event)
         (('bump)
          (media-play audio:bump)
          #f)
         (('push)
          (media-play audio:push)
          #f)
         (('exit)
          (media-play audio:exit)
          'next-level)
         (('gem)
          (media-play audio:pickup)
          ;; TODO: Maybe show a little achievement popup when all gems
          ;; are collected?
          (set! *gems* (cons *level-idx* *gems*))
          #f)
         (_ #f)))
     (update-objects!)
     result))
  (save-snapshot!)
  (when (eq? (do-move) 'next-level)
    (next-level!)))

(define dt (/ 1000.0 60.0)) ; aim for updating at 60Hz
(define (update)
  ;; TODO: what kind of work do we need to do each frame?
  (timeout update-callback dt))
(define update-callback (procedure->external update))

;; Render loop
(define number->string*
  (let ((cache (make-eq-hashtable))) ; assuming fixnums only
    (lambda (x)
      (or (hashtable-ref cache x)
          (let ((str (number->string x)))
            (hashtable-set! cache x str)
            str)))))

(define (draw-player pos)
  (draw-tile context tileset 0 (vec2-x pos) (vec2-y pos)))

(define (draw-exit pos)
  (draw-tile context tileset 27 (vec2-x pos) (vec2-y pos)))

(define (draw-wall type pos)
  (let ((x (vec2-x pos))
        (y (vec2-y pos)))
    (match type
      ('brick
       (draw-tile context tileset 22 x y))
      (_
       (draw-tile context tileset 2 x y)))
    (match type
      ('electron-head
       (draw-tile context tileset 4 x y))
      ('electron-tail
       (draw-tile context tileset 5 x y))
      (_ #f))))

(define (draw-block type pos)
  (let ((x (vec2-x pos))
        (y (vec2-y pos)))
    (match type
      ('crate (draw-tile context tileset 29 x y))
      (_ (draw-tile context tileset 3 x y)))
    (match type
      ('electron-head
       (draw-tile context tileset 4 x y))
      ('electron-tail
       (draw-tile context tileset 5 x y))
      (_ #f))))

(define (draw-clock-emitter pos)
  (draw-tile context tileset 48 (vec2-x pos) (vec2-y pos)))

(define (draw-floor-switch pos on?)
  (draw-tile context tileset (if on? 25 24) (vec2-x pos) (vec2-y pos)))

(define (draw-gem pos)
  (draw-tile context tileset 28 (vec2-x pos) (vec2-y pos)))

(define (draw-gate pos open?)
  (draw-tile context tileset (if open? 46 45) (vec2-x pos) (vec2-y pos)))

(define (draw-object obj)
  (match obj
    (#f #f)
    (('player pos) (draw-player pos))
    ;; Wall and exit tiles are baked into the background layer.
    (('exit pos) #t)
    (('wall pos type) #t)
    (('block pos type) (draw-block type pos))
    (('clock-emitter pos) (draw-clock-emitter pos))
    (('floor-switch pos on?) (draw-floor-switch pos on?))
    (('gem pos) (draw-gem pos))
    (('gate pos open?) (draw-gate pos open?))))

(define (draw-background)
  (let* ((bv (level-background *level*))
         (len (bytevector-length bv)))
    (let lp ((i 0))
      (when (< i len)
        (let ((x (bytevector-ieee-single-native-ref bv i))
              (y (bytevector-ieee-single-native-ref bv (+ i 4)))
              (idx (bytevector-u16-native-ref bv (+ i 8))))
          (draw-tile context tileset idx x y)
          (lp (+ i 10)))))))

(define (draw-level)
  (draw-background)
  (for-each draw-object *objects*))

(define (draw-win)
  (set-fill-color! context "#x000000")
  (fill-text context "OMG YOU DID IT WOW CONGRATS" 32.0 120.0))

(define (draw prev-time)
  (clear-rect context 0.0 0.0 *canvas-width* *canvas-height*)
  (set-transform! context 1.0 0.0 0.0 1.0 0.0 0.0)
  (set-scale! context *canvas-scale* *canvas-scale*)
  (match *state*
    ('play (draw-level))
    ('win (draw-win)))
  (request-animation-frame draw-callback))
(define draw-callback (procedure->external draw))

;; Input
(define key:left "ArrowLeft")
(define key:right "ArrowRight")
(define key:down "ArrowDown")
(define key:up "ArrowUp")
(define key:confirm "Enter")
(define key:undo "KeyZ")

(define (on-key-down event)
  (let ((key (keyboard-event-code event)))
    (pk 'key-down key)
    (match *state*
      ('play
       (cond
        ((string=? key key:left)
         (move-player 'left))
        ((string=? key key:right)
         (move-player 'right))
        ((string=? key key:up)
         (move-player 'up))
        ((string=? key key:down)
         (move-player 'down))
        ((string=? key key:undo)
         (rollback-snapshot!)
         (with-goblins (update-objects!)))
        ;; REMOVE BEFORE RELEASE!!!!
        ((string=? key key:confirm)
         (next-level!))))
      ('win
       (cond
        ((string=? key key:confirm)
         (reset-game!)))))))

;; Canvas and event loop setup
(define canvas (get-element-by-id "canvas"))
(define context (get-context canvas "2d"))

(define (resize-canvas)
  (let* ((win (current-window))
         (w (window-inner-width win))
         (h (window-inner-height win))
         (gw (inexact->exact game-width))
         (gh (inexact->exact game-height))
         (scale (max (min (quotient w gw) (quotient h gh)) 1))
         (cw (* gw scale))
         (ch (* gh scale)))
    (set-element-width! canvas cw)
    (set-element-height! canvas ch)
    (set-image-smoothing-enabled! context 0)
    (set! *canvas-scale* (exact->inexact scale))
    (set! *canvas-width* (* game-width *canvas-scale*))
    (set! *canvas-height* (* game-height *canvas-scale*))
    (pk 'resize-canvas *canvas-scale* *canvas-width* *canvas-height*)))

(set-element-width! canvas (inexact->exact game-width))
(set-element-height! canvas (inexact->exact game-height))
(add-event-listener! (current-window) "resize"
                     (procedure->external (lambda (_) (resize-canvas))))
(add-event-listener! (current-document) "keydown"
                     (procedure->external on-key-down))
(resize-canvas)
(request-animation-frame draw-callback)
(timeout update-callback dt)
(load-game!)