Add CES to game

Add initial components

Add player component

Add system scaffolding

Add entity-manager

Add game-core

Redo entities so their components are stored in a searchable hashtable

Make systems thunk-based

Add system-manager

Create game-core

Makefile

@@ -1,4 +1,14 @@
 modules = \
+  modules/game-core.scm \
+  modules/ces/component/player.scm \
+  modules/ces/component/position.scm \
+  modules/ces/component/velocity.scm \
+  modules/ces/component/sprite.scm \
+  modules/ces/component.scm \
+  modules/ces/entity.scm \
+  modules/ces/entity-manager.scm \
+  modules/ces/system-manager.scm \
+  modules/ces/system.scm \
   modules/dom/canvas.scm \
   modules/dom/document.scm \
   modules/dom/element.scm \

game.scm

@@ -33,7 +33,12 @@
         (dom window)
         (math)
         (math rect)
-        (math vector))
+        (math vector)
+        (ces entity)
+        (ces system)
+        (ces system-manager)
+        (ces entity-manager)
+        (game-core))
 
 ;; Data types
 

modules/ces/component.scm

@@ -0,0 +1,28 @@
+;; Defines the component part of a CES
+;; Components are associated with entities (tracking their IDs) and have a type
+;; which should just match the component name.
+
+(define-module (ces component)
+  #:pure
+  #:use-module (scheme base))
+
+;; Eventually there will be a macro, once I figure out macros...
+
+;; Taken from the guix codebase, in the component defs
+#;(define-syntax-rule (id ctx parts ...)
+(datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
+
+#;(define-syntax-rule (component-field ctx field-name)
+(datum->syntax ctx (id ctx )))
+
+#;(define-syntax define-component
+(lambda (x) 
+(syntax-case x ()
+((_ component-name fields ...)
+#`(define-record-type #,(id #'component-name
+#'< #'component-name #'-component #'>)
+#,(id #'component-name #'make- #'component-name)
+#,(id #'component-sym #'?)
+)))))
+
+

modules/ces/component/player.scm

@@ -0,0 +1,9 @@
+(define-module (ces component player)
+  #:pure
+  #:use-module (scheme base))
+
+;; Player is a mostly empty component, used for tagging an entity for player systems
+(define-record-type <player>
+    (make-player entity-id)
+  player?
+  (entity-id player-entity-id))

modules/ces/component/position.scm

@@ -0,0 +1,38 @@
+(define-module (ces component position)
+  #:pure
+  #:use-module (scheme base)
+  #:use-module (math vector)
+  #:export (position?
+            position-entity-id
+            create-position
+            position-x
+            position-y
+            set-position
+            set-position!))
+
+(define-record-type <position>
+    (make-position type entity-id pos-vec)
+  position?
+  (type position-type)
+  (entity-id position-entity-id)
+  (pos-vec position-vector))
+
+(define (create-position entity-id x y)
+  (make-position 'position entity-id
+                 (vec2 x y)))
+
+(define (position-x position)
+  (vec2-x (position-vector position)))
+
+(define (position-y position)
+  (vec2-y (position-vector position)))
+
+(define (set-position position x y)
+  "Creates a copy of the position component with the given x and y"
+  (create-position (position-entity-id position) x y))
+
+(define (set-position! position x y)
+  "Sets the coordinates of the given position component"
+  (begin
+    (set-vec2-x! (position-vector position) x)
+    (set-vec2-y! (position-vector position) y)))

modules/ces/component/sprite.scm

@@ -0,0 +1,13 @@
+(define-module (ces component sprite)
+  #:pure
+  #:use-module (scheme base)
+  #:use-module (dom image)
+  #:export (sprite?
+            make-sprite
+            sprite-image))
+
+(define-record-type <sprite>
+    (make-sprite entity-id image)
+  sprite?
+  (entity-id sprite-entity-id)
+  (image sprite-image))

modules/ces/component/velocity.scm

@@ -0,0 +1,14 @@
+(define-module (ces component velocity)
+  #:pure
+  #:use-module (scheme base)
+  #:use-module (math vector)
+  #:export (velocity?
+            velocity-entity-id
+            velocity-vector
+            set-velocity-vector!))
+
+(define-record-type <velocity>
+    (make-velocity entity-id velocity-vec)
+  velocity?
+  (entity-id velocity-entity-id)
+  (velocity-vec velocity-vector set-velocity-vector!))

modules/ces/entity-manager.scm

