diff options
| -rw-r--r-- | Makefile | 18 | ||||
| -rw-r--r-- | src/game.scm | 62 | ||||
| -rw-r--r-- | src/tilemap.scm | 390 |
3 files changed, 263 insertions, 207 deletions
@@ -1,13 +1,19 @@ -bin/game: bin bin/tilemap.o - csc -o bin/game bin/tilemap.o -uses tilemap src/game.scm +.DEFAULT_GOAL := bin/game bin: - mkdir bin + @mkdir -p $@ -bin/tilemap.o: bin src/tilemap.scm - csc -c -J src/tilemap.scm -unit tilemap -o bin/tilemap.o +bin/tilemap.o: src/tilemap.scm | bin + csc -c -J src/tilemap.scm -unit tilemap -o $@ -.PHONY: +bin/game.o: src/game.scm | bin + csc -c src/game.scm -uses tilemap -o $@ + +bin/game: bin/tilemap.o bin/game.o | bin + csc -o bin/game bin/tilemap.o bin/game.o + + +.PHONY: clean clean: rm -rf bin rm -f *.import.scm game diff --git a/src/game.scm b/src/game.scm index 2e3f6ee..4206533 100644 --- a/src/game.scm +++ b/src/game.scm @@ -8,8 +8,9 @@ (srfi 12) miscmacros (prefix sdl2 "sdl2:") - (prefix sdl2-ttf "ttf:") + (prefix sdl2-ttf "ttf:") (prefix sdl2-image "img:") + matchable tilemap) (define +color-depth+ 32) @@ -39,9 +40,9 @@ (if (and +vsync?+ (not +software-mode?+)) ; vsync doesn't work with software rendering (sdl2:set-hint! 'render-vsync "1")) (define *window* (sdl2:create-window! "MacroKnight" - 'centered 'centered - +screen-width+ +screen-height+ - (if *fullscreen?* '(fullscreen) '()))) + 'centered 'centered + +screen-width+ +screen-height+ + (if *fullscreen?* '(fullscreen) '()))) (define *renderer* (handle-exceptions exn @@ -59,9 +60,9 @@ (define *level* (load-tilemap "assets/level-0.tmx")) (define *level-tileset-texture* (sdl2:create-texture-from-surface *renderer* (tileset-image (tilemap-tileset *level*)))) -(define (draw-tile target tileset tile-id row-num col-num) +(define (draw-tile renderer tileset tile-id row-num col-num) (let ((tile (tileset-tile tileset tile-id))) - (sdl2:render-copy! *renderer* *level-tileset-texture* + (sdl2:render-copy! renderer *level-tileset-texture* (tile-rect tile) (sdl2:make-rect (* col-num (tileset-tileheight tileset)) (* row-num (tileset-tilewidth tileset)) @@ -75,37 +76,72 @@ (iota (length (car rows)))) (draw-tilemap-rows draw-fn (cdr rows) (+ row-num 1)))) -(define (draw-tilemap target tilemap) - (let ((map-layer (layer-map (list-ref (tilemap-layers tilemap) 0))) +(define (draw-tilemap renderer tilemap) + (let ((map-layer (layer-map (car (tilemap-layers tilemap)))) (tileset (tilemap-tileset tilemap))) (draw-tilemap-rows - (lambda (tile-id row-num col-num) (draw-tile target tileset tile-id row-num col-num)) + (lambda (tile-id row-num col-num) (draw-tile renderer tileset tile-id row-num col-num)) map-layer 0))) +(define (draw-objects renderer tilemap) + (let ((objects (tilemap-objects tilemap)) + (tileset (tilemap-tileset tilemap))) + (for-each + (cut draw-object renderer tileset <>) + objects))) + +(define (draw-object renderer tileset object) + (match (object-type object) + ("Player" (draw-player renderer tileset object)) + ("Text" (draw-text renderer tileset object)) + ("Enemy" (draw-enemy renderer tileset object)) + (_ #f))) + +(define (draw-player renderer tileset object) + (let ((col-num (inexact->exact (floor (/ (object-x object) (tileset-tilewidth tileset))))) + (row-num (inexact->exact (floor (/ (object-y object) (tileset-tileheight tileset)))))) + (draw-tile renderer tileset 29 row-num col-num))) + +(define (draw-text renderer tileset object) + (let* ((text (cdr (assoc "text" (object-properties object)))) + (text-texture (sdl2:create-texture-from-surface renderer + (ttf:render-text-solid *font* text *text-color*)))) + (sdl2:render-copy! renderer text-texture #f (sdl2:make-rect + (inexact->exact (floor (object-x object))) + (inexact->exact (floor (object-y object))) + (inexact->exact (floor (object-width object))) + (inexact->exact (floor (object-height object))))))) + +(define (draw-enemy renderer tileset object) + (let ((col-num (inexact->exact (floor (/ (object-x object) (tileset-tilewidth tileset))))) + (row-num (inexact->exact (floor (/ (object-y object) (tileset-tileheight tileset)))))) + (draw-tile renderer tileset 111 row-num col-num))) + (set! (sdl2:render-draw-color *renderer*) +background-color+) (sdl2:render-clear! *renderer*) (let/cc exit-main-loop! (while #t (set! (sdl2:render-draw-color *renderer*) +background-color+) - (sdl2:render-clear! *renderer*) + (sdl2:render-clear! *renderer*) (sdl2:pump-events!) (while (sdl2:has-events?) (let ((event (sdl2:make-event))) (sdl2:poll-event! event) - (pp event) + ;; (pp event) (when (and (sdl2:keyboard-event? event) (eq? (sdl2:event-type event) 'key-down) (eq? (sdl2:keyboard-event-sym event) 'escape)) (exit-main-loop!)))) (draw-tilemap *renderer* *level*) - + + (draw-objects *renderer* *level*) + (sdl2:render-present! *renderer*) (sdl2:delay! 10))) (sdl2:joystick-close *joystick*) (format #t "Bye!\n") - diff --git a/src/tilemap.scm b/src/tilemap.scm index 6f6c3ef..3fa9ace 100644 --- a/src/tilemap.scm +++ b/src/tilemap.scm @@ -1,192 +1,207 @@ (module tilemap -* -(import scheme - (chicken io) - (chicken base) - (chicken string) - (chicken format) - (chicken process-context) - (chicken pathname) - (chicken pretty-print) - (srfi 1) - expat - defstruct - (prefix sdl2-image "img:") - (prefix sdl2 "sdl2:")) - -(defstruct tileset - tilewidth - tileheight - spacing - tilecount - columns - image-source - image) - -(defstruct layer - name - width - height - map) - -(defstruct object - name - type - x - y - width - height - properties) - -(defstruct tilemap - width - height - tilewidth - tileheight - tileset-source - tileset - layers - objects) - -(defstruct tile - id - rect) - -(define (maybe-do action) - (lambda (value) - (if (eq? value #f) - #f - (action value)))) - -(define (attempt action) - (lambda (value) - (or (action value) value))) - -(define maybe-string->number (maybe-do (attempt string->number))) - -(define (string-alist->alist string-alist) - (map (lambda (pair) (cons (string->symbol (car pair)) - (maybe-string->number (cdr pair)))) - string-alist)) - -(define (parse-tileset string-tileset) - (let ((parser (expat:make-parser)) - (tags '()) - (tileset (make-tileset 0 0 0 0 0 ""))) - (expat:set-start-handler! parser - (lambda (tag attrs) - (let ((symbol-attrs (string-alist->alist attrs))) - (cond ((string=? tag "tileset") - (set! tileset (alist->tileset symbol-attrs))) - ((string=? tag "image") - (tileset-image-source-set! tileset (alist-ref 'source symbol-attrs))))) - (set! tags (cons tag tags)))) - (expat:set-end-handler! parser (lambda (tag) - (set! tags (cdr tags)))) - (expat:set-character-data-handler! parser (lambda (line) #f)) - (expat:parse parser string-tileset) - tileset)) - -(define (load-tileset file-name) - (call-with-input-file file-name - (lambda (port) - (let* ((tileset (parse-tileset (read-string #f port))) - (image-source (tileset-image-source tileset)) - (base-path (pathname-directory file-name)) - (img-to-load (if (absolute-pathname? image-source) - image-source - (pathname-replace-directory - image-source - (if (pathname-directory image-source) - (format "~a/~a" base-path (pathname-directory image-source)) - base-path))))) - (tileset-image-set! tileset (img:load img-to-load)) - tileset)))) - -(define (parse-tilemap string-tilemap) - (let ((parser (expat:make-parser)) - (tags '()) - (tilemap (make-tilemap 0 0 0 0 '() '() '())) - (layer '())) - (expat:set-start-handler! parser - (lambda (tag attrs) - (let ((symbol-attrs (string-alist->alist attrs))) - (cond ((string=? tag "map") - (tilemap-width-set! tilemap (alist-ref 'width symbol-attrs)) - (tilemap-height-set! tilemap (alist-ref 'height symbol-attrs)) - (tilemap-tilewidth-set! tilemap (alist-ref 'tilewidth symbol-attrs)) - (tilemap-tileheight-set! tilemap (alist-ref 'tileheight symbol-attrs))) - ((string=? tag "tileset") - (tilemap-tileset-source-set! tilemap (alist-ref 'source symbol-attrs))) - ((string=? tag "layer") - (set! layer (alist->layer attrs))) - ((string=? tag "object") - (tilemap-objects-set! tilemap (cons (alist->object symbol-attrs) - (tilemap-objects tilemap))))) - (set! tags (cons tag tags))))) - (expat:set-end-handler! parser (lambda (tag) - (when (string=? tag "layer") - (tilemap-layers-set! tilemap - (cons layer (tilemap-layers tilemap))) - (set! layer '())) - (set! tags (cdr tags)))) - (expat:set-character-data-handler! parser (lambda (line) - (when (string=? (car tags) "data") - (let ((txt (string-chomp line))) - (when (not (string=? txt "")) - (layer-map-set! layer (append - (or (layer-map layer) '()) - (list (map string->number - (string-split txt ",")))))))))) - (expat:parse parser string-tilemap) - tilemap)) - -(define (tileset-rows tileset) - "Return the number of rows in the tileset" - (inexact->exact (ceiling (/ (tileset-tilecount tileset) (tileset-columns tileset))))) - -(define (tileset-tile tileset tile-id) - ;; Use the tileset's columns setting and the tileheight/tilewidth to - ;; find the tile's x,y location and create a rect - (let* ((tile-num (- tile-id 1)) ; tile-id starts at 1! - (tile-width (tileset-tilewidth tileset)) - (tile-height (tileset-tileheight tileset)) - (tile-x (modulo tile-num (tileset-columns tileset))) - (tile-y (inexact->exact (floor (/ tile-num (tileset-columns tileset))))) - (x (+ (* tile-x tile-width) tile-x)) - (y (+ (* tile-y tile-height) tile-y))) - (pp (list tile-x tile-y x y)) - (make-tile - id: tile-id - rect: (sdl2:make-rect x y tile-width tile-height)))) - -(define (load-tilemap file-name) - (call-with-input-file file-name - (lambda (port) - (let* ((tilemap (parse-tilemap (read-string #f port))) - (base-path (pathname-directory file-name)) - (tileset-source (tilemap-tileset-source tilemap))) - (tilemap-tileset-set! tilemap (load-tileset - (if (absolute-pathname? tileset-source) - tileset-source - (pathname-replace-directory - tileset-source - (if (pathname-directory tileset-source) - (format "~a/~a" base-path (pathname-directory tileset-source)) - base-path)) - ))) - tilemap)))) - -(when #f - - (let ((txt "<?xml version='1.0' encoding='UTF-8'?> + * + (import scheme + (chicken io) + (chicken base) + (chicken string) + (chicken format) + (chicken process-context) + (chicken pathname) + (chicken pretty-print) + (srfi 1) + matchable + expat + defstruct + (prefix sdl2-image "img:") + (prefix sdl2 "sdl2:")) + + (defstruct tileset + tilewidth + tileheight + spacing + tilecount + columns + image-source + image) + + (defstruct layer + name + width + height + map) + + (defstruct object + name + type + x + y + width + height + properties) + + (defstruct tilemap + width + height + tilewidth + tileheight + tileset-source + tileset + layers + objects) + + (defstruct tile + id + rect) + + (define (maybe-do action) + (lambda (value) + (if (eq? value #f) + #f + (action value)))) + + (define (attempt action) + (lambda (value) + (or (action value) value))) + + (define maybe-string->number (maybe-do (attempt string->number))) + + (define (string-alist->alist string-alist) + (map (lambda (pair) (cons (string->symbol (car pair)) + (maybe-string->number (cdr pair)))) + string-alist)) + + (define (parse-tileset string-tileset) + (let ((parser (expat:make-parser)) + (tags '()) + (tileset (make-tileset 0 0 0 0 0 ""))) + (expat:set-start-handler! parser + (lambda (tag attrs) + (let ((symbol-attrs (string-alist->alist attrs))) + (match tag + ("tileset" (set! tileset (alist->tileset symbol-attrs))) + ("image" (tileset-image-source-set! tileset (alist-ref 'source symbol-attrs))) + (_ #f))) + (set! tags (cons tag tags)))) + (expat:set-end-handler! parser (lambda (tag) + (set! tags (cdr tags)))) + (expat:set-character-data-handler! parser (lambda (line) #f)) + (expat:parse parser string-tileset) + tileset)) + + (define (load-tileset file-name) + (call-with-input-file file-name + (lambda (port) + (let* ((tileset (parse-tileset (read-string #f port))) + (image-source (tileset-image-source tileset)) + (base-path (pathname-directory file-name)) + (img-to-load (if (absolute-pathname? image-source) + image-source + (pathname-replace-directory + image-source + (if (pathname-directory image-source) + (format "~a/~a" base-path (pathname-directory image-source)) + base-path))))) + (tileset-image-set! tileset (img:load img-to-load)) + tileset)))) + + (define (parse-tilemap string-tilemap) + (let ((parser (expat:make-parser)) + (tags '()) + (tilemap (make-tilemap 0 0 0 0 '() '() '())) + (layer '()) + (object '())) + (expat:set-start-handler! + parser + (lambda (tag attrs) + (let ((symbol-attrs (string-alist->alist attrs))) + (match tag + ("map" + (tilemap-width-set! tilemap (alist-ref 'width symbol-attrs)) + (tilemap-height-set! tilemap (alist-ref 'height symbol-attrs)) + (tilemap-tilewidth-set! tilemap (alist-ref 'tilewidth symbol-attrs)) + (tilemap-tileheight-set! tilemap (alist-ref 'tileheight symbol-attrs))) + ("tileset" + (tilemap-tileset-source-set! tilemap (alist-ref 'source symbol-attrs))) + ("layer" + (set! layer (alist->layer attrs))) + ("object" + (set! object (alist->object symbol-attrs))) + ("property" + (object-properties-set! + object + (cons (cons (alist-ref 'name symbol-attrs) (alist-ref 'value symbol-attrs)) + (or (object-properties object) '())))) + (_ #f)) + (set! tags (cons tag tags))))) + (expat:set-end-handler! + parser + (lambda (tag) + (match tag + ("layer" (begin + (tilemap-layers-set! tilemap + (cons layer (tilemap-layers tilemap))) + (set! layer '()))) + ("object" (tilemap-objects-set! tilemap (cons object (tilemap-objects tilemap)))) + (_ #f)) + (set! tags (cdr tags)))) + (expat:set-character-data-handler! + parser + (lambda (line) + (when (string=? (car tags) "data") + (let ((txt (string-chomp line))) + (when (not (string=? txt "")) + (layer-map-set! layer (append + (or (layer-map layer) '()) + (list (map string->number + (string-split txt ",")))))))))) + (expat:parse parser string-tilemap) + tilemap)) + + (define (tileset-rows tileset) + "Return the number of rows in the tileset" + (inexact->exact (ceiling (/ (tileset-tilecount tileset) (tileset-columns tileset))))) + + (define (tileset-tile tileset tile-id) + ;; Use the tileset's columns setting and the tileheight/tilewidth to + ;; find the tile's x,y location and create a rect + (let* ((tile-num (- tile-id 1)) ; tile-id starts at 1! + (tile-width (tileset-tilewidth tileset)) + (tile-height (tileset-tileheight tileset)) + (tile-x (modulo tile-num (tileset-columns tileset))) + (tile-y (inexact->exact (floor (/ tile-num (tileset-columns tileset))))) + (x (+ (* tile-x tile-width) tile-x)) + (y (+ (* tile-y tile-height) tile-y))) + (make-tile + id: tile-id + rect: (sdl2:make-rect x y tile-width tile-height)))) + + (define (load-tilemap file-name) + (call-with-input-file file-name + (lambda (port) + (let* ((tilemap (parse-tilemap (read-string #f port))) + (base-path (pathname-directory file-name)) + (tileset-source (tilemap-tileset-source tilemap))) + (tilemap-tileset-set! tilemap (load-tileset + (if (absolute-pathname? tileset-source) + tileset-source + (pathname-replace-directory + tileset-source + (if (pathname-directory tileset-source) + (format "~a/~a" base-path (pathname-directory tileset-source)) + base-path)) + ))) + tilemap)))) + + (when #f + + (let ((txt "<?xml version='1.0' encoding='UTF-8'?> <tileset version='1.10' tiledversion='1.11.2' name='monochrome_transparent' tilewidth='16' tileheight='16' spacing='1' tilecount='1078' columns='49'> <image source='monochrome-transparent.png' width='832' height='373'/> </tileset> ")) - (tileset-image (parse-tileset txt))) + (tileset-image (parse-tileset txt))) - (let ((txt "<?xml version='1.0' encoding='UTF-8'?> + (let ((txt "<?xml version='1.0' encoding='UTF-8'?> <map version='1.10' tiledversion='1.11.0' orientation='orthogonal' renderorder='right-down' width='40' height='30' tilewidth='16' tileheight='16' infinite='0' nextlayerid='8' nextobjectid='5'> <tileset firstgid='1' source='monochrome_transparent.tsx'/> <layer id='3' name='ground' width='40' height='30'> @@ -206,12 +221,11 @@ </objectgroup> </map> ")) - (tilemap-tileset (parse-tilemap txt))) + (tilemap-tileset (parse-tilemap txt))) - (tileset-image (tilemap-tileset (load-tilemap "assets/level-0.tmx"))) - ) + (tileset-image (tilemap-tileset (load-tilemap "assets/level-0.tmx"))) + ) -) ;; End tilemap module - + ) ;; End tilemap module |