added text and text/font (but with some problems still) and changed the image saving setup so the filenames are not so long

svn: r16623

collects/2htdp/image.ss

@@ -71,6 +71,8 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          star
          star-polygon
          triangle
+         text
+         text/font
          
          x-place?
          y-place?

collects/2htdp/private/image-more.ss

@@ -46,6 +46,9 @@
          star
          star-polygon
          
+         text
+         text/font
+         
          swizzle)
 
 
@@ -235,6 +238,26 @@
        (if (send the-color-database find-color color-str)
            color-str
            "black"))]
+    [(string)
+     (check-arg fn-name (string? arg) 'string i arg)
+     arg]
+    [(font-size)
+     (check-arg fn-name (and (integer? arg) (<= 1 arg 255)) 'font-size i arg)
+     arg]
+    [(face)
+     (check-arg fn-name (or (not arg) (string? arg)) 'face i arg)
+     arg]
+    [(family)
+     (check-arg fn-name (memq arg '(default decorative roman script swiss modern symbol system)) 'family i arg)
+     arg]
+    [(style)
+     (check-arg fn-name (memq arg '(normal italic slant)) 'style i arg)
+     arg]
+    [(weight)
+     (check-arg fn-name (memq arg '(normal bold light)) 'weight i arg)
+     arg]
+    [(underline)
+     (and arg #t)]
     [else
      (error 'check "the function ~a has an argument with an unknown name: ~s"
             fn-name
@@ -558,7 +581,14 @@
     [(text? atomic-shape)
      (make-text (text-string atomic-shape)
                 (bring-between (+ θ (text-angle atomic-shape)) 360)
-                (text-font atomic-shape))]
+                (text-y-scale atomic-shape)
+                (text-color atomic-shape)
+                (text-size  atomic-shape)
+                (text-face  atomic-shape)
+                (text-family atomic-shape)
+                (text-style atomic-shape)
+                (text-weight  atomic-shape)
+                (text-underline atomic-shape))]
     [(bitmap? atomic-shape)
      (make-bitmap (bitmap-raw-bitmap atomic-shape)
                   (bitmap-raw-mask atomic-shape)
@@ -626,6 +656,35 @@
 ;;       line
 ;;       text
 
+;; this is just so that 'text' objects can be sized.
+(define text-sizing-bm (make-object bitmap-dc% (make-object bitmap% 1 1)))
+
+(define/chk (text string font-size color)
+  (mk-text string font-size color #f 'swiss 'normal 'normal #f))
+
+(define/chk (text/font string font-size color face family style weight underline)
+  (mk-text string font-size color face family style weight underline))
+
+(define (mk-text str font-size color face family style weight underline)
+  (cond
+    [(<= (string-length str) 1)
+     (mk-single-text str font-size color face family style weight underline)]
+    [else
+     (let ([letters (string->list str)])
+       (beside/internal
+        'baseline
+        (mk-single-text (string (car letters)) font-size color face family style weight underline)
+        (map (λ (letter)
+               (mk-single-text (string letter) font-size color face family style weight underline))
+             (cdr letters))))]))
+
+(define (mk-single-text letter font-size color face family style weight underline)
+  (let ([text (make-text letter 0 1 color font-size face family style weight underline)])
+    (let-values ([(w h a d) (send text-sizing-bm get-text-extent letter (text->font text))])
+      (make-image text
+                  (make-bb w h d)
+                  #f))))
+
 (define/chk (triangle side-length mode color)
   (make-polygon/star side-length 3 mode color values))
 

collects/mrlib/image-core.ss

@@ -13,6 +13,16 @@ use of this library is the snip class addition it
 does (and any code that that does not depend on
 has been moved out).
 
+
+-- in the middle of text:
+
+  - bounding boxes
+  - rotating (and bounding boxes)
+  - hbl append(?)
+  - this doesn't work (how to test?)
+(beside/places "baseline"
+                 (text "ijy" 12 'black)
+                 (text "ijy" 24 'black))
 |#
 
 (require scheme/class
@@ -115,9 +125,11 @@ has been moved out).
 ;;  - (make-ellipse width height angle mode color)
 (define-struct/reg-mk ellipse (width height angle mode color) #:transparent #:omit-define-syntaxes)
 ;;
-;;  - (make-text string angle font)
+;;  - (make-text string angle number color
+;;               number (or/c #f string) family (or/c 'normal 'italic) (or/c 'normal 'light 'bold) boolean)
 ;;    NOTE: font can't be the raw mred font or else copy & paste won't work
-(define-struct/reg-mk text (string angle font) #:omit-define-syntaxes #:transparent)
+(define-struct/reg-mk text (string angle y-scale color size face family style weight underline) 
+  #:omit-define-syntaxes #:transparent)
 ;;
 ;;  - (make-bitmap (is-a?/c bitmap%) angle positive-real (or/c #f (is-a?/c bitmap%)))
 ;;    NOTE: bitmap copying needs to happen in 'write' and 'read' methods
@@ -355,11 +367,20 @@ has been moved out).
                    (ellipse-angle shape)
                    (ellipse-mode shape)
                    (ellipse-color shape))]
-    [(text? shape) 
-     (unless (and (= 1 x-scale)
-                  (= 1 y-scale))
-       (fprintf (current-error-port) "scaling text, ignoring\n"))
-     shape]
+    [(text? shape)
+     ;; should probably do something different here so that
+     ;; the y-scale is always greater than 1
+     ;; (or else always smaller than 1)
+     (make-text (text-string shape)
+                (text-angle shape)
+                (* (text-y-scale shape) (/ y-scale x-scale))
+                (text-color shape)
+                (* (text-size shape) x-scale)
+                (text-face shape)
+                (text-family shape)
+                (text-style shape)
+                (text-weight shape)
+                (text-underline shape))]
     [(bitmap? shape) 
      (unless (and (= 1 x-scale)
                   (= 1 y-scale))
@@ -388,13 +409,21 @@ has been moved out).
 
 ;; render-image : normalized-shape dc dx dy -> void
 (define (render-image image dc dx dy)
-  (let loop ([shape (send image get-normalized-shape)])
-    (cond
-      [(overlay? shape)
-       (render-simple-shape (overlay-bottom shape) dc dx dy)
-       (loop (overlay-top shape))]
-      [else
-       (render-simple-shape shape dc dx dy)])))
+  (let ([pen (send dc get-pen)]
+        [brush (send dc get-brush)]
+        [font (send dc get-font)]
+        [fg (send dc get-text-foreground)])
+    (let loop ([shape (send image get-normalized-shape)])
+      (cond
+        [(overlay? shape)
+         (render-simple-shape (overlay-bottom shape) dc dx dy)
+         (loop (overlay-top shape))]
+        [else
+         (render-simple-shape shape dc dx dy)]))
+    (send dc set-pen pen)
+    (send dc set-brush brush)
+    (send dc set-font font)
+    (send dc set-text-foreground fg)))
 
 (define (render-simple-shape simple-shape dc dx dy)
   (cond
@@ -442,9 +471,31 @@ has been moved out).
                 (send the-color-database find-color "black")
                 (bitmap-raw-mask atomic-shape))]
          [(text? atomic-shape)
-          (let ([θ (degrees->radians (text-angle atomic-shape))])
-            (send dc set-font (text-font atomic-shape))
-            (send dc draw-text (text-string atomic-shape) dx dy #f 0 angle))]))]))
+          (let ([θ (degrees->radians (text-angle atomic-shape))]
+                [font (send dc get-font)])
+            (send dc set-font (text->font atomic-shape))
+            (send dc set-text-foreground 
+                  (or (send the-color-database find-color (text-color atomic-shape))
+                      (send the-color-database find-color "black")))
+            (send dc draw-text (text-string atomic-shape) dx dy #f 0 θ))]))]))
+
+(define (text->font text)
+  (cond
+    [(text-face text)
+     (send the-font-list find-or-create-font
+           (text-size text)
+           (text-face text)
+           (text-family text)
+           (text-style text) 
+           (text-weight text)
+           (text-underline text))]
+    [else
+     (send the-font-list find-or-create-font
+           (text-size text)
+           (text-family text)
+           (text-style text) 
+           (text-weight text)
+           (text-underline text))]))
 
 (define (ellipse-rotated-size ew eh θ)
   (cond
@@ -490,7 +541,8 @@ has been moved out).
          make-translate translate? translate-dx translate-dy translate-shape
          make-scale scale-x scale-y scale-shape
          make-ellipse ellipse? ellipse-width ellipse-height ellipse-angle ellipse-mode ellipse-color
-         make-text text? text-string text-angle text-font
+         make-text text? text-string text-angle text-y-scale text-color
+         text-angle text-size text-face text-family text-style text-weight text-underline
          make-polygon polygon? polygon-points polygon-mode polygon-color
          make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-scale bitmap-rendered-bitmap
          
@@ -503,6 +555,8 @@ has been moved out).
          image-bottom
          image-baseline
          
+         text->font
+         
          render-image)
 
 ;; method names

collects/teachpack/2htdp/scribblings/image-gen.ss

@@ -1,7 +1,6 @@
 #lang scheme/gui
 
-(require 2htdp/private/image-more
-         "image-util.ss")
+(require 2htdp/private/image-more)
 
 (define-namespace-anchor anchor)
 (define ns (namespace-anchor->namespace anchor))
@@ -23,22 +22,23 @@
 (define-namespace-anchor image-anchor)
 (define image-ns (namespace-anchor->namespace anchor))
 
-(define (handle-image exp)
-  (printf "saving ~s\n" exp)
-  (parameterize ([current-namespace image-ns])
-    (save-image (eval exp)
-                (build-path "img" (exp->filename exp)))))
+(define mapping '())
 
-(let ([ht (make-hash)])
-  (for-each
-   (λ (exp)
-     (when (hash-ref ht (exp->filename exp) #f)
-       (error 'image-gen.ss
-              "~s and ~s go to the same string, namely ~s"
-              (hash-ref ht (exp->filename exp))
-              exp
-              (exp->filename exp)))
-     (hash-set! ht (exp->filename exp) exp))
-   expressions))
+(define (handle-image exp)
+  (let* ([i (length mapping)]
+         [fn (format "~a.png" i)])
+    (printf "saving ~s\n" exp)
+    (set! mapping (cons (list exp fn) mapping))
+    (parameterize ([current-namespace image-ns])
+      (save-image (eval exp)
+                  (build-path "img" fn)))))
 
 (for-each handle-image expressions)
+(call-with-output-file "image-toc.ss"
+  (λ (port)
+    (fprintf port "#lang scheme/base\n(provide mapping)\n")
+    (fprintf port ";; this file is generated by image-gen.ss -- do not edit\n\n")
+    (pretty-print
+     `(define mapping (list ,@(map (λ (l) `(list ',(car l) ,(cadr l))) mapping)))
+     port))
+  #:exists 'truncate)

collects/teachpack/2htdp/scribblings/image-toc.ss

@@ -0,0 +1,128 @@
+#lang scheme/base
+(provide mapping)
+;; this file is generated by image-gen.ss -- do not edit
+
+(define mapping
+  (list
+   (list
+    '(beside/places
+      "bottom"
+      (ellipse 20 70 "solid" "lightsteelblue")
+      (frame (ellipse 20 50 "solid" "mediumslateblue"))
+      (ellipse 20 30 "solid" "slateblue")
+      (ellipse 20 10 "solid" "navy"))
+    "38.png")
+   (list '(frame (ellipse 20 20 "outline" "black")) "37.png")
+   (list '(ellipse 60 60 "solid" "blue") "36.png")
+   (list '(scale/xy 3 2 (ellipse 20 30 "solid" "blue")) "35.png")
+   (list '(ellipse 40 60 "solid" "blue") "34.png")
+   (list '(scale 2 (ellipse 20 30 "solid" "blue")) "33.png")
+   (list '(rotate 5 (rectangle 50 50 "outline" "black")) "32.png")
+   (list '(rotate 45 (ellipse 60 20 "solid" "olivedrab")) "31.png")
+   (list
+    '(beside/places "baseline" (text "ijy" 18 "black") (text "ijy" 24 "black"))
+    "30.png")
+   (list
+    '(beside/places
+      "center"
+      (ellipse 20 70 "solid" "mediumorchid")
+      (ellipse 20 50 "solid" "darkorchid")
+      (ellipse 20 30 "solid" "purple")
+      (ellipse 20 10 "solid" "indigo"))
+    "29.png")
+   (list
+    '(beside/places
+      "bottom"
+      (ellipse 20 70 "solid" "lightsteelblue")
+      (ellipse 20 50 "solid" "mediumslateblue")
+      (ellipse 20 30 "solid" "slateblue")
+      (ellipse 20 10 "solid" "navy"))
+    "28.png")
+   (list
+    '(beside
+      (ellipse 20 70 "solid" "gray")
+      (ellipse 20 50 "solid" "darkgray")
+      (ellipse 20 30 "solid" "dimgray")
+      (ellipse 20 10 "solid" "black"))
+    "27.png")
+   (list
+    '(overlay/xy
+      (rectangle 10 10 "solid" "red")
+      -10
+      -10
+      (rectangle 10 10 "solid" "black"))
+    "26.png")
+   (list
+    '(overlay/xy
+      (rectangle 10 10 "solid" "red")
+      10
+      10
+      (rectangle 10 10 "solid" "black"))
+    "25.png")
+   (list
+    '(overlay/xy
+      (rectangle 10 10 "outline" "red")
+      10
+      0
+      (rectangle 10 10 "outline" "black"))
+    "24.png")
+   (list
+    '(overlay/xy
+      (ellipse 40 40 "outline" "black")
+      25
+      25
+      (ellipse 10 10 "solid" "forestgreen"))
+    "23.png")
+   (list
+    '(overlay/places
+      "right"
+      "bottom"
+      (rectangle 20 20 "solid" "red")
+      (rectangle 30 30 "solid" "black")
+      (rectangle 40 40 "solid" "red")
+      (rectangle 50 50 "solid" "black"))
+    "22.png")
+   (list
+    '(overlay/places
+      "middle"
+      "middle"
+      (rectangle 30 60 "solid" "orange")
+      (ellipse 60 30 "solid" "purple"))
+    "21.png")
+   (list
+    '(overlay
+      (ellipse 10 10 "solid" "red")
+      (ellipse 30 30 "solid" "black")
+      (ellipse 50 50 "solid" "red")
+      (ellipse 70 70 "solid" "black"))
+    "20.png")
+   (list
+    '(overlay
+      (ellipse 60 30 "solid" "purple")
+      (rectangle 30 60 "solid" "orange"))
+    "19.png")
+   (list
+    '(text/font "not really a link" 18 "blue" #f 'roman 'normal 'normal #t)
+    "18.png")
+   (list
+    '(text/font "Goodbye" 18 "indigo" #f 'modern 'italic 'normal #f)
+    "17.png")
+   (list
+    '(text/font "Hello" 24 "olive" "Gill Sans" 'swiss 'normal 'bold #f)
+    "16.png")
+   (list '(text "Goodbye" 36 "indigo") "15.png")
+   (list '(text "Hello" 24 "olive") "14.png")
+   (list '(star-polygon 20 10 3 "solid" "cornflowerblue") "13.png")
+   (list '(star-polygon 40 7 3 "outline" "darkred") "12.png")
+   (list '(star-polygon 40 5 2 "solid" "seagreen") "11.png")
+   (list '(star 40 "solid" "gray") "10.png")
+   (list '(triangle 40 "solid" "tan") "9.png")
+   (list '(regular-polygon 20 6 "solid" "red") "8.png")
+   (list '(regular-polygon 20 4 "outline" "blue") "7.png")
+   (list '(regular-polygon 30 3 "outline" "red") "6.png")
+   (list '(rectangle 20 40 "solid" 'blue) "5.png")
+   (list '(rectangle 40 20 "outline" 'black) "4.png")
+   (list '(ellipse 20 40 "solid" "blue") "3.png")
+   (list '(ellipse 40 20 "outline" "black") "2.png")
+   (list '(circle 20 "solid" "blue") "1.png")
+   (list '(circle 30 "outline" "red") "0.png")))

collects/teachpack/2htdp/scribblings/image-util.ss

@@ -3,7 +3,9 @@
          scribble/core
          scribble/manual
          scribble/scheme
-         (for-syntax scheme/base))
+         (for-syntax scheme/base)
+         "image-toc.ss")
+
 (provide image-examples
          exp->filename)
 
@@ -38,8 +40,11 @@
                     expr-paras
                     val-list+outputs)))))
 
-(define (exp->filename exp)
-  (regexp-replace*
-   #rx"[() '\\/\"]"
-   (format "~s.png" exp)
-   "_"))
+(define (exp->filename exp) 
+  (let ([fn (assoc exp mapping)])
+    (cond 
+      [fn 
+       (cadr fn)]
+      [else
+       (fprintf (current-error-port) "exp->filename: unknown exp ~s\n" exp)
+       "unk.png"])))

collects/teachpack/2htdp/scribblings/image.scrbl

@@ -104,6 +104,42 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
                   (star-polygon 20 10 3 "solid" "cornflowerblue")]
  
 }
+
+@defproc[(text [string string?] [font-size (and/c integer? (<=/c 1 255))] [color (or/c symbol? string?)])
+         image?]{
+                
+  Constructs an image that draws the given string, using the font size and color.
+                 
+  @image-examples[(text "Hello" 24 "olive")
+                  (text "Goodbye" 36 "indigo")]
+}
+
+@defproc[(text/font [string string?] [font-size (and/c integer? (<=/c 1 255))] [color (or/c symbol? string?)]
+                    [face (or/c string? #f)]
+                    [family (or/c 'default 'decorative 'roman 'script 'swiss 'modern 'symbol 'system)]
+                    [style (or/c 'normal 'italic 'slant)]
+                    [weight (or/c 'normal 'bold 'light)]
+                    [underline? any/c])
+         image?]{
+                
+  Constructs an image that draws the given string, using a complete font specification.
+  
+  The @scheme[face] and the @scheme[family] combine to give the complete typeface. If 
+  @scheme[face] is available on the system, it is used, but if not then a default typeface
+  based on the @scheme[family] is chosen. The @scheme[style] controls if the face is italic
+  or not (under Windows and Mac OS X, @scheme['slant] and @scheme['italic] are the same),
+  the @scheme[weight] controls if it is boldface (or light), and @scheme[underline?]
+  determines if the face is underlined. For more details on these arguments, see @scheme[face%],
+  which ultimately is what this code uses to draw the font.
+                 
+  @image-examples[(text/font "Hello" 24 "olive"
+                             "Gill Sans" 'swiss 'normal 'bold #f)
+                  (text/font "Goodbye" 18 "indigo"
+                             #f 'modern 'italic 'normal #f)
+                  (text/font "not really a link" 18 "blue"
+                             #f 'roman 'normal 'normal #t)]
+}
+
                 
 @section{Overlaying Images}
 
@@ -186,7 +222,11 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
                                  (ellipse 20 70 "solid" "mediumorchid")
                                  (ellipse 20 50 "solid" "darkorchid")
                                  (ellipse 20 30 "solid" "purple")
-                                 (ellipse 20 10 "solid" "indigo"))]
+                                 (ellipse 20 10 "solid" "indigo"))
+                                                                  
+                  (beside/places "baseline"
+                                 (text "ijy" 18 "black")
+                                 (text "ijy" 24 "black"))]
                                  
   
   }