math.scm 5.06 KB
Newer Older
1
;;; This is part of an example program demonstrating chicken-sdl2:
2
;;; https://gitlab.com/chicken-sdl2/chicken-sdl2-examples
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
;;;
;;; 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))
24
(define-inline (sq n) (* n n))
25 26 27 28 29 30 31 32 33


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

(: exact-round   (number -> fixnum))
(: exact-floor   (number -> fixnum))
(: exact-celeing (number -> fixnum))
34 35 36
(define-inline (exact-round   n) (exact (round   n)))
(define-inline (exact-floor   n) (exact (floor   n)))
(define-inline (exact-ceiling n) (exact (ceiling n)))
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53


;;; 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)))


54 55 56 57 58
(define (clamp n lower upper)
  (cond ((< n lower) lower)
        ((< upper n) upper)
        (else n)))

59 60 61 62 63 64

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

(: rect-right ((struct sdl2:rect) -> fixnum))
(: rect-bottom ((struct sdl2:rect) -> fixnum))
65 66
(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)))
67 68 69 70


(: rect-w/2 ((struct sdl2:rect) -> number))
(: rect-w/2-fx ((struct sdl2:rect) -> fixnum))
71 72
(define (rect-w/2 r)    (/ (sdl2:rect-w r) 2))
(define (rect-w/2-fx r) (fx/ (sdl2:rect-w r) 2))
73 74 75

(: rect-h/2 ((struct sdl2:rect) -> number))
(: rect-h/2-fx ((struct sdl2:rect) -> fixnum))
76 77
(define (rect-h/2 r)    (/ (sdl2:rect-h r) 2))
(define (rect-h/2-fx r) (fx/ (sdl2:rect-h r) 2))
78 79 80 81


(: rect-centerx ((struct sdl2:rect) -> number))
(: rect-centerx-fx ((struct sdl2:rect) -> fixnum))
82 83
(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)))
84 85 86

(: rect-centery ((struct sdl2:rect) -> number))
(: rect-centery-fx ((struct sdl2:rect) -> fixnum))
87 88
(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)))
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131

(: 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)))
132 133
    (sdl2:rect-set! r
                    (fx- cx (fx/ w 2))
134 135
                    (fx- cy (fx/ h 2))
                    w h)))
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157


;;; 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)))))