svn: r7983

collects/htdp/matrix-client.ss

@@ -0,0 +1,83 @@
+;; The first three lines of this file were inserted by DrScheme. They record metadata
+;; about the language level of this file in a form that our tools can easily process.
+#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname matrix-client) (read-case-sensitive #t) (teachpacks ((lib "world.ss" "teachpack" "htdp") (lib "testing.ss" "teachpack" "htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "world.ss" "teachpack" "htdp") (lib "testing.ss" "teachpack" "htdp")))))
+(require (lib "matrix.ss" "htdp"))
+(require (lib "testing.ss" "htdp"))
+
+(define m1 (make-matrix 2 3 (list 'a 'b 'c 'd 'e 'f)))
+(define m2 (matrix-set m1 1 1 'x))
+
+(check-expect (matrix-ref m1 0 0) 'a)
+(check-expect (matrix-ref m1 0 1) 'b)
+(check-expect (matrix-ref m1 0 2) 'c)
+(check-expect (matrix-ref m1 1 0) 'd)
+(check-expect (matrix-ref m1 1 1) 'e)
+(check-expect (matrix-ref m1 1 2) 'f)
+
+(check-expect (matrix-ref m2 1 1) 'x)
+
+(define matrix1 (make-matrix 2 3 '(a00 a01 a02 a10 a11 a12)))
+
+(define r1 '((a00 a01 a02)
+             (a10 a11 a12)))
+
+(check-expect (matrix-render matrix1) (matrix-render (rectangle->matrix r1)))
+(check-expect (matrix-ref matrix1 0 0) 'a00)
+(check-expect (matrix-ref matrix1 0 1) 'a01)
+(check-expect (matrix-ref matrix1 0 2) 'a02)
+(check-expect (matrix-ref matrix1 1 0) 'a10)
+(check-expect (matrix-ref matrix1 1 1) 'a11)
+(check-expect (matrix-ref matrix1 1 2) 'a12)
+
+(check-expect (matrix-render (build-matrix 2 3 (lambda (i j) (matrix-ref matrix1 i j))))
+              (matrix-render matrix1))
+
+(define matrix2 (make-matrix 2 2 '(a00 a01 a10 a11)))
+
+(check-expect (matrix-render (matrix-minor matrix2 0 0))
+              (matrix-render (make-matrix 1 1 '(a11))))
+
+(check-expect (matrix-render (matrix-minor matrix2 1 1))
+              (matrix-render (make-matrix 1 1 '(a00))))
+
+;; ===========================================================================
+
+;; Matrix -> Number 
+;; compute the determinat of a square (n x n) matrix 
+(define (determinant M)
+  (local 
+    ((define n (matrix-n M))
+     (define (series i)
+       (* (expt -1 i) (matrix-ref M 0 i) (determinant (matrix-minor M 0 i)))))
+    (if (= n 1)
+        (matrix-ref M 0 0)
+        (foldl + 0 (build-list n series)))))
+
+
+
+(check-expect (determinant (rectangle->matrix '((1 1)
+                                                (1 1))))
+              0)
+
+(check-expect (determinant (rectangle->matrix '((2 1)
+                                                (1 1))))
+              1)
+
+;; ===========================================================================
+;; matrix with structure inside 
+
+(define-struct p (x y))
+
+(define matrix3 
+  (rectangle->matrix 
+   (list (list (make-p 0 0) (make-p 0 1))
+         (list (make-p 1 0) (make-p 1 1)))))
+
+(define matrix4 (matrix-set matrix3 0 0 "intentionally failing check"))
+
+(check-expect matrix3 matrix3)
+
+(check-expect matrix3 matrix4)
+"the above test should fail"
+
+(generate-report)

collects/htdp/matrix-invisible.ss

@@ -0,0 +1,23 @@
+#lang scheme
+
+(require (lib "matrix-sig.ss" "htdp")
+         (lib "matrix-unit.ss" "htdp")
+         (lib "matrix-render.ss" "htdp"))
+
+(define render@
+  (unit (import)
+        (export matrix-render^)
+        (define-struct invisible (matrix))
+        (define make-visible make-invisible)
+        (define visible-matrix invisible-matrix)))
+
+(define invisible-matrix@
+  (compound-unit
+    (import)
+    (export m)
+    (link (((r : matrix-render^)) render@)
+          (((m : matrix^)) matrix@ r))))
+
+(define-values/invoke-unit invisible-matrix@ (import) (export matrix^))
+
+(provide-signature-elements matrix^)

collects/htdp/matrix-render.ss

@@ -0,0 +1,6 @@
+#lang scheme/signature 
+
+;; type: [VM X]
+make-visible    ;; [Matrix X] -> [VM X]
+
+visible-matrix  ;; [VM X] -> [Matrix M]

collects/htdp/matrix-sig.ss

@@ -0,0 +1,49 @@
+#lang scheme/signature
+
+;; CONVENTION: 
+;; [Rectangle X] = [Listof [Listof X]] 
+;;  where all elements of the non-empty list are of equal non-empty length
+
+;; type: [Matrix X]
+matrix? 
+;; is this a matrix?
+
+matrix-n ;; [Matrix X] -> Nat 
+;; what is n for an n x m Matrix 
+
+matrix-m ;; [Matrix X] -> Nat 
+;; what is m for an n x m Matrix 
+
+rectangle->matrix ;; [Rectangle X] -> [Matrix X]
+;; create a matrix from a rectangle 
+
+matrix->rectangle ;; [Matrix X] -> [Rectangle X]
+;; create a rectangle from matrix
+
+;; ----------------------------------------------------------------------------
+
+make-matrix ;; Nat Nat [Listof X] -> [Matrix X]
+;; create an initialized n x m matrix from list l
+;; NOTE: make-matrix would consume an optional number of entries, 
+;; if it were like make-vector  
+
+build-matrix ;; Nat Nat (Nat Nat -> Number) -> Matrix 
+;; create a matrix from a function 
+
+matrix-ref ;; [Matrix X] Nat Nat -> X
+;; retrieve the content of the matrix at (i,j)
+
+matrix-set ;; [Matrix X] Nat Nat X -> [Matrix X]
+;; create a new matrix with x at (i,j) and all other places the same 
+
+matrix-where? ;; [Matrix X] (X -> Boolean) -> [Listof Posn]
+;; (matrix-where? M P) :: list of (make-posn i j) s.t. (P (matrix-ref M i j))
+
+matrix-render ;; [Matrix X] -> [Rectangle String]
+;; render the matrix as a rectangle of strings 
+
+matrix-minor ;; Matrix Nat Nat -> Matrix 
+;; create a matrix minor from M at (i,j)
+
+matrix-set! ;; [Matrix X] Nat Nat X -> [Matrix X]
+;; set the matrix at (i,j)

collects/htdp/matrix-unit.ss

@@ -0,0 +1,255 @@
+#lang scheme/unit
+
+(require (lib "matrix-sig.ss" "htdp")
+         (lib "matrix-render.ss" "htdp")
+         (lib "error.ss" "htdp")
+         (lib "posn.ss" "lang")
+         (lib "class.ss")
+         (lib "pconvert.ss")
+         (lib "pretty.ss"))
+
+(import matrix-render^)
+(export matrix^)
+
+
+(define (matrix-mixin% s%)
+  (class s%
+    (init-field n m mat)
+    ;; [InnerMatrix X] = Nat x Nat x [vectorof X] 
+    ;; s.t. (= (* n m)(vector-length vector))
+    (super-new)))
+
+;; [Matrix X] = [BST X]
+(define bmatrix% (matrix-mixin% object%))
+
+(define (create-matrix n m mat) 
+  (new bmatrix% [n n] [m m] [mat mat]))
+
+(define matrix-get-mat (class-field-accessor bmatrix% mat))
+(define matrix-get-n (class-field-accessor bmatrix% n))
+(define matrix-get-m (class-field-accessor bmatrix% m))
+
+(define-struct imatrix (left i j info right) #:transparent)
+(define (set-imatrix-left n x)
+  (make-imatrix x (imatrix-i n) (imatrix-j n) (imatrix-info n) (imatrix-right n)))
+(define (set-imatrix-right n x)
+  (make-imatrix (imatrix-left n) (imatrix-i n) (imatrix-j n) (imatrix-info n) x))
+(define (set-imatrix-info n x)
+  (make-imatrix (imatrix-left n) (imatrix-i n) (imatrix-j n) x (imatrix-right n)))
+
+;; [BST X] = [InnerMatrix X] | (make-imatrix [BST X] Nat Nat X [BST X])
+
+;; Nat Nat Nat Nat -> Boolean
+(define (bst-< i j imatrix-i imatrix-j)
+  (or (< i imatrix-i) (and (= i imatrix-i) (< j imatrix-j))))
+
+;; Nat Nat Nat Nat -> Boolean
+(define (bst-= i j imatrix-i imatrix-j)
+  (and (= i imatrix-i) (= j imatrix-j)))
+
+;; Nat Nat Nat Nat -> Boolean
+(define (bst-> i j imatrix-i imatrix-j)
+  (not (or (bst-< i j imatrix-i imatrix-j) (bst-= i j imatrix-i imatrix-j))))
+
+;; bst-insert : [BST X] Nat Nat X -> [BST X]
+(define (bst-insert t i j x)
+  (cond
+    [(imatrix? t)
+     (cond
+       [(bst-< i j (imatrix-i t) (imatrix-j t)) (set-imatrix-left t (bst-insert (imatrix-left t) i j x))]
+       [(bst-= i j (imatrix-i t) (imatrix-j t)) (set-imatrix-info t x)]
+       [else ;; (bst-< i j (imatrix-i t) (imatrix-j t)) 
+        (set-imatrix-right t (bst-insert (imatrix-right t) i j x))])]
+    [else (make-imatrix t i j x t)]))
+
+;; bst-lookup : [BST X] Nat Nat -> X
+(define (bst-lookup t i j)
+  (cond
+    [(imatrix? t)
+     (cond
+       [(bst-< i j (imatrix-i t) (imatrix-j t)) (bst-lookup (imatrix-left t) i j)]
+       [(bst-= i j (imatrix-i t) (imatrix-j t)) (imatrix-info t)]
+       [else (bst-lookup (imatrix-left t) i j)])]
+    [else (inner-ref (matrix-get-mat t) (matrix-get-m t) i j)]))
+
+
+
+;                                                   
+;                                                   
+;  ;;;;;;                                           
+;   ;   ;                               ;           
+;   ; ;   ;;  ;; ;; ;;    ;;;   ;; ;;  ;;;;;   ;;;; 
+;   ;;;    ;  ;   ;;  ;  ;   ;   ;;     ;     ;   ; 
+;   ; ;     ;;    ;   ;  ;   ;   ;      ;      ;;;  
+;   ;       ;;    ;   ;  ;   ;   ;      ;         ; 
+;   ;   ;  ;  ;   ;   ;  ;   ;   ;      ;   ; ;   ; 
+;  ;;;;;; ;;  ;;  ;;;;    ;;;   ;;;;;    ;;;  ;;;;  
+;                 ;                                 
+;                ;;;                                
+;                                                   
+;                                                   
+
+(define (matrix? x) (or (is-a? x bmatrix%) (imatrix? x)))
+
+(define (matrix-n M*)
+  (define-values (M n m) (check-matrix 'matrix-n M* 0 0))
+  n)
+
+(define (matrix-m M*)
+  (define-values (M n m) (check-matrix 'matrix-n M* 0 0))
+  m)
+
+(define (rectangle->matrix r)
+  ;; check rectangleness of r 
+  (define n (length r))
+  (define m (length (car r)))
+  (make-matrix n m (apply append r)))
+
+(define (matrix->rectangle M*)
+  (define-values (M n m) (check-matrix 'matrix->rectangle M* 0 0))
+  (build-list n (lambda (i) (build-list m (lambda (j) (matrix-ref M i j))))))
+
+;; -------------------------------------------------------------------------
+
+(define (make-matrix n m l)
+  (check-arg 'make-matrix (natural? n) 'Nat "first" n)
+  (check-arg 'make-matrix (natural? m) 'Nat "second" m)
+  (check-arg 'make-matrix (list? l) 'list "third" l)
+  (check-arg 'make-matrix (= (length l) (* n m)) 
+             (format "list of length ~a given, expected ~a items" 
+                     (length l)
+                     (* n m))
+             "third" l)
+  (make-visible
+   (let ([mat (make-vector (* n m) 0)])
+     (let loop ([l l][i 0][j 0])
+       (cond
+         [(null? l) (create-matrix n m mat)]
+         [else (begin (vector-set! mat (+ (* i m) j) (car l))
+                      (if (< j (- m 1))
+                          (loop (cdr l) i (+ j 1))
+                          (loop (cdr l) (+ i 1) 0)))])))))
+
+(define (build-matrix n m f)
+  (check-arg 'make-matrix (natural? n) 'Nat "first" n)
+  (check-arg 'make-matrix (natural? m) 'Nat "second" m)
+  (check-proc 'make-matrix f 2 "third" "2 arguments")
+  (build-matrix-aux n m f))
+(define (build-matrix-aux n m f)
+  (define ns (build-list n (lambda (x) x)))
+  (define ms (build-list m (lambda (x) x)))
+  (define ** 
+    (apply append (map (lambda (i) (map (lambda (j) (f i j)) ms)) ns)))
+  (make-matrix n m **))
+
+(define (matrix-ref M* i j)
+  (define-values (M n m) (check-matrix 'matrix-ref M* i j))
+  (bst-lookup M i j))
+
+(define (matrix-set M* i j x)
+  (define-values (M m n) (check-matrix 'matrix-set M* i j))
+  (make-visible (bst-insert M i j x)))
+
+(define (matrix-render M*)
+  (define-values (M n m) (check-matrix 'matrix-render M* 0 0))
+  (define (make-row i)
+    (let loop ([j 0])
+      (if (= j m)
+          '()
+          (cons (element->string (matrix-ref M i j)) (loop (+ j 1))))))
+  (let loop ([i 0])
+    (if (= i n) '() (cons (make-row i) (loop (+ i 1))))))
+
+(define (matrix-where? M* pred?)
+  (define-values (M n m) (check-matrix 'matrix-where? M* 0 0))
+  (define (select-from-row i)
+    (define (select-cell j)
+      (if (pred? (matrix-ref M i j)) (make-posn i j) #f))
+    (filter posn? (build-list m select-cell)))
+  (apply append (build-list n select-from-row)))
+
+(define (matrix-minor M* i j)
+  (define-values (M n m) (check-matrix 'matrix-minor M* i j))
+  (build-matrix (- n 1) (- m 1) 
+                (lambda (i* j*) 
+                  (cond
+                    [(< i* i) 
+                     (cond 
+                       [(< j* j) (matrix-ref M i* j*)]
+                       [(>= j* j) (matrix-ref M i* (+ j* 1))])]
+                    [(>= i* i)
+                     (cond 
+                       [(< j* j) (matrix-ref M (+ i* 1) j*)]
+                       
+                       [(>= j* j) (matrix-ref M (+ i* 1) (+ j* 1))])]))))
+
+(define (matrix-set! M* i j x)
+  (define _ (when (imatrix? M)
+              (error 'matrix-set! "use functional updates instead")))
+  (define-values (M n m) (check-matrix 'matrix-ref M* i j))
+  (vector-set! (matrix-get-mat M) (+ (* i m) j) x)
+  M)
+
+;                              
+;                              
+;    ;;                        
+;     ;                        
+;    ; ;  ;;  ;; ;;  ;;   ;;;; 
+;    ; ;   ;   ;  ;  ;   ;   ; 
+;    ; ;   ;   ;   ;;     ;;;  
+;   ;;;;;  ;   ;   ;;        ; 
+;   ;   ;  ;  ;;  ;  ;   ;   ; 
+;  ;;; ;;;  ;; ;;;;  ;;  ;;;;  
+;                              
+;                              
+;                              
+;                              
+
+;; [Vectorof X] Nat Nat Nat -> Nat 
+;; the internal referencing for element (i,j) in an _ x m matrix 
+(define (inner-ref V m i j)
+  (vector-ref V (+ (* i m) j)))
+
+;; X -> String 
+;; okay, not X, something renderable via constructor style printing
+(define (element->string value)
+  (parameterize ([constructor-style-printing #t]
+                 [pretty-print-columns 40])
+    (let ([value1 0]
+          [text* (open-output-string)])
+      (pretty-print (print-convert value) text*)
+      (close-output-port text*)
+      (let* ([s (get-output-string text*)]
+             [l (string->list s)]
+             [x (reverse l)])
+        (if (char=? (car x) #\newline)
+            (list->string (reverse (cdr x)))
+            s)))))
+
+;; Symbol [Matrix X] Nat Nat ->* [Vectorof X] Nat Nat 
+;; contract checking for teaching languages; compute properties of matrix
+(define (check-matrix tag M* i j)
+  (define M (if (matrix? M*) M* (visible-matrix M*)))
+  (check-arg tag (matrix? M) 'matrix "first" M)
+  (check-arg tag (natural? i) 'Nat "second" i)
+  (check-arg tag (natural? j) 'Nat "third" j)
+  ;; --- now that M is a matrix, i and j are natural numbers:
+  (check-aux tag M i j))
+(define (check-aux tag M* i j)
+  (define M (let loop ([M M*]) (if (imatrix? M) (loop (imatrix-left M)) M)))
+  (define n (matrix-get-n M))
+  (define m (matrix-get-m M))
+  ;; i and j have to be in Nat
+  (unless (< -1 i n)
+    (error tag "~ax~a matrix given, can't index into ~a~a row" n m i (th i)))
+  (unless (< -1 j m)
+    (error tag "~ax~a matrix given, can't index into ~a~a column" n m j (th j)))
+  (values M* n m))
+
+;; Nat -> String 
+(define (th n)
+  (cond
+    [(= n 1) "st"]
+    [(= n 2) "nd"]
+    [(> n 3) "th"]
+    [else (error 'th "can't happen")]))

collects/htdp/matrix.ss

@@ -0,0 +1,209 @@
+#lang scheme
+
+;; 4. integrate with snips
+
+(require (lib "matrix-sig.ss" "htdp")
+         (lib "matrix-unit.ss" "htdp")
+         (lib "matrix-render.ss" "htdp"))
+
+(require (lib "class.ss")
+         (lib "string.ss")
+         (lib "mred.ss" "mred")
+         (lib "cache-image-snip.ss" "mrlib"))
+
+(define matrix-snip-class 'missing)
+(define matrix-snip-class% 'missing)
+
+;; ---------------------------------------------------------------------------
+(provide (rename-out (matrix-snip-class snip-class))
+         matrix-snip-class%)
+
+(define render@
+  (unit (import matrix^)
+        (export matrix-render^)
+        
+        ;; representing a matrix that renders itself as an image, as in image.ss
+        (define visible-matrix%
+          (class cache-image-snip%
+            (inherit set-snipclass get-argb)
+            (init-field M)
+            (inherit-field dc-proc argb-proc width height argb px py)
+            
+            ;; create a matrix from this instance 
+            (define/override (copy)
+              (new visible-matrix%
+                   (M M)
+                   (width width) (height height) (px px) (py py) (argb argb)
+                   (dc-proc dc-proc)
+                   (argb-proc argb-proc)))
+            
+            (define/override (write f)
+              (let ([str (string->bytes/utf-8
+                          (format "~s"
+                                  (list (matrix->rectangle M)
+                                        (list (argb-vector (get-argb))
+                                              width
+                                              px 
+                                              py))))])
+                (send f put str)))
+            
+            (super-new)
+            (set-snipclass matrix-snip-class)))
+        
+        (define visible-matrix (class-field-accessor visible-matrix% M))
+        
+        ;; the snip class for matricies 
+        (define matrix-snip-class% 
+          (class cache-image-snip-class% 
+            (super-new)
+            (define/override (read f)
+              (data->snip (read-from-string (send f get-bytes) (lambda () #f))))
+            (define/override (data->snip data) 
+              (define _ (unless data (error 'read "in matrix-snip-class% failed")))
+              (define new-cache-image-snip (super data->snip (cadr data)))
+              (define-values (w h) (send new-cache-image-snip get-size))
+              (define M (rectangle->matrix (car data)))
+              ;; .. but we need to produce a visible-matrix% instead 
+              (new visible-matrix% 
+                   (M M)
+                   (dc-proc (send new-cache-image-snip get-dc-proc))
+                   (argb-proc (send new-cache-image-snip get-argb-proc))
+                   (width w)
+                   (height h)
+                   (argb (get-argb new-cache-image-snip))
+                   (px (get-px new-cache-image-snip))
+                   (py (get-py new-cache-image-snip))))))
+        (define get-argb (class-field-accessor cache-image-snip% argb))
+        (define get-px (class-field-accessor cache-image-snip% px))
+        (define get-py (class-field-accessor cache-image-snip% py))
+        
+        ;; setting up the 'snip class' 
+        (define matrix-snip-class (new matrix-snip-class%))
+        (send matrix-snip-class set-version 1)
+        (send matrix-snip-class set-classname (format "~s" `(lib "matrix.ss" "htdp")))
+        (send the-drscheme-snip-class #;(get-the-snip-class-list) add matrix-snip-class)
+        
+        ;; the graphical stuff follows  .. it is code based on image.ss 
+        ;; Matrix -> VisibleMatrix
+        (define (make-visible M)
+          (define S (matrix-render M))
+          (define indent 3)
+          (define xspan 3)
+          (define-values (row-heights col-widths) (text-sizes S))
+          (define th ;; total height of matrix: 2 lines plus the text height
+            (+ 2 (apply + row-heights)))
+          (define tw ;; total width of matrix: 2 identations, n xspans
+            (+ 1 (* 2 indent) (apply + col-widths) (* (length col-widths) xspan)))
+          ;; 
+          (define (draw-proc mode dc dx dy)
+            [define old-mode (send dc get-text-mode)]
+            [define old-fore (send dc get-text-foreground)]
+            [define old-font (send dc get-font)]
+            (send dc set-text-mode mode)
+            (send dc set-text-foreground COLOR)
+            (send dc set-font (get-font SIZE))
+            ;; --- left bracket 
+            (send dc draw-line dx dy (+ dx indent) dy)
+            (send dc draw-line dx (+ dy th -1) (+ dx indent) (+ dy th -1))
+            (send dc draw-line dx dy dx (+ dy th -1))
+            ;; --- right bracket 
+            (send dc draw-line (+ dx tw (- indent) -1) dy (+ dx tw -1) dy)
+            (send dc draw-line (+ dx tw (- indent) -1) (+ dy th -1) (+ dx tw -1) (+ dy th -1))
+            (send dc draw-line (+ dx tw -1) dy (+ dx tw -1) (+ dy th -1))
+            ;; --- draw all matrix cells 
+            (draw-matrix S dc dx dy indent xspan col-widths row-heights)
+            (send dc set-text-mode old-mode)
+            (send dc set-text-foreground old-fore)
+            (send dc set-font old-font))
+          ;; 
+          (define (argb-proc argb dx dy)
+            (define (bm-color-builder dc)
+              (define p (send the-pen-list find-or-create-pen "black" 1 'transparent))
+              (define b (send the-brush-list find-or-create-brush COLOR 'solid))
+              (send dc set-pen p)
+              (send dc set-brush b)
+              (send dc draw-rectangle 0 0 tw th))
+            (define bm-color (build-bitmap bm-color-builder tw th))
+            (define(bm-mask-builder dc) (draw-proc 'solid dc 0 0))
+            (define bm-mask (build-bitmap bm-mask-builder tw th))
+            (overlay-bitmap argb dx dy bm-color bm-mask))
+          (new visible-matrix%
+               [M M]
+               [width tw] [height th] [px 0] [py 0]
+               [dc-proc (lambda (dc dx dy) (draw-proc 'transparent dc dx dy))]
+               [argb-proc argb-proc]))
+        
+        ;; [Rectangle String] DC Nat Nat Nat Nat [Listof Nat] [Listof Nat] -> Void
+        (define (draw-matrix S dc dx dy indent xspan col-widths row-heights)
+          (define dx0 dx)
+          (for-each (lambda (row deltay)
+                      (set! dx (+ dx0 2 indent))
+                      (for-each (lambda (str deltax)
+                                  (draw-centrally dc str dx dy deltax deltay)
+                                  (set! dx (+ deltax xspan dx)))
+                                row col-widths)
+                      (set! dy (+ 2 deltay dy)))
+                    S row-heights))
+        
+        ;; basic constants 
+        (define SIZE 12)
+        (define COLOR (send the-color-database find-color "black"))
+        
+        ;; String Nat Nat Nat Nat -> Void
+        ;; draw str centrally into a (deltax x deltay) rectangle of dc 
+        ;; whose upper-left position is (dx,dy)
+        (define (draw-centrally dc str dx dy deltax deltay)
+          (define-values (w h) (get-text-size SIZE str))
+          (define dx* (+ dx (quotient (- deltax w) 2)))
+          (define dy* (+ dy (quotient (- deltay h) 2)))
+          (send dc draw-text str dx* dy*))
+        
+        ;; [Rectangle String] ->* [Listof Nat] [Listof Nat]
+        ;; determine the height of each row and the width of each column
+        (define (text-sizes S)
+          (define S-sizes 
+            (map (lambda (row)
+                   (map (lambda (cell) 
+                          (define-values (tw th) (get-text-size SIZE cell))
+                          (list tw th))
+                        row))
+                 S))
+          (define row-heights (map (lambda (r) (apply max (map cadr r))) S-sizes))
+          (define col-widths
+            (let loop ([S-sizes S-sizes])
+              (if (andmap null? S-sizes)
+                  '()
+                  (cons (apply max (map car (map car S-sizes)))
+                        (loop (map cdr S-sizes))))))
+          (values row-heights col-widths))
+        
+        ;; --- copied from image.ss --- needs refactoring
+        (define (get-text-size size string)
+          (unless (thread-cell-ref cached-bdc-for-text-size)
+            (let* ([bm (make-object bitmap% 1 1)]
+                   [dc (make-object bitmap-dc% bm)])
+              (thread-cell-set! cached-bdc-for-text-size dc)))
+          (let ([dc (thread-cell-ref cached-bdc-for-text-size)])
+            (let-values ([(w h _1 _2) (send dc get-text-extent string (get-font size))])
+              (values (inexact->exact (ceiling w)) 
+                      (inexact->exact (ceiling h))))))
+        
+        (define (get-font size)
+          (send the-font-list find-or-create-font size
+                'default 'normal 'normal #f
+                (case (system-type)
+                  [(macosx) 'partly-smoothed]
+                  [else 'smoothed])))
+        
+        (define cached-bdc-for-text-size (make-thread-cell #f))))
+
+(define invisible-matrix@
+  (compound-unit
+    (import)
+    (export m r)
+    (link (((r : matrix-render^)) render@ m)
+          (((m : matrix^)) matrix@ r))))
+
+(define-values/invoke-unit invisible-matrix@ (import) (export matrix^))
+
+(provide-signature-elements matrix^)