math.scm 5.06 KB
;;; This is part of an example program demonstrating chicken-sdl2:
;;; https://gitlab.com/chicken-sdl2/chicken-sdl2-examples
;;;
;;; The contents of this file are made available under the CC0 1.0
;;; Universal Public Domain Dedication. See LICENSE-CC0.txt or visit
;;; http://creativecommons.org/publicdomain/zero/1.0/


;;; This file defines various useful math procedures.

;;; ATTENTION!
;;;
;;; - Procedures with "-fx" use fixnums (exact integers). They are
;;;   faster, but don't work if passed floats or inexact integers!
;;;
;;; - sdl2:rect and sdl2:point fields must be integers, so many of
;;;   those procedures round their results to the nearest integer.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SCALAR MATH

(: sq (number -> number))
(define-inline (sq n) (* n n))


;;; R7RS alias.
(: exact (number -> fixnum))
(define exact inexact->exact)

(: exact-round   (number -> fixnum))
(: exact-floor   (number -> fixnum))
(: exact-celeing (number -> fixnum))
(define-inline (exact-round   n) (exact (round   n)))
(define-inline (exact-floor   n) (exact (floor   n)))
(define-inline (exact-ceiling n) (exact (ceiling n)))


;;; Round number N to have no more than D digits after the decimal
;;; point. (Negative D will round before the decimal point, as a
;;; useful quirk of how this is implemented.)
;;;
;;; (round-digits 1.23456 3)  => 1.235
;;; (round-digits 1.2     3)  => 1.2
;;; (round-digits 1       3)  => 1
;;; (round-digits 123456 -2)  => 1235000.0
;;;
(: round-digits (number fixnum -> number))
(define (round-digits n d)
  (let ((scale (expt 10 d)))
    (/ (round (* n scale)) scale)))


(define (clamp n lower upper)
  (cond ((< n lower) lower)
        ((< upper n) upper)
        (else n)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RECT MATH

(: rect-right ((struct sdl2:rect) -> fixnum))
(: rect-bottom ((struct sdl2:rect) -> fixnum))
(define (rect-right r)  (fx+ (sdl2:rect-x r) (sdl2:rect-w r)))
(define (rect-bottom r) (fx+ (sdl2:rect-y r) (sdl2:rect-h r)))


(: rect-w/2 ((struct sdl2:rect) -> number))
(: rect-w/2-fx ((struct sdl2:rect) -> fixnum))
(define (rect-w/2 r)    (/ (sdl2:rect-w r) 2))
(define (rect-w/2-fx r) (fx/ (sdl2:rect-w r) 2))

(: rect-h/2 ((struct sdl2:rect) -> number))
(: rect-h/2-fx ((struct sdl2:rect) -> fixnum))
(define (rect-h/2 r)    (/ (sdl2:rect-h r) 2))
(define (rect-h/2-fx r) (fx/ (sdl2:rect-h r) 2))


(: rect-centerx ((struct sdl2:rect) -> number))
(: rect-centerx-fx ((struct sdl2:rect) -> fixnum))
(define (rect-centerx r)    (+ (sdl2:rect-x r) (rect-w/2 r)))
(define (rect-centerx-fx r) (fx+ (sdl2:rect-x r) (rect-w/2-fx r)))

(: rect-centery ((struct sdl2:rect) -> number))
(: rect-centery-fx ((struct sdl2:rect) -> fixnum))
(define (rect-centery r)    (+ (sdl2:rect-y r) (rect-h/2 r)))
(define (rect-centery-fx r) (fx+ (sdl2:rect-y r) (rect-h/2-fx r)))

(: rect-center ((struct sdl2:rect) -> (struct sdl2:point)))
(define (rect-center r)
  (sdl2:make-point (rect-centerx-fx r)
                   (rect-centery-fx r)))


;;; Create a rect centered at (cx, cy). The results will be rounded to
;;; the nearest integer.
(: centered-rect
   (number number number number
    -> (struct sdl2:rect)))
(define (centered-rect cx cy w h)
  (sdl2:make-rect (exact-round (- cx (/ w 2)))
                  (exact-round (- cy (/ h 2)))
                  (exact-round w)
                  (exact-round h)))

;;; Like centered-rect, but uses fixnum math.
(: centered-rect-fx
   (fixnum fixnum fixnum fixnum
    -> (struct sdl2:rect)))
(define (centered-rect-fx cx cy w h)
  (sdl2:make-rect (fx- cx (fx/ w 2))
                  (fx- cy (fx/ h 2))
                  w h))


;;; Move the given rect so that its center is at the given
;;; coordinates. cx and cy will be rounded.
(: recenter-rect!
   ((struct sdl2:rect) number number
    -> (struct sdl2:rect)))
(define (recenter-rect! r cx cy)
  (recenter-rect-fx! r (exact-round cx) (exact-round cy)))

;;; Like recenter-rect!, but uses fixnum math.
(: recenter-rect-fx!
   ((struct sdl2:rect) fixnum fixnum
    -> (struct sdl2:rect)))
(define (recenter-rect-fx! r cx cy)
  (let ((w (sdl2:rect-w r))
        (h (sdl2:rect-h r)))
    (sdl2:rect-set! r
                    (fx- cx (fx/ w 2))
                    (fx- cy (fx/ h 2))
                    w h)))


;;; Returns the x and y amounts that r1 would need to move in order to
;;; be inside r2. Returns 0 0 if r1 is already inside r2.
(define (need-clamp-rect r1 r2)
  ;; pos is either x or y. dim is either w or h.
  (define (change-needed pos1 dim1 pos2 dim2)
    ;; If r1 left/top is outside of r2...
    (if (< pos1 pos2)
        ;; Then move so left/top edges are equal.
        (- pos2 pos1)
        ;; Otherwise, if r1 right/bottom is outside of r2...
        (if (> (+ pos1 dim1) (+ pos2 dim2))
            ;; Then move so right/bottom edges are equal.
            (- (+ pos2 dim2) (+ pos1 dim1))
            ;; Otherwise, no change is needed.
            0)))

  (receive (x1 y1 w1 h1) (sdl2:rect->values r1)
    (receive (x2 y2 w2 h2) (sdl2:rect->values r2)
      (values (change-needed x1 w1 x2 w2)
              (change-needed y1 h1 y2 h2)))))