From a744958fd539471315b7515e3e9460af861aa7b7 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 26 Oct 2010 15:25:57 -0500
Subject: [PATCH] added support to the 2htdp/image library for reading files
 when there is no GUI around. currently the support is limited to images that
 can only report their sizes and pinholes and where equal? signals an error
 unless the arguments are eq?.

---
 collects/2htdp/tests/test-image.rkt           | 62 ++++++++++++++++++
 collects/mrlib/image-core-wxme.rkt            | 62 ++++++++++++++++++
 collects/mrlib/image-core.rkt                 | 64 +++----------------
 .../mrlib/private/image-core-snipclass.rkt    | 36 +++++++++++
 collects/mrlib/private/regmk.rkt              | 37 +++++++++++
 collects/wxme/private/compat.rkt              |  4 ++
 6 files changed, 209 insertions(+), 56 deletions(-)
 create mode 100644 collects/mrlib/image-core-wxme.rkt
 create mode 100644 collects/mrlib/private/image-core-snipclass.rkt
 create mode 100644 collects/mrlib/private/regmk.rkt

diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt
index 4bde5b5ddb..dab52101c7 100644
--- a/collects/2htdp/tests/test-image.rkt
+++ b/collects/2htdp/tests/test-image.rkt
@@ -47,6 +47,8 @@
          racket/class
          racket/file
          racket/gui/base
+         racket/port
+         wxme
          rackunit
          (prefix-in 1: htdp/image)
          (only-in lang/htdp-advanced equal~?))
