foss-mmo/modules/game/level.scm

;;; 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.

(define-module (game level)
  #:use-module (game actors)
  #:use-module (goblins core)
  #:use-module (hoot bytevectors)
  #:use-module (ice-9 match)
  #:use-module (math vector)
  #:use-module (srfi srfi-9)
  #:export (tile-width
            tile-height

            <level-tile>
            level-tile?
            level-tile-position
            level-tile-id

            make-level
            level?
            level-background
            level-actor
            level-player))

(define tile-width 16.0)
(define tile-height 16.0)

(define-record-type <level-tile>
  (make-level-tile position id)
  level-tile?
  (position level-tile-position)
  (id level-tile-id))

;; Client-side rendering info coupled with level actor that contains
;; game state.
(define-record-type <level>
  (%make-level background actor player)
  level?
  (background level-background)
  (actor level-actor)
  (player level-player))

(define (make-level width height background objects collected-gem?)
  (let ((level* (spawn ^level width height))
        (background* (make-vector (* width height)))
        (direction->symbol
         (match-lambda
           (1 'right)
           (2 'left)
           (3 'up)
           (4 'down))))
    ;; Unpack background tile data.
    (let y-loop ((y 0))
      (when (< y height)
        (let x-loop ((x 0))
          (when (< x width)
            (let* ((i (+ (* y width) x))
                   (pos (vec2 (* x tile-width) (* y tile-height)))
                   (id (case (bytevector-u16-native-ref background (* i 2))
                         ((120) 81)
                         ((121) 82)
                         ((122) 85)
                         ((123) 105)
                         (else => (lambda (v) v))))
                   (tile (make-level-tile pos id)))
              (vector-set! background* i tile))
            (x-loop (1+ x))))
        (y-loop (1+ y))))
    ;; Unpack object data and spawn objects, making special
    ;; note of the player.
    (let lp ((i 0) (player #f))
      (if (< i (bytevector-length objects))
          (let* ((x (bytevector-u8-ref objects i))
                 (y (bytevector-u8-ref objects (+ i 1)))
                 (id (bytevector-u8-ref objects (+ i 2)))
                 (obj (match id
                        (1 (spawn ^wall x y 'inert))
                        (2 (spawn ^wall x y 'copper))
                        (3 (spawn ^player x y))
                        (4 (spawn ^exit x y))
                        (5 (spawn ^block x y 'copper))
                        (6 (spawn ^block x y 'crate))
                        (7 (spawn ^clock-emitter x y
                                  (bytevector-u8-ref objects (+ i 3))))
                        (8 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
                                 (target-y (bytevector-u8-ref objects (+ i 4))))
                             (spawn ^floor-switch x y target-x target-y)))
                        (9 (spawn ^gem x y collected-gem?))
                        (10 (spawn ^gate x y))
                        (11 (spawn ^and-gate x y
                                   (direction->symbol
                                    (bytevector-u8-ref objects (+ i 3)))))
                        (12 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
                                  (target-y (bytevector-u8-ref objects (+ i 4))))
                              (spawn ^electric-switch x y target-x target-y)))
                        (13 (spawn ^xor-gate x y
                                   (direction->symbol
                                    (bytevector-u8-ref objects (+ i 3)))))
                        (14 (let ((target-x (bytevector-u8-ref objects (+ i 3)))
                                  (target-y (bytevector-u8-ref objects (+ i 4))))
                              (spawn ^electron-warp x y target-x target-y)))
                        (15 (spawn ^or-gate x y
                                   (direction->symbol
                                    (bytevector-u8-ref objects (+ i 3)))))
                        (16 (spawn ^switched-emitter x y
                                   (bytevector-u8-ref objects (+ i 3))))
                        (17 (spawn ^bomb x y))
                        (18 (spawn ^brick x y))
                        (id (error "invalid level object" id))))
                 (i* (+ i (match id
                            ;; floor-switch
                            ;; electric-switch
                            ;; electron-warp
                            ((or 8 12 14) 5)
                            ;; clock-emitter
                            ;; logic gates
                            ;; switched-emitter
                            ((or 7 11 13 15 16) 4)
                            (_ 3)))))
            (when obj
              ($ level* 'add-object obj))
            (if (= id 3)                ; player-spawn
                (lp i* obj)
                (lp i* player)))
          (%make-level background* level* player)))))