昨晩の続き (問題 2.37)

昨晩時点のものまでの試験を書いた。若干微妙。

(use gauche.test)

(add-load-path ".")
(load "2.37")

(test-start "dot-product")
(test-section "dot-product")
(test* "(dot-product '(0 9) '(2 0))"
       0
       (dot-product '(0 9) '(2 0)))

(test* "(dot-product '(2 0) '(2 0))"
       4
       (dot-product '(2 0) '(2 0)))

(test* "(dot-product '(1 1) '(3 1))"
       4
       (dot-product '(1 1) '(3 1)))

(test-section "m-*-v")
(test* "(m-*-v '((1 2 3) (4 5 6)) '(1 2 3))"
       '(14 32)
       (m-*-v '((1 2 3) (4 5 6)) '(1 2 3)))

(test-end)

残りは transpose と m-*-m になります。まず transpose の試験から以下。

(test-section "transpose")
(test* "(transpose '((1 2 3) (4 5 6) (7 8 9)))"
       '((1 4 7) (2 5 8) (3 6 9))
       (transpose '((1 2 3) (4 5 6) (7 8 9))))

実装はどうしたものか、と言いつつ以下でパス。

(define (transpose mat)
  (accumulate-n cons '() mat))

次は m-*-m なんですが、問題の記述は以下になってます。

(define (m-*-m m n)
  (let ((cols (transpose n)))
    (map <??> m)))

ええと、n は transpose してるので map に渡す手続きの中身は行列の積の定義によれば以下で良いのかな。

(lambda (row-m) 
  (map (lambda (row-cols) 
         (dot-product row-m row-cols))
       cols))

しまった試験が先。数学入門の例から以下。

(test-section "m-*-m")
(test* "(m-*-m '((1 3) (2 4)) '((4 2) (3 1)))"
       '((13 5) (20 8))
       (m-*-m '((1 3) (2 4)) '((4 2) (3 1))))

(test* "(m-*-m '((4 2) (3 1)) '((1 3) (2 4)))"
       '((8 20) (5 13))
       (m-*-m '((4 2) (3 1)) '((1 3) (2 4))))

試験パス。実装以下です。

(define (m-*-m m n)
  (let ((cols (transpose n)))
    (map (lambda (row-m)
	   (map (lambda (row-cols)
		  (dot-product row-m row-cols))
		cols))
	 m)))

これ、もう少しなんとかならんかな。