Compare commits
No commits in common. "e7bfc01f7bafa34aa841949c5c9c3e6dc32f0d8e" and "d379cd28d7531b82f8e0d4887806cbcf43d01b6e" have entirely different histories.
e7bfc01f7b
...
d379cd28d7
6 changed files with 503 additions and 554 deletions
|
|
@ -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 <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
|
||||
(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 <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?))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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 <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
|
||||
(export register-render-queue push-render-object evaluate-render-queue)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 <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
163
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 <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))))))
|
||||
)
|
||||
|
|
|
|||
|
|
@ -4,8 +4,6 @@
|
|||
raylib
|
||||
(engine core)
|
||||
(engine components core)
|
||||
(engine math)
|
||||
(engine drawing)
|
||||
(srfi 1)
|
||||
(srfi 99))
|
||||
|
||||
|
|
@ -19,19 +17,23 @@
|
|||
0
|
||||
'entity
|
||||
'(<visual-2d> <screen-transform>)
|
||||
(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 <rigidbody-2d>
|
||||
|
|
@ -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
|
||||
'(<rigidbody-2d>)
|
||||
(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
|
||||
'(<rigidbody-2d> <screen-transform>)
|
||||
(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
|
||||
'(<rigidbody-2d> <screen-transform>)
|
||||
(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
|
||||
'(<rigidbody-2d>)
|
||||
(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
|
||||
'(<rigidbody-2d> <screen-transform>)
|
||||
(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 <key-press>
|
||||
(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
|
||||
'(<rigidbody-2d>)
|
||||
(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)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue