2012-08-08 23:28:14 -04:00
|
|
|
|
! Copyright (c) 2012 John Benediktsson
|
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2014-11-11 21:00:44 -05:00
|
|
|
|
USING: arrays kernel locals math math.constants math.functions
|
2012-08-08 23:28:14 -04:00
|
|
|
|
math.vectors sequences sequences.extras sequences.private ;
|
|
|
|
|
IN: math.transforms.fft
|
|
|
|
|
|
|
|
|
|
<PRIVATE
|
|
|
|
|
|
2014-06-04 15:06:45 -04:00
|
|
|
|
DEFER: (fft)
|
|
|
|
|
|
2012-08-09 11:56:47 -04:00
|
|
|
|
! Discrete Fourier Transform
|
2012-08-08 23:28:14 -04:00
|
|
|
|
:: (slow-fft) ( seq inverse? -- seq' )
|
|
|
|
|
seq length :> N
|
2013-09-23 18:56:18 -04:00
|
|
|
|
inverse? 1 -1 ? 2pi * N / N iota n*v :> omega
|
2012-08-08 23:28:14 -04:00
|
|
|
|
N iota [| k |
|
2013-09-23 18:56:18 -04:00
|
|
|
|
0 seq omega [ k * cis * + ] 2each
|
2012-08-08 23:28:14 -04:00
|
|
|
|
inverse? [ N / ] when
|
|
|
|
|
] map ; inline
|
|
|
|
|
|
2012-08-09 11:56:47 -04:00
|
|
|
|
! Cooley–Tukey Algorithm
|
2014-06-04 15:06:45 -04:00
|
|
|
|
:: (fast-fft) ( seq inverse? -- seq' )
|
2012-08-08 23:28:14 -04:00
|
|
|
|
seq length :> N
|
|
|
|
|
N 1 = [ seq ] [
|
2014-06-04 15:28:59 -04:00
|
|
|
|
seq even-indices inverse? (fast-fft)
|
|
|
|
|
seq odd-indices inverse? (fast-fft)
|
2013-09-23 18:56:18 -04:00
|
|
|
|
inverse? 1 -1 ? 2pi * N /
|
|
|
|
|
[ * cis * ] curry map-index!
|
2012-08-09 15:34:02 -04:00
|
|
|
|
[ [ + inverse? [ 2 / ] when ] 2map ]
|
|
|
|
|
[ [ - inverse? [ 2 / ] when ] 2map ]
|
2012-08-09 11:36:26 -04:00
|
|
|
|
2bi append
|
2012-08-08 23:28:14 -04:00
|
|
|
|
] if ; inline recursive
|
|
|
|
|
|
2014-06-04 15:06:45 -04:00
|
|
|
|
: (fft) ( seq inverse? -- seq' )
|
|
|
|
|
over length power-of-2?
|
2014-06-04 15:28:59 -04:00
|
|
|
|
[ (fast-fft) ] [ (slow-fft) ] if ; inline
|
2014-06-04 15:06:45 -04:00
|
|
|
|
|
2012-08-08 23:28:14 -04:00
|
|
|
|
PRIVATE>
|
|
|
|
|
|
|
|
|
|
ERROR: not-enough-data ;
|
|
|
|
|
|
|
|
|
|
: fft ( seq -- seq' )
|
2015-08-13 19:13:05 -04:00
|
|
|
|
[ not-enough-data ] [ f (fft) ] if-empty ;
|
2012-08-08 23:28:14 -04:00
|
|
|
|
|
|
|
|
|
: ifft ( seq -- seq' )
|
2015-08-13 19:13:05 -04:00
|
|
|
|
[ not-enough-data ] [ t (fft) ] if-empty ;
|
2012-08-09 00:00:49 -04:00
|
|
|
|
|
|
|
|
|
: correlate ( x y -- z )
|
|
|
|
|
[ fft ] [ reverse fft ] bi* v* ifft ;
|