From 342290e520a7733aec955a273c6c8c86d004272e Mon Sep 17 00:00:00 2001
From: Matthias Felleisen <matthias@racket-lang.org>
Date: Wed, 19 Dec 2007 17:44:57 +0000
Subject: [PATCH] matrix

svn: r8066
---
 collects/mrlib/matrix-snip.ss | 97 +++++++++++++++++++++++++++++++++++
 1 file changed, 97 insertions(+)
 create mode 100644 collects/mrlib/matrix-snip.ss

diff --git a/collects/mrlib/matrix-snip.ss b/collects/mrlib/matrix-snip.ss
new file mode 100644
index 0000000000..310a7d083a
--- /dev/null
+++ b/collects/mrlib/matrix-snip.ss
@@ -0,0 +1,97 @@
+#lang scheme 
+
+(require (lib "class.ss")
+         (lib "string.ss")
+         (lib "cache-image-snip.ss" "mrlib"))
+
+(provide visible-matrix%
+         matrix-snip-class%
+         (rename-out (matrix-snip-class snip-class))
+         v?
+         v-m
+         matrix<%>
+         build-bitmap ;; from cache-image-snip
+         overlay-bitmap
+         )
+
+(define matrix<%> 
+  (interface ()
+    ->rectangle ;; -> [Listof [Listof X]]
+    ))
+
+(define visible-matrix<%> 
+  (interface ()
+    get-M ;; -> matrix<%> u [Listof [Listof X]]
+    ))
+
+;; ---------------------------------------------------------------------------
+
+(define (v-m VM) (send VM get-M))
+(define (v? VM) (is-a? VM visible-matrix%))
+
+;; 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)
+    (inherit-field dc-proc argb-proc width height argb px py)
+    
+    (init M_0)
+    (field 
+     [M (if (is-a? M_0 matrix<%>) M_0 #f)]
+     [R (cond
+          [M #f]
+          [(pair? M_0) M_0]
+          [else
+           (error 'visible% "expects matrix or rectangle, given: ~e" M_0)])])
+                  
+    (define/public (get-M) (if M M R))
+    
+    ;; create a matrix from this instance 
+    (define/override (copy)
+      (new visible-matrix%
+           (M_0 (get-M)) (dc-proc dc-proc) (argb-proc argb-proc)
+           (width width) (height height) (px px) (py py) (argb argb)))
+
+    (define/private (->s-expr)
+      (list (if R R (send M ->rectangle))
+            (list (argb-vector (get-argb)) width px py)))
+    
+    (define/override (write f)
+      (define x (format "~s" (->s-expr)))
+      (define y (string->bytes/utf-8 x))
+      (send f put y))
+    
+    (super-new)
+    (set-snipclass matrix-snip-class)))
+
+;; the snip class for matricies 
+(define matrix-snip-class% 
+  (class cache-image-snip-class% 
+    (super-new)
+    (define/override (read f)
+      (define b (send f get-bytes))
+      (data->snip (read-from-string b (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 (car data))
+      ;; .. but we need to produce a visible-matrix% instead
+      (new visible-matrix% 
+           (M_0 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)