;;; File:
;;;   hog.scm
;;; Author:
;;;   Samuel A. Rebelsky
;;; Version:
;;;   0.1 of 30 October 2006
;;; Summary:
;;;   Procedures for higher-order graphics.
;;; Note:
;;;   Relies on gimp.scm
;;; Contents:
;;;   Forthcoming.
;;; History:
;;;   At end.

; +----------------------------------+--------------------------------
; | Standard Higher-Order Procedures |
; +----------------------------------+

;;; Procedures:
;;;   left-section 
;;;   l-s
;;; Parameters:
;;;   binproc, a two-parameter procedure
;;;   left, a value
;;; Purpose:
;;;   Creates a one-parameter procedure by filling in the first parameter
;;    of binproc. 
;;; Produces:
;;;   unproc, a one-parameter procedure 
;;; Preconditions:  
;;;   left is a valid first parameter for binproc.
;;; Postconditions:
;;;   (unproc right) = (binproc left right)
(define left-section
  (lambda (binproc left)
    (lambda (right) (binproc left right))))
(define l-s left-section)

;;; Procedures:
;;;   right-section 
;;;   r-s
;;; Parameters:
;;;   binproc, a two-parameter procedure
;;;   right, a value
;;; Purpose:
;;;   Creates a one-parameter procedure by filling in the second parameter
;;    of binproc. 
;;; Produces:
;;;   unproc, a one-parameter procedure 
;;; Preconditions:  
;;;   left is a valid first parameter for binproc.
;;; Postconditions:
;;;   (unproc left) = (binproc left right)
(define right-section
  (lambda (binproc right)
    (lambda (left) (binproc left right))))
(define r-s right-section)

;;; Procedure:
;;;   compose
;;; Parameters:
;;;   f, a procedure
;;;   g, a procedure
;;; Purpose:
;;;   Compose f and g.
;;; Produces:
;;;   fog, a procedure
;;; Preconditions:
;;;   f can be applied to the results returned by g.
;;; Postconditions:
;;;   (fog x) = (f (g x))
(define compose
  (lambda (f g)
    (lambda (x)
      (f (g x)))))

;;; Procedure:
;;;   constant
;;; Parameters:
;;;   c, a value
;;; Purpose:
;;;   Build a constant function.
;;; Produces:
;;;   constant-function, a function
;;; Postconditions:
;;;   (constanc-function x) = c for all x.
(define constant
  (lambda (c)
    (lambda (x) c)))

; +------------------------+------------------------------------------
; | Basic Color Procedures |
; +------------------------+

;;; Procedure:
;;;   set-color-at!
;;; Parameters:
;;;   image, an image
;;;   x, an integer
;;;   y, an integer
;;;   color, a color built by rgb
;;; Purpose:
;;;   Sets the color at one point in the image.
;;; Produces:
;;;   (nothing)
;;; Preconditions:
;;;   0 <= x < (width image)
;;;   0 <= y < (height image)
(define set-color-at!
  (lambda (image x y color)
    (set-color-in-layer! (get-drawable image) x y (color->array color))))
(define set-color-in-layer!
  (lambda (layer x y color)
    (gimp-drawable-set-pixel layer x y 3 color)))

;;; Procedure:
;;;   get-color-at
;;; Parameters:
;;;   image, an image
;;;   x, an integer
;;;   y, an integer
;;; Purpose:
;;;   Gets the color at position (x,y) of image.
;;; Produces:
;;;   color, an rgb color.
;;; Preconditions:
;;;   0 <= x < (width image)
;;;   0 <= y < (height image)
(define get-color-at
  (lambda (image x y)
    (get-color-from-layer (get-drawable image) x y)))

(define get-color-from-layer
  (lambda (layer x y)
    (cadr (gimp-drawable-get-pixel layer x y))))

;;; Procedure:
;;;   fixbyte
;;; Parameters:
;;;   byte, a value returned from a byte array
;;; Purpose:
;;;   Convert to the range 0..255
;;; Produces:
;;;   fixedbyte, an integer in the range 0.255
(define fixbyte
  (lambda (byte) (if (< byte 0) (+ byte 256) byte)))

