blob: 14840c81790765fee98b1ec3b4cd2d0c2add7ca5 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
(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.
;; 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).
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))))))))
(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
(define (scene-add-entity scene entity)
(update-scene scene
entities: (append (scene-entities scene) (list entity))))
(define (scene-update-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 proc 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))))
;; 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 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))))))
(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. Returns a new scene.
(define (scene-sync-groups scene)
(let ((origins (group-origin-alist (scene-entities scene))))
(update-scene scene
entities: (map (cut sync-member-to-origin <> origins)
(scene-entities scene)))))
)
|
