diff --git a/engine/components.scm b/engine/components.scm index 87b12c8..bdbd8c5 100644 --- a/engine/components.scm +++ b/engine/components.scm @@ -2,12 +2,220 @@ (import scheme (chicken base) (chicken module) - (engine core) (engine guards) - (engine math) (srfi 1) + (srfi 4) (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 + (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 + (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 (export make-screen-transform screen-transform?) @@ -25,28 +233,20 @@ ;; Type safe constructor (define (make-screen-transform position pivot rotation scale anchor parent) - (assert (vec2? position)) + (assert (vector2? position)) (assert (real? rotation)) - (assert (vec2? scale)) + (assert (vector2? scale)) (assert (and (symbol? anchor) (member anchor '(top-left top-middle top-right center-left center center-right bottom-left bottom-middle bottom-right)))) - (assert (or (null? parent) (screen-transform? parent))) + (assert (and (symbol? parent))) (int:make-screen-transform position pivot rotation scale anchor 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 ;; screen-transform and 2D-transform, with type checking -(export global-position position set-position! rotation - 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))))) +(export position set-position! rotation set-rotation! scale set-scale! + anchor set-anchor! parent set-parent!) (define (position component) (assert (record? component)) @@ -55,7 +255,7 @@ (define (set-position! component position) (assert (record? component)) (cond - ((screen-transform? component) (assert (vec2? position)))) + ((screen-transform? component) (assert (vector2? position)))) ((rtd-mutator (record-rtd component) 'position) component position)) (define (pivot component) @@ -65,7 +265,7 @@ (define (set-pivot! component pivot) (assert (record? component)) (cond - ((screen-transform? component) (assert (vec2? pivot)))) + ((screen-transform? component) (assert (vector2? pivot)))) ((rtd-mutator (record-rtd component) 'pivot) component pivot)) (define (rotation component) @@ -85,7 +285,7 @@ (define (set-scale! component scale) (assert (record? component)) (cond - ((screen-transform? component) (assert (vec2? scale)))) + ((screen-transform? component) (assert (vector2? scale)))) ((rtd-mutator (record-rtd component) 'scale) component scale)) (define (anchor component) @@ -112,4 +312,149 @@ ((screen-transform? component) (assert (symbol? anchor)))) ((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 + (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 + (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 + (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 + (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 + (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 + (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?)) ) diff --git a/engine/core.scm b/engine/core.scm index f4a43cc..92808e2 100644 --- a/engine/core.scm +++ b/engine/core.scm @@ -271,17 +271,7 @@ (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)))))) + ((eqv? (system-mode system) 'entity) (for-each (lambda (e) ((system-process system) e)) entities)))))) (define (execute-systems) (for-each @@ -356,45 +346,6 @@ event) #f))) -;; Input actions alist -(define input-actions '()) - -;; Key-press type action -(define-record-type - (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 (export register-render-queue push-render-object evaluate-render-queue) diff --git a/engine/drawing.scm b/engine/drawing.scm deleted file mode 100644 index 758ac5d..0000000 --- a/engine/drawing.scm +++ /dev/null @@ -1,230 +0,0 @@ -(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 - (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 - (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 - (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 - (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 - (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 - (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 - (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))) -) diff --git a/engine/math.scm b/engine/math.scm index ca82e91..e4f608d 100644 --- a/engine/math.scm +++ b/engine/math.scm @@ -1,9 +1,7 @@ (module (engine math) () (import scheme (chicken base) - (chicken module) - (srfi 1) - (srfi 99)) + (chicken module)) (export PI PI/2) (define PI @@ -26,163 +24,4 @@ ;; Approximately equal - for real number comparison (define (approx-= x y) (< (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 - (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)))))) ) diff --git a/samples/bounce.scm b/samples/bounce.scm index 7f84621..4890d51 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -4,8 +4,6 @@ raylib (engine core) (engine components core) - (engine math) - (engine drawing) (srfi 1) (srfi 99)) @@ -19,19 +17,23 @@ 0 'entity '( ) - (lambda (_ vis-2d transform) - (when (circle-2d? (visual-2d-draw vis-2d)) - (let ((circle (visual-2d-draw vis-2d))) - (push-render-object 'screen - (visual-2d-layer vis-2d) - (lambda () - (let ((draw-pos (v+ (position transform) - (circle-2d-center circle)))) - (draw-circle-2d - draw-pos + (lambda (ball) + (let ((vis-2d (find visual-2d? ball)) + (transform (find screen-transform? ball))) + (when (circle-2d? (visual-2d-draw vis-2d)) + (let ((circle (visual-2d-draw vis-2d))) + (push-render-object 'screen + (visual-2d-layer vis-2d) + (lambda () + ((if (circle-2d-filled? circle) + draw-circle + draw-circle-lines) + (inexact->exact (round (+ (vector-x (position transform)) + (vector-x (circle-2d-center circle))))) + (inexact->exact (round (+ (vector-y (position transform)) + (vector-y (circle-2d-center circle))))) (circle-2d-radius circle) - (visual-2d-color vis-2d) - (circle-2d-filled? circle)))))))))) + (use-color (visual-2d-color vis-2d))))))))))) (define-record-type @@ -39,7 +41,7 @@ rigidbody-2d? (velocity rigidbody-2d-velocity set-rigidbody-2d-velocity!)) -(define +gravity+ (vec 0 9.8)) +(define +gravity+ (make-vector2 0 9.8)) (define +friction+ -0.1) (add-system @@ -47,107 +49,149 @@ 0 'entity '() - (lambda (_ rbody) - (set-rigidbody-2d-velocity! rbody - (v+ (rigidbody-2d-velocity rbody) - (v* (get-frame-time) - +gravity+)))))) + (lambda (body) + (let ((rbody (find rigidbody-2d? body))) + (set-rigidbody-2d-velocity! rbody + (vector-+ (rigidbody-2d-velocity rbody) + (vector-* + (make-vector2 (get-frame-time) + (get-frame-time)) + +gravity+))))))) (add-system (make-system 'apply-bounce 1 'entity '( ) - (lambda (_ rbody transform) - (when (> (v-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) - (set-rigidbody-2d-velocity! rbody - (v* (rigidbody-2d-velocity rbody) - (vec 1 -1))))))) + (lambda (ball) + (let ((rbody (find rigidbody-2d? ball)) + (transform (find screen-transform? ball))) + (when (> (vector-y (position transform)) (- (cdr (*window-size*)) +ball-radius+)) + (set-rigidbody-2d-velocity! rbody + (make-vector2 (vector-x (rigidbody-2d-velocity rbody)) (* -1 (vector-y (rigidbody-2d-velocity rbody)))))))))) (add-system (make-system 'apply-wall-bounce 1 'entity '( ) - (lambda (_ rbody transform) - (when (or (> (v-x (position transform)) (- (car (*window-size*)) +ball-radius+)) - (< (v-x (position transform)) (+ 0 +ball-radius+))) - (set-rigidbody-2d-velocity! rbody - (v* (rigidbody-2d-velocity rbody) - (vec -1 1))))))) + (lambda (ball) + (let ((rbody (find rigidbody-2d? ball)) + (transform (find screen-transform? ball))) + (when (or (> (vector-x (position transform)) (- (car (*window-size*)) +ball-radius+)) + (< (vector-x (position transform)) (+ 0 +ball-radius+))) + (set-rigidbody-2d-velocity! rbody + (make-vector2 (* -1 (vector-x (rigidbody-2d-velocity rbody))) (vector-y (rigidbody-2d-velocity rbody))))))))) (add-system (make-system 'apply-friction 2 'entity '() - (lambda (_ rbody) - (set-rigidbody-2d-velocity! rbody - (v+ (rigidbody-2d-velocity rbody) - (v* (get-frame-time) - +friction+ - (rigidbody-2d-velocity rbody))))))) + (lambda (ball) + (let ((rbody (find rigidbody-2d? ball))) + (set-rigidbody-2d-velocity! rbody + (vector-+ (rigidbody-2d-velocity rbody) + (vector-* + (make-vector2 (* (get-frame-time) +friction+) (* (get-frame-time) +friction+)) + (rigidbody-2d-velocity rbody)))))))) (add-system (make-system 'move-rigidbody 3 'entity '( ) - (lambda (_ rbody transform) - (set-position! transform - (v+ (rigidbody-2d-velocity rbody) - (position transform)))))) + (lambda (ball) + (let ((rbody (find rigidbody-2d? ball)) + (transform (find screen-transform? ball))) + (set-position! transform + (vector-+ (rigidbody-2d-velocity rbody) + (position transform))))))) -(register-action 'boost 'key-press KEY_SPACE) +(define-record-type + (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 (make-system 'boost-rigidbody 2 'entity '() - (lambda (_ rbody) - (when (peek-event 'input 'boost) - (set-rigidbody-2d-velocity! rbody - (v* 2 - (rigidbody-2d-velocity rbody))))))) + (lambda (ball) + (let ((rbody (find rigidbody-2d? ball))) + (when (peek-event 'input 'boost) + (set-rigidbody-2d-velocity! rbody + (vector-* (make-vector2 2 2) + (rigidbody-2d-velocity rbody)))))))) (add-system - (make-system 'clear-boost - 4 + (make-system 'clear-boost-input + 10 'global '() (lambda () (pop-event 'input 'boost)))) -(define (make-ball position velocity color) - (create-entity - (make-visual-2d - (make-circle-2d - (vec 0 0) - +ball-radius+ - #t) - color - 0) - (make-screen-transform - position - (vec 0 0) - 0 - (vec 1 1) - 'center - 'none) - (make-rigidbody-2d velocity))) +(create-entity + (make-visual-2d + (make-circle-2d + (make-vector2 0 0) + +ball-radius+ + #t) + (make-color 0 0 1 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 5 1))) -(make-ball (vec 100 100) - (vec 5 1) - (make-color 0 0 1 1)) +(create-entity + (make-visual-2d + (make-circle-2d + (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))) -(make-ball (vec 200 200) - (vec -2 -2) - (make-color 0 1 0 1)) - -(make-ball (vec 300 300) - (vec -2 -2) - (make-color 1 0 0 1)) +(create-entity + (make-visual-2d + (make-circle-2d + (make-vector2 0 0) + +ball-radius+ + #t) + (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) ) diff --git a/test/components.scm b/test/components.scm index 317ab9c..d297f0e 100644 --- a/test/components.scm +++ b/test/components.scm @@ -7,24 +7,24 @@ (srfi 78) (srfi 99)) -(define v1 (vec 0 0)) -(define v2 (vec 10 10)) +(define v1 (make-vector2 0 0)) +(define v2 (make-vector2 10 10)) -(check (v= v2 (vec 10 10)) => #t) -(check (v= (vec 20 20) - (v+ v2 (vec 10 10))) => #t) -(check (v= v1 - (v- v2 (vec 10 10))) => #t) -(check (v= (vec 100 100) - (v* v2 (vec 10 10))) => #t) -(check (v= (vec 1 1) - (v/ v2 (vec 10 10))) => #t) -(check (vector-magnitude (vec 100 0)) => 100) -(check (v= (vec 1 0) - (vector-normalize (vec 100 0))) => #t) -(check (vector-dot (vec 1 2) - (vec 3 4)) => 11) +(check (vector-= v2 (make-vector2 10 10)) => #t) +(check (vector-= (make-vector2 20 20) + (vector-+ v2 (make-vector2 10 10))) => #t) +(check (vector-= v1 + (vector-- v2 (make-vector2 10 10))) => #t) +(check (vector-= (make-vector2 100 100) + (vector-* v2 (make-vector2 10 10))) => #t) +(check (vector-= (make-vector2 1 1) + (vector-/ v2 (make-vector2 10 10))) => #t) +(check (vector-magnitude (make-vector2 100 0)) => 100) +(check (vector-= (make-vector2 1 0) + (vector-normalize (make-vector2 100 0))) => #t) +(check (vector-dot (make-vector2 1 2) + (make-vector2 3 4)) => 11) (check (rad-to-deg - (vector-angle-between (vec 1 2) - (vec 3 4))) (=> approx-=) 10.305) + (vector-angle-between (make-vector2 1 2) + (make-vector2 3 4))) (=> approx-=) 10.305) )