166 lines
4.3 KiB
Scheme
166 lines
4.3 KiB
Scheme
(define-module (game model level)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 pretty-print)
|
|
#:use-module (ice-9 textual-ports)
|
|
#:use-module (chickadee math vector)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-9)
|
|
#:use-module (srfi srfi-64)
|
|
#:export (level-width
|
|
level-height
|
|
level-tiles
|
|
level-entities
|
|
level-hero
|
|
level-goal
|
|
level-parse-file
|
|
level-parse
|
|
level-tile-at
|
|
level-find-hero
|
|
))
|
|
|
|
(define-record-type <level>
|
|
(%make-level width height tiles goal hero entities)
|
|
level?
|
|
(width level-width)
|
|
(height level-height)
|
|
(tiles level-tiles)
|
|
(goal level-goal)
|
|
(hero level-hero)
|
|
(entities level-entities))
|
|
|
|
(define (parse-tile c)
|
|
(case c
|
|
((#\W) 'wall)
|
|
((#\B) 'brick)
|
|
((#\H) 'ladder)
|
|
((#\P) 'hero)
|
|
((#\O) 'other)
|
|
((#\G) 'goal)
|
|
(else 'empty)))
|
|
|
|
(define (content->lines content)
|
|
(filter (lambda (line) (not (string-null? line)))
|
|
(map
|
|
(lambda (line)
|
|
(string-trim-right
|
|
(car (string-split line #\-))
|
|
#\space))
|
|
(string-split content #\newline))))
|
|
|
|
|
|
(define (parse-lines lines)
|
|
(fold append
|
|
'()
|
|
(map
|
|
(lambda (line)
|
|
(map parse-tile (string->list line)))
|
|
lines)))
|
|
|
|
(define (level-parse content)
|
|
(let* ((lines (content->lines content))
|
|
(width (string-length (car lines)))
|
|
(height (length lines))
|
|
(tiles (list->vector
|
|
(parse-lines lines)))
|
|
(entities '()))
|
|
(%make-level width height tiles #f #f entities)))
|
|
|
|
(define (level-parse-file filename)
|
|
(level-parse (call-with-input-file filename get-string-all)))
|
|
|
|
|
|
(define (level-tile-at-row-col level row col )
|
|
(let ((index (+ (* row (level-width level)) col)))
|
|
(vector-ref (level-tiles level) index)))
|
|
|
|
(define cell-size 16)
|
|
|
|
(define (coord->cell coord)
|
|
(inexact->exact (floor (/ coord cell-size))))
|
|
|
|
(define (level-tile-at level x y )
|
|
(level-tile-at-row-col level (coord->cell y) (coord->cell x)))
|
|
|
|
(define (gen-coords a b)
|
|
(append-map
|
|
(lambda (r)
|
|
(map
|
|
(lambda (c)
|
|
(list r c))
|
|
(iota b)))
|
|
(iota a))
|
|
)
|
|
|
|
(define (level-find-tile level tile)
|
|
(map
|
|
(lambda (rc) (vec2 (* cell-size (cadr rc)) (* cell-size (car rc))))
|
|
(filter
|
|
(lambda (rc)
|
|
(equal?
|
|
(level-tile-at-row-col level (car rc) (cadr rc))
|
|
tile))
|
|
(gen-coords (level-height level) (level-width level)))))
|
|
|
|
(define (level-find-hero level)
|
|
(car (level-find-tile level 'hero)))
|
|
|
|
(define (level-find-goal level)
|
|
(car (level-find-tile level 'goal)))
|
|
|
|
(define (level-find-others level)
|
|
(level-find-tile level 'other))
|
|
|
|
;; Tests
|
|
(test-begin "level")
|
|
|
|
(test-equal (content->lines "WWWWW\nWP GW\nWWWWW\n") '("WWWWW" "WP GW" "WWWWW"))
|
|
|
|
(let ((level (level-parse "WWWWW\nWP GW\nWWWWW\n")))
|
|
(test-assert (level? level))
|
|
(test-equal (level-width level) 5)
|
|
(test-equal (level-height level) 3)
|
|
(test-equal
|
|
(level-tiles level)
|
|
#(wall wall wall wall wall wall hero empty goal wall wall wall wall wall wall)))
|
|
|
|
(test-equal "check if comments are ignored"
|
|
(level-tiles (level-parse "--- ignore this line\nWWWWW\nWP GW - must be ignored\nWWWWW\n"))
|
|
#(wall wall wall wall wall wall hero empty goal wall wall wall wall wall wall))
|
|
|
|
;; regression test for character parsing
|
|
(test-equal (parse-tile #\W) 'wall)
|
|
(test-equal (parse-tile #\B) 'brick)
|
|
(test-equal (parse-tile #\H) 'ladder)
|
|
(test-equal (parse-tile #\P) 'hero)
|
|
(test-equal (parse-tile #\O) 'other)
|
|
(test-equal (parse-tile #\G) 'goal)
|
|
(test-equal (parse-tile #\space) 'empty)
|
|
|
|
(test-equal (level-width (level-parse-file "assets/levels/level-1.map")) 40)
|
|
(test-equal (level-height (level-parse-file "assets/levels/level-1.map")) 30)
|
|
|
|
(test-equal
|
|
(level-tile-at-row-col (level-parse "WWWWW\nWP GW\nWWWWW\n") 1 1)
|
|
'hero)
|
|
|
|
(test-equal
|
|
(level-tile-at-row-col (level-parse "WWWWW\nWP GW\nWWWWW\n") 1 3)
|
|
'goal)
|
|
|
|
(test-equal (gen-coords 2 3) '((0 0) (0 1) (0 2) (1 0) (1 1) (1 2)))
|
|
|
|
(let ((level (level-parse "WWWWW\nWO OW\nWP GW\nWWWWW\n")))
|
|
(test-equal
|
|
(vec2 16 16)
|
|
(level-find-hero level))
|
|
|
|
(test-equal
|
|
(vec2 48 16)
|
|
(level-find-goal level))
|
|
|
|
(test-equal
|
|
(list (vec2 16 32) (vec2 48 32))
|
|
(level-find-others level))
|
|
)
|
|
|
|
(test-end "level")
|