bloatrunner/game/model/level.scm

(define-module (game model level)
  #:use-module (game util assets)
  #: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-cell-size
            level-find-hero
            level-find-goal
            level-find-others
            level-find-keys
            level-find-good-foods
            level-find-bad-foods
            level-tile-blocked?
            level-same-cell?
            coord->cell
            ))

(define-record-type <level>
  (%make-level width height tiles)
  level?
  (width level-width)
  (height level-height)
  (tiles level-tiles)
  (goal level-goal)
  (hero level-hero)
  (entities level-entities))

(define (parse-tile c)
  "Parse a character into a tile type"
  (case c
    ((#\W) 'wall)
    ((#\B) 'brick)
    ((#\H) 'ladder)
    ((#\P) 'hero)
    ((#\O) 'other)
    ((#\G) 'goal)
    ((#\K) 'key)
    ((#\F) 'bad-food)
    ((#\f) 'good-food)
    (else 'empty)))

(define (content->lines content)
  "Parse a string into a list of lines, ignoring empty lines and comments"
  (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)
  "Parse a list of lines into a list of tiles"
  (fold append
        '()
        (map
         (lambda (line)
           (map parse-tile (string->list line)))
         lines)))

(define (level-parse content)
  "Parse a level from a string"
  (let* ((lines (content->lines content))
         (width (string-length (car lines)))
         (height (length lines))
         (tiles (list->vector 
                 (parse-lines lines))))
    (%make-level width height tiles)))

(define (level-tile-at-row-col level row col )
  "Get the tile at a given row and column"
  (let ((index (+ (* row (level-width level)) col)))
    (vector-ref (level-tiles level) index)))

(define level-cell-size 16)

(define (coord->cell coord)
  "Convert a screen coordinate to a vector cell index"
  (inexact->exact (floor (/ coord level-cell-size))))

(define (level-tile-at level position )
  "Get the tile at a given screen position"
  (let ((x (vec2-x position))
        (y (vec2-y position)))
    (level-tile-at-row-col level (coord->cell y) (coord->cell x))))

(define (level-tile-blocked? level position)
  (memq (level-tile-at level position) '(wall brick)))

(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 (* level-cell-size (cadr rc)) (* level-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))

(define (level-find-keys level)
  (level-find-tile level 'key))

(define (level-find-good-foods level)
  (level-find-tile level 'good-food))

(define (level-find-bad-foods level)
  (level-find-tile level 'bad-food))

(define (level-same-cell? a b)
  (and (= (coord->cell (vec2-x a)) (coord->cell (vec2-x b)))
       (= (coord->cell (vec2-y a)) (coord->cell (vec2-y b)))))

;; 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 (parse-tile #\F) 'bad-food)
(test-equal (parse-tile #\f) 'good-food)

(test-equal (level-width (level-parse (read-level-map "level-001.map"))) 40)
(test-equal (level-height (level-parse (read-level-map "level-001.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")