source: project/release/3/sigma/trunk/sigma.scm @ 12413

Last change on this file since 12413 was 12413, checked in by Ivan Raikov, 12 years ago

Updated for version 1.15.

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