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

I dunno anymore

Browse source
This commit is contained in:
TakeV 2024-05-26 12:35:23 -04:00
parent 32b288c1df
commit d2f3b39bff
Signed by: TakeV
GPG key ID: A64F41345C7400AF
8 changed files with 179 additions and 93 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

133
modules/ces/system-manager.scm
View file

@ -8,6 +8,8 @@
(define-module (ces system-manager)
#:pure
#:use-module (logging)
#:use-module (hoot debug)
#:use-module (hoot match)
#:use-module (scheme base)
#:use-module (scheme case-lambda)
#:use-module (hoot hashtables)
@ -17,6 +19,9 @@
#:export (system-manager?
create-system-manager
add-system-to-system-manager
system-manager-systems
set-system-manager-systems!
system-manager-proc-table
apply-systems-to-entity!
remove-systems-from-entity!
@ -32,71 +37,92 @@
(define-record-type <system-manager>
(make-system-manager systems proc-table)
system-manager?
(systems systems)
(systems system-manager-systems set-system-manager-systems!)
(proc-table system-manager-proc-table))
(define (add-system-to-system-manager sys-manager sys)
"Returns a new system manager with sys added,
or false if the input is invalid."
(if (and (system-manager? sys-manager)
(system? sys))
(system? sys)
(list? (system-manager-systems sys-manager)))
(let ((proc-table (system-manager-proc-table sys-manager))
(old-systems (systems sys-manager)))
(old-systems (system-manager-systems sys-manager)))
(pk "Add system:"
"sys" sys
"old-systems" old-systems
"proc-table" (hashtable-entries proc-table))
(make-system-manager (cons sys old-systems) proc-table))
(error "Invalid inputs to add-system-to-system-manager" sys-manager sys)))
(define (%add-systems-to-manager! manager sys-list)
(if (system-manager? manager)
(begin
(write-log! "Running system-manager:%add-systems-to-manager!"
(system-manager? manager))
(let ((current-systems (system-manager-systems manager)))
(write-log! "Obtained systems successfully")
(set-system-manager-systems! manager
(append sys-list
current-systems))))
(error "Invalid inputs to %add-systems-to-manager!" manager sys-list)))
(define create-system-manager
(case-lambda
(()
(make-system-manager '() (make-eq-hashtable)))
(write-log! "Running system-manager:create-system-manager with no arguments")
(make-system-manager (list) (make-eq-hashtable)))
((sys-list)
(cond
((list? sys-list)
(let* ((new-sys-manager (create-system-manager))
(for-each-proc
(lambda (sys)
(if (system? sys)
(add-system-to-system-manager new-sys-manager sys)
(error "Invalid system passed to create-system-manager" sys)))))
(for-each for-each-proc sys-list)
new-sys-manager))
(else (error "Incorrect parameter passed to create-system-manager"
sys-list))))))
(match sys-list
((? list?)
(write-log! "Running system-manager:create-system-manager with list argument")
(let ((new-sys-manager (create-system-manager)))
(%add-systems-to-manager! new-sys-manager sys-list)
new-sys-manager))
((? system-manager?)
(write-log! "Running system-manager:create-system-manager with system-manager argument")
(make-system-manager (system-manager-systems sys-list)
(system-manager-proc-table sys-list)))
(else (error "Incorrect parameter passed to create-system-manager"
sys-list))))))
(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))
(let* ((proc-table (system-manager-proc-table sys-manager))
(entity-id (game-entity-id entity)))
(hashtable-ref proc-table entity-id '()))
(error "Invalid inputs to get-procs-from-table" sys-manager entity)))
(define (add-proc-to-table! sys-manager system entity)
(write-log! "Runnig system-manager:add-proc-to-table!")
(if (and (system-manager? sys-manager)
(system? system)
(game-entity? entity))
(let ((proc-table (system-manager-proc-table sys-manager))
(let ((entity-id (game-entity-id entity))
(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)))
(write-log! "Adding proc to table for system" (system-name system)
"- on entity" entity-id)
(hashtable-set! proc-table entity-id (cons proc proc-table-entry)))
(error "Invalid inputs to add-proc-to-table!" sys-manager system entity)))
(define (apply-systems-to-entity! sys-manager entity)
(write-log! "Running system-manager:apply-systems-to-entity!")
(if (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)))
(let* ((sys-list (system-manager-systems sys-manager))
(proc-table (system-manager-proc-table sys-manager))
(entity-id (game-entity-id entity)))
(begin
(hashtable-clear! proc-table)
(hashtable-delete! proc-table (game-entity-id entity))
(for-each (lambda (sys)
(let ((add-hook (system-entity-added-hook sys)))
(add-proc-to-table! sys-manager sys entity)
(when add-hook
(add-hook entity))))
applied-systems)))
(write-log! "Applying system:" (system-name sys)
"- to entity" entity-id)
(add-proc-to-table! sys-manager sys entity))
sys-list))
(write-log! "Applied systems to" (game-entity-id entity)))
(error "Invalid inputs to apply-systems-to-entity!" sys-manager entity)))
(define (remove-systems-from-entity! sys-manager entity)
@ -110,28 +136,47 @@ or false if the input is invalid."
(let ((removed-hook (system-entity-removed-hook sys)))
(when removed-hook
(removed-hook entity))))
(systems sys-manager))))
(system-manager-systems sys-manager))))
(error "Invalid inputs to remove-systems-from-entity!" sys-manager entity)))
(define (%thunkify-system procs dt)
(map (lambda (proc)
(lambda ()
(proc dt)))
procs))
(write-log! "Running system-manager:%thunkify-system"
"Is table?" (hashtable? procs)
"Is list?" (list? procs)
"Is vector?" (vector? procs))
(let ((thunks
(map (lambda (proc)
(write-log! "Current proc" proc)
(lambda ()
(proc dt)))
procs)))
(write-log! "Created thunks!" thunks)
thunks))
(define (get-thunks sys-manager dt)
(write-log! "Running system-manager:get-thunks"
"Is proc table set?" (hashtable?
(system-manager-proc-table sys-manager))
"proc-table entries:" (hashtable-entries (system-manager-proc-table sys-manager)))
(if (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)))
(let* ((proc-table (system-manager-proc-table sys-manager))
(thunk-generator
(lambda (procs)
(%thunkify-system procs dt)))
(entries (hashtable-entries proc-table)))
(vector-map thunk-generator entries))
(error "Invalid inputs to get-thunks" sys-manager dt)))
(define (run-systems! sys-manager dt)
"Executes every valid system."
(if (system-manager? sys-manager)
(write-log! "Running system-manager:run-systems!"
(system-manager-systems sys-manager))
(if (and (system-manager? sys-manager)
(list? (system-manager-systems sys-manager)))
(let ((thunks (get-thunks sys-manager dt)))
(write-log! "Generated thunks" thunks)
(vector-for-each (lambda (proc)
(write-log! "Running thunk" proc)
(proc))
thunks))
(error "Invalid inputs to run-systems!" sys-manager dt)))
@ -144,7 +189,7 @@ if one exists."
(let ((sys-pre-process (system-pre-process sys)))
(when sys-pre-process
(sys-pre-process))))
(systems sys-manager))
(system-manager-systems sys-manager))
(error "Invalid input to run-systems-pre-process!" sys-manager)))
(define (run-systems-post-process! sys-manager)
@ -155,5 +200,5 @@ if one exists."
(let ((sys-post-process (system-post-process sys)))
(when sys-post-process
(sys-post-process))))
(systems sys-manager))
(system-manager-systems sys-manager))
(error "Invalid input to run-systems-post-process!" sys-manager)))