@@ -1970,6 +1972,66 @@
           =>
           #rx"^beside/align")
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  testing the wxme connection for 2htdp/image images
+;;
+
+(let ()
+  (define txt (new text%))
+  (define img1 (overlay (rectangle 100 20 'solid 'red)
+                        (rectangle 20 100 'solid 'red)))
+  (define img2 
+    (put-pinhole 50 
+                 20
+                 (overlay (rectangle 100 20 'solid 'red)
+                          (rectangle 20 100 'solid 'red))))
+
+  (send txt insert "(define img (list ")
+  (send txt insert img1)
+  (send txt insert " ")
+  (send txt insert img2)
+  (send txt insert "))")
+
+  (define sp (open-output-string))
+  (send txt save-port sp)
+  (test (port->string (wxme-port->text-port (open-input-string (get-output-string sp))))
+        =>
+        "(define img (list . .))"))
+
+(let ()
+  (define txt (new text%))
+  (define img1 (overlay (rectangle 100 20 'solid 'red)
+                        (rectangle 20 200 'solid 'red)))
+  (define img2 
+    (put-pinhole 50 
+                 20
+                 (overlay (rectangle 200 20 'solid 'red)
+                          (rectangle 20 100 'solid 'red))))
+  (define img3 (text "Hello" 32 'black))
+
+  (send txt insert "(")
+  (send txt insert img1)
+  (send txt insert " ")
+  (send txt insert img2)
+  (send txt insert " ")
+  (send txt insert img3)
+  (send txt insert ")")
+
+  (define sp (open-output-string))
+  (send txt save-port sp)
+  (define washed (read (wxme-port->port (open-input-string (get-output-string sp)))))
+  (test (list? washed) => #t)
+  (test (map pinhole-x washed) => (list #f 50 #f))
+  (test (map pinhole-y washed) => (list #f 20 #f))
+  (test (image-width (car washed)) => 100)
+  (test (image-height (car washed)) => 200)
+  (test (image-baseline (car washed)) => 200)
+  (test (equal? (image-baseline (list-ref washed 2))
+                (image-height (list-ref washed 2)))
+        =>
+        #f))
+
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/collects/mrlib/image-core-wxme.rkt b/collects/mrlib/image-core-wxme.rkt
new file mode 100644
index 0000000000..88906d33bc
--- /dev/null
+++ b/collects/mrlib/image-core-wxme.rkt
@@ -0,0 +1,62 @@
+#lang racket/base
+(require racket/class
+         wxme
+         "private/image-core-snipclass.rkt"
+         "private/regmk.rkt")
+(provide reader image<%>)
+
+(define guiless-image%
+  (class* object% (equal<%> image<%>)
+    (init-field pinhole bb)
+    (define/public (equal-to? that eq-recur)
+      (cond
+        [(eq? this that) #t]
+        [else (error 'image% "cannot do equality comparison without gui libraries")]))
+    (define/public (equal-hash-code-of y) 42)
+    (define/public (equal-secondary-hash-code-of y) 3)
+
+    (define/public (get-shape)
+      (error 'image% "cannot get-shape without gui libraries"))
+    (define/public (set-shape s)
+      (error 'image% "cannot get-shape without gui libraries"))
+    (define/public (get-bb) bb)
+    (define/public (get-pinhole) pinhole)
+    (define/public (get-normalized?) #f)
+    (define/public (set-normalized? n?) (void))
+    
+    (define/public (get-normalized-shape)
+      (error 'image% "cannot get-normalized-shape without gui libraries"))
+
+    (super-new)))
+
+(define reader
+  (new
+   (class* object% (snip-reader<%>)
+     (define/public (read-header vers stream)
+       (void))
+     (define/public (read-snip text? cvers stream)
+       (let* ([lst (fetch (send stream read-raw-bytes '2htdp/image))])
+         (if text?
+             #"."
+             (let ([marshalled-img (list-ref lst 0)]
+                   [marshalled-bb (list-ref lst 1)]
+                   [marshalled-pinhole (list-ref lst 2)])
+               (new guiless-image%
+                    [bb (if (and (vector? marshalled-bb)
+                                 (= 4 (vector-length marshalled-bb))
+                                 (eq? (vector-ref marshalled-bb 0) 'struct:bb)
+                                 (number? (vector-ref marshalled-bb 1))
+                                 (number? (vector-ref marshalled-bb 2))
+                                 (number? (vector-ref marshalled-bb 3)))
+                            (apply make-bb (cdr (vector->list marshalled-bb)))
+                            (make-bb 100 100 100))]
+                    [pinhole 
+                     (if (and (vector? marshalled-pinhole)
+                              (= 3 (vector-length marshalled-pinhole))
+                              (eq? (vector-ref marshalled-pinhole 0) 'struct:point)
+                              (number? (vector-ref marshalled-pinhole 1))
+                              (number? (vector-ref marshalled-pinhole 2)))
+                         (make-point (vector-ref marshalled-pinhole 1)
+                                     (vector-ref marshalled-pinhole 2))
+                         #f)])))))
+    (super-new))))
diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt
index c7569eb5ac..aab0febfa1 100644
--- a/collects/mrlib/image-core.rkt
+++ b/collects/mrlib/image-core.rkt
@@ -32,34 +32,13 @@ has been moved out).
          racket/math
          racket/contract
          "private/image-core-bitmap.ss"
+         "image-core-wxme.ss"
+         "private/image-core-snipclass.rkt"
+         "private/regmk.rkt"
          (prefix-in cis: "cache-image-snip.ss")
          (for-syntax racket/base))
 
-(define-for-syntax id-constructor-pairs '())
-(define-for-syntax (add-id-constructor-pair a b)
-  (set! id-constructor-pairs (cons (list a b) id-constructor-pairs)))
 
-(define-syntax (define-struct/reg-mk stx)
-  (syntax-case stx ()
-    [(_ id . rest)
-     (let ([build-name
-            (λ (fmt)
-              (datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))])
-       (add-id-constructor-pair (build-name "struct:~a")
-                                (build-name "make-~a"))
-       #'(define-struct id . rest))]))
-
-(define-syntax (define-id->constructor stx)
-  (syntax-case stx ()
-    [(_ fn)
-     #`(define (fn x)
-         (case x
-           #,@(map (λ (x) 
-                     (with-syntax ([(struct: maker) x])
-                       #`[(struct:) maker]))
-                   id-constructor-pairs)))]))
-
-(define-struct/reg-mk point (x y) #:transparent)
 
 
 ;                                                                
@@ -93,15 +72,11 @@ has been moved out).
 (define (set-image-shape! p s) (send p set-shape s))
 (define (set-image-normalized?! p n?) (send p set-normalized? n?))
 (define (image? p) 
-  (or (is-a? p image%)
+  (or (is-a? p image<%>)
       (is-a? p image-snip%)
       (is-a? p bitmap%)))
 
 
-;; a bb is  (bounding box)
-;;  (make-bb number number number)
-(define-struct/reg-mk bb (right bottom baseline) #:transparent)
-
 ;; a shape is either:
 ;;
 ;;  - (make-overlay shape shape)
@@ -219,14 +194,10 @@ has been moved out).
 ;                        ;;   ;                     
 ;                         ;;;;                      
 
-(define-local-member-name
-  get-shape set-shape get-bb get-pinhole 
-  get-normalized? set-normalized get-normalized-shape)
-
 (define skip-image-equality-fast-path (make-parameter #f))
 
 (define image%
-  (class* snip% (equal<%>)
+  (class* snip% (equal<%> image<%>)
     (init-field shape bb normalized? pinhole)
     (define/public (equal-to? that eq-recur)
       (or (eq? this that)
@@ -346,30 +317,13 @@ has been moved out).
 (define image-snipclass% 
   (class snip-class%
     (define/override (read f)
-      (let* ([bytes (send f get-unterminated-bytes)]
-             [str 
-              (and bytes
-                   (with-handlers ((exn:fail? (λ (x) #f)))
-                     (bytes->string/utf-8 bytes)))]
-             [lst 
-              (and str
-                   (with-handlers ((exn:fail:read? (λ (x) #f)))
-                     (parse 
-                      (racket/base:read
-                       (open-input-string
-                        str)))))])
+      (let ([lst (parse (fetch (send f get-unterminated-bytes)))])
         (cond
           [(not lst)
            (make-image (make-ellipse 100 100 0 'solid "black")
                        (make-bb 100 100 100)
                        #f
                        #f)]
-          [(= 2 (length lst))
-           ;; backwards compatibility for saved images that didn't have a pinhole
-           (make-image (list-ref lst 0)
-                       (list-ref lst 1)
-                       #f
-                       #f)]
           [else
            (make-image (list-ref lst 0)
                        (list-ref lst 1)
@@ -379,7 +333,8 @@ has been moved out).
 
 (provide snip-class) 
 (define snip-class (new image-snipclass%))
-(send snip-class set-classname (format "~s" '(lib "image-core.ss" "mrlib")))
+(send snip-class set-classname (format "~s" (list '(lib "image-core.ss" "mrlib")
+                                                  '(lib "image-core-wxme.rkt" "mrlib"))))
 (send snip-class set-version 1)
 (send (get-the-snip-class-list) add snip-class)
 
@@ -406,9 +361,6 @@ has been moved out).
                       (k #f)))]))]
         [else sexp]))))
 
-(define-id->constructor id->constructor)
-
-
 (define (normalized-shape? s)
   (cond
     [(overlay? s)
diff --git a/collects/mrlib/private/image-core-snipclass.rkt b/collects/mrlib/private/image-core-snipclass.rkt
new file mode 100644
index 0000000000..eac28521f1
--- /dev/null
+++ b/collects/mrlib/private/image-core-snipclass.rkt
@@ -0,0 +1,36 @@
+#lang racket/base
+(require racket/class)
+(provide fetch image<%>
+         get-shape set-shape get-bb get-pinhole 
+         get-normalized? set-normalized get-normalized-shape)
+
+(define-local-member-name
+  get-shape set-shape get-bb get-pinhole 
+  get-normalized? set-normalized get-normalized-shape)
+
+(define image<%>
+  (interface ()
+    get-shape set-shape get-bb get-pinhole 
+    get-normalized? get-normalized-shape))
+
+(define (fetch bytes)
+  (let* ([str 
+          (and bytes
+               (with-handlers ((exn:fail? (λ (x) #f)))
+                 (bytes->string/utf-8 bytes)))]
+         [lst (and str
+                   (with-handlers ((exn:fail:read? (λ (x) #f)))
+                     (racket/base:read
+                      (open-input-string
+                       str))))])
+    (cond
+      [(and (list? lst)
+            (= 2 (length lst)))
+       ;; backwards compatibility for saved images that didn't have a pinhole
+       (list (list-ref lst 0)
+             (list-ref lst 1)
+             #f)]
+      [else
+       lst])))
+
+(define racket/base:read read)
diff --git a/collects/mrlib/private/regmk.rkt b/collects/mrlib/private/regmk.rkt
new file mode 100644
index 0000000000..59510a4365
--- /dev/null
+++ b/collects/mrlib/private/regmk.rkt
@@ -0,0 +1,37 @@
+#lang racket
+(provide define-struct/reg-mk
+         id->constructor 
+         (struct-out point)
+         (struct-out bb))
+
+(define-for-syntax id-constructor-pairs '())
+(define-for-syntax (add-id-constructor-pair a b)
+  (set! id-constructor-pairs (cons (list a b) id-constructor-pairs)))
+
+(define-syntax (define-struct/reg-mk stx)
+  (syntax-case stx ()
+    [(_ id . rest)
+     (let ([build-name
+            (λ (fmt)
+              (datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))])
+       (add-id-constructor-pair (build-name "struct:~a")
+                                (build-name "make-~a"))
+       #'(define-struct id . rest))]))
+
+(define-syntax (define-id->constructor stx)
+  (syntax-case stx ()
+    [(_ fn)
+     #`(define (fn x)
+         (case x
+           #,@(map (λ (x) 
+                     (with-syntax ([(struct: maker) x])
+                       #`[(struct:) maker]))
+                   id-constructor-pairs)))]))
+
+(define-id->constructor id->constructor)
+
+(define-struct/reg-mk point (x y) #:transparent)
+
+;; a bb is  (bounding box)
+;;  (make-bb number number number)
+(define-struct/reg-mk bb (right bottom baseline) #:transparent)
diff --git a/collects/wxme/private/compat.rkt b/collects/wxme/private/compat.rkt
index 677c471247..f16f7ed98f 100644
--- a/collects/wxme/private/compat.rkt
+++ b/collects/wxme/private/compat.rkt
@@ -38,6 +38,10 @@
     (register-lib-mapping!
      "(lib \"cache-image-snip.ss\" \"mrlib\")"
      '(lib "cache-image.ss" "wxme"))
+    
+    (register-lib-mapping!
+     "(lib \"image-core.ss\" \"mrlib\")"
+     '(lib "image-core-wxme.rkt" "wxme"))
 
     (register-lib-mapping!
      "test-case-box%"