;;
;; macaw:
;; Efficient color types and math for CHICKEN Scheme.
;;
;; Copyright © 2020  John Croisant.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;;  * Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;
;;  * Redistributions in binary form must reproduce the above
;;    copyright notice, this list of conditions and the following
;;    disclaimer in the documentation and/or other materials provided
;;    with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
;; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
;; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
;; OF THE POSSIBILITY OF SUCH DAMAGE.


;;; Defines a procedure which dispatches to other procedures depending
;;; on what type of record instance it is called with. The dispatching
;;; only works for record instances, but other types can be handled in
;;; the ELSE clause.
;;;
;;; Usage:
;;;
;;;   (define-struct-dispatch (array-ref a x y)
;;;     ((macaw:rgb-array macaw#macaw:rgb-array)
;;;      rgb-array-ref)
;;;     ((macaw:rgb8-array macaw#macaw:rgb8-array)
;;;      rgb8-array-ref)
;;;     ((macaw:hsl-array macaw#macaw:hsl-array)
;;;      hsl-array-ref)
;;;     (else (error "Not an array" a)))
;;;
(define-syntax define-struct-dispatch
  (syntax-rules (else)
    ((define-struct-dispatch (NAME X . ARGS)
       ((TYPE-NAME ...) FUNC)
       ...
       (else ELSE))
     (define (NAME X . ARGS)
       (case (and (record-instance? X) (record-instance-type X))
         ((TYPE-NAME ...) (FUNC X . ARGS))
         ...
         (else ELSE))))))


;;; Like foreign-lambda*, except the function body strings are
;;; created at macro expansion time using sprintf.
;;;
;;; Usage:
;;;
;;;   (foreign-lambda~
;;;    RETURN-TYPE
;;;    (ARG-TYPE ...)
;;;    (BODY-FORMATSTRING FORMAT-ARG ...)
;;;    ...)
;;;
;;; Because the body strings are constructed at macro expansion time,
;;; each FORMAT-ARG must be a literal value like a symbol, string, or
;;; number.
;;;
(define-syntax foreign-lambda~
  (ir-macro-transformer
   (lambda (form inject compare?)
     (let ((return-type (cadr form))
           (args        (caddr form))
           (bodies      (cdddr form)))
       `(foreign-lambda*
         ,return-type
         ,args
         ,@(map (lambda (body)
                  (apply sprintf (map strip-syntax body)))
                bodies))))))


;;; Macro-time if. Expands to one expression or the other, depending
;;; on whether the first argument is #f at macro expansion time.
(define-syntax macro-if
  (syntax-rules ()
    ;; First argument is #f, so expand to false-expr.
    ((macro-if #f true-expr false-expr)
     false-expr)
    ;; First argument is anything else, so expand to true-expr.
    ((macro-if x true-expr false-expr)
     true-expr)
    ;; No false-expr
    ((macro-if x true-expr)
     (macro-if x true-expr (begin)))))


(: clamp (number number number --> number))
(define (clamp n low high)
  (cond ((< n low) low)
        ((< high n) high)
        (else n)))

;;; Like modulo but works with non-integers.
(: wrap (number number --> number))
(define (wrap n high)
  (cond ((< n 0) (wrap (+ n high) high))
        ((< high n) (wrap (- n high) high))
        (else n)))