;;
;; Scheme Image Gallery Management Application
;;
;; Based on the igal program by Eric Pop.
;; SXML templates based on code by Oleg Kiselyov.
;; CD image creation code by Walter C. Pelissero.
;;
;;
;; Copyright 2007-2010 Ivan Raikov.
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; .
;;
(import foreign)
(require-extension
regex data-structures posix files srfi-1 srfi-13 extras
matchable getopt-long uri-generic fmt
utf8 sxml-transforms)
(define s+ string-append)
(define lookup-def
(lambda (k lst . rest)
(let-optionals rest ((default #f))
(alist-ref k lst eq? default))))
(define (fpesc dir . rest)
(if (null? rest)
(s+ "\"" dir "\"")
(s+ "\"" dir dirsep (apply s+ rest) "\"")))
(foreign-declare "#include ")
(define mkdtemp (foreign-lambda c-string "mkdtemp" c-string))
(define log10 (foreign-lambda double "log10" double))
(define (sigma:warning x . rest)
(let loop ((port (open-output-string)) (objs (cons x rest)))
(if (null? objs)
(begin
(newline port)
(print-error-message (get-output-string port)
(current-error-port) "SIGMA warning: "))
(begin (display (car objs) port)
(display " " port)
(loop port (cdr objs))))))
(define (sigma:error x . rest)
(let ((port (open-output-string)))
(if (port? x)
(begin
(display "[" port)
(display (port-name x) port)
(display "] " port)))
(let loop ((objs (if (port? x) rest (cons x rest))))
(if (null? objs)
(begin
(newline port)
(error 'SIGMA (get-output-string port)))
(begin (display (car objs) port)
(display " " port)
(loop (cdr objs)))))))
(define SHARED-DIR (chicken-home))
(define SIGMA-DIR (make-pathname SHARED-DIR "sigma"))
(define-constant slide-tmpl-file "slide-template.scm")
(define-constant index-tmpl-file "index-template.scm")
(define-constant css-tmpl-file "sigma.css")
(define-constant caption-file ".captions")
(define-constant sigma-dir ".sigma")
(define-constant thumbprefix ".thumb_")
(define-constant slideprefix ".slide_")
(define dirsep (string ##sys#pathname-directory-separator))
(define local-sigma-dir
(let ((home (getenv "HOME")))
(if home (s+ home dirsep sigma-dir)
sigma-dir)))
(define opt-defaults
`(
(d . ".")
(g . "Default Gallery Title")
(y . 75)
(n . 20)
(author .
,(let ((user (getenv "USER")))
(if user (car (string-split
(fifth (user-information user)) ","))
"")))
(con . "")
(cd-dir .
,(let ((home (getenv "HOME")))
(if home (s+ home dirsep "tmp")
(s+ dirsep "tmp"))))
(cd-file . "Photos")
(html-ext . "html")
(html-index . "index")
(html-hindex . "hindex")
(sp . ,slideprefix)
(tp . ,thumbprefix)
(verbose . 1)
))
(define (defopt x)
(lookup-def x opt-defaults))
(define opt-grammar
`(
(a "write image sizes under thumbnails on index page")
(c "first generate and then use captions")
(C "like -c, but preserve file names as captions")
(d ,(s+ "operate on files in directory DIR (default: " (defopt 'd) ")")
(value (required DIR)
(predicate ,directory?)
(default ,(defopt 'd))))
(f "force thumbnail regeneration and scaled slides")
(g ,(s+ "gallery title (default: " (defopt 'g) ")")
(value (required TITLE)
(default ,(defopt 'g))))
(k "use the image captions for the HTML slide titles")
(n "maximum thumbnails per index page"
(value (required N)
(default ,(defopt 'n))
(predicate ,string->number)
(transformer ,string->number)))
(R "recursively descend subdirectories")
(t ,(s+ "place gallery files in directory DIR "
"(will be created if it doesn't exist)")
(value (required DIR)))
(u "write captions under thumbnails on index page")
(U "write slide names under thumbnails on index page")
(x "omit the image count from the captions")
(y ,(s+ "scale all thumbnails to the same height "
"(default: " (number->string (defopt 'y)) ")")
(value (required N)
(predicate ,string->number)
(transformer ,string->number)
(default ,(defopt 'y))))
(ad "like -a, but write only the image dimensions")
(as "like -a, but write only the file size (in kbytes)")
(author ,(s+ "specify author name "
"(default: " (defopt 'author) ")")
(value (required AUTHOR)
(default ,(defopt 'author))))
(con "options to pass to convert"
(value (required OPTS)
(default "")))
(cd-dir ,(s+ "directory for CD image output "
"(default: " (defopt 'cd-dir) ")")
(value (required DIR)
(predicate ,directory?)
(default ,(defopt 'cd-dir))))
(cd-file ,(s+ "name of CD image file if --gcd is not specified "
"(default: " (defopt 'cd-file) ")")
(value (required FILE)
(default ,(defopt 'cd-file))))
(gcd "like -g, but also sets CD image file name"
(value (required TITLE)))
(hls "creates a highlights page")
(hls-main "creates a highlights page as the main page")
(html-ext ,(s+ "suffix of output HTML files "
"(default: " (defopt 'html-ext) ")")
(value (required SUFFIX)
(default ,(defopt 'html-ext))))
(html-index ,(s+ "name (without suffix) of the main thumbnail "
"index file (default: " (defopt 'html-index) ")")
(value (required NAME)
(default ,(defopt 'html-index))))
(html-hindex ,(s+ "name (without suffix) of the highlights "
"index file (default: " (defopt 'html-hindex) ")")
(value (required NAME)
(default ,(defopt 'html-hindex))))
(in "use image file names for the HTML slide files")
(sp ,(s+ "sets the slide image prefix "
"(default: " (defopt 'sp) ")")
(value (required PREFIX)
(default ,(defopt 'sp))))
(top "create index pages for directories that only contain subfolders")
(tp ,(s+ "sets the thumbnail image prefix "
"(default: " (defopt 'tp) ")")
(value (required PREFIX)
(default ,(defopt 'tp))))
(up "create Up links even in top-level image galleries")
(verbose ,(s+ "set verbose mode (0: quiet; 1: info; 2: debug)")
(value (required LEVEL)
(default 1)
(predicate ,string->number)
(transformer ,string->number)))
(www "makes all SIGMA files world-readable")
(xy "scale thumbnails to N pixels in their longer dimension"
(value (required N)
(predicate ,string->number)
(transformer ,string->number)))
(yslide "scale slides to the given maximum height"
(value (required N)
(predicate ,string->number)
(transformer ,string->number)))
(help (single-char #\h))
))
;; Use args:usage to generate a formatted list of options (from OPTS),
;; suitable for embedding into help text.
(define (sigma:usage)
(print "Usage: " (car (argv)) " [options...] commands ")
(newline)
(print "Where command can be one of the following: ")
(newline)
((lambda (lst)
(let ((print-line (lambda (x) (cat (space-to 5) (car x) (space-to 30) (cadr x)))))
(fmt #t (pad-char #\space (fmt-join print-line lst nl)))
(newline)))
`(("gallery" "Create an image gallery (default if no command given)")
("cdimage" "Create a CD image containing the image slides")
("thumbs" "Create image thumbnails (implicit when gallery is also given)")
("sort" "Sort images by EXIF date or file creation date")
("clean" "Clean generated files")
))
(newline)
(print "The following options are recognized: ")
(newline)
(print (parameterize ((indent 5)) (usage opt-grammar)))
(exit 1))
;; Process arguments and collate options and arguments into OPTIONS
;; alist, and operands (filenames) into OPERANDS. You can handle
;; options as they are processed, or afterwards.
(define opts (getopt-long (command-line-arguments) opt-grammar))
(define opt (make-option-dispatch opts opt-grammar))
(define v:quiet 0)
(define v:info 1)
(define v:debug 2)
(define (done . rest)
(let-optionals rest ((indicator "done!"))
(if (= (or (opt 'verbose) (defopt 'verbose)) v:info)
(begin
(display indicator)
(newline)))))
(define (progress . rest)
(let-optionals rest ((indicator "."))
(if (= (or (opt 'verbose) (defopt 'verbose)) v:info)
(display indicator))))
(define (message x . rest)
(if (positive? (or (opt 'verbose) (defopt 'verbose)))
(let loop ((port (open-output-string)) (objs (cons x rest)))
(if (null? objs)
(begin
(newline port)
(print-error-message (get-output-string port)
(current-output-port) "SIGMA"))
(begin (display (car objs) port)
(display " " port)
(loop port (cdr objs)))))))
(define (run:execute explist)
(define (smooth lst)
(let ((slst (map ->string lst)))
(string-intersperse (cons (car slst) (cdr slst)) " ")))
(for-each (lambda (cmd)
(if (>= (or (opt 'verbose) (defopt 'verbose)) 2)
(printf " ~A~%~!" cmd))
(system (->string cmd)))
(map smooth explist)))
(define (run:execute* explist)
(define (smooth lst)
(let ((slst (map ->string lst)))
(string-intersperse (cons (car slst) (cdr slst)) " ")))
(for-each (lambda (cmd)
(if (>= (or (opt 'verbose) (defopt 'verbose)) 2) (printf " ~A~%~!" cmd))
(system* "~a" cmd))
(map smooth explist)))
(define-syntax run
(syntax-rules ()
((_ exp ...)
(run:execute* (list `exp ...)))))
(define-syntax run-
(syntax-rules ()
((_ exp ...)
(run:execute (list `exp ...)))))
(define (ipipe:execute lam cmd)
(define (smooth lst)
(let ((slst (map ->string lst)))
(string-intersperse (cons (car slst) (cdr slst)) " ")))
((lambda (cmd)
(if (>= (or (opt 'verbose) (defopt 'verbose)) 2)
(printf " ~A~%~!" cmd))
(with-input-from-pipe (sprintf "~a" cmd) lam))
(smooth cmd)))
(define-syntax ipipe
(syntax-rules ()
((_ lam exp)
(ipipe:execute lam `exp ))))
(define nl (list->string (list #\newline)))
(define (generate-HTML Content)
(define (make-navbar head-parms)
(let ((links (lookup-def 'Links head-parms '())))
(and (pair? links)
`(div (@ (class "navbar"))
(ul . ,(map (lambda (x)
(match x ((name val)
`(li (a (@ (href ,val)) ,name))))) links))))))
(define (make-header head-parms)
`(head
,nl (title ,(lookup-def 'title head-parms))
,nl (meta (@ (http-equiv "Content-Type") (content "text/html; charset=UTF-8")))
,nl (meta (@ (http-equiv "Content-Style-Type") (content "text/css")))
,nl (meta (@ (http-equiv "Generator") (content "http://www.call-with-current-continuation.org/eggs/sigma.html")))
,nl ,(let ((style (lookup-def 'Style head-parms)))
(if style `(link (@ (rel "stylesheet") (type "text/css") (href ,style))) '()))
,nl
,(zip
(map
(lambda (key)
(let ((val (lookup-def key head-parms )))
(and val
`(meta (@ (name ,(symbol->string key)) (content ,val))))))
'(description Author keywords Date-yyyymmdd))
(circular-list nl))
,nl))
(define (make-footer head-parms)
`((div (@ (id "footer"))
(h3 "Created on "
,(let* ((date-revised (car (lookup-def 'Date-yyyymmdd head-parms)))
(year (string->number (string-copy date-revised 0 4)))
(month (string->number (string-copy date-revised 4 6)))
(day (string->number (string-copy date-revised 6 8)))
(month-name
(vector-ref
'#("January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November"
"December")
(- month 1))))
(list month-name " " day ", " year)))
,(let ((links (lookup-def 'Links head-parms '())))
(and (pair? links)
(let ((home (lookup-def 'home links)))
(and home
`(p "This site's top page is "
(a (@ (href ,home)) (strong ,home)))))))
(div (address ,(lookup-def 'Author head-parms)))
(p (font (@ (size "-2")) "Image gallery generated by SIGMA.")))))
(let*
;; Universal transformation rules. Work for every HTML,
;; present and future
((universal-conversion-rules
`((@
((*default* ;; local override for attributes
. ,(lambda (attr-key . value) (enattr attr-key value))))
. ,(lambda (trigger . value) (cons '@ value)))
(*default* .
,(let ((with-nl ;; Block-level HTML elements:
;; We insert a NL before them.
;; No NL is inserted before or after an
;; inline element.
'(br ;; BR is technically inline, but we
;; treat it as block
p div hr
h1 h2 h3 h3 h5 h6
dl ul ol li dt dd pre
table tr th td
center blockquote form
address body thead tfoot tbody col colgroup)))
(lambda (tag . elems)
(let ((nl? (and (memq tag with-nl) #\newline)))
(if (and (pair? elems) (pair? (car elems))
(eq? '@ (caar elems)))
(list nl? #\< tag (cdar elems) #\>
(and (pair? (cdr elems))
(list (cdr elems) " nl?)))
(list nl? #\< tag #\>
(and (pair? elems) (list elems " nl?))
))))))
(*text* . ,(lambda (trigger str)
(if (string? str) (string->goodHTML str) str)))
(n_ ;; a non-breaking space
. ,(lambda (tag . elems)
(list " " elems)))))
;; Transformation rules to drop out everything but the
;; 'Header' node
(search-Header-rules
`((Header *preorder*
. ,(lambda (tag . elems) (cons tag elems)))
(*default*
. ,(lambda (attr-key . elems)
(let loop ((elems elems))
(cond
((null? elems) '())
((not (pair? (car elems))) (loop (cdr elems)))
((eq? 'Header (caar elems)) (car elems))
(else (loop (cdr elems)))))))
(*text* . ,(lambda (trigger str) '()))))
)
(let ((header-parms (lookup-def 'Header (list (post-order Content search-Header-rules)))))
(SRV:send-reply
(pre-post-order Content
`(
,@universal-conversion-rules
(html:begin
. ,(lambda (tag . elems)
(let ((embedded? (lookup-def 'Embedded header-parms)))
(if embedded? elems
(list
"" nl
"" nl
elems
"" nl)))))
(Header
*macro*
. ,(lambda (tag . headers)
(let ((embedded? (lookup-def 'Embedded header-parms)))
(if embedded? (list) (make-header headers)))))
(navbar ; Find the Header in the Content
. ,(lambda (tag) ; and create the navigation bar
(let ((header-parms
(lookup-def 'Header
(list (post-order Content
search-Header-rules))
)))
(post-order (make-navbar header-parms)
universal-conversion-rules))))
(body
. ,(lambda (tag . elems)
(list "" nl elems "")))
(footer ;; Find the Header in the Content
. ,(lambda (tag) ;; and create the footer of the page
(post-order (make-footer header-parms)
universal-conversion-rules)))
(gallery-title *macro* ;; Find the Header in the Content
. ,(lambda (tag) ;; and create the page title rule
`(div (@ (id "header"))
(h1 ,(lookup-def 'Gallery-Title header-parms)))))
(slide-title *macro* ;; Find the Header in the Content
. ,(lambda (tag) ;; and create the page title rule
`(div (@ (id "header"))
(h1 ,(lookup-def 'Slide-Title header-parms)))))
(slide-caption *macro*
. ,(lambda (tag)
`(p ,(lookup-def 'Slide-Caption header-parms))))
(slide-url *macro*
. ,(lambda (tag)
(lookup-def 'Slide-URL header-parms)))
(image-url *macro*
. ,(lambda (tag)
(lookup-def 'Image-URL header-parms)))
(image-thumbs *macro*
. ,(lambda (tag . alist)
(let ((thumbs (lookup-def 'Thumbs header-parms)))
(or (and thumbs `(div (@ . ,alist) ,thumbs))
(list)))))
(gallery-subfolders *macro*
. ,(lambda (tag . alist)
(let ((subfolders (lookup-def 'Subfolders header-parms)))
(or (and subfolders
`(div (@ . ,alist) (h1 "Subfolders") ,subfolders))
(list)))))
(url *macro* . ,(lambda (tag href . contents)
`(a (@ (href ,href))
,(if (pair? contents)
contents
href))))
(Section ;; (Section level "content ...")
*macro*
. ,(lambda (tag level head-word . elems)
`((br) (n_) (a (@ (name ,head-word)) (n_))
(,(string->symbol (s+ "h" (number->string level)))
,head-word ,elems))))
(Section* ;; (Section* level "content ...")
*macro*
. ,(lambda (tag level head-word . elems)
`((br) (n_) (a (@ (name ,head-word)) (n_))
(,(string->symbol (s+ "h" (number->string level)))
,head-word ,elems))))
(TOC ;; Re-scan the Content for "Section" tags and generate
. ,(lambda (tag) ;; the Table of contents
(let ((sections
(pre-post-order Content
`((Section ;; (Section level "content ...")
((*text* . ,(lambda (tag str) str)))
. ,(lambda (tag level head-word . elems)
(list "" head-word elems "" nl )))
(*default*
. ,(lambda (tag . elems) elems))
(*text* . ,(lambda (trigger str) (list)))))))
;(write sections ##stderr)
(list "" nl))))
))))))
;; remove the automatically generated files from the target directory
(define (clean-targetdir path)
(let ((pat (s+ path dirsep "*.html")))
(run (rm -f ,pat))))
;; load up list of image files from the given directory
(define (read-imagedir path . rest)
(let-optionals rest ((sort-order 'l))
(let ((jpgpat "(.*\\.[jJ][pP][eE]?[gG]$)")
(pngpat "(.*\\.[pP][nN][gG]$)")
(gifpat "(.*\\.[gG][iI][fF]$)")
(thumbpat (regexp-escape thumbprefix))
(slidepat (regexp-escape slideprefix)))
(let ((pat (s+ jpgpat "|" pngpat "|" gifpat))
(expat (regexp (s+ ".*((" thumbpat ")|(" slidepat ")).*"))))
(let ((flst (find-files path (regexp pat)
(lambda (x ax) (if (string-match expat x) ax
(cons (pathname-strip-directory x) ax)))
(list) 0)))
(sort flst stringstring (seconds->local-time (current-seconds)))
".")
(print "; The captions must be in S-expression format and may include SXML tags. ")
(print "; ")
(print "; Each caption entry can be in one of two forms: ")
(print "; ")
(print "; 1. (fname caption [option1 option2 ...]) ")
(print "; The first element is the image file name, and the second element is the caption. ")
(print "; The file name and the caption are required. They can be followed by any number of ")
(print "; options keywords. The only option keyword currently recognized is hl, which ")
(print "; indicates that the slide should be included on the optional highlights page. ")
(print "; ")
(print "; 2. (subdir name caption) ")
(print "; Entries of this form be used to specify captions for subfolders. ")
(print "; ")
(print "; To add any comments to this file or to exclude any images from the slide ")
(print "; show, add a ; sign at the beginning of their respective lines. ")
(print "; You may also change the order of images in your slide show at this time.")
(let loop ((flst flst))
(if (not (null? flst))
(begin
(write (list (car flst) (if fname-as-caption? (car flst) "")))
(print)
(loop (cdr flst)))))
(if subdirs
(let loop ((subdirs subdirs))
(if (not (null? subdirs))
(let ((subdir (car subdirs)))
(write (list 'subdir (first subdir) (second subdir)
(if fname-as-caption? (first subdir) "")))
(print)
(loop (cdr subdirs))))))))
(message "Now edit the " captionpath " file to your liking and rerun sigma -c.")
(values #f #f))))))
;; read EXIF image date or inode change time for the file
(define (image-date path)
(let ((date (ipipe read-line (exif ,(fpesc path) |\|| grep Date |\|| grep orig |\|| cut -f2 -d |\\\||))))
(if (or (eof-object? date) (string-null? date))
(let* ((s (file-change-time path))
(ti (seconds->local-time s)))
(s+ (number->string (+ 1900 (vector-ref ti 5))) ":"
(number->string (+ 1 (vector-ref ti 4))) ":"
(number->string (vector-ref ti 3)) " "
(number->string (vector-ref ti 2)) ":"
(number->string (vector-ref ti 1)) ":"
(number->string (vector-ref ti 0))))
(let loop ((str date))
(let ((str1 (string-chomp str " ")))
(if (string=? str str1) str
(loop str1)))))))
;; return x dim, y dim, rounded kb for image
(define (image-size path)
(let ((kb (vector-ref (file-stat path) 5)))
(let ((dim (ipipe (lambda () (let ((line (read-line)))
((lambda (geom)
(and (list? geom) (not (null? geom))
(map string->number (string-split (car geom) "x"))))
(string-split line "+"))))
(identify -ping -verbose ,(fpesc path) |\|| grep "Geometry:" |\|| cut -d":" -f2 ))))
(list (car dim) (cadr dim) kb))))
;; determine image file sizes
(define (read-image-sizes image-dir flst)
(message "Determining image sizes: ")
(let loop ((flst flst) (sz (list)))
(if (null? flst)
(begin
(done)
(reverse sz))
(let ((path (s+ image-dir dirsep (car flst))))
(let ((dims (image-size path)))
(progress)
(loop (cdr flst) (cons dims sz)))))))
(define (sort-images image-dir target-dir flst)
(let ((order (inexact->exact (ceiling (log10 (length flst))))))
(message "Reading image dates: ")
(let ((olst
(let loop ((flst flst) (olst (list)))
(if (null? flst) olst
(let ((path (s+ image-dir dirsep (car flst))))
(if (not (and (file-exists? path) (file-read-access? path)))
(sigma:error 'sort-images ": cannot open " path))
(let ((date (image-date path)))
(progress)
(loop (cdr flst) (merge (list (cons (car flst) date)) olst
(lambda (x y) (string<=? (cdr x) (cdr y)))))))))))
(done)
(message "Sorting images by date: ")
(let* ((op (if (string=? image-dir target-dir) 'mv 'cp))
(temp-dir-name (s+ image-dir dirsep "sigma-tmp.XXXXXX"))
(temp-dir (mkdtemp temp-dir-name)))
(if (not temp-dir)
(sigma:error 'sort-image ": unable to create temporary directory " temp-dir-name))
(for-each (lambda (f)
(let ((fpath (s+ image-dir dirsep f))
(rpath (s+ temp-dir dirsep f)))
(run (,op ,(fpesc fpath) ,(fpesc rpath)))
(progress)))
flst)
(let ((i+nlst (fold (lambda (fp i+nlst)
(let ((fpath (s+ temp-dir dirsep (car fp)))
(ext (pathname-extension (car fp))))
(match i+nlst
((i . nlst)
(let* ((width (if (positive? order) order 1))
(nfile (s+ (fmt #f (pad-char #\0 (fit/left width i))) "." ext))
(npath (s+ target-dir dirsep nfile)))
(run (mv ,(fpesc fpath) ,(fpesc npath)))
(progress)
(cons (+ 1 i) (cons nfile nlst)))))))
(cons 0 (list)) olst)))
(run (rm -rf ,temp-dir))
(done)
(reverse (cdr i+nlst)))))))
(define (make-thumbs image-dir target-dir flst y . rest)
(let-optionals rest ((xy #f) (force-regen? #f) (convert-options ""))
(message "Creating thumbnails: ")
(let ((source-dir (if (string=? image-dir target-dir) image-dir target-dir)))
(let loop ((flst flst))
(if (not (null? flst))
(let ((image-path (s+ source-dir dirsep (car flst))))
(if (not (and (file-exists? image-path) (file-read-access? image-path)))
(sigma:error 'make-thumbs ": cannot open " image-path))
(let ((thumb-path (s+ target-dir dirsep thumbprefix (car flst))))
(if (or (not (file-exists? thumb-path)) force-regen?
(> (vector-ref (file-stat image-path) 9)
(vector-ref (file-stat thumb-path) 9)))
(run (convert ,convert-options -scale
,(if xy (let ((xy (number->string xy)))
(s+ xy "x" xy))
(s+ "x" (number->string y)))
,(fpesc image-path) ,(fpesc thumb-path))))
(progress)
(loop (cdr flst))))))
(done))))
;; copy images to target-dir, if necessary
(define (copy-images image-dir target-dir flst)
(if (not (string=? image-dir target-dir))
(begin
(message "Copying images to target directory: ")
(let loop ((flst flst))
(if (not (null? flst))
(let ((image-path (s+ image-dir dirsep (car flst)))
(target-path (s+ target-dir dirsep (car flst))))
(if (not (and (file-exists? image-path) (file-read-access? image-path)))
(sigma:error 'copy-images ": cannot open " image-path))
(if (not (file-exists? target-path))
(run (cp -f ,(fpesc image-path) ,(fpesc target-path))))
(progress)
(loop (cdr flst)))
(done))))))
;; scale down images if the --yslide option was given
(define (scale-images image-dir target-dir flst yslide . rest)
(let-optionals rest ((force-regen? #f) (convert-options ""))
(let ((source-dir (if (string=? image-dir target-dir) image-dir target-dir)))
(message "Scaling down big slides: ")
(let loop ((flst flst))
(if (not (null? flst))
(let ((image-path (s+ source-dir dirsep (car flst))))
(if (not (and (file-exists? image-path) (file-read-access? image-path)))
(sigma:error 'scale-images ": cannot open " image-path))
(let ((slide-path (s+ target-dir dirsep slideprefix (car flst))))
(if (or (not (file-exists? slide-path)) force-regen?)
(let ((y (cadr (image-size image-path))))
(if (and (positive? yslide) (> y yslide)) ;; only scale down, never up.
(run (convert ,convert-options
-scale ,(s+ "x" (number->string yslide))
,(fpesc image-path) ,(fpesc slide-path)))
(run (ln ,(fpesc image-path) ,(fpesc slide-path))))))
(progress)
(loop (cdr flst))))))
(done))))
(define (filter-subfolders target-dir target-dir-depth lst)
(filter-map (lambda (d)
(let ((thumbpat (regexp (s+ (regexp-escape thumbprefix) ".*")))
(absolute? (string=? dirsep (car d))))
;; only allow subfolders that contain thumbnails
(let* ((dd (drop (if absolute? (cdr d) d) target-dir-depth))
(subflst (directory (string-intersperse (cons target-dir dd) dirsep) #t))
(subthumbs (filter (lambda (x) (string-match thumbpat x)) subflst)))
(and (pair? subthumbs)
(list (string-intersperse dd dirsep) (car subthumbs))))))
lst))
;; create the individual slide show files
(define (make-slides image-dir target-dir slidetmpl index
gallery-title flst captions slst
caption-as-title? omit-image-count? yslide author)
(message "Creating individual slides: ")
(let loop ((lst (zip flst captions slst)) (prev index) (counter 0))
(if (not (null? lst))
(match (car lst)
((imagename caption slidename)
(let ((title (let ((title (if caption-as-title?
;; use image caption for the HTML slide title
caption
;; otherwise use the image name with stripped suffix
(pathname-strip-extension imagename))))
(if omit-image-count? title
(list title " (" (number->string counter) ")"))))
(slide-url (uri-encode-string
(if yslide
(s+ slideprefix imagename)
imagename)))
(image-url (uri-encode-string imagename))
(date (let ((v (seconds->local-time (current-seconds)))
(num->str (lambda (i w) (fmt #f (pad-char #\0 (fit/left w i))))))
(let ((year (num->str (+ 1900 (vector-ref v 5)) 4))
(month (num->str (+ 1 (vector-ref v 4)) 2))
(day (num->str (vector-ref v 3) 2)))
(s+ year month day))))
(links `((contents ,index)
(prev ,prev)
(next ,(if (null? (cdr lst)) "" (third (cadr lst)))))))
(with-output-to-file (s+ target-dir dirsep slidename)
(lambda ()
(let* ((header `(Header (Date-yyyymmdd ,date)
(Style ,css-tmpl-file)
(Gallery-Title ,gallery-title)
(Slide-Title ,title)
(Slide-Caption ,caption)
(Slide-URL ,slide-url)
(Image-URL ,image-url)
(Author ,author)
(Links . ,links)))
(content
(pre-post-order
slidetmpl
`((html:begin . ,(lambda (tag . elems)
(if (not (lookup-def 'Header elems))
`(html:begin . ,(cons header elems))
`(html:begin . ,elems))))
(Header . ,(lambda (tag . elems)
(if (null? elems) header
`(Header . ,(append (cdr header) elems)))))
(*default* . ,(lambda (tag . elems) `(,tag . ,elems)))))))
(generate-HTML content))))
(progress)
(loop (cdr lst) slidename (+ 1 counter)))))))
(done))
;; create the index files with all the thumbnails and optional subgalleries
(define (make-index target-dir index-tmpl-file flst slst captions szlst
nfiles max-thumbs html-index html-ext gallery-title author
subfolders . rest)
(let-optionals rest ((up #f) (mlinks (list)))
(let ((index-tmpl-path (s+ target-dir dirsep index-tmpl-file))
(npages (inexact->exact (ceiling (/ nfiles max-thumbs)))))
(let ((indextmpl (with-input-from-file index-tmpl-path read)))
(let loop ((i 0) (flst flst) (slst slst) (captions captions) (szlst szlst))
(if (not (null? flst))
(let ((nthumbs (min (length flst) max-thumbs))
(index-path (s+ target-dir dirsep html-index
(if (positive? i) (number->string i) "")
"." html-ext)))
(message "Creating " index-path " file: ")
(let ((date (let ((v (seconds->local-time (current-seconds)))
(num->str (lambda (i w) (fmt #f (pad-char #\0 (fit/left w i))))))
(let ((year (num->str (+ 1900 (vector-ref v 5)) 4))
(month (num->str (+ 1 (vector-ref v 4)) 2))
(day (num->str (vector-ref v 3) 2)))
(s+ year month day))))
(image-thumbs
(map (lambda (fname sname caption sz)
(let ((thumbname (s+ thumbprefix fname)))
`(div (@ (class "thumb"))
(a (@ (href ,(uri-encode-string sname)))
(img (@ (src ,(uri-encode-string thumbname)))) ,nl)
(div (@ (class "thumb-caption"))
,(cond ((opt 'u) `(p (@ (size "-2")) ,caption))
((opt 'U) `(p (@ (size "-2")) ,sname))
(else ""))
,(cond ((opt 'a) `(p (@ (size "-2"))
,(first sz) "x" ,(second sz) (br)
"(" ,(quotient (third sz) 1024) " KB" ")"))
((opt 'ad) `(p (@ (size "-2")) ,(first sz) "x" ,(second sz)))
((opt 'as) `(p (@ (size "-2")) ,(quotient (third sz) 1024) " KB"))
(else ""))))))
(take flst nthumbs) (take slst nthumbs) (take captions nthumbs)
(take szlst nthumbs)))
(links (append
(if up (let ((up-link (if (boolean? up)
(s+ ".." dirsep html-index "." html-ext)
up)))
(list (list "Up" up-link)))
(list))
mlinks
(if (> npages 1)
(list-tabulate
npages (lambda (i) (list (string->symbol (number->string i))
(s+ html-index (if (positive? i) (number->string i) "")
"." html-ext))))
(list))))
(subfolders (map (lambda (sub)
(let ((index-path (s+ (first sub) dirsep html-index "." html-ext))
(thumb-path (s+ (first sub) dirsep (uri-encode-string (second sub))))
(caption (if (string-null? (third sub)) (first sub) (third sub))))
`(div (@ (class "thumb"))
(a (@ (href ,index-path))
(img (@ (src ,thumb-path))) ,nl)
(div (@ (class "thumb-caption"))
(p ,caption)))))
subfolders)))
(with-output-to-file index-path
(lambda ()
(let* ((header `(Header (Date-yyyymmdd ,date)
(Style ,css-tmpl-file)
(Gallery-Title ,gallery-title)
(Thumbs ,image-thumbs)
(Author ,author)
(Links . ,links)
,@(if (null? subfolders) `()
`((Subfolders . ,subfolders)))))
(content
(pre-post-order
indextmpl
`((html:begin . ,(lambda (tag . elems)
(if (not (lookup-def 'Header elems))
`(html:begin . ,(cons header elems))
`(html:begin . ,elems))))
(Header . ,(lambda (tag . elems)
(if (null? elems) header
`(Header ,(append (cdr header) elems)))))
(*default* . ,(lambda (tag . elems) `(,tag . ,elems)))))))
(generate-HTML content))))
(done)
(loop (+ 1 i) (drop flst nthumbs) (drop slst nthumbs) (drop captions nthumbs)
(drop szlst nthumbs))))))))))
;; create an index file that only contains subgalleries
(define (make-toplevel-index target-dir index-tmpl-file html-index html-ext gallery-title author
subfolders . rest)
(let-optionals rest ((up #f) (home #f))
(let ((index-tmpl-path (s+ target-dir dirsep index-tmpl-file)))
(let ((indextmpl (with-input-from-file index-tmpl-path read)))
(let ((index-path (s+ target-dir dirsep html-index "." html-ext)))
(message "Creating " index-path " file: ")
(let ((date (let ((v (seconds->local-time (current-seconds)))
(num->str (lambda (i w) (fmt #f (pad-char #\0 (fit/left w i))))))
(let ((year (num->str (+ 1900 (vector-ref v 5)) 4))
(month (num->str (+ 1 (vector-ref v 4)) 2))
(day (num->str (vector-ref v 3) 2)))
(s+ year month day))))
(links (append
(if up (let ((up-link (if (boolean? up)
(s+ ".." dirsep html-index "." html-ext)
up)))
(list (list "Up" up-link)))
(list))
(if home (list (list "Home" home)) (list))))
(subfolders (map (lambda (sub)
(let ((index-path (s+ (first sub) dirsep html-index "." html-ext))
(thumb-path (s+ (first sub) dirsep (uri-encode-string (second sub))))
(caption (if (string-null? (third sub)) (first sub) (third sub))))
`(div (@ (class "thumb"))
(a (@ (href ,index-path))
(img (@ (src ,thumb-path))) ,nl)
(div (@ (class "thumb-caption"))
(p ,caption)))))
subfolders)))
(with-output-to-file index-path
(lambda ()
(let* ((header `(Header (Date-yyyymmdd ,date)
(Style ,css-tmpl-file)
(Gallery-Title ,gallery-title)
(Author ,author)
(Links . ,links)
,@(if (null? subfolders) `()
`((Subfolders . ,subfolders)))))
(content
(pre-post-order
indextmpl
`((html:begin . ,(lambda (tag . elems)
(if (not (lookup-def 'Header elems))
`(html:begin . ,(cons header elems))
`(html:begin . ,elems))))
(Header . ,(lambda (tag . elems)
(if (null? elems) header
`(Header ,(append (cdr header) elems)))))
(*default* . ,(lambda (tag . elems) `(,tag . ,elems)))))))
(generate-HTML content))))
(done)))))))
(define (main-make-gallery SIGMA-DIR index image-dir target-dir commands . rest)
(let-optionals rest ((subdirs (list)) (up #f) (toplevel? #f) (slide-dir #f))
(message "entering directory: " image-dir)
(if (commands 'clean?)
(let* ((pat (s+ ".*/(" thumbprefix ".*|" slideprefix ".*|" css-tmpl-file "|"
index-tmpl-file "|" slide-tmpl-file "|.*\\.html|" caption-file ")"))
(flst (find-files target-dir (regexp pat)
(lambda (x ax) (delete-file x) (cons x ax)) (list) 0)))
(message "deleted files: " flst)))
(let ((flst (read-imagedir image-dir)))
;; make sure there are some image files or subdirectories in the given directory
(if (and (null? flst) (null? subdirs))
(sigma:error "cannot find any image files or subdirectories in directory " image-dir))
;; make sure target dir exists
(if (not (file-exists? target-dir))
(create-directory target-dir))
(let ((captionpath (s+ target-dir dirsep caption-file))
(target-dir-depth (length (string-split target-dir dirsep))))
(let ((subfolders (filter-subfolders target-dir target-dir-depth subdirs))
;; count the image files and sort them if requested by the user
(flst (if (and (commands 'sort?) (pair? flst))
(sort-images image-dir target-dir flst) flst)))
;; read in files specified in the .captions file
(let-values (((flst+captions subfolders)
(if (or (opt 'c) (opt 'C))
(read-or-create-captions captionpath flst subfolders (opt 'C))
(values (map (lambda (x) (if (list? x) (append x (list "")) (list x ""))) flst)
(map (lambda (x) (if (list? x) (append x (list "")) (list x ""))) subfolders)))))
(let ((nfiles (or (and flst+captions (length flst)) 0)))
(message "Found " nfiles " image files in directory: " image-dir)
(cond ((and (zero? nfiles) toplevel? subfolders)
;; Create a top-level index file that only contains links to subgalleries
(begin
(message "creating top-level index file...")
;; locate and copy the index template file, if necessary
(locate-and-copy-template SIGMA-DIR target-dir index-tmpl-file)
;; locate and copy the CSS file, if necessary
(locate-and-copy-template SIGMA-DIR target-dir css-tmpl-file)
;; create the index files with all the thumbnails
(make-toplevel-index
target-dir index-tmpl-file
(or (opt 'html-index) (defopt 'html-index))
(or (opt 'html-ext) (defopt 'html-ext))
(or (opt 'gcd) (opt 'g) (defopt 'g))
(or (opt 'author) (defopt 'author))
subfolders up)
(done)))
(flst+captions
(begin
(if (commands 'gallery?)
(if (< nfiles 1)
(sigma:error " please select more files for your gallery!")))
(if flst+captions
(let-values (((flst captions) (unzip2 flst+captions))
((hflst hcaptions) (unzip2 (filter (lambda (x) (member 'hl x)) flst+captions))))
;; copy images to target dir, if necessary
(if (not (commands 'sort?)) (copy-images image-dir target-dir flst))
;; generate thumbnails
(if (commands 'thumbs?)
(make-thumbs image-dir target-dir flst (or (opt 'y) (defopt 'y))
(opt 'xy) (opt 'f) (or (opt 'con) (defopt 'con))))
;; if slide-dir is true (e.g. when making a CD image),
;; copy the slides to slide-dir
(if slide-dir
(let ((snum (length (directory slide-dir))))
(message "Copying slide images to CD image dir (" slide-dir "): ")
(fold (lambda (f i)
(let ((ext (pathname-extension f))
(is (fmt #f (pad-char #\0 (fit/left 5 i)))))
(let ((fpath (s+ target-dir dirsep
(if (opt 'yslide) (s+ slideprefix f) f)))
(rpath (s+ slide-dir dirsep is "." ext )))
(run (cp ,(fpesc fpath) ,(fpesc rpath)))
(progress)
(+ 1 i))))
snum flst)
(done)))
(if (commands 'gallery?)
(begin
;; scale down images
(if (opt 'yslide)
(scale-images image-dir target-dir flst (opt 'yslide) (opt 'f)
(or (opt 'con) (defopt 'con))))
(let ((szlst (read-image-sizes target-dir flst))
(hszlst (and (or (opt 'hls) (opt 'hls-main))
(read-image-sizes target-dir hflst)))
(slst (if (opt 'in) ;; use image file names for slide html file names
(map (lambda (n) (pathname-replace-extension n (or (opt 'html-ext) (defopt 'html-ext))))
flst)
(map (lambda (n) (s+ n "." (or (opt 'html-ext) (defopt 'html-ext))))
(list-tabulate nfiles number->string))))
(hslst (if (opt 'in)
(map (lambda (n) (s+ "hl" (pathname-replace-extension n (or (opt 'html-ext) (defopt 'html-ext)))))
hflst)
(map (lambda (n) (s+ "hl" n "." (or (opt 'html-ext) (defopt 'html-ext))))
(list-tabulate (length hflst) number->string)))))
(clean-targetdir target-dir)
;; locate and copy the slide template file, if necessary
(locate-and-copy-template SIGMA-DIR target-dir slide-tmpl-file)
(let ((slide-tmpl-path (s+ target-dir dirsep slide-tmpl-file)))
(let ((slidetmpl (with-input-from-file slide-tmpl-path read))
(hindex (s+ (or (opt 'html-hindex) (defopt 'html-hindex)) "."
(or (opt 'html-ext) (defopt 'html-ext))))
(htitle (list "Highlights of " '(br) (or (opt 'gcd) (opt 'g) (defopt 'g)))))
;; create the individual slide show files
(make-slides image-dir target-dir slidetmpl
(if (and (opt 'hls-main) (not (null? hflst))) hindex index)
(or (opt 'gcd) (opt 'g) (defopt 'g)) flst captions slst
(opt 'k) (opt 'x) (opt 'yslide)
(or (opt 'author) (defopt 'author)))
(if (and (or (opt 'hls) (opt 'hls-main)) (not (null? hflst)))
;; create the slide show files for the highlight images
(make-slides image-dir target-dir slidetmpl
(if (opt 'hls-main) index hindex)
htitle hflst hcaptions hslst
(opt 'k) (opt 'x) (opt 'yslide)
(or (opt 'author) (defopt 'author))))
;; locate and copy the index template file, if necessary
(locate-and-copy-template SIGMA-DIR target-dir index-tmpl-file)
;; locate and copy the CSS file, if necessary
(locate-and-copy-template SIGMA-DIR target-dir css-tmpl-file)
(cond ((and (opt 'hls-main) (not (null? hflst)))
(let ((up-url (s+ ".." dirsep (or (opt 'html-index) (defopt 'html-index))
"." (or (opt 'html-ext) (defopt 'html-ext)))))
;; create the index files with all the thumbnails
(make-index target-dir index-tmpl-file flst slst captions szlst
nfiles (or (opt 'n) (defopt 'n))
(or (opt 'html-hindex) (defopt 'html-hindex))
(or (opt 'html-ext) (defopt 'html-ext))
(or (opt 'gcd) (opt 'g) (defopt 'g))
(or (opt 'author) (defopt 'author))
subfolders (and up up-url)
`(("Highlights"
,(s+ (or (opt 'html-index) (defopt 'html-index)) "."
(or (opt 'html-ext) (defopt 'html-ext))))))
(make-index target-dir index-tmpl-file hflst hslst hcaptions hszlst
(length hflst) (or (opt 'n) (defopt 'n))
(or (opt 'html-index) (defopt 'html-index))
(or (opt 'html-ext) (defopt 'html-ext))
htitle (or (opt 'author) (defopt 'author))
subfolders (and up up-url)
`(("All images"
,(s+ (or (opt 'html-hindex) (defopt 'html-hindex))
"."
(or (opt 'html-ext) (defopt 'html-ext))))))))
((and (or (opt 'hls) (opt 'hls-main)) (not (null? hflst)))
(let ((up-url (s+ ".." dirsep
(or (opt 'html-index) (defopt 'html-index)) "."
(or (opt 'html-ext) (defopt 'html-ext)))))
;; create the index files with all the thumbnails
(make-index target-dir index-tmpl-file flst slst captions szlst
nfiles (or (opt 'n) (defopt 'n))
(or (opt 'html-hindex) (defopt 'html-hindex))
(or (opt 'html-ext) (defopt 'html-ext))
(or (opt 'gcd) (opt 'g) (defopt 'g))
(or (opt 'author) (defopt 'author))
subfolders (and up up-url)
`(("Highlights"
,(s+ (or (opt 'html-hindex) (defopt 'html-hindex)) "."
(or (opt 'html-ext) (opt 'html-ext))))))
(make-index target-dir index-tmpl-file hflst hslst hcaptions hszlst
(length hflst) (or (opt 'n) (defopt 'n))
(or (opt 'html-index) (defopt 'html-index))
(or (opt 'html-ext) (defopt 'html-ext))
htitle (or (opt 'author) (defopt 'author))
subfolders (and up up-url)
`(("All images"
,(s+ (or (opt 'html-index) (defopt 'html-index)) "."
(or (opt 'html-ext) (defopt 'html-ext))))))))
(else
(make-index target-dir index-tmpl-file flst slst captions szlst
nfiles (or (opt 'n) (defopt 'n))
(or (opt 'html-index) (defopt 'html-index))
(or (opt 'html-ext) (defopt 'html-ext))
(or (opt 'gcd) (opt 'g) (defopt 'g))
(or (opt 'author) (defopt 'author))
subfolders up )))
;; if --www was invoked make all images world-readable at the end
(if (opt 'www)
(begin
(message "Making all gallery files world-readable for WWW publishing...")
(run (chmod a+r ,(s+ (fpesc target-dir) dirsep css-tmpl-file)))
(run (chmod a+r ,(s+ (fpesc target-dir) dirsep "*." (or (opt 'html-ext) (defopt 'html-ext)))))
(run- (chmod a+r ,(s+ (fpesc target-dir) dirsep thumbprefix "*.*")))
(run- (chmod a+r ,(s+ (fpesc target-dir) dirsep slideprefix "*.*")))
(for-each (lambda (x) (run (chmod a+r ,(fpesc target-dir x)))) flst)
(done))))))))))))))))))))
(define (blocks->MB blocks) (quotient (* 2 blocks) 1024))
(define-constant *blocks-in-700MB* 359846)
(define-constant *blocks-in-650MB* 332800)
(define (estimate-filesystem-size dirs)
(let* ((blocks (ipipe (lambda () (let ((line (read-line))) (string->number line)))
(mkisofs -r -print-size -quiet ,@dirs)))
(size-MB (blocks->MB blocks)))
(if (zero? size-MB)
(message "CD image size is estimated to be " (* 2 blocks) " KB. " )
(message "CD image size is estimated to be " size-MB " MB. " ))
(if (<= size-MB *blocks-in-650MB*)
(let ((remaining (- *blocks-in-650MB* size-MB)))
(message "it will fit in a 650 MB (70 min) disk, leaving "
(blocks->MB remaining)
" MB (" remaining " blocks) unused. ")
'cd650)
(let ((remaining (- *blocks-in-700MB* size-MB))
(excess (- size-MB *blocks-in-650MB*)))
(cond ((> size-MB *blocks-in-700MB*)
(message "it will not fit in a 700 MB (80 min) disk, for "
(blocks->MB (abs remaining))
" MB (" (abs remaining) " blocks) too much. ")
#f)
(else
(begin
(message "it will not fit in a 650 MB (70 min) disk for "
(blocks->MB excess)
" MB (" excess " blocks), ")
(message "but it will fit in a 700 MB (80 min) disk leaving "
(blocks->MB remaining)
" MB (" remaining " blocks) unused. ")
'cd700)))))))
;; Make up a reasonable volume title from the directory names
(define (make-up-volume-title dirs)
(string-intersperse (map (lambda (d) (pathname-file d)) dirs) " "))
(define (create-iso-image dirs . rest)
(if (estimate-filesystem-size dirs)
(let-optionals rest
((title (make-up-volume-title dirs))
(output-path (s+ (or (opt 'cd-dir) (defopt 'cd-dir))
dirsep (or (opt 'gcd) (opt 'cd-file) (defopt 'cd-file))
".iso"))
(preparer (or (opt 'author) (defopt 'author)))
(publisher (or (opt 'author) (defopt 'author))))
(run (mkisofs -r -V ,(s+ "\"" title "\"") -p ,(s+ "\"" preparer "\"")
-P ,(s+ "\"" publisher "\"") -o ,(fpesc output-path) ,@dirs))
output-path)))
(define valid-commands '(clean sort thumbs gallery cdimage))
(define (make-command-selector commands)
(let ((clean? (member 'clean commands))
(sort? (member 'sort commands))
(thumbs? (or (member 'gallery commands) (member 'thumbs commands)))
(gallery? (member 'gallery commands))
(cdimage? (member 'cdimage commands)))
(and (or clean? sort? thumbs? gallery? cdimage?)
(lambda (selector)
(case selector
((cdimage?) cdimage?)
((clean?) clean?)
((sort?) sort?)
((thumbs?) thumbs?)
((gallery?) gallery?))))))
(define (main options operands)
(let* (;; Determine what commands were given to the program, if
;; any
(commands (make-command-selector
(filter-map (lambda (x) (let ((s (string->symbol x)))
(and (member s valid-commands) s)))
operands)))
(commands (or commands (make-command-selector '(gallery))))
;; Strip any unnecessary slashes from the end of the given
;; -d and -t directories
(image-dir (let loop ((opt_d (string-chomp (or (opt 'd) (defopt 'd)) dirsep)))
(let ((opt_d1 (string-chomp opt_d dirsep)))
(if (string=? opt_d1 opt_d) opt_d
(loop opt_d1)))))
(target-dir (or (and (opt 't)
(let loop ((opt_t (string-chomp (opt 't) dirsep)))
(let ((opt_t1 (string-chomp opt_t dirsep)))
(if (string=? opt_t1 opt_t) opt_t
(loop opt_t)))))
image-dir)))
(if (opt 'help) (sigma:usage))
;; sanity checks
(if (and (opt 'g) (opt 'gcd))
(sigma:error "please specify only one of the -g and --gcd options"))
(if (and (opt 'y) (opt 'xy))
(sigma:error "please specify only one of the -y and --xy options"))
(if (or (and (opt 'y) (negative? (opt 'y)))
(and (opt 'xy) (negative? (opt 'xy))))
(sigma:error "please enter non-negative thumbnail dimensions" ))
(if (and (opt 'yslide) (negative? (opt 'yslide)))
(sigma:error "please enter non-negative maximum slide height" ))
(let (;; construct the name of the main index file
(index (s+ (or (opt 'html-index) (defopt 'html-index)) "."
(or (opt 'html-ext) (defopt 'html-ext))))
;; let users store their templates in a $HOME/.sigma directory, if it exists,
;; instead of the site-wide /usr/share/sigma
(SIGMA-DIR (if (directory? local-sigma-dir) local-sigma-dir SIGMA-DIR))
;; makes a directory to store slides for a CD image
(slide-dir (and (commands 'cdimage?)
(let* ((temp-dir-name (s+ image-dir dirsep ".sigma-cdimage.XXXXXX"))
(temp-dir (mkdtemp temp-dir-name )))
(if (not temp-dir)
(sigma:error 'main ": unable to create temporary directory " temp-dir-name))
temp-dir))))
(if (opt 'R)
(let* ((image-dir-depth (length (string-split image-dir dirsep)))
(make-gallery
(lambda (lev d . rest)
(let-optionals
rest ((subdirs (list)))
(let* ((absolute? (string=? dirsep (car d)))
(image-dir (if absolute?
(s+ (car d) (string-intersperse (cdr d) dirsep))
(string-intersperse d dirsep)))
(target-dir (string-intersperse
(cons target-dir (drop (if absolute? (cdr d) d) image-dir-depth))
dirsep)))
(main-make-gallery SIGMA-DIR index image-dir target-dir commands
subdirs (or (positive? lev) (opt 'up)) (opt 'top)
slide-dir))))))
;; make sure target dir exists
(if (not (file-exists? target-dir))
(create-directory target-dir))
(let recur ((level 0)
(dir image-dir)
(dirlst (read-subdirs image-dir))
(null-handler (lambda (level dir) (sigma:error "no subdirectories found in " dir))))
(if (null? dirlst)
(null-handler level dir)
(for-each
(lambda (d)
(let ((sd (string-intersperse d dirsep)))
(let ((subdirs (read-subdirs sd)))
(recur (+ 1 level) d subdirs make-gallery))))
dirlst)))
(main-make-gallery SIGMA-DIR index image-dir target-dir commands
(read-subdirs target-dir) (opt 'up) (opt 'top slide-dir)))
(main-make-gallery SIGMA-DIR index image-dir target-dir commands (list) (opt 'up) #f slide-dir))
(if (commands 'cdimage?)
(begin
(message "Creating CD image "
(s+ (or (opt 'cd-dir) (defopt 'cd-dir)) dirsep
(or (opt 'gcd) (opt 'cd-file) (defopt 'cd-file)) ".iso") ": ")
(create-iso-image (list slide-dir) (or (opt 'g) (defopt 'g)))
(done)))
(if slide-dir (run (rm -rf ,slide-dir)))
)))
(main opts (opt '@))