source: project/release/4/sigma/trunk/sigma.scm @ 15689

Last change on this file since 15689 was 15689, checked in by Ivan Raikov, 10 years ago

converted sigma to using getopt-long

File size: 51.6 KB
Line 
1
2;;
3;; Scheme Image Gallery Management Application
4;;
5;; Based on the igal program by Eric Pop.
6;; SXML templates based on code by Oleg Kiselyov.
7;; CD image creation code by Walter C. Pelissero.
8;;
9;;
10;; Copyright 2007-2009 Ivan Raikov.
11;;
12;; This program is free software: you can redistribute it and/or
13;; modify it under the terms of the GNU General Public License as
14;; published by the Free Software Foundation, either version 3 of the
15;; License, or (at your option) any later version.
16;;
17;; This program is distributed in the hope that it will be useful, but
18;; WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
20;; General Public License for more details.
21;;
22;; A full copy of the GPL license can be found at
23;; <http://www.gnu.org/licenses/>.
24;;
25
26
27(import foreign)
28
29(require-extension
30 regex data-structures posix files srfi-1 srfi-13 extras 
31 matchable getopt-long uri-generic fmt 
32 utf8 sxml-transforms) 
33
34(define s+ string-append)
35
36(define lookup-def 
37  (lambda (k lst . rest)
38    (let-optionals rest ((default #f))
39      (alist-ref k lst eq? default))))
40
41
42(define (fpesc dir . rest)
43  (if (null? rest)
44      (s+ "\"" dir "\"")
45      (s+ "\"" dir dirsep (apply s+ rest) "\"")))
46
47(foreign-declare "#include <math.h>")
48
49(define mkdtemp (foreign-lambda c-string "mkdtemp" c-string))
50(define log10 (foreign-lambda double "log10" double))
51
52(define (sigma:warning x . rest)
53  (let loop ((port (open-output-string)) (objs (cons x rest)))
54    (if (null? objs)
55        (begin
56          (newline port)
57          (print-error-message (get-output-string port) 
58                               (current-error-port) "SIGMA warning: "))
59        (begin (display (car objs) port)
60               (display " " port)
61               (loop port (cdr objs))))))
62
63(define (sigma:error x . rest)
64  (let ((port (open-output-string)))
65    (if (port? x)
66        (begin
67          (display "[" port)
68          (display (port-name x) port)
69          (display "] " port)))
70    (let loop ((objs (if (port? x) rest (cons x rest))))
71      (if (null? objs)
72          (begin
73            (newline port)
74            (error 'SIGMA (get-output-string port)))
75          (begin (display (car objs) port)
76                 (display " " port)
77                 (loop (cdr objs)))))))
78
79
80(define SHARED-DIR (chicken-home))
81
82(define SIGMA-DIR (make-pathname SHARED-DIR "sigma"))
83
84(define-constant  slide-tmpl-file  "slide-template.scm")
85(define-constant  index-tmpl-file  "index-template.scm")
86(define-constant  css-tmpl-file    "sigma.css")
87(define-constant  caption-file     ".captions")
88(define-constant  sigma-dir        ".sigma")
89(define-constant  thumbprefix      ".thumb_")
90(define-constant  slideprefix      ".slide_")
91
92(define dirsep (string ##sys#pathname-directory-separator))
93
94(define local-sigma-dir
95    (let ((home (getenv "HOME")))
96      (if home (s+ home dirsep sigma-dir)
97          sigma-dir)))
98
99(define opt-defaults
100  `(
101    (d . ".")
102    (g . "Default Gallery Title")
103    (y . 75)
104    (n . 20)
105    (author .
106     ,(let ((user (getenv "USER")))
107        (if user (car (string-split 
108                       (fifth (user-information user)) ",")) 
109            "")))
110    (con .  "")
111
112    (cd-dir .
113     ,(let ((home (getenv "HOME")))
114        (if home (s+ home dirsep "tmp")
115            (s+ dirsep "tmp"))))
116
117    (cd-file  .   "Photos")
118    (html-ext .  "html")
119    (html-index . "index")
120    (html-hindex . "hindex")
121    (sp .         ,slideprefix)
122    (tp .        ,thumbprefix)
123    (verbose .    1)
124    ))
125
126(define (defopt x)
127  (lookup-def x opt-defaults))
128                 
129(define opt-grammar
130  `(
131    (a  "write image sizes under thumbnails on index page")
132    (c  "first generate and then use captions")
133    (C  "like -c, but preserve file names as captions")
134
135    (d  ,(s+ "operate on files in directory DIR (default: " (defopt 'd) ")")
136        (value (required DIR)
137               (predicate ,directory?)
138               (default ,(defopt 'd))))
139               
140    (f  "force thumbnail regeneration and scaled slides")
141
142    (g  ,(s+ "gallery title (default: " (defopt 'g) ")")
143        (value (required TITLE)
144               (default ,(defopt 'g))))
145
146    (k  "use the image captions for the HTML slide titles")
147
148    (n  "maximum thumbnails per index page"
149        (value (required N)
150               (default ,(defopt 'n))
151               (predicate ,string->number)
152               (transformer ,string->number)))
153
154    (R  "recursively descend subdirectories")
155
156    (t  ,(s+ "place gallery files in directory DIR "
157             "(will be created if it doesn't exist)")
158        (value (required DIR)))
159
160    (u  "write captions under thumbnails on index page")
161    (U  "write slide names under thumbnails on index page")
162    (x  "omit the image count from the captions")
163
164    (y  ,(s+ "scale all thumbnails to the same height  "
165             "(default: " (number->string (defopt 'y)) ")")
166        (value (required N)
167               (predicate ,string->number)
168               (transformer ,string->number)
169               (default ,(defopt 'y))))
170
171    (ad  "like -a, but write only the image dimensions")
172    (as  "like -a, but write only the file size (in kbytes)")
173
174    (author   ,(s+ "specify author name "
175                   "(default: " (defopt 'author) ")")
176              (value (required AUTHOR)
177                     (default  ,(defopt 'author))))
178
179    (con      "options to pass to convert"
180              (value (required OPTS)
181                     (default "")))
182
183    (cd-dir   ,(s+ "directory for CD image output "
184                   "(default: "   (defopt 'cd-dir) ")")
185              (value (required DIR)
186                     (predicate ,directory?)
187                     (default ,(defopt 'cd-dir))))
188
189    (cd-file  ,(s+ "name of CD image file if --gcd is not specified "
190                   "(default: " (defopt 'cd-file) ")")
191              (value (required FILE) 
192                     (default ,(defopt 'cd-file))))
193
194    (gcd       "like -g, but also sets CD image file name"
195               (value (required TITLE)))
196
197    (hls       "creates a highlights page")
198    (hls-main  "creates a highlights page as the main page")
199
200    (html-ext  ,(s+ "suffix of output HTML files "
201                    "(default: " (defopt 'html-ext) ")")
202               (value (required SUFFIX)
203                      (default ,(defopt 'html-ext))))
204
205    (html-index  ,(s+ "name (without suffix) of the main thumbnail "
206                      "index file (default: " (defopt 'html-index) ")")   
207                 (value (required NAME)
208                        (default ,(defopt 'html-index))))
209                       
210    (html-hindex  ,(s+ "name (without suffix) of the highlights "
211                       "index file (default: " (defopt 'html-hindex) ")")   
212                  (value (required NAME)
213                         (default ,(defopt 'html-hindex))))
214
215    (in          "use image file names for the HTML slide files")
216    (sp          ,(s+ "sets the slide image prefix "
217                      "(default: " (defopt 'sp) ")")
218                 (value (required PREFIX)
219                        (default ,(defopt 'sp))))
220
221    (top         "create index pages for directories that only contain subfolders")
222    (tp          ,(s+ "sets the thumbnail image prefix "
223                      "(default: " (defopt 'tp) ")")
224                 (value (required PREFIX)
225                        (default ,(defopt 'tp))))
226
227    (up          "create Up links even in top-level image galleries")
228
229    (verbose      ,(s+ "set verbose mode (0: quiet; 1: info; 2: debug)")
230                  (value (required LEVEL) 
231                         (default 1)
232                         (predicate ,string->number)
233                         (transformer ,string->number)))
234
235    (www          "makes all SIGMA files world-readable")
236    (xy           "scale thumbnails to N pixels in their longer dimension"
237                  (value (required N)     
238                         (predicate ,string->number)
239                         (transformer ,string->number)))
240
241    (yslide       "scale slides to the given maximum height"
242                  (value (required N)   
243                         (predicate ,string->number)
244                         (transformer ,string->number)))
245
246    (help         (single-char #\h))           
247
248    ))
249
250
251;; Use args:usage to generate a formatted list of options (from OPTS),
252;; suitable for embedding into help text.
253(define (sigma:usage)
254  (print "Usage: " (car (argv)) " [options...] commands ")
255  (newline)
256  (print "Where command can be one of the following: ")
257  (newline)
258  ((lambda (lst)
259     (let ((print-line  (lambda (x) (cat (space-to 5) (car x) (space-to 30) (cadr x)))))
260       (fmt #t (pad-char #\space (fmt-join print-line lst nl)))
261       (newline)))
262   `(("gallery"  "Create an image gallery (default if no command given)")
263     ("cdimage"  "Create a CD image containing the image slides")
264     ("thumbs"   "Create image thumbnails (implicit when gallery is also given)")
265     ("sort"     "Sort images by EXIF date or file creation date")
266     ("clean"    "Clean generated files")
267     ))
268  (newline)
269  (print "The following options are recognized: ")
270  (newline)
271  (print (parameterize ((indent 5)) (usage opt-grammar)))
272  (exit 1))
273
274
275;; Process arguments and collate options and arguments into OPTIONS
276;; alist, and operands (filenames) into OPERANDS.  You can handle
277;; options as they are processed, or afterwards.
278
279(define opts    (getopt-long (command-line-arguments) opt-grammar))
280(define opt     (make-option-dispatch opts opt-grammar))
281
282
283(define v:quiet 0)
284(define v:info  1)
285(define v:debug 2)
286
287(define (done . rest)
288  (let-optionals rest ((indicator "done!"))
289    (if (= (opt 'verbose) v:info)
290        (begin
291          (display indicator)
292          (newline)))))
293
294(define (progress . rest)
295  (let-optionals rest ((indicator "."))
296    (if (= (opt 'verbose) v:info)
297        (display indicator))))
298
299(define (message x . rest)
300  (if (positive? (opt 'verbose))
301      (let loop ((port (open-output-string)) (objs (cons x rest)))
302        (if (null? objs)
303            (begin
304              (newline port)
305              (print-error-message (get-output-string port) 
306                                   (current-output-port) "SIGMA"))
307            (begin (display (car objs) port)
308                   (display " " port)
309                   (loop port (cdr objs)))))))
310
311
312
313(define (run:execute explist)
314  (define (smooth lst)
315    (let ((slst (map ->string lst)))
316      (string-intersperse (cons (car slst) (cdr slst)) " ")))
317  (for-each (lambda (cmd)
318              (if (>= (opt 'verbose) 2) (printf "  ~A~%~!" cmd))
319              (system (->string cmd)))
320            (map smooth explist)))
321
322(define (run:execute* explist)
323  (define (smooth lst)
324    (let ((slst (map ->string lst)))
325      (string-intersperse (cons (car slst) (cdr slst)) " ")))
326  (for-each (lambda (cmd)
327              (if (>= (opt 'verbose) 2) (printf "  ~A~%~!" cmd))
328              (system* "~a" cmd))
329            (map smooth explist)))
330
331
332(define-syntax run
333  (syntax-rules ()
334    ((_ exp ...)
335     (run:execute* (list `exp ...)))))
336
337(define-syntax run-
338  (syntax-rules ()
339    ((_ exp ...)
340     (run:execute (list `exp ...)))))
341
342
343(define (ipipe:execute lam cmd)
344  (define (smooth lst)
345    (let ((slst (map ->string lst)))
346      (string-intersperse (cons (car slst) (cdr slst)) " ")))
347  ((lambda (cmd) 
348     (if (>= (opt 'verbose) 2) (printf "  ~A~%~!" cmd))
349     (with-input-from-pipe (sprintf "~a" cmd) lam))
350   (smooth cmd)))
351
352(define-syntax ipipe
353  (syntax-rules ()
354    ((_ lam exp)
355     (ipipe:execute lam `exp ))))
356
357
358
359(define nl (list->string (list #\newline)))
360
361(define (generate-HTML Content)
362 
363  (define (make-navbar head-parms)
364    (let ((links (lookup-def 'Links head-parms '())))
365      (and (pair? links)
366           `(div (@ (class "navbar"))
367                 (ul . ,(map (lambda (x) 
368                               (match x ((name val) 
369                                         `(li (a (@ (href ,val)) ,name))))) links))))))
370 
371 
372  (define (make-header head-parms)
373    `(head
374      ,nl (title ,(lookup-def 'title head-parms))
375      ,nl (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
376      ,nl (meta (@ (http-equiv "Content-Style-Type") (content "text/css")))
377      ,nl (meta (@ (http-equiv "Generator") (content "http://www.call-with-current-continuation.org/eggs/sigma.html")))
378      ,nl ,(let ((style  (lookup-def 'Style head-parms)))
379             (if style `(link (@ (rel "stylesheet") (type "text/css") (href ,style))) '()))
380      ,nl
381      ,(zip
382        (map
383         (lambda (key)
384           (let ((val (lookup-def key head-parms )))
385             (and val
386                  `(meta (@ (name ,(symbol->string key)) (content ,val))))))
387         '(description Author keywords Date-yyyymmdd))
388        (circular-list nl))
389      ,nl))
390 
391  (define (make-footer head-parms)
392    `((div  (@ (id "footer"))
393            (h3 "Created on "
394                ,(let* ((date-revised (car (lookup-def 'Date-yyyymmdd head-parms)))
395                        (year  (string->number (string-copy date-revised 0 4)))
396                        (month (string->number (string-copy date-revised 4 6)))
397                        (day   (string->number (string-copy date-revised 6 8)))
398                        (month-name
399                         (vector-ref
400                          '#("January" "February" "March" "April" "May" "June"
401                             "July"   "August" "September" "October" "November"
402                             "December")
403                          (- month 1))))
404                   (list month-name " " day ", " year)))
405            ,(let ((links (lookup-def 'Links head-parms '())))
406               (and (pair? links)
407                    (let ((home (lookup-def 'home links)))
408                      (and home
409                           `(p "This site's top page is "
410                               (a (@ (href ,home)) (strong ,home)))))))
411            (div (address ,(lookup-def 'Author head-parms)))
412            (p (font (@ (size "-2")) "Image gallery generated by SIGMA.")))))
413 
414
415  (let*
416      ;; Universal transformation rules. Work for every HTML,
417      ;; present and future
418      ((universal-conversion-rules
419        `((@
420           ((*default*       ;; local override for attributes
421             . ,(lambda (attr-key . value) (enattr attr-key value))))
422           . ,(lambda (trigger . value) (cons '@ value)))
423          (*default* . 
424                     ,(let ((with-nl    ;; Block-level HTML elements:
425                             ;; We insert a NL before them.
426                             ;; No NL is inserted before or after an
427                             ;; inline element.
428                             '(br                       ;; BR is technically inline, but we
429                               ;; treat it as block
430                               p div hr
431                               h1 h2 h3 h3 h5 h6
432                               dl ul ol li dt dd pre
433                               table tr th td
434                               center blockquote form
435                               address body thead tfoot tbody col colgroup)))
436                        (lambda (tag . elems)
437                          (let ((nl? (and (memq tag with-nl) #\newline)))
438                            (if (and (pair? elems) (pair? (car elems))
439                                     (eq? '@ (caar elems)))
440                                (list nl? #\< tag (cdar elems) #\>
441                                      (and (pair? (cdr elems))
442                                           (list (cdr elems) "</" tag #\> nl?)))
443                                (list nl? #\< tag #\> 
444                                      (and (pair? elems) (list elems "</" tag #\> nl?))
445                                      ))))))
446          (*text* . ,(lambda (trigger str) 
447                       (if (string? str) (string->goodHTML str) str)))
448          (n_           ;; a non-breaking space
449           . ,(lambda (tag . elems)
450                (list "&nbsp;" elems)))))
451
452       ;; Transformation rules to drop out everything but the
453       ;; 'Header' node
454       (search-Header-rules
455        `((Header *preorder*
456                  . ,(lambda (tag . elems) (cons tag elems)))
457          (*default*
458           . ,(lambda (attr-key . elems)
459                (let loop ((elems elems))
460                  (cond
461                   ((null? elems) '())
462                   ((not (pair? (car elems))) (loop (cdr elems)))
463                   ((eq? 'Header (caar elems)) (car elems))
464                   (else (loop (cdr elems)))))))
465          (*text* . ,(lambda (trigger str) '()))))
466       )
467
468    (let ((header-parms  (lookup-def 'Header (list (post-order Content search-Header-rules)))))
469      (SRV:send-reply
470       (pre-post-order Content
471                       `(
472                         ,@universal-conversion-rules
473
474                         (html:begin
475                          . ,(lambda (tag . elems)
476                               (let ((embedded?    (lookup-def 'Embedded header-parms)))
477                                 (if embedded? elems
478                                     (list
479                                      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\""
480                                      nl 
481                                      "\"http://www.w3.org/TR/html4/loose.dtd\">" nl
482                                      "<html>" nl
483                                      elems
484                                      "</html>" nl)))))
485                         
486                         (Header
487                          *macro*
488                          . ,(lambda (tag . headers)
489                               (let ((embedded?  (lookup-def 'Embedded header-parms)))
490                                 (if embedded?  (list)  (make-header headers)))))
491
492                         (navbar                        ; Find the Header in the Content
493                          . ,(lambda (tag)              ; and create the navigation bar
494                               (let ((header-parms
495                                      (lookup-def 'Header
496                                                  (list (post-order Content
497                                                                    search-Header-rules))
498                                                  )))
499                                 (post-order (make-navbar header-parms)
500                                             universal-conversion-rules))))
501                         
502                         (body
503                          . ,(lambda (tag . elems)
504                               (list "<body>" nl elems "</body>")))
505
506                         (footer                        ;; Find the Header in the Content
507                          . ,(lambda (tag)              ;; and create the footer of the page
508                               (post-order (make-footer header-parms)
509                                           universal-conversion-rules)))
510
511                         (gallery-title *macro* ;; Find the Header in the Content
512                                     . ,(lambda (tag)           ;; and create the page title rule
513                                          `(div (@ (id "header")) 
514                                                (h1 ,(lookup-def 'Gallery-Title header-parms)))))
515
516                         (slide-title *macro*   ;; Find the Header in the Content
517                                     . ,(lambda (tag)           ;; and create the page title rule
518                                          `(div (@ (id "header")) 
519                                                (h1 ,(lookup-def 'Slide-Title header-parms)))))
520
521                         (slide-caption *macro* 
522                                     . ,(lambda (tag)           
523                                          `(p ,(lookup-def 'Slide-Caption header-parms))))
524
525                         (slide-url *macro* 
526                                    . ,(lambda (tag)
527                                         (lookup-def 'Slide-URL header-parms)))
528
529                         (image-url *macro* 
530                                    . ,(lambda (tag)
531                                         (lookup-def 'Image-URL header-parms)))
532
533                         (image-thumbs *macro* 
534                                    . ,(lambda (tag . alist)
535                                         (let ((thumbs (lookup-def 'Thumbs header-parms)))
536                                           (or (and thumbs `(div (@ . ,alist) ,thumbs))
537                                               (list)))))
538
539                         (gallery-subfolders *macro* 
540                                    . ,(lambda (tag . alist)
541                                         (let ((subfolders (lookup-def 'Subfolders header-parms)))
542                                           (or (and subfolders
543                                                    `(div (@ . ,alist) (h1 "Subfolders") ,subfolders))
544                                               (list)))))
545
546                         (url *macro* . ,(lambda (tag href . contents)
547                                           `(a (@ (href ,href))
548                                               ,(if (pair? contents)
549                                                    contents
550                                                    href))))
551
552                         
553                         (Section       ;; (Section level "content ...")
554                          *macro*
555                          . ,(lambda (tag level head-word . elems)
556                               `((br) (n_) (a (@ (name ,head-word)) (n_))
557                                 (,(string->symbol (s+ "h" (number->string level)))
558                                  ,head-word ,elems))))
559
560                         (Section*      ;; (Section* level "content ...")
561                          *macro*
562                          . ,(lambda (tag level head-word . elems)
563                               `((br) (n_) (a (@ (name ,head-word)) (n_))
564                                 (,(string->symbol (s+ "h" (number->string level)))
565                                  ,head-word ,elems))))
566
567
568                         (TOC   ;; Re-scan the Content for "Section" tags and generate
569                          . ,(lambda (tag)      ;; the Table of contents
570                               (let ((sections
571                                      (pre-post-order Content
572                                                      `((Section        ;; (Section level "content ...")
573                                                         ((*text* . ,(lambda (tag str) str)))
574                                                         . ,(lambda (tag level head-word . elems)
575                                                              (list "<li><a href=\"#" head-word
576                                                                    "\">" head-word elems "</a>" nl )))
577                                                        (*default*
578                                                         . ,(lambda (tag . elems) elems))
579
580                                                        (*text* . ,(lambda (trigger str) (list)))))))
581                                        ;(write sections ##stderr)
582                                 (list "<div id=\"toc\">" 
583                                       "<h3>In this page:</h3> "
584                                       "<ul>"
585                                       sections 
586                                       "</ul></div>" nl))))
587
588
589                         ))))))
590
591
592;; remove the automatically generated files from the target directory
593(define (clean-targetdir path)
594  (let ((pat (s+ path dirsep "*.html")))
595    (run (rm -f ,pat))))
596
597;; load up list of image files from the given directory
598(define (read-imagedir path . rest)
599  (let-optionals rest ((sort-order 'l))
600    (let ((jpgpat  "(.*\\.[jJ][pP][eE]?[gG]$)")
601          (pngpat  "(.*\\.[pP][nN][gG]$)")
602          (gifpat  "(.*\\.[gG][iI][fF]$)")
603          (thumbpat (regexp-escape thumbprefix))
604          (slidepat (regexp-escape slideprefix)))
605      (let ((pat   (s+ jpgpat "|" pngpat "|" gifpat))
606            (expat (regexp (s+ ".*((" thumbpat ")|(" slidepat ")).*"))))
607        (let ((flst (find-files path (regexp pat)
608                                (lambda (x ax) (if (string-match expat x) ax 
609                                                   (cons (pathname-strip-directory x) ax)))
610                                (list) 0)))
611          (sort flst string<?))))))
612
613(define (read-subdirs path)
614  (find-files 
615   path (lambda (x) 
616          (let ((canx (canonical-path x))
617                (cant (and (opt 't) (canonical-path (opt 't)))))
618            (and (directory? x) (or (not cant) (not (string=? cant canx))))))
619   (lambda (x y) (let ((lst (string-split x dirsep)))
620                   (cons (if (absolute-pathname? x) (cons dirsep lst) lst) y))) (list) 0))
621 
622
623;; locate and copy (if necessary) a SIGMA template file
624(define (locate-and-copy-template SIGMA-DIR target-dir file-name)
625  (if (file-exists? (s+ target-dir dirsep file-name))
626      (message "Found " file-name " file.")
627      (begin
628        (message "No " file-name " file; getting a copy from " SIGMA-DIR ".")
629        (if (directory? SIGMA-DIR)
630            (if (file-exists? (s+ SIGMA-DIR dirsep file-name))
631                (run (cp -f ,(fpesc SIGMA-DIR file-name) ,(fpesc target-dir file-name)))
632                (sigma:error (s+ SIGMA-DIR dirsep file-name) 
633                             " cannot be read or does not exist."))
634            (sigma:error SIGMA-DIR " cannot be read or does not exist. ")))))
635
636
637(define (read-or-create-captions captionpath flst subdirs . rest)
638  (let-optionals rest ((fname-as-caption? #f))
639    (if (and (file-exists? captionpath)
640             (file-read-access? captionpath))
641      (with-input-from-file captionpath
642        (lambda ()
643          (let loop ((captions (list)) (subdirs (list)))
644            (let ((line (read-line)))
645              (if (eof-object? line)
646                  (values (reverse captions) (reverse subdirs))
647                  (let ((sexp (with-input-from-string line read)))
648                    (let* ((subdir?   (match sexp (('subdir . _) #t) (else #f)))
649                           (captions  (if (or subdir? (eof-object? sexp)) 
650                                          captions (cons sexp captions)))
651                           (subdirs   (if subdir? (cons (cdr sexp) subdirs) subdirs)))
652                    (loop captions subdirs))))))))
653      (if (and (null? flst) (null? subdirs))
654          (values #f #f)
655          (begin
656            ;; create caption-file file if it doesn't exist
657            (message "Creating file " captionpath ": ")
658            (with-output-to-file captionpath
659              (lambda ()
660                (print "; This is SIGMA " caption-file " file, first generated " 
661                       (time->string (seconds->local-time  (current-seconds)))
662                       ".")
663                (print "; The captions must be in S-expression format and may include SXML tags. ")
664                (print "; ")
665                (print "; Each caption entry can be in one of two forms: ")
666                (print "; ")
667                (print "; 1. (fname caption [option1 option2 ...]) ")
668                (print "; The first element is the image file name, and the second element is the caption. ")
669                (print "; The file name and the caption are required. They can be followed by any number of ")
670                (print "; options keywords. The only option keyword currently recognized is hl, which  ")
671                (print "; indicates that the slide should be included on the optional highlights page. ")
672                (print "; ")
673                (print "; 2. (subdir name caption) ")
674                (print "; Entries of this form  be used to specify captions for subfolders. ")
675                (print "; ")
676                (print "; To add any comments to this file or to exclude any images from the slide ")
677                (print "; show, add a ; sign at the beginning of their respective lines. ")
678                (print "; You may also change the order of images in your slide show at this time.")
679                (let loop ((flst  flst))
680                  (if (not (null? flst))
681                      (begin
682                        (write (list (car flst) (if fname-as-caption? (car flst) "")))
683                        (print)
684                        (loop (cdr flst)))))
685                (if subdirs
686                    (let loop ((subdirs  subdirs))
687                      (if (not (null? subdirs))
688                          (let ((subdir (car subdirs)))
689                            (write (list 'subdir (first subdir) (second subdir)
690                                         (if fname-as-caption? (first subdir) "")))
691                            (print)
692                            (loop (cdr subdirs))))))))
693            (message "Now edit the " captionpath " file to your liking and rerun sigma -c.")
694            (values #f #f))))))
695
696;; read EXIF image date or inode change time for the file
697(define (image-date path)
698  (let ((date (ipipe read-line (exif ,(fpesc path) |\|| grep Date |\|| grep orig  |\||  cut -f2 -d |\\\||))))
699    (if (or (eof-object? date) (string-null? date))
700        (let* ((s  (file-change-time path))
701               (ti (seconds->local-time s)))
702          (s+ (number->string (+ 1900 (vector-ref ti 5))) ":"
703                         (number->string (+ 1 (vector-ref ti 4))) ":"
704                         (number->string (vector-ref ti 3)) " "
705                         (number->string (vector-ref ti 2)) ":"
706                         (number->string (vector-ref ti 1)) ":"
707                         (number->string (vector-ref ti 0))))
708        (let loop ((str date))
709                  (let ((str1 (string-chomp str " ")))
710                    (if (string=? str str1) str
711                        (loop str1)))))))
712
713;; return x dim, y dim, rounded kb for image
714(define (image-size path)
715  (let ((kb (vector-ref (file-stat path) 5)))
716    (let ((dim (ipipe (lambda () (let ((line (read-line)))
717                                   ((lambda (geom)
718                                      (and (list? geom) (not (null? geom)) 
719                                           (map string->number (string-split (car geom) "x"))))
720                                    (string-split line "+"))))
721                      (identify -ping -verbose ,(fpesc path) |\|| grep "Geometry:" |\|| cut -d":" -f2 ))))
722      (list (car dim) (cadr dim) kb))))
723       
724
725;; determine image file sizes
726(define (read-image-sizes image-dir flst)
727  (message "Determining image sizes: ")
728  (let loop ((flst flst) (sz (list)))
729    (if (null? flst)
730        (begin
731          (done)
732          (reverse sz))
733        (let ((path (s+ image-dir dirsep (car flst))))
734          (let ((dims  (image-size path)))
735            (progress)
736            (loop (cdr flst) (cons dims sz)))))))
737
738
739(define (sort-images image-dir target-dir flst)
740  (let ((order (inexact->exact (ceiling (log10 (length flst))))))
741    (message "Reading image dates: ")
742    (let ((olst
743           (let loop ((flst flst) (olst (list)))
744             (if (null? flst) olst
745                 (let ((path (s+ image-dir dirsep (car flst))))
746                   (if (not (and (file-exists? path) (file-read-access? path)))
747                       (sigma:error 'sort-images ": cannot open " path))
748                   (let ((date (image-date path)))
749                     (progress)
750                     (loop (cdr flst) (merge (list (cons (car flst) date)) olst 
751                                             (lambda (x y) (string<=? (cdr x) (cdr y)))))))))))
752      (done)
753      (message "Sorting images by date: ")
754      (let* ((op (if (string=? image-dir target-dir) 'mv 'cp))
755             (temp-dir-name (s+ image-dir dirsep "sigma-tmp.XXXXXX"))
756             (temp-dir (mkdtemp temp-dir-name)))
757        (if (not temp-dir)
758            (sigma:error 'sort-image ": unable to create temporary directory " temp-dir-name))
759        (for-each (lambda (f)
760                    (let ((fpath (s+ image-dir dirsep f))
761                          (rpath (s+ temp-dir dirsep  f)))
762                      (run (,op  ,(fpesc fpath) ,(fpesc rpath)))
763                      (progress)))
764                  flst)
765        (let ((i+nlst (fold (lambda (fp i+nlst)
766                              (let ((fpath (s+ temp-dir dirsep  (car fp)))
767                                    (ext   (pathname-extension (car fp))))
768                                (match i+nlst 
769                                       ((i . nlst)
770                                        (let* ((width (if (positive? order) order 1))
771                                               (nfile (s+ (fmt #f (pad-char #\0 (fit/left width i))) "." ext))
772                                               (npath (s+ target-dir dirsep nfile)))
773                                          (run (mv  ,(fpesc fpath) ,(fpesc npath)))
774                                          (progress)
775                                          (cons (+ 1 i) (cons nfile nlst)))))))
776                            (cons 0 (list)) olst)))
777          (run (rm -rf ,temp-dir))
778          (done)
779          (reverse (cdr i+nlst)))))))
780
781(define (make-thumbs image-dir target-dir flst y . rest)
782  (let-optionals rest ((xy #f) (force-regen? #f) (convert-options ""))
783   (message "Creating thumbnails: ")
784   (let ((source-dir (if (string=? image-dir target-dir) image-dir target-dir)))
785     (let loop ((flst flst))
786       (if (not (null? flst))
787           (let ((image-path (s+ source-dir dirsep (car flst))))
788             (if (not (and (file-exists? image-path) (file-read-access? image-path)))
789                 (sigma:error 'make-thumbs ": cannot open " image-path))
790             (let ((thumb-path (s+ target-dir dirsep thumbprefix (car flst))))
791               (if (or (not (file-exists? thumb-path)) force-regen?
792                       (> (vector-ref (file-stat image-path) 9)
793                          (vector-ref (file-stat thumb-path) 9)))
794                   (run (convert ,convert-options -scale
795                                 ,(if xy (let ((xy (number->string xy)))
796                                           (s+ xy "x" xy))
797                                      (s+ "x" (number->string y)))
798                                 ,(fpesc image-path) ,(fpesc thumb-path))))
799               (progress)
800               (loop (cdr flst))))))
801     (done))))
802
803;; copy images to target-dir, if necessary
804(define (copy-images image-dir target-dir flst)
805  (if (not (string=? image-dir target-dir))
806      (begin
807        (message "Copying images to target directory: ")
808        (let loop ((flst flst))
809          (if (not (null? flst))
810          (let ((image-path  (s+ image-dir dirsep (car flst)))
811                (target-path (s+ target-dir dirsep (car flst))))
812            (if (not (and (file-exists? image-path) (file-read-access? image-path)))
813                (sigma:error 'copy-images ": cannot open " image-path))
814            (if (not (file-exists? target-path))
815                (run (cp -f ,(fpesc image-path) ,(fpesc target-path))))
816            (progress)
817            (loop (cdr flst)))
818          (done))))))
819
820;; scale down images if the --yslide <n> option was given
821(define (scale-images image-dir target-dir flst yslide . rest)
822  (let-optionals rest ((force-regen? #f) (convert-options ""))
823    (let ((source-dir (if (string=? image-dir target-dir) image-dir target-dir)))
824     (message "Scaling down big slides: ")
825     (let loop ((flst flst))
826       (if (not (null? flst))
827           (let ((image-path (s+ source-dir dirsep (car flst))))
828             (if (not (and (file-exists? image-path) (file-read-access? image-path)))
829                 (sigma:error 'scale-images ": cannot open " image-path))
830             (let ((slide-path (s+ target-dir dirsep slideprefix (car flst))))
831               (if (or (not (file-exists? slide-path)) force-regen?)
832                   (let ((y (cadr (image-size image-path))))
833                     (if (and (positive? yslide) (> y yslide)) ;; only scale down, never up.
834                         (run (convert  ,convert-options 
835                                        -scale ,(s+ "x" (number->string yslide))
836                                        ,(fpesc image-path) ,(fpesc slide-path)))
837                         (run (ln ,(fpesc image-path) ,(fpesc slide-path))))))
838               (progress)
839               (loop (cdr flst))))))
840     (done))))
841
842
843(define (filter-subfolders target-dir target-dir-depth lst)
844  (filter-map (lambda (d) 
845                (let ((thumbpat   (regexp (s+ (regexp-escape thumbprefix) ".*")))
846                      (absolute?  (string=? dirsep (car d))))
847                  ;; only allow subfolders that contain thumbnails
848                  (let* ((dd        (drop (if absolute? (cdr d) d) target-dir-depth))
849                         (subflst   (directory (string-intersperse (cons target-dir dd) dirsep) #t))
850                         (subthumbs (filter (lambda (x) (string-match thumbpat x)) subflst)))
851                    (and (pair? subthumbs) 
852                         (list (string-intersperse dd dirsep) (car subthumbs))))))
853              lst))
854
855
856;; create the individual slide show files
857(define (make-slides image-dir target-dir slidetmpl index
858                     gallery-title flst captions slst 
859                     caption-as-title? omit-image-count? yslide author)
860  (message "Creating individual slides: ")
861  (let loop ((lst (zip flst captions slst)) (prev index) (counter 0))
862    (if (not (null? lst))
863        (match (car lst)
864               ((imagename caption slidename)
865                (let ((title   (let ((title (if caption-as-title?
866                                                ;; use image caption for the HTML slide title
867                                                caption
868                                                ;; otherwise use the image name with stripped suffix
869                                                (pathname-strip-extension imagename))))
870                                 (if omit-image-count? title 
871                                     (list title " (" (number->string counter) ")"))))
872                      (slide-url  (uri-encode-string 
873                                   (if yslide 
874                                       (s+ slideprefix imagename) 
875                                       imagename)))
876                      (image-url   (uri-encode-string imagename))
877                      (date        (let ((v         (seconds->local-time (current-seconds)))
878                                         (num->str  (lambda (i w) (fmt #f (pad-char #\0 (fit/left w i))))))
879                                     (let ((year  (num->str (+ 1900 (vector-ref v 5)) 4))
880                                           (month (num->str (+ 1 (vector-ref v 4)) 2))
881                                           (day   (num->str (vector-ref v 3) 2)))
882                                     (s+ year month day))))
883                      (links      `((contents  ,index)
884                                    (prev      ,prev)
885                                    (next      ,(if (null? (cdr lst)) "" (third (cadr lst)))))))
886                  (with-output-to-file (s+ target-dir dirsep slidename)
887                    (lambda ()
888                      (let* ((header `(Header (Date-yyyymmdd    ,date)
889                                              (Style            ,css-tmpl-file)
890                                              (Gallery-Title    ,gallery-title)
891                                              (Slide-Title      ,title)
892                                              (Slide-Caption    ,caption)
893                                              (Slide-URL        ,slide-url)
894                                              (Image-URL        ,image-url)
895                                              (Author           ,author)
896                                              (Links      . ,links)))
897                             (content 
898                              (pre-post-order
899                               slidetmpl
900                               `((html:begin . ,(lambda (tag . elems)
901                                                  (if (not (lookup-def 'Header elems))
902                                                      `(html:begin . ,(cons header elems))
903                                                      `(html:begin . ,elems))))
904                                 (Header . ,(lambda (tag . elems)
905                                              (if (null? elems) header
906                                                  `(Header . ,(append (cdr header) elems)))))
907                                 (*default*  . ,(lambda (tag . elems) `(,tag . ,elems)))))))
908                        (generate-HTML content))))
909                  (progress)
910                  (loop (cdr lst) slidename (+ 1 counter)))))))
911  (done))
912
913
914
915;; create the index files with all the thumbnails and optional subgalleries
916(define (make-index target-dir index-tmpl-file flst slst captions szlst
917                    nfiles max-thumbs html-index html-ext gallery-title author
918                    subfolders . rest)
919  (let-optionals rest ((up #f) (mlinks (list)))
920   (let ((index-tmpl-path (s+ target-dir dirsep index-tmpl-file))
921         (npages          (inexact->exact (ceiling (/ nfiles max-thumbs)))))
922     (let ((indextmpl (with-input-from-file index-tmpl-path read)))
923       (let loop ((i 0) (flst flst) (slst slst) (captions captions) (szlst szlst))
924         (if (not (null? flst))
925            (let ((nthumbs     (min (length flst) max-thumbs))
926                  (index-path  (s+ target-dir dirsep html-index 
927                                              (if (positive? i) (number->string i) "") 
928                                              "." html-ext)))
929              (message "Creating " index-path " file: ")
930              (let ((date   (let ((v         (seconds->local-time (current-seconds)))
931                                  (num->str  (lambda (i w) (fmt #f (pad-char #\0 (fit/left w i))))))
932                              (let ((year  (num->str (+ 1900 (vector-ref v 5)) 4))
933                                    (month (num->str (+ 1 (vector-ref v 4)) 2))
934                                    (day   (num->str (vector-ref v 3) 2)))
935                                (s+ year month day))))
936                    (image-thumbs
937                     (map (lambda (fname sname caption sz)
938                            (let ((thumbname (s+ thumbprefix fname)))
939                              `(div (@ (class "thumb"))
940                                    (a (@ (href ,(uri-encode-string sname))) 
941                                       (img (@ (src ,(uri-encode-string thumbname)))) ,nl) 
942                                    (div (@ (class "thumb-caption"))
943                                         ,(cond ((opt 'u)  `(p (@ (size "-2")) ,caption))
944                                                ((opt 'U)  `(p (@ (size "-2")) ,sname))
945                                                (else   ""))
946                                         ,(cond ((opt 'a)   `(p (@ (size "-2")) 
947                                                                ,(first sz) "x" ,(second sz) (br)
948                                                                "(" ,(quotient (third sz) 1024) " KB" ")"))
949                                                ((opt 'ad)  `(p (@ (size "-2")) ,(first sz) "x" ,(second sz)))
950                                                ((opt 'as)  `(p (@ (size "-2")) ,(quotient (third sz) 1024) " KB"))
951                                                (else   ""))))))
952                          (take flst nthumbs) (take slst nthumbs) (take captions nthumbs)
953                          (take szlst nthumbs)))
954                    (links (append
955                            (if up (let ((up-link (if (boolean? up) 
956                                                      (s+ ".." dirsep html-index "." html-ext)
957                                                      up)))
958                                     (list (list "Up" up-link)))
959                                (list))
960                            mlinks
961                            (if (> npages 1) 
962                                (list-tabulate
963                                npages (lambda (i) (list (string->symbol (number->string i))
964                                                         (s+ html-index (if (positive? i) (number->string i) "") 
965                                                             "." html-ext))))
966                                (list))))
967                    (subfolders  (map (lambda (sub)
968                                        (let ((index-path  (s+ (first sub) dirsep html-index "." html-ext))
969                                              (thumb-path  (s+ (first sub) dirsep (uri-encode-string (second sub))))
970                                              (caption     (if (string-null? (third sub)) (first sub) (third sub))))
971                                        `(div (@ (class "thumb"))
972                                              (a (@ (href ,index-path))
973                                                 (img (@ (src ,thumb-path))) ,nl)
974                                              (div (@ (class "thumb-caption"))
975                                                   (p ,caption)))))
976                                      subfolders)))
977                (with-output-to-file index-path
978                  (lambda ()
979                    (let* ((header `(Header (Date-yyyymmdd  ,date)
980                                            (Style          ,css-tmpl-file)
981                                            (Gallery-Title  ,gallery-title)
982                                            (Thumbs         ,image-thumbs)
983                                            (Author         ,author)
984                                            (Links          . ,links) 
985                                            ,@(if (null? subfolders) `()
986                                                  `((Subfolders     . ,subfolders)))))
987                           (content 
988                            (pre-post-order
989                             indextmpl
990                             `((html:begin . ,(lambda (tag . elems)
991                                                (if (not (lookup-def 'Header elems))
992                                                    `(html:begin . ,(cons header elems))
993                                                    `(html:begin . ,elems))))
994                               (Header . ,(lambda (tag . elems)
995                                            (if (null? elems) header
996                                                `(Header ,(append (cdr header) elems)))))
997                               (*default* . ,(lambda (tag . elems) `(,tag . ,elems)))))))
998                      (generate-HTML content))))
999                (done)
1000                (loop (+ 1 i) (drop flst nthumbs) (drop slst nthumbs) (drop captions nthumbs)
1001                      (drop szlst nthumbs))))))))))
1002
1003
1004;; create an index file that only contains subgalleries
1005(define (make-toplevel-index target-dir index-tmpl-file html-index html-ext gallery-title author
1006                             subfolders . rest)
1007  (let-optionals rest ((up #f) (home #f))
1008   (let ((index-tmpl-path (s+ target-dir dirsep index-tmpl-file)))
1009     (let ((indextmpl (with-input-from-file index-tmpl-path read)))
1010       (let ((index-path  (s+ target-dir dirsep html-index "." html-ext)))
1011         (message "Creating " index-path " file: ")
1012         (let ((date   (let ((v         (seconds->local-time (current-seconds)))
1013                             (num->str  (lambda (i w) (fmt #f (pad-char #\0 (fit/left w i))))))
1014                         (let ((year  (num->str (+ 1900 (vector-ref v 5)) 4))
1015                               (month (num->str (+ 1 (vector-ref v 4)) 2))
1016                               (day   (num->str (vector-ref v 3) 2)))
1017                           (s+ year month day))))
1018               (links (append
1019                       (if up (let ((up-link (if (boolean? up) 
1020                                                 (s+ ".." dirsep html-index "." html-ext)
1021                                                 up)))
1022                                (list (list "Up" up-link)))
1023                           (list))
1024                       (if home (list (list "Home" home)) (list))))
1025               (subfolders  (map (lambda (sub)
1026                                   (let ((index-path  (s+ (first sub) dirsep html-index "." html-ext))
1027                                         (thumb-path  (s+ (first sub) dirsep (uri-encode-string (second sub))))
1028                                         (caption     (if (string-null? (third sub)) (first sub) (third sub))))
1029                                     `(div (@ (class "thumb"))
1030                                           (a (@ (href ,index-path))
1031                                              (img (@ (src ,thumb-path))) ,nl)
1032                                           (div (@ (class "thumb-caption"))
1033                                                (p ,caption)))))
1034                                 subfolders)))
1035           (with-output-to-file index-path
1036             (lambda ()
1037               (let* ((header `(Header (Date-yyyymmdd  ,date)
1038                                       (Style          ,css-tmpl-file)
1039                                       (Gallery-Title  ,gallery-title)
1040                                       (Author         ,author)
1041                                       (Links          . ,links) 
1042                                       ,@(if (null? subfolders) `()
1043                                             `((Subfolders     . ,subfolders)))))
1044                      (content 
1045                       (pre-post-order
1046                        indextmpl
1047                        `((html:begin . ,(lambda (tag . elems)
1048                                           (if (not (lookup-def 'Header elems))
1049                                               `(html:begin . ,(cons header elems))
1050                                               `(html:begin . ,elems))))
1051                          (Header . ,(lambda (tag . elems)
1052                                       (if (null? elems) header
1053                                           `(Header ,(append (cdr header) elems)))))
1054                          (*default* . ,(lambda (tag . elems) `(,tag . ,elems)))))))
1055                 (generate-HTML content))))
1056           (done)))))))
1057
1058
1059(define (main-make-gallery SIGMA-DIR index image-dir target-dir commands . rest)
1060  (let-optionals rest ((subdirs (list)) (up #f) (toplevel? #f) (slide-dir #f))
1061   (message "entering directory: " image-dir)
1062   (if (commands 'clean?) 
1063       (let* ((pat (s+ ".*/(" thumbprefix ".*|" slideprefix ".*|" css-tmpl-file "|"
1064                       index-tmpl-file "|" slide-tmpl-file "|.*\\.html|" caption-file ")"))
1065              (flst (find-files target-dir (regexp pat) 
1066                                (lambda (x ax) (delete-file x) (cons x ax)) (list) 0)))
1067         (message "deleted files: " flst)))
1068   (let ((flst  (read-imagedir image-dir)))
1069     ;; make sure there are some image files or subdirectories in the given directory
1070     (if (and (null? flst) (null? subdirs))
1071         (sigma:error "cannot find any image files or subdirectories in directory " image-dir))
1072     ;; make sure target dir exists
1073     (if (not (file-exists? target-dir))
1074         (create-directory target-dir))
1075     (let ((captionpath        (s+ target-dir dirsep caption-file))
1076           (target-dir-depth   (length (string-split target-dir dirsep))))
1077       (let ((subfolders (filter-subfolders target-dir target-dir-depth subdirs))
1078             ;; count the image files and sort them if requested by the user
1079             (flst  (if (and (commands 'sort?) (pair? flst)) 
1080                        (sort-images image-dir target-dir flst) flst)))
1081         ;; read in files specified in the .captions file
1082         (let-values (((flst+captions subfolders)
1083                       (if (or (opt 'c) (opt 'C)) 
1084                           (read-or-create-captions captionpath flst subfolders (opt 'C))
1085                           (values (map (lambda (x) (if (list? x) (append x (list "")) (list x ""))) flst)
1086                                   (map (lambda (x) (if (list? x) (append x (list "")) (list x ""))) subfolders)))))
1087           (let ((nfiles (or (and flst+captions (length flst)) 0)))
1088             (message "Found " nfiles " image files in directory: " image-dir)
1089             (cond ((and (zero? nfiles) toplevel? subfolders)
1090                    ;; Create a top-level index file that only contains links to subgalleries
1091                    (begin
1092                      (message "creating top-level index file...")
1093                      ;; locate and copy the index template file, if necessary
1094                      (locate-and-copy-template SIGMA-DIR target-dir index-tmpl-file)
1095                      ;; locate and copy the CSS file, if necessary
1096                      (locate-and-copy-template SIGMA-DIR target-dir css-tmpl-file)
1097                      ;; create the index files with all the thumbnails
1098                      (make-toplevel-index 
1099                       target-dir index-tmpl-file 
1100                       (opt 'html-index) (opt 'html-ext) 
1101                       (or (opt 'gcd) (opt 'g))
1102                       (opt 'author) 
1103                       subfolders up)
1104
1105                      (done)))
1106                   (flst+captions
1107                    (begin
1108                      (if (commands 'gallery?)
1109                          (if (< nfiles 1)
1110                              (sigma:error " please select more files for your gallery!")))
1111                      (if flst+captions
1112                          (let-values (((flst captions)   (unzip2 flst+captions))
1113                                       ((hflst hcaptions) (unzip2 (filter (lambda (x) (member 'hl x)) flst+captions))))
1114                            ;; copy images to target dir, if necessary
1115                            (if (not (commands 'sort?)) (copy-images image-dir target-dir flst))
1116                            ;; generate thumbnails
1117                            (if (commands 'thumbs?)
1118                                (make-thumbs image-dir target-dir flst (opt 'y) (opt 'xy) (opt 'f) (opt 'con)))
1119                            ;; if slide-dir is true (e.g. when making a CD image),
1120                            ;; copy the slides to slide-dir
1121                            (if slide-dir
1122                                (let ((snum (length (directory slide-dir))))
1123                                  (message "Copying slide images to CD image dir (" slide-dir "): ")
1124                                  (fold (lambda (f i)
1125                                          (let ((ext (pathname-extension f))
1126                                                (is  (fmt #f (pad-char #\0 (fit/left 5 i)))))
1127                                            (let ((fpath (s+ target-dir dirsep 
1128                                                             (if (opt 'yslide) (s+ slideprefix f) f)))
1129                                                  (rpath (s+ slide-dir dirsep is "." ext )))
1130                                              (run (cp  ,(fpesc fpath) ,(fpesc rpath)))
1131                                              (progress)
1132                                              (+ 1 i))))
1133                                        snum flst)
1134                                  (done)))
1135                            (if (commands 'gallery?)
1136                                (begin
1137                                  ;; scale down images
1138                                  (if (opt 'yslide)
1139                                      (scale-images image-dir target-dir flst (opt 'yslide) (opt 'f) (opt 'con)))
1140
1141                                  (let ((szlst  (read-image-sizes target-dir flst))
1142                                        (hszlst (and (or (opt 'hls) (opt 'hls-main))
1143                                                     (read-image-sizes target-dir hflst)))
1144                                        (slst  (if (opt 'in)  ;; use image file names for slide html file names
1145                                                   (map (lambda (n) (pathname-replace-extension n (opt 'html-ext))) flst)
1146                                                   (map (lambda (n) (s+ n "." (opt 'html-ext)))
1147                                                        (list-tabulate nfiles number->string))))
1148                                        (hslst  (if (opt 'in) 
1149                                                    (map (lambda (n) 
1150                                                           (s+ "hl" (pathname-replace-extension n (opt 'html-ext))))
1151                                                         hflst)
1152                                                    (map (lambda (n) (s+ "hl" n "." (opt 'html-ext)))
1153                                                         (list-tabulate (length hflst) number->string)))))
1154                                    (clean-targetdir target-dir)
1155                                    ;; locate and copy the slide template file, if necessary
1156                                    (locate-and-copy-template SIGMA-DIR target-dir slide-tmpl-file)
1157                                    (let ((slide-tmpl-path    (s+ target-dir dirsep slide-tmpl-file)))
1158                                      (let ((slidetmpl   (with-input-from-file slide-tmpl-path read))
1159                                            (hindex      (s+ (opt 'html-hindex) "." (opt 'html-ext)))
1160                                            (htitle      (list "Highlights of " '(br) (or (opt 'gcd) (opt 'g)))))
1161                                        ;; create the individual slide show files
1162                                        (make-slides image-dir target-dir slidetmpl 
1163                                                     (if (and (opt 'hls-main) (not (null? hflst))) hindex index)
1164                                                     (or (opt 'gcd) (opt 'g)) flst captions slst 
1165                                                     (opt 'k) (opt 'x) (opt 'yslide)
1166                                                     (opt 'author))
1167                                       
1168                                        (if (and (or (opt 'hls) (opt 'hls-main)) (not (null? hflst)))
1169                                            ;; create the slide show files for the highlight images
1170                                            (make-slides image-dir target-dir slidetmpl
1171                                                         (if (opt 'hls-main) index hindex)
1172                                                         htitle hflst hcaptions hslst
1173                                                         (opt 'k) (opt 'x) (opt 'yslide) (opt 'author)))
1174                                        ;; locate and copy the index template file, if necessary
1175                                        (locate-and-copy-template SIGMA-DIR target-dir index-tmpl-file)
1176                                        ;; locate and copy the CSS file, if necessary
1177                                        (locate-and-copy-template SIGMA-DIR target-dir css-tmpl-file)
1178                                        (cond ((and (opt 'hls-main) (not (null? hflst)))
1179                                               (let ((up-url (s+ ".." dirsep (opt 'html-index) "." (opt 'html-ext))))
1180                                                 ;; create the index files with all the thumbnails
1181                                                 (make-index target-dir index-tmpl-file flst slst captions szlst 
1182                                                             nfiles (opt 'n) (opt 'html-hindex) (opt 'html-ext)
1183                                                             (or (opt 'gcd) (opt 'g)) (opt 'author)
1184                                                             subfolders (and up up-url)
1185                                                             `(("Highlights" 
1186                                                                ,(s+ (opt 'html-index) "." (opt 'html-ext)))))
1187                                                 (make-index target-dir index-tmpl-file hflst hslst hcaptions hszlst 
1188                                                             (length hflst) (opt 'n) (opt 'html-index) (opt 'html-ext) 
1189                                                             htitle (opt 'author) subfolders (and up up-url)
1190                                                             `(("All images" 
1191                                                                ,(s+ (opt 'html-hindex) "." (opt 'html-ext)))))))
1192
1193                                              ((and (or (opt 'hls) (opt 'hls-main)) (not (null? hflst)))
1194                                               (let ((up-url (s+ ".." dirsep (opt 'html-index) "." (opt 'html-ext))))
1195                                                  ;; create the index files with all the thumbnails
1196                                                  (make-index target-dir index-tmpl-file flst slst captions szlst 
1197                                                              nfiles (opt 'n) (opt 'html-index) (opt 'html-ext)
1198                                                              (or (opt 'gcd) (opt 'g)) (opt 'author)
1199                                                              subfolders (and up up-url)
1200                                                              `(("Highlights" 
1201                                                                 ,(s+ (opt 'html-hindex) "." (opt 'html-ext)))))
1202                                                  (make-index target-dir index-tmpl-file hflst hslst hcaptions hszlst 
1203                                                              (length hflst) (opt 'n) (opt 'html-hindex) (opt 'html-ext)
1204                                                              htitle (opt 'author) subfolders (and up up-url)
1205                                                              `(("All images" 
1206                                                                 ,(s+ (opt 'html-index) "." (opt 'html-ext)))))))
1207                                               (else
1208                                                (make-index target-dir index-tmpl-file flst slst captions szlst 
1209                                                              nfiles (opt 'n) (opt 'html-index) (opt 'html-ext)
1210                                                              (or (opt 'gcd) (opt 'g)) (opt 'author) subfolders up )))
1211
1212                                        ;; if --www was invoked make all images world-readable at the end
1213                                        (if (opt 'www)
1214                                            (begin
1215                                              (message "Making all gallery files world-readable for WWW publishing...")
1216                                              (run  (chmod a+r ,(s+ (fpesc target-dir) dirsep css-tmpl-file)))
1217                                              (run  (chmod a+r ,(s+ (fpesc target-dir) dirsep "*." (opt 'html-ext))))
1218                                              (run- (chmod a+r ,(s+ (fpesc target-dir) dirsep thumbprefix "*.*")))
1219                                              (run- (chmod a+r ,(s+ (fpesc target-dir) dirsep slideprefix "*.*")))
1220                                              (for-each (lambda (x) (run (chmod a+r ,(fpesc target-dir x)))) flst)
1221                                              (done))))))))))))))))))))
1222
1223
1224(define (blocks->MB blocks)  (quotient (* 2 blocks) 1024))
1225     
1226(define-constant *blocks-in-700MB* 359846)
1227(define-constant *blocks-in-650MB* 332800)
1228
1229(define (estimate-filesystem-size dirs)
1230  (let* ((blocks  (ipipe (lambda () (let ((line (read-line))) (string->number line)))
1231                         (mkisofs -r -print-size -quiet ,@dirs)))
1232         (size-MB (blocks->MB blocks)))
1233    (if (zero? size-MB)
1234        (message "CD image size is estimated to be " (* 2 blocks) " KB. " )
1235        (message "CD image size is estimated to be " size-MB " MB. " ))
1236    (if (<= size-MB *blocks-in-650MB*)
1237        (let ((remaining (- *blocks-in-650MB* size-MB)))
1238          (message "it will fit in a 650 MB (70 min) disk, leaving " 
1239                   (blocks->MB remaining)
1240                   " MB (" remaining " blocks) unused. ")
1241          'cd650)
1242        (let ((remaining (- *blocks-in-700MB* size-MB))
1243              (excess    (- size-MB *blocks-in-650MB*)))
1244          (cond ((> size-MB *blocks-in-700MB*)
1245                 (message "it will not fit in a 700 MB (80 min) disk, for "
1246                          (blocks->MB (abs remaining))
1247                          " MB (" (abs remaining) " blocks) too much.  ")
1248                 #f)
1249                (else
1250                 (begin
1251                   (message "it will not fit in a 650 MB (70 min) disk for "
1252                            (blocks->MB excess)
1253                            " MB (" excess "  blocks), ")
1254                   (message "but it will fit in a 700 MB (80 min) disk leaving "
1255                            (blocks->MB remaining)
1256                            " MB (" remaining " blocks) unused. ")
1257                   'cd700)))))))
1258
1259
1260;; Make up a reasonable volume title from the directory names
1261(define (make-up-volume-title dirs)
1262  (string-intersperse (map (lambda (d) (pathname-file d)) dirs) " "))
1263
1264(define (create-iso-image dirs . rest)
1265  (if (estimate-filesystem-size dirs)
1266      (let-optionals rest
1267                     ((title        (make-up-volume-title dirs))
1268                      (output-path  (s+ (opt 'cd-dir) dirsep (or (opt 'gcd) (opt 'cd-file)) ".iso"))
1269                      (preparer     (opt 'author))
1270                      (publisher    (opt 'author)))
1271        (run (mkisofs -r -V ,(s+ "\"" title "\"") -p ,(s+ "\"" preparer "\"")
1272                      -P ,(s+ "\"" publisher "\"") -o ,(fpesc output-path) ,@dirs))
1273        output-path)))
1274
1275
1276
1277(define valid-commands '(clean sort thumbs gallery cdimage))
1278
1279(define (make-command-selector commands)
1280  (let ((clean?     (member 'clean commands))
1281        (sort?      (member 'sort commands))
1282        (thumbs?    (or (member 'gallery commands) (member 'thumbs commands)))
1283        (gallery?   (member 'gallery commands))
1284        (cdimage?   (member 'cdimage commands)))
1285    (and (or clean? sort? thumbs? gallery? cdimage?)
1286         (lambda (selector)
1287           (case selector
1288             ((cdimage?)     cdimage?)
1289             ((clean?)       clean?)
1290             ((sort?)        sort?)
1291             ((thumbs?)      thumbs?)
1292             ((gallery?)     gallery?))))))
1293     
1294     
1295(define (main options operands) 
1296    (let* (;; Determine what commands were given to the program, if
1297           ;; any
1298           (commands  (make-command-selector
1299                       (filter-map (lambda (x) (let ((s (string->symbol x)))
1300                                                 (and (member s valid-commands) s)))
1301                                   operands)))
1302           (commands  (or commands (make-command-selector '(gallery))))
1303           ;; Strip any unnecessary slashes from the end of the given
1304           ;; -d and -t directories
1305           (image-dir  (let loop ((opt_d (string-chomp (opt 'd) dirsep)))
1306                         (let ((opt_d1 (string-chomp opt_d dirsep)))
1307                           (if (string=? opt_d1 opt_d) opt_d
1308                               (loop opt_d1)))))
1309           (target-dir  (or (and (opt 't)
1310                                 (let loop ((opt_t (string-chomp (opt 't) dirsep)))
1311                                   (let ((opt_t1 (string-chomp opt_t dirsep)))
1312                                     (if (string=? opt_t1 opt_t) opt_t
1313                                         (loop opt_t)))))
1314                            image-dir)))
1315     
1316      (if (opt 'help) (sigma:usage))
1317     
1318      ;; sanity checks
1319      (if (and (opt 'g) (opt 'gcd))
1320          (sigma:error "please specify only one of the -g and --gcd options"))
1321      (if (and (opt 'y) (opt 'xy))
1322          (sigma:error "please specify only one of the -y and --xy options"))
1323      (if (or (and (opt 'y) (negative? (opt 'y))) 
1324              (and (opt 'xy) (negative? (opt 'xy))))
1325          (sigma:error "please enter non-negative thumbnail dimensions" ))
1326      (if (and (opt 'yslide) (negative? (opt 'yslide)))
1327          (sigma:error "please enter non-negative maximum slide height" ))
1328     
1329      (let (;; construct the name of the main index file
1330            (index  (s+ (opt 'html-index) "." (opt 'html-ext)))
1331            ;; let users store their templates in a $HOME/.sigma directory, if it exists,
1332            ;; instead of the site-wide /usr/share/sigma
1333            (SIGMA-DIR   (if (directory? local-sigma-dir) local-sigma-dir SIGMA-DIR))
1334            ;; makes a directory to store slides for a CD image
1335            (slide-dir (and (commands 'cdimage?)
1336                            (let* ((temp-dir-name (s+ image-dir dirsep ".sigma-cdimage.XXXXXX"))
1337                                   (temp-dir      (mkdtemp temp-dir-name )))
1338                              (if (not temp-dir) 
1339                                  (sigma:error 'main ": unable to create temporary directory " temp-dir-name))
1340                            temp-dir))))
1341        (if (opt 'R)
1342            (let* ((image-dir-depth   (length (string-split image-dir dirsep)))
1343                   (make-gallery 
1344                    (lambda (lev d . rest)
1345                      (let-optionals
1346                       rest ((subdirs (list)))
1347                       (let* ((absolute?    (string=? dirsep (car d)))
1348                              (image-dir    (if absolute?
1349                                                (s+ (car d) (string-intersperse (cdr d) dirsep))
1350                                                (string-intersperse d dirsep)))
1351                              (target-dir   (string-intersperse
1352                                             (cons target-dir (drop (if absolute? (cdr d) d) image-dir-depth))
1353                                             dirsep)))
1354                         (main-make-gallery SIGMA-DIR index image-dir target-dir commands 
1355                                            subdirs (or (positive? lev) (opt 'up)) (opt 'top)
1356                                            slide-dir))))))
1357              ;; make sure target dir exists
1358              (if (not (file-exists? target-dir))
1359                  (create-directory target-dir))
1360              (let recur ((level  0)
1361                          (dir    image-dir)
1362                          (dirlst (read-subdirs image-dir))
1363                          (null-handler (lambda (level dir) (sigma:error "no subdirectories found in " dir))))
1364                (if (null? dirlst)
1365                    (null-handler level dir)
1366                    (for-each
1367                     (lambda (d)
1368                       (let ((sd (string-intersperse d dirsep))) 
1369                         (let ((subdirs (read-subdirs sd)))
1370                           (recur (+ 1 level) d subdirs make-gallery))))
1371                     dirlst)))
1372              (main-make-gallery SIGMA-DIR index image-dir target-dir commands
1373                                 (read-subdirs target-dir) (opt 'up) (opt 'top slide-dir)))
1374            (main-make-gallery SIGMA-DIR index image-dir target-dir commands (list) (opt 'up) #f slide-dir))
1375        (if (commands 'cdimage?)
1376            (begin
1377              (message "Creating CD image " 
1378                       (s+ (opt 'cd-dir) dirsep (or (opt 'gcd) (opt 'cd-file)) ".iso") ": ")
1379              (create-iso-image (list slide-dir) (opt 'g))
1380              (done)))
1381        (if slide-dir (run (rm -rf ,slide-dir)))
1382        )))
1383
1384(main opts (opt '@))
1385
Note: See TracBrowser for help on using the repository browser.