@@ -0,0 +1,156 @@
+;; This is in charge of managing the world state.
+;; The entity manager just holds a hashmap with every
+;; entity. It handles updating, searching, addition,
+;; and so forth.
+;;
+;; For the most part, it is best to only use the pure proceedures,
+;; as game state mutation should never happen except when updating the
+;; entire world.
+
+(define-module (ces entity-manager)
+  #:pure
+  #: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)
+  #:export (create-entity-manager
+            add-entity!
+            apply-update-to-entity!
+            get-current-entities
+            get-updated-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 (%get-entity entity-map entity-id)
+  "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-id #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!
+  ;; Replaces the entity in the entity-map the given entity.
+  ;; Optionally takes an entity-id, which updates the entry with that index.
+  (case-lambda
+    ((entity-map entity) (set-entity! entity-map entity (game-entity-id entity)))
+    ((entity-map entity entity-id) (let ((entity-table (entity-map-entities entity-map)))
+                                     (when (game-entity? entity)
+                                       (hashtable-set! entity-table entity-id 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 entity-id (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 next-entities)
+  entity-manager?
+  (current-entities entity-manager-current-entities)
+  (next-entities entity-manager-next-entities))
+
+(define create-entity-manager
+  (case-lambda
+    (() (create-entity-manager (create-entity-map)))
+    ((initial-world-state)
+     (make-entity-manager initial-world-state (create-entity-map)))))
+
+(define (add-entity! entity-manager entity)
+  (when (and (entity-manager? entity-manager)
+             (game-entity? entity))
+    (let ((updated-entities (entity-manager-next-entities entity)))
+      (set-entity! updated-entities entity))))
+
+;; We only want to update the next state, so we check
+;; if the entity already exists in the next state,
+;; otherwise update the current entity.
+(define (%get-map-to-update entity-manager entity-id)
+  (let* ((current-entities (entity-manager-current-entities entity-manager))
+         (next-entities (entity-manager-next-entities entity-manager)))
+    (if (%get-entity next-entities entity-id)
+        next-entities
+        current-entities)))
+
+(define (apply-update-to-entity! entity-manager entity proc)
+  "Applies proc to the given entity, and stores the result
+in the updated entities list."
+  (when (game-entity? entity)
+    (let* ((entity-id (game-entity-id entity))
+           (map-to-update (%get-map-to-update entity-manager entity-id))
+           (existing-entity (%get-entity map-to-update entity-id)))
+      (when existing-entity
+        (update-entity! map-to-update entity-id proc)))))
+
+(define (get-entity entity-manager entity-id)
+  "Returns the entity with entity-id from the current world state.
+Returns false if the entity does not exist."
+  (if (entity-manager? entity-manager)
+      (%get-entity (entity-manager-current-entities entity-manager)
+                   entity-id)
+      #f))
+
+(define (get-current-entities entity-manager)
+  "Returns a vector of every current entity."
+  (hashtable-entries (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)))
+
+(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)
+    (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)))))

modules/ces/entity.scm

@@ -0,0 +1,96 @@
+;; Defines the entity aspect of the component-entity-system
+;; Entities are really, really simple, often just an ID
+;; We are just going to store an ID and a list of components.
+
+(define-module (ces entity)
+  #:pure
+  #:use-module (scheme base)
+  #:use-module (scheme case-lambda)
+  #:use-module (hoot atomics)
+  #:use-module (hoot hashtables)
+  #:use-module (hoot match)
+  #:export (game-entity?
+            game-entity-id
+            create-entity
+
+            get-component
+            get-components
+
+            set-component!
+            add-component!
+            update-component!
+            delete-component!
+            
+            create-entity-generator))
+
+(define-record-type <game-entity>
+    (make-game-entity id components)
+  game-entity?
+  (id game-entity-id)
+  (components game-entity-components entity-components-set!))
+
+(define (create-entity id)
+  "Creates a new game entity"
+  (make-game-entity id (make-eq-hashtable)))
+
+(define (get-component entity component-name)
+  "Returns the component from entity with component-name if it exists,
+false otherwise."
+  (hashtable-ref (game-entity-components entity) component-name #f))
+
+;; Returns a vector of components matching the provided critera
+;; If only the entity is provided, return all the entities.
+;; If a list or vector is provided, returns a vector with
+;; the component which matches that component-name
+;; (get-components renderable-entity ['position 'sprite])
+;; would return [POSITION-COMPONENT SPRITE-COMPONENT]
+(define get-components
+  (case-lambda
+    ((entity) (hashtable-entries entity))
+    ((entity names)
+     (let ((component-search
+            (lambda (component-name)
+              (get-component entity component-name))))
+       (match names
+         ((? list?)
+          (list->vector (map component-search names)))
+         ((? vector?)
+          (list->vector (vector-map component-search names))))))))
+
+(define (set-component! entity component-name component)
+  "Replaces the component in entity with component-name.
+Add the component if one does not exist."
+  (let ((e-components (game-entity-components entity)))
+    (hashtable-set! e-components component-name component)))
+
+(define (add-component! entity component-name component)
+  "Appends component to entity's component list.
+Does nothing if component-name exists."
+  (when (not (get-component entity component-name))
+    (set-component! entity component-name component)))
+
+(define (update-component! entity component-name proc)
+  "Swaps entity component with component-name with the result
+of applying proc to the existing component. Does nothing if
+the component does not exist."
+  (let ((old-component (get-component entity component-name)))
+    (when old-component
+      (set-component! entity component-name (proc old-component)))))
+
+(define (delete-component! entity component-name)
+  "Removes the component with component-name from the entity.
+Does nothing if the component does not exist."
+  (let ((components (game-entity-components entity)))
+    (when (hashtable-contains? components component-name)
+      (hashtable-delete! components component-name))))
+
+(define (create-entity-generator)
+  "Returns a procedure which takes a list of components and creates
+a new entity with the ID set. IDs are integers, and each generator
+handles the ID state. ID generation is atomic, and thus should be
+thread-safe."
+  (let ((id-counter (make-atomic-box 0)))
+    (lambda (components)
+      (let ((current-id (atomic-box-swap! id-counter
+                                          (+ 1 (atomic-box-ref id-counter)))))
+        (make-game-entity current-id components)))))

modules/ces/system-manager.scm

@@ -0,0 +1,105 @@
+;;; The system-manager. Manages applying systems to entities,
+;;; executes procs, and so forth.
+;;; We are going with a thunk-based system to be able to
+;;; control when a particular call is executed.
+;;; This will make it easier to interface with goblins,
+;;; later on down the line. :3
+
+(define-module (ces system-manager)
+  #:pure
+  #:use-module (scheme base)
+  #:use-module (hoot hashtables)
+  #:use-module (ces system)
+  #:use-module (ces entity)
+  #:export (system-manager?
+            create-system-manager
+            add-system-to-system-manager
+
+            apply-systems-to-entity!
+            remove-systems-from-entity!
+            run-systems!))
+
+;; Unlike the entity and component
+;; functionality, we care about system
+;; order. 'systems' should be a list,
+;; since some systems should run before or
+;; after each other.
+(define-record-type <system-manager>
+    (make-system-manager systems proc-table)
+  system-manager?
+  (systems systems)
+  (proc-table system-manager-proc-table))
+
+(define (create-system-manager)
+  "Creates a system manager."
+  (make-system-manager (make-eq-hashtable)))
+
+(define (add-system-to-system-manager sys-manager sys)
+  "Returns a new system manager with sys added,
+or false if the input is invalid."
+  (let ((proc-table (system-manager-proc-table sys-manager))
+        (old-systems (systems sys-manager)))
+    (if (and (system-manager? sys-manager)
+             (system? sys))
+        (make-system-manager (cons sys old-systems)
+                             proc-table)
+        #f)))
+
+(define (get-procs-from-table sys-manager entity)
+  (if (and (system-manager? sys-manager)
+           (game-entity? entity))
+      (let* ((proc-table (system-manager-proc-table sys-manager)))
+        (hashtable-ref proc-table entity #f))
+      #f))
+
+(define (add-proc-to-table! sys-manager system entity)
+  (when (and (system-manager? sys-manager)
+             (system? system)
+             (game-entity? entity))
+    (let ((proc-table (system-manager-proc-table sys-manager))
+          (proc-table-entry (get-procs-from-table sys-manager entity))
+          (proc (apply-system-to-entity system entity)))
+      (hashtable-set! proc-table entity (cons proc proc-table-entry)))))
+
+(define (apply-systems-to-entity! sys-manager entity)
+  (when (and (system-manager? sys-manager)
+             (game-entity? entity))
+    (let* ((sys-list (systems sys-manager))
+           (applied-systems (map (lambda (sys)
+                                   (apply-system-to-entity sys entity))
+                                 sys-list))
+           (proc-table (system-manager-proc-table sys-manager)))
+      (begin
+        (hashtable-clear! proc-table)
+        (for-each (lambda (sys)
+                    (add-proc-to-table! sys-manager sys entity))
+                  applied-systems)))))
+
+(define (remove-systems-from-entity! sys-manager entity)
+  (when (and (system-manager? sys-manager)
+             (game-entity? entity))
+    (let ((proc-table (system-manager-proc-table sys-manager)))
+      (when (hashtable-contains? proc-table entity)
+        (hashtable-delete! (system-manager-proc-table sys-manager)
+                           entity)))))
+
+(define (%thunkify-system procs dt)
+  (map (lambda (proc)
+         (lambda ()
+           (proc dt)))
+       procs))
+
+(define (get-thunks sys-manager dt)
+  (when (system-manager? sys-manager)
+    (let ((proc-table (system-manager-proc-table sys-manager)))
+      (vector-map (lambda (procs)
+                    (%thunkify-system procs dt))
+                  (hashtable-entries proc-table)))))
+
+(define (run-systems! sys-manager dt)
+  "Executes every valid system."
+  (when (system-manager? sys-manager)
+    (let ((thunks (get-thunks sys-manager dt)))
+      (vector-for-each (lambda (proc)
+                         (proc))
+                       thunks))))

modules/ces/system.scm

@@ -0,0 +1,48 @@
+;;; Systems are where we store the actual game logic.
+;;;
+;;; Systems are a record that defines a predicate and a process proceedure
+;;;
+;;; The precicate decides if an entity should be processed by the system,
+;;; typically just checking if an entity has some component.
+;;;
+;;; The process proceedure gets passed an entity and a time span,
+;;; and returns a thunk which, when called, will perform the system's action.
+;;;
+;;; It is recommended to only use mutation when absolutely needed.
+;;;
+;;; Most systems are not concerned with every component,
+;;; for instance rendering does not care about velocity,
+;;; but it does care about position and any image components.
+
+(define-module (ces system)
+  #:pure
+  #:use-module (scheme base)
+  #:use-module (ces entity)
+  #:export (make-system
+            system?
+            system-predicate?
+            system-process-entity
+
+            system-applicable-to-entity?
+            apply-system-to-entity))
+
+;; Eventually should work with events as well.
+(define-record-type <system>
+    (make-system predicate process-entity)
+  system?
+  (predicate system-predicate?) ;; (entity, time) -> entity
+  (process-entity system-process-entity))
+
+(define (system-applicable-to-entity? entity system)
+  (and (game-entity? entity) (system? system)
+       ((system-predicate? system) entity)))
+
+(define (apply-system-to-entity system entity)
+  "Takes a system and entity and returns a proceedure
+which takes a time delta and entity as an input and returns
+a proceedure that takes a time delta.
+This is essentially a partial application of the system's
+process proceedure."
+  (let ((sys-proc (system-process-entity system)))
+    (lambda (dt)
+      (sys-proc entity dt))))

modules/game-core.scm

@@ -0,0 +1,54 @@
+;; This is where the magic happens. The game core is what
+;; coordinates the entities, components, and systems.
+
+(define-module (game-core)
+  :pure
+  :use-module (scheme base)
+  :use-module (ces system)
+  :use-module (ces component)
+  :use-module (ces entity)
+  :use-module (ces entity-manager)
+  :use-module (ces system-manager)
+  #:export (game?
+            make-game
+            initialize-systems!
+            step-game!
+            start-game!))
+
+(define-record-type <game>
+    (make-game entity-manager system-manager previous-time current-time)
+  game?
+  (entity-manager game-entity-manager)
+  (system-manager game-system-manager)
+  (previous-time game-previous-time)
+  (current-time game-current-time))
+
+(define (initialize-systems! game)
+  (let ((e-manager (game-entity-manager game))
+        (s-manager (game-system-manager game)))
+    (vector-for-each (lambda (entity)
+                       (apply-systems-to-entity! s-manager entity))
+                     (get-current-entities e-manager))))
+
+(define (step-game! game dt)
+  "Returns a new game-state after dt"
+  (let* ((e-manager (game-entity-manager game))
+         (s-manager (game-system-manager game)))
+    (begin
+      (run-systems! s-manager dt)
+      (vector-for-each (lambda (entity)
+                         (apply-systems-to-entity! s-manager entity))
+                       (get-updated-entities e-manager))
+      (make-game (get-next-generation e-manager)
+                 s-manager
+                 dt
+                 (+ (game-current-time game) dt)))))
+
+(define (loop-game! game dt)
+  (let ((next-state (step-game! game dt)))
+    (loop-game! next-state dt)))
+
+(define (start-game! game dt)
+  (begin
+    (initialize-systems! game)
+    (loop-game! game dt)))