source: project/release/4/sigma/tags/2.5/sigma.scm @ 32850

Last change on this file since 32850 was 32850, checked in by Ivan Raikov, 5 years ago

sigma release 2.5

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