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