latex2bitmap.rkt

#lang racket/base
(require (for-syntax racket/base)
         racket/system
         racket/string
         racket/port
         racket/list
         racket/vector
         racket/class
         racket/gui/base
         file/md5)

(provide latex->bitmap latex->bitmap+ascent
         latex-preamble add-preamble latex-dpi latex-debug?
         latex-path dvipng-path
         (struct-out exn:latex)
         (struct-out exn:dvipng)
         set-latex-cache-path
         tidy-latex-cache
         setup-local-latex-cache)

(define used-files (make-hash))

(define cached-bitmaps (make-hash))

;; Document contents
(define latex-preamble (make-parameter ""))

(define (add-preamble . latex-strs)
  (latex-preamble (string-join (cons (latex-preamble) latex-strs) "\n")))

;; Formatting options
(define latex-dpi (make-parameter 300))

;; Spam the console with debugging info?
(define latex-debug? (make-parameter #t))

(define (find-executable name [defaultdir "/usr/bin"])
  (cond [(find-executable-path name) => (λ (p) p)]
        [(find-executable-path (string-append name ".exe")) => (λ (p) p)]
        [else  (build-path defaultdir name)]))

;; Default paths
(define latex-path (make-parameter (find-executable "latex" "/usr/bin")))
(define dvipng-path (make-parameter (find-executable "dvipng" "/usr/bin")))
(define cache-path (make-parameter (find-system-path 'temp-dir)))

;; Exceptions raised
(struct exn:latex exn:fail (message))
(struct exn:dvipng exn:fail ())

;; base+ext : path? string? -> path?
(define (base+ext file-base ext)
  (build-path (string-append (path->string file-base) ext)))

;; text-file->string : path? -> string?
(define (text-file->string file)
  (call-with-input-file file #:mode 'text port->string))

;; string->text-file : string? path? -> void?
(define (string->text-file str file)
  (with-output-to-file file #:mode 'text #:exists 'truncate
    (lambda () (printf "~a" str))))

;; text-file->string-list : path? -> (listof string?)
(define (text-file->string-list file)
  (call-with-input-file file #:mode 'text port->lines))

;; Example error:
;; ./latex125249806.tex:18: Undefined control sequence.

;; parse-latex-log : path? -> string?
;; Returns the first error message and context string found in the log
(define (parse-latex-log base-file)
  (define error-regexp
    (regexp (format ".*~a.*:[0-9]+:" (path->string base-file))))
  
  (let loop ([lines  (text-file->string-list (base+ext base-file ".log"))])
    (cond [(empty? lines)  "unknown"]
          [(regexp-match error-regexp (first lines))
           (let* ([info  (regexp-split #rx":" (first lines))]
                  [msg  (string-join (drop info 2) ":")]
                  [ctx  (string-join (take (rest lines) 2) "\n")])
             (format "~a ~a" msg ctx))]
          [else  (loop (rest lines))])))

;; compile-latex : path? -> void?
(define (compile-latex file-base)
  (define tex-file (base+ext file-base ".tex"))
  (define dvi-file (base+ext file-base ".dvi"))
  (define png-file (base+ext file-base ".png"))
  
  (define latex-args
    (list "-interaction=batchmode" "-file-line-error" "-halt-on-error"
          (path->string tex-file)))
  
  (define dvipng-args
    (list "--follow" "-bg" "Transparent" "--truecolor"
          "-D" (number->string (exact->inexact (latex-dpi)))
          "-T" "tight"
          "-o" (path->string png-file) (path->string dvi-file)))
  
  (when (latex-debug?)
    (printf "INFO: ~a ~a~n" (latex-path) (string-join latex-args " ")))
  
  (when (not (zero? (parameterize ([current-output-port (open-output-nowhere)])
                      (apply system*/exit-code (latex-path) latex-args))))
    (when (latex-debug?)
      (printf "ERROR: latex error, here's the log:~n")
      (printf "~a~n" (text-file->string (base+ext file-base ".log"))))
    (raise (exn:latex "latex failed" (current-continuation-marks)
                      (parse-latex-log file-base))))
  
  (when (latex-debug?)
    (printf "INFO: ~a ~a~n" (dvipng-path) (string-join dvipng-args " ")))
  
  (parameterize ([current-output-port (open-output-nowhere)])
    (apply system*/exit-code (dvipng-path) dvipng-args)
    (when (not (file-exists? png-file))
      (raise (exn:dvipng (format "dvipng failed to convert ~e" dvi-file)
                         (current-continuation-marks))))))

;; latex-doc->file-base : string? -> string?
(define (latex-doc->file-base doc-str)
  (build-path
   (format "latex2bitmap-~a"
           (bytes->string/latin-1
            (call-with-input-string (string-append (number->string (latex-dpi))
                                                   doc-str)
                                    md5)))))

;; ensure-png : string? -> void?
(define (ensure-png file-base doc-str)
  (define tex-file (base+ext file-base ".tex"))
  (define png-file (base+ext file-base ".png"))
  
  (unless (file-exists? png-file)
    (when (latex-debug?) (printf "INFO: generating ~a~n" png-file))
    (string->text-file doc-str tex-file)
    (compile-latex file-base))
  
  (hash-set! used-files png-file #t))

;; latex->latex-doc : string? -> string?
(define (latex->latex-doc latex-str)
  (string-append "\\documentclass[12pt]{article}\n"
                 "\\pagestyle{empty}\n"
                 (format "~a~n" (latex-preamble))
                 (format "\\begin{document}~n")
                 (format "~a~n" latex-str)
                 "\\end{document}"))

;; latex->bitmap : string? -> bitmap%
(define (latex->bitmap latex-str)
  (define doc-str (latex->latex-doc latex-str))
  (define file-base (latex-doc->file-base doc-str))
  (define png-file (base+ext file-base ".png"))
  
  (hash-ref!
   cached-bitmaps file-base
   (λ () (parameterize ([current-directory  (cache-path)])
           (ensure-png file-base doc-str)
           (when (latex-debug?) (printf "INFO: loading ~a~n" png-file))
           (make-object bitmap% png-file 'png/mask #f)))))


(define (get-column-alpha bm x)
  (let* ([height  (send bm get-height)]
         [b  (make-bytes (* 4 height))])
    (send bm get-argb-pixels x 0 1 height b #t)
    (build-vector height (λ (y) (bytes-ref b (* 4 y))))))

(define (find-first-largest v [idx 0] [lidx 0])
  (cond [(idx . >= . (vector-length v))  lidx]
        [((vector-ref v idx) . > . (vector-ref v lidx))
         (find-first-largest v (add1 idx) idx)]
        [else  (find-first-largest v (add1 idx) lidx)]))

(define (blank-column? v)
  (zero? (vector-count (compose not zero?) v)))

(define (find-first-column bm x0)
  (cond [(x0 . >= . (send bm get-width))  (send bm get-width)]
        [(blank-column? (get-column-alpha bm x0))
         (find-first-column bm (add1 x0))]
        [else  x0]))

(define (latex->bitmap+ascent latex-str)
  (define 1/2px-in (exact->inexact (/ 1 (latex-dpi) 2)))
  (define back-in (exact->inexact (/ 5 (latex-dpi))))
  (define baseline-dot (format "\\rule{~ain}{~ain}" 1/2px-in 1/2px-in))
  
  (define bm (latex->bitmap (format "\\makebox[0px][l]{\\hspace{-~ain}~a}~a"
                                    back-in baseline-dot latex-str)))
  
  (define ascent (+ 1 (find-first-largest (get-column-alpha bm 0))))
  (define x0 (find-first-column bm 1))
  
  (values bm ascent x0))


(define (set-latex-cache-path cpath)
  (when (file-exists? cpath)
    (error 'set-cache "~e exists as a regular file" cpath))
  (when (not (directory-exists? cpath))
    (make-directory cpath))
  (when (latex-debug?) (printf "INFO: latex compile path set to ~a~n" cpath))
  (cache-path cpath))

(define (tidy-latex-cache)
  (for ([file  (directory-list (cache-path))])
    (when (and (regexp-match #rx"^latex2bitmap-" (path->string file))
               (not (hash-has-key? used-files file)))
      (when (latex-debug?) (printf "INFO: deleting unused file ~a~n" file))
      (delete-file (build-path (cache-path) file)))))

(define (setup-local-cache stx)
  (let ([src  (syntax-source stx)])
    (if (path? src)
        (let-values ([(base-dir modname _) (split-path src)])
          (set-latex-cache-path (path->directory-path
                                 (build-path base-dir (format "~a-latex" modname)))))
        (printf "WARNING: not a path: ~a~n" src))))

(define-syntax (setup-local-latex-cache stx)
  (syntax-case stx ()
    [(local-name)  #'(setup-local-cache #'local-name)]))