sample.scheme.txt 3.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105
  1. ;;; make-matrix creates a matrix (a vector of vectors).
  2. (define make-matrix
  3. (lambda (rows columns)
  4. (do ((m (make-vector rows))
  5. (i 0 (+ i 1)))
  6. ((= i rows) m)
  7. (vector-set! m i (make-vector columns)))))
  8. ;;; matrix? checks to see if its argument is a matrix.
  9. ;;; It isn't foolproof, but it's generally good enough.
  10. (define matrix?
  11. (lambda (x)
  12. (and (vector? x)
  13. (> (vector-length x) 0)
  14. (vector? (vector-ref x 0)))))
  15. ;; matrix-rows returns the number of rows in a matrix.
  16. (define matrix-rows
  17. (lambda (x)
  18. (vector-length x)))
  19. ;; matrix-columns returns the number of columns in a matrix.
  20. (define matrix-columns
  21. (lambda (x)
  22. (vector-length (vector-ref x 0))))
  23. ;;; matrix-ref returns the jth element of the ith row.
  24. (define matrix-ref
  25. (lambda (m i j)
  26. (vector-ref (vector-ref m i) j)))
  27. ;;; matrix-set! changes the jth element of the ith row.
  28. (define matrix-set!
  29. (lambda (m i j x)
  30. (vector-set! (vector-ref m i) j x)))
  31. ;;; mul is the generic matrix/scalar multiplication procedure
  32. (define mul
  33. (lambda (x y)
  34. ;; mat-sca-mul multiplies a matrix by a scalar.
  35. (define mat-sca-mul
  36. (lambda (m x)
  37. (let* ((nr (matrix-rows m))
  38. (nc (matrix-columns m))
  39. (r (make-matrix nr nc)))
  40. (do ((i 0 (+ i 1)))
  41. ((= i nr) r)
  42. (do ((j 0 (+ j 1)))
  43. ((= j nc))
  44. (matrix-set! r i j
  45. (* x (matrix-ref m i j))))))))
  46. ;; mat-mat-mul multiplies one matrix by another, after verifying
  47. ;; that the first matrix has as many columns as the second
  48. ;; matrix has rows.
  49. (define mat-mat-mul
  50. (lambda (m1 m2)
  51. (let* ((nr1 (matrix-rows m1))
  52. (nr2 (matrix-rows m2))
  53. (nc2 (matrix-columns m2))
  54. (r (make-matrix nr1 nc2)))
  55. (if (not (= (matrix-columns m1) nr2))
  56. (match-error m1 m2))
  57. (do ((i 0 (+ i 1)))
  58. ((= i nr1) r)
  59. (do ((j 0 (+ j 1)))
  60. ((= j nc2))
  61. (do ((k 0 (+ k 1))
  62. (a 0
  63. (+ a
  64. (* (matrix-ref m1 i k)
  65. (matrix-ref m2 k j)))))
  66. ((= k nr2)
  67. (matrix-set! r i j a))))))))
  68. ;; type-error is called to complain when mul receives an invalid
  69. ;; type of argument.
  70. (define type-error
  71. (lambda (what)
  72. (error 'mul
  73. "~s is not a number or matrix"
  74. what)))
  75. ;; match-error is called to complain when mul receives a pair of
  76. ;; incompatible arguments.
  77. (define match-error
  78. (lambda (what1 what2)
  79. (error 'mul
  80. "~s and ~s are incompatible operands"
  81. what1
  82. what2)))
  83. ;; body of mul; dispatch based on input types
  84. (cond
  85. ((number? x)
  86. (cond
  87. ((number? y) (* x y))
  88. ((matrix? y) (mat-sca-mul y x))
  89. (else (type-error y))))
  90. ((matrix? x)
  91. (cond
  92. ((number? y) (mat-sca-mul x y))
  93. ((matrix? y) (mat-mat-mul x y))
  94. (else (type-error y))))
  95. (else (type-error x)))))