diff --git a/engine/components.scm b/engine/components.scm index d68e07a..54b220d 100644 --- a/engine/components.scm +++ b/engine/components.scm @@ -2,65 +2,12 @@ (import scheme (chicken base) (chicken module) + (engine core) (engine guards) (engine math) (srfi 1) - (srfi 4) (srfi 99)) -;; 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 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)) - ;; Screen transform record and exports (export make-screen-transform screen-transform?) @@ -84,7 +31,7 @@ (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))) + (assert (or (null? parent) (screen-transform? parent))) (int:make-screen-transform position pivot rotation scale anchor parent)) ;; Generic accessors and mutators for position, rotation, scale, anchor, and parent @@ -95,7 +42,10 @@ (define (position component) (assert (record? component)) - ((rtd-accessor (record-rtd component) 'position) component)) + (if (null? (parent component)) + ((rtd-accessor (record-rtd component) 'position) component) + (v+ ((rtd-accessor (record-rtd component) 'position) component) + (position (parent component))))) (define (set-position! component position) (assert (record? component)) @@ -157,149 +107,4 @@ ((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 (vec2? position)) - (int:make-pixel-2d position)) - -(define set-pixel-2d-position! - (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! - 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?))) - -(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?)) - -;; 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?))) - -(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?)) ) diff --git a/engine/drawing.scm b/engine/drawing.scm new file mode 100644 index 0000000..758ac5d --- /dev/null +++ b/engine/drawing.scm @@ -0,0 +1,230 @@ +(module (engine drawing) () +(import scheme + (chicken base) + (chicken module) + raylib + (engine guards) + (engine math) + (srfi 4) + (srfi 99)) + +;; Color exports +(export make-color color-r color-g color-b color-a + set-color-r! set-color-g! set-color-b! set-color-a!) + +;; Color type +(define-record-type + (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 ead9b9b..ca82e91 100644 --- a/engine/math.scm +++ b/engine/math.scm @@ -27,6 +27,12 @@ (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!) diff --git a/samples/bounce.scm b/samples/bounce.scm index 97f1d23..7f84621 100644 --- a/samples/bounce.scm +++ b/samples/bounce.scm @@ -5,6 +5,7 @@ (engine core) (engine components core) (engine math) + (engine drawing) (srfi 1) (srfi 99)) @@ -26,13 +27,11 @@ (lambda () (let ((draw-pos (v+ (position transform) (circle-2d-center circle)))) - ((if (circle-2d-filled? circle) - draw-circle - draw-circle-lines) - (v-x draw-pos) - (v-y draw-pos) + (draw-circle-2d + draw-pos (circle-2d-radius circle) - (visual-2d-color vis-2d)))))))))) + (visual-2d-color vis-2d) + (circle-2d-filled? circle)))))))))) (define-record-type