;;; File:
;;;   gimp.scm
;;; Version:
;;;   0.5.1 of 27 November 2006
;;; Authors:
;;;   Samuel A. Rebelsky
;;;   Janet Davis
;;;   Ian Bone-Rundle
;;;   Anthony Leguia
;;;   Saugar Sainju
;;; Summary:
;;;   A collection of Scheme procedures to make Script-FU and GIMP
;;;   easier to use.
;;; Contents:
;;;   Design Notes: General notes on the structure of the program
;;;     1. Image representation
;;;     2. Color representation
;;;   Standard Scheme: Some standard Scheme procedures that SIOD lacks.
;;;     (close-input-port port)
;;;       Close a port/stream opened by open-input-file.
;;;     (close-output-port port)
;;;       Close a port/stream opened by open-output-file.
;;;     else
;;;       The syntactic fun in conds
;;;     (eof-object? val)
;;;       Determine if val represents the end of file.
;;;     (even? int)
;;;       Determines if an int is even.
;;;     (integer? val)
;;;       A hack replacement for one of my favorite predicates.
;;;       Unfortunately, SIOD does not seem to distinguish integers
;;;       from other numbers.
;;;     (list? val)
;;;       Determine if val is a list.
;;;;    (list->string lst)
;;;       Convert a list of characters to a string.
;;;     (list->vector lst)
;;;       Convert a list of values to a vector.
;;;     (list-ref lst pos)
;;;       Extract the value at the specified position.
;;;     (map proc lst1 lst2 ... lstn)
;;;       Everyone's favorite higher-order procedure.
;;;     (modulo dividend divisor)
;;;       Compute the remainder, more or less.
;;;     (odd? int)
;;;       Determine if int is odd.
;;;     (open-input-file fname)
;;;       Open a file for reading.  Returns an input port.
;;;     (open-output-file fname)
;;;       Open a file for writing.  Returns an output port.
;;;     (peek-char input-port)
;;;       Read, but do not remove, a character from the given port.
;;;     (random max)
;;;       Compute a "random" number in the range [0..max).
;;;     (read-char input-port)
;;;       Reads and remove one character from the given input port.
;;;     (string-ref str pos)
;;;       Extract the character at position pos from str.  (In the GIMP,
;;;       characters are integers.)
;;;     (vector-ref vec pos)
;;;       Extract the value at position pos from vec.
;;;     (vector-set! vec pos val)
;;;       Set the value at the specified position to val.
;;;   Input:
;;;     (eol-object? val)
;;;       Check if val is the end-of-line character.
;;;     (read-line input-port)
;;;       Read one line from the port, returning it as a string.
;;;     (read-lines fname)
;;;       Read all the lines from the file, returning them as a
;;;       list of strings.
;;;   GIMP Constants: Values mentioned in Script-Fu docs, but not defined.
;;;     GIMP_CHANNEL_OP_ADD
;;;       A parameter to selection operations to indicate that we
;;;       should add the selection to the current selection.
;;;     GIMP_CHANNEL_OP_SUBTRACT
;;;       A parameter to selection operations to indicate that we
;;;       should subtract the selection from the current selection.
;;;     GIMP_CHANNEL_OP_REPLACE
;;;       A parameter to selection operations to indicate that we
;;;       should use the new selection as the current seleection.
;;;     GIMP_CHANNEL_OP_INTERSECT
;;;       A parameter to selection operations to indicate that we
;;;       should intersect the selection with the current selection.
;;;   Constructors: Ways to build image values.
;;;     (create-image width height)
;;;       Create a new image of the specified width and height.
;;;     (load-image fname)
;;;       Load an image from a file
;;;   Colors: Named color values
;;;     colors
;;;       A list of strings for all the named colors.
;;;     (color->list color)
;;;       Convert a color to a list of the RGB components.
;;;     (is-color? val)
;;;       Determine whether the specified value is a color.
;;;     (array-color? val)
;;;       Determine whether the specified value is a particular represntation
;;;       of a color.
;;;     (list-color? val)
;;;       Determine whether the specified value is a particular represntation
;;;       of a color.
;;;     (set-fgcolor color)
;;;       Set the foreground color.
;;;     (set-bgcolor color)
;;;       Set the background color.
;;;   Drawing:
;;;     (line image x0 y0 x1 y1)
;;;     (draw-text image str font x y)
;;; History:
;;;   At end.

; +--------------+----------------------------------------------------
; | Design Notes |
; +--------------+

; 1. Image Representation
;    Images can be represented in a variety of ways.  The simplest
;    representation is a two-element list with image id and layer id.
;    We also provide ways to convert image names to this representation.
;
; 2. Colors
;    There are currently two ways to represent colors.  A color can
;    be a list of three integers (each in the range 0-255) or a color
;    can be an array of three bytes.


