; PinPoint -- Produce presentation graphics using the GIMP
; Copyright (C) 2001 by Martin Pool <mbp@linuxcare.com.au>
;
; $Id: pinpoint.scm,v 1.6 2001/01/20 03:47:30 mbp Exp $
;
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation; either version 2 of the License, or
; (at your option) any later version.
; 
; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU General Public License for more details.
; 
; You should have received a copy of the GNU General Public License
; along with this program; if not, write to the Free Software
; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

(define (readline file)
  (let* ((ch (fread 1 file)))
    (cond ((equal? () ch) ())
          ((equal? "\n" ch) "")
          ('else (let ((rest (readline file)))
                   (if (equal? () rest)
                       ch
                       (string-append ch rest)))))))

(define (read-file-lines file)
  (let* ((line (readline file)))
    (if (equal? () line)
        ()
        (cons line (read-file-lines file)))))

(define (pinpoint-draw-show background-image outline-file
                            body-fontname body-pixels body-color
                            output-dir show-images)
  (define slide-no 0)
  (define file (fopen outline-file "r"))

  (define (fold-right fn init vals)
    (if (null? vals)
        init
        (fold-right fn (fn init (car vals)) (cdr vals))))
  
  ; Return a list of pages, each of which is a list of lines of text
  (define (open-background)
    (car (gimp-file-load RUN-NONINTERACTIVE
                         background-image background-image)))

  ; Return a list of lists, each being the lines of text to go onto a
  ; slide
  (define (pinpoint-split-pages lines)
    (map reverse 
         (reverse 
          (fold-right (lambda (l v)
                        (if (equal? v "%page")
                            (cons () l)
                            (cons (cons v (car l)) (cdr l))))
                      (list ())
                      lines))))

  (define (pinpoint-draw-page page-lines)
    (define img (open-background))
    (define layer (car (gimp-image-get-active-layer img)))

    (define (pinpoint-draw-a-line text x y)
      (if (< 0 (string-length text))
          (let ((text-sel
                 (car (gimp-text-fontname img layer x y text
                                          0 TRUE body-pixels PIXELS
                                          body-fontname))))
            (gimp-floating-sel-anchor text-sel))))

    (define (pinpoint-draw-page-lines lines x y)
      (cond ((null? lines) ())
            ((equal? (car lines) "%page") 'page)
            ('else (begin
                     (pinpoint-draw-a-line (car lines) x y)
                     (pinpoint-draw-page-lines (cdr lines) x
                                               (+ y (* 1.2 body-pixels)))))))

    (define (pinpoint-save-page)
      (let ((filename
             (string-append output-dir "/slide" (number->string slide-no) ".jpg"))
            (quality 0.95)
            (smoothing 0.10))
        (file-jpeg-save RUN-NONINTERACTIVE img layer filename filename
                        quality smoothing 1 1
                        "Produced by The GIMP and PinPoint"
                        0 1 10 2)))

    (define display
      (if (equal? TRUE show-images)
          (car (gimp-display-new img))))
    
    (gimp-palette-set-foreground body-color)

    (pinpoint-draw-page-lines page-lines 40 20)

    (pinpoint-save-page)
    (if display (gimp-display-delete display))

    (set! slide-no (+ 1 slide-no)))

  (mapcar pinpoint-draw-page
          (pinpoint-split-pages (read-file-lines file)))
  
  (gimp-displays-flush))

(script-fu-register "pinpoint-draw-show"
		    _"<Toolbox>/Xtns/Script-Fu/mbp/Pinpoint Presentation..."
		    "PinPoint Presentation"
		    "Martin Pool"
		    "Martin Pool"
                    "January 2001"
		    ""
                    SF-FILENAME   _"Background image" "/home/mbp/lxcr-background-01.bmp"
                    SF-FILENAME   _"Outline"  "/home/mbp/rproxy-doc/linuxconfau/rproxy.pin"
                    SF-FONT       _"Body font" "-adobe-avantgarde-demi-r-normal-*-48-*-*-*-p-*-iso8859-1"
                    SF-ADJUSTMENT _"Body font size (pixels)" '(40 2 300 1 10 0 1)
                    SF-COLOR      _"Body color" '(255 255 0)
                    SF-STRING     _"Output directory" "/tmp"
                    SF-TOGGLE     _"Show images" FALSE)