diff --git a/extra/math/haar/authors.txt b/extra/math/haar/authors.txt new file mode 100644 index 0000000000..cf46c0ea5e --- /dev/null +++ b/extra/math/haar/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Aaron Schaefer diff --git a/extra/math/haar/haar-tests.factor b/extra/math/haar/haar-tests.factor new file mode 100644 index 0000000000..9c9124bf17 --- /dev/null +++ b/extra/math/haar/haar-tests.factor @@ -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 diff --git a/extra/math/haar/haar.factor b/extra/math/haar/haar.factor index f1bf87161c..f745721124 100644 --- a/extra/math/haar/haar.factor +++ b/extra/math/haar/haar.factor @@ -1,15 +1,30 @@ -! Haar wavelet transform -- http://dmr.ath.cx/gfx/haar/ -USING: sequences math kernel splitting grouping columns ; +! Copyright (c) 2008 Slava Pestov, Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs columns grouping kernel math math.statistics math.vectors + sequences ; IN: math.haar +! Haar Wavelet Transform -- http://dmr.ath.cx/gfx/haar/ + +r 0 r> [ - ] 2map ; + [ 0 ] dip v- ; : haar-step ( seq -- differences averages ) 2 group dup averages [ differences ] keep ; +: rev-haar-step ( seq -- seq ) + halves [ v+ ] [ v- ] 2bi zip concat ; + +PRIVATE> + : haar ( seq -- seq ) dup length 1 <= [ haar-step haar prepend ] unless ; + +: rev-haar ( seq -- seq ) + dup length 2 > [ halves swap rev-haar prepend ] when rev-haar-step ; +