steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Add reverse haar wavelet transform and tests

db4
Aaron Schaefer 2008-11-06 23:21:19 -05:00
parent b7dc7296db
commit 8ec695332a
3 changed files with 26 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/math/haar/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Slava Pestov
Aaron Schaefer

5
extra/math/haar/haar-tests.factor Normal file
View File

@ -0,0 +1,5 @@
USING: math.haar tools.test ;
IN: math.haar.tests
[ { 3 2 -1 -2 3 0 4 1 } ] [ { 7 1 6 6 3 -5 4 2 } haar ] unit-test
[ { 7 1 6 6 3 -5 4 2 } ] [ { 3 2 -1 -2 3 0 4 1 } rev-haar ] unit-test

23
extra/math/haar/haar.factor
View File

@ -1,15 +1,30 @@
! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/ ! Copyright (c) 2008 Slava Pestov, Aaron Schaefer.
USING: sequences math kernel splitting grouping columns ; ! See http://factorcode.org/license.txt for BSD license.
USING: assocs columns grouping kernel math math.statistics math.vectors
sequences ;
IN: math.haar IN: math.haar
! Haar Wavelet Transform -- http://dmr.ath.cx/gfx/haar/
<PRIVATE
: averages ( seq -- seq ) : averages ( seq -- seq )
[ first2 + 2 / ] map ; [ mean ] map ;
: differences ( seq averages -- differences ) : differences ( seq averages -- differences )
>r 0 <column> r> [ - ] 2map ; [ 0 <column> ] dip v- ;
: haar-step ( seq -- differences averages ) : haar-step ( seq -- differences averages )
2 group dup averages [ differences ] keep ; 2 group dup averages [ differences ] keep ;
: rev-haar-step ( seq -- seq )
halves [ v+ ] [ v- ] 2bi zip concat ;
PRIVATE>
: haar ( seq -- seq ) : haar ( seq -- seq )
dup length 1 <= [ haar-step haar prepend ] unless ; dup length 1 <= [ haar-step haar prepend ] unless ;
: rev-haar ( seq -- seq )
dup length 2 > [ halves swap rev-haar prepend ] when rev-haar-step ;