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


(export array?
        array-width array-height array-pitch
        array-ref array-ref-pointer
        array-for-each array-for-each-pointer)


(: array? (any --> boolean))
(define (array? x)
  (case (and (record-instance? x) (record-instance-type x))
    ((macaw:rgb-array
      macaw:rgb8-array
      macaw:hsl-array
      macaw#macaw:rgb-array
      macaw#macaw:rgb8-array
      macaw#macaw:hsl-array)
     #t)
    (else #f)))

(define-type array (or (struct macaw:rgb-array)
                       (struct macaw:rgb8-array)
                       (struct macaw:hsl-array)))
(declare (predicate (array? array)))


(: array-width (array --> fixnum))
(define-struct-dispatch (array-width a)
  ((macaw:rgb-array macaw#macaw:rgb-array)
   rgb-array-width)
  ((macaw:rgb8-array macaw#macaw:rgb8-array)
   rgb8-array-width)
  ((macaw:hsl-array macaw#macaw:hsl-array)
   hsl-array-width)
  (else (error "not an array" a)))

(: array-height (array --> fixnum))
(define-struct-dispatch (array-height a)
  ((macaw:rgb-array macaw#macaw:rgb-array)
   rgb-array-height)
  ((macaw:rgb8-array macaw#macaw:rgb8-array)
   rgb8-array-height)
  ((macaw:hsl-array macaw#macaw:hsl-array)
   hsl-array-height)
  (else (error "not an array" a)))

(: array-pitch (array --> fixnum))
(define-struct-dispatch (array-pitch a)
  ((macaw:rgb-array macaw#macaw:rgb-array)
   rgb-array-pitch)
  ((macaw:rgb8-array macaw#macaw:rgb8-array)
   rgb8-array-pitch)
  ((macaw:hsl-array macaw#macaw:hsl-array)
   hsl-array-pitch)
  (else (error "not an array" a)))


(: array-ref (array fixnum fixnum --> color))
(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)))


(: array-ref-pointer (array fixnum fixnum --> (or pointer locative)))
(define-struct-dispatch (array-ref-pointer a x y)
  ((macaw:rgb-array macaw#macaw:rgb-array)
   rgb-array-ref-pointer)
  ((macaw:rgb8-array macaw#macaw:rgb8-array)
   rgb8-array-ref-pointer)
  ((macaw:hsl-array macaw#macaw:hsl-array)
   hsl-array-ref-pointer)
  (else (error "not an array" a)))


(: array-for-each ((fixnum fixnum #!rest color -> any)
                   #!rest array -> undefined))
(define (array-for-each f . arrays)
  (let ((width (apply min (map array-width arrays)))
        (height (apply min (map array-height arrays))))
    (do ((y 0 (add1 y)))
        ((= y height))
      (do ((x 0 (add1 x)))
          ((= x width))
        (apply f x y (map (cut array-ref <> x y) arrays))))))


(: array-for-each-pointer
   ((fixnum fixnum #!rest (or pointer locative) -> any)
    #!rest array -> undefined))
(define (array-for-each-pointer f . arrays)
  (let ((width (apply min (map array-width arrays)))
        (height (apply min (map array-height arrays))))
    (do ((y 0 (add1 y)))
        ((= y height))
      (do ((x 0 (add1 x)))
          ((= x width))
        (apply f x y (map (cut array-ref-pointer <> x y) arrays))))))