From e8d0ea30b0baba0bb03fdc14ab2dce6651416b0f Mon Sep 17 00:00:00 2001
From: Jon Rafkind <rafkind@racket-lang.org>
Date: Mon, 1 Oct 2012 10:41:15 -0600
Subject: [PATCH] add codeblock->pict to convert between scribble and slideshow
 representations of code

---
 collects/unstable/gui/scribble.rkt | 146 +++++++++++++++++++++++++++++
 1 file changed, 146 insertions(+)
 create mode 100644 collects/unstable/gui/scribble.rkt

diff --git a/collects/unstable/gui/scribble.rkt b/collects/unstable/gui/scribble.rkt
new file mode 100644
index 0000000000..a0f2b6e6c3
--- /dev/null
+++ b/collects/unstable/gui/scribble.rkt
@@ -0,0 +1,146 @@
+#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)))])))]))