;;; map-on-guash-selection.scm -*-scheme-*-
;;; Author: Shuji Narazaki <narazaki@gimp.org>
;;; Time-stamp: <1999/02/24 22:35:10 narazaki@gimp.org>
;;; Version: 0.94
;;; Commentary:
;;;  This script is a part of guash, and is invoked from guash mainly.
;;;  YOU MUST define guash-selection-file out of this script.
;;;  EDIT ./guash-selection.scm

;;; Code:

(define gm-sample
  ;; 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
  ;;
  ;; Implementation memo: #t is equal to 1 in script-fu!! What a C-flavor lisp!
  (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)))))))

(define (script-fu-map-on-guash-selection script-file delete-script-file
					  func display? overwrite?
					  sort? reverse? extra-args-string)
  (define (sort l small? accessor)	; copied from my guile lib.
    (define (divide obj l)
      (define (divide-aux obj l smalls larges)
	(cond ((null? l) (cons smalls larges))
	      ((small? (accessor (car l)) (accessor obj))
	       (divide-aux obj (cdr l) (cons (car l) smalls) larges))
	      ('else (divide-aux obj (cdr l) smalls (cons (car l) larges)))))
      (divide-aux obj l () ()))
    (define (quick-sort l)
      (if (null? l)
	  ()
	  (let* ((obj (let ((tmp (car l))) (set! l (cdr l)) tmp))
		 (tmp (divide obj l))
		 (append! append))	; Oh boy!
	    (append! (quick-sort (car tmp))
		     (append! (list obj) (quick-sort (cdr tmp)))))))
    (quick-sort l))
  (let ((image #f)
	(drawable #f)
	(%guash-selection '())
	(image-files '())
	(image-file '())
	(interactive? 1)
	(extra-args (read-from-string extra-args-string)))
    (let ((file (fopen script-file)))
      (set! %guash-selection (car (cdr (car (cdr (cdr (read file)))))))
      (fclose file))
    ;(load selection-list-filename)
    (if (pair? %guash-selection)
	(begin
	  (set! image-files
		(if (eq? sort? TRUE)
		    (sort %guash-selection 
			  (lambda (x y) (< (strcmp x y) 0))
			  car)
		    %guash-selection))
	  (if (eq? reverse? TRUE)
	      (set! image-files (reverse image-files)))
	  ;; First call initializer with #f #f
	  (apply func (append (list #f #f image-files) extra-args))
	  (while (not (null? image-files))
	    (set! image-file (car (car image-files)))
	    (set! image (car (gimp-file-load interactive? image-file
					     image-file)))
	    (gimp-image-clean-all image)
	    (set! drawable (car (gimp-image-get-active-layer image)))
	    (if (= drawable -1)
		(set! drawable (car (nth 1 (gimp-image-get-layers image)))))
	    (if (eq? display? TRUE) (gimp-display-new image))
	    (apply func (append (list image drawable (car image-files))
				extra-args))
	    (if (eq? overwrite? TRUE)
		(gimp-file-save interactive? image drawable 
				image-file image-file))
	    (if (not (eq? display? TRUE))
		(begin
		  ;; delete quietly even if the image modified
		  (gimp-image-clean-all image)
		  (gimp-image-delete image)))
	    (set! image-files (cdr image-files)))
	  ;; Lastly call finalizer with #f #t
	  (apply func (append (list #f #t image-files) extra-args))
	  (if (eq? delete-script-file TRUE)
	      (extension-guash-script-fu-interface script-file))
	  )
	(gimp-displays-flush))))

(script-fu-register
 "script-fu-map-on-guash-selection"
 "<Toolbox>/Xtns/Script-Fu/Misc/Map on guash selection"
 "Map a procedure on the image files selected by guash"
 "Shuji Narazaki <narazaki@gimp.org>"
 "Shuji Narazaki"
 "1997-1998"
 ""
 SF-FILENAME "script file genrated by guash" "/tmp/guash"
 SF-TOGGLE "delete the script file after execution" TRUE
 SF-VALUE "Procedure" "gm-sample"
 SF-TOGGLE "Display the file" FALSE
 SF-TOGGLE "Overwrite the file" FALSE
 SF-TOGGLE "Sort files alphabetically" FALSE
 SF-TOGGLE "Reverse order" FALSE
 SF-STRING "Extra arg list" "()"
)
;;; map-on-guash-selection.scm ends here
