;;;
;;; 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 color type and its constructor, accessors, etc.
;;;
;;; A color type holds a pointer or locative to its numerical data.
;;; Newly constructed colors will hold a locative of a SRFI-4 numeric
;;; vector, but advanced users can use the "at" procedure to create a
;;; color from a static memory pointer, a locative of a blob, etc.
;;;
(define-syntax define-color-type
  (syntax-rules (min: max: default: memory:)
    ((define-color-type STRUCT-NAME
       SELF SELF? SELF= SELF-SET!
       SELF->VALUES SELF->LIST
       SELF-COPY SELF-COPY!
       ((FIELD-NAME FIELD-I FIELD-GET FIELD-SET! FIELD-TYPE
                    min: FIELD-MIN max: FIELD-MAX)
        ...
        (ALPHA-NAME ALPHA-I ALPHA-GET ALPHA-SET! ALPHA-TYPE
                    min: ALPHA-MIN max: ALPHA-MAX
                    default: ALPHA-DEFAULT))
       memory: (AT %AT POINTER PARENT
                   NVECTOR FOREIGN-TYPE
                   NCOLOR-SET! NCOLOR->VALUES))

     (begin
       (define-record-type STRUCT-NAME
         (%AT pointer parent)
         SELF?
         (pointer POINTER (setter POINTER))
         (parent PARENT (setter PARENT)))

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

       (define-record-printer (STRUCT-NAME c out)
         (display "#<" out)
         (display 'SELF out)
         (begin
           (display " " out)
           (display (FIELD-GET c) out))
         ...
         (display " " out)
         (display (ALPHA-GET c) out)
         (display ">" out))

       (: AT ((or pointer locative) #!optional any --> SELF))
       (define (AT pointer #!optional parent)
         (assert (or (pointer? pointer) (locative? pointer))
                 "not a pointer or locative" pointer)
         (%AT pointer parent))

       (: SELF (FIELD-TYPE ... #!optional ALPHA-TYPE --> SELF))
       (define (SELF FIELD-NAME ... #!optional (ALPHA-NAME ALPHA-DEFAULT))
         (macro-if FIELD-MIN (assert (<= FIELD-MIN FIELD-NAME FIELD-MAX)))
         ...
         (macro-if ALPHA-MIN (assert (<= ALPHA-MIN ALPHA-NAME ALPHA-MAX)))
         (%AT (make-locative (NVECTOR FIELD-NAME ... ALPHA-NAME)) #f))

       (: SELF= (SELF SELF --> boolean))
       (define (SELF= c1 c2)
         (and (= (FIELD-GET c1) (FIELD-GET c2))
              ...
              (= (ALPHA-GET c1) (ALPHA-GET c2))))

       (: SELF-SET! (SELF FIELD-TYPE ... ALPHA-TYPE -> SELF))
       (define (SELF-SET! c FIELD-NAME ... ALPHA-NAME)
         (NCOLOR-SET! (POINTER c) FIELD-NAME ... ALPHA-NAME)
         c)

       (: SELF->VALUES (SELF --> FIELD-TYPE ... ALPHA-TYPE))
       (define (SELF->VALUES c)
         (NCOLOR->VALUES (POINTER c)))

       (: SELF->LIST (SELF --> (list FIELD-TYPE ... ALPHA-TYPE)))
       (define (SELF->LIST c)
         (call-with-values (cut SELF->VALUES c) list))

       (: SELF-COPY (SELF --> SELF))
       (define (SELF-COPY c)
         (call-with-values (cut SELF->VALUES c) SELF))

       (: SELF-COPY! (SELF SELF -> SELF))
       (define (SELF-COPY! src dst)
         ;; TODO: Optimize
         (FIELD-SET! dst (FIELD-GET src))
         ...
         (ALPHA-SET! dst (ALPHA-GET src))
         dst)

       (define-color-field SELF POINTER FOREIGN-TYPE
         FIELD-NAME FIELD-I FIELD-GET FIELD-SET! FIELD-TYPE
         min: FIELD-MIN max: FIELD-MAX)
       ...
       (define-color-field SELF POINTER FOREIGN-TYPE
         ALPHA-NAME ALPHA-I ALPHA-GET ALPHA-SET! ALPHA-TYPE
         min: ALPHA-MIN max: ALPHA-MAX)))))


(define-syntax define-color-field
  (syntax-rules (min: max:)
    ((define-color-field SELF POINTER FOREIGN-TYPE
       FIELD-NAME FIELD-I FIELD-GET FIELD-SET! FIELD-TYPE
       min: FIELD-MIN max: FIELD-MAX)
     (begin
       (: FIELD-SET! (SELF FIELD-TYPE -> undefined))
       (define FIELD-SET!
         (let ((raw
                (foreign-lambda~
                 void
                 (((nonnull-c-pointer FOREIGN-TYPE) c)
                  ((const FOREIGN-TYPE) n))
                 ("c[~A] = n;" FIELD-I))))
           (lambda (c n)
             (macro-if FIELD-MIN (assert (<= FIELD-MIN n FIELD-MAX)))
             (raw (POINTER c) n)
             c)))

       (: FIELD-GET (SELF --> FIELD-TYPE))
       (define FIELD-GET
         (let ((raw
                (foreign-lambda~
                 FOREIGN-TYPE
                 (((const (nonnull-c-pointer FOREIGN-TYPE)) c))
                 ("C_return(c[~A]);" FIELD-I))))
           (getter-with-setter
            (lambda (c)
              (raw (POINTER c)))
            FIELD-SET!)))))))