; slice-save.scm
; Author: Arun Ravindran <arunvr@gmail.com>
; Version: 1.5
;
; License:
;
; 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.
;
; The GNU Public License is available at
; http://www.gnu.org/copyleft/gpl.html
;
; Description
; Simple script takes an image,
; - cuts it up on the guides, and
; - saves to numbered files.
;
; Modified from of Web-O-Tine by Jason Austin <jason@jasononthe.net>.
;
; Usage Notes:
;
; File numbering starts from 0, order basename-row-col.ext
; Image dir is relative to path of sliced image
;
; Changelog:
; Mikko Vatanen <mvatanen@cs.joensuu.fi>: Created version 1.0
;
; Start of code
; -------------
;;
;; Get a list of guides with the given orientation
;;

(define (script-fu-slice-save-guides image guide orientation)
  (if (not (= guide 0))
      (if (= (car (gimp-image-get-guide-orientation image guide))
             orientation)
          (append (gimp-image-get-guide-position image guide)
                  (script-fu-slice-save-guides
                   image
                   (car (gimp-image-find-next-guide image guide))
                   orientation))
        (script-fu-slice-save-guides
         image (car (gimp-image-find-next-guide image guide))
         orientation)
        )
    )
  )

;;
;; From a list of guides, create a list of coordinate pair lists for
;; the image slices.
;;
(define (script-fu-slice-save-slices cur-point last-point middle-points)
  (if (null? middle-points)
      (cons (list cur-point last-point) ())
    (cons (list cur-point (car middle-points))
          (script-fu-slice-save-slices
           (car middle-points) last-point
           (cdr middle-points)))
    )
  )


;;
;; Return path string from filename + path
;;
;;
;(define (script-fu-slice-save-dirname s)
;
; ;; Return string after first "/"
; (define (my-dirname-cut l)
; (if (or (null? l) (string=? (string (car l)) "/"))
; l (my-dirname-cut (cdr l))))
;
; (list->string (reverse
; (my-dirname-cut (reverse (string->list s)))))
; )

;;
;; Create an image slice and save it to file
;;
;;
(define (script-fu-slice-save-make-image image image-base
                                         image-dir image-ext
                                         horiz vert hpos vpos)
  (let* (
         (image-ext-str
          (if (= image-ext 0) "xpm"
            (if (= image-ext 1) "jpg"
              (if (= image-ext 2) "gif" "png"))))

         (image-file (string-append image-dir "/"
                                    image-base "-"
                                    (number->string (- hpos 1) 10) "-"
                                    (number->string (- vpos 1) 10) "."
                                    image-ext-str))
         ;; Duplicate
         (temp-image (car (gimp-image-duplicate image)))
         ;; Flatten image
         (layer (car (gimp-image-flatten temp-image)))
         ;; Crop size
         (image-width (- (cadr horiz) (car horiz)))
         (image-height (- (cadr vert) (car vert)))
         )


    ;; Crop image
    (gimp-image-crop temp-image image-width image-height
                     (car horiz) (car vert))
    ;; XPM
    (if (= image-ext 0)
        (file-xpm-save 1 temp-image layer image-file image-file 127))

    ;; JPG
    (if (= image-ext 1)
        (file-jpeg-save 1 temp-image layer image-file image-file 0.92
                        0.0 1 1 "Created with Gimp" 0 1 0 2))
    ;; GIF
    (if (= image-ext 2)
        (begin
         (gimp-convert-indexed temp-image 1 0 255 0 0 "")
         (file-gif-save 1 temp-image layer image-file image-file 0
                        0 0 0)))

    ;; PNG
    (if (= image-ext 3)
        (file-png-save 1 temp-image layer image-file image-file 0 6 1
                       0 0 1 1))

    (gimp-image-delete temp-image)

                                        ;(gimp-display-new temp-image)

    )
  )

