summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--sly/math/rect.scm80
-rw-r--r--sly/render/viewport.scm11
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))))