home *** CD-ROM | disk | FTP | other *** search
/ ftp.sunet.sepub/pictures / 2014.11.ftp.sunet.se-pictures.tar / ftp.sunet.se / pub / pictures / ACiD-artpacks / programs / unix / editors / gimp-plugins-unstable-0_99_23_tar.gz / gimp-plugins-unstable-0_99_23_tar / gimp-plugins-unstable-0.99.23 / guash / guash-mapper-sample.scm < prev    next >
Text File  |  1998-02-24  |  3KB  |  103 lines
  1. ;;; Commentary:
  2. ;;;  This is a sample file for %guash-mapper function.
  3. ;;;  Modify or delete freely!
  4.  
  5. ;;; First, try:
  6. ;;; %gm-thumbnail, %gm-add-copyright, %gm-to-jpg
  7. ;;; These functions were generated from its mother(meta) functions.
  8.  
  9. ;; 1st sample is automatic thumnail&html generator
  10. ;; This is an example of use of two extra invocations.
  11.  
  12. (define (%gm-thumbnail-m thumbnail-tail directory html-file)
  13.   ;; make a closure
  14.   (let ((url-infos '())
  15.     ;; parameters: modify them as you like.
  16.     (url-file-header "")    ; "<ul>"
  17.     (url-file-trailer "")    ; "</ul>"
  18.     (url-header "")    ; "<li>"
  19.     (url-trailer ""))
  20.     (lambda (img drw path-strs)
  21.       (if (number? img)
  22.       (let* ((width (car (gimp-image-width img)))
  23.          (height (car (gimp-image-height img)))
  24.          (thumbnail-size 64)
  25.          (thumbnail-width 1)
  26.          (thumbnail-height 1)
  27.          (original-name "")
  28.          (thumbnail-name "")
  29.          (new-name ""))
  30.         (if (null? directory)
  31.         (set! directory (nth 1 path-strs)))
  32.         (if (< width height)
  33.         (begin
  34.           (set! thumbnail-height thumbnail-size)
  35.           (set! thumbnail-width (* (/ width height) thumbnail-size)))
  36.         (begin
  37.           (set! thumbnail-width thumbnail-size)
  38.           (set! thumbnail-height (* (/ height width) thumbnail-size))))
  39.         (gimp-image-scale img thumbnail-width thumbnail-height)
  40.         (set! original-name (string-append (nth 2 path-strs) "."
  41.                            (nth 3 path-strs)))
  42.         (set! thumbnail-name (string-append (nth 2 path-strs)
  43.                         thumbnail-tail
  44.                         (nth 3 path-strs)))
  45.         (set! new-name (string-append directory "/" thumbnail-name))
  46.         (gimp-file-save 0 img drw new-name new-name)
  47.         (gimp-image-clean-all img)
  48.         (set! url-infos
  49.           (cons (string-append url-header
  50.                        "<a href=\"" original-name
  51.                        "\"><img src=\"" thumbnail-name
  52.                        "\" alt=\"" original-name
  53.                        "\"></a>"
  54.                        url-trailer "\n")
  55.             url-infos)))
  56.       ;; hook
  57.       (if (eq? drw #f)
  58.           (begin            ; initialization
  59.         ;; for 2nd invocation
  60.         (set! url-infos '()))
  61.           (let ((html (fopen (string-append directory "/" html-file) "w")))
  62.         (if (string? url-file-header)
  63.             (fwrite url-file-header html))
  64.         (for-each (lambda (str) (fwrite str html)) url-infos)
  65.         (if (string? url-file-trailer)
  66.             (fwrite url-file-trailer html))
  67.         (fclose html)))))))
  68.  
  69. (define %gm-thumbnail
  70.   (%gm-thumbnail-m  "-small." #f ; or "/tmp"
  71.             "thumbnail-index.html"))
  72.  
  73. ;; 2nd mother is add a string to image
  74. (define (%gm-add-string str)
  75.   (lambda (img drw path-strs)
  76.     (if (number? img)
  77.     (let ((not-in-use #t))        ; for future extension
  78.       (gimp-text img -1 2 2 str 1 TRUE 14 PIXELS
  79.              "*" "courier" "*" "*" "*" "*")
  80.       ;;(gimp-image-flatten img)
  81.       ))))
  82.  
  83. (define %gm-add-copyright (%gm-add-string "Copyright (c) Shuji Narazaki"))
  84.  
  85. ;; file  converter
  86. (define (%gm-save-as extension indexed?)
  87.   (lambda (img drw path-strs)
  88.     (if (number? img)
  89.     (let ((new-name (string-append (nth 1 path-strs) ; directory
  90.                        "/"
  91.                        (nth 2 path-strs) ; name 
  92.                        "."
  93.                        extension)))
  94.       ;; check image type if need!
  95.       ;; not implemented...
  96.       (gimp-file-save 0 img drw new-name new-name)))))
  97.  
  98. ;; try them!
  99. (define %gm-to-jpg (%gm-save-as "jpg" #f))
  100. (define %gm-to-gif (%gm-save-as "gif" #t))
  101.  
  102. ;;; guash-mapper-sample.scm ends here
  103.