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

Move entity-map to a dedicated module

Browse source
This commit is contained in:
TakeV 2024-05-24 23:57:40 -04:00
parent 0fa32d9df2
commit ebd0f3d956
Signed by: TakeV
GPG key ID: A64F41345C7400AF
4 changed files with 148 additions and 105 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile
View file

@ -2,6 +2,7 @@ modules := \
$(wildcard modules/*.scm) \
$(wildcard modules/ces/*.scm) \
$(wildcard modules/ces/component/*.scm) \
$(wildcard modules/ces/entity/*.scm) \
$(wildcard modules/ces/system/*.scm) \
$(wildcard modules/dom/*.scm) \
$(wildcard modules/math/*.scm) \

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

@ -9,12 +9,14 @@
(define-module (ces entity-manager)
#:pure
#:use-module (logging)
#:use-module (hoot atomics)
#:use-module (hoot hashtables)
#:use-module (hoot match)
#:use-module (scheme base)
#:use-module (scheme case-lambda)
#:use-module (ces entity)
#:use-module ((ces entity entity-map) #:prefix emap:)
#:export (create-entity-manager
create-entity!
add-entity!
@ -27,88 +29,6 @@
get-deleted-entities
get-next-generation))
(define-record-type <entity-map>
(make-entity-map enitites)
entity-map?
(entities entity-map-entities))
(define (create-entity-map)
"Creates a new entity-map and returns it."
(make-entity-map (make-eq-hashtable)))
(define (%entity-key entity)
"Returns the entity id of an entity, or the value itself if it is
and integer already. Returns false if passed an invalid entity."
(cond
((game-entity? entity)) (game-entity-id entity)
((integer? entity) entity)
(else #f)))
(define (%get-entity entity-map entity)
"Returns the entity with the supplied entity-id if one exists.
Returns false if no entity exists with that id."
(hashtable-ref (entity-map-entities entity-map) (%entity-key entity) #f))
(define (%get-entities entity-map criteria?)
"Returns a list of all entities which return a truthy value when used as
an argument for criteria?"
(let* ((entities (entity-map-entities entity-map))
(entity-list (make-atomic-box (list)))
(update-entity-list
(lambda (k v)
(when (criteria? v)
(atomic-box-swap! entity-list
(cons v (atomic-box-ref entity-list)))))))
(begin
(hashtable-for-each update-entity-list entities)
(atomic-box-ref entity-list))))
(define (%set-entity! entity-map 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-key entity)
entity)))
(define (%delete-entity! entity-map entity)
"Removes the entity from the entity map"
(when (and (entity-map? entity-map)
(%get-entity entity-map entity))
(hashtable-delete! (entity-map-entities entity-map)
(%entity-key entity))))
(define (%update-entity! entity-map entity-id proc)
"Applies proc to the entity in entity-map with entity-id, and replaces the entity
with the result of proc.
proc must be a proceedure with one argument: the entity to update.
proc should be free of side effects, as it may be called multiple times.
If the entity does not exist, no change is applied. "
(let ((old-entity (%get-entity entity-map entity-id)))
(when old-entity
(%set-entity! entity-map (proc old-entity)))))
(define (%update-entity entity-map entity-id proc)
"Pure update-entity call, does not modify the underlying entity.
Returns the updated entity, or false if the entity does not exist."
(let ((old-entity (%get-entity entity-map entity-id)))
(if (old-entity)
(proc old-entity)
#f)))
(define (%update-entities! entity-map entities)
"Updates entity-map using entities. entities can be a list, vector, or entity-map.
Entities within entity-map are added if they do not already exist, or are replaced if they do."
(match entities
((? entity-map?)
(let ((new-entities (entity-map-entities entities)))
(hashtable-for-each (lambda (k v)
(%set-entity! k v))
new-entities)))
((? list?)
(map %set-entity! entities))
((? vector?)
(vector-map %set-entity! entities))))
(define-record-type <entity-manager>
(make-entity-manager current-entities
@ -123,11 +43,11 @@ Entities within entity-map are added if they do not already exist, or are replac
(define create-entity-manager
(case-lambda
(() (create-entity-manager (create-entity-map)))
(() (create-entity-manager (emap:create-entity-map)))
((initial-world-state)
(make-entity-manager initial-world-state
(create-entity-map)
(create-entity-map)
(emap:create-entity-map)
(emap:create-entity-map)
(create-entity-generator)))))
(define (%valid-em-inputs? entity-manager entity)
@ -140,8 +60,8 @@ an integer."
(define (%entity-check-helper entity-manager entity manager-field)
(and (%valid-em-inputs? entity-manager entity)
(%get-entity (manager-field entity-manager)
(%entity-key entity))))
(emap:get-entity (manager-field entity-manager)
(emap:entity-key entity))))
(define (%entity-deleted? entity-manager entity)
(%entity-check-helper entity-manager entity entity-manager-deleted-entities))
@ -169,13 +89,16 @@ an integer."
(define (add-entity! entity-manager entity)
"Adds an entity to the next generation."
(when (%valid-em-inputs? entity-manager entity)
(let-values (((cur add up del)
(%get-em-state-list entity-manager entity))
((em-cur em-next em-del)
(%get-em-state-list entity-manager entity)))
(when (not (or cur add))
(%set-entity! em-next entity)))))
(begin
(write-log! "Adding entity:")
(when (%valid-em-inputs? entity-manager entity)
(write-log! (string-append "Adding entity id: " (game-entity-id entity)))
(let-values (((cur add up del)
(%get-em-state-list entity-manager entity))
((em-cur em-next em-del)
(%get-em-state-list entity-manager entity)))
(when (not (or cur add))
(emap:set-entity! em-next entity))))))
(define (create-entity! entity-manager)
"Creates and returns an empty entity. Note that this does not automatically
@ -195,11 +118,11 @@ Returns false if the entity-manager is not an entity-manager"
;; Only continue if we have not seen this entity before
(when (not del)
(when add
(%delete-entity! em-cur entity))
(emap:delete-entity! em-cur entity))
(when upt
(%delete-entity! em-next entity))
(emap:delete-entity! em-next entity))
(when cur
(%set-entity! em-del entity)))))
(emap:set-entity! em-del entity)))))
(define (reset-entity! entity-manager entity)
"Replaces an entity, either adding it or updating it in the next gen."
@ -211,8 +134,8 @@ Returns false if the entity-manager is not an entity-manager"
(%get-em-fields entity-manager)))
(begin
(when del
(%delete-entity! em-del entity))
(%set-entity! em-next entity)))))
(emap:delete-entity! em-del entity))
(emap:set-entity! em-next entity)))))
(define (apply-update-to-entity! entity-manager entity proc)
"Applies proc to the given entity, and stores the result
@ -224,26 +147,28 @@ in the updated entities list."
"Returns the entity with entity-id from the current world state.
Returns false if the entity does not exist."
(and (%valid-em-inputs? entity-manager entity)
(%get-entity (entity-manager-current-entities entity-manager) entity)))
(emap:get-entity (entity-manager-current-entities entity-manager) entity)))
(define (get-current-entities entity-manager)
"Returns a vector of every current entity."
(hashtable-entries (entity-manager-current-entities entity-manager)))
(begin (write-log! "Getting entities from 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"
(hashtable-entries (entity-manager-next-entities entity-manager)))
(emap:get-entity-map-entities (entity-manager-next-entities entity-manager)))
(define (get-deleted-entities entity-manager)
"Returns a vector of the deleted-entities"
(hashtable-entries (entity-manager-deleted-entities entity-manager)))
(emap:get-entity-map-entities (entity-manager-deleted-entities entity-manager)))
(define (get-next-generation entity-manager)
"Returns an entity-manager representing the next generation.
The new current-entities will be the result of replacing entity-manager's
current entities with the next-entities."
(when (entity-manager? entity-manager)
(write-log! "Getting next generation from entity-manager.")
(let* ((current-gen (entity-manager-current-entities entity-manager))
(updates (entity-manager-next-entities entity-manager))
(next-generation (hashtable-copy current-gen)))
(make-entity-manager (%update-entities! next-generation updates)))))
(next-generation (emap:copy-entity-map current-gen)))
(make-entity-manager (emap:update-entities! next-generation updates)))))

1
modules/ces/entity/README.org Normal file
View file

@ -0,0 +1 @@
Code to help manage entities. Not intended to be used by anything except for the entity manager.

116
modules/ces/entity/entity-map.scm Normal file
View file

@ -0,0 +1,116 @@
(define-module (ces entity entity-map)
#:pure
#:use-module (scheme base)
#:use-module (hoot atomics)
#:use-module (hoot hashtables)
#:use-module (hoot match)
#:use-module (ces entity)
#:export (entity-map?
create-entity-map
copy-entity-map
entity-key
get-entity
get-entities
get-entity-map-entities
set-entity!
delete-entity!
update-entity!
update-entity
update-entities!))
(define-record-type <entity-map>
(make-entity-map entities)
entity-map?
(entities entity-map-entities))
(define (create-entity-map)
"Creates a new entity-map and returns it."
(make-entity-map (make-eq-hashtable)))
(define (entity-key entity)
"Returns the entity id of an entity, or the value itself if it is
and integer already. Returns false if passed an invalid entity."
(cond
((game-entity? entity)) (game-entity-id entity)
((integer? entity) entity)
(else #f)))
(define (get-entity entity-map entity)
"Returns the entity with the supplied entity-id if one exists.
Returns false if no entity exists with that id."
(hashtable-ref (entity-map-entities entity-map) (entity-key entity) #f))
(define (get-entities entity-map criteria?)
"Returns a list of all entities which return a truthy value when used as
an argument for criteria?"
(let* ((entities (entity-map-entities entity-map))
(entity-list (make-atomic-box (list)))
(update-entity-list
(lambda (k v)
(when (criteria? v)
(atomic-box-swap! entity-list
(cons v (atomic-box-ref entity-list)))))))
(begin
(hashtable-for-each update-entity-list entities)
(atomic-box-ref entity-list))))
(define (get-entity-map-entities entity-map)
(if (entity-map? entity-map)
(hashtable-entries
(entity-map-entities entity-map))
#f))
(define (set-entity! entity-map 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-key entity)
entity)))
(define (delete-entity! entity-map entity)
"Removes the entity from the entity map"
(when (and (entity-map? entity-map)
(get-entity entity-map entity))
(hashtable-delete! (entity-map-entities entity-map)
(entity-key entity))))
(define (update-entity! entity-map entity-id proc)
"Applies proc to the entity in entity-map with entity-id, and replaces the entity
with the result of proc.
proc must be a proceedure with one argument: the entity to update.
proc should be free of side effects, as it may be called multiple times.
If the entity does not exist, no change is applied. "
(let ((old-entity (get-entity entity-map entity-id)))
(when old-entity
(set-entity! entity-map (proc old-entity)))))
(define (update-entity entity-map entity-id proc)
"Pure update-entity call, does not modify the underlying entity.
Returns the updated entity, or false if the entity does not exist."
(let ((old-entity (get-entity entity-map entity-id)))
(if (old-entity)
(proc old-entity)
#f)))
(define (copy-entity-map entity-map)
"Returns a copy of entity-map."
(if (entity-map? entity-map)
(let ((old-map (entity-map-entities entity-map)))
(make-entity-map (hashtable-copy old-map)))
#f))
(define (update-entities! entity-map entities)
"Updates entity-map using entities. entities can be a list, vector, or entity-map.
Entities within entity-map are added if they do not already exist, or are replaced if they do."
(match entities
((? entity-map?)
(let ((new-entities (entity-map-entities entities)))
(hashtable-for-each (lambda (k v)
(set-entity! k v))
new-entities)))
((? list?)
(map set-entity! entities))
((? vector?)
(vector-map set-entity! entities))))