(define (script-fu-slice-save image
                              layer
                              html-file
                              image-dir image-base
                              image-ext)
 
  (let* (
         (fh (open-output-file html-file))
         (grid (list (script-fu-slice-save-slices
                      0 (car (gimp-image-width image))
                      (sort (script-fu-slice-save-guides
                             image (car (gimp-image-find-next-guide image 0))
                             VERTICAL) <))
                     (script-fu-slice-save-slices
                      0 (car (gimp-image-height image))
                      (sort (script-fu-slice-save-guides
                             image (car (gimp-image-find-next-guide image 0))
                             HORIZONTAL) <))))
         (hpos 0)
         (vpos 0)
         (image-width 0)
         (image-file "")

         ;; (image-basedir (script-fu-slice-save-dirname
         ;; (car (gimp-image-get-filename image))))
         ;; (image-dir (
         ;; if (string? image-dir)
         ;; (string-append image-basedir image-dir)
         ;; (image-dir (image-basedir))))
         )

    (display "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">\n" fh)
    (display "<HTML>\n<BODY>\n" fh)
    (display "<TABLE BORDER=\"0\" CELLSPACING=\"0\" CELLPADDING=\"0\">\n" fh)
    (map (lambda (v)
           (set! hpos (+ hpos 1))
           (set! vpos 0)
           (display "<TR>\n" fh)
           (map (lambda (h)
                  (set! vpos (+ vpos 1))
                  (set! image-width (- (cadr h) (car h)))
                  (script-fu-slice-save-make-image image image-base
                                                   image-dir
                                                   image-ext
                                                   h v
                                                   hpos vpos)
                  (set! image-file (string-append "./"
                                    image-base "-"
                                    (number->string (- hpos 1) 10) "-"
                                    (number->string (- vpos 1) 10) "."
                                    (if (= image-ext 0) "xpm"
                                      (if (= image-ext 1) "jpg"
                                      (if (= image-ext 2) "gif" "png")))))
                  (display (string-append "<TD WIDTH='" (number->string image-width 10)
                     "'><IMG src='" image-file "'></TD>\n") fh)
                  ) (car grid))
                  (display "</TR>\n" fh)
           ) (cadr grid))
    ;(write grid fh)
    ;(write (map (lambda (x) (- (cadr x) (car x)))  '((0 47) (47 408) (408 480))) fh)
    (display "</TABLE>\n" fh)
    (display "</BODY>\n</HTML>\n" fh)
    (close-output-port fh)
    )
  )
;; Sort fnss
;;; (merge! a b less?)
;;; takes two sorted lists a and b and smashes their cdr fields to form a
;;; single sorted list including the elements of both.
;;; Note:  this does _not_ accept vectors.


(define (merge! a b less?)
  (define (loop r a b)
        (if (less? (car b) (car a))
            (begin
         (set-cdr! r b)
         (if (null? (cdr b))
             (set-cdr! b a)
           (loop b a (cdr b)) ))
      ;; (car a) <= (car b)
      (begin
       (set-cdr! r a)
       (if (null? (cdr a))
           (set-cdr! a b)
         (loop a (cdr a) b)) )) )
  (cond
   ((null? a) b)
   ((null? b) a)
   ((less? (car b) (car a))
    (if (null? (cdr b))
                (set-cdr! b a)
      (loop b a (cdr b)))
    b)
   (else                                ; (car a) <= (car b)
    (if (null? (cdr a))
                (set-cdr! a b)
      (loop a (cdr a) b))
    a)))



;;; (sort! sequence less?)
;;; sorts the list or vector sequence destructively.  It uses a version
;;; of merge-sort invented, to the best of my knowledge, by David H. D.
;;; Warren, and first used in the DEC-10 Prolog system.  R. A. O'Keefe
;;; adapted it to work destructively in Scheme.

(define (sort! seq less?)
  (define (step n)
        (cond
     ((> n 2)
      (let* ((j (quotient n 2))
             (a (step j))
             (k (- n j))
             (b (step k)))
        (merge! a b less?)))
     ((= n 2)
      (let ((x (car seq))
            (y (cadr seq))
            (p seq))
        (set! seq (cddr seq))
        (if (less? y x) (begin
                         (set-car! p y)
                         (set-car! (cdr p) x)))
        (set-cdr! (cdr p) '())
        p))
     ((= n 1)
      (let ((p seq))
        (set! seq (cdr seq))
        (set-cdr! p '())
        p))
     (else
      '()) ))
  (if (vector? seq)
      (let ((n (vector-length seq))
            (vec seq))
        (set! seq (vector->list seq))
        (do ((p (step n) (cdr p))
             (i 0 (+ i 1)))
            ((null? p) vec)
          (vector-set! vec i (car p)) ))
        ;; otherwise, assume it is a list
        (step (length seq)) ))

;;; (sort sequence less?)
;;; sorts a vector or list non-destructively.  It does this by sorting a
;;; copy of the sequence.  My understanding is that the Standard says
;;; that the result of append is always "newly allocated" except for
;;; sharing structure with "the last argument", so (append x '()) ought
;;; to be a standard way of copying a list x.

(define (sort seq less?)
  (if (vector? seq)
      (list->vector (sort! (vector->list seq) less?))
        (sort! (append seq '()) less?)))

;;;;;;;;;;;;;;;;;;;;;;
(script-fu-register "script-fu-slice-save"
                    _"_Slice for Web..."
                    "Slices image according to guides and saves to separate files. Creates an HTML to view the sliced image"
                    "Arun Ravindran"
                    "Arun Ravindran"
                    "2008"
                    "RGB*, GRAY*"
                    SF-IMAGE "Image to use" 0
                    SF-DRAWABLE "Drawable to draw grid" 0
                    SF-FILENAME "HTML File (beta)" "sliced.html"
                    SF-DIRNAME "Image Directory" "pixmaps"
                    SF-STRING "Image Base Name" "slice"
                    SF-OPTION "Image Extension" '("xpm" "jpg" "gif" "png")
                    )
(script-fu-menu-register "script-fu-slice-save"
 _"<Image>/File/Slice")