|
| 1 | + |
| 2 | + |
| 3 | +(defun get-gif-dimensions (filename) |
| 4 | + "Get GIF dimensions, return a cons of (w,h). |
| 5 | +
|
| 6 | +Get GIF dimensions directly from binary. Does not need external |
| 7 | +tools. |
| 8 | +
|
| 9 | +
|
| 10 | +GIF Header |
| 11 | +
|
| 12 | +Offset Length Contents |
| 13 | + 0 3 bytes \"GIF\" |
| 14 | + 3 3 bytes \"87a\" or \"89a\" |
| 15 | + 6 2 bytes <Logical Screen Width> |
| 16 | + 8 2 bytes <Logical Screen Height> |
| 17 | + 10 1 byte bit 0: Global Color Table Flag (GCTF) |
| 18 | + bit 1..3: Color Resolution |
| 19 | + bit 4: Sort Flag to Global Color Table |
| 20 | + bit 5..7: Size of Global Color Table: 2^(1+n) |
| 21 | + 11 1 byte <Background Color Index> |
| 22 | + 12 1 byte <Pixel Aspect Ratio> |
| 23 | + 13 ? bytes <Global Color Table(0..255 x 3 bytes) if GCTF is one> |
| 24 | + ? bytes <Blocks> |
| 25 | + 1 bytes <Trailer> (0x3b)" |
| 26 | + (interactive "fFile name:") |
| 27 | + (with-current-buffer (get-buffer-create "*GIF*") |
| 28 | + (set-buffer-multibyte nil) |
| 29 | + (insert-file-contents-literally filename nil 0 10 t) |
| 30 | + (when (not (looking-at-p "GIF8[79]a")) |
| 31 | + (error "File '%s' is not a GIF" filename)) |
| 32 | + (let ((result |
| 33 | + (cons (+ (char-after 7) (* 256 (char-after 8))) |
| 34 | + (+ (char-after 9) (* 256 (char-after 10)))))) |
| 35 | + (if (called-interactively-p) |
| 36 | + (message "Dimensions: %dx%d" (car result) (cdr result))) |
| 37 | + result))) |
| 38 | + |
| 39 | +(defun haskell-manual-fixup-buffer (&optional buffer) |
| 40 | + "Fix contents of HTML from makeinfo in a BUFFER. |
| 41 | +
|
| 42 | +Currently it looks for image references and adds an explicit |
| 43 | +width and height. GIFs are generate on Retina so their resolution |
| 44 | +is double of what it should be. Here we halve it to compensate |
| 45 | +dimensions and to keep it crisp when viewed on Retina again." |
| 46 | + (interactive) |
| 47 | + (with-current-buffer (or buffer (current-buffer)) |
| 48 | + (save-excursion |
| 49 | + (goto-char (point-min)) |
| 50 | + (while (re-search-forward "<img src=\"\\(.*\\)\" alt=\"\\(.*\\)\">" nil t) |
| 51 | + (let* ((filename (match-string-no-properties 1)) |
| 52 | + (alttext (match-string-no-properties 2)) |
| 53 | + (default-directory (file-name-directory (buffer-file-name))) |
| 54 | + (dim (get-gif-dimensions filename)) |
| 55 | + (img (format "<img width=\"%d\" height=\"%d\" src=\"%s\" alt=\"%s\">" |
| 56 | + (/ (car dim) 2) (/ (cdr dim) 2) filename alttext))) |
| 57 | + (delete-region (match-beginning 0) (match-end 0)) |
| 58 | + (insert img)))))) |
| 59 | + |
| 60 | +(defun haskell-manual-fixup-file (filename) |
| 61 | + "Run `haskell-manual-fixup-buffer' on a file." |
| 62 | + (interactive "fFile name:") |
| 63 | + (with-temp-buffer |
| 64 | + (insert-file-contents filename t) |
| 65 | + (haskell-manual-fixup-buffer) |
| 66 | + (when (buffer-modified-p) |
| 67 | + (basic-save-buffer)))) |
| 68 | + |
| 69 | +(defun haskell-manual-fixups-batch-and-exit () |
| 70 | + "Run `haskell-manual-fixup-buffer' on files given as arguments. |
| 71 | +
|
| 72 | +Should be invoked as: |
| 73 | +
|
| 74 | + emacs -l haskell-manual-fixups.el -f haskell-manual-fixups-batch-and-exit doc/html/*.html" |
| 75 | + (dolist (filename command-line-args-left) |
| 76 | + (haskell-manual-fixup-file filename)) |
| 77 | + (kill-emacs 0)) |
0 commit comments