;;; Procedures:
;;;   red
;;;   green
;;;   blue
;;; Parameters:
;;;   color, an rgb color
;;; Purpose:
;;;   Extract one of the components
(define red (compose fixbyte (right-section aref 0)))
(define green (compose fixbyte (right-section aref 1)))
(define blue (compose fixbyte (right-section aref 2)))

; +--------------------+----------------------------------------------
; | Image Transformers |
; +--------------------+

;;; Procedure
;;;   modify-region!
;;; Parameters:
;;;   color-trans
;;;   image
;;;   left
;;;   top
;;;   right
;;;   bottom
;;; Purpose:
;;;   Modify the colors in a rectangular region of the image
;;; Produces:
;;;   (nothing)
;;; Preconditions:
;;;   0 <= left <= right < (width image)
;;;   0 <= top <= bottom < (height image)
;;; Postconditions:
;;;   For all x in [left..right], for all y in [top..bottom]
;;;     (get-color-at image) = (colortrans (get-color-at OLD_IMAGE))
(define modify-region!
  (lambda (colortrans image left top right bottom)
    (let ((layer (get-drawable image))
          (x left)
          (y top))
      (gimp-image-undo-disable (get-imageid image))
      (while (<= y bottom)
             (set! x left)
             (while (<= x right)
                    (let* ((pixel (get-color-from-layer layer x y))
                           (newpixel (colortrans pixel)))
                      ; (print (list x y pixel newpixel)) ; DEBUG
                      (set-color-in-layer! layer x y newpixel)
                      (set! x (+ x 1))))
             (set! y (+ y 1)))
      (gimp-image-undo-enable (get-imageid image))
      image)))

(define modify-image!
  (lambda (colorfun image)
    (modify-region! colorfun
                    image
                    0 
                    0 
                    (- (car (gimp-image-width (get-imageid image))) 1)
                    (- (car (gimp-image-height (get-imageid image))) 1))))

; +-----------------------+-------------------------------------------
; | Color Transformations |
; +-----------------------+

;;; Procedure:
;;;   color-transformer
;;; Parameters:
;;;   redfunc, a function from colors to integers in the range 0..255.
;;;   greenfunc, a function from colors to integers in the range 0-..255.
;;;   bluefunc, a function from colors to integers in the range 0-..255.
;;; Purpose:
;;;   Combine the three functions into a color transformer.
;;; Produces:
;;;   transform, a function from colors to colors.
;;; Preconditions:
;;;   (none)
;;; Postconditions:
;;;   (transform color) = 
;;;     (rgb (redfunc color) (greenfunc color) (bluefunc color)))
(define color-transformer
  (lambda (redfunc greenfunc bluefunc)
    (lambda (color)
      (rgb (redfunc color) (greenfunc color) (bluefunc color)))))
(define c-t color-transformer)

;;; Procedure:
;;;   conditional-transform
;;; Parameters:
;;;   test, a color predicate
;;;   trans, a color transformer
;;; Purpose:
;;;   Build a conditional transformer
;;; Produces:
;;;   con-trans, a color transformer
;;; Postconditions:
;;;   (con-trans color) = (if (test color) (trans color) color)
(define conditional-transform
  (lambda (test trans)
    (lambda (color)
      (if (test color) (trans color) color))))

;;; Procedures:
;;;   greyscale-simple
;;;   greyscale-better
;;; Parameters:
;;;   color, an rgb color
;;; Purpose: 
;;;   Convert color to an appropriate shade of grey
;;; Produces:
;;;   grey, a shade of grey
(define greyscale-simple
  (lambda (color)
    (let ((ave (/ (+ (red color) (green color) (blue color)) 3)))
      (rgb ave ave ave))))
(define greyscale-better
  (lambda (color)
    (let ((ave (+ (* 0.299 (red color)) (* 0.587 (green color)) (* 0.114 (blue color)))))
      (rgb ave ave ave))))

;;; Procedure:
;;;   change-red
;;; Parameters:
;;;   amt, an integer in the range -255 to 255 [unverified]
;;;   color, the color to be transformed.
;;; Purpose:
;;;   Build a new color by adding amt to the red component of color
;;; Produces:
;;;   new-color, a color
;;; Preconditions:
;;;   (none)
;;; Postconditions:
;;;   For any color,
;;;     (red new-color) = (+ (red color) amt)
;;;       unless the sum is less than 0 or greater than 255, in
;;;       which case new-color is  0 or 255, respectively.
(define change-red
  (lambda (amt color)
    (rgb (+ (red color) amt) (green color) (blue color))))

