;;; File:
;;;   utils.scm
;;; Authors:
;;;   Samuel A. Rebelsky
;;;   Ian Bone-Rundle
;;; Version:
;;;   1.5 of May 2006
;;; Summary:
;;;   The "Glimmer Utilities for Gimp"
;;;   A collection of procedures that may be helpful in writing
;;;   Scheme scripts for the Gnu Image Manipulation Program.
;;; Location:
;;;   /home/rebelsky/Web/GIMP/Scheme/utils.ss
;;;   http://www.cs.grinnell.edu/~rebelsky/GIMP/Scheme/utils.ss
;;; Contents:
;;;   Values
;;;     BLACK: the color black
;;;     BLUE: the color blue 
;;;     RED: the color red
;;;   Procedures:
;;;     (float-array num_1 num_2 ... num_n)
;;;        Create an array of "floats" that contains the
;;;        specified values.  Particularly useful for calls
;;;        to gimp-paintbrush.
;;;     (sample-image width height drawproc)
;;;        Create a sample image of the specified width and
;;;        height, using the procedure to do the actual
;;;        drawing.  drawproc should take two parameters:
;;;        an image and a layer.
;;;     (gsfu-line layer x1 y1 x2 y2)
;;;	  Draw a line between the two given points.
;;;     (gsfu-load-image path-to-image)
;;;        Load an image.
;;;     (gsfu-get-pixel image layer x y)
;;;       Get the color of the pixel at (x,y) in image.
;;;     (mod dividend divisor)
;;;       Compute a remainder.
;;;     (gsfu-image width height)
;;;       Creates and displays a new, cleared image with drawable layer added.
;;;     (list-ref list pos)
;;;	  Rewritten because it is not included in SIOD.
;;;	  
;;; History:
;;;   Monday, 2 April 2001
;;;     Wrote the first-version of float-array (in a separate
;;;       file).
;;;     Thought about other utility functions.
;;;   Tuesday, 3 April 2001 [Version 1.0]
;;;     Created.
;;;   Thursday, 5 April 2001 [Version 1.1]
;;;     Added gsfu-load-image, gsfu-get-pixel, and mod.
;;;   Thursday, 25 May 2006 [Version 1.5]
;;;	    Ian Bone-Rundle updated history, table of contents,
;;;	    and modified procedures to work with the GIMP v. 2.2.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Constants

;;; Names:
;;;   BLACK
;;;   BLUE
;;;   RED
;;;   WHITE
;;; Type:
;;;   RGB value (list of three integers)
;;; Value:
;;;   Appropriate numbers for the specified color
(define BLACK  (list   0   0   0))
(define BLUE   (list   0   0 255))
(define GREEN  (list   0 255   0))
(define PURPLE (list 191  63 255))
(define RED    (list 255   0   0))
(define WHITE  (list 255 255 255))
(define YELLOW (list 255 255   0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Procedures

;;; 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:
;;;   sample-image
;;; Parameters:
;;;   width, an integer
;;;   height, an integer
;;;   drawproc, a procedure which takes two parameters,
;;;     an image and a layer
;;; Purpose:
;;;   Create a new image and draw on it.  Intended as a way
;;;   of quickly testing new drawing procedures.
;;; Preconditions:
;;;   width and height are positive integers
;;;   drawproc is a valid procedure that takes an image and
;;;     a layer.
;;; Postconditions:
;;;   Displays a new image whose content is essentially the
;;;   result of drawproc.
(define sample-image
  (lambda (width height drawproc)
    (let* ((image (car (gimp-image-new width height 0)))
           (layer (car (gimp-layer-new image width height
                                       0 
                                       "Stuff" 100 0))))
      ; Add the layer to the image
      (gimp-image-add-layer image layer 0)
      ; Set forground and background
      (gimp-palette-set-foreground WHITE)
      (gimp-palette-set-background WHITE)
      ; Make it all white for a start
      (gimp-selection-all image)
      (gimp-edit-bucket-fill layer 0 0 100 15 FALSE 0 0)
      ; Set the pen to black
      (gimp-palette-set-foreground BLACK)
      ; Draw some picture
      (drawproc image layer)
      ; Display the new image
      (gimp-display-new image)
      ; Clear any selections so that life is nicer.
      (gimp-selection-clear image)
    )))

(define gsfu-line
  (lambda (layer x1 y1 x2 y2)
     (gimp-paintbrush layer 0 4 
                      (float-array x1 y1 x2 y2) 0 0)))

;;; Procedure:
;;;   gsfu-load-image
;;; Parameters:
;;;   path, the file path to the file
;;; Purpose:
;;;   Loads a GIF or JPEG file.
;;; Produces:
;;;   The ID of the corresponding image.
;;; Preconditions:
;;;   The file must exist and contain a GIF/JPEG image.
;;; Postconditions:
;;;   The associated ID can be used as an image
;;; Note:
;;;   A shorter way to use file-gif-load and file-jpeg-load.
(define gsfu-load-image
  (lambda (path)
    (let* ((len (length path))
           (suffix (substring path (- len 3) len)))
      (print suffix)
      (cond
        ((equal? suffix "jpg") (car (file-jpeg-load 0 path path)))
        ((equal? suffix "gif") (car (file-gif-load  0 path path)))
        (#t (error (string-append "Cannot figure out type of "
                                  path)))))))

