532 lines
15 KiB
Scheme
532 lines
15 KiB
Scheme
(module (imugi core) ()
|
|
(import scheme
|
|
(chicken base)
|
|
(chicken module)
|
|
(chicken sort)
|
|
(imugi guards)
|
|
raylib
|
|
(srfi 1)
|
|
(srfi 4)
|
|
(srfi 69)
|
|
(srfi 99)
|
|
(srfi 113)
|
|
(srfi 128))
|
|
|
|
;; We export the world, component sets, systems, and event buses so that the core can be extended to
|
|
;; include serialization functions across all.
|
|
;; NOTE: direct read/write to these is undefined, and will cause problems.
|
|
(export world component-sets systems event-buses render-queues render-priority)
|
|
|
|
;; The world hash table
|
|
(define world (make-hash-table))
|
|
;; The component-sets hash table
|
|
(define component-sets (make-hash-table))
|
|
|
|
(define component-eq-comparator (make-eq-comparator))
|
|
|
|
;; Insert an entity into component-sets, either creating
|
|
;; a new set or updating an existing one for the component
|
|
;; type provided.
|
|
(define (classify-entity-by id component)
|
|
(let ((component-type (rtd-name (record-rtd component))))
|
|
(if (hash-table-exists? component-sets component-type)
|
|
(let ((component-set (hash-table-ref component-sets component-type)))
|
|
;; TODO: this could be nicer with set-adjoin! but I'm not sure if hash-table-ref is locative
|
|
(hash-table-set! component-sets
|
|
component-type
|
|
(set-adjoin component-set
|
|
id)))
|
|
(hash-table-set! component-sets
|
|
component-type
|
|
(set component-eq-comparator id)))))
|
|
|
|
;; Create an entity in the world immediately,
|
|
;; and add it to the requisite component-sets
|
|
(define (create-entity-now id components)
|
|
(hash-table-set! world id components)
|
|
(for-each
|
|
(lambda (component)
|
|
(classify-entity-by id component))
|
|
components))
|
|
|
|
;; Remove a single matching item from a set
|
|
(define (remove-from-set! set element)
|
|
(set-search! set element
|
|
(lambda (insert ignore)
|
|
(ignore #f))
|
|
(lambda (old update remove)
|
|
(remove old))))
|
|
|
|
;; Remove an entity from the world immediately,
|
|
;; as well as from all component sets.
|
|
(define (remove-entity-now id)
|
|
(hash-table-delete! world id)
|
|
(for-each
|
|
(lambda (set)
|
|
(remove-from-set! set id))
|
|
(hash-table-values component-sets)))
|
|
|
|
;; Queues for entity creation and deletion
|
|
(define add-entity-queue '())
|
|
(define del-entity-queue '())
|
|
|
|
;; Add an entity to the incoming queue
|
|
;; TODO: append! doesn't work here and IDK why
|
|
;; TODO: this could be done with cons anyway because we don't care about the order
|
|
(define (queue-add-entity id components-lst)
|
|
(set! add-entity-queue
|
|
(append add-entity-queue (list (cons id components-lst)))))
|
|
|
|
;; Add an entity to the deletion queue
|
|
(define (queue-del-entity id)
|
|
(set! del-entity-queue
|
|
(append del-entity-queue (list id))))
|
|
|
|
;; Resolve all new entity creations
|
|
(define (add-queued-entities)
|
|
(for-each
|
|
(lambda (entity)
|
|
(let ((id (car entity))
|
|
(components (cdr entity)))
|
|
(create-entity-now id components)))
|
|
add-entity-queue)
|
|
(set! add-entity-queue '()))
|
|
|
|
;; Resolve all queued entity deletions
|
|
(define (remove-queued-entities)
|
|
(for-each
|
|
(lambda (id)
|
|
(remove-entity-now id))
|
|
del-entity-queue)
|
|
(set! del-entity-queue '()))
|
|
|
|
;; Resolve all queued entity changes
|
|
(define (resolve-entity-queue)
|
|
(remove-queued-entities)
|
|
(add-queued-entities))
|
|
|
|
;; Entity creation/removal interface
|
|
(export create-named-entity create-entity remove-entity
|
|
get-entity clear-world)
|
|
|
|
(define (get-entity id)
|
|
(assert (symbol? id))
|
|
(hash-table-ref world id))
|
|
|
|
;; Get all entities by their component types
|
|
(define (query-by-components . components)
|
|
(assert (every symbol? components))
|
|
(let ((sets (map (lambda (comp) (hash-table-ref component-sets comp)) components)))
|
|
(apply set-intersection sets)))
|
|
|
|
;; Create an entity in the world and return it's ID
|
|
;; TODO: consider whether we want to use a hash-table for the entity list. I'm not sure yet how punishing O(n) lookup will be here, so it might be sometihng to look at once we start handling entity execution
|
|
(define (create-named-entity id . components)
|
|
(assert (symbol? id))
|
|
(assert (every record? components))
|
|
(queue-add-entity id components)
|
|
id)
|
|
|
|
;; Shortcut for anonymous instancing
|
|
(define (create-entity . components)
|
|
(apply create-named-entity (gensym) components))
|
|
|
|
;; Remove an entity from the world
|
|
(define (remove-entity id)
|
|
(assert (symbol? id))
|
|
(queue-del-entity id)
|
|
id)
|
|
|
|
;; Clear the entire world
|
|
(define (clear-world)
|
|
(for-each
|
|
remove-entity
|
|
(hash-table-keys world)))
|
|
|
|
;; System record interface
|
|
(export make-system system? system-name
|
|
system-priority set-system-priority! system-criteria
|
|
set-system-criteria! system-process set-system-process!)
|
|
|
|
;; The system record
|
|
(define-record-type <system>
|
|
(int:make-system name priority mode criteria process)
|
|
system?
|
|
(name system-name)
|
|
(priority system-priority int:set-system-priority!)
|
|
(mode system-mode)
|
|
(criteria system-criteria int:set-system-criteria!)
|
|
(process system-process int:set-system-process!))
|
|
|
|
;; Type-checked system constructor wrapper
|
|
(define (make-system name priority mode criteria process)
|
|
(assert (symbol? name))
|
|
(assert (integer? priority))
|
|
(assert (member mode '(entity batch global)))
|
|
(assert (every symbol? criteria))
|
|
(assert (procedure? process))
|
|
(int:make-system name priority mode criteria process))
|
|
|
|
;; Type-checked system priority mutator
|
|
(define (set-system-priority! system priority)
|
|
(assert (system? system))
|
|
(assert (integer? priority))
|
|
(int:set-system-priority! system priority))
|
|
|
|
;; Type-checked system criteria mutator
|
|
(define (set-system-criteria! system criteria)
|
|
(assert (system? system))
|
|
(assert (every symbol? criteria))
|
|
(int:set-system-criteria! system criteria))
|
|
|
|
;; Type-checked system process mutator
|
|
(define (set-system-process! system process)
|
|
(assert (system? system))
|
|
(assert (procedure? process))
|
|
(int:set-system-process! system process))
|
|
|
|
;; The systems list
|
|
(define systems '())
|
|
|
|
;; Immediately add a new system
|
|
(define (add-system-now system)
|
|
(set! systems
|
|
(append systems (list system))))
|
|
|
|
;; Immediately remove a new system
|
|
(define (remove-system-now name)
|
|
(set! systems
|
|
(delete name systems
|
|
(lambda (n el)
|
|
(eqv? n (system-name el))))))
|
|
|
|
;; Sort the systems list by priority
|
|
(define (sort-systems)
|
|
(sort! systems
|
|
(lambda (x y)
|
|
(< (system-priority x)
|
|
(system-priority y)))))
|
|
|
|
;; System addition/deletion queues
|
|
(define add-system-queue '())
|
|
(define del-system-queue '())
|
|
|
|
;; Add a system to the incoming queue
|
|
(define (queue-add-system system)
|
|
(set! add-system-queue
|
|
(append add-system-queue (list system))))
|
|
|
|
;; Add a system to the deletion queue
|
|
(define (queue-del-system name)
|
|
(set! del-system-queue
|
|
(append del-system-queue (list name))))
|
|
|
|
;; Resolve all new system creations
|
|
(define (add-queued-systems)
|
|
(for-each
|
|
(lambda (system)
|
|
(add-system-now system))
|
|
add-system-queue)
|
|
(set! add-system-queue '()))
|
|
|
|
;; Resolve all queued system deletions
|
|
(define (remove-queued-systems)
|
|
(for-each
|
|
(lambda (system-name)
|
|
(remove-system-now system-name))
|
|
del-system-queue)
|
|
(set! del-system-queue '()))
|
|
|
|
;; Resolve all queued system changes
|
|
(define (resolve-system-queue)
|
|
(remove-queued-systems)
|
|
(add-queued-systems)
|
|
(sort-systems))
|
|
|
|
;; System creation/removal interface
|
|
(export add-system remove-system clear-systems execute-system execute-systems)
|
|
|
|
;; Add a system to the state processing and return its name
|
|
(define (add-system system)
|
|
(assert (system? system))
|
|
(queue-add-system system)
|
|
(system-name system))
|
|
|
|
;; Remove a system from process
|
|
(define (remove-system name)
|
|
(assert (symbol? name))
|
|
(queue-del-system name)
|
|
name)
|
|
|
|
(define (clear-systems)
|
|
(for-each
|
|
remove-system
|
|
(map system-name systems)))
|
|
|
|
;; Execute a single system
|
|
(define (execute-system system)
|
|
(assert (system? system))
|
|
(if (eqv? (system-mode system) 'global)
|
|
((system-process system))
|
|
(let ((entities (map get-entity (set->list (apply query-by-components (system-criteria system))))))
|
|
(cond
|
|
((eqv? (system-mode system) 'batch) ((system-process system) entities))
|
|
((eqv? (system-mode system) 'entity)
|
|
(for-each (lambda (e)
|
|
(apply (system-process system)
|
|
(cons e
|
|
(map (lambda (component)
|
|
(find (lambda (c)
|
|
(eqv? (rtd-name (record-rtd c))
|
|
component))
|
|
e))
|
|
(system-criteria system)))))
|
|
entities))))))
|
|
|
|
(define (execute-systems)
|
|
(for-each
|
|
execute-system
|
|
systems))
|
|
|
|
;; Event buses hash table
|
|
(define event-buses (make-hash-table))
|
|
|
|
;; Event bus interface
|
|
(export register-event-bus remove-event-bus fetch-event-bus
|
|
clear-event-bus push-event peek-event pop-event)
|
|
|
|
;; Register a new event bus
|
|
(define (register-event-bus name)
|
|
(assert (symbol? name))
|
|
(if (hash-table-exists? event-buses name)
|
|
#f
|
|
(begin
|
|
(hash-table-set! event-buses name (make-hash-table))
|
|
name)))
|
|
|
|
;; Remove an event bus
|
|
(define (remove-event-bus name)
|
|
(assert (symbol? name))
|
|
(if (hash-table-exists? event-buses name)
|
|
(begin
|
|
(hash-table-delete! event-buses name)
|
|
name)
|
|
#f))
|
|
|
|
(define (clear-event-bus name)
|
|
(assert (symbol? name))
|
|
(let ((event-bus (fetch-event-bus name)))
|
|
(if event-bus
|
|
(begin
|
|
(for-each
|
|
(lambda (key)
|
|
(hash-table-delete! event-bus key))
|
|
(hash-table-keys event-bus))
|
|
#t)
|
|
#f)))
|
|
|
|
;; Fetch an event bus by name, or #f if it doesn't exist
|
|
(define (fetch-event-bus name)
|
|
(assert (symbol? name))
|
|
(if (hash-table-exists? event-buses name)
|
|
(hash-table-ref event-buses name)
|
|
#f))
|
|
|
|
;; Push an event to the specified bus, return #f on failure (if the bus doesn't exist
|
|
(define (push-event bus action event)
|
|
(assert (symbol? bus))
|
|
(assert (symbol? action))
|
|
(assert (record? event))
|
|
(let ((event-bus (fetch-event-bus bus)))
|
|
(if event-bus
|
|
(begin
|
|
(hash-table-set! event-bus action event)
|
|
#t)
|
|
#f)))
|
|
|
|
;; Retrieve an event from the event bus, if it exists. Return false if it doesn't
|
|
(define (peek-event bus action)
|
|
(assert (symbol? bus))
|
|
(assert (symbol? action))
|
|
(let ((event-bus (fetch-event-bus bus)))
|
|
(if (and event-bus
|
|
(hash-table-exists? event-bus action))
|
|
(hash-table-ref event-bus action)
|
|
#f)))
|
|
|
|
;; Retrieve an event from the event bus, if it exists, then delete it. Return false if it doesn't exist.
|
|
(define (pop-event bus action)
|
|
(assert (symbol? bus))
|
|
(assert (symbol? action))
|
|
(let ((event-bus (fetch-event-bus bus)))
|
|
(if (and event-bus
|
|
(hash-table-exists? event-bus action))
|
|
(let ((event (hash-table-ref event-bus action)))
|
|
(hash-table-delete! event-bus action)
|
|
event)
|
|
#f)))
|
|
|
|
;; Render queue exports
|
|
(export register-render-queue push-render-object evaluate-render-queue)
|
|
|
|
;; Render queues
|
|
(define render-queues (make-hash-table))
|
|
(define render-priority '())
|
|
|
|
;; Register a new render queue
|
|
(define (register-render-queue name drawing)
|
|
(assert (symbol? name))
|
|
(assert (and (symbol? drawing) (member drawing '(screen 2d 3d))))
|
|
(if (hash-table-exists? render-queues name)
|
|
#f
|
|
(begin
|
|
(hash-table-set! render-queues name '())
|
|
(set! render-priority (cons (cons name drawing) render-priority))
|
|
name)))
|
|
|
|
;; Default render queues
|
|
(register-render-queue '3d '3d)
|
|
(register-render-queue '2d '2d)
|
|
(register-render-queue 'screen 'screen)
|
|
|
|
;; TODO: camera selection needs a better solution, ideally treating the camera
|
|
;; as an entity.
|
|
(define *active-camera-2d* (make-parameter '()))
|
|
(define *active-camera-3d* (make-parameter '()))
|
|
|
|
;; Push a render call to the queue
|
|
(define (push-render-object queue-name layer thunk)
|
|
(assert (symbol? queue-name))
|
|
(assert (integer? layer))
|
|
(assert (procedure? thunk))
|
|
(hash-table-set! render-queues queue-name
|
|
(cons (cons layer thunk) (hash-table-ref render-queues queue-name))))
|
|
|
|
;; Evaluate a single render queue with a specific mode.
|
|
;; Render objects are sorted by their layer
|
|
(define (evaluate-render-queue queue-name mode)
|
|
(assert (symbol? queue-name))
|
|
(assert (symbol? mode) (member mode '(screen 2d 3d)))
|
|
(let ((queue (hash-table-ref render-queues queue-name)))
|
|
(when (or (eq? mode 'screen)
|
|
(and (eq? mode '2d)
|
|
(not (null? (*active-camera-2d*))))
|
|
(and (eq? mode '3d)
|
|
(not (null? (*active-camera-3d*)))))
|
|
(when (eq? mode '2d)
|
|
(begin-mode-2d (*active-camera-2d*)))
|
|
(when (eq? mode '3d)
|
|
(begin-mode-3d (*active-camera-3d*)))
|
|
(for-each
|
|
(lambda (render-obj) ((cdr render-obj)))
|
|
(sort queue
|
|
(lambda (render-obj-a render-obj-b)
|
|
(< (car render-obj-a)
|
|
(car render-obj-b)))))
|
|
(when (eq? mode '2d)
|
|
(end-mode-2d))
|
|
(when (eq? mode '3d)
|
|
(end-mode-3d)))
|
|
(hash-table-set! render-queues queue-name '())))
|
|
|
|
;; Resource queue
|
|
(export resource-load-queue resource-unload-queue)
|
|
(define resource-load-queue '())
|
|
(define resource-unload-queue '())
|
|
|
|
(export make-resource resource? resource-type resource-contents resource-initialized? resource-initializer resource-finalizer set-resource-contents! set-resource-initialized!)
|
|
(define-record-type <resource>
|
|
(int:make-resource type struct initialized? initializer finalizer)
|
|
resource?
|
|
(type resource-type)
|
|
(struct resource-contents set-resource-contents!)
|
|
(initialized? resource-initialized? set-resource-initialized!)
|
|
(initializer resource-initializer)
|
|
(finalizer resource-finalizer))
|
|
|
|
(define (add-resource res)
|
|
(assert (resource? res))
|
|
(set! resource-load-queue (cons res resource-load-queue)))
|
|
|
|
(define (make-resource type struct initialized? initializer finalizer)
|
|
(assert (member type '(font texture)))
|
|
(assert (boolean? initialized?))
|
|
(assert (procedure? initializer))
|
|
(assert (procedure? finalizer))
|
|
(let ((r (int:make-resource type struct initialized? initializer finalizer)))
|
|
(add-resource r)
|
|
r))
|
|
|
|
(define (load-queued-resources)
|
|
(for-each
|
|
(lambda (res)
|
|
((resource-initializer res) res)
|
|
(set! resource-unload-queue (cons res resource-unload-queue)))
|
|
resource-load-queue)
|
|
(set! resource-load-queue '()))
|
|
|
|
(define (unload-queued-resources)
|
|
(for-each
|
|
(lambda (res)
|
|
((resource-finalizer res) res))
|
|
resource-unload-queue)
|
|
(set! resource-unload-queue '()))
|
|
|
|
;; Frame generation and game loop
|
|
(export resolve-queues next-frame *clear-color* perform-render)
|
|
|
|
;; Resolve the entity and system queues. This is exported which allows breaking iteration
|
|
(define (resolve-queues)
|
|
(load-queued-resources)
|
|
(resolve-entity-queue)
|
|
(resolve-system-queue))
|
|
|
|
;; Clear color
|
|
(define *clear-color* (guarded-parameter RAYWHITE u8vector?))
|
|
|
|
;; Render all queues
|
|
(define (perform-render)
|
|
(begin-drawing)
|
|
(clear-background (*clear-color*))
|
|
(for-each
|
|
(lambda (queue-spec)
|
|
(evaluate-render-queue (car queue-spec)
|
|
(cdr queue-spec)))
|
|
render-priority)
|
|
(end-drawing))
|
|
|
|
;; Generate the next frame, for use in the main game loop
|
|
(define (next-frame)
|
|
(resolve-queues)
|
|
(execute-systems)
|
|
(perform-render))
|
|
|
|
;; Window creation
|
|
(export *window-size* *window-title* *target-fps* create-window)
|
|
|
|
;; Window size to use
|
|
(define *window-size* (guarded-parameter '(768 . 576)
|
|
(lambda (x)
|
|
(and (pair? x)
|
|
(integer? (car x))
|
|
(integer? (cdr x))))))
|
|
|
|
;; Window title
|
|
(define *window-title* (guarded-parameter "imugi"
|
|
string?))
|
|
|
|
;; Desired FPS count
|
|
(define *target-fps* (guarded-parameter 60
|
|
integer?))
|
|
|
|
;; Make a window with the above parameters and default processing and predicate
|
|
(define (create-window #!key (process next-frame) (close-predicate window-should-close?))
|
|
(init-window (car (*window-size*)) (cdr (*window-size*)) (*window-title*))
|
|
(set-target-fps (*target-fps*))
|
|
(let loop ()
|
|
(process)
|
|
(unless (close-predicate)
|
|
(loop)))
|
|
(unload-queued-resources)
|
|
(close-window))
|
|
)
|