;;; Procedure:
;;;   change-green
;;; Parameters:
;;;   amt, an integer in the range -255 to 255 [unverified]
;;;   color, the color to be transformed.
;;; Purpose:
;;;   Build a new color by adding amt to the green component of color
;;; Produces:
;;;   new-color, a color
;;; Preconditions:
;;;   (none)
;;; Postconditions:
;;;   For any color,
;;;     (green new-color) = (+ (green color) amt)
;;;       unless the sum is less than 0 or greater than 255, in
;;;       which case new-color is  0 or 255, respectively.
(define change-green
  (lambda (amt color)
    (rgb (red color) (+ amt (green color)) (blue color))))

;;; Procedure:
;;;   change-blue
;;; Parameters:
;;;   amt, an integer in the range -255 to 255 [unverified]
;;;   color, the color to be transformed.
;;; Purpose:
;;;   Build a new color by adding amt to the blue component of color
;;; Produces:
;;;   new-color, a color
;;; Preconditions:
;;;   (none)
;;; Postconditions:
;;;   For any color,
;;;     (blue new-color) = (+ (blue color) amt)
;;;       unless the sum is less than 0 or greater than 255, in
;;;       which case new-color is  0 or 255, respectively.
(define change-blue
  (lambda (amt color)
    (rgb (red color) (green color) (+ amt (blue color)))))

;;; Procedures:
;;;   redder
;;;   greener
;;;   bluer
;;; Parameters (Curried):
;;;   amt, an integer in the range -255 to 255 [unverified]
;;; Purpose:
;;;   Build a color transformer.
;;; Produces:
;;;   make-redder, a color transformer (make-greener, make-bluer,
;;;     respectively).
;;; Preconditions:
;;;   (none)
;;; Postconditions:
;;;   For any color,
;;;     (red (redder color)) = (red color) + amt 
;;;     (green (green color)) = (green color) + amt 
;;;     (blue (bluer color)) = (blue color) + amt 
;;;       unless the sum is less than 0 or greater than 255, in
;;;       which case the result is 0 or 255, respectively.
(define redder
  (lambda (amt)
    (left-section change-red amt)))
(define greener
  (lambda (amt)
    (left-section change-green amt)))
(define bluer
  (lambda (amt)
    (left-section change-blue amt)))

;;; Procedure:
;;;   rotate-components
;;; Parameters:
;;;   color, a color
;;; Purpose:
;;;   Build a new color by rotating the red, green, and blue components.
;;; Produces:
;;;   newcolor, a color
;;; Postconditions:
;;;   (red newcolor) = (green color)
;;;   (green newcolor) = (blue color)
;;;   (blue newcolor) = (red color)
(define rotate-components (c-t green blue red))

(define redder-64 (redder 64))
(define lessblue-64 (bluer -64))

(define flop (c-t (compose (left-section - 255) red)
                  (compose (left-section - 255) green)
                  (compose (left-section - 255) blue)))

(define less-red (c-t (compose (right-section - 32) red) green blue))

(define just-blue (constant (rgb 0 0 255)))

(define no-green (c-t red (constant 0) blue))

(define more-yellow (c-t (compose (left-section + 16) red)
                         (compose (left-section + 16) green)
                         blue))

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

;;; Procedure
;;;   convert-to-greyscale!
;;; Parameters:
;;;   image, an image
;;; Purpose:
;;;   Converts the image to greyscale.
;;; Produces:
;;;   (nothing)
;;; Preconditions:
;;;   (none)
;;; Postconditions:
;;;   image is now in greyscale (that is, for each position, the red, 
;;;     green, and blue components are identical).  
;;;   The color at each position has approximately the same brightness
;;;     as it did prior to the conversion.
(define convert-to-greyscale! (l-s modify-image! greyscale-better))


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

; Monday, 30 October 2006 (v. 0.1) [Samuel A. Rebelsky]
; *  First version for revised laboratories.  Many procedures
;    modified from elsewhere.