BirDt/imugi
1
0
Fork 0
Code Issues 14 Pull requests Projects 1 Wiki Activity Actions

Simplifying engine interface #14

Merged
BirDt merged 14 commits from feature/basic-samples into master 2026-04-18 09:12:01 +08:00
Conversation 0 Commits 14 Files changed 6 +554 -503
6 changed files with 554 additions and 503 deletions
Download patch file Download diff file Expand all files Collapse all files

381
engine/components.scm
View file

@ -2,220 +2,12 @@
(import scheme (import scheme
(chicken base) (chicken base)
(chicken module) (chicken module)
(engine core)
(engine guards) (engine guards)
(engine math)
(srfi 1) (srfi 1)
(srfi 4)
(srfi 99)) (srfi 99))
;; Vector exports
(export make-vector2 vector2? vector-x
set-vector-x! vector-y set-vector-y!)
;; 2D Vector type
;; TODO: this could be done with a macro to save some definitions
(define-record-type <vector2>
(int:make-vector2 x y)
vector2?
(x vector2-x int:set-vector2-x!)
(y vector2-y int:set-vector2-y!))
;; Type safe 2D vector constructor
(define (make-vector2 x y)
(assert (number? x))
(assert (number? y))
(int:make-vector2 x y))
;; Type safe 2D vector setter
(define (set-vector2-x! vector2 x)
(assert (vector2? vector2))
(assert (number? x))
(int:set-vector2-x! vector2 x))
;; Type safe 2D vector setter
(define (set-vector2-y! vector2 y)
(assert (vector2? vector2))
(assert (number? y))
(int:set-vector2-y! vector2 y))
;; Vector utility functions
(define (vector-x component)
(assert (record? component))
((rtd-accessor (record-rtd component) 'x) component))
(define (set-vector-x! component x)
(assert (record? component))
(assert (number? x))
((rtd-mutator (record-rtd component) 'x) component x))
(define (vector-y component)
(assert (record? component))
((rtd-accessor (record-rtd component) 'y) component))
(define (set-vector-y! component y)
(assert (record? component))
(assert (number? y))
((rtd-mutator (record-rtd component) 'y) component y))
;; Export vector functions
(export vector-= vector-+ vector-- vector-* vector-/
vector-magnitude vector-normalize vector-dot
vector-angle-between)
;; TODO: make this function accept any number of vectors
(define (vector-= vec1 vec2)
(assert (and (record? vec1)
(record? vec2)))
(assert (eq? (rtd-name (record-rtd vec1))
(rtd-name (record-rtd vec2))))
(assert ((disjoin vector2?) vec1))
(cond
((vector2? vec1)
(and (= (vector-x vec1) (vector-x vec2))
(= (vector-y vec1) (vector-y vec2))))))
;; TODO: make this function accept any number of vectors
(define (vector-+ vec1 vec2)
(assert (and (record? vec1)
(record? vec2)))
(assert (eq? (rtd-name (record-rtd vec1))
(rtd-name (record-rtd vec2))))
(assert ((disjoin vector2?) vec1))
(cond
((vector2? vec1)
(make-vector2 (+ (vector-x vec1) (vector-x vec2))
(+ (vector-y vec1) (vector-y vec2))))))
;; TODO: make this function accept any number of vectors
(define (vector-- vec1 vec2)
(assert (and (record? vec1)
(record? vec2)))
(assert (eq? (rtd-name (record-rtd vec1))
(rtd-name (record-rtd vec2))))
(assert ((disjoin vector2?) vec1))
(cond
((vector2? vec1)
(make-vector2 (- (vector-x vec1) (vector-x vec2))
(- (vector-y vec1) (vector-y vec2))))))
;; TODO: make this function accept any number of vectors
(define (vector-* vec1 vec2)
(assert (and (record? vec1)
(record? vec2)))
(assert (eq? (rtd-name (record-rtd vec1))
(rtd-name (record-rtd vec2))))
(assert ((disjoin vector2?) vec1))
(cond
((vector2? vec1)
(make-vector2 (* (vector-x vec1) (vector-x vec2))
(* (vector-y vec1) (vector-y vec2))))))
;; TODO: make this function accept any number of vectors
(define (vector-/ vec1 vec2)
(assert (and (record? vec1)
(record? vec2)))
(assert (eq? (rtd-name (record-rtd vec1))
(rtd-name (record-rtd vec2))))
(assert ((disjoin vector2?) vec1))
(cond
((vector2? vec1)
(make-vector2 (/ (vector-x vec1) (vector-x vec2))
(/ (vector-y vec1) (vector-y vec2))))))
;; Magnitude
(define (vector-magnitude vec)
(assert ((disjoin vector2?) vec))
(cond
((vector2? vec)
(sqrt (+ (expt (vector-x vec) 2)
(expt (vector-y vec) 2))))))
(define (vector-dot vec1 vec2)
(assert (and (record? vec1)
(record? vec2)))
(assert (eq? (rtd-name (record-rtd vec1))
(rtd-name (record-rtd vec2))))
(assert ((disjoin vector2?) vec1))
(cond
((vector2? vec1)
(+ (* (vector-x vec1) (vector-x vec2))
(* (vector-y vec1) (vector-y vec2))))))
(define (vector-angle-between vec1 vec2)
(assert (and (record? vec1)
(record? vec2)))
(assert (eq? (rtd-name (record-rtd vec1))
(rtd-name (record-rtd vec2))))
(assert ((disjoin vector2?) vec1))
(cond
((vector2? vec1)
(acos (/ (vector-dot vec1 vec2)
(* (vector-magnitude vec1)
(vector-magnitude vec2)))))))
;; Normalization
(define (vector-normalize vec)
(assert ((disjoin vector2?) vec)) ;; TODO: This assertion should be moved out of here
(let ((magnitude (vector-magnitude vec)))
(cond
((vector2? vec)
(make-vector2 (/ (vector-x vec)
magnitude)
(/ (vector-y vec)
magnitude))))))
;; Color exports
(export make-color use-color color-r color-g color-b color-a
set-color-r! set-color-g! set-color-b! set-color-a!)
;; Color type
(define-record-type <color>
(int:make-color r g b a)
color?
(r color-r int:set-color-r!)
(g color-g int:set-color-g!)
(b color-b int:set-color-b!)
(a color-a int:set-color-a!))
;; Get a raylib color vector from a color
(define (use-color col)
(assert (color? col))
(u8vector (floor (* 255 (color-r col)))
(floor (* 255 (color-g col)))
(floor (* 255 (color-b col)))
(floor (* 255 (color-a col)))))
;; Type safe color constructor
(define (make-color r g b a)
(assert (and (number? r) (<= 0 r 1)))
(assert (and (number? g) (<= 0 g 1)))
(assert (and (number? b) (<= 0 b 1)))
(assert (and (number? a) (<= 0 a 1)))
(int:make-color r g b a))
;; Type safe color setter
(define (set-color-r! color r)
(assert (color? color))
(assert (and (number? r) (<= 0 r 1)))
(int:set-color-r! color r))
;; Type safe color setter
(define (set-color-g! color g)
(assert (color? color))
(assert (and (number? g) (<= 0 g 1)))
(int:set-color-g! color g))
;; Type safe color setter
(define (set-color-b! color b)
(assert (color? color))
(assert (and (number? b) (<= 0 b 1)))
(int:set-color-b! color b))
;; Type safe color setter
(define (set-color-a! color a)
(assert (color? color))
(assert (and (number? a) (<= 0 a 1)))
(int:set-color-a! color a))
;; Screen transform record and exports ;; Screen transform record and exports
(export make-screen-transform screen-transform?) (export make-screen-transform screen-transform?)
@ -233,20 +25,28 @@
;; Type safe constructor ;; Type safe constructor
(define (make-screen-transform position pivot rotation scale anchor parent) (define (make-screen-transform position pivot rotation scale anchor parent)
(assert (vector2? position)) (assert (vec2? position))
(assert (real? rotation)) (assert (real? rotation))
(assert (vector2? scale)) (assert (vec2? scale))
(assert (and (symbol? anchor) (member anchor '(top-left top-middle top-right (assert (and (symbol? anchor) (member anchor '(top-left top-middle top-right
center-left center center-right center-left center center-right
bottom-left bottom-middle bottom-right)))) bottom-left bottom-middle bottom-right))))
(assert (and (symbol? parent))) (assert (or (null? parent) (screen-transform? parent)))
(int:make-screen-transform position pivot rotation scale anchor parent)) (int:make-screen-transform position pivot rotation scale anchor parent))
;; Generic accessors and mutators for position, rotation, scale, anchor, and parent ;; Generic accessors and mutators for position, rotation, scale, anchor, and parent
;; This allows us to abstract across different transform types - (position) will work for ;; This allows us to abstract across different transform types - (position) will work for
;; screen-transform and 2D-transform, with type checking ;; screen-transform and 2D-transform, with type checking
(export position set-position! rotation set-rotation! scale set-scale! (export global-position position set-position! rotation
anchor set-anchor! parent set-parent!) set-rotation! scale set-scale! anchor set-anchor!
parent set-parent!)
(define (global-position component)
(assert (record? component))
(if (null? (parent component))
((rtd-accessor (record-rtd component) 'position) component)
(v+ ((rtd-accessor (record-rtd component) 'position) component)
(global-position (parent component)))))
(define (position component) (define (position component)
(assert (record? component)) (assert (record? component))
@ -255,7 +55,7 @@
(define (set-position! component position) (define (set-position! component position)
(assert (record? component)) (assert (record? component))
(cond (cond
((screen-transform? component) (assert (vector2? position)))) ((screen-transform? component) (assert (vec2? position))))
((rtd-mutator (record-rtd component) 'position) component position)) ((rtd-mutator (record-rtd component) 'position) component position))
(define (pivot component) (define (pivot component)
@ -265,7 +65,7 @@
(define (set-pivot! component pivot) (define (set-pivot! component pivot)
(assert (record? component)) (assert (record? component))
(cond (cond
((screen-transform? component) (assert (vector2? pivot)))) ((screen-transform? component) (assert (vec2? pivot))))
((rtd-mutator (record-rtd component) 'pivot) component pivot)) ((rtd-mutator (record-rtd component) 'pivot) component pivot))
(define (rotation component) (define (rotation component)
@ -285,7 +85,7 @@
(define (set-scale! component scale) (define (set-scale! component scale)
(assert (record? component)) (assert (record? component))
(cond (cond
((screen-transform? component) (assert (vector2? scale)))) ((screen-transform? component) (assert (vec2? scale))))
((rtd-mutator (record-rtd component) 'scale) component scale)) ((rtd-mutator (record-rtd component) 'scale) component scale))
(define (anchor component) (define (anchor component)
@ -312,149 +112,4 @@
((screen-transform? component) ((screen-transform? component)
(assert (symbol? anchor)))) (assert (symbol? anchor))))
((rtd-mutator (record-rtd component) 'parent) component parent)) ((rtd-mutator (record-rtd component) 'parent) component parent))
;; Visuals
;; Primitive shape visual types
(export pixel-2d? make-pixel-2d
pixel-2d-position set-pixel-2d-position!)
(define-record-type <pixel-2d>
(int:make-pixel-2d position)
pixel-2d?
(position pixel-2d-position int:set-pixel-2d-position!))
(define (make-pixel-2d position)
(assert (vector2? position))
(int:make-pixel-2d position))
(define set-pixel-2d-position!
(guarded-mutator pixel-2d? 'position vector2?))
(export line-2d? make-line-2d line-2d-start-pos
set-line-2d-start-pos! line-2d-end-pos set-line-2d-end-pos!
line-2d-thickness set-line-2d-thickness!)
(define-record-type <line-2d>
(int:make-line-2d start-pos end-pos thickness)
line-2d?
(start-pos line-2d-start-pos int:set-line-2d-start-pos!)
(end-pos line-2d-end-pos int:set-line-2d-end-pos!)
(thickness line-2d-thickness int:set-line-2d-thickness!))
(define (make-line-2d start-pos end-pos thickness)
(assert (vector2? start-pos))
(assert (vector2? end-pos))
(assert ((conjoin integer? positive?) thickness))
(int:make-line-2d start-pos end-pos thickness))
(define set-line-2d-start-pos!
(guarded-mutator line-2d? 'start-pos vector2?))
(define set-line-2d-end-pos!
(guarded-mutator line-2d? 'end-pos vector2?))
(define set-line-2d-thickness!
(guarded-mutator line-2d? 'start-pos (conjoin integer? positive?)))
(export circle-2d? make-circle-2d circle-2d-center
set-circle-2d-center! circle-2d-radius set-circle-2d-radius!
circle-2d-filled? set-circle-2d-filled!)
(define-record-type <circle-2d>
(int:make-circle-2d center radius filled)
circle-2d?
(center circle-2d-center int:set-circle-2d-center!)
(radius circle-2d-radius int:set-circle-2d-radius!)
(filled circle-2d-filled? int:set-circle-2d-filled!))
(define (make-circle-2d center radius filled)
(assert (vector2? center))
(assert ((conjoin integer? positive?) radius))
(assert (boolean? filled))
(int:make-circle-2d center radius filled))
(define set-circle-2d-center!
(guarded-mutator circle-2d? 'center vector2?))
(define set-circle-2d-radius!
(guarded-mutator circle-2d? 'radius (conjoin integer? positive?)))
(define set-circle-2d-filled!
(guarded-mutator circle-2d? 'filled boolean?))
;; TODO: might be nicer to have the origin and width/height inside a rect-2d type or similar
(export rectangle-2d? make-rectangle-2d rectangle-2d-origin
set-rectangle-2d-origin! rectangle-2d-width set-rectangle-2d-width!
rectangle-2d-height set-rectangle-2d-height! rectangle-2d-filled?
set-rectangle-2d-filled! rectangle-2d-thickness set-rectangle-2d-thickness!)
(define-record-type <rectangle-2d>
(int:make-rectangle-2d origin width height filled thickness)
rectangle-2d?
(origin rectangle-2d-origin int:set-rectangle-2d-origin!)
(width rectangle-2d-width int:set-rectangle-2d-width!)
(height rectangle-2d-height int:set-rectangle-2d-height!)
(filled rectangle-2d-filled? int:set-rectangle-2d-filled!)
(thickness rectangle-2d-thickness int:set-rectangle-2d-thickness))
(define (make-rectangle-2d origin width height filled thickness)
(assert (vector2? origin))
(assert ((conjoin integer? positive?) width))
(assert ((conjoin integer? positive?) height))
(assert (boolean? filled))
(assert ((conjoin integer? positive?) thickness))
(int:make-rectangle-2d origin width height filled thickness))
(define set-rectangle-2d-origin!
(guarded-mutator rectangle-2d? 'origin vector2?))
(define set-rectangle-2d-width!
(guarded-mutator rectangle-2d? 'width (conjoin integer? positive?)))
(define set-rectangle-2d-height!
(guarded-mutator rectangle-2d? 'height (conjoin integer? positive?)))
(define set-rectangle-2d-filled!
(guarded-mutator rectangle-2d? 'filled boolean?))
(define set-rectangle-2d-thickness!
(guarded-mutator rectangle-2d? 'thickness (conjoin integer? positive?)))
(export triangle-2d? make-triangle-2d triangle-2d-vertex-1
set-triangle-2d-vertex-1! triangle-2d-vertex-2 set-triangle-2d-vertex-2!
triangle-2d-vertex-3 set-triangle-2d-vertex-3! triangle-2d-filled? set-triangle-2d-filled!)
(define-record-type <triangle-2d>
(int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled)
triangle-2d?
(vertex-1 triangle-2d-vertex-1 int:set-triangle-2d-vertex-1!)
(vertex-2 triangle-2d-vertex-2 int:set-triangle-2d-vertex-2!)
(vertex-3 triangle-2d-vertex-3 int:set-triangle-2d-vertex-3!)
(filled triangle-2d-filled? int:set-triangle-2d-filled!))
(define (make-triangle-2d vertex-1 vertex-2 vertex-3 filled)
(assert (vector2? vertex-1))
(assert (vector2? vertex-2))
(assert (vector2? vertex-3))
(assert (boolean? filled))
(int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled))
(define set-triangle-2d-vertex-1!
(guarded-mutator triangle-2d? 'vertex-1 vector2?))
(define set-triangle-2d-vertex-2!
(guarded-mutator triangle-2d? 'vertex-2 vector2?))
(define set-triangle-2d-vertex-3!
(guarded-mutator triangle-2d? 'vertex-3 vector2?))
(define set-triangle-2d-filled!
(guarded-mutator triangle-2d? 'filled boolean?))
;; Visual component
(export visual-2d? make-visual-2d visual-2d-draw set-visual-2d-draw!
visual-2d-color set-visual-2d-color! visual-2d-layer set-visual-2d-layer!)
(define-record-type <visual-2d>
(int:make-visual-2d draw color layer)
visual-2d?
(draw visual-2d-draw int:set-visual-2d-draw!) ;; NOTE: Typing here: pixel-2d, line-2d, circle-2d, rectangle-2d, triangle-2d etc
(color visual-2d-color int:set-visual-2d-color!)
(layer visual-2d-layer int:set-visual-2d-layer!))
(define (make-visual-2d draw color layer)
(assert ((disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?) draw))
(assert (color? color))
(assert (integer? layer))
(int:make-visual-2d draw color layer))
(define set-visual-2d-draw!
(guarded-mutator visual-2d? 'draw (disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?)))
(define set-visual-2d-color!
(guarded-mutator visual-2d? 'color color?))
(define set-visual-2d-layer!
(guarded-mutator visual-2d? 'layer integer?))
) )

51
engine/core.scm
View file

@ -271,7 +271,17 @@
(let ((entities (map get-entity (set->list (apply query-by-components (system-criteria system)))))) (let ((entities (map get-entity (set->list (apply query-by-components (system-criteria system))))))
(cond (cond
((eqv? (system-mode system) 'batch) ((system-process system) entities)) ((eqv? (system-mode system) 'batch) ((system-process system) entities))
((eqv? (system-mode system) 'entity) (for-each (lambda (e) ((system-process system) e)) 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) (define (execute-systems)
(for-each (for-each
@ -346,6 +356,45 @@
event) event)
#f))) #f)))
;; Input actions alist
(define input-actions '())
;; Key-press type action
(define-record-type <key-press>
(make-key-press key)
key-press?
(key key-press-key))
;; Add a new action to the input actions alist
(export register-action)
(define (register-action name type . data)
(assert (symbol? name))
(assert (member type '(key-press)))
(set! input-actions
(cons (cons name
(apply (cond
((eqv? type 'key-press) make-key-press))
data))
input-actions)))
;; Default global system for simple input management
(add-system
(make-system
'push-actions
0
'global
'()
(lambda ()
(for-each
(lambda (action)
(cond
((key-press? (cdr action))
(when (key-pressed? (key-press-key (cdr action)))
(push-event 'input
(car action)
(cdr action))))))
input-actions))))
;; Render queue exports ;; Render queue exports
(export register-render-queue push-render-object evaluate-render-queue) (export register-render-queue push-render-object evaluate-render-queue)

230
engine/drawing.scm Normal file
View file

@ -0,0 +1,230 @@
(module (engine drawing) ()
(import scheme
(chicken base)
(chicken module)
raylib
(engine guards)
(engine math)
(srfi 4)
(srfi 99))
;; Color exports
(export make-color color-r color-g color-b color-a
set-color-r! set-color-g! set-color-b! set-color-a!)
;; Color type
(define-record-type <color>
(int:make-color r g b a)
color?
(r color-r int:set-color-r!)
(g color-g int:set-color-g!)
(b color-b int:set-color-b!)
(a color-a int:set-color-a!))
;; Get a raylib color vec from a color
(define (use-color col)
(assert (color? col))
(u8vector (floor (* 255 (color-r col)))
(floor (* 255 (color-g col)))
(floor (* 255 (color-b col)))
(floor (* 255 (color-a col)))))
;; Type safe color constructor
(define (make-color r g b a)
(assert (and (number? r) (<= 0 r 1)))
(assert (and (number? g) (<= 0 g 1)))
(assert (and (number? b) (<= 0 b 1)))
(assert (and (number? a) (<= 0 a 1)))
(int:make-color r g b a))
;; Type safe color setter
(define (set-color-r! color r)
(assert (color? color))
(assert (and (number? r) (<= 0 r 1)))
(int:set-color-r! color r))
;; Type safe color setter
(define (set-color-g! color g)
(assert (color? color))
(assert (and (number? g) (<= 0 g 1)))
(int:set-color-g! color g))
;; Type safe color setter
(define (set-color-b! color b)
(assert (color? color))
(assert (and (number? b) (<= 0 b 1)))
(int:set-color-b! color b))
;; Type safe color setter
(define (set-color-a! color a)
(assert (color? color))
(assert (and (number? a) (<= 0 a 1)))
(int:set-color-a! color a))
;; Visuals
;; Primitive shape visual types
;; Pixel
(export pixel-2d? make-pixel-2d
pixel-2d-position set-pixel-2d-position!)
(define-record-type <pixel-2d>
(int:make-pixel-2d position)
pixel-2d?
(position pixel-2d-position int:set-pixel-2d-position!))
(define (make-pixel-2d position)
(assert (vec2? position))
(int:make-pixel-2d position))
(define set-pixel-2d-position!
(guarded-mutator pixel-2d? 'position vec2?))
;; Line2D
(export line-2d? make-line-2d line-2d-start-pos
set-line-2d-start-pos! line-2d-end-pos set-line-2d-end-pos!
line-2d-thickness set-line-2d-thickness!)
(define-record-type <line-2d>
(int:make-line-2d start-pos end-pos thickness)
line-2d?
(start-pos line-2d-start-pos int:set-line-2d-start-pos!)
(end-pos line-2d-end-pos int:set-line-2d-end-pos!)
(thickness line-2d-thickness int:set-line-2d-thickness!))
(define (make-line-2d start-pos end-pos thickness)
(assert (vec2? start-pos))
(assert (vec2? end-pos))
(assert ((conjoin integer? positive?) thickness))
(int:make-line-2d start-pos end-pos thickness))
(define set-line-2d-start-pos!
(guarded-mutator line-2d? 'start-pos vec2?))
(define set-line-2d-end-pos!
(guarded-mutator line-2d? 'end-pos vec2?))
(define set-line-2d-thickness!
(guarded-mutator line-2d? 'start-pos (conjoin integer? positive?)))
;; Circle2D
(export circle-2d? make-circle-2d circle-2d-center
set-circle-2d-center! circle-2d-radius set-circle-2d-radius!
circle-2d-filled? set-circle-2d-filled!)
(define-record-type <circle-2d>
(int:make-circle-2d center radius filled)
circle-2d?
(center circle-2d-center int:set-circle-2d-center!)
(radius circle-2d-radius int:set-circle-2d-radius!)
(filled circle-2d-filled? int:set-circle-2d-filled!))
(define (make-circle-2d center radius filled)
(assert (vec2? center))
(assert ((conjoin integer? positive?) radius))
(assert (boolean? filled))
(int:make-circle-2d center radius filled))
(define set-circle-2d-center!
(guarded-mutator circle-2d? 'center vec2?))
(define set-circle-2d-radius!
(guarded-mutator circle-2d? 'radius (conjoin integer? positive?)))
(define set-circle-2d-filled!
(guarded-mutator circle-2d? 'filled boolean?))
;; Rectangle2D
;; TODO: might be nicer to have the origin and width/height inside a rect-2d type or similar
(export rectangle-2d? make-rectangle-2d rectangle-2d-origin
set-rectangle-2d-origin! rectangle-2d-width set-rectangle-2d-width!
rectangle-2d-height set-rectangle-2d-height! rectangle-2d-filled?
set-rectangle-2d-filled! rectangle-2d-thickness set-rectangle-2d-thickness!)
(define-record-type <rectangle-2d>
(int:make-rectangle-2d origin width height filled thickness)
rectangle-2d?
(origin rectangle-2d-origin int:set-rectangle-2d-origin!)
(width rectangle-2d-width int:set-rectangle-2d-width!)
(height rectangle-2d-height int:set-rectangle-2d-height!)
(filled rectangle-2d-filled? int:set-rectangle-2d-filled!)
(thickness rectangle-2d-thickness int:set-rectangle-2d-thickness))
(define (make-rectangle-2d origin width height filled thickness)
(assert (vec2? origin))
(assert ((conjoin integer? positive?) width))
(assert ((conjoin integer? positive?) height))
(assert (boolean? filled))
(assert ((conjoin integer? positive?) thickness))
(int:make-rectangle-2d origin width height filled thickness))
(define set-rectangle-2d-origin!
(guarded-mutator rectangle-2d? 'origin vec2?))
(define set-rectangle-2d-width!
(guarded-mutator rectangle-2d? 'width (conjoin integer? positive?)))
(define set-rectangle-2d-height!
(guarded-mutator rectangle-2d? 'height (conjoin integer? positive?)))
(define set-rectangle-2d-filled!
(guarded-mutator rectangle-2d? 'filled boolean?))
(define set-rectangle-2d-thickness!
(guarded-mutator rectangle-2d? 'thickness (conjoin integer? positive?)))
;; Triangle2D
(export triangle-2d? make-triangle-2d triangle-2d-vertex-1
set-triangle-2d-vertex-1! triangle-2d-vertex-2 set-triangle-2d-vertex-2!
triangle-2d-vertex-3 set-triangle-2d-vertex-3! triangle-2d-filled? set-triangle-2d-filled!)
(define-record-type <triangle-2d>
(int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled)
triangle-2d?
(vertex-1 triangle-2d-vertex-1 int:set-triangle-2d-vertex-1!)
(vertex-2 triangle-2d-vertex-2 int:set-triangle-2d-vertex-2!)
(vertex-3 triangle-2d-vertex-3 int:set-triangle-2d-vertex-3!)
(filled triangle-2d-filled? int:set-triangle-2d-filled!))
(define (make-triangle-2d vertex-1 vertex-2 vertex-3 filled)
(assert (vec2? vertex-1))
(assert (vec2? vertex-2))
(assert (vec2? vertex-3))
(assert (boolean? filled))
(int:make-triangle-2d vertex-1 vertex-2 vertex-3 filled))
(define set-triangle-2d-vertex-1!
(guarded-mutator triangle-2d? 'vertex-1 vec2?))
(define set-triangle-2d-vertex-2!
(guarded-mutator triangle-2d? 'vertex-2 vec2?))
(define set-triangle-2d-vertex-3!
(guarded-mutator triangle-2d? 'vertex-3 vec2?))
(define set-triangle-2d-filled!
(guarded-mutator triangle-2d? 'filled boolean?))
;; Visual component
(export visual-2d? make-visual-2d visual-2d-draw set-visual-2d-draw!
visual-2d-color set-visual-2d-color! visual-2d-layer set-visual-2d-layer!)
(define-record-type <visual-2d>
(int:make-visual-2d draw color layer)
visual-2d?
(draw visual-2d-draw int:set-visual-2d-draw!) ;; NOTE: Typing here: pixel-2d, line-2d, circle-2d, rectangle-2d, triangle-2d etc
(color visual-2d-color int:set-visual-2d-color!)
(layer visual-2d-layer int:set-visual-2d-layer!))
(define (make-visual-2d draw color layer)
(assert ((disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?) draw))
(assert (color? color))
(assert (integer? layer))
(int:make-visual-2d draw color layer))
(define set-visual-2d-draw!
(guarded-mutator visual-2d? 'draw (disjoin triangle-2d? rectangle-2d? circle-2d? line-2d? pixel-2d?)))
(define set-visual-2d-color!
(guarded-mutator visual-2d? 'color color?))
(define set-visual-2d-layer!
(guarded-mutator visual-2d? 'layer integer?))
;; Drawing functions
;; Helper wrappers for raylib functions
(export draw-circle-2d)
(define (draw-circle-2d pos-vec radius color filled)
(assert (vec2? pos-vec))
(assert (number? radius))
(assert (color? color))
(assert (boolean? filled))
((if filled
draw-circle
draw-circle-2d)
(number->integer (v-x pos-vec))
(number->integer (v-y pos-vec))
(number->integer radius)
(use-color color)))
)

163
engine/math.scm
View file

@ -1,7 +1,9 @@
(module (engine math) () (module (engine math) ()
(import scheme (import scheme
(chicken base) (chicken base)
(chicken module)) (chicken module)
(srfi 1)
(srfi 99))
(export PI PI/2) (export PI PI/2)
(define PI (define PI
@ -24,4 +26,163 @@
;; Approximately equal - for real number comparison ;; Approximately equal - for real number comparison
(define (approx-= x y) (define (approx-= x y)
(< (abs (- x y)) (*float-precision*))) (< (abs (- x y)) (*float-precision*)))
;; Somewhat reliable fixnum conversion
(export number->integer)
(define (number->integer number)
(assert (number? number))
(inexact->exact (round number)))
;; Vector exports
(export vec vec? vec2? v-x
set-v-x! v-y set-v-y!)
;; 2D Vector type
;; TODO: this could be done with a macro to save some definitions
(define-record-type <vector2>
(int:make-vector2 x y)
vec2?
(x vector2-x int:set-vector2-x!)
(y vector2-y int:set-vector2-y!))
;; Type safe 2D vector constructor
(define (vec . args)
(assert (every number? args))
(apply (case (length args)
((2) int:make-vector2))
args))
(define vec?
(disjoin vec2?))
;; Vector utility functions
(define (v-x component)
(assert (record? component))
((rtd-accessor (record-rtd component) 'x) component))
(define (set-v-x! component x)
(assert (record? component))
(assert (number? x))
((rtd-mutator (record-rtd component) 'x) component x))
(define (v-y component)
(assert (record? component))
((rtd-accessor (record-rtd component) 'y) component))
(define (set-v-y! component y)
(assert (record? component))
(assert (number? y))
((rtd-mutator (record-rtd component) 'y) component y))
;; Vector operations
(export v= v+ v- v* v/)
;; Vector equality
(define (v= . vecs)
(assert (every record? vecs))
(assert (every vec? vecs))
(assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs)))))
(map (compose rtd-name record-rtd) vecs)))
(and (apply = (map v-x vecs))
(apply = (map v-y vecs))))
;; Vector addition
;; Note that each operand can be either a vector OR a number
;; If a number, that number is added to EVERY member of the vector
(define (v+ . operands)
(assert (every (disjoin number? (conjoin record? vec?)) operands))
(let ((vecs (filter vec? operands)))
(assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs)))))
(map (compose rtd-name record-rtd) vecs))))
(let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands))
(y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands)))
(vec (apply + x-parts)
(apply + y-parts))))
;; Vector subtractions
;; Note that each operand can be either a vector OR a number
;; If a number, that number is subtracted from EVERY member of the vector
(define (v- . operands)
(assert (every (disjoin number? (conjoin record? vec?)) operands))
(let ((vecs (filter vec? operands)))
(assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs)))))
(map (compose rtd-name record-rtd) vecs))))
(let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands))
(y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands)))
(vec (apply - x-parts)
(apply - y-parts))))
;; Vector multiplication
;; Note that each operand can be either a vector OR a number
;; If a number, that number is multiplied to EVERY member of the vector
(define (v* . operands)
(assert (every (disjoin number? (conjoin record? vec?)) operands))
(let ((vecs (filter vec? operands)))
(assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs)))))
(map (compose rtd-name record-rtd) vecs))))
(let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands))
(y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands)))
(vec (apply * x-parts)
(apply * y-parts))))
;; Vector division
;; Note that each operand can be either a vector OR a number
;; If a number, EVERY member of the vector is divided by that number
(define (v/ . operands)
(assert (every (disjoin number? (conjoin record? vec?)) operands))
(let ((vecs (filter vec? operands)))
(assert (every (lambda (x) (eqv? x (rtd-name (record-rtd (car vecs)))))
(map (compose rtd-name record-rtd) vecs))))
(let ((x-parts (map (lambda (v) (if (vec? v) (v-x v) v)) operands))
(y-parts (map (lambda (v) (if (vec? v) (v-y v) v)) operands)))
(vec (apply / x-parts)
(apply / y-parts))))
;; More complex vector functions
(export vector-magnitude vector-normalize vector-dot
vector-angle-between)
;; Magnitude
(define (vector-magnitude vec)
(assert ((disjoin vec2?) vec))
(cond
((vec2? vec)
(sqrt (+ (expt (v-x vec) 2)
(expt (v-y vec) 2))))))
;; Dot product of vectors
(define (vector-dot vec1 vec2)
(assert (and (record? vec1)
(record? vec2)))
(assert (eq? (rtd-name (record-rtd vec1))
(rtd-name (record-rtd vec2))))
(assert ((disjoin vec2?) vec1))
(cond
((vec2? vec1)
(+ (* (v-x vec1) (v-x vec2))
(* (v-y vec1) (v-y vec2))))))
;; Angle between vectors
(define (vector-angle-between vec1 vec2)
(assert (and (record? vec1)
(record? vec2)))
(assert (eq? (rtd-name (record-rtd vec1))
(rtd-name (record-rtd vec2))))
(assert ((disjoin vec2?) vec1))
(cond
((vec2? vec1)
(acos (/ (vector-dot vec1 vec2)
(* (vector-magnitude vec1)
(vector-magnitude vec2)))))))
;; Normalization
(define (vector-normalize v)
(assert ((disjoin vec2?) v)) ;; TODO: This assertion should be moved out of here
(let ((magnitude (vector-magnitude v)))
(cond
((vec2? v)
(vec (/ (v-x v)
magnitude)
(/ (v-y v)
magnitude))))))
) )

152
samples/bounce.scm
View file

@ -4,6 +4,8 @@
raylib raylib
(engine core) (engine core)
(engine components core) (engine components core)
(engine math)
(engine drawing)
(srfi 1) (srfi 1)
(srfi 99)) (srfi 99))
@ -17,23 +19,19 @@
0 0
'entity 'entity
'(<visual-2d> <screen-transform>) '(<visual-2d> <screen-transform>)
(lambda (ball) (lambda (_ vis-2d transform)
(let ((vis-2d (find visual-2d? ball))
(transform (find screen-transform? ball)))
(when (circle-2d? (visual-2d-draw vis-2d)) (when (circle-2d? (visual-2d-draw vis-2d))
(let ((circle (visual-2d-draw vis-2d))) (let ((circle (visual-2d-draw vis-2d)))
(push-render-object 'screen (push-render-object 'screen
(visual-2d-layer vis-2d) (visual-2d-layer vis-2d)
(lambda () (lambda ()
((if (circle-2d-filled? circle) (let ((draw-pos (v+ (position transform)
draw-circle (circle-2d-center circle))))
draw-circle-lines) (draw-circle-2d
(inexact->exact (round (+ (vector-x (position transform)) draw-pos
(vector-x (circle-2d-center circle)))))
(inexact->exact (round (+ (vector-y (position transform))
(vector-y (circle-2d-center circle)))))
(circle-2d-radius circle) (circle-2d-radius circle)
(use-color (visual-2d-color vis-2d))))))))))) (visual-2d-color vis-2d)
(circle-2d-filled? circle))))))))))
(define-record-type <rigidbody-2d> (define-record-type <rigidbody-2d>
@ -41,7 +39,7 @@
rigidbody-2d? rigidbody-2d?
(velocity rigidbody-2d-velocity set-rigidbody-2d-velocity!)) (velocity rigidbody-2d-velocity set-rigidbody-2d-velocity!))
(define +gravity+ (make-vector2 0 9.8)) (define +gravity+ (vec 0 9.8))
(define +friction+ -0.1) (define +friction+ -0.1)
(add-system (add-system
@ -49,149 +47,107 @@
0 0
'entity 'entity
'(<rigidbody-2d>) '(<rigidbody-2d>)
(lambda (body) (lambda (_ rbody)
(let ((rbody (find rigidbody-2d? body)))
(set-rigidbody-2d-velocity! rbody (set-rigidbody-2d-velocity! rbody
(vector-+ (rigidbody-2d-velocity rbody) (v+ (rigidbody-2d-velocity rbody)
(vector-* (v* (get-frame-time)
(make-vector2 (get-frame-time) +gravity+))))))
(get-frame-time))
+gravity+)))))))
(add-system (add-system
(make-system 'apply-bounce (make-system 'apply-bounce
1 1
'entity 'entity
'(<rigidbody-2d> <screen-transform>) '(<rigidbody-2d> <screen-transform>)
(lambda (ball) (lambda (_ rbody transform)
(let ((rbody (find rigidbody-2d? ball)) (when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+))
(transform (find screen-transform? ball)))
(when (> (vector-y (position transform)) (- (cdr (*window-size*)) +ball-radius+))
(set-rigidbody-2d-velocity! rbody (set-rigidbody-2d-velocity! rbody
(make-vector2 (vector-x (rigidbody-2d-velocity rbody)) (* -1 (vector-y (rigidbody-2d-velocity rbody)))))))))) (v* (rigidbody-2d-velocity rbody)
(vec 1 -1)))))))
(add-system (add-system
(make-system 'apply-wall-bounce (make-system 'apply-wall-bounce
1 1
'entity 'entity
'(<rigidbody-2d> <screen-transform>) '(<rigidbody-2d> <screen-transform>)
(lambda (ball) (lambda (_ rbody transform)
(let ((rbody (find rigidbody-2d? ball)) (when (or (> (v-x (position transform)) (- (car (*window-size*)) +ball-radius+))
(transform (find screen-transform? ball))) (< (v-x (position transform)) (+ 0 +ball-radius+)))
(when (or (> (vector-x (position transform)) (- (car (*window-size*)) +ball-radius+))
(< (vector-x (position transform)) (+ 0 +ball-radius+)))
(set-rigidbody-2d-velocity! rbody (set-rigidbody-2d-velocity! rbody
(make-vector2 (* -1 (vector-x (rigidbody-2d-velocity rbody))) (vector-y (rigidbody-2d-velocity rbody))))))))) (v* (rigidbody-2d-velocity rbody)
(vec -1 1)))))))
(add-system (add-system
(make-system 'apply-friction (make-system 'apply-friction
2 2
'entity 'entity
'(<rigidbody-2d>) '(<rigidbody-2d>)
(lambda (ball) (lambda (_ rbody)
(let ((rbody (find rigidbody-2d? ball)))
(set-rigidbody-2d-velocity! rbody (set-rigidbody-2d-velocity! rbody
(vector-+ (rigidbody-2d-velocity rbody) (v+ (rigidbody-2d-velocity rbody)
(vector-* (v* (get-frame-time)
(make-vector2 (* (get-frame-time) +friction+) (* (get-frame-time) +friction+)) +friction+
(rigidbody-2d-velocity rbody)))))))) (rigidbody-2d-velocity rbody)))))))
(add-system (add-system
(make-system 'move-rigidbody (make-system 'move-rigidbody
3 3
'entity 'entity
'(<rigidbody-2d> <screen-transform>) '(<rigidbody-2d> <screen-transform>)
(lambda (ball) (lambda (_ rbody transform)
(let ((rbody (find rigidbody-2d? ball))
(transform (find screen-transform? ball)))
(set-position! transform (set-position! transform
(vector-+ (rigidbody-2d-velocity rbody) (v+ (rigidbody-2d-velocity rbody)
(position transform))))))) (position transform))))))
(define-record-type <key-press> (register-action 'boost 'key-press KEY_SPACE)
(make-key-press key)
key-press?
(key key-press-key))
(add-system
(make-system 'input
0
'global
'()
(lambda ()
(when (key-pressed? KEY_SPACE)
(push-event 'input 'boost (make-key-press 'space))))))
(add-system (add-system
(make-system 'boost-rigidbody (make-system 'boost-rigidbody
2 2
'entity 'entity
'(<rigidbody-2d>) '(<rigidbody-2d>)
(lambda (ball) (lambda (_ rbody)
(let ((rbody (find rigidbody-2d? ball)))
(when (peek-event 'input 'boost) (when (peek-event 'input 'boost)
(set-rigidbody-2d-velocity! rbody (set-rigidbody-2d-velocity! rbody
(vector-* (make-vector2 2 2) (v* 2
(rigidbody-2d-velocity rbody)))))))) (rigidbody-2d-velocity rbody)))))))
(add-system (add-system
(make-system 'clear-boost-input (make-system 'clear-boost
10 4
'global 'global
'() '()
(lambda () (lambda ()
(pop-event 'input 'boost)))) (pop-event 'input 'boost))))
(define (make-ball position velocity color)
(create-entity (create-entity
(make-visual-2d (make-visual-2d
(make-circle-2d (make-circle-2d
(make-vector2 0 0) (vec 0 0)
+ball-radius+ +ball-radius+
#t) #t)
(make-color 0 0 1 1) color
0) 0)
(make-screen-transform (make-screen-transform
(make-vector2 100 100) position
(make-vector2 0 0) (vec 0 0)
0 0
(make-vector2 1 1) (vec 1 1)
'center 'center
'none) 'none)
(make-rigidbody-2d (make-vector2 5 1))) (make-rigidbody-2d velocity)))
(create-entity (make-ball (vec 100 100)
(make-visual-2d (vec 5 1)
(make-circle-2d (make-color 0 0 1 1))
(make-vector2 0 0)
+ball-radius+
#t)
(make-color 0 1 0 1)
0)
(make-screen-transform
(make-vector2 100 100)
(make-vector2 0 0)
0
(make-vector2 1 1)
'center
'none)
(make-rigidbody-2d (make-vector2 -2 -2)))
(create-entity (make-ball (vec 200 200)
(make-visual-2d (vec -2 -2)
(make-circle-2d (make-color 0 1 0 1))
(make-vector2 0 0)
+ball-radius+ (make-ball (vec 300 300)
#t) (vec -2 -2)
(make-color 1 0 0 1) (make-color 1 0 0 1))
0)
(make-screen-transform
(make-vector2 100 100)
(make-vector2 0 0)
0
(make-vector2 1 1)
'center
'none)
(make-rigidbody-2d (make-vector2 10 -5)))
(create-window) (create-window)
) )

36
test/components.scm
View file

@ -7,24 +7,24 @@
(srfi 78) (srfi 78)
(srfi 99)) (srfi 99))
(define v1 (make-vector2 0 0)) (define v1 (vec 0 0))
(define v2 (make-vector2 10 10)) (define v2 (vec 10 10))
(check (vector-= v2 (make-vector2 10 10)) => #t) (check (v= v2 (vec 10 10)) => #t)
(check (vector-= (make-vector2 20 20) (check (v= (vec 20 20)
(vector-+ v2 (make-vector2 10 10))) => #t) (v+ v2 (vec 10 10))) => #t)
(check (vector-= v1 (check (v= v1
(vector-- v2 (make-vector2 10 10))) => #t) (v- v2 (vec 10 10))) => #t)
(check (vector-= (make-vector2 100 100) (check (v= (vec 100 100)
(vector-* v2 (make-vector2 10 10))) => #t) (v* v2 (vec 10 10))) => #t)
(check (vector-= (make-vector2 1 1) (check (v= (vec 1 1)
(vector-/ v2 (make-vector2 10 10))) => #t) (v/ v2 (vec 10 10))) => #t)
(check (vector-magnitude (make-vector2 100 0)) => 100) (check (vector-magnitude (vec 100 0)) => 100)
(check (vector-= (make-vector2 1 0) (check (v= (vec 1 0)
(vector-normalize (make-vector2 100 0))) => #t) (vector-normalize (vec 100 0))) => #t)
(check (vector-dot (make-vector2 1 2) (check (vector-dot (vec 1 2)
(make-vector2 3 4)) => 11) (vec 3 4)) => 11)
(check (rad-to-deg (check (rad-to-deg
(vector-angle-between (make-vector2 1 2) (vector-angle-between (vec 1 2)
(make-vector2 3 4))) (=> approx-=) 10.305) (vec 3 4))) (=> approx-=) 10.305)
) )