imugi/engine/components.scm

(module (engine components core) ()
(import scheme
	(chicken base)
	(chicken module)
	(srfi 1)
	(srfi 99))

;; Vector exports
(export make-vector2 vector2? vector2-x
	set-vector2-x! vector2-y set-vector2-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 (any (lambda (pred) (pred vec1)) (list vector2?)))
  (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 (any (lambda (pred) (pred vec1)) (list vector2?)))
  (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 (any (lambda (pred) (pred vec1)) (list vector2?)))
  (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 (any (lambda (pred) (pred vec1)) (list vector2?)))
  (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 (any (lambda (pred) (pred vec1)) (list vector2?)))
  (cond
   ((vector2? vec1)
    (make-vector2 (/ (vector-x vec1) (vector-x vec2))
		  (/ (vector-y vec1) (vector-y vec2))))))

;; Magnitude
(define (vector-magnitude vec)
  (assert (any (lambda (pred) (pred vec)) (list vector2?)))
  (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 (any (lambda (pred) (pred vec1)) (list vector2?)))
  (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 (any (lambda (pred) (pred vec1)) (list vector2?)))
  (cond
   ((vector2? vec1)
    (acos (/ (vector-dot vec1 vec2)
	     (* (vector-magnitude vec1)
		(vector-magnitude vec2)))))))

;; Normalization
(define (vector-normalize vec)
  (assert (any (lambda (pred) (pred vec)) (list vector2?))) ;; 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 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!))

;; 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?)

;; The screen transform is for representing transformations in screen-space, that is
;; in UI and not in 2D/3D
(define-record-type <screen-transform>
  (int:make-screen-transform position pivot rotation scale anchor parent)
  screen-transform?
  (position screen-transform-position int:set-screen-transform-position!)
  (pivot screen-transform-pivot int:set-screen-transform-pivot!)
  (rotation screen-transform-rotation int:set-screen-transform-rotation!)
  (scale screen-transform-scale int:set-screen-transform-scale!)
  (anchor screen-transform-anchor int:set-screen-transform-anchor!)
  (parent screen-transform-parent int:set-screen-transform-parent!))

;; Type safe constructor
(define (make-screen-transform position rotation scale anchor parent)
  (assert (vector2? position))
  (assert (real? rotation))
  (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 (and (symbol? parent)))
  (int:make-screen-transform position 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 position set-position! rotation set-rotation! scale set-scale!
	anchor set-anchor! parent set-parent!)

(define (position component)
  (assert (record? component))
  ((rtd-accessor (record-rtd component) 'position) component))

(define (set-position! component position)
  (assert (record? component))
  (cond
   ((screen-transform? component) (assert (vector2? position))))
  ((rtd-mutator (record-rtd component) 'position) component position))

(define (pivot component)
  (assert (record? component))
  ((rtd-accessor (record-rtd component) 'pivot) component))

(define (set-pivot! component pivot)
  (assert (record? component))
  (cond
   ((screen-transform? component) (assert (vector2? pivot))))
  ((rtd-mutator (record-rtd component) 'pivot) component pivot))

(define (rotation component)
  (assert (record? component))
  ((rtd-accessor (record-rtd component) 'rotation) component))

(define (set-rotation! component rotation)
  (assert (record? component))
  (cond
   ((screen-transform? component) (assert (real? rotation))))
  ((rtd-mutator (record-rtd component) 'rotation) component rotation))

(define (scale component)
  (assert (record? component))
  ((rtd-accessor (record-rtd component) 'scale) component))

(define (set-scale! component scale)
  (assert (record? component))
  (cond
   ((screen-transform? component) (assert (vector2? scale))))
  ((rtd-mutator (record-rtd component) 'scale) component scale))

(define (anchor component)
  (assert (record? component))
  ((rtd-accessor (record-rtd component) 'anchor) component))

(define (set-anchor! component anchor)
  (assert (record? component))
  (cond
   ((screen-transform? component)
    (assert (and (symbol? anchor)
		 (member anchor '(top-left top-middle top-right
					   center-left center center-right
					   bottom-left bottom-middle bottom-right))))))
  ((rtd-mutator (record-rtd component) 'anchor) component anchor))

(define (parent component)
  (assert (record? component))
  ((rtd-accessor (record-rtd component) 'parent) component))

(define (set-parent! component parent)
  (assert (record? component))
  (cond
   ((screen-transform? component)
    (assert (symbol? anchor))))
  ((rtd-mutator (record-rtd component) 'parent) component parent))

;; Visuals
;; Primitive shape visual types
(define-record-type <pixel-2d>
  (int:make-pixel-2d position)
  pixel-2d?
  (position pixel-2d-position int:set-pixel-2d-position!))

(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-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!))

;; TODO: might be nicer to have the origin and width/height inside a rect-2d type or similar
(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-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!))

;; Visual component
(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!))
)