#lang racket/base
(require slideshow
racket/gui
"latex2bitmap.rkt"
"extras.rkt")
(provide add-preamble
latex-page-width latex-pict lt $$ $
(all-from-out "latex2bitmap.rkt"))
(define latex-page-width (make-parameter client-w))
(define (lines . latex-strs)
(string-join latex-strs "\n"))
(define (current-font-dpi)
(* 7 (current-font-size)))
(define (px n)
(format "~ain" (exact->inexact (/ n (current-font-dpi)))))
(define (minipage width . latex-strs)
(lines (format "\\begin{minipage}{~a}" width)
(apply lines latex-strs)
(format "\\end{minipage}")))
(define (dpi-scale)
(first (current-expected-text-scale)))
(define (latex->pict latex-str latex-stx)
(with-handlers ([exn:latex? (λ (e) (raise-syntax-error
'latex (exn:latex-message e)
latex-stx))])
(define dscale (dpi-scale))
(parameterize ([latex-dpi (* dscale (current-font-dpi))])
(define bm (latex->bitmap (minipage (px (latex-page-width)) latex-str)))
(define w (send bm get-width))
(define h (send bm get-height))
(dc (λ (dest-dc x y)
(define color (send (send dest-dc get-pen) get-color))
(define opacity (send dest-dc get-alpha))
(define new-bm (silhouette-bitmap bm color opacity))
(define pct (scale (bitmap new-bm) (/ 1 dscale)))
(draw-pict pct dest-dc x y))
(/ w dscale) (/ h dscale)))))
(define (latex->pict/baseline latex-str latex-stx)
(with-handlers ([exn:latex? (λ (e) (raise-syntax-error
'latex (exn:latex-message e)
latex-stx))])
(define dscale (dpi-scale))
(parameterize ([latex-dpi (* dscale (current-font-dpi))])
(define-values (bm a x0) (latex->bitmap+ascent latex-str))
(define w (- (send bm get-width) x0))
(define h (send bm get-height))
(define d (- h a))
(dc (λ (dest-dc x y)
(define color (send (send dest-dc get-pen) get-color))
(define opacity (send dest-dc get-alpha))
(define new-bm (silhouette-bitmap bm color opacity))
(define pct
(scale (drop-below-ascent
(inset/clip (bitmap new-bm) (- x0) 0 0 0) d)
(/ 1 dscale)))
(draw-pict pct dest-dc x y))
(/ w dscale) (/ h dscale) (/ a dscale) (/ d dscale)))))
(define-syntax (latex-pict stx)
(syntax-case stx ()
[(_ latex-str ...)
(with-syntax ([latex-stx stx])
(syntax/loc stx
(latex->pict (apply lines (list latex-str ...)) #'latex-stx)))]))
(define-syntax ($$ stx)
(syntax-case stx ()
[(_ math-str ...) (syntax/loc stx (latex-pict "$$" math-str ... "$$"))]))
(define-syntax (lt stx)
(syntax-case stx ()
[(_ latex-str ...)
(with-syntax ([latex-stx stx])
(syntax/loc stx
(latex->pict/baseline (string-join (list latex-str ...) " ") #'latex-stx)))]))
(define-syntax ($ stx)
(syntax-case stx ()
[(_ math-str ...) (syntax/loc stx (lt "$" math-str ... "$"))]))
(define (bitmap->argb-pixels bm)
(define w (send bm get-width))
(define h (send bm get-height))
(define bs (make-bytes (* 4 w h)))
(send bm get-argb-pixels 0 0 w h bs #f)
(define mask (send bm get-loaded-mask))
(when mask
(send mask get-argb-pixels 0 0 w h bs #t))
bs)
(define (argb-pixels->bitmap bs w h)
(unless (= (* 4 w h) (bytes-length bs))
(error 'set-bitmap-argb-pixels!
"~vx~v bitmap needs ~v argb bytes; given ~v bytes"
w h (* 4 w h) (bytes-length bs)))
(define bm (make-object bitmap% w h))
(define dc (make-object bitmap-dc% bm))
(send dc set-argb-pixels 0 0 w h bs #f)
(define mask (make-object bitmap% w h))
(send dc set-bitmap mask)
(send dc set-argb-pixels 0 0 w h bs #t)
(send bm set-loaded-mask mask)
(send dc set-bitmap #f)
bm)
(define (color->rgb col)
(cond [(string? col)
(let ([c (send the-color-database find-color col)])
(list (send c red) (send c green) (send c blue)))]
[(col . is-a? . color%)
(list (send col red) (send col green) (send col blue))]))
(define sil-cache (make-weak-hash))
(define (silhouette-bitmap bm color opacity)
(match-define (list r g b) (color->rgb color))
(hash-ref!
sil-cache (list (eq-hash-code bm) opacity r g b)
(λ ()
(define w (send bm get-width))
(define h (send bm get-height))
(define bs (bitmap->argb-pixels bm))
(for ([i (in-range 0 (bytes-length bs) 4)])
(define a-val (bytes-ref bs i))
(when (a-val . > . 0)
(bytes-set! bs i (inexact->exact (round (* a-val opacity))))
(bytes-set! bs (+ 1 i) r)
(bytes-set! bs (+ 2 i) g)
(bytes-set! bs (+ 3 i) b)))
(argb-pixels->bitmap bs w h))))