scheme 矩阵运算

标签：scheme

基于表：

( define ( accumulate op init seq )
   ( cond 
      [ ( null? seq ) init ]
      [ else 
        ( op ( car seq )
             ( accumulate op init ( cdr seq ) ) ) ] ) )

( define ( accumulate-n op init seqs )
   ( cond 
      [ ( null? ( car seqs ) ) ‘() ]
      [ else 
        ( cons ( accumulate op init ( map car seqs ) )
               ( accumulate-n op init ( map cdr seqs ) ) ) ] ) )

( define ( dot-product v m )
   ( accumulate + 0 ( map * v m ) ) )

( define ( mat-*-vec mat vec )
   ( map ( lambda ( row )( dot-product row vec ) ) mat ) )

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

( define ( mat-*-mat m n )
   ( let ( [ n ( transpose n ) ] )
      ( map ( lambda ( row )( mat-*-vec n row ) ) m ) ) )

基于vector：

#!r6rs
( import ( rnrs ) )

( define type-error 
   ( lambda ( what )
      ( assertion-violation ‘mul "not a number or matrix" what ) ) )

( define match-error 
   ( lambda ( what1 what2 )
      ( assertion-violation ‘mul "incompatible operands" what1 what2 ) ) )

( define make-matrix 
   ( lambda ( rows cols )
      ( do ( [ mat ( make-vector rows ) ]
             [ r 0 ( + r 1 ) ] )
         ( ( = r rows ) mat )
         ( vector-set! mat r ( make-vector cols ) ) ) ) )

( define matrix? 
   ( lambda ( mat )
      ( and ( vector? mat )
            ( vector? ( vector-ref mat 0 ) )
            ( > ( vector-length mat ) 0 ) ) ) )

( define matrix-ref 
   ( lambda ( mat row col )
      ( vector-ref ( vector-ref mat row ) col ) ) )

( define matrix-set!
   ( lambda ( mat row col val )
      ( vector-set! ( vector-ref mat row ) col val ) ) )

( define matrix-rows ( lambda ( mat )( vector-length mat ) ) )
( define matrix-cols ( lambda ( mat )( vector-length ( vector-ref mat 0 ) ) ) )

( define mat-*-vec
   ( lambda ( mat vec )
      ( let* ( [ rows ( matrix-rows mat ) ]
               [ cols ( matrix-cols mat ) ]
               [ res ( make-matrix rows cols ) ] )
         ( do ( [ r 0 ( + r 1 ) ] )
            ( ( = r rows ) res )
            ( do ( [ c 0 ( + c 1 ) ] )
               ( = c cols )
               ( vector-set! res r c ( * vec ( matrix-ref mat r c ) ) ) ) ) ) ) )

( define mat-*-mat
   ( lambda ( mat1 mat2 )
      ( let* ( [ rows1 ( matrix-rows mat1 ) ]
               [ cols1 ( matrix-cols mat1 ) ]
               [ rows2 ( matrix-rows mat2 ) ]
               [ cols2 ( matrix-cols mat2 ) ]
               [ res ( make-matrix rows1 cols2 ) ] )         
         ( unless ( = cols1 rows2 )
            ( match-error mat1 mat2 ) )        
         ( do ( [ r 0 ( + r 1 ) ] )
            ( ( = r rows1 ) res )
            ( do ( [ c 0 ( + c 1 ) ] )
               ( ( = c cols2 ) )
               ( do ( [ k 0 ( + k 1 ) ]
                      [ val 0 ( + val 
                                  ( * ( matrix-ref mat1 r k )
                                      ( matrix-ref mat2 k c ) ) ) ] )
                  ( ( = k rows2 )
                    ( matrix-set! res r c val ) ) ) ) ) ) ) )

( define mul 
   ( lambda ( x y )
      ( cond 
         [ ( number? x )
           ( cond 
              [ ( number? y )( * x y ) ]
              [ ( matrix? y )( mat-*-vec y x ) ]
              [ else ( type-error y ) ] ) ]
         [ ( matrix? x )
           ( cond 
              [ ( number? y )( mat-*-vec x y ) ]
              [ ( matrix? x )( mat-*-mat x y ) ]
              [ else ( type-error x ) ] ) ]
         [ else ( type-error x ) ] ) ) )

scheme 矩阵运算

标签：scheme

原文地址：http://blog.csdn.net/pandora_madara/article/details/43059483