Chris@82: (*
Chris@82:  * Copyright (c) 1997-1999 Massachusetts Institute of Technology
Chris@82:  * Copyright (c) 2003, 2007-14 Matteo Frigo
Chris@82:  * Copyright (c) 2003, 2007-14 Massachusetts Institute of Technology
Chris@82:  *
Chris@82:  * This program is free software; you can redistribute it and/or modify
Chris@82:  * it under the terms of the GNU General Public License as published by
Chris@82:  * the Free Software Foundation; either version 2 of the License, or
Chris@82:  * (at your option) any later version.
Chris@82:  *
Chris@82:  * This program is distributed in the hope that it will be useful,
Chris@82:  * but WITHOUT ANY WARRANTY; without even the implied warranty of
Chris@82:  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Chris@82:  * GNU General Public License for more details.
Chris@82:  *
Chris@82:  * You should have received a copy of the GNU General Public License
Chris@82:  * along with this program; if not, write to the Free Software
Chris@82:  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
Chris@82:  *
Chris@82: *)
Chris@82: 
Chris@82: open Complex
Chris@82: open Util
Chris@82: 
Chris@82: let polyphase m a ph i = a (m * i + ph)
Chris@82: 
Chris@82: let rec divmod n i =
Chris@82:   if (i < 0) then 
Chris@82:     let (a, b) = divmod n (i + n)
Chris@82:     in (a - 1, b)
Chris@82:   else (i / n, i mod n)
Chris@82: 
Chris@82: let unpolyphase m a i = let (x, y) = divmod m i in a y x
Chris@82: 
Chris@82: let lift2 f a b i = f (a i) (b i)
Chris@82: 
Chris@82: (* convolution of signals A and B *)
Chris@82: let rec conv na a nb b =
Chris@82:   let rec naive na a nb b i =
Chris@82:     sigma 0 na (fun j -> (a j) @* (b (i - j)))
Chris@82: 
Chris@82:   and recur na a nb b =
Chris@82:     if (na <= 1 || nb <= 1) then
Chris@82:       naive na a nb b
Chris@82:     else
Chris@82:       let p = polyphase 2 in
Chris@82:       let ee = conv (na - na / 2) (p a 0) (nb - nb / 2) (p b 0)
Chris@82:       and eo = conv (na - na / 2) (p a 0) (nb / 2) (p b 1)
Chris@82:       and oe = conv (na / 2) (p a 1) (nb - nb / 2) (p b 0)
Chris@82:       and oo = conv (na / 2) (p a 1) (nb / 2) (p b 1) in
Chris@82:       unpolyphase 2 (function
Chris@82: 	  0 -> fun i -> (ee i) @+ (oo (i - 1))
Chris@82: 	| 1 -> fun i -> (eo i) @+ (oe i) 
Chris@82: 	| _ -> failwith "recur")
Chris@82: 
Chris@82: 
Chris@82:   (* Karatsuba variant 1: (a+bx)(c+dx) = (ac+bdxx)+((a+b)(c+d)-ac-bd)x *)
Chris@82:   and karatsuba1 na a nb b =
Chris@82:       let p = polyphase 2 in
Chris@82:       let ae = p a 0 and nae = na - na / 2
Chris@82:       and ao = p a 1 and nao = na / 2
Chris@82:       and be = p b 0 and nbe = nb - nb / 2
Chris@82:       and bo = p b 1 and nbo = nb / 2 in
Chris@82:       let ae = infinite nae ae and ao = infinite nao ao
Chris@82:       and be = infinite nbe be and bo = infinite nbo bo in
Chris@82:       let aeo = lift2 (@+) ae ao and naeo = nae
Chris@82:       and beo = lift2 (@+) be bo and nbeo = nbe in
Chris@82:       let ee = conv nae ae nbe be 
Chris@82:       and oo = conv nao ao nbo bo
Chris@82:       and eoeo = conv naeo aeo nbeo beo in
Chris@82: 
Chris@82:       let q = function
Chris@82: 	  0 -> fun i -> (ee i)  @+ (oo (i - 1))
Chris@82: 	| 1 -> fun i -> (eoeo i) @- ((ee i) @+ (oo i))
Chris@82: 	| _ -> failwith "karatsuba1" in
Chris@82:       unpolyphase 2 q
Chris@82: 
Chris@82:   (* Karatsuba variant 2: 
Chris@82:      (a+bx)(c+dx) = ((a+b)c-b(c-dxx))+x((a+b)c-a(c-d)) *)
Chris@82:   and karatsuba2 na a nb b =
Chris@82:       let p = polyphase 2 in
Chris@82:       let ae = p a 0 and nae = na - na / 2
Chris@82:       and ao = p a 1 and nao = na / 2
Chris@82:       and be = p b 0 and nbe = nb - nb / 2
Chris@82:       and bo = p b 1 and nbo = nb / 2 in
Chris@82:       let ae = infinite nae ae and ao = infinite nao ao
Chris@82:       and be = infinite nbe be and bo = infinite nbo bo in
Chris@82: 
Chris@82:       let c1 = conv nae (lift2 (@+) ae ao) nbe be
Chris@82:       and c2 = conv nao ao (nbo + 1) (fun i -> be i @- bo (i - 1))
Chris@82:       and c3 = conv nae ae nbe (lift2 (@-) be bo) in
Chris@82: 
Chris@82:       let q = function
Chris@82: 	  0 -> lift2 (@-) c1 c2
Chris@82: 	| 1 -> lift2 (@-) c1 c3
Chris@82: 	| _ -> failwith "karatsuba2" in
Chris@82:       unpolyphase 2 q
Chris@82: 
Chris@82:   and karatsuba na a nb b =
Chris@82:     let m = na + nb - 1 in
Chris@82:     if (m < !Magic.karatsuba_min) then
Chris@82:       recur na a nb b
Chris@82:     else
Chris@82:       match !Magic.karatsuba_variant with
Chris@82: 	1 -> karatsuba1 na a nb b
Chris@82:       |	2 -> karatsuba2 na a nb b
Chris@82:       |	_ -> failwith "unknown karatsuba variant"
Chris@82: 
Chris@82:   and via_circular na a nb b =
Chris@82:     let m = na + nb - 1 in
Chris@82:     if (m < !Magic.circular_min) then
Chris@82:       karatsuba na a nb b
Chris@82:     else
Chris@82:       let rec find_min n = if n >= m then n else find_min (2 * n) in
Chris@82:       circular (find_min 1) a b
Chris@82: 
Chris@82:   in
Chris@82:   let a = infinite na a and b = infinite nb b in
Chris@82:   let res = array (na + nb - 1) (via_circular na a nb b) in
Chris@82:   infinite (na + nb - 1) res
Chris@82:     
Chris@82: and circular n a b =
Chris@82:   let via_dft n a b =
Chris@82:     let fa = Fft.dft (-1) n a 
Chris@82:     and fb = Fft.dft (-1) n b
Chris@82:     and scale = inverse_int n in
Chris@82:     let fab i = ((fa i) @* (fb i)) @* scale in
Chris@82:     Fft.dft 1 n fab
Chris@82: 
Chris@82:   in via_dft n a b