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

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

;; 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-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 criteria process)
  system?
  (name system-name)
  (priority system-priority int:set-system-priority!)
  (criteria system-criteria int:set-system-criteria!)
  (process system-process int:set-system-process!))

;; Type-checked system constructor wrapper
(define (make-system name priority criteria process)
  (assert (symbol? name))
  (assert (integer? priority))
  (assert (every symbol? criteria))
  (assert (procedure? process))
  (int:make-system name priority 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)

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

(register-event-bus 'input)

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

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

;; Frame generation and game loop
(export resolve-queues next-frame *clear-color* perform-render)

;; Utility function for guarding parameter values
(define (guarded-parameter default predicate)
  (make-parameter default (lambda (val)
			    (if (predicate val)
				val
				default))))

;; Resolve the entity and system queues. This is exported which allows breaking iteration
(define (resolve-queues)
  (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)
  (perform-render))

;; Window creation
(export *window-size* *window-title* 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?))

(define (create-window #!key (process next-frame) (close-predicate window-should-close?))
  (init-window (car (*window-size*)) (cdr (*window-size*)) (*window-title*))
  (let loop ()
    (process)
    (unless (close-predicate)
      (loop)))
  (close-window))
)