diff --git a/album.ss b/album.ss index 4ad9cc0..c8f9c98 100644 --- a/album.ss +++ b/album.ss @@ -5,38 +5,58 @@ ((list? (car l)) (append (flatten (car l)) (flatten (cdr l)))) (#t (cons (car l) (flatten (cdr l)))))) - -(define (tree path) +(define (file-tree path) (cond ((file-directory? path) - (map (lambda (item) (tree (string-append path "/" item))) (directory-list 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 (pictures path) - (sort - string<=? - (filter - (lambda (filename) (string=? ".JPG" (string-suffix filename 4))) - (flatten (tree path))))) +(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 (albumize path) +(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: 100%; + max-width: calc(100% - 20px); margin: auto; padding: 10px; } ")) - ,(cons 'body (cons '() (map (lambda (filename) `(img (src ,filename))) (pictures path)))))) + ,(cons 'body (cons '() (map (lambda (filepath) `(img (src ,(path-last filepath) loading "lazy"))) pl))))) (define (list->attr l) (cond @@ -67,10 +87,18 @@ img { (format "~%" (car s)))) )) -(define (build src-folder dest-file) - (call-with-output-file - dest-file - (lambda (p) - (display (sexpr->html (albumize src-folder)) p) -))) +(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 "" p) + (newline p) + (display (sexpr->html (albumize pl)) p) +))))