diff options
Diffstat (limited to 'world.scm')
| -rw-r--r-- | world.scm | 208 |
1 files changed, 104 insertions, 104 deletions
@@ -1,121 +1,121 @@ (module downstroke-world - * - (import scheme - (chicken base) - (only srfi-1 fold filter) - defstruct - downstroke-tilemap - downstroke-entity) - ;; Scene = current level: tilemap (layers, objects) + list of entities. +* +(import scheme + (chicken base) + (only srfi-1 fold filter) + defstruct + downstroke-tilemap + downstroke-entity) +;; Scene = current level: tilemap (layers, objects) + list of entities. - ;; Returns tile-id if the cell at (col, row) in this layer is non-zero, #f otherwise. - (define (layer-tile-at layer col row) - (let ((rows (layer-map layer))) - (and (< row (length rows)) - (let ((row-data (list-ref rows row))) - (and (< col (length row-data)) - (let ((tile-id (list-ref row-data col))) - (and (not (zero? tile-id)) tile-id))))))) +;; Returns tile-id if the cell at (col, row) in this layer is non-zero, #f otherwise. +(define (layer-tile-at layer col row) + (let ((rows (layer-map layer))) + (and (< row (length rows)) + (let ((row-data (list-ref rows row))) + (and (< col (length row-data)) + (let ((tile-id (list-ref row-data col))) + (and (not (zero? tile-id)) tile-id))))))) - (define (tilemap-tile-at tilemap col row) - "Get the tile ID at grid position (col, row). +(define (tilemap-tile-at tilemap col row) + "Get the tile ID at grid position (col, row). Returns 0 if out of bounds or if all layers have 0 at that cell." - (let ((width (tilemap-width tilemap)) - (height (tilemap-height tilemap))) - (if (or (< col 0) (>= col width) (< row 0) (>= row height)) - 0 - (let loop ((layers (tilemap-layers tilemap))) - (if (null? layers) - 0 - (or (layer-tile-at (car layers) col row) - (loop (cdr layers)))))))) + (let ((width (tilemap-width tilemap)) + (height (tilemap-height tilemap))) + (if (or (< col 0) (>= col width) (< row 0) (>= row height)) + 0 + (let loop ((layers (tilemap-layers tilemap))) + (if (null? layers) + 0 + (or (layer-tile-at (car layers) col row) + (loop (cdr layers)))))))) - (defstruct camera x y) +(defstruct camera x y) - (defstruct scene - entities - tilemap - tileset ; optional tileset struct when ~tilemap~ is ~#f~ (see renderer) - camera - tileset-texture - camera-target ; symbol tag or #f - background ; #f or (r g b) / (r g b a) for framebuffer clear - engine-update) ; #f = inherit from game, procedure = per-scene override +(defstruct scene + entities + tilemap + tileset ; optional tileset struct when ~tilemap~ is ~#f~ (see renderer) + camera + tileset-texture + camera-target ; symbol tag or #f + background ; #f or (r g b) / (r g b a) for framebuffer clear + engine-update) ; #f = inherit from game, procedure = per-scene override - (define (scene-add-entity scene entity) - (update-scene scene - entities: (append (scene-entities scene) (list entity)))) +(define (scene-add-entity scene entity) + (update-scene scene + entities: (append (scene-entities scene) (list entity)))) - (define (scene-map-entities scene . procs) - "Apply each proc in sequence to the scene's entities; returns a new scene." - (update-scene scene - entities: (fold - (lambda (proc es) - (map (cut proc scene <>) es)) - (scene-entities scene) - procs))) +(define (scene-map-entities scene . procs) + "Apply each proc in sequence to the scene's entities; returns a new scene." + (update-scene scene + entities: (fold + (lambda (proc es) + (map (cut proc scene <>) es)) + (scene-entities scene) + procs))) - (define (scene-filter-entities scene pred) - "Keep only entities satisfying pred; returns a new scene." - (update-scene scene - entities: (filter pred (scene-entities scene)))) +(define (scene-filter-entities scene pred) + "Keep only entities satisfying pred; returns a new scene." + (update-scene scene + entities: (filter pred (scene-entities scene)))) - (define (scene-transform-entities scene proc) - "Apply proc to the full entity list (entities → entities); returns a new scene." - (update-scene scene - entities: (proc (scene-entities scene)))) +(define (scene-transform-entities scene proc) + "Apply proc to the full entity list (entities → entities); returns a new scene." + (update-scene scene + entities: (proc (scene-entities scene)))) - ;; Center camera on entity. Clamps to >= 0 on both axes. - ;; Returns a new camera struct. - (define (camera-follow camera entity viewport-w viewport-h) - (let* ((entity-x (entity-ref entity #:x 0)) - (entity-y (entity-ref entity #:y 0))) - (update-camera camera - x: (inexact->exact (floor (max 0 (- entity-x (/ viewport-w 2))))) - y: (inexact->exact (floor (max 0 (- entity-y (/ viewport-h 2)))))))) +;; Center camera on entity. Clamps to >= 0 on both axes. +;; Returns a new camera struct. +(define (camera-follow camera entity viewport-w viewport-h) + (let* ((entity-x (entity-ref entity #:x 0)) + (entity-y (entity-ref entity #:y 0))) + (update-camera camera + x: (inexact->exact (floor (max 0 (- entity-x (/ viewport-w 2))))) + y: (inexact->exact (floor (max 0 (- entity-y (/ viewport-h 2)))))))) - ;; Returns the first entity in scene whose #:tags list contains tag, or #f. - (define (scene-find-tagged scene tag) - (let loop ((entities (scene-entities scene))) - (cond - ((null? entities) #f) - ((member tag (entity-ref (car entities) #:tags '())) (car entities)) - (else (loop (cdr entities)))))) +;; Returns the first entity in scene whose #:tags list contains tag, or #f. +(define (scene-find-tagged scene tag) + (let loop ((entities (scene-entities scene))) + (cond + ((null? entities) #f) + ((member tag (entity-ref (car entities) #:tags '())) (car entities)) + (else (loop (cdr entities)))))) - ;; Returns all entities in scene whose #:tags list contains tag. - (define (scene-find-all-tagged scene tag) - (filter (lambda (e) (member tag (entity-ref e #:tags '()))) - (scene-entities scene))) +;; Returns all entities in scene whose #:tags list contains tag. +(define (scene-find-all-tagged scene tag) + (filter (lambda (e) (member tag (entity-ref e #:tags '()))) + (scene-entities scene))) - ;; First wins: one origin entity per #:group-id (for lookup). - (define (group-origin-alist entities) - (let loop ((es entities) (acc '())) - (if (null? es) - acc - (let ((e (car es))) - (if (and (entity-ref e #:group-origin? #f) - (entity-ref e #:group-id #f)) - (let ((gid (entity-ref e #:group-id))) - (if (assq gid acc) - (loop (cdr es) acc) - (loop (cdr es) (cons (cons gid e) acc)))) - (loop (cdr es) acc)))))) +;; First wins: one origin entity per #:group-id (for lookup). +(define (group-origin-alist entities) + (let loop ((es entities) (acc '())) + (if (null? es) + acc + (let ((e (car es))) + (if (and (entity-ref e #:group-origin? #f) + (entity-ref e #:group-id #f)) + (let ((gid (entity-ref e #:group-id))) + (if (assq gid acc) + (loop (cdr es) acc) + (loop (cdr es) (cons (cons gid e) acc)))) + (loop (cdr es) acc)))))) - (define (sync-member-to-origin e origins) - (let* ((gid (entity-ref e #:group-id #f)) - (o (and gid (not (entity-ref e #:group-origin? #f)) - (assq gid origins)))) - (if o - (let ((origin (cdr o))) - (entity-set (entity-set e #:x (+ (entity-ref origin #:x 0) - (entity-ref e #:group-local-x 0))) - #:y (+ (entity-ref origin #:y 0) - (entity-ref e #:group-local-y 0)))) - e))) +(define (sync-member-to-origin e origins) + (let* ((gid (entity-ref e #:group-id #f)) + (o (and gid (not (entity-ref e #:group-origin? #f)) + (assq gid origins)))) + (if o + (let ((origin (cdr o))) + (entity-set (entity-set e #:x (+ (entity-ref origin #:x 0) + (entity-ref e #:group-local-x 0))) + #:y (+ (entity-ref origin #:y 0) + (entity-ref e #:group-local-y 0)))) + e))) - ;; Snap member #:x/#:y to origin + #:group-local-x/y. - ;; Pure entities → entities function; use with scene-transform-entities. - (define (sync-groups entities) - (let ((origins (group-origin-alist entities))) - (map (cut sync-member-to-origin <> origins) entities))) +;; Snap member #:x/#:y to origin + #:group-local-x/y. +;; Pure entities → entities function; use with scene-transform-entities. +(define (sync-groups entities) + (let ((origins (group-origin-alist entities))) + (map (cut sync-member-to-origin <> origins) entities))) ) |