; +-----------------+-------------------------------------------------
; | Standard Scheme |
; +-----------------+

(define close-input-port fclose)

(define close-output-port fclose)

(define else #t)

(define eof-object? null?)

(define even? (lambda (val) (eq? (modulo val 2) 0)))

(define integer? number?)

(define list-ref
  (letrec ((kernel (lambda (lst pos)
                     (cond
                       ((null? lst) 
                        (crash 'list-ref 
                               "Too few elements in list."))
                       ((not (pair? lst) 
                             (crash 'list-ref 
                                    "Received non-list as first parameter.")))
                       ((= pos 0) (car lst))
                       (else (kernel (cdr lst) (- pos 1)))))))
    (lambda (lst pos)
      (cond
        ((not (integer? pos))
         (crash 'list-ref 
                "Expected an integer as second parameter, recieved: " 
                pos))
        ((< pos 0)
         (crash 'list-ref 
                "Expected a positive integer as second parameter, received: "
                pos))
        (else (kernel lst pos))))))

(define list?
  (lambda (val)
    (or (null? val)
        (and (pair? val)
             (list? (cdr val))))))

(define list->vector
  (letrec ((kernel
            (lambda (lst vec pos len)
              (if (= pos len) vec
                  (begin
                    (vector-set! vec pos (car lst))
                    (kernel (cdr lst) vec (+ pos 1) len))))))
    (lambda (lst)
      (let ((len (length lst)))
        (kernel lst (cons-array len) 0 len)))))

(define list->string
  (letrec ((kernel
            (lambda (lst str pos len)
              (if (= pos len)
                  str
                  (begin
                    (aset str pos (car lst))
                    (kernel (cdr lst) str (+ 1 pos) len))))))
    (lambda (lst)
      (let ((len (length lst)))
        (kernel lst (cons-array len 'string) 0 len)))))

(define map mapcar)

(define modulo fmod)

(define mod
  (let ((kernel (lambda (dividend divisor)
                  (if (< dividend divisor) dividend
                      (mod (- dividend divisor) divisor)))))
    (lambda (dividend divisor)
      (cond
        ((not (integer? dividend))
         (crash 'mod 
                "expects an integer as first parameter, received: "
                dividend))
        ((< dividend 0)
         (crash 'mod 
                "expects non-negative integer as first parameter, received: "
                dividend))
        ((not (integer? divisor))
         (crash 'mod 
                "expects an integer as second parameter, received: "
                divisor))
        ((< divisor 1)
         (crash 'mod 
                "expects a positive integer as second parameter, received: "
                divisor))
        (else (kernel dividend divisor))))))

(define null ())

(define odd? (lambda (val) (eq? (modulo val 2) 1)))

(define open-input-file
  (lambda (fname)
    (fopen fname "r")))

(define open-output-file
  (lambda (fname)
    (fopen fname "w")))

(define peek-char
  (lambda (stream)
    (let ((ch (getc stream)))
      (ungetc ch stream)
      ch)))

(define random rand)

(define read-char getc)

(define real? number?)

(define string-ref aref)

(define vector
  (lambda vals
    (list->vector vals)))

(define vector-length length)

(define vector-ref aref)

(define vector-set! aset)

(define vector->list
  (letrec ((kernel (lambda (vec pos len)
                     (if (= pos len)
                         null
                         (cons (vector-ref vec pos) 
                               (kernel vec (+ pos 1) len))))))
    (lambda (vec)
      (kernel vec 0 (vector-length vec)))))

; +-----------------+-------------------------------------------------
; | Input Utilities |
; +-----------------+

;;; Procedure:
;;;   eol-char?
;;; Parameters:
;;;   ch, a character
;;; Purpose:
;;;   Determines if the character is the end-of-line character.
;;; Produces:
;;;   is-eol?, a boolean.
(define eol-char? 
  (let ((newline-char (string-ref "\n" 0)))
    (lambda (ch)
      (eq? ch newline-char))))

;;; Procedure:
;;;   read-line
;;; Parameters:
;;;   input-port, an input port
;;; Purpose:
;;;   Reads one line from the input port.
;;; Produces:
;;;   line, a string.
;;; Preconditions:
;;;   input-port is open for reading.
;;; Postconditions:
;;;   One line has been read.
(define read-line
  (let ((cr (string-ref "\r" 0)))
    ; The kernel reads a list of characters until hitting the newline.
    (letrec ((kernel
              (lambda (input-port)
                (let ((ch (read-char input-port)))
                  (cond
                    ; At the end of line, there are no more characters.
                    ((or (eof-object? ch) (eol-char? ch))
                     null)
                    ; Drop carriage returns.  (Macs and PCs tend to insert
                    ; them before newlines.)
                    ((eq? ch cr) (kernel input-port))
                    (else (cons ch (kernel input-port))))))))
      (lambda (input-port)
        (list->string (kernel input-port))))))

;;; Procedure:
;;;   read-lines
;;; Parameters:
;;;   fname, a string
;;; Purpose:
;;;   Reads all the lines from the file.
;;; Produces:
;;;   lines, a list of strings string.
;;; Preconditions:
;;;   fname names a readable file.
;;; Postconditions:
;;;   (list-ref lines i) represents line i of file fname.
(define read-lines
  (letrec ((kernel 
            (lambda (input-port)
              (if (eof-object? (peek-char input-port))
                  (begin
                    (close-input-port input-port)
                    null)
                  (cons (read-line input-port)
                        (kernel input-port))))))
    (lambda (fname)
      (kernel (open-input-file fname)))))


; +----------------+--------------------------------------------------
; | GIMP Constants |
; +----------------+

(define GIMP_CHANNEL_OP_ADD 0)
(define GIMP_CHANNEL_OP_SUBTRACT 1)
(define GIMP_CHANNEL_OP_REPLACE 2)
(define GIMP_CHANNEL_OP_INTERSECT 3)
(define ADD GIMP_CHANNEL_OP_ADD)
(define SUBTRACT GIMP_CHANNEL_OP_SUBTRACT)
(define REPLACE GIMP_CHANNEL_OP_REPLACE)
(define INTERSECT GIMP_CHANNEL_OP_INTERSECT)
(define BEZIER_ANCHOR 1.0)
(define BEZIER_CONTROL 2.0)
(define BEZIER_MOVE 3.0)

; +--------------+----------------------------------------------------
; | Constructors |
; +--------------+

;;; Procedure:
;;;   image?
;;; Parameters:
;;;   val, a Scheme value
;;; Purpose:
;;;   Determine if val is one of the valid image descriptions.
(define image?
  (lambda (val)
    (or (image-id? val) 
        (string? val)
        (and (list? val) (= (length val) 2) (image-id? (car val))))))

;;; Procedure:
;;;   create-image
;;; Parameters:
;;;   width, a positive integer
;;;   height, a positive integer
;;; Purpose:
;;;   Create an image of the given width and height.
;;; Produces:
;;;   img, an encapsulated image
(define create-image
  (lambda (width height)
    (let* ((image (car (gimp-image-new width height 0)))
           (layer (car (gimp-layer-new image width height 0 "Layer" 100 0))))
      (gimp-image-add-layer image layer 0)
      (gimp-selection-all image)
      (gimp-edit-clear layer)
      (gimp-selection-none image)
      (list image layer))))

;;; Procedure:
;;;   load-image
;;; Parameters:
;;;   fname, a string
;;; Purpose:
;;;   Loads the given image
;;; Produces:
;;;   img, an encapsulated image that corresponds to the image stored
;;;     in the given file.
;;; Preconditions:
;;;   fname names a valid image file.
(define load-image
  (lambda (fname)
    (let* ((image (car (gimp-file-load 1 fname fname)))
           (layer (car (gimp-image-get-active-layer image))))
      (list image layer))))


; +--------+----------------------------------------------------------
; | Colors |
; +--------+

(define ALGAE_GREEN '(0 128 0))
(define AQUAMARINE '(112 219 147))
(define BAKERS_CHOCOLATE '(92 51 23))
(define BLACK '(0 0 0))
(define BLAH_GREY '(153 153 153))
(define BLOOD_ORANGE '(204 17 0))
(define BLOOD_RED '(102 0 0))
(define BLUE '(0 0 255))
(define BLUE_VIOLET '(159 95 159))
(define BRASS '(181 166 66))
(define BRIGHT_GOLD '(217 217 25))
(define BRONZE '(140 120 83))
(define BRONZE_II '(166 125 61))
(define BROWN '(78 47 47))
(define CADET_BLUE '(95 159 159))
(define CARDINAL_RED '(255 22 22))
(define CERULEAN '(51 0 204))
(define CHARCOAL '(51 51 51))
(define COBALT_BLUE '(102 102 255))
(define COOL_COPPER '(217 135 25))
(define COPPER '(184 115 51))
(define CORAL '(255 127 0))
(define CORN_FLOWER_BLUE '(66 66 111))
(define CYAN '(0 255 255))
(define DARK_BROWN '(92 64 51))
(define DARK_CHERRY_RED '(85 17 16))
(define DARK_FOREST_GREEN '(34 51 17))
(define DARK_GREEN '(47 79 47))
(define DARK_GREEN_COPPER '(74 118 110))
(define DARK_OLIVE_GREEN '(79 79 47))
(define DARK_ORCHID '(153 50 205))
(define DARK_PURPLE '(135 31 120))
(define DARK_SLATE_BLUE '(107 35 142))
(define DARK_SLATE_GREY '(47 79 79))
(define DARK_TAN '(151 105 79))
(define DARK_TURQUOISE '(112 147 219))
(define DARK_WOOD '(133 94 66))
(define DEEP_MIDNIGHT_BLUE '(17 17 68))
(define DEEP_PURPLE '(85 16 85))
(define DIM_GREY '(84 84 84))
(define DUSTY_ROSE '(133 99 99))
(define FELDSPAR '(209 146 117))
(define FIREBRICK '(142 35 35))
(define FOREST_GREEN '(35 142 35))
(define FUCHSIA '(255 0 170))
(define GOLD '(205 127 50))
(define GOLDENROD '(219 219 112))
(define GRAPE '(204 0 255))
(define GREEN '(0 255 0))
(define GREEN_COPPER '(82 127 118))
(define GREEN_YELLOW '(147 219 112))
(define GREY '(168 168 168))
(define HOT_PINK '(255 0 102))
(define HUNTER_GREEN '(33 94 33))
(define INDIAN_RED '(166 42 42))
(define INDIGO '(102 0 255))
(define KHAKI '(159 159 95))
(define LAVENDER '(204 153 204))
(define LIGHT_AVOCADO_GREEN '(66 170 66))
(define LIGHT_BLUE '(192 217 217))
(define LIGHT_GREY '(192 192 192))
(define LIGHT_STEEL_BLUE '(143 143 189))
(define LIGHT_WOOD '(233 194 166))
(define LIME_GREEN '(50 205 50))
(define MAGENTA '(255 0 255))
(define MANDARIAN_ORANGE '(228 120 51))
(define MAROON '(142 35 107))
(define MEDIUM_AQUAMARINE '(50 205 153))
(define MEDIUM_BLUE '(50 50 205))
(define MEDIUM_FOREST_GREEN '(107 142 35))
(define MEDIUM_GOLDENROD '(234 234 174))
(define MEDIUM_GREY '(128 128 128))
(define MEDIUM_ORCHID '(147 112 219))
(define MEDIUM_SEA_GREEN '(66 111 66))
(define MEDIUM_SLATE_BLUE '(127 0 255))
(define MEDIUM_SPRING_GREEN '(127 255 0))
(define MEDIUM_TURQUOISE '(112 219 219))
(define MEDIUM_VIOLET_RED '(219 112 147))
(define MEDIUM_WOOD '(166 128 100))
(define MIDNIGHT_BLUE '(47 47 79))
(define MUSTARD '(255 204 17))
(define NAVY_BLUE '(35 35 142))
(define NECTARINE '(255 51 0))
(define NEON_AVOCADO '(0 255 102))
(define NEON_BLUE '(77 77 255))
(define NEON_PINK '(255 110 199))
(define NEW_MIDNIGHT_BLUE '(0 0 156))
(define NEW_TAN '(235 199 158))
(define NOVA_SCOTIA_SALMON '(255 51 51))
(define OCEAN_BLUE '(0 0 128))
(define OFF-WHITE_GREEN '(204 255 204))
(define OLD_GOLD '(207 181 59))
(define ORANGE '(255 119 0))
(define ORANGE_RED '(255 36 0))
(define ORCHID '(219 112 219))
(define OREGON_SALMON '(255 119 34))
(define PALE_BLUE '(187 221 255))
(define PALE_GREEN '(143 188 143))
(define PALE_PINK '(255 204 204))
(define PARROT_GREEN '(51 255 51))
(define PEACH '(255 153 85))
(define PENCIL_LEAD '(102 102 102))
(define PERIWINKLE '(170 170 255))
(define PINE_GREEN '(0 51 0))
(define PINK '(188 143 143))
(define PLUM_PINK '(234 173 234))
(define POPCORN '(255 255 170))
(define PURPLE '(170 0 255))
(define PYRIDIUM_ORANGE '(240 168 4))
(define QUARTZ '(217 217 243))
(define RED '(255 0 0))
(define RICH_BLUE '(89 89 171))
(define ROSE '(255 0 204))
(define ROYAL_BLUE '(51 51 255))
(define SALMON '(111 66 66))
(define SCARLET '(140 23 23))
(define SEA_ALGAE_GREEN '(0 255 170))
(define SEA_GREEN '(35 142 104))
(define SEATTLE_SALMON '(255 102 102))
(define SEMI-SWEET_CHOCOLATE '(107 66 38))
(define SIENNA '(142 107 35))
(define SILVER '(230 232 250))
(define SKY_BLUE '(50 153 204))
(define SLATE_BLUE '(0 127 255))
(define SPICY_PINK '(255 28 174))
(define SPRING_GREEN '(0 255 127))
(define STEEL_BLUE '(35 107 142))
(define SUMMER_SKY '(56 176 222))
(define TAN '(219 147 112))
(define TEAL '(52 159 121))
(define THISTLE '(216 191 216))
(define TURQUOISE '(0 221 170))
(define TURQUOISE '(173 234 234))
(define VERY_DARK_BROWN '(92 64 51))
(define VERY_LIGHT_GREY '(205 205 205))
(define VIOLET '(79 47 79))
(define VIOLET_RED '(204 50 153))
(define WHEAT '(216 216 191))
(define WHITE '(255 255 255))
(define YELLOW '(255 255 0))
(define YELLOW_GREEN '(153 204 50))
(define colors '("ALGAE_GREEN" "AQUAMARINE" "BAKERS_CHOCOLATE" "BLACK" "BLAH_GREY" "BLOOD_ORANGE" "BLOOD_RED" "BLUE" "BLUE_VIOLET" "BRASS" "BRIGHT_GOLD" "BRONZE" "BRONZE_II" "BROWN" "CADET_BLUE" "CARDINAL_RED" "CERULEAN" "CHARCOAL" "COBALT_BLUE" "COOL_COPPER" "COPPER" "CORAL" "CORN_FLOWER_BLUE" "CYAN" "DARK_BROWN" "DARK_CHERRY_RED" "DARK_FOREST_GREEN" "DARK_GREEN" "DARK_GREEN_COPPER" "DARK_OLIVE_GREEN" "DARK_ORCHID" "DARK_PURPLE" "DARK_SLATE_BLUE" "DARK_SLATE_GREY" "DARK_TAN" "DARK_TURQUOISE" "DARK_WOOD" "DEEP_MIDNIGHT_BLUE" "DEEP_PURPLE" "DIM_GREY" "DUSTY_ROSE" "FELDSPAR" "FIREBRICK" "FOREST_GREEN" "FUCHSIA" "GOLD" "GOLDENROD" "GRAPE" "GREEN" "GREEN_COPPER" "GREEN_YELLOW" "GREY" "HOT_PINK" "HUNTER_GREEN" "INDIAN_RED" "INDIGO" "KHAKI" "LAVENDER" "LIGHT_AVOCADO_GREEN" "LIGHT_BLUE" "LIGHT_GREY" "LIGHT_STEEL_BLUE" "LIGHT_WOOD" "LIME_GREEN" "MAGENTA" "MANDARIAN_ORANGE" "MAROON" "MEDIUM_AQUAMARINE" "MEDIUM_BLUE" "MEDIUM_FOREST_GREEN" "MEDIUM_GOLDENROD" "MEDIUM_GREY" "MEDIUM_ORCHID" "MEDIUM_SEA_GREEN" "MEDIUM_SLATE_BLUE" "MEDIUM_SPRING_GREEN" "MEDIUM_TURQUOISE" "MEDIUM_VIOLET_RED" "MEDIUM_WOOD" "MIDNIGHT_BLUE" "MUSTARD" "NAVY_BLUE" "NECTARINE" "NEON_AVOCADO" "NEON_BLUE" "NEON_PINK" "NEW_MIDNIGHT_BLUE" "NEW_TAN" "NOVA_SCOTIA_SALMON" "OCEAN_BLUE" "OFF-WHITE_GREEN" "OLD_GOLD" "ORANGE" "ORANGE_RED" "ORCHID" "OREGON_SALMON" "PALE_BLUE" "PALE_GREEN" "PALE_PINK" "PARROT_GREEN" "PEACH" "PENCIL_LEAD" "PERIWINKLE" "PINE_GREEN" "PINK" "PLUM_PINK" "POPCORN" "PURPLE" "PYRIDIUM_ORANGE" "QUARTZ" "RED" "RICH_BLUE" "ROSE" "ROYAL_BLUE" "SALMON" "SCARLET" "SEA_ALGAE_GREEN" "SEA_GREEN" "SEATTLE_SALMON" "SEMI-SWEET_CHOCOLATE" "SIENNA" "SILVER" "SKY_BLUE" "SLATE_BLUE" "SPICY_PINK" "SPRING_GREEN" "STEEL_BLUE" "SUMMER_SKY" "TAN" "TEAL" "THISTLE" "TURQUOISE" "TURQUOISE" "VERY_DARK_BROWN" "VERY_LIGHT_GREY" "VIOLET" "VIOLET_RED" "WHEAT" "WHITE" "YELLOW" "YELLOW_GREEN"))

;;; Procedure:
;;;   color->list
;;; Parameters:
;;;   color, a color
;;; Purpose:
;;;   Convert a color (in either list or array form) to list form.
;;; Produces:
;;;   rgb-list, a list of three values
;;; Preconditions:
;;;   color is a valid color [unverified]
(define color->list
  (lambda (color)
    (if (pair? color) 
        color
        (list (red color) (green color) (blue color)))))

;;; Procedure:
;;;   color->array
;;; Parameters:
;;;   color, a color
;;; Purpose:
;;;   Convert a color (in either list or array form) to array form.
;;; Produces:
;;;   rgb-array, an array of three bytes
;;; Preconditions:
;;;   color is a valid color [unverified]
(define color->array
  (lambda (color)
    (if (pair? color)
        (rgb (list-ref color 0) (list-ref color 1) (list-ref color 2))
        color)))

;;; Procedure:
;;;   rgb
;;; Parameters:
;;;   r, an integer in the range 0..255
;;;   g, an integer in the range 0..255
;;;   b, an integer in the range 0..255
(define rgb
  (lambda (r g b)
    (let ((cap (lambda (x) 
                 (cond 
                   ((> x 255) 255)
                   ((< x 0) 0)
                   (#t x)))))
      (let ((bytes (cons-array 3 'byte)))
        (begin
          (aset bytes 0 (cap r))
          (aset bytes 1 (cap g))
          (aset bytes 2 (cap b))
          bytes)))))

;;; Procedures:
;;;   red
;;;   green
;;;   blue
(define red
  (lambda (color)
    (if (list-color? color)
        (list-ref color 0)
        (fixbyte (aref color 0)))))
(define green
  (lambda (color)
    (if (list-color? color)
        (list-ref color 1)
        (fixbyte (aref color 1)))))
(define blue
  (lambda (color)
    (if (list-color? color)
        (list-ref color 1)
        (fixbyte (aref color 1)))))

;;; Procedure:
;;;   color?
;;; Parameters:
;;;   val, a Scheme value
;;; Purpose:
;;;   Determines if val is a color in one of the valid representations.
;;; Produces:
;;;   is-color?, a Boolean
(define color?
  (lambda (val)
    (or (array-color? val)
        (list-color? val))))

;;; Procedure:
;;;   array-color?
;;; Parameters:
;;;   val, a Scheme value
;;; Purpose:
;;;   Determines if val is a color represented as an array of three bytes.
(define array-color?
  (lambda (val)
    (and (byte-array? val) (= (length val) 3))))

;;; Procedure:
;;;   list-color?
;;; Parameters:
;;;   val, a Scheme value
;;; Purpose:
;;;   Determines if val is a color represented by a list of three integers
(define list-color?
  (lambda (val)
    (and (list? val)
         (= (length val) 3)
         (number? (car val))
         (number? (cadr val))
         (number? (caddr val))
         (<= 0 (car val) 255)
         (<= 0 (cadr val) 255)
         (<= 0 (caddr val) 255))))

;;; Procedure:
;;;   set-fgcolor
;;; Parameters:
;;;   color, a color
;;; Purpose:
;;;   Set the foreground color.
;;; Produces:
;;;   Nothing.
;;; Preconditions:
;;;   color is a valid color.  (Either a list of three RGB values
;;;     or a byte vector of length 3.) [Unverified]
;;; Postconditions:
;;;   The foreground color is now the specified color.
(define set-fgcolor
  (lambda (color)
    (gimp-context-set-foreground (color->list color))))

;;; Purpose:
;;;   Set the background color.
;;; Produces:
;;;   Nothing.
;;; Preconditions:
;;;   color is a valid color.  (Either a list of three RGB values
;;;     or a byte vector of length 3.) [Unverified]
;;; Postconditions:
;;;   The background color is now the specified color.
(define set-bgcolor
  (lambda (color)
    (gimp-context-set-background (color->list color))))


; +------------------+------------------------------------------------
; | Basic Operations |
; +------------------+

;;; Procedure:
;;;   show-image
;;; Parameters:
;;;   image, an image
;;; Purpose:
;;;   Displays the image (which may have been modified behind the scenes).
;;; Produces:
;;;   Nothing of consequence.
;; Preconditions:
;;;   image must be a valid image (created by create-image or load-image).
(define show-image
  (lambda (image)
    (if (not (image? image))
        (crash 'show-image "Parameter was not an image.")
        (gimp-display-new (get-imageid image)))))

(define set-brush
  (lambda (brush)
    (cond
      ((not (string? brush))
       (error "set-brush: expects a string as a parameter"))
      ((not (member brush (cadr (gimp-brushes-get-list brush))))
       (error (string-append "set-brush: invalid brush: " brush)))
      (else (gimp-brushes-set-brush brush)))))

(define list-brushes
  (lambda ()
    (cadr (gimp-brushes-get-list ""))))


; +------------+------------------------------------------------------
; | Conversion |
; +------------+

;;; Procedure:
;;;   image-id?
;;; Parameters:
;;;   val, a Scheme value
;;; Purpose:
;;;   Determine whether or not val is a valid image id
;;; Problems:
;;;   Currently a stub.  I should really search through the array
;;;   of valid ids, but I'm too lazy.
(define image-id?
  (lambda (val)
    (integer? val)))

;;; Procedure:
;;;   get-drawable
;;; Parameters:
;;;   image, an image
;;; Purpose:
;;;   Get a drawable that corresponds to the image (e.g., the top layer).
(define get-drawable
  (lambda (image)
    (cond
      ((image-id? image) (car (gimp-image-get-active-layer image)))
      ((string? image) (get-drawable (name->image image)))
      ((pair? image) (cadr image))
      (else image))))

;;; Procedure:
;;;   get-imageid
;;; Parameters:
;;;   image, an image
;;; Purpose:
;;;   Get the numeric id of the image.
(define get-imageid
  (lambda (image)
    (cond
      ((image-id? image) image)
      ((string? image) (name->image image))
      ((pair? image) (car image)))))

;;; Procedure:
;;;   name->image
;;; Parameters:
;;;   name, a string
;;; Purpose:
;;;   Find the id of the image associated with the given name.
;;; Produces:
;;;   imageid, that id
;;; Preconditions:
;;;   name must name an image (verified)
(define name->image
  (letrec ((kernel (lambda (name images)
                     (cond
                       ((null? images)
                        (crash 'name->image
                               "there is no image named "
                               name))
                       ((equal? name (car (gimp-image-get-name (car images))))
                        (car images))
                       (else (kernel name (cdr images)))))))
    (lambda (name)
      (kernel name (vector->list (cadr (gimp-image-list)))))))


; +-------------------------+-----------------------------------------
; | Selection-Based Drawing |
; +-------------------------+

(define fill-bgcolor
  (lambda (image)
    (gimp-edit-fill (get-drawable image) 1)))

(define fill-fgcolor
  (lambda (image)
    (gimp-edit-fill (get-drawable image) 0)))

(define stroke
  (lambda (image)
    (gimp-edit-stroke (get-drawable image))))

(define select-ellipse
  (lambda (image operation left top width height)
    (gimp-ellipse-select (get-imageid image) 
                         left top
                         width height
                         operation
                         0 0 0)))

(define select-rectangle
  (lambda (image operation left top width height)
    (gimp-rect-select (get-imageid image) 
                      left top
                      width height
                      operation
                      0 0)))

(define select-all
  (lambda (image)
    (gimp-selection-all (get-imageid image))))

(define clear-selection
  (lambda (image)
    (gimp-edit-clear (get-drawable image))))

(define select-nothing
  (lambda (image)
    (gimp-selection-none (get-imageid image))))

; +--------+----------------------------------------------------------
; | Shapes |
; +--------+

(define blot
  (lambda (image x y)
    (gimp-paintbrush-default (get-drawable image) 
                             2 
                             (float-array x y))))

(define line
  (lambda (image x1 y1 x2 y2)
    (gimp-paintbrush-default (get-drawable image)
                             4                   
                             (float-array x1 y1 x2 y2))))

(define text
  (lambda (image str x y font size)
    (gimp-text-fontname (get-imageid image)
                        (get-drawable image)
                        x
                        y
                        str
                        0
                        0
                        size
                        0
                        font)
    (flatten! image)
    ))

;;; Procedure:
;;;   connect-the-dots
;;; Parameters:
;;;   image, an image
;;;   points, a list of points ((x.y) pairs)
;;; Purpose:
;;;   Draw a line through all the points.
;;; Produces:
;;;   (nothing)
;;; Preconditions:
;;;   There are at least two values in points.  [unverified]
;;;   Each value in points is an (x.y) pair. [unverified]
;;; Postconditions:
;;;   A line has been drawn through the points, using the current
;;;   color and brush.
(define connect-the-dots
  (letrec ((kernel (lambda (array pos points)
                     (if (null? points) array
                         (begin
                           (aset array pos (caar points))
                           (aset array (+ pos 1) (cdar points))
                           (kernel array (+ pos 2) (cdr points)))))))
    (lambda (image points)
      (let ((numvals (* 2 (length points))))
        (gimp-paintbrush-default (get-drawable image)
                                 numvals
                                 (kernel (cons-array numvals 'double) 0 points))))))


; +---------------+---------------------------------------------------
; | Miscellaneous |
; +---------------+

;;; Procedure:
;;;   byte-array?
;;; Parameters:
;;;   val, a Scheme value
;;; Purpose:
;;;   Determine if val is an array of bytes.
;;; Produces:
;;;   is-ba, a Boolean
(define byte-array?
  (lambda (val)
    (eq? (typeof val) 'tc_byte_array)))

;;; Procedure:
;;;   crash
;;; Parameters:
;;;   proc, a symbol (the name of a procedure)
;;;   val1 ... valn, lots of Scheme values
;;; Purpose:
;;;   Report an error for the given procedure
;;; Produces:
;;;   Nothing.
(define crash
  (let ((_tmp "                                                                                                                                                "))
    (letrec ((kernel (lambda (stuff)
                       (if (null? stuff) _tmp
                           (begin
                             (if (string? (car stuff))
                                 (strcat _tmp (car stuff))
                                 (print-to-string (car stuff) _tmp 1))
                             (kernel (cdr stuff)))))))
      (lambda (proc . values)
        (print-to-string proc _tmp)
        (strcat _tmp ": ")
        (kernel values)
        (error _tmp)))))

;;; Procedure:
;;;   fixbyte
;;; Parameters:
;;;   byte, a byte
;;; Purpose:
;;;   Make sure the byte has a value between 0 and 255, inclusive
(define fixbyte
  (lambda (byte)
    (if (< byte 0) (+ byte 256) byte)))

;;; Procedure:
;;;   flatten
;;; Parameters:
;;;   image, an image
;;; Purpose:
;;;   Flatten the image
(define flatten!
  (lambda (image)
    (let ((id (get-imageid image)))
      (let ((drawable (gimp-image-flatten id)))
        (if (pair? image)
            (set-cdr! image drawable))
        image))))

;;; Procedure:
;;;   float-array
;;; Parameters:
;;;   num_1, a number
;;;   num_2, a number
;;     ...
;;;   num_n, a number
;;; Purpose:
;;;   Create an array of floats of size n with the specified
;;;   values.  (Similar to the list and vector procedures from
;;;   standard Scheme.)
;;; Produces:
;;;   farray, an array
;;; Preconditions:
;;;   num_1 through num_n are integers.
;;; Postconditions:
;;;   farray is an array of floats.
;;;   (aref farray i) is num_(i-1) for all reasonable i.
(define float-array
  (lambda stuff
    (letrec ((kernel (lambda (array pos remainder)
                       (if (null? remainder) array
                           (begin
                             (aset array pos (car remainder))
                             (kernel array (+ pos 1) (cdr remainder)))))))
      (kernel (cons-array (length stuff) 'double) 0 stuff))))

;;; Procedure:
;;;   reload
;;; Parameters:
;;;   None
;;; Purpose:
;;;   Reload this file.  (Useful for when I make changes.)
(define reload
  (lambda ()
    (load "/home/rebelsky/Web/Courses/CS151/2006F/Examples/gimp.scm")))

; +---------+---------------------------------------------------------
; | History |
; +---------+

; Sunday, 22 October 2006 (v 0.1) [Samuel A. Rebelsky]
; * First version, based on work by all the authors listed above.

; Monday, 23 October 2006 (v 0.2) [Samuel A. Rebelsky]
; * Added some the documentation.
; * Added the color functions.

; Tuesday, 24 October 2006 (v 0.3) [Samuel A. Rebelsky]
; * Many minor updates.

; Monday, 30 October 2006 (v 0.4) [Samuel A. Rebelsky]
; * Started to eliminate the object-based version of images (it added
;   more confusion than I'd hoped).
; * Moved some of the color functions to hog.scm.
; * Fixed a bug in load-image.
; * Added some support for images as (image value) lists.
; * Added connect-the-dots.

; Tuesday, 31 October 2006 (v 0.4.1) [Samuel A. Rebelsky]
; * Added odd? and even?
; * Rewrote modulo

; Sunday, 26 November 2006 (v 0.5) [Samuel A. Rebelsky]
; * Added translations of various I/O routines.
; * Added line-based input.
; * Added string-ref.
; * Cleaned up documentation a bit.