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

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

sigma converted to using getopt-long

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