(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 "~%" (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 "" p) (newline p) (display (sexpr->html (albumize pl)) p) ))))