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


(define-syntax define-array-type
  (syntax-rules (color: memory: bpp:)
    ((define-array-type STRUCT-NAME
       ARRAY ARRAY? MAKE
       WIDTH HEIGHT PITCH
       REF REF-POINTER
       FOR-EACH FOR-EACH-POINTER
       color: (COLOR COLOR? COLOR-AT)
       memory: (AT %AT POINTER PARENT bpp: BPP))

     (begin
       (define-record-type STRUCT-NAME
         (%AT pointer width height pitch parent)
         ARRAY?
         (pointer POINTER)
         (width WIDTH)
         (height HEIGHT)
         (pitch PITCH)
         (parent PARENT (setter PARENT)))

       (define-type ARRAY (struct STRUCT-NAME))

       (define-record-printer (STRUCT-NAME a out)
         (display "#<" out)
         (display 'ARRAY out)
         (display " " out)
         (display (WIDTH a) out)
         (display "x" out)
         (display (HEIGHT a) out)
         (display ">" out))

       (: AT ((or pointer locative) fixnum fixnum #!optional fixnum --> ARRAY))
       (define (AT pointer width height #!optional pitch)
         (assert (or (pointer? pointer) (locative? pointer))
                 "not a pointer or locative" pointer)
         (let-values (((width height pitch)
                       (%array-settings width height pitch BPP)))
           (%AT pointer width height pitch #f)))

       (: MAKE (fixnum fixnum #!optional fixnum --> ARRAY))
       (define (MAKE width height #!optional pitch)
         (let-values (((width height pitch)
                       (%array-settings width height pitch BPP)))
           (%AT (make-locative (make-blob (* pitch height)))
                width height pitch #f)))

       (: REF (ARRAY fixnum fixnum --> COLOR))
       (define (REF a x y)
         (COLOR-AT (REF-POINTER a x y) a))

       (: REF-POINTER (ARRAY fixnum fixnum --> (or pointer locative)))
       (define (REF-POINTER a x y)
         (assert (< x (WIDTH a)))
         (assert (< y (HEIGHT a)))
         (let ((ptr (POINTER a))
               (offset (+ (* y (PITCH a)) (* x BPP))))
           (if (locative? ptr)
               (make-locative (locative->object ptr) offset)
               (pointer+ ptr offset))))

       (: FOR-EACH
          ((fixnum fixnum #!rest COLOR -> any)
           #!rest ARRAY -> undefined))
       (define (FOR-EACH f . arrays)
         (let ((width (apply min (map WIDTH arrays)))
               (height (apply min (map HEIGHT arrays))))
           (do ((y 0 (add1 y)))
               ((= y height))
             (do ((x 0 (add1 x)))
                 ((= x width))
               (apply f x y (map (cut REF <> x y) arrays))))))

       (: FOR-EACH-POINTER
          ((fixnum fixnum #!rest (or pointer locative) -> any)
           #!rest ARRAY -> undefined))
       (define (FOR-EACH-POINTER f . arrays)
         (let ((width (apply min (map WIDTH arrays)))
               (height (apply min (map HEIGHT arrays))))
           (do ((y 0 (add1 y)))
               ((= y height))
             (do ((x 0 (add1 x)))
                 ((= x width))
               (apply f x y (map (cut REF-POINTER <> x y) arrays))))))

       ))))


(define (%array-settings width height pitch bpp)
  (assert (and (integer? width) (positive? width))
          "width is not a positive integer" width)
  (assert (and (integer? height) (positive? height))
          "height is not a positive integer" height)
  (if pitch
      (assert (and (integer? pitch) (positive? pitch))
              "pitch is not a positive integer" pitch))
  (let* ((width (inexact->exact width))
         (height (inexact->exact height))
         (min-pitch (* width bpp))
         (pitch (if pitch
                    (inexact->exact pitch)
                    min-pitch)))
    (assert (>= pitch min-pitch)
            "pitch is smaller than minimum necessary pitch"
            pitch min-pitch)
    (values width height pitch)))