diff options
| -rw-r--r-- | sly/math/rect.scm | 80 | ||||
| -rw-r--r-- | sly/render/viewport.scm | 11 |
2 files changed, 42 insertions, 49 deletions
diff --git a/sly/math/rect.scm b/sly/math/rect.scm index 362cf69..79cc957 100644 --- a/sly/math/rect.scm +++ b/sly/math/rect.scm @@ -27,8 +27,8 @@ #:use-module (srfi srfi-9) #:use-module (sly math) #:use-module (sly math vector) - #:export (<rect> - make-rect + #:use-module (sly records) + #:export (make-rect null-rect rect? rect-x @@ -64,15 +64,16 @@ ;;; ;; The rect API is very similar to the Pygame rect API, but rects are -;; immutable. +;; immutable (to the public, anyway). -(define-record-type <rect> - (%make-rect x y width height) +(define-packed-f64-record-type <rect> + %make-rect + bytevector->rect rect->bytevector rect? - (x rect-x) - (y rect-y) - (width rect-width) - (height rect-height)) + (x 0 rect-x set-rect-x!) + (y 1 rect-y set-rect-y!) + (width 2 rect-width set-rect-width!) + (height 3 rect-height set-rect-height!)) (define make-rect (case-lambda @@ -84,14 +85,16 @@ (define null-rect (make-rect 0 0 0 0)) -(define (rect-right rect) +(define-inlinable (rect-right rect) (+ (rect-x rect) (rect-width rect))) -(define rect-left rect-x) +(define-inlinable (rect-left rect) + (rect-x rect)) -(define rect-bottom rect-y) +(define-inlinable (rect-bottom rect) + (rect-y rect)) -(define (rect-top rect) +(define-inlinable (rect-top rect) (+ (rect-y rect) (rect-height rect))) (define (rect-position rect) @@ -134,23 +137,13 @@ (vector2 (rect-width rect) (rect-height rect))) -(define (%rect-move rect x y) - "Move RECT by the offset X, Y." - (make-rect (+ (rect-x rect) x) - (+ (rect-y rect) y) +(define (rect-move rect v) + "Move RECT by the offset given by the 2D vector V." + (make-rect (+ (rect-x rect) (vector2-x v)) + (+ (rect-y rect) (vector2-y v)) (rect-width rect) (rect-height rect))) -(define rect-move - (case-lambda - "Create a new rectangle by moving RECT by the given -offset. rect-move accepts a vector or x and y coordinates as separate -arguments." - ((rect v) - (%rect-move rect (vx v) (vy v))) - ((rect x y) - (%rect-move rect x y)))) - (define (%rect-inflate rect width height) "Grows the rect by the given amount. The rect stays centered around its current center." @@ -185,11 +178,13 @@ RECT2. If the rects do not overlap, a rect of size 0 is returned." (y2 (min (rect-top rect1) (rect-top rect2)))) (make-rect x1 y1 (max (- x2 x1) 0) (max (- y2 y1) 0)))) -(define rect-clamp - (match-lambda* - ((($ <rect> rx ry width height) (? vector2? v)) - (vector2 (clamp rx (+ rx width) (vector2-x v)) - (clamp ry (+ ry height) (vector2-y v)))))) +(define (rect-clamp rect v) + (let ((x (rect-x rect)) + (y (rect-y rect)) + (width (rect-width rect)) + (height (rect-height rect))) + (vector2 (clamp x (+ x width) (vector2-x v)) + (clamp y (+ y height) (vector2-y v))))) (define (rect-within? rect1 rect2) "Return #t if RECT2 is completely within RECT1." @@ -205,16 +200,11 @@ RECT2. If the rects do not overlap, a rect of size 0 is returned." (< (rect-bottom rect1) (rect-top rect2)) (> (rect-top rect1) (rect-bottom rect2)))) -(define (%rect-contains? rect x y) - (and (>= x (rect-left rect)) - (< x (rect-right rect)) - (>= y (rect-bottom rect)) - (< y (rect-top rect)))) - -(define rect-contains? - (case-lambda - "Return #t if the 2D vector V (or the coordinates X and Y) is within RECT." - ((rect v) - (%rect-contains? rect (vx v) (vy v))) - ((rect x y) - (%rect-contains? rect x y)))) +(define (rect-contains? rect v) + "Return #t if the 2D vector V is within RECT." + (let ((x (vector2-x v)) + (y (vector2-y v))) + (and (>= x (rect-left rect)) + (< x (rect-right rect)) + (>= y (rect-bottom rect)) + (< y (rect-top rect))))) diff --git a/sly/render/viewport.scm b/sly/render/viewport.scm index 054646e..eb02825 100644 --- a/sly/render/viewport.scm +++ b/sly/render/viewport.scm @@ -79,10 +79,13 @@ values for CLEAR-FLAGS are 'color-buffer', 'depth-buffer', "Set the OpenGL state for VIEWPORT. Clip rendering to the viewport area, set the clear color, and clear necessary buffers." (gl-enable (enable-cap scissor-test)) - (match (viewport-area viewport) - (($ <rect> x y width height) - (gl-viewport x y width height) - (gl-scissor x y width height))) + (let* ((rect (viewport-area viewport)) + (x (inexact->exact (rect-x rect))) + (y (inexact->exact (rect-y rect))) + (width (inexact->exact (rect-width rect))) + (height (inexact->exact (rect-height rect)))) + (gl-viewport x y width height) + (gl-scissor x y width height)) (match (viewport-clear-color viewport) (($ <color> r g b a) (gl-clear-color r g b a)))) |