(use (only data-structures string-intersperse) (only ports with-output-to-port with-output-to-string) (only getopt-long getopt-long usage) (only imlib2 image-load image-width image-height image-destroy image-pixel/rgba) (only srfi-1 every fold any for-each) (rename format (format cl-format)) giflib giflib-imlib2) (define (hex-shorten r g b) (let ((r* (quotient r 16)) (g* (quotient g 16)) (b* (quotient b 16))) (if (and (= r* (modulo r 16)) (= g* (modulo g 16)) (= b* (modulo b 16))) (format "#~x~x~x" r* g* b*) #f))) (define (hex-code-at image x y optimize?) (receive (r g b a) (image-pixel/rgba image x y) ;; is the pixel fully opaque? (if (= a 255) (let ((hex-code (cl-format #f "#~2,'0x~2,'0x~2,'0x" r g b))) (if optimize? (or (hex-shorten r g b) hex-code) hex-code)) #f))) (define (float->equivalent n) (if (= n (floor n)) (inexact->exact n) n)) (define (css-spec-at x y unit scale hex-code optimize?) (let* ((scale (if optimize? (float->equivalent scale) scale)) (x (if optimize? (float->equivalent x) x)) (y (if optimize? (float->equivalent y) y))) (format "~a~a ~a~a ~a" (add1 (* x scale)) unit (add1 (* y scale)) unit hex-code))) (define (image->string image width height unit scale optimize?) (let ((data '())) (do ((y 0 (add1 y))) ((= y height)) (do ((x 0 (add1 x))) ((= x width)) (let ((hex-code (hex-code-at image x y optimize?))) (when hex-code (set! data (cons (css-spec-at x y unit scale hex-code optimize?) data)))))) (string-intersperse (reverse data) ","))) (define (transform-image path unit scale optimize?) (let* ((image (image-load path)) (width (image-width image)) (height (image-height image)) (data (image->string image width height unit scale optimize?))) (image-destroy image) data)) (define (error-message message . args) (with-output-to-port (current-error-port) (lambda () (apply printf message args))) (exit 1)) (define opts '((input "input file" (single-char #\i) (value (required "FILE"))) (output "output file" (single-char #\o) (value (required "FILE"))) (unit "unit (default: \"px\")" (single-char #\u) (value (optional "UNIT"))) (scale "scaling factor (default: 1)" (single-char #\s) (value (optional "N"))) (html-title "HTML title (default: \"Image\")" (value (optional "TITLE"))) (css-id "CSS ID (default: \"image\")" (value (optional "ID"))) (optimize "enable optimizations" (single-char #\O) (required #f)) (stylesheet-name "stylesheet name (default: \"style.css\")" (value (optional "NAME"))) (stylesheet "stylesheet type (default: embed, options: embed, split, only)" (value (optional "TYPE"))) (animate "enable animation mode" (required #f)) (help "display usage" (single-char #\h)))) (define (gif-animated? gif) (any (lambda (frame) (alist-ref 'loop (frame-metadata frame))) (gif-frames gif))) (define (gif-delays gif) (let ((delays (map (lambda (frame) (alist-ref 'delay (frame-metadata frame))) (gif-frames gif)))) (when (not (every identity delays)) (error-message "Malformed GIF: missing delay(s)\n")) delays)) (define (gif-length gif) (fold + 0 (gif-delays gif))) (define (gif-timings gif) (let* ((delays (gif-delays gif)) (sum (fold + 0 delays))) (let loop ((time 0) (delays delays) (acc '())) (if (null? delays) (reverse acc) (loop (+ time (car delays)) (cdr delays) (cons (/ time sum) acc)))))) (define (gif->css gif timings unit scale optimize?) (with-output-to-string (lambda () (for-each (lambda (timing image) (cl-format #t "~,1f%{box-shadow:" (* timing 100)) (let ((width (image-width image)) (height (image-height image))) (display (image->string image width height unit scale optimize?))) (image-destroy image) (display "}")) timings (gif->imlib2-images gif))))) (define (save-css output css html-title css-id stylesheet-name stylesheet) (with-output-to-file output (lambda () (cond ((eq? stylesheet 'embed) (display (format "