97 lines
2.6 KiB
Scheme
97 lines
2.6 KiB
Scheme
|
;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
|
||
|
|
;;;
|
||
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||
|
|
;;; you may not use this file except in compliance with the License.
|
||
|
|
;;; You may obtain a copy of the License at
|
||
|
|
;;;
|
||
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||
|
|
;;;
|
||
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
||
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||
|
|
;;; See the License for the specific language governing permissions and
|
||
|
|
;;; limitations under the License.
|
||
|
|
|
||
|
|
;;; Commentary:
|
||
|
|
;;;
|
||
|
|
;;; Rectangle data type.
|
||
|
|
;;;
|
||
|
|
;;; Code:
|
||
|
|
|
||
|
|
(define-module (math rect)
|
||
|
|
#:pure
|
||
|
|
#:use-module (scheme base)
|
||
|
|
#:use-module ((hoot bytevectors)
|
||
|
|
#:select
|
||
|
|
(bytevector-ieee-double-native-ref
|
||
|
|
bytevector-ieee-double-native-set!))
|
||
|
|
#:export (make-rect
|
||
|
|
rect?
|
||
|
|
rect-x
|
||
|
|
rect-y
|
||
|
|
rect-width
|
||
|
|
rect-height
|
||
|
|
set-rect-x!
|
||
|
|
set-rect-y!
|
||
|
|
set-rect-width!
|
||
|
|
set-rect-height!
|
||
|
|
rect-intersects?
|
||
|
|
rect-clip))
|
||
|
|
|
||
|
|
;; For speed, a rect is a wrapper around a bytevector so that we can
|
||
|
|
;; use unboxed floats.
|
||
|
|
(define-record-type <rect>
|
||
|
|
(%make-rect bv)
|
||
|
|
rect?
|
||
|
|
(bv rect-bv))
|
||
|
|
|
||
|
|
(define f64-ref bytevector-ieee-double-native-ref)
|
||
|
|
(define f64-set! bytevector-ieee-double-native-set!)
|
||
|
|
|
||
|
|
(define (make-rect x y w h)
|
||
|
|
(let ((bv (make-bytevector (* 8 4))))
|
||
|
|
(f64-set! bv 0 x)
|
||
|
|
(f64-set! bv 8 y)
|
||
|
|
(f64-set! bv 16 w)
|
||
|
|
(f64-set! bv 24 h)
|
||
|
|
(%make-rect bv)))
|
||
|
|
|
||
|
|
(define (rect-x r)
|
||
|
|
(f64-ref (rect-bv r) 0))
|
||
|
|
|
||
|
|
(define (rect-y r)
|
||
|
|
(f64-ref (rect-bv r) 8))
|
||
|
|
|
||
|
|
(define (rect-width r)
|
||
|
|
(f64-ref (rect-bv r) 16))
|
||
|
|
|
||
|
|
(define (rect-height r)
|
||
|
|
(f64-ref (rect-bv r) 24))
|
||
|
|
|
||
|
|
(define (set-rect-x! r x)
|
||
|
|
(f64-set! (rect-bv r) 0 x))
|
||
|
|
|
||
|
|
(define (set-rect-y! r y)
|
||
|
|
(f64-set! (rect-bv r) 8 y))
|
||
|
|
|
||
|
|
(define (set-rect-width! r width)
|
||
|
|
(f64-set! (rect-bv r) 16 width))
|
||
|
|
|
||
|
|
(define (set-rect-height! r height)
|
||
|
|
(f64-set! (rect-bv r) 24 height))
|
||
|
|
|
||
|
|
(define (rect-intersects? a b)
|
||
|
|
(and (< (rect-x a) (+ (rect-x b) (rect-width b)))
|
||
|
|
(< (rect-y a) (+ (rect-y b) (rect-height b)))
|
||
|
|
(> (+ (rect-x a) (rect-width a)) (rect-x b))
|
||
|
|
(> (+ (rect-y a) (rect-height a)) (rect-y b))))
|
||
|
|
|
||
|
|
(define (rect-clip a b)
|
||
|
|
(let* ((x1 (max (rect-x a) (rect-x b)))
|
||
|
|
(x2 (min (+ (rect-x a) (rect-width a))
|
||
|
|
(+ (rect-x b) (rect-width b))))
|
||
|
|
(y1 (max (rect-y a) (rect-y b)))
|
||
|
|
(y2 (min (+ (rect-y a) (rect-height a))
|
||
|
|
(+ (rect-y b) (rect-height b)))))
|
||
|
|
(make-rect x1 y1 (- x2 x1) (- y2 y1))))
|