99 lines
3.9 KiB
Scheme
99 lines
3.9 KiB
Scheme
(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))))
|
|
;; 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 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 (if collected-gem?
|
|
(spawn ^ghost-gem x y)
|
|
(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)))
|
|
(13 (spawn ^xor-gate x y))
|
|
(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))
|
|
(16 (spawn ^switched-emitter x y 4))
|
|
(id (error "invalid level object" id))))
|
|
(i* (+ i (match id
|
|
;; floor-switch
|
|
;; electric-switch
|
|
;; electron-warp
|
|
((or 8 12 14) 5)
|
|
(_ 3)))))
|
|
(when obj
|
|
($ level* 'add-object obj))
|
|
(if (= id 3) ; player-spawn
|
|
(lp i* obj)
|
|
(lp i* player)))
|
|
(%make-level background* level* player)))))
|