;;; Procedure:
;;;   gsfu-get-pixel
;;; Parameters:
;;;   image, an image
;;;   layer, a layer associated with the image
;;;   x, the coordinate of a pixel
;;;   y, the coordinate of a pixel
;;; Purpose:
;;;   Get the RGB color value of the given pixel.
;;; Produces:
;;;   color, an RGB color (list of three values).
;;; Preconditions:
;;;   (x,y) must be a valid pixel location for the image.
;;; Postconditions:
;;;   Returns a valid color
;;; Note:
;;;   A shorter way to use gimp-color-picker.
(define gsfu-get-pixel
  (lambda (image layer x y)
    (car (gimp-image-pick-color image layer x y 0 0 0))))

;;; Procedure:
;;;   mod
;;; Parameters:
;;;   dividend, a non-negative integer
;;;   divisor, a positive integer
;;; Purpose:
;;;   Computes the remainder after dividing dividend by divisor.
;;; Produces:
;;;   result, a non-negative integer
;;; Preconditions:
;;;   dividend and divisors meet the criteria set above
;;; Postconditions:
;;;   There exists an integer, x, such that dividend = x*divisor + result
;;;   result is non-negative.
;;;   result is less than divisor.
(define mod
  (lambda (dividend divisor)
    (cond 
      ((< dividend 0) (mod (+ dividend divisor) divisor))
      ((< dividend divisor) dividend)
      (#t (mod (- dividend divisor) divisor)))))

;;; Procedure:
;;;   gsfu-image
;;; Parameters:
;;;   width, an integer
;;;   height, an integer
;;; Purpose:
;;;   Creates a new image of the given width and height.
;;; Produces:
;;;   A list that consists of the id of the image and the id
;;;   of a layer on the image.
;;; Preconditions:
;;;   width and height are positive integers
;;; Postconditions:
;;;   Returns a two element list.
(define gsfu-image
  (lambda (width height)
    (let* ((image (car (gimp-image-new width height RGB)))
           (layer (car (gimp-layer-new image width height 
                                       RGB "Layer" 100 0))))
      ; Add the layer to the image
      (gimp-image-add-layer image layer 0)
      ; Clear everything
      (gimp-selection-all image)
      (gimp-edit-clear image layer)
      (gimp-selection-none image)
      ; Show the result
      (gimp-display-new image)
      ; And return the information
      (list image layer))))

;;; Procedure:
;;;   list-ref
;;; Note:
;;;    Rewritten because SIOD doesn't include it
(define list-ref
  (lambda (lst pos)
    (if (= pos 0) (car lst)
        (list-ref (cdr lst) (- pos 1)))))