imugi/engine/core.scm

(module (engine core) ()
(import scheme
	(chicken base)
	(chicken module)
	(chicken sort)
	raylib
	(srfi 1)
	(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)

;; The world hash table
(define world (make-hash-table))
;; The component-sets hash table
(define component-sets (make-hash-table))

;; 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 (make-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
(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 clear-world)

;; Create an entity in the world and return it's ID
(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-rendering
	system-priority set-system-priority! system-criteria
	set-system-criteria! system-process set-system-process!)

;; The system record
(define-record-type <system>
  (internal-make-system name rendering priority criteria process)
  system?
  (name system-name)
  (rendering system-rendering)
  (priority system-priority internal-set-system-priority!)
  (criteria system-criteria internal-set-system-criteria!)
  (process system-process internal-set-system-process!))

;; Type-checked system constructor wrapper
(define (make-system name rendering priority criteria process)
  (assert (symbol? name))
  (assert (and (symbol? rendering) (member rendering '(3d 2d screen none))))
  (assert (integer? priority))
  (assert (every symbol? criteria))
  (assert (procedure? process))
  (internal-make-system name rendering priority criteria process))

;; Type-checked system priority mutator
(define (set-system-priority! system priority)
  (assert (system? system))
  (assert (integer? priority))
  (internal-set-system-priority! system priority))

;; Type-checked system criteria mutator
(define (set-system-criteria! system criteria)
  (assert (system? system))
  (assert (every symbol? criteria))
  (internal-set-system-criteria! system criteria))

;; Type-checked system process mutator
(define (set-system-process! system process)
  (assert (system? system))
  (assert (procedure? process))
  (internal-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)

;; 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
;; TODO: Implement
(define (execute-system system)
  (assert (system? system))
  #t)

(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
	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))

;; 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)))

;; Frame generation and game loop
(export resolve-queues next-frame)

;; Resolve the entity and system queues. This is exported which allows breaking iteration
(define (resolve-queues)
  (resolve-entity-queue)
  (resolve-system-queue))

;; Generate the next frame, for use in the main game loop
(define (next-frame)
  (resolve-queues)
  (with-drawing
   (execute-systems)))
)