28
modules/ces/system.scm
View file

@ -20,8 +20,9 @@
#:use-module (scheme case-lambda)
#:use-module ((hoot syntax) #:select (define*))
#:use-module (ces entity)
#:use-module (logging)
#:export (create-system
make-system
system-name
system?
system-predicate?
system-process-entity
@ -40,8 +41,10 @@
pre-process
post-process
entity-added-hook
entity-removed-hook)
entity-removed-hook
name)
system?
(name system-name)
(predicate system-predicate?) ;; (entity) -> bool
(process-entity system-process-entity) ;; (entity, dt) -> whatever
(post-process system-post-process) ;; thunk
@ -49,21 +52,24 @@
(entity-added-hook system-entity-added-hook) ;; entity -> whatever
(entity-removed-hook system-entity-removed-hook)) ;; entity -> whatever
(define* (create-system predicate process
(define* (create-system predicate process name
#:key
(pre-process #f)
(post-process #f)
(entity-added-hook #f)
(entity-removed-hook #f))
(write-log! "Running system:create-system")
(make-system predicate
process
pre-process
post-process
entity-added-hook
entity-removed-hook))
entity-removed-hook
name))
(define (system-applicable-to-entity? entity system)
(and (game-entity? entity) (system? system)
(and (game-entity? entity)
(system? system)
((system-predicate? system) entity)))
(define (apply-system-to-entity system entity)
@ -72,6 +78,12 @@ 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))))
(write-log! "Running system:apply-system-to-entity"
"System?" (system? system)
"System process" (system-process-entity system)
"System name" (system-name system))
(let* ((sys-proc (system-process-entity system))
(wrapped-proc (lambda (dt)
(sys-proc entity dt))))
(write-log! "System-applied to entity successfully")
wrapped-proc))

42
modules/ces/system/html-canvas-renderer.scm
View file

@ -2,6 +2,7 @@
#:pure
#:use-module (scheme base)
#:use-module (scheme case-lambda)
#:use-module (hoot debug)
#:use-module (ces component)
#:use-module (ces entity)
#:use-module (ces system)
@ -9,6 +10,7 @@
#:use-module (ces system tilemap-renderer)
#:use-module (ces system-manager)
#:use-module (game-core)
#:use-module (logging)
#:export (create-html-canvas-renderer))
;; The canvas renderer requires an entity to have a position,
@ -18,7 +20,6 @@
(or (has-component? entity 'sprite)
(has-component? entity 'tilemap))))
(define (make-image-renderer draw-function canvas-context)
"Returns a proceedure which calls the underlying html5 canvas
drawImage function. Arities include:
@ -35,35 +36,44 @@
(define (%make-rendering-systems draw-function canvas-context)
"Returns a list of rendering systems."
(write-log! "Running html-canvas-renderer:%make-rendering-systems")
(let ((draw-proc (make-image-renderer draw-function canvas-context)))
(list (create-tilemap-renderer draw-proc)
(create-sprite-rendering-system draw-proc))))
(list
(create-tilemap-renderer draw-proc)
(create-sprite-rendering-system draw-proc))))
(define (%add-entity-to-renderer! entity)
(when (game-entity? entity)
(let ((sys-manager (get-system-manager)))
(apply-systems-to-entity! sys-manager entity))))
(define (%add-entity-to-renderer! sys-manager entity)
(write-log! "Running html-canvas-renderer:%add-entity-to-renderer!")
(if (and (game-entity? entity)
(system-manager? sys-manager))
(apply-systems-to-entity! sys-manager entity)
(error "Invalid inputs to html-canvas-renderer:%add-entity-to-renderer!"
sys-manager entity)))
(define (%entity-removed-hook entity)
(when (game-entity? entity)
(remove-systems-from-entity! (get-system-manager) entity)))
(define (%run-rendering-subsystems! dt)
(define (%run-rendering-subsystems! sys-manager dt)
(let ((sys-manager (get-system-manager)))
(begin
(write-log! "Running html-canvas-renderer" dt)
(run-systems-pre-process! sys-manager)
(run-systems! sys-manager dt)
(run-systems-post-process! sys-manager))))
(define (%system-process-proc entity dt)
(let ((sys-manager (get-system-manager)))
(%add-entity-to-renderer! entity)
(%run-rendering-subsystems! dt)))
(define (%system-process-proc subsystem-manager entity dt)
(%add-entity-to-renderer! subsystem-manager entity)
(%run-rendering-subsystems! subsystem-manager dt))
(define (create-html-canvas-renderer draw-function context)
(write-log! "Running html-canvas-renderer:create-html-canvas-renderer")
(let* ((rendering-subsystems (%make-rendering-systems draw-function context))
(rendering-subsystem-manager (create-system-manager rendering-subsystems)))
(parameterize ((*system-manager-parameter* rendering-subsystem-manager))
(create-system wants-entity?
%system-process-proc
#:entity-removed-hook %entity-removed-hook))))
(create-system wants-entity?
(lambda (entity dt)
(write-log! "Running html-canvas-renderer")
(%system-process-proc rendering-subsystem-manager
entity dt))
'html-canvas-renderer
#:entity-removed-hook %entity-removed-hook)))

8
modules/ces/system/keyboard-reader.scm
View file

@ -16,7 +16,8 @@
#:use-module (dom canvas)
#:export (create-keyboard-reader))
(define system-wants '('keyboard-inputs))
(define (%system-wants-entity? entity)
(has-components? entity 'keyboard-inputs))
(define %current-input-state
(make-atomic-box #f))
@ -97,6 +98,7 @@
(define (create-keyboard-reader current-document keys-to-monitor)
(begin (%register-callbacks! current-document keys-to-monitor)
(create-system (apply has-components? system-wants)
(create-system %system-wants-entity?
(lambda (entity dt)
(%set-entity-input-component! entity)))))
(%set-entity-input-component! entity))
'keyboard-reader)))

10
modules/ces/system/sprite-renderer.scm
View file

@ -15,7 +15,7 @@
(define (wants-entity? entity)
(and (game-entity? entity)
(apply has-components? desired-components)))
(has-components? entity 'position 'sprite)))
(define (render-entity entity renderer)
(let ((sprite (get-component entity 'sprite))
@ -28,8 +28,12 @@
(y (position-y position)))
(renderer image x y width height)))))
(define (%make-system-proc renderer)
(lambda (entity dt)
(render-entity entity renderer)))
(define (create-sprite-rendering-system renderer)
"Calls renderer on an entity which has a position and sprite."
(create-system wants-entity?
(lambda (entity dt)
(render-entity entity renderer))))
(%make-system-proc renderer)
'sprite-renderer))

31
modules/ces/system/tilemap-renderer.scm
View file

@ -11,7 +11,7 @@
(define (wants-entity? entity)
(and (game-entity? entity)
(apply has-components? desired-components)))
(has-components? entity 'tilemap)))
(define (render-tilemap renderer entity dt)
(lambda (dt)
@ -22,23 +22,24 @@
(ts-tile-width (ts-tile-width tm-tileset))
(ts-tile-height (ts-tile-height tm-tileset)))
(for-each (lambda (layer)
(let ((data (tl-data layer))
(x-offset (tl-x layer))
(y-offset (tl-y layer))
(tl-width (tl-width layer))
(tl-height (tl-height layer)))
(for-each (lambda (index)
(let* ((tile (vector-ref ts-tiles index))
(img (tile-image tile))
(tile-width (tile-width tile))
(tile-height (tile-height tile))
(x (+ x-offset (* (modulo index tl-width) ts-tile-width)))
(y (+ y-offset (* (modulo index tl-height) ts-tile-height))))
(renderer img x y tile-width tile-height))) data))) tm-layers))))
(let ((data (tl-data layer))
(x-offset (tl-x layer))
(y-offset (tl-y layer))
(tl-width (tl-width layer))
(tl-height (tl-height layer)))
(for-each (lambda (index)
(let* ((tile (vector-ref ts-tiles index))
(img (tile-image tile))
(tile-width (tile-width tile))
(tile-height (tile-height tile))
(x (+ x-offset (* (modulo index tl-width) ts-tile-width)))
(y (+ y-offset (* (modulo index tl-height) ts-tile-height))))
(renderer img x y tile-width tile-height))) data))) tm-layers))))
(define (create-tilemap-renderer renderer)
(create-system wants-entity?
(lambda (entity dt)
(render-tilemap renderer entity dt))))
(render-tilemap renderer entity dt))
'tilemap-renderer))

17
modules/game-core.scm
View file

@ -50,8 +50,15 @@
(begin
(vector-for-each
(lambda (entity)
(apply-systems-to-entity! s-manager entity))
(write-log! "Applying system to entity:" (game-entity-id entity))
(if (and (game-entity? entity)
(system-manager? s-manager))
(apply-systems-to-entity! s-manager entity)
(error "Unable to apply systems to entity"
s-manager entity))
(write-log! "Applied system to entity:" (game-entity-id entity)))
(get-current-entities e-manager))
(write-log! "Initialization complete.")
(make-game e-manager s-manager 0))
(error "Game in incorrect state. System manager or entity manager incorrect."
e-manager s-manager))))
@ -60,9 +67,13 @@
"Returns a new game-state after dt"
(let* ((e-manager (game-entity-manager game))
(s-manager (game-system-manager game)))
(write-log! "Running game step")
(parameterize ((*entity-manager-parameter* e-manager)
(write-log! "Running game step" dt)
(parameterize ((*logger* pk)
(*entity-manager-parameter* e-manager)
(*system-manager-parameter* s-manager))
(write-log! "system-manager information:"
(system-manager-systems s-manager)
(system-manager-proc-table s-manager))
(write-log! "Running pre-process")
(run-systems-pre-process! s-manager)
(write-log! "Running systems")

3
modules/game/game-manager.scm
View file

@ -2,6 +2,7 @@
#:pure
#:use-module (scheme base)
#:use-module (ces system html-canvas-renderer)
#:use-module (ces system sprite-renderer)
#:use-module (dom image)
#:use-module (media)
#:use-module (ces component tilemap)
@ -38,4 +39,4 @@
(define (init-game-systems draw-proc context)
"Returns a list of initial game systems.
Note: Systems are executed sequentially. "
(list (create-html-canvas-renderer draw-proc context)))
(list (create-sprite-rendering-system draw-proc)))