;;; guash-mapper-sample.scm
;;; Time-stamp: <1999/06/20 09:31:55 narazaki@gimp.org>
;;; This file ia a part of guash.
;;;
;;; Commentary:
;;;  This is a sample file for guash-mapper function.
;;;  Modify or delete freely!

;;; First, try:
;;; gm-thumbnail, gm-to-jpg, gm-mpg

;; 1st sample is automatic thumnail&html generator
;; This is an example of use of two extra invocations.

(define (%gm-thumbnail-m thumbnail-tail directory html-file)
  ;; make a closure
  (let ((url-infos '())
	;; parameters: modify them as you like.
	(url-file-header "")	; "<ul>"
	(url-file-trailer "")	; "</ul>"
	(url-header "")	; "<li>"
	(url-trailer ""))
    (lambda (img drw path-strs)
      (if (number? img)
	  (let* ((width (car (gimp-image-width img)))
		 (height (car (gimp-image-height img)))
		 (thumbnail-size 480)
		 (thumbnail-width 1)
		 (thumbnail-height 1)
		 (original-name "")
		 (thumbnail-name "")
		 (new-name ""))
	    (if (null? directory)
		(set! directory (nth 1 path-strs)))
	    (if (< width height)
		(begin
		  (set! thumbnail-height thumbnail-size)
		  (set! thumbnail-width (* (/ width height) thumbnail-size)))
		(begin
		  (set! thumbnail-width thumbnail-size)
		  (set! thumbnail-height (* (/ height width) thumbnail-size))))
	    (gimp-image-scale img thumbnail-width thumbnail-height)
	    (set! original-name (string-append (nth 2 path-strs) "."
					       (nth 3 path-strs)))
	    (set! thumbnail-name (string-append (nth 2 path-strs)
						thumbnail-tail
						(nth 3 path-strs)))
	    (set! new-name (string-append directory "/" thumbnail-name))
	    (gimp-file-save 0 img drw new-name new-name)
	    (gimp-image-clean-all img)
	    (set! url-infos
		  (cons (string-append url-header
				       "<a href=\"" original-name
				       "\"><img src=\"" thumbnail-name
				       "\" alt=\"" original-name
				       "\"></a>"
				       url-trailer "\n")
			url-infos)))
	  ;; hook
	  (if (eq? drw #f)
	      ;; initialization
	      (begin		
		;; for 2nd invocation
		(set! url-infos '()))
	      ;; finalization
	      (let ((html (fopen (string-append directory "/" html-file) "w")))
		(if (string? url-file-header)
		    (fwrite url-file-header html))
		(for-each (lambda (str) (fwrite str html)) (reverse url-infos))
		(if (string? url-file-trailer)
		    (fwrite url-file-trailer html))
		(fclose html)))))))

;; run with the following settings:
;; Display the file		=> NO
;; Overwrite the file		=> NO
;; Sort files alphabetically	=> YES
;; Reverse order		=> NO
(define gm-thumbnail
  (%gm-thumbnail-m  "-small." #f ; or "/tmp"
		    "thumbnail-index.html"))

;; 2nd mother is add a string to image
(define (%gm-add-string str)
  (lambda (img drw path-strs)
    (if (number? img)
	(let ((not-in-use #t))		; for future extension
	  (gimp-text img -1 2 2 str 1 TRUE 14 PIXELS
		     "*" "courier" "*" "*" "*" "*")
	  ;;(gimp-image-flatten img)
	  ))))

(if (not (symbol-bound? 'gm-copyright-string (the-environment)))
    (define gm-copyright-string "Copyright (c) 1998 Shuji Narazaki"))

;; try it!
;; run with the following settings:
;; Display the file		=> NO
;; Overwrite the file		=> NO
;; Sort files alphabetically	=> NO
;; Reverse order		=> NO
(define gm-add-copyright (%gm-add-string gm-copyright-string))

(if (not (symbol-bound? 'gm-number-of-color-for-indexed-image (the-environment)))
    (define gm-number-of-color-for-indexed-image 256))
;; file  converter
(define (%gm-save-as extension indexed?)
  (lambda (img drw path-strs)
    (if (number? img)
	(let ((new-name (string-append (nth 1 path-strs) ; directory
				       "/"
				       (nth 2 path-strs) ; name 
				       "."
				       extension))
	      (image-type (car (gimp-image-base-type img))))
	  (cond ((and indexed?
		      (not (= image-type INDEXED)))
		 (gimp-convert-indexed img TRUE
				       gm-number-of-color-for-indexed-image))
		((and (not indexed?)
		      (not (= image-type RGB)))
		 (gimp-convert-rgb img)))
	  (set! drw (car (gimp-image-flatten img)))
	  (gimp-file-save 0 img drw new-name new-name)))))

;; try them!
;; run with the following settings:
;; Display the file		=> NO
;; Overwrite the file		=> NO
;; Sort files alphabetically	=> NO
;; Reverse order		=> NO
(define gm-to-jpg (%gm-save-as "jpg" #f))
(define gm-to-tiff (%gm-save-as "tif" #f))
(define gm-to-gif (%gm-save-as "gif" #t))
(define gm-to-png (%gm-save-as "png" #t))

;; gather selected images into a new multi-layered image
;; run with the following settings:
;; Display the file		=> NO
;; Overwrite the file		=> NO
;; Sort files alphabetically	=> NO
;; Reverse order		=> YES
(define gm-collect
  ;; arguments: image-id, drawable-id, file-list
  ;; file-list is: (fullpath directory file-name-w/o-suffix suffix)
  ;; Namely, this function should be inovoked like:
  ;;  (gm-mapper 1 1 '("/usr/tmp/foo.jpg" "/usr/tmp" "foo" "jpg"))
  ;;  Warning: period between foo and jpg is removed here ^
  ;;
  ;; The procedure is invoked twice more out of the iteration on selection.
  ;; Fisrt invoked as initialization step with args: #f #f selection-list
  ;; And invoked as finalization with #f #t selection-list after the loop
  ;; Note: #t is equal to 1 in script-fu !!!!!!!!
  (let* ((init-size 1)
	 (max-width init-size)
	 (max-height init-size)
	 (new-image #f)
	 (bg-layer #f)
	 (top-layer #f))
    (lambda (img drw path-strs)
      (if (number? img)
	  (let* ((width (car (gimp-drawable-width drw)))
		 (height (car (gimp-drawable-height drw)))
		 (resized? #f)
		 (new-layer
		  (car (gimp-layer-new new-image width height RGBA_IMAGE 
				       (string-append (nth 2 path-strs)
						      "."
						      (nth 3 path-strs))
				       100 NORMAL))))
	    ;; flatten image
	    (set! drw (car (gimp-image-flatten img)))
	    ;; copy drawable
	    (gimp-selection-all img)
	    (gimp-edit-copy drw)
	    ;; resize new-image before add the layer
	    (if (< max-width width)
		(begin
		  (set! max-width width)
		  (set! resized? #t)))
	    (if (< max-height height)
		(begin
		  (set! max-height height)
		  (set! resized? #t)))
	    (if resized?
		(gimp-image-resize new-image max-height max-width 0 0))
	    ;; add to new-image
	    (gimp-image-add-layer new-image new-layer -1)
	    (set! top-layer (car (gimp-edit-paste new-layer FALSE)))
	    (gimp-floating-sel-anchor top-layer)
	    )
	  ;; hook
	  (if (eq? drw #f)
	      (begin			; initialization
		(set! new-image (car (gimp-image-new init-size init-size RGB)))
		(set! bg-layer (car (gimp-layer-new new-image init-size init-size
						    RGBA_IMAGE "BG" 100 NORMAL)))
		(set! top-layer bg-layer)
		(gimp-image-add-layer new-image bg-layer 0)
		(gimp-display-new new-image))
	      (begin			; finalization
		(gimp-image-resize new-image max-width max-height 0 0)
		(gimp-image-remove-layer new-image bg-layer)
		(gimp-image-clean-all new-image)
		(gimp-displays-flush)))))))

;; run with the following settings:
;; Display the file		=> NO
;; Overwrite the file		=> NO
;; Sort files alphabetically	=> NO
;; Reverse order		=> NO
;; Extra args	=> (WIDTH-OF-IMAGE-REGION HEIGTH-OF-IMAGE-REGION FILENAME)
;;   FILENAME is the name of generated file (STRING).
;;   (870 576 "guash-mgp.mgp") is the default (85% of 1024x768 screen)
(if (not (symbol-bound? 'gm-mgp-filename (the-environment)))
    (define gm-mgp-filename "guash-mgp.mgp"))
(if (not (symbol-bound? 'gm-mgp-file-header (the-environment)))
    (define gm-mgp-file-header 
"%include \"default.mgp\"
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%page
%nodefault
%fore \"red\", size 7, xfont times-bold-r, back \"darkblue\"



%center
The GIMP
meets
Magic Point

"))
(if (not (symbol-bound? 'gm-mgp-file-tailer (the-environment)))
    (define gm-mgp-file-trailer #f))
(if (not (symbol-bound? 'gm-mgp-image-header (the-environment)))
    (define gm-mgp-image-header "\n%CENTER, IMAGE "))
(if (not (symbol-bound? 'gm-mgp-image-width-threshold (the-environment)))
    (define gm-mgp-image-max-size 
      (let ((scale 0.85))
	(list (* 1024 scale)
	      (*  768 scale)))))
(define gm-mgp
  ;; make a closure
  (let ((mgp-pages '())
	(directory #f))
    (lambda (img drw path-strs . geometry.file)
      (if (number? img)
	  (let* ((width (car (gimp-image-width img)))
		 (height (car (gimp-image-height img)))
		 (image-max-size 
		  (if (pair? geometry.file)
		      (list (nth 0 geometry.file)
			    (nth 1 geometry.file))
		      gm-mgp-image-max-size))
		 (width-scale (/ (* 100 (car image-max-size)) width))
		 (height-scale (/ (* 100 (car (cdr image-max-size))) height))
		 (floor (lambda (x) (- x (fmod x 1))))
		 (scale (number->string
			 (floor
			  (if (< width-scale height-scale)
			      width-scale
			      height-scale)
			  1)))
		 (original-name ""))
	    (if (null? directory)
		(set! directory (nth 1 path-strs)))
	    (set! original-name (string-append (nth 2 path-strs) "."
					       (nth 3 path-strs)))
	    (set! mgp-pages
		  (cons (string-append "%PAGE\n\n"
				       original-name "\n\n"
				       gm-mgp-image-header
				       "\"" original-name "\" 0 "
				       scale
				       " "
				       scale
				       " 1\n\n\n")
			mgp-pages)))
	  ;; hook
	  (if (eq? drw #f)
	      ;; initialization
	      (begin		
		;; for 2nd invocation
		(set! mgp-pages '())
		(set! directory #f))
	      ;; finalization
	      (let ((mgp 
		     (fopen (string-append
			     (or directory ".")
			     "/"
			     (if (and (pair? geometry.file)
				      (= (length geometry.file) 3))
				 (nth 2 geometry.file)
				 gm-mgp-filename))
			    "w")))
		(if (string? gm-mgp-file-header)
		    (fwrite gm-mgp-file-header mgp))
		(for-each (lambda (str) (fwrite str mgp)) (reverse mgp-pages))
		(if (string? gm-mgp-file-trailer)
		    (fwrite gm-mgp-file-trailer mgp))
		(fclose mgp)))))))

;;; guash-mapper-sample.scm ends here
