; Emacs: This file contains -*- Scheme -*- source code.

;;; logo-variation-4: create the department logo

;;; John David Stone
;;; Department of Mathematics and Computer Science
;;; Grinnell College
;;; stone@cs.grinnell.edu

;;; created June 15, 2004
;;; last revised June 18, 2004

;;; ------------------
;;; Utility procedures
;;; ------------------

;;; Many Script-Fu procedures take arguments that must be 0 or 1 rather
;;; than Boolean values.  Also, they often take so many such arguments that
;;; I have trouble remembering which argument corresponds to which feature.
;;; The functions YES and NO always return 1 or 0, respectively, ignoring
;;; the argument (which is present only for documentation purposes), so
;;; that I can write, for instance, `(yes 'anti-aliasing)' rather than `1'
;;; to enable anti-aliasing.

(define yes
  (lambda (option) 1))

(define no
  (lambda (option) 0))

;;; The SIOD Scheme system on which Script-Fu is based seems to have a MAP
;;; procedure that works only for unary procedures.  Here is a binary
;;; version:

(define map2
  (lambda (procedure left-list right-list)
    (letrec ((mapper
              (lambda (left-list right-list)
                (if (null? left-list)
                    '()
                    (cons (procedure (car left-list) (car right-list))
                          (mapper (cdr left-list) (cdr right-list)))))))
      (mapper left-list right-list))))

;;; The LIST-REF procedure selects the element at a given (zero-based)
;;; position in a given list.

(define list-ref
  (lambda (ls position)
    (if (= position 0)
        (car ls)
        (list-ref (cdr ls) (- position 1)))))

;;; -----------------------
;;; Description of the logo
;;; -----------------------

;;; The proposed logo is a rectangle dissected into smaller rectangles that
;;; are distinct from one another, but all similar (in the geometrical
;;; sense) to the rectangle that they compose.

;;; SIDE-RATIO is the ratio of the longer sides of each rectangle to the
;;; shorter sides.

(define side-ratio 3)

;;; The rectangle that is being dissected is 192 units wide and 64 units
;;; high.

(define unscaled-width 192)
(define unscaled-height 64)

;;; For each component rectangle, it will be convenient to know its width
;;; and height and the position of its upper left-hand corner within the
;;; larger rectangle.  Coordinates are measured in unscaled units,
;;; rightwards and downwards from the upper left-hand corner.

(define make-component
  (lambda (width height distance-from-left distance-from-top)
    (list width height distance-from-left distance-from-top)))

(define component-width car)
(define component-height cadr)
(define component-distance-from-left caddr)
(define component-distance-from-top
  (lambda (component)
    (car (cdddr component))))

;;; Here is a list of the component rectangles.

(define unscaled-components (list (make-component 111 37 0 0)
                                  (make-component 30 10 111 0)
                                  (make-component 51 17 141 0)
                                  (make-component 9 27 111 10)
                                  (make-component 21 7 120 10)
                                  (make-component 72 24 120 17)
                                  (make-component 81 27 0 37)
                                  (make-component 39 13 81 37)
                                  (make-component 3 9 120 41)
                                  (make-component 69 23 123 41)
                                  (make-component 42 14 81 50)))

;;; The units in which all of the preceding quantities are measured can be
;;; scaled up by any integer factor.  For display at the top of a browser
;;; window that might be, say, eight hundred pixels wide, we'll make each
;;; unit equal to three pixels.

(define scale 3)

;;; The widths, heights, and coordinates of all of the component rectangles
;;; must be multiplied by the scale to yield pixel coordinates.

(define components
  (map (lambda (component)
         (make-component
           (* scale (component-width component))
           (* scale (component-height component))
           (* scale (component-distance-from-left component))
           (* scale (component-distance-from-top component))))
       unscaled-components))

;;; Here are the colors used in the logo.

