foss-mmo/modules/game/level.scm

(define-module (game level)
  #:use-module (game actors)
  #:use-module (goblins core)
  #:use-module (hoot bytevectors)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-9)
  #:export (make-level
            level?
            level-background
            level-actor
            level-player))

;; 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 spawn-gem?)
  (let ((level* (spawn ^level width height))
        (len (bytevector-length objects)))
    ;; Parsed packed object data and spawn objects, making special
    ;; note of the player.
    (let lp ((i 0) (player #f))
      (if (< i len)
          (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 'brick))
                        (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 4))
                        (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 (and spawn-gem? (spawn ^gem x y)))
                        (10 (spawn ^gate x y))
                        (11 (spawn ^and-gate x y))
                        (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)))
                        (id (error "invalid level object" id))))
                 (i* (+ i (match id
                            ;; floor-switch or electric-switch
                            ((or 8 12) 5)
                            (_ 3)))))
            (when obj
              ($ level* 'add-object obj))
            (if (= id 3)               ; player-spawn
                (lp i* obj)
                (lp i* player)))
          (%make-level background level* player)))))