suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

matrix

Browse Source 
svn: r8068
This commit is contained in:
Matthias Felleisen 2007-12-19 17:48:55 +00:00
parent deca1bd57f
commit 98c57e31df
9 changed files with 1659 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1478
collects/htdp/Test/matrix-example.ss Normal file
View File

File diff suppressed because it is too large Load Diff

59
collects/htdp/Test/matrix-test.ss Normal file
View File

@ -0,0 +1,59 @@
;; 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-test) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
; (require (lib "matrix-invisible.ss" "htdp"))
(require (lib "matrix.ss" "htdp"))
(require (lib "testing.ss" "htdp"))
(define r1 '((a00 a01 a02)
(a10 a11 a12)))
(define m1 (rectangle->matrix r1))
(check-expect (matrix? m1) true)
(check-expect (matrix-rows m1) 2)
(check-expect (matrix-cols m1) 3)
(check-expect (matrix->rectangle m1) r1)
(define x (random 2))
(define y (random 3))
(check-expect (matrix-ref (make-matrix 2 3 '(a00 a01 a02 a10 a11 a12)) x y)
(matrix-ref m1 x y))
(check-expect
(matrix-ref (build-matrix 2 3 (lambda (row col) (matrix-ref m1 row col))) x y)
(matrix-ref m1 x y))
(define lpons (list (make-posn 0 0)
(make-posn 1 0)
(make-posn 0 1)
(make-posn 1 2)
(make-posn 1 1)
(make-posn 0 2)))
(define m2
(foldl (lambda (x m) (matrix-set m (posn-x x) (posn-y x) 1)) m1 lpons))
(check-expect 1 (matrix-ref m2 (random 2) (random 3)))
(define (is1 x) (= x 1))
(check-expect (matrix-where? m2 is1)
(list (make-posn 0 0) (make-posn 0 1) (make-posn 0 2)
(make-posn 1 0) (make-posn 1 1) (make-posn 1 2)))
(define (is2 x) (= x 2))
(check-expect (matrix-where? m2 is2) empty)
(define m1-minor (matrix-minor m1 1 1))
(check-expect (matrix-ref m1-minor 0 0) 'a00)
(check-expect (matrix-ref m1-minor 0 1) 'a02)
;; --- IMPERATIVE ---
(check-expect (matrix-ref m1 0 0) 'a00)
(define m1-modified (matrix-set! m1 0 0 'xxx))
(check-expect (matrix-ref m1 0 0) 'xxx)
(generate-report)

4
collects/htdp/info.ss
View File

@ -3,6 +3,6 @@
(define compile-omit-files
'("hangman-world.ss" "hangman-world-play.ss"
;; TEMPORARY DISABLE THESE FILES UNTIL FIXED
"matrix.ss" "matrix-client.ss" "matrix-invisible.ss"
"matrix-render.ss" "matrix-sig.ss" "matrix-unit.ss"
;; "matrix.ss" "matrix-client.ss" "matrix-invisible.ss"
;; "matrix-render-sig.ss" "matrix-sig.ss" "matrix-unit.ss"
)))

4
collects/htdp/matrix-invisible.ss
View File

@ -1,8 +1,8 @@
#lang scheme
(require (lib "matrix-sig.ss" "htdp")
(lib "matrix-unit.ss" "htdp")
(lib "matrix-render.ss" "htdp"))
(lib "matrix-render-sig.ss" "htdp")
(lib "matrix-unit.ss" "htdp"))
(define render@
(unit (import)

0
collects/htdp/matrix-render.ss → collects/htdp/matrix-render-sig.ss
View File

10
collects/htdp/matrix-sig.ss
View File

@ -8,11 +8,11 @@
matrix?
;; is this a matrix?
matrix-n ;; [Matrix X] -> Nat
;; what is n for an n x m Matrix
matrix-rows ;; [Matrix X] -> Nat
;; how many rows does this matrix have?
matrix-m ;; [Matrix X] -> Nat
;; what is m for an n x m Matrix
matrix-cols ;; [Matrix X] -> Nat
;; how many columns does this matrix have?
rectangle->matrix ;; [Rectangle X] -> [Matrix X]
;; create a matrix from a rectangle
@ -46,4 +46,4 @@ 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)
;; set the matrix at (i,j)

113
collects/htdp/matrix-unit.ss
View File

@ -1,16 +1,26 @@
#lang scheme
#lang scheme/unit
(require (lib "matrix-sig.ss" "htdp")
(lib "matrix-render.ss" "htdp")
(lib "matrix-render-sig.ss" "htdp")
(lib "matrix-snip.ss" "mrlib")
(lib "error.ss" "htdp")
(lib "posn.ss" "lang")
(lib "class.ss")
(lib "pconvert.ss")
(lib "pretty.ss"))
(import matrix-render^)
(export matrix^)
;; [Matrix X] = [BST X]
(define matrix%
(class* object% (matrix<%>)
(define/public (->rectangle) (matrix->rectangle this))
(super-new)))
(define bmatrix%
(class object%
(class* matrix% (matrix<%>)
(init-field n m mat)
(define/public (get-n) n)
(define/public (get-m) m)
@ -19,7 +29,20 @@
;; s.t. (= (* n m)(vector-length vector))
(super-new)))
(define-struct imatrix (left i j info right) #:transparent)
(define imatrix%
(class* matrix% (matrix<%>)
(init-field left i j info right)
(super-new)))
(define imatrix-left (class-field-accessor imatrix% left))
(define imatrix-i (class-field-accessor imatrix% i))
(define imatrix-j (class-field-accessor imatrix% j))
(define imatrix-info (class-field-accessor imatrix% info))
(define imatrix-right (class-field-accessor imatrix% right))
(define (make-imatrix left i j info right)
(make-object imatrix% left i j info right))
(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)
@ -27,14 +50,7 @@
(define (set-imatrix-info n x)
(make-imatrix (imatrix-left n) (imatrix-i n) (imatrix-j n) x (imatrix-right n)))
(provide matrix@)
(define matrix@
(unit
(import matrix-render^)
(export matrix^)
(define (create-matrix n m mat)
(define (create-matrix n m mat)
(new bmatrix% [n n] [m m] [mat mat]))
(define (matrix-get-mat bm) (send bm get-mat))
@ -58,26 +74,26 @@
;; bst-insert : [BST X] Nat Nat X -> [BST X]
(define (bst-insert t i j x)
(cond
[(imatrix? t)
[(is-a? t imatrix%)
(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))
[(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)]
[(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)
[(is-a? t imatrix%)
(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 (bst-lookup (imatrix-right t) i j)])]
[else (inner-ref (matrix-get-mat t) (matrix-get-m t) i j)]))
;
;
; ;;;;;;
@ -93,13 +109,18 @@
;
;
(define (matrix? x) (or (is-a? x bmatrix%) (imatrix? x)))
(define (matrix? x)
(define m (if (visible? x) (visible-matrix x) x))
(internal-matrix? m))
(define (matrix-n M*)
(define (internal-matrix? m)
(or (is-a? m bmatrix%) (is-a? m imatrix%)))
(define (matrix-rows M*)
(define-values (M n m) (check-matrix 'matrix-n M* 0 0))
n)
(define (matrix-m M*)
(define (matrix-cols M*)
(define-values (M n m) (check-matrix 'matrix-n M* 0 0))
m)
@ -109,6 +130,12 @@
(define m (length (car r)))
(make-matrix n m (apply append r)))
(define (rectangle->imatrix r)
;; check rectangleness of r
(define n (length r))
(define m (length (car r)))
(make-matrix-aux 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))))))
@ -124,15 +151,16 @@
(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)))])))))
(make-visible (make-matrix-aux n m l)))
(define (make-matrix-aux n m l)
(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)
@ -188,11 +216,11 @@
[(>= j* j) (matrix-ref M (+ i* 1) (+ j* 1))])]))))
(define (matrix-set! M* i j x)
(define _ (when (imatrix? M)
(define _ (when (is-a? M imatrix%)
(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)
M*)
;
;
@ -233,18 +261,19 @@
;; 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 (cond
[(matrix? M*) M*]
[(visible? M*) (visible-matrix M*)]
[else (error 'check-matrix "something is wrong: ~e ~e~e\n"
M* (visible? M*) (send M* get-M))]))
(check-arg tag (matrix? M) 'matrix "first" M)
(define M (if (internal-matrix? M*)
M*
(let ([r (visible-matrix M*)])
(cond
[(internal-matrix? r) r]
[(pair? r) (rectangle->imatrix r)]
[else (check-arg tag #f '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 M (let loop ([M M*]) (if (is-a? M imatrix%) (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
@ -261,4 +290,4 @@
[(= n 2) "nd"]
[(> n 3) "th"]
[else (error 'th "can't happen")]))
))

85
collects/htdp/matrix.ss
View File

@ -1,88 +1,16 @@
#lang scheme
#lang scheme/gui
;; 4. integrate with snips
(require (lib "matrix-sig.ss" "htdp")
(lib "matrix-render-sig.ss" "htdp")
(lib "matrix-unit.ss" "htdp")
(lib "matrix-render.ss" "htdp"))
(lib "matrix-snip.ss" "mrlib"))
(require (lib "class.ss")
(lib "string.ss")
(lib "mred.ss" "mred")
(lib "cache-image-snip.ss" "mrlib"))
(provide (rename-out (matrix-snip-class snip-class))
matrix-snip-class%)
;; ---------------------------------------------------------------------------
;(define matrix-snip-class 'missing)
;(define matrix-snip-class% 'missing)
(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-field M)
(define/public (get-M) M)
;; 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)))
;; 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
M
#;
(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)
(lib "matrix-snip.ss" "mrlib"))
;; ---------------------------------------------------------------------------
@ -138,7 +66,7 @@
(define bm-mask (build-bitmap bm-mask-builder tw th))
(overlay-bitmap argb dx dy bm-color bm-mask))
(new visible-matrix%
[M M]
[M_0 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]))
@ -194,7 +122,8 @@
[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))])
(let-values ([(w h _1 _2)
(send dc get-text-extent string (get-font size))])
(values (inexact->exact (ceiling w))
(inexact->exact (ceiling h))))))

35
collects/htdp/matrix.txt Normal file
View File

@ -0,0 +1,35 @@
%% -----------------------------------------------------------------------------
rectangle: a list of lists of equal length
files:
mrlib/matrix-snip.ss : the image snips for matrix
works with matrices that implement matrix<%>
i.e., support a ->rectangle method
it writes out a matrix as a rectangle and
reconstructs it as a rectangle
the function visible-matrix may therefore yield a
rectangle or a matrix representation proper
drscheme/private/eval.ss : requires matrix-snip to share at module level
htdp/matrix.ss : uses snips to present matrices, requires matrix-snip
htdp/matrix-invisible.ss : make matrices invisible
* they are created from two mutually recursive units:
* matrix-unit and a 'rendering' unit
htdp/matrix-sig.ss : the functions that matrix-unit.ss provides
and that matrix-render.ss needs
htdp/matrix-render-sig.ss: the functions that matrix-unit expects from the
rendering unit
htdp/matrix-unit.ss : the matrix functionality
htdp/Tests/matrix-test.ss: a textual test
htdp/Tests/matrix-client.ss a test with embedded images