Change vector math interface
This commit is contained in:
parent
30b8206889
commit
66fbc1587c
4 changed files with 215 additions and 214 deletions
|
|
@ -3,166 +3,11 @@
|
|||
(chicken base)
|
||||
(chicken module)
|
||||
(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!)
|
||||
|
|
@ -176,7 +21,7 @@
|
|||
(b color-b int:set-color-b!)
|
||||
(a color-a int:set-color-a!))
|
||||
|
||||
;; Get a raylib color vector from a color
|
||||
;; Get a raylib color vec from a color
|
||||
(define (use-color col)
|
||||
(assert (color? col))
|
||||
(u8vector (floor (* 255 (color-r col)))
|
||||
|
|
@ -233,9 +78,9 @@
|
|||
|
||||
;; Type safe constructor
|
||||
(define (make-screen-transform position pivot rotation scale anchor parent)
|
||||
(assert (vector2? position))
|
||||
(assert (vec2? position))
|
||||
(assert (real? rotation))
|
||||
(assert (vector2? scale))
|
||||
(assert (vec2? scale))
|
||||
(assert (and (symbol? anchor) (member anchor '(top-left top-middle top-right
|
||||
center-left center center-right
|
||||
bottom-left bottom-middle bottom-right))))
|
||||
|
|
@ -255,7 +100,7 @@
|
|||
(define (set-position! component position)
|
||||
(assert (record? component))
|
||||
(cond
|
||||
((screen-transform? component) (assert (vector2? position))))
|
||||
((screen-transform? component) (assert (vec2? position))))
|
||||
((rtd-mutator (record-rtd component) 'position) component position))
|
||||
|
||||
(define (pivot component)
|
||||
|
|
@ -265,7 +110,7 @@
|
|||
(define (set-pivot! component pivot)
|
||||
(assert (record? component))
|
||||
(cond
|
||||
((screen-transform? component) (assert (vector2? pivot))))
|
||||
((screen-transform? component) (assert (vec2? pivot))))
|
||||
((rtd-mutator (record-rtd component) 'pivot) component pivot))
|
||||
|
||||
(define (rotation component)
|
||||
|
|
@ -285,7 +130,7 @@
|
|||
(define (set-scale! component scale)
|
||||
(assert (record? component))
|
||||
(cond
|
||||
((screen-transform? component) (assert (vector2? scale))))
|
||||
((screen-transform? component) (assert (vec2? scale))))
|
||||
((rtd-mutator (record-rtd component) 'scale) component scale))
|
||||
|
||||
(define (anchor component)
|
||||
|
|
@ -323,11 +168,11 @@
|
|||
(position pixel-2d-position int:set-pixel-2d-position!))
|
||||
|
||||
(define (make-pixel-2d position)
|
||||
(assert (vector2? position))
|
||||
(assert (vec2? position))
|
||||
(int:make-pixel-2d position))
|
||||
|
||||
(define set-pixel-2d-position!
|
||||
(guarded-mutator pixel-2d? 'position vector2?))
|
||||
(guarded-mutator pixel-2d? 'position vec2?))
|
||||
|
||||
(export line-2d? make-line-2d line-2d-start-pos
|
||||
set-line-2d-start-pos! line-2d-end-pos set-line-2d-end-pos!
|
||||
|
|
@ -340,15 +185,15 @@
|
|||
(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 (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 vector2?))
|
||||
(guarded-mutator line-2d? 'start-pos vec2?))
|
||||
(define set-line-2d-end-pos!
|
||||
(guarded-mutator line-2d? 'end-pos vector2?))
|
||||
(guarded-mutator line-2d? 'end-pos vec2?))
|
||||
(define set-line-2d-thickness!
|
||||
(guarded-mutator line-2d? 'start-pos (conjoin integer? positive?)))
|
||||
|
||||
|
|
@ -363,13 +208,13 @@
|
|||
(filled circle-2d-filled? int:set-circle-2d-filled!))
|
||||
|
||||
(define (make-circle-2d center radius filled)
|
||||
(assert (vector2? center))
|
||||
(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 vector2?))
|
||||
(guarded-mutator circle-2d? 'center vec2?))
|
||||
(define set-circle-2d-radius!
|
||||
(guarded-mutator circle-2d? 'radius (conjoin integer? positive?)))
|
||||
(define set-circle-2d-filled!
|
||||
|
|
@ -390,7 +235,7 @@
|
|||
(thickness rectangle-2d-thickness int:set-rectangle-2d-thickness))
|
||||
|
||||
(define (make-rectangle-2d origin width height filled thickness)
|
||||
(assert (vector2? origin))
|
||||
(assert (vec2? origin))
|
||||
(assert ((conjoin integer? positive?) width))
|
||||
(assert ((conjoin integer? positive?) height))
|
||||
(assert (boolean? filled))
|
||||
|
|
@ -398,7 +243,7 @@
|
|||
(int:make-rectangle-2d origin width height filled thickness))
|
||||
|
||||
(define set-rectangle-2d-origin!
|
||||
(guarded-mutator rectangle-2d? 'origin vector2?))
|
||||
(guarded-mutator rectangle-2d? 'origin vec2?))
|
||||
(define set-rectangle-2d-width!
|
||||
(guarded-mutator rectangle-2d? 'width (conjoin integer? positive?)))
|
||||
(define set-rectangle-2d-height!
|
||||
|
|
@ -420,18 +265,18 @@
|
|||
(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 (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 vector2?))
|
||||
(guarded-mutator triangle-2d? 'vertex-1 vec2?))
|
||||
(define set-triangle-2d-vertex-2!
|
||||
(guarded-mutator triangle-2d? 'vertex-2 vector2?))
|
||||
(guarded-mutator triangle-2d? 'vertex-2 vec2?))
|
||||
(define set-triangle-2d-vertex-3!
|
||||
(guarded-mutator triangle-2d? 'vertex-3 vector2?))
|
||||
(guarded-mutator triangle-2d? 'vertex-3 vec2?))
|
||||
(define set-triangle-2d-filled!
|
||||
(guarded-mutator triangle-2d? 'filled boolean?))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue