TakeV/lisp-game-jam
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Working entity-manager setup

Browse source
This commit is contained in:
TakeV 2024-05-25 22:50:05 -04:00
parent 9cc0b4c259
commit 1ff5a8e94e
Signed by: TakeV
GPG key ID: A64F41345C7400AF
9 changed files with 126 additions and 89 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
game.scm
View file

@ -56,26 +56,26 @@
(define game-width 640.0)
(define game-height 480.0)
(define game-images `(('player . ,(make-image "assets/sprites/player.png"))
('barrel . ,(make-image "assets/sprites/barrel.png"))
('bricks . ,(make-image "assets/sprites/bricks.png"))
('stones . ,(make-image "assets/sprites/stones.png"))
('card-back . ,(make-image "assets/sprites/bricks.png"))
('tile-blank . ,(make-image "assets/tiles/blank.png"))
('tile-floor . ,(make-image "assets/tiles/floor-light.png"))
('tile-wall . ,(make-image "assets/tiles/bricks-light.png"))
('tile-door . ,(make-image "assets/tiles/door-light.png"))))
(define game-images `((player . ,(make-image "assets/sprites/player.png"))
(barrel . ,(make-image "assets/sprites/barrel.png"))
(bricks . ,(make-image "assets/sprites/bricks.png"))
(stones . ,(make-image "assets/sprites/stones.png"))
(card-back . ,(make-image "assets/sprites/bricks.png"))))
(parameterize ((*logger* pk))
(parameterize ((*media-library* (create-media-library)))
(add-images! (get-media-library) game-images)
(define bootstrap-entity-manager (make-parameter #f))
(define bootstrap-system-manager (make-parameter #f))
(write-log! "Creating bootstrap managers")
(define bootstrap-entity-manager (create-entity-manager))
(define bootstrap-system-manager (create-entity-manager))
(write-log! "Creating entity manager")
(define e-manager (parameterize ((*entity-manager-parameter* bootstrap-entity-manager)
(*system-manager-parameter* bootstrap-system-manager))
(create-entity-manager (pk (init-game-entities)))))
(write-log! "Entering e-manager creation")
(let ((init-entities (init-game-entities)))
(write-log! "Got initial game entities.")
(create-entity-manager init-entities))))
(write-log! "Creating system manager")
(define s-manager
@ -98,7 +98,7 @@
(write-log! "Defining game loop.")
(define (update-game-loop)
(parameterize ((*logger* pk))
(parameterize ((*logger* #f))
(write-log! "Heartbeat")
(let* ((last-game-state (atomic-box-ref game-atom))
(next-game-state (step-game! last-game-state dt)))

8
modules/ces/component.scm
View file

@ -14,6 +14,7 @@
#:use-module (hoot hashtables)
#:use-module (ces entity)
#:use-module (lib ihashtable)
#:use-module (logging)
#:export (set-component
get-component
remove-component
@ -30,12 +31,15 @@ or false if the component is not found."
(define (set-component entity component-name component)
"Returns a new instance of entity with component-name set to component.
Returns false entity is not a game-entity."
(write-log! "Running component:set-component" component-name)
(if (game-entity? entity)
(let ((old-components (get-entity-components entity)))
(set-entity-components entity
(ihashtable-assoc old-components
component-name
component)))))
component)))
(error "Invalid entity passed to component:set-component"
entity component-name component)))
(define (update-component entity component-name update-proc)
"Returns a new instance of entity with component-name set to the result
@ -46,7 +50,7 @@ Returns #f if entity is not a game-entity or if component-name does not exists."
(set-component entity component-name
(update-proc component-name
(get-component entity component-name)))
#f))
(error "Invalid parameters passed to update-component" entity component-name update-proc)))
(define (remove-component entity component-name)
"Returns a copy of entity with component-name removed.

40
modules/ces/entity-manager.scm
View file

@ -14,6 +14,7 @@
#:use-module (hoot hashtables)
#:use-module (hoot debug)
#:use-module (hoot match)
#:use-module ((hoot write) #:select (display))
#:use-module (scheme base)
#:use-module (scheme case-lambda)
#:use-module (ces entity)
@ -42,6 +43,12 @@
(next-entities entity-manager-next-entities)
(entities-to-delete entity-manager-deleted-entities))
(define (%em-printer em)
(entity-manager-current-entities em)
(entity-manager-next-entities em)
(entity-manager-deleted-entities em)
(entity-generator em))
(define create-entity-manager
(case-lambda
(() (create-entity-manager (emap:create-entity-map)))
@ -91,16 +98,14 @@ an integer."
(if (entity-manager? entity-manager)
(values (entity-manager-current-entities entity-manager)
(entity-manager-next-entities entity-manager)
(entity-manager-deleted-entities entity-manager))))
(entity-manager-deleted-entities entity-manager))
(error "Invalid entity-manager passed to %get-em-fields")))
(define (add-entity! entity-manager entity)
"Adds an entity to the next generation."
(begin
(write-log! "Adding entity:")
(when (%valid-em-inputs? entity-manager entity)
(let ((entity-id (game-entity-id entity)))
(write-log! (string-append "Adding entity id: "
(number->string entity-id)))
(let-values (((cur add up del)
(%get-em-state-list entity-manager entity))
((em-cur em-next em-del)
@ -114,8 +119,9 @@ add the entity to the next generation, just creates one with a valid
entity-id. Use 'add-entity!' to add it to the game.
Returns false if the entity-manager is not an entity-manager"
(if (entity-manager? entity-manager)
((entity-generator entity-manager))
#f))
(begin
((entity-generator entity-manager)))
(error "Invalid entity-manager for create-entity!" entity-manager)))
(define (delete-entity! entity-manager entity)
"Deletes the entity from the next generation."
@ -135,16 +141,15 @@ Returns false if the entity-manager is not an entity-manager"
(define (reset-entity! entity-manager entity)
"Replaces an entity, either adding it or updating it in the next gen."
(when (and (%valid-em-inputs? entity-manager entity)
(game-entity? entity))
(let ((entity-id (game-entity-id entity)))
(let-values (((cur add upt del)
(%get-em-state-list entity-manager entity))
((em-cur em-next em-del)
(%get-em-fields entity-manager)))
(when del
(emap:delete-entity! em-del entity))
(emap:set-entity! em-next entity-id entity)))))
(when (%valid-em-inputs? entity-manager entity)
(let-values ((entity-id (game-entity-id entity))
((cur add upt del)
(%get-em-state-list entity-manager entity))
((em-cur em-next em-del)
(%get-em-fields entity-manager)))
(when del
(emap:delete-entity! em-del entity))
(emap:set-entity! em-next entity-id entity))))
(define (apply-update-to-entity! entity-manager entity proc)
"Applies proc to the given entity, and stores the result
@ -160,8 +165,7 @@ Returns false if the entity does not exist."
(define (get-current-entities entity-manager)
"Returns a vector of every current entity."
(begin (write-log! "Getting entities from entity-manager")
(emap:get-entity-map-entities (entity-manager-current-entities entity-manager))))
(emap:get-entity-map-entities (entity-manager-current-entities entity-manager)))
(define (get-updated-entities entity-manager)
"Returns a vector of the updated-entities"

21
modules/ces/entity.scm
View file

@ -7,9 +7,11 @@
#:use-module (scheme base)
#:use-module (scheme case-lambda)
#:use-module (hoot atomics)
#:use-module (hoot debug)
#:use-module (hoot hashtables)
#:use-module (hoot match)
#:use-module (lib ihashtable)
#:use-module (logging)
#:export (game-entity?
game-entity-id
create-entity
@ -27,31 +29,37 @@
(define create-entity
(case-lambda
((id) (create-entity id (ihashtable)))
((id) (create-entity id (create-ihashtable)))
((id components)
(make-game-entity id (ihashtable components)))))
(make-game-entity id (create-ihashtable components)))))
(define (copy-entity entity)
"Returns a copy of the provided entity. Returns false on error."
(if (game-entity? entity)
(make-game-entity (game-entity-id entity)
(ihashtable (game-entity-components entity)))))
(create-ihashtable (game-entity-components entity)))))
(define (set-entity-components entity new-components)
"Returns a copy of the provided entity with components set to new-components.
Returns false on error."
(write-log! "Running entity:set-entity-components"
(when (game-entity? entity)
(game-entity-id entity))
(when (ihashtable? new-components)
(ihashtable-keys new-components)))
(if (and (game-entity? entity)
(ihashtable? new-components))
(let ((id (game-entity-id entity))
(current-components (game-entity-components entity)))
(create-entity id new-components))))
(create-entity id new-components))
(error "Invalid paramters passed to entity:set-entity-components" entity new-components)))
(define (get-entity-components entity)
"Returns the entity components in the form of an immutable hashtable.
Returns false if entity is not a game-entity."
(if (game-entity? entity)
(game-entity-components entity)
#f))
(error "Invalid entity passed to get-entity-components" entity)))
(define (create-entity-generator)
"Returns a procedure which takes a list of components and creates
@ -64,7 +72,8 @@ thread-safe."
(atomic-box-swap! id-counter
(+ 1 (atomic-box-ref id-counter))))))
(case-lambda
(() (create-entity (get-next-counter-value!)))
(()
(create-entity (get-next-counter-value!)))
((components)
(create-entity (get-next-counter-value!)
components)))))

21
modules/ces/entity/entity-map.scm
View file

@ -5,7 +5,9 @@
#:use-module (hoot atomics)
#:use-module (hoot hashtables)
#:use-module (hoot match)
#:use-module (hoot debug)
#:use-module (ces entity)
#:use-module (logging)
#:export (entity-map?
create-entity-map
copy-entity-map
@ -27,7 +29,8 @@
(define create-entity-map
(case-lambda
(() (make-entity-map (make-eq-hashtable)))
(()
(make-entity-map (make-eq-hashtable)))
((initial-entities)
(cond
((list? initial-entities)
@ -45,7 +48,7 @@
(make-entity-map
(hashtable-copy
(entity-map-entities initial-entities))))
(else (create-entity-map))))))
(else (error "create-entity-map supplied with invalid input"))))))
(define (entity-key entity)
"Returns the entity id of an entity, or the value itself if it is
@ -53,7 +56,7 @@ and integer already. Returns false if passed an invalid entity."
(cond
((game-entity? entity)) (game-entity-id entity)
((integer? entity) entity)
(else #f)))
(else (error "Invalid entity-key parameter" entity))))
(define (get-entity entity-map entity)
"Returns the entity with the supplied entity-id if one exists.
@ -82,11 +85,13 @@ an argument for criteria?"
(define (set-entity! entity-map entity-id entity)
"Replaces the entity in the entity-map the given entity."
(when (and (entity-map? entity-map)
(game-entity? entity))
(hashtable-set! (entity-map-entities entity-map)
entity-id
entity)))
(if (and (entity-map? entity-map)
(game-entity? entity))
(begin
(hashtable-set! (entity-map-entities entity-map)
entity-id
entity))
(error "Invalid game entity and entity-map" entity-map entity)))
(define (delete-entity! entity-map entity)
"Removes the entity from the entity map"

29
modules/game/game-manager.scm
View file

@ -14,21 +14,24 @@
"Returns a list of initial game entities. "
(write-log! "Init game entities")
(let* ((room-background (get-image (get-media-library) 'room-background))
(ts-vec (write-log! (vector
(make-tile 'tile-blank 16 16)
(make-tile 'tile-floor 16 16)
(make-tile 'tile-wall 16 16)
(make-tile 'tile-door 16 16))))
(tl-vec (write-log!
(ts-vec
(write-log!
(vector
(make-tile 'tile-blank 16 16)
(make-tile 'tile-floor 16 16)
(make-tile 'tile-wall 16 16)
(make-tile 'tile-door 16 16))))
(tl-vec
(write-log!
#(2 2 2 2 3 2 2 2
1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1)))
1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1
1 1 1 1 1 1 1 1)))
(room-tilemap
(make-tilemap
(make-tileset ts-vec 16 16)
(list
(make-tilemap-layer tl-vec 0 0 8 4)))))
(make-tilemap
(make-tileset ts-vec 16 16)
(list
(make-tilemap-layer tl-vec 0 0 8 4)))))
(list (create-player!)
(create-room! room-tilemap))))

20
modules/game/game-objects.scm
View file

@ -1,6 +1,7 @@
(define-module (game game-objects)
#:pure
#:use-module (scheme base)
#:use-module (hoot debug)
#:use-module (ces component)
#:use-module (ces component hitbox)
#:use-module (ces component position)
@ -15,6 +16,7 @@
create-game-object!))
(define (add-position entity entity-id x y)
(write-log! "Running game-objects:add-position")
(set-component entity 'position (create-position entity-id x y)))
(define (add-hitbox entity entity-id x y w h)
@ -24,18 +26,18 @@
(set-component entity 'sprite (make-sprite entity-id sprite w h)))
(define (add-game-object-components entity x y width height sprite)
(unless (game-entity? entity)
(error "Invalid entity passed to game-objects:add-game-object-components"))
(let* ((entity-id (game-entity-id entity))
(entity (add-position entity entity-id x y))
(entity (add-hitbox entity entity-id x y width height))
(entity (add-sprite entity entity-id sprite width height)))
entity))
(p-entity (add-position entity entity-id x y))
(h-entity (add-hitbox p-entity entity-id x y width height))
(s-entity (add-sprite h-entity entity-id sprite width height)))
s-entity))
(define (game-object? entity)
(has-components? entity 'position 'hitbox 'sprite))
(define (create-game-object! x y width height sprite)
(write-log! "create-game-object!")
(let* ((e-manager (write-log! (get-entity-manager)))
(entity (write-log! (create-entity! e-manager))))
(reset-entity! e-manager
(add-game-object-components entity x y width height sprite))))
(let* ((e-manager (get-entity-manager))
(entity (create-entity! e-manager)))
(add-game-object-components entity x y width height sprite)))

16
modules/game/level-manager.scm
View file

@ -21,12 +21,9 @@
(has-components? entity 'keyboard-input)))
(define (create-player!)
(let* (
(player-sprite (write-log! (get-image (get-media-library) 'player)))
(initial-entity (write-log! (create-game-object! 0 0 16 16 player-sprite)))
)
(set-component initial-entity 'keyboard-input
(create-inputs))))
(let* ((player-sprite (get-image (get-media-library) 'player))
(initial-entity (create-game-object! 0 0 16 16 'player-sprite)))
(set-component initial-entity 'keyboard-input (create-inputs))))
;; Room
(define (room? entity)
@ -45,10 +42,9 @@
(add-tilemap entity tm))
(define (create-room! tm)
(let* ((e-manager (get-entity-manager))
(entity (create-entity! e-manager)))
(reset-entity! e-manager
(add-room-components entity tm))))
(let* ((e-manager (get-entity-manager))
(entity (create-entity! e-manager)))
(add-room-components entity tm)))
;; Floor
;; A floor is a list of rooms

34
modules/lib/ihashtable.scm
View file

@ -4,8 +4,11 @@
#:use-module (scheme case-lambda)
#:use-module (hoot hashtables)
#:use-module ((hoot syntax) #:select (define*))
#:use-module (logging)
#:export (ihashtable?
ihashtable
create-ihashtable
ihashtable-keys
ihashtable-values
ihashtable-contains?
ihashtable-get
ihashtable-assoc
@ -34,18 +37,29 @@
lst))
#f))
(define ihashtable
(define create-ihashtable
(case-lambda
(() (make-ihashtable (make-eq-hashtable)))
(()
(make-ihashtable (make-eq-hashtable)))
((initial-values)
(cond
((hashtable? initial-values)
(make-ihashtable (hashtable-copy values)))
(make-ihashtable (hashtable-copy initial-values)))
((ihashtable? initial-values)
(%copy-ihashtable initial-values))
((list? initial-values)
(make-ihashtable (%assoc-list->hashtable initial-values)))
(else (ihashtable))))))
(else (create-ihashtable))))))
(define (ihashtable-keys ihashtable)
(if (ihashtable? ihashtable)
(hashtable-keys (ihashtable-entries ihashtable))
(error "Invalid ihashtable passed to ihashtable-keys" ihashtable)))
(define (ihashtable-values ihashtable)
(if (ihashtable? ihashtable)
(hashtable-entries (ihashtable-entries ihashtable))
(error "Invalid ihashtable passed to ihashtable-values" ihashtable)))
(define (ihashtable-contains? ihashtable key)
"Returns true if the hashtable contains key"
@ -57,7 +71,7 @@
Returns false if there is an error."
(if (ihashtable? ihashtable)
(hashtable-ref (ihashtable-entries ihashtable) key default-value)
#f))
(error "Invalid ihashtable" ihashtable key default-value)))
(define (ihashtable-assoc ihashtable key val)
"Returns a copy of hashtable with key set to val.
@ -67,8 +81,8 @@ Returns false if there is an error."
(new-table (hashtable-copy backing-table)))
(begin
(hashtable-set! new-table key val)
(ihashtable new-table)))
#f))
(create-ihashtable new-table)))
(error "Invalid ihashtable" ihashtable key val)))
(define (ihashtable-dissoc ihashtable key)
"Returns a copy of hashtable without key.
@ -78,8 +92,8 @@ Returns false on error."
(new-table (hashtable-copy backing-table)))
(begin
(hashtable-delete! new-table key)
(ihashtable new-table)))
#f))
(create-ihashtable new-table)))
(error "Invalid ihashtable" ihashtable key)))
(define (ihashtable-update ihashtable key proc)
"Takes a two arity proc (key,value) and returns a new hashtable