147 lines
4.5 KiB
Racket
147 lines
4.5 KiB
Racket
#lang racket/base
|
|
|
|
(require (prefix-in s: (combine-in scribble/manual scribble/core))
|
|
(prefix-in slideshow: (combine-in slideshow/base slideshow/pict))
|
|
racket/draw
|
|
racket/class ;; only for make-object
|
|
racket/match)
|
|
|
|
(provide codeblock->pict)
|
|
|
|
;; Converts a scribble codeblock into a slideshow pict. Most useful with at-exp
|
|
;; @codeblock{
|
|
;; #lang racket
|
|
;;
|
|
;; (define (x z)
|
|
;; (+ z 2))
|
|
;; }
|
|
(define (codeblock->pict block)
|
|
(define (color-text name what)
|
|
(define (float-part v)
|
|
(inexact->exact (round (* 255 v))))
|
|
|
|
(define-syntax-rule (define-color name r g b)
|
|
(define name (make-object color%
|
|
(float-part r)
|
|
(float-part g)
|
|
(float-part b))))
|
|
;; \definecolor{PaleBlue}{rgb}{0.90,0.90,1.0}
|
|
;; \definecolor{LightGray}{rgb}{0.90,0.90,0.90}
|
|
;; \definecolor{CommentColor}{rgb}{0.76,0.45,0.12}
|
|
;; \definecolor{ParenColor}{rgb}{0.52,0.24,0.14}
|
|
;; \definecolor{IdentifierColor}{rgb}{0.15,0.15,0.50}
|
|
;; \definecolor{ResultColor}{rgb}{0.0,0.0,0.69}
|
|
;; \definecolor{ValueColor}{rgb}{0.13,0.55,0.13}
|
|
;; \definecolor{OutputColor}{rgb}{0.59,0.00,0.59}
|
|
|
|
(define-color value-color 0.13 0.55 0.13)
|
|
(define-color identifier-color 0.15 0.15 0.50)
|
|
(define-color pale-blue 0.90 0.90 1.0)
|
|
(define-color light-gray 0.90 0.90 0.90)
|
|
(define-color comment-color 0.76 0.45 0.12)
|
|
(define-color paren-color 0.52 0.24 0.14)
|
|
(define-color result-color 0.0 0.0 0.69)
|
|
(define-color output-color 0.59 0.0 0.59)
|
|
(define-color black 0.0 0.0 0.0)
|
|
|
|
;; FIXME
|
|
(define-color blue 0 0 1)
|
|
|
|
;; FIXME
|
|
(define-color red 1 0 0)
|
|
|
|
;; FIXME
|
|
(define-color light-grey 0.8 0.8 0.8)
|
|
|
|
(define (get-color name)
|
|
(match name
|
|
["RktMeta" identifier-color]
|
|
["RktPn" paren-color]
|
|
["RktPlain" black]
|
|
["RktKw" black]
|
|
["RktCmt" comment-color]
|
|
["RktPn" paren-color]
|
|
["RktInBG" paren-color]
|
|
["RktSym" identifier-color]
|
|
["RktVal" value-color]
|
|
["RktValLink" blue]
|
|
["RktModLink" blue]
|
|
["RktRes" result-color]
|
|
["RktOut" output-color]
|
|
["RktMeta" identifier-color]
|
|
["RktMod" black]
|
|
["RktRdr" black]
|
|
["RktVarCol" identifier-color]
|
|
|
|
;; FIXME
|
|
;; \RktVarCol{\textsl{#1}}}
|
|
["RktVar" (get-color "RktVarCol")]
|
|
|
|
["RktErrCol" red]
|
|
|
|
;; FIXME:
|
|
;; {{\RktErrCol{\textrm{\textit{#1}}}}}
|
|
["RktErr" (get-color "RktErrCol")]
|
|
|
|
;; FIXME:
|
|
;; {\RktOpt}[1]{#1}
|
|
;;
|
|
["RktOpt" black]
|
|
|
|
;; FIXME:
|
|
;; }[1]{\incolorbox{LightGray}{\RktInBG{#1}}}
|
|
["RktIn" light-grey]
|
|
|
|
;; FIXME:
|
|
;; }[1]{\colorbox{PaleBlue}{\hspace{-0.5ex}\RktInBG{#1}\hspace{-0.5ex}}}
|
|
["highlighted" pale-blue]
|
|
[else (error 'color-text "unknown type type '~a'" name)]))
|
|
|
|
(define out (slideshow:text what '(bold . modern) (slideshow:current-font-size)))
|
|
(slideshow:colorize out (get-color name)))
|
|
|
|
(define (append-all combiner)
|
|
(lambda (elements)
|
|
(apply combiner (slideshow:blank) elements)))
|
|
|
|
(define hc-append-all (append-all slideshow:hc-append))
|
|
(define vl-append-all (append-all slideshow:vl-append))
|
|
|
|
(define (convert-element element)
|
|
(match element
|
|
[(struct s:element (style content))
|
|
(match style
|
|
#;
|
|
['hspace (tt " ")]
|
|
['hspace (slideshow:tt (s:content->string content))]
|
|
#;
|
|
['hspace (blank 20 1)]
|
|
[(struct s:style (name properties))
|
|
(color-text name (s:content->string content))])]))
|
|
|
|
(define (convert-block block)
|
|
(match block
|
|
[(struct s:paragraph (style content))
|
|
(hc-append-all
|
|
(for/list ([element content])
|
|
(match element
|
|
[(? string?) (slideshow:t element)]
|
|
[(struct s:element (style content)) (convert-element element)]
|
|
[else (error 'convert-block "don't know what to do with ~a" element)])))]))
|
|
|
|
(define (convert-row row)
|
|
(hc-append-all
|
|
(for/list ([element row])
|
|
(convert-block element))))
|
|
|
|
;; (pretty-print block)
|
|
(match block
|
|
[(struct s:nested-flow (style (list blocks ...)))
|
|
(hc-append-all
|
|
(for/list ([block blocks])
|
|
(match block
|
|
[(struct s:table (style (list rows ...)))
|
|
(vl-append-all
|
|
(for/list ([row rows])
|
|
(convert-row row)))])))]))
|