105 lines
2.8 KiB
Scheme
105 lines
2.8 KiB
Scheme
(define (flatten l)
|
|
(cond
|
|
((not (list? l)) l)
|
|
((null? l) '())
|
|
((list? (car l)) (append (flatten (car l)) (flatten (cdr l))))
|
|
(#t (cons (car l) (flatten (cdr l))))))
|
|
|
|
(define (file-tree path)
|
|
(cond
|
|
((file-directory? path)
|
|
(map (lambda (item) (file-tree (string-append path "/" item))) (directory-list path)))
|
|
(#t path)))
|
|
|
|
(define (file-list path) (sort string<=? (flatten (file-tree path))))
|
|
|
|
(define (string-suffix s n)
|
|
(let ([strlen (string-length s)])
|
|
(substring s (- strlen n) strlen)))
|
|
|
|
(define (filter-ext fl ext)
|
|
(filter
|
|
(lambda (filename) (string=? ext (string-suffix filename (string-length ext))))
|
|
fl))
|
|
|
|
(define (jpg path) (filter-ext (file-list path) ".JPG"))
|
|
(define (webp path) (filter-ext (file-list path) ".webp"))
|
|
|
|
(define convert "/nix/store/rxxvsvf5p41p83k43cj0mibhymjzvkpk-imagemagick-7.1.0-37/bin/convert")
|
|
|
|
(define (import-picture src dest)
|
|
(system (string-append convert " " src " -resize 1600x1600\\> " dest)))
|
|
|
|
(define (import-pictures src-list dest-path album-slug . cnt)
|
|
(cond
|
|
((null? cnt) (import-pictures (reverse src-list) dest-path album-slug (length src-list)))
|
|
((null? src-list) '())
|
|
(#t (let ([newname (string-append dest-path "/" album-slug (format "~6,,,'0@A" (car cnt)) ".webp")])
|
|
(display (format "processing ~A ~%" (car src-list)))
|
|
(import-picture (car src-list) newname)
|
|
(cons newname (import-pictures
|
|
(cdr src-list)
|
|
dest-path
|
|
album-slug
|
|
(- (car cnt) 1)))
|
|
))))
|
|
|
|
(define (albumize pl)
|
|
`(html ()
|
|
(head ()
|
|
(meta (charset "utf-8"))
|
|
(style () "
|
|
img {
|
|
display:block;
|
|
max-width: calc(100% - 20px);
|
|
margin: auto;
|
|
padding: 10px;
|
|
}
|
|
"))
|
|
,(cons 'body (cons '() (map (lambda (filepath) `(img (src ,(path-last filepath) loading "lazy"))) pl)))))
|
|
|
|
(define (list->attr l)
|
|
(cond
|
|
((null? l) "")
|
|
(#t (string-append (format " ~A=\"~A\"" (car l) (cadr l)) (list->attr (cddr l))))))
|
|
|
|
(define (list->inner-html l)
|
|
(apply
|
|
string-append
|
|
(map
|
|
(lambda (v)
|
|
(cond
|
|
((list? v) (sexpr->html v))
|
|
(#t (format "~A" v))))
|
|
l)))
|
|
|
|
(define (sexpr->html s)
|
|
(cond
|
|
((null? (cddr s)) ; self-closing tag
|
|
(format "<~A~A/>~%" (car s) (list->attr (cadr s))))
|
|
(#t ; non self-closing tag
|
|
(string-append
|
|
; opening tag
|
|
(format "<~A~A>~%" (car s) (list->attr (cadr s)))
|
|
; inner content
|
|
(list->inner-html (cddr s))
|
|
; closing tag
|
|
(format "</~A>~%" (car s))))
|
|
))
|
|
|
|
(define (pic-list src out slug)
|
|
(cond
|
|
((file-exists? out) (webp out))
|
|
(#t (mkdir out) (reverse (import-pictures (jpg src) out slug)))))
|
|
|
|
(define (build src out slug)
|
|
(let ([pl (pic-list src out slug)])
|
|
(call-with-output-file
|
|
(string-append out "/index.html")
|
|
(lambda (p)
|
|
(display "<!doctype html>" p)
|
|
(newline p)
|
|
(display (sexpr->html (albumize pl)) p)
|
|
))))
|
|
|