(define scarlet '(245 30 48))  ; = "Grinnell red"
(define black '(0 0 0))
(define white '(255 255 255))
(define gray '(159 159 159))

;;; Each of the component rectangles is filled with one of these colors.
;;; Here is a list of the color choices for the components.  Note that the
;;; order corresponds to the order used in the COMPONENTS list.

(define component-colors (list white gray black black white scarlet
                               scarlet gray white gray black))

;;; Two of the component rectangles contain text: the name of the
;;; department (split onto two separate lines) and the name of the college.

(define department-name-first-half "Department of Mathematics")
(define department-name-second-half "and Computer Science")
(define college-name "Grinnell College")

;;; The department's name is to be printed in scarlet and the college's
;;; name in black.

(define department-name-color scarlet)
(define college-name-color black)

;;; Here are the characteristics of the font used in the logo,
;;; twenty-four-point Helvetica bold upright.

(define font-size 24)
(define font-family "Helvetica")
(define font-weight "bold")
(define font-slant "r")

;;; Leave a four-pixel border around each string.

(define border-width 4)

;;; The College's logo, four laurel leaves arranged in a square, is to be
;;; displayed in another of the component rectangles.  Here is the name of
;;; a file containing the four-laurel-leaf logo:

(define laurel-leaves-file
  "/home/stone/public_html/new-site/leaves4534.gif")

;;; Here are the component rectangles that will contain the texts and
;;; graphic.

(define department-name-component (list-ref components 0))
(define college-name-component (list-ref components 5))
(define laurel-leaves-component (list-ref components 10))

;;; TARGET-FILE is the full pathname of the file in which the completed
;;; graphic is to be stored.

(define target-file "/home/stone/public_html/new-site/logo-variation-4.png")

;;; ----------------------
;;; Creating image objects
;;; ----------------------

;;; Given positive integers WIDTH and HEIGHT, the MAKE-GRAPHIC procedure
;;; constructs and returns a Script-Fu image object of the specifed size.

(define make-graphic
  (lambda (width height)
    (car (gimp-image-new width height RGB))))

;;; Define a constant that denotes full opacity.  (It's used in calls to
;;; the GIMP-LAYER-NEW procedure.)

(define opaque 100.0)

;;; Given an image object BASE and a string LAYER-NAME, the
;;; MAKE-DRAWING-LAYER procedure constructs a layer of the same height and
;;; width, with LAYER-NAME as its name, and attaches it to the image
;;; object, clears it, and returns it.

(define make-drawing-layer
  (let ((opaque 100.0))  ; full opacity
    (lambda (base layer-name)
      (let ((drawing-layer
             (car (gimp-layer-new base (car (gimp-image-width base))
                                  (car (gimp-image-height base)) RGB_IMAGE
                                  layer-name opaque NORMAL)))
            (drawing-layer-position 0))
        (gimp-image-add-layer base drawing-layer drawing-layer-position)
        (gimp-selection-all base)
        (gimp-drawable-fill drawing-layer BG-IMAGE-FILL)
        (gimp-selection-none base)
        drawing-layer))))

;;; Given a complete pathname, the IMAGE-FROM-FILE procedure returns the
;;; image stored in the designated file.

(define image-from-file
  (lambda (pathname)
    (car (gimp-file-load (yes 'batch-mode) pathname pathname))))

;;; The GET-LOWEST-LAYER procedure extracts layer 0 from an image object.

(define get-lowest-layer
  (lambda (img)
    (aref (cadr (gimp-image-get-layers img)) 0)))

;;; -------
;;; Drawing
;;; -------

;;; The DRAW-COMPONENT procedure fills in the region occupied by a given
;;; component with a given color and outlines it in the current foreground
;;; color.  The image and the drawing layer must also be given as
;;; parameters.

(define draw-component
  (lambda (img layer component color)
    (gimp-rect-select img (component-distance-from-left component)
                      (component-distance-from-top component)
                      (component-width component)
                      (component-height component) REPLACE (no 'feather) 0)
    (gimp-palette-set-background color)
    (gimp-edit-fill layer BG-IMAGE-FILL)
    (gimp-edit-stroke layer)
    (gimp-selection-none img)))

;;; The string constant ANY is used to indicate indifference to some
;;; characteristic of the font of type that is used.

(define any "*")

;;; The TEXT-WIDTH procedure computes the width of a given string, written
;;; in the font that the logo will use.  For some reason, turning on
;;; anti-aliasing causes GIMP-TEXT to select a more compressed font than
;;; GIMP-TEXT-GET-EXTENTS does, so I have thrown in a fudge factor to
;;; compensate.

(define text-width
  (let ((fudge-factor 0.80))
    (lambda (text)
      (* fudge-factor
         (car (gimp-text-get-extents text font-size PIXELS any font-family
                                     font-weight font-slant any any any
                                     any))))))

;;; Given an image IMG, a drawing-layer DL, a string TEXT, a color COLOR, a
;;; horizontal coordinate FROM-LEFT, and a vertical coordinate FROM-TOP,
;;; the DRAW-TEXT procedure writes TEXT, in the specified color, onto the
;;; image, in the specified position.

(define draw-text
  (lambda (img dl text color from-left from-top)
    (let ((old-color (car (gimp-palette-get-foreground))))
      (gimp-palette-set-foreground color)
      (let ((floating-selection
             (car (gimp-text img dl from-left from-top text border-width
                             (yes 'anti-aliasing) font-size PIXELS any
                             font-family font-weight font-slant any any any
                             any))))
        (gimp-floating-sel-anchor floating-selection))
      (gimp-palette-set-foreground old-color))))

;;; Select the entire decoration, copy it to the clipboard, and paste it
;;; into the new graphic.

(define draw-imported-graphic
  (let ((clear-first 0))  ; Erase the clipboard before use.
    (lambda (imported dl from-left from-top)
      (gimp-selection-all imported)
      (gimp-edit-copy (get-lowest-layer imported))
      (gimp-selection-none imported)
      (let ((floating-selection (car (gimp-edit-paste dl clear-first))))
        (gimp-layer-set-offsets floating-selection from-left from-top)
        (gimp-floating-sel-anchor floating-selection)))))

;;; ----------------------
;;; Saving images to files
;;; ----------------------

;;; Given an image, a layer, and a complete pathname, the IMAGE-TO-FILE
;;; procedure stores the image in the designed file.

(define image-to-file
  (let ((normal-compression 6))
    (lambda (img lr pathname)
      (file-png-save (yes 'batch-mode) img lr pathname pathname
                     (no 'interlacing) normal-compression (yes 'bKGD-chunk)
                     (yes 'gAMA-chunk) (yes 'oFFs-chunk) (yes 'tIME-chunk)
                     (yes 'pHYs-chunk)))))

;;; ------------
;;; Construction
;;; ------------

;;; Define the width and height of the whole graphic.  Each rectangular
;;; region will be outlined by a one-pixel border.  The top and left
;;; borders will be allocated from the region itself; the bottom and right
;;; borders of each region will coincide with the top or left borders of
;;; the adjacent region.  The frame must provide one extra pixel of width
;;; and height to contain the borders of the regions at the bottom and
;;; right edges of the main rectangle.

(define whole-width (+ (* unscaled-width scale) 1))
(define whole-height (+ (* unscaled-height scale) 1))

;;; Establish the background and foreground colors.

(gimp-palette-set-background white)
(gimp-palette-set-foreground black)

;;; Use the one-pixel brush.

(gimp-brushes-set-brush "pixel (1x1 square)")
(gimp-brushes-set-opacity 100.0)

;;; Create and name the graphic and a drawing layer for it.

(define whole (make-graphic whole-width whole-height))
(define drawing-layer (make-drawing-layer whole "drawing layer"))

;;; Fill in the component rectangles.

(map2 (lambda (component color)
        (draw-component whole drawing-layer component color))
      components
      component-colors)

;;; Add the texts.

(draw-text whole drawing-layer department-name-first-half
           department-name-color
           (+ (component-distance-from-left department-name-component)
              (/ (- (component-width department-name-component)
                    (text-width department-name-first-half))
                 2))
           (+ (component-distance-from-top department-name-component)
              (/ (- (component-height department-name-component)
                    (+ font-size border-width font-size))
                 2)))

(draw-text whole drawing-layer department-name-second-half
           department-name-color
           (+ (component-distance-from-left department-name-component)
              (/ (- (component-width department-name-component)
                    (text-width department-name-second-half))
                 2))
           (+ (component-distance-from-top department-name-component)
              (/ (- (component-height department-name-component)
                    (+ font-size border-width font-size))
                 2)
              font-size border-width))

(draw-text whole drawing-layer college-name college-name-color
           (+ (component-distance-from-left college-name-component)
              (/ (- (component-width college-name-component)
                    (text-width college-name))
                 2))
           (+ (component-distance-from-top college-name-component)
              (/ (- (component-height college-name-component)
                    font-size)
                 2)))

;;; Add the logo.

(let ((laurel-leaves (image-from-file laurel-leaves-file)))
  (draw-imported-graphic
    laurel-leaves
    drawing-layer
    (+ (component-distance-from-left laurel-leaves-component)
       (/ (- (component-width laurel-leaves-component)
             (car (gimp-image-width laurel-leaves)))
          2))
    (+ (component-distance-from-top laurel-leaves-component)
       (/ (- (component-height laurel-leaves-component)
             (car (gimp-image-height laurel-leaves)))
          2))))

;;; Save the graphic to the target file.

(image-to-file whole drawing-layer target-file)