(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-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 (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 (%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 (bytevector-u16-native-ref background (* i 2))) (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 '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 (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 (if collected-gem? (spawn ^ghost-gem x y) (spawn ^gem x y))) (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)))) (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)))))