From 615f6e04542fcff9fec824a075acbe8186955af3 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 30 Mar 2007 01:42:54 +0000
Subject: [PATCH] add current-code-font and fix bounding box ascent/descent for
 pin-line operations

svn: r5844
---
 collects/texpict/code.ss  | 20 +++++++++++---------
 collects/texpict/doc.txt  |  8 ++++++--
 collects/texpict/utils.ss |  8 +++++---
 3 files changed, 22 insertions(+), 14 deletions(-)

diff --git a/collects/texpict/code.ss b/collects/texpict/code.ss
index 00be00f7c5..5898fa9e07 100644
--- a/collects/texpict/code.ss
+++ b/collects/texpict/code.ss
@@ -94,7 +94,7 @@
   (define-signature code^
     (typeset-code code-pict-bottom-line-pict pict->code-pict
      comment-color keyword-color id-color const-color literal-color
-     code-align current-code-tt
+     code-align current-code-tt current-code-font
      current-keyword-list current-const-list current-literal-list 
      code-colorize-enabled code-colorize-quote-enabled 
      code-italic-underscore-enabled code-scripts-enabled
@@ -120,9 +120,11 @@
   (define-unit code@
       (import code-params^)
       (export code^)
+
+      (define current-code-font (make-parameter `(bold . modern)))
       
       (define (default-tt s)
-	(text s `(bold . modern) (current-font-size)))
+	(text s (current-code-font) (current-font-size)))
 
       (define current-code-tt (make-parameter default-tt))
 
@@ -286,31 +288,31 @@
 	       (not (char=? #\_ (string-ref str 1))))
 	  (mode-colorize
 	   mode 'id
-	   (text (substring str 1) `(bold italic . modern) (current-font-size)))]
+	   (text (substring str 1) `(italic . ,(current-code-font)) (current-font-size)))]
 	 [(and (code-scripts-enabled)
 	       (regexp-match #rx"^(.+)_([0-9a-z]+)\\^([0-9a-z]+)$" str))
 	  => (lambda (m)
 	       (hbl-append (colorize-id (cadr m) mode)
 			   (cc-superimpose
-			    (text (caddr m) `(subscript bold . modern) (current-font-size))
-			    (text (cadddr m) `(superscript bold . modern) (current-font-size)))))]
+			    (text (caddr m) `(subscript . ,(current-code-font)) (current-font-size))
+			    (text (cadddr m) `(superscript . ,(current-code-font)) (current-font-size)))))]
 	 [(and (code-scripts-enabled)
 	       (regexp-match #rx"^(.+)\\^([0-9a-z]+)_([0-9a-z]+)$" str))
 	  => (lambda (m)
 	       (hbl-append (colorize-id (cadr m) mode)
 			   (cc-superimpose
-			    (text (cadddr m) `(subscript bold . modern) (current-font-size))
-			    (text (caddr m) `(superscript bold . modern) (current-font-size)))))]
+			    (text (cadddr m) `(subscript . ,(current-code-font)) (current-font-size))
+			    (text (caddr m) `(superscript . ,(current-code-font)) (current-font-size)))))]
 	 [(and (code-scripts-enabled)
 	       (regexp-match #rx"^(.+)\\^([0-9a-z]+)$" str))
 	  => (lambda (m)
 	       (hbl-append (colorize-id (cadr m) mode)
-			   (text (caddr m) `(superscript bold . modern) (current-font-size))))]
+			   (text (caddr m) `(superscript . ,(current-code-font)) (current-font-size))))]
 	 [(and (code-scripts-enabled)
 	       (regexp-match #rx"^(.+)_([0-9a-z]+)$" str))
 	  => (lambda (m)
 	       (hbl-append (colorize-id (cadr m) mode)
-			   (text (caddr m) `(subscript bold . modern) (current-font-size))))]
+			   (text (caddr m) `(subscript . ,(current-code-font)) (current-font-size))))]
 	 [else
 	  (mode-colorize
 	   mode 
diff --git a/collects/texpict/doc.txt b/collects/texpict/doc.txt
index 2b037ed09f..db272af415 100644
--- a/collects/texpict/doc.txt
+++ b/collects/texpict/doc.txt
@@ -1155,9 +1155,13 @@ The _code^_ unit supplies the following
 >     $                        - typesets as a vertical bar (for no
                                  particularly good reason)
 
-> current-code-tt - parameter for a one-argument function to turn a
+> current-code-font - parameter for a base font used to typeset text.
+  The default is `(bold . modern).
+> current-code-tt - parameter for a one-argument procedure to turn a
   string into a pict, used to typeset text. The default is
-    (lambda (s) (text s `(bold . modern) (current-font-size)))
+    (lambda (s) (text s (current-code-font) (current-font-size)))
+  This procedure is not used to typeset subscripts or other items
+  that require font changes, but `current-code-font' is always used.
 
 > current-comment-color - parameter for a string or color% for comments
 > current-keyword-color - parameter for a string or color% for keywords
diff --git a/collects/texpict/utils.ss b/collects/texpict/utils.ss
index 9b92ed8419..3fed584459 100644
--- a/collects/texpict/utils.ss
+++ b/collects/texpict/utils.ss
@@ -795,9 +795,11 @@
                  (if color
                      (colorize p2 color)
                      p2)))])
-        (if under?
-            (cc-superimpose arrows base)
-            (cc-superimpose base arrows)))))
+        (refocus
+         (if under?
+             (cc-superimpose arrows base)
+             (cc-superimpose base arrows))
+         base))))
 
   (define add-line
     (opt-lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f])