{-# language BangPatterns #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# language MultiParamTypeClasses #-}
{-# language RankNTypes #-}
{-# language RebindableSyntax #-}
{-# language TypeFamilies #-}
module W40K.Core.Prob
  ( QQ
  , Event(..)
  , Prob
  , events
  , traceLength
  , traceEvents
  , traceNumEvents
  , fmapProb
  , fmapProbMonotone
  , fmapProbMonotone'
  , (|>>=|), (|=<<|)
  , uniformly
  , probTrue
  , probFalse
  , probOf
  , given
  , bernoulli
  , binomial
  , foldlProbs'
  , foldrProbs
  , foldProbs
  , sumProbs
  , foldAssocIID
  , foldIID
  , sumIID
  , addImpossibleEvents
  , cdf
  , ccdf
  , summary
  , summaryInt
  , mean
  , variance
  , stDev
  , maxEvent
  ) where

import Prelude hiding (Functor(..), Applicative(..), Monad(..))

import Control.DeepSeq (NFData(..))

import Data.List (foldl', sort)
import Data.MemoTrie (memo)

import Numeric.SpecFunctions (choose)

import Debug.Trace (trace)

import W40K.Core.SortedList (SortedList, SortedListItem(..))
import qualified W40K.Core.SortedList as SortedList

import W40K.Core.ConstrMonad as ConstrMonad
import W40K.Core.Util

type QQ = Double

data Event a = Event !a {-# unpack #-} !QQ
    deriving (Eq, Ord)

mapEvent :: (a -> b) -> Event a -> Event b
mapEvent f (Event a p) = Event (f a) p
{-# inline mapEvent #-}

instance NFData a => NFData (Event a) where
    rnf (Event a _) = rnf a

instance Ord a => SortedListItem (Event a) where
    type ItemKey (Event a) = a
    itemKey (Event a _) = a
    combineItems (Event _ p) (Event a p') = Event a (p + p')

instance Show a => Show (Event a) where
    show (Event a p) = show a ++ ": " ++ show (realToFrac p :: Float)

newtype Prob a = Prob { density :: SortedList (Event a) }
    deriving (Eq, Ord, Show, NFData)

events :: Prob a -> [Event a]
events (Prob es) = SortedList.toAscList es
{-# inline events #-}

traceLength :: [a] -> [a]
traceLength as = trace (show (length as)) as

traceEvents :: Show a => Prob a -> Prob a
traceEvents df@(Prob _) =
    trace (show (events df)) df

traceNumEvents :: Prob a -> Prob a
traceNumEvents df@(Prob _) =
    trace (show (length (events df))) df

fmapProb :: Ord b => (a -> b) -> Prob a -> Prob b
fmapProb f (Prob evts) = Prob (SortedList.map (mapEvent f) evts)
{-# inline fmapProb #-}

{-# rules "fmap/fmapProb" fmap = fmapProb #-}
{-# specialize fmapProb :: (a -> Int) -> Prob a -> Prob Int #-}

-- only for monotone f
fmapProbMonotone :: Ord b => (a -> b) -> Prob a -> Prob b
fmapProbMonotone f (Prob evts) = Prob (SortedList.mapMonotone (mapEvent f) evts)
{-# inline fmapProbMonotone #-}

-- only for *strictly* monotone f
fmapProbMonotone' :: (a -> b) -> Prob a -> Prob b
fmapProbMonotone' f (Prob evts) = Prob (SortedList.mapMonotone' (mapEvent f) evts)
{-# inline fmapProbMonotone' #-}

bindProbWithStrat :: Ord b => (forall c. [c] -> [c]) -> Prob a -> (a -> Prob b) -> Prob b
bindProbWithStrat evalList (Prob evts) f =
    case SortedList.toAscList evts of
      [Event a _] -> f a
      evtList     -> Prob $ SortedList.concat $ evalList $ totalProb [Event (f a) p | Event a p <- evtList]
  where
    totalProb :: [Event (Prob a)] -> [SortedList (Event a)]
    totalProb ess = [SortedList.fromAscList [Event b (p*p') | Event b p' <- events y] | Event y p <- ess]

{-# inlinable bindProbWithStrat #-}

instance ConstrMonad Ord Prob where
    return a = Prob (SortedList.singleton (Event a 1))
    {-# inline return #-}
    (>>=) = bindProbWithStrat seqItems
    {-# inline (>>=) #-}
    {-# specialize (>>=) :: Prob a -> (a -> Prob Int) -> Prob Int #-}

(|>>=|) :: (Ord a, Ord b) => Prob a -> (a -> Prob b) -> Prob b
(|>>=|) = bindProbWithStrat parItems
{-# inline (|>>=|) #-}

(|=<<|) :: (Ord a, Ord b) => (a -> Prob b) -> Prob a -> Prob b
f |=<<| ma = ma |>>=| f
{-# inline (|=<<|) #-}

uniformly :: Ord a => [a] -> Prob a
uniformly as = Prob $ SortedList.fromAscList [Event a (1/n) | a <- sort as]
  where
    n = fromIntegral (length as)

probTrue :: Prob Bool -> QQ
probTrue prob =
    case events prob of
        [Event False _, Event True p] -> p
        [Event True p]                -> p
        [Event False q]               -> 1 - q
        []                            -> error "empty Prob!"
        _                             -> error ("unnormalized Prob!" ++ show prob)

probFalse :: Prob Bool -> QQ
probFalse df = 1 - probTrue df

probOf :: (a -> Bool) -> Prob a -> QQ
probOf test df = sum [p | Event a p <- events df, test a]

given :: (a -> Bool) -> Prob a -> Prob a
given hyp prob =
    Prob (SortedList.fromAscList [Event a (p / probHyp) | Event a p <- events prob, hyp a])
  where
    probHyp = probOf hyp prob

bernoulli :: QQ -> Prob Bool
bernoulli p = Prob $ SortedList.fromAscList [Event False (1-p), Event True p]

binomial :: Int -> QQ -> Prob Int
binomial 0 _ = return 0
binomial n p = binomialFlip p n

binomialFlip :: QQ -> Int -> Prob Int
binomialFlip p
  | p == 1/2  = binomial12
  | p == 1/3  = binomial13
  | p == 1/6  = binomial16
  | p == 2/3  = binomial23
  | otherwise = binomialMemo p

binomialMemo :: QQ -> Int -> Prob Int
binomialMemo p = memo $ \n ->
    case p of
      0 -> return 0
      1 -> return n
      _ -> Prob $ SortedList.fromAscList [Event k (binomProbOf n p k) | k <- [0..n]]
  where
    binomProbOf :: Int -> QQ -> Int -> QQ
    binomProbOf n p k
      | k < 0 || k > n = 0
      | n == 0         = 1
      | otherwise      = realToFrac (choose n k) * p^k * (1-p)^(n-k)

binomial23 :: Int -> Prob Int
binomial23 = binomialMemo (2/3)

binomial12 :: Int -> Prob Int
binomial12 = binomialMemo (1/2)

binomial13 :: Int -> Prob Int
binomial13 = binomialMemo (1/3)

binomial16 :: Int -> Prob Int
binomial16 = binomialMemo (1/6)

foldlProbs' :: (Ord a, Ord b) => (b -> a -> b) -> Prob b -> [Prob a] -> Prob b
foldlProbs' = foldl' . liftA2

foldrProbs :: (Ord a, Ord b) => (a -> b -> b) -> Prob b -> [Prob a] -> Prob b
foldrProbs = foldr . liftA2

foldProbs :: (Ord m, Monoid m) => [Prob m] -> Prob m
foldProbs = foldlProbs' mappend (return mempty)

sumProbs :: (Ord a, Num a) => [Prob a] -> Prob a
sumProbs []     = return 0
sumProbs [p]    = p
sumProbs (p:ps) = foldlProbs' (+) p ps
{-# specialize sumProbs :: [Prob Int] -> Prob Int #-}

foldAssocIID :: (Ord a) => (a -> a -> a) -> a -> Int -> Prob a -> Prob a
foldAssocIID _ z 0 _ = return z
foldAssocIID f z n p
  | n < 0     = error "foldAssocIID: n must be >= 0"
  | otherwise = noCheck f z n p
  where
    noCheck _ _ 1 p = p
    noCheck f z n p
      | n `mod` 2 == 0 = twiceHalf
      | otherwise      = liftA2 f p twiceHalf
      where
        !twiceHalf = liftA2 f recHalf recHalf
        !recHalf   = foldAssocIID f z (n`div`2) p

foldIID :: (Ord a, Monoid a) => Int -> Prob a -> Prob a
foldIID = foldAssocIID mappend mempty

-- TODO: Option to use Central Limit Theorem for sufficiently large n
sumIID :: (Ord a, Num a) => Int -> Prob a -> Prob a
sumIID = foldAssocIID (+) 0

addImpossibleEvents :: (Ord a, Enum a) => Prob a -> Prob a
addImpossibleEvents prob =
    let es = events prob
        as = [a | Event a _ <- es]
    in
        Prob $ SortedList.fromAscList $ merge es (zipWith Event [minimum as .. maximum as] (repeat 0))
  where
    merge es []  = es
    merge [] es' = es'
    merge ees@(e@(Event a _):es)
          ees'@(e'@(Event a' _):es')
      | a == a' = e : merge es es'
      | a <  a' = e : merge es ees'
      | a >  a' = e' : merge ees es'

cdf :: Ord a => Prob a -> [Event a]
cdf = scanl1 sumEvents . events
  where
    sumEvents (Event _ p) (Event a p') = Event a (p + p')

ccdf :: Ord a => Prob a -> [Event a]
ccdf = scanr1 sumEvents . events
  where
    sumEvents (Event a p) (Event _ p') = Event a (p + p')

summary :: Prob QQ -> IO ()
summary p =
  let mu    = "µ=" ++ show (realToFrac (mean p) :: Double)
      sigma = "σ=" ++ show (sqrt $ realToFrac (variance p) :: Double)
  in
      putStrLn $ mu ++ ", " ++ sigma

summaryInt :: Prob Int -> IO ()
summaryInt = summary . fmap fromIntegral

mean :: Prob QQ -> QQ
mean df = sum [k * p | Event k p <- events df]

variance :: Prob QQ -> QQ
variance df = sum [squared k * p | Event k p <- events df] - squared (mean df)
  where
    squared x = x*x

stDev :: Prob QQ -> QQ
stDev df = sqrt (variance df)

maxEvent :: Ord a => Prob a -> a
maxEvent df = maximum [a | Event a _ <- events df]


{-# LANGUAGE DataKinds #-}

module SCG.Graph () where
{--
import GHC.TypeLits
import Algebra.Graph
import Backprop
import Numeric.LinearAlgebra.Static

{--
Optimizing loss functions over random variables is often intractable
due to the loss functions and their gradients being either a sum over
an exponential number of latent variable configurations or non-analytic,
high-dimensional integrals.

Usually this is resolved by using problem-specific MC Grad Estimators.

There is a general technique for this!

Stochastic Computation Graphs:
- Allows derivation of unbiased gradient estimators for general expected losses.
- Estimator can be computed as the grad of a differentiable "surrogate loss" through backprop
- Variance reduction techniques can be applied to this problem formulation
- Hessian-free methods and majorization-minimization algorithms can be generalized to the SCG framework

!! The main modification to backprop is to introduce extra gradient signals at the stochastic nodes.
--}

-- Gradient Estimators for a Single Random Variable

type RV = Vector Double

type Theta = Matrix

parameterizedProbDist :: Theta -> RV

costfn :: RV -> Double
costfn rv = 2.0

-- scoreFunctionEstimator: By Log-Derivative Trick (valid if p_x_theta is continuous function of theta, though not necessarily for x)
-- also known as REINFORCE or likelihood ratio estimator
ddTheta_expect_over_x_f_x x f p theta = expectation $ x $ f x $ ddTheta $ log $ p x theta

-- if x is deterministic differentiable (perhaps representable as a type constraint? find one)
-- function of theta and another rv z, (i.e, x(z, theta)) we can use
-- !!Pathwise Derivative
-- only valid if f(x(z, theta)) is continous function of theta for all z (another type constraint?)
ddTheta_expect_over_x_f_ztheta f x z theta = expectation $ z $ ddTheta $ f (x z theta)

-- Theta might appear inside the expectation and the prob dist!
-- ddtheta Expectation_z~p(., theta)[ f( x(z, theta) ) ]
-- then two terms in the gradient estimator:

ddtheta_expect_over_z_from_pOfTheta_f_of_x_of_z_theta p f x z theta =
  expectation map (\z -> pointwiseEstimate) sample (p z theta)
  where pointwiseEstimate = ddTheta $ f (x z theta) + (ddTheta $ log (p z theta)) * (f $ x z theta)

{--
1. SF can be used even if f is discontinuous or x is a discrete rv
2. SF only requires trajectories, PD requires f'(x)
3. SF has higher variance than PD, unless f is rough as in time-series problems with exploding gradients
4. PD has a deterministic limit, SF doesn't.
--}

{--
  STOCHASTIC COMPUTATION GRAPHS:
    Directed, Acyclic Graph with Three Kinds of nodes:
    - Input Nodes, set externally including the parameters we differentiate with respect to
    - Deterministic Nodes: pure functions of their parents
    - Stochastic Nodes: Distributed Conditionally on their parents.

    Each parent v of a non-input node w is connected to it by a directed edge (v, w)

  THE STRUCTURE OF THE GRAPH FULLY SPECIFIES:
    - What estimator we will use, SF or PD or a combination thereof
    - Nodes arranged in series are multiplicative terms only
    - Nodes arranged in parallel lead to sums over mulplicative terms
    -
--}
{--
data Node a = InputNode a | DeterministicNode a | StochasticNode a

newtype InputNode a = IO a

newtype DeterministicNode v e = ([v] -> e -> b)

newtype StochasticNode v e = ConditionalDistribution [v] e

data DirectedEdge a = DirectedEdge
  { _v :: Node,
    _w :: DeterministicNode | StochasticNode
  }
--}

-- TODO: Create a directed acyclic graph DS using alga
-- TODO: Define Node types which typecheck (initially for a scalar parameterization of the relevant types)
-- TODO: Add backprop for folds over the deterministic nodes? derive an instance of Backprop for edges?
-- TODO: Add the right gradient estimation procedure for combinations of deterministic and stochastic nodes
-- TODO: Figure out how to do dataflow programming over the Graph
--}


-- Graphical and Network Models in Haskell.
-- Nicolas Kim
-- Department of Statistics, Carnegie Mellon University
-- Distributed under the MIT License.

import System.IO
import System.Random

import Adjacency
import Core
import Local

import Control.Monad
import Control.Monad.Random
import Control.Parallel (par, pseq)
-- import Control.Lens

import qualified Data.Map.Lazy as M
import qualified Data.List as L

import Numeric.LinearAlgebra (dispf)

-- import qualified Numeric.LinearAlgebra as LA

-- Some examples of graphs.
gr1 = Graph [1..3] [(1,2), (1,3), (2,3)] :: Graph Int
gr2 = Graph [1..2] [(1,2), (1,3), (2,3)] :: Graph Int
gr3 = completeGraph [1..10] :: Graph Int
gr4 = Graph [1..4] [(1,2), (3,4), (1,4)] :: Graph Int

kite = Graph [1..4] [(1,2), (1,3), (2,3), (2,4), (3,4)] :: Graph Int
wiki = Graph [1..6] [(1,2), (1,5), (2,5), (2,3), (3,4), (4,5), (4,6)] ::
  Graph Int
gr5 = Graph [1..3] [(1,2)] :: Graph Int
disconnected = Graph [1..4] [(1,2), (3,4)] :: Graph Int

-- Data structure for network models.
-- data Model = ERG { parameters :: [Double] } deriving (Show, Eq)

-- Makes an empty graph.
emptyGraph :: Graph a
emptyGraph = Graph [] []

-- Makes a complete simple graph from a list of nodes.
completeGraph :: (Ord a, Eq a) => [a] -> Graph a
completeGraph ns = Graph sns es
  where
    sns = L.sort ns
    es = completeEdges sns

-- List of all possible graphs on n nodes.
-- allGraphs :: (Ord a, Eq a) => [a] -> [Graph a] -> M.Map [Int] [Graph a]
-- allGraphs ns = L.foldl' () mapInit [1..n]
--   where
--     mapInit = M.fromList [(0, emptyGraph)]
--     n = (\x -> x*(x-1) `div` 2) $ length ns

-- Makes a valid graph object from a list of edges.
toGraph :: (Ord a, Eq a) => [(a, a)] -> Graph a
toGraph es = Graph (extractNodes es) es

-- Checks if the edges contain defined nodes.
validGraph :: (Eq a) => Graph a -> Bool
validGraph (Graph ns es) = subset (L.union (map fst es) (map snd es)) ns
  where
    subset xs ys = all (`elem` ys) xs

-- Removes redundant edges (e.g. (1,2) = (2,1)).
redundant :: (Ord a, Eq a) => [(a, a)] -> [(a, a)]
redundant es = L.intersect es (map f es)
  where
    f (x, y) = (min x y, max x y)

-- Makes a graph valid (see the `validGraph` function).
makeValid :: (Eq a) => Graph a -> Graph a
makeValid gr@(Graph ns es)
  | validGraph gr = gr
  | otherwise = Graph (L.union ens ns) es
    where
      ens = L.nub $ L.union (map fst es) (map snd es)

-- From a list of edges, give the sorted and pruned list of nodes
extractNodes :: (Ord a, Eq a) => [(a, a)] -> [a]
extractNodes es = L.nub $ L.sort allnodes
  where
    allnodes = (map fst es) ++ (map snd es)

-- The complete set of edges between nodes in a list. Nodes don't need to
-- be orderable. 22s
completeEdges' :: [a] -> [(a, a)]
completeEdges' ns = [ (fst x, fst y) | x <- zs, y <- zs, snd x < snd y ]
  where
    zs = zip ns [1..]

-- Add a set of nodes to a graph using their labels.
addNodes :: (Ord a) => Graph a -> [a] -> Graph a
addNodes (Graph ns es) nns = Graph (L.union ns nns) es

-- Add a set of edges to a graph.
addEdges :: (Ord a) => Graph a -> [(a, a)] -> Graph a
addEdges (Graph ns es) ees = Graph ns (L.union es ees)

-- -- Various graph statistics.
-- Computes the number of nodes.
nNode :: Graph a -> Int
nNode gr = length $ nodes gr

-- Computes the number of edges.
nEdge :: Graph a -> Int
nEdge gr = length $ edges gr

-- -- Monad-based generation of random nodes and edges, i.e. random graphs.
-- Erdos-Renyi Model
-- Include or don't include an edge?
pBool :: (RandomGen g) => Double -> Rand g Bool
pBool p = liftM (< p) $ getRandomR ((0, 1) :: (Double, Double))

-- Decide over a list of edges.
pBools :: (RandomGen g) => [Double] -> Rand g [Bool]
pBools ps = sequence $ map pBool ps

-- Given a list of Bools and any other list, return the list subsetted by
-- the list of Bools.
byBool :: [Bool] -> [a] -> [a]
byBool bs xs = [ snd zs | zs <- (zip bs xs), fst zs ]

-- Select elements from a list independently and with probabilities ps.
setEdges :: (RandomGen g) => [a] -> [Double] -> Rand g [a]
setEdges xs ps = liftM (flip byBool xs) $ pBools ps

-- Generate an Erdos-Renyi random graph; nodes ns, and edge probabilities
-- ps.
erdosGen :: (Ord a, RandomGen g) => [a] -> [Double] -> Rand g (Graph a)
erdosGen ns ps = liftM (Graph ns) $ setEdges (completeEdges ns) ps

-- Graphon Model: generates a w-random graph.
graphonGen :: (Ord a, RandomGen g) => [a] -> (Double -> Double -> Double)
  -> Rand g (Graph a)
graphonGen ns w = liftM (Graph ns) es
  where
    us = liftM (take (length ns)) $ getRandomRs ((0, 1) :: (Double, Double))
    es = (liftM (applyUpper w) us) >>= (setEdges (completeEdges ns))

-- Graphon Model: generates a w-random graph. Parallel.
graphonGen' :: (Ord a, RandomGen g) => [a] -> (Double -> Double -> Double)
  -> Rand g (Graph a)
graphonGen' ns w = liftM2 pseq (liftM2 par (liftM force es) (liftM force
                               es')) (liftM (Graph ns) (liftM2 (++) es
                               es'))
  where
    us = liftM (take (length ns)) $ getRandomRs ((0, 1) :: (Double, Double))
    cs = completeEdges ns
    n = length ns
    cshalf = splitAt (((n * (n-1))+2) `div` 4) cs
    es = (liftM (applyUpper w) us) >>= (setEdges (fst cshalf))
    es' = (liftM (applyUpper w) us) >>= (setEdges (snd cshalf))

-- From "Real World Haskell". Used in the parallel version of the code for
-- generating w-random graphs, `graphonGen'`.
force :: [a] -> ()
force xs = go xs `pseq` ()
  where go (_:xs) = go xs
        go [] = 1

-- Apply a function to the upper triangle of an array.
applyUpper :: (a -> a -> b) -> [a] -> [b]
applyUpper f xs = [ f (fst x) (fst y) | x <- zl, y <- zl, snd x < snd y ]
  where
    zl = zip xs ([1..] :: [Int])

sblock :: Double -> Double -> Double
sblock x y
  | x < 0.5 && y < 0.5 = 0.8
  | x < 0.5 || y < 0.5 = 0.2
  | otherwise          = 0.8

-- Need to create a show instance for this (or rewrite it).
round' :: (RealFrac a, RealFrac b, Integral b) => Int -> a -> b
round' x = (/ 10^x) . round . (* 10^x)

main :: IO ()
main = do
    -- values <- evalRandIO $ graphonGen [1..10] (\x y -> (x+y)/2)
    let n = 100 :: Int
    gr <- evalRandIO $ graphonGen [1..n] sblock
    putStrLn . show . length $ community (toMap gr) 1
    -- let spannum = spanTreeCount values
    -- putStrLn . (\x -> "Number of spanning trees: " ++ x) $ show spannum
    -- putStrLn . show $ spectralCluster' values
    -- putStrLn . (\x -> "Guess for optimal lambda: " ++ x) . show
    --  $ lambdaSelect values
    -- putStrLn . (\x -> "This is " ++ x ++ "% of the true value." ) . show
    --   . round' 4 . ((/) $ fromIntegral n^(n-2)) $ fromIntegral spannum


{-# LANGUAGE ApplicativeDo                            #-}
{-# LANGUAGE DataKinds                                #-}
{-# LANGUAGE EmptyCase                                #-}
{-# LANGUAGE FlexibleContexts                         #-}
{-# LANGUAGE GADTs                                    #-}
{-# LANGUAGE KindSignatures                           #-}
{-# LANGUAGE LambdaCase                               #-}
{-# LANGUAGE PartialTypeSignatures                    #-}
{-# LANGUAGE QuantifiedConstraints                    #-}
{-# LANGUAGE RankNTypes                               #-}
{-# LANGUAGE RecordWildCards                          #-}
{-# LANGUAGE ScopedTypeVariables                      #-}
{-# LANGUAGE TupleSections                            #-}
{-# LANGUAGE TypeApplications                         #-}
{-# LANGUAGE TypeInType                               #-}
{-# LANGUAGE TypeOperators                            #-}
{-# LANGUAGE ViewPatterns                             #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures     #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Extra.Solver    #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

import           Backprop.Learn
import           Control.Applicative
import           Control.DeepSeq
import           Control.Exception
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Primitive
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.State
import           Data.Char
import           Data.Conduit
import           Data.Default
import           Data.Kind
import           Data.Proxy
import           Data.Singletons
import           Data.Singletons.TypeLits
import           Data.Time
import           Data.Type.Equality
import           Data.Type.Tuple
import           GHC.TypeLits.Compare
import           GHC.TypeNats
import           Numeric.LinearAlgebra.Static.Backprop hiding ((<>))
import           Numeric.Natural
import           Numeric.Opto
import           Options.Applicative
import           Statistics.Distribution
import           Statistics.Distribution.Normal
import           Text.Printf
import qualified Data.Conduit.Combinators                     as C
import qualified Data.Vector.Sized                            as SV
import qualified System.Random.MWC                            as MWC

data Mode = CSimulate (Maybe Int)
          | forall s p. ( Floating s
                        , Floating p
                        , NFData s
                        , NFData p
                        , Metric Double s
                        , Metric Double p
                        , Show s
                        , Show p
                        , Initialize p
                        , Initialize s
                        , Backprop p
                        , Backprop s
                        , forall m. PrimMonad m => LinearInPlace m Double p
                        , forall m. PrimMonad m => LinearInPlace m Double s
                        )
                        => CLearn (ModelPick p s)

data ModelPick :: Type -> Type -> Type where
    MARIMA :: Sing p -> Sing d -> Sing q
           -> ModelPick (ARIMAp p q) (ARIMAs p d q)
    MFCRNN :: Sing h
           -> ModelPick (LRp h 1 :# LRp (1 + h) h) (R h)
    MLSTM  :: Sing h
           -> ModelPick (LRp h 1 :# LSTMp 1 h)     (R h :# R h)
    MGRU   :: Sing h
           -> ModelPick (LRp h 1 :# GRUp 1 h)      (R h)

data Process = PSin

modelLearn :: ModelPick p s -> Model ('Just p) ('Just s) Double Double
modelLearn = \case
    MARIMA (SNat :: Sing pp) (SNat :: Sing d) (SNat :: Sing q) ->
              arima @pp @d @q
    MFCRNN (SNat :: Sing h) ->
              funcD sumElements
           <~ fc
           <~ fcra logistic logistic
           <~ funcD konst
    MLSTM  (SNat :: Sing h) ->
              funcD sumElements
           <~ fc
           <~ lstm
           <~ funcD konst
    MGRU   (SNat :: Sing h) ->
              funcD sumElements
           <~ fc
           <~ gru
           <~ funcD konst

data Options = O { oMode     :: Mode
                 , oProcess  :: Process
                 , oNoise    :: Double
                 , oInterval :: Int
                 , oLookback :: Natural
                 }

processConduit
    :: PrimMonad m
    => Process
    -> MWC.Gen (PrimState m)
    -> ConduitT i Double m ()
processConduit = \case
    PSin -> \g -> void . flip (foldr (>=>) pure) (0, 1) . repeat $ \(t, v) -> do
      dv <- genContVar (normalDistr 0 0.025) g
      let v' = min 2 . max 0.5 $ v + dv
          t' = t + v'
      yield (sin (2 * pi * (1/25) * t))
      return (t', v')

noisyConduit
    :: PrimMonad m
    => Double
    -> MWC.Gen (PrimState m)
    -> ConduitT Double Double m ()
noisyConduit σ g = C.mapM $ \x ->
    (x + ) <$> genContVar (normalDistr 0 σ) g

-- type Context = ConduitT (Vector)

main :: IO ()
main = MWC.withSystemRandom @IO $ \g -> do
    O{..} <- execParser $ info (parseOpt <**> helper)
                            ( fullDesc
                           <> progDesc "Learning ARIMA"
                           <> header "backprop-learn-arima - backprop-learn demo"
                            )

    SomeNat (Proxy :: Proxy n) <- pure $ someNatVal oLookback
    Just Refl <- pure $ Proxy @1 `isLE` Proxy @n
    let generator = processConduit oProcess g
                 .| noisyConduit oNoise g

    case oMode of
      CSimulate lim ->
        runConduit $ generator
                  .| maybe (C.map id) C.take lim
                  .| C.mapM_ print
                  .| C.sinkNull

      CLearn (modelLearn->model) -> do
        let unrolled = trainState . unrollFinal @(SV.Vector n) $ model
        p0 <- initParamNormal unrolled 0.2 g

        let report n b = do
              liftIO $ printf "(Batch %d)\n" (b :: Int)
              t0 <- liftIO getCurrentTime
              C.drop (n - 1)
              mp <- mapM (liftIO . evaluate . force) =<< await
              t1 <- liftIO getCurrentTime
              case mp of
                Nothing -> liftIO $ putStrLn "Done!"
                Just p -> do
                  chnk <- lift . state $ (,[])
                  liftIO $ do
                    printf "Trained on %d points in %s.\n"
                      (length chnk)
                      (show (t1 `diffUTCTime` t0))
                    let trainScore = testModelAll absErrorTest unrolled (TJust p) chnk
                    printf "Training error:   %.8f\n" trainScore
                  report n (b + 1)

        flip evalStateT []
            . runConduit
            $ transPipe lift generator
           .| leadings
           .| skipSampling 0.05 g
           .| C.iterM (modify . (:))
           .| optoConduit def p0
                (adam def (modelGrad squaredError noReg unrolled))
           .| report oInterval 0
           .| C.sinkNull

parseOpt :: Parser Options
parseOpt = O <$> subparser ( command "simulate" (info (parseSim   <**> helper) (progDesc "Simulate ARIMA only"))
                          <> command "learn"    (info (parseLearn <**> helper) (progDesc "Simulate and learn model"))
                           )
             <*> option (maybeReader parseProcess)
                   ( long "process"
                  <> help "Process to learn"
                  <> showDefaultWith showProcess
                  <> value PSin
                  <> metavar "PROCESS"
                   )
             <*> option auto
                   ( short 'e'
                  <> help "Standard deviation of noise term"
                  <> showDefault
                  <> value 0.05
                  <> metavar "DOUBLE"
                   )
             <*> option auto
                   ( long "interval"
                  <> short 'i'
                  <> help "Report interval"
                  <> showDefault
                  <> value 5000
                  <> metavar "INT"
                   )
             <*> option auto
                   ( long "lookback"
                  <> short 'l'
                  <> help "Learn lookback"
                  <> showDefault
                  <> value 10
                  <> metavar "INT"
                   )
  where
    parseSim :: Parser Mode
    parseSim = CSimulate <$> optional (option auto
                                          ( short 'n'
                                         <> help "Number of items to generate (infinite, if none given)"
                                         <> metavar "INT"
                                          )
                                      )
    parseLearn :: Parser Mode
    parseLearn = subparser
        ( command "arima" (info parseARIMA (progDesc "Learn ARIMA(p,d,q) model"))
       <> command "fcrnn" (info parseFCRNN (progDesc "Learn Fully Connected RNN model"))
       <> command "lstm"  (info parseLSTM  (progDesc "Learn LSTM model"))
       <> command "gru"   (info parseGRU   (progDesc "Learn GRU model"))
        )
    parseARIMA :: Parser Mode
    parseARIMA = do
        p <- argument auto ( help "AR(p): Autoregressive lookback"
                          <> metavar "INT"
                           )
        d <- argument auto ( help "I(d): Differencing degree"
                          <> metavar "INT"
                           )
        q <- argument auto ( help "MA(q): Moving average lookback"
                          <> metavar "INT"
                           )
        pure $ withSomeSing @Nat p $ \sp@SNat ->
          withSomeSing @Nat d $ \sd@SNat ->
          withSomeSing @Nat q $ \sq@SNat ->
            CLearn (MARIMA sp sd sq)
    parseFCRNN :: Parser Mode
    parseFCRNN = do
        h <- argument auto ( help "Hidden layer size"
                          <> metavar "INT"
                          <> showDefault
                          <> value 10
                           )
        pure $ withSomeSing @Nat h $ \sh@SNat ->
          CLearn (MFCRNN sh)
    parseLSTM :: Parser Mode
    parseLSTM = do
        h <- argument auto ( help "Hidden layer size"
                          <> metavar "INT"
                          <> showDefault
                          <> value 10
                           )
        pure $ withSomeSing @Nat h $ \sh@SNat ->
          CLearn (MLSTM sh)
    parseGRU :: Parser Mode
    parseGRU = do
        h <- argument auto ( help "Hidden layer size"
                          <> metavar "INT"
                          <> showDefault
                          <> value 10
                           )
        pure $ withSomeSing @Nat h $ \sh@SNat ->
          CLearn (MGRU sh)

showProcess :: Process -> String
showProcess PSin = "sin"

parseProcess :: String -> Maybe Process
parseProcess s = case map toLower s of
    "sin" -> Just PSin
    _     -> Nothing


module Numeric.FFT.Special.Miscellaneous
       ( special6, special9, special10, special12, special14
       , special15, special20, special25
       ) where

import           Control.Monad.ST
import           Data.Complex
import qualified Data.Vector.Unboxed.Mutable as MV

import           Numeric.FFT.Types

-- | Length 6 hard-coded FFT.
kp866025403, kp500000000 :: Double
kp866025403 = 0.866025403784438646763723170752936183471402627
kp500000000 = 0.500000000000000000000000000000000000000000000
special6 :: Int -> MVCD s -> MVCD s -> ST s ()
special6 sign xsin xsout = do
  xr0 :+ xi0 <- MV.unsafeRead xsin 0 ; xr1 :+ xi1 <- MV.unsafeRead xsin 1
  xr2 :+ xi2 <- MV.unsafeRead xsin 2 ; xr3 :+ xi3 <- MV.unsafeRead xsin 3
  xr4 :+ xi4 <- MV.unsafeRead xsin 4 ; xr5 :+ xi5 <- MV.unsafeRead xsin 5
  let tb = xr0 + xr3 ; t3 = xr0 - xr3 ; tx = xi0 + xi3 ; tp = xi0 - xi3
      tc = xr2 + xr5 ; t6 = xr2 - xr5 ; td = xr4 + xr1 ; t9 = xr4 - xr1
      te = tc + td ; tA = td - tc ; ts = t9 - t6 ; ta = t6 + t9
      tu = xi2 + xi5 ; ti = xi2 - xi5 ; tf = t3 - kp500000000 * ta
      tv = xi4 + xi1 ; tl = xi4 - xi1 ; tt = tb - kp500000000 * te
      ty = tu + tv ; tw = tu - tv ; tq = ti + tl ; tm = ti - tl
      tr = tp - kp500000000 * tq ; tz = tx - kp500000000 * ty
      r5 = (tf + kp866025403 * tm) :+ (tr + kp866025403 * ts)
      r4 = (tt - kp866025403 * tw) :+ (tz - kp866025403 * tA)
      r3 = (t3 + ta) :+ (tp + tq)
      r2 = (tt + kp866025403 * tw) :+ (tz + kp866025403 * tA)
      r1 = (tf - kp866025403 * tm) :+ (tr - kp866025403 * ts)
  MV.unsafeWrite xsout 0 $ (tb + te) :+ (tx + ty)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r5
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r4
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r3
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r2
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r1

-- | Length 9 hard-coded FFT.
kp954188894, kp363970234, kp852868531, kp984807753 :: Double
kp492403876, kp777861913, kp839099631, kp176326980 :: Double
--kp866025403, kp500000000 :: Double
kp954188894 = 0.954188894138671133499268364187245676532219158
kp363970234 = 0.363970234266202361351047882776834043890471784
kp852868531 = 0.852868531952443209628250963940074071936020296
kp984807753 = 0.984807753012208059366743024589523013670643252
kp492403876 = 0.492403876506104029683371512294761506835321626
kp777861913 = 0.777861913430206160028177977318626690410586096
kp839099631 = 0.839099631177280011763127298123181364687434283
kp176326980 = 0.176326980708464973471090386868618986121633062
--kp866025403 = 0.866025403784438646763723170752936183471402627
--kp500000000 = 0.500000000000000000000000000000000000000000000
special9 :: Int -> MVCD s -> MVCD s -> ST s ()
special9 sign xsin xsout = do
  xr0 :+ xi0 <- MV.unsafeRead xsin 0 ; xr1 :+ xi1 <- MV.unsafeRead xsin 1
  xr2 :+ xi2 <- MV.unsafeRead xsin 2 ; xr3 :+ xi3 <- MV.unsafeRead xsin 3
  xr4 :+ xi4 <- MV.unsafeRead xsin 4 ; xr5 :+ xi5 <- MV.unsafeRead xsin 5
  xr6 :+ xi6 <- MV.unsafeRead xsin 6 ; xr7 :+ xi7 <- MV.unsafeRead xsin 7
  xr8 :+ xi8 <- MV.unsafeRead xsin 8
  let t4 = xr3 + xr6 ; tm = xr6 - xr3 ; tM = xi3 - xi6 ; tk = xi3 + xi6
      tL = xr0 - kp500000000 * t4 ; t5 = xr0 + t4
      tl = xi0 - kp500000000 * tk ; t1f = xi0 + tk
      tE = xr4 - xr7 ; t9 = xr4 + xr7 ; tH = xi7 - xi4 ; tC = xi4 + xi7
      ta = xr1 + t9 ; tG = xr1 - kp500000000 * t9
      t1c = xi1 + tC ; tD = xi1 - kp500000000 * tC
      tI = tG - kp866025403 * tH ; tX = tG + kp866025403 * tH
      tF = tD - kp866025403 * tE ; tW = tD + kp866025403 * tE
      t17 = tl - kp866025403 * tm ; tn = tl + kp866025403 * tm
      tw = xr8 - xr5 ; te = xr5 + xr8 ; tu = xi5 + xi8 ; tr = xi5 - xi8
      tN = tL + kp866025403 * tM ; tV = tL - kp866025403 * tM
      tf = xr2 + te ; to = xr2 - kp500000000 * te
      t1d = xi2 + tu ; tv = xi2 - kp500000000 * tu
      ts = to + kp866025403 * tr ; tZ = to - kp866025403 * tr
      tg = ta + tf ; t1i = tf - ta
      tx = tv + kp866025403 * tw ; t10 = tv - kp866025403 * tw
      t1e = t1c - t1d ; t1g = t1c + t1d
      t1b = t5 - kp500000000 * tg ; t1h = t1f - kp500000000 * t1g
      tO = tx + kp176326980 * ts ; ty = ts - kp176326980 * tx
      tJ = tF - kp839099631 * tI ; tP = tI + kp839099631 * tF
      tS = ty + kp777861913 * tJ ; tK = ty - kp777861913 * tJ
      tU = tO - kp777861913 * tP ; tQ = tO + kp777861913 * tP
      tT = tn + kp492403876 * tK ; tR = tN - kp492403876 * tQ
      t14 = tX - kp176326980 * tW ; tY = tW + kp176326980 * tX
      t11 = tZ - kp363970234 * t10 ; t15 = t10 + kp363970234 * tZ
      t12 = tY - kp954188894 * t11 ; t1a = tY + kp954188894 * t11
      t16 = t14 - kp954188894 * t15 ; t18 = t14 + kp954188894 * t15
      t13 = tV - kp492403876 * t12 ; t19 = t17 + kp492403876 * t18
      r8 = (tN + kp984807753 * tQ) :+ (tn - kp984807753 * tK)
      r7 = (tV + kp984807753 * t12) :+ (t17 - kp984807753 * t18)
      r6 = (t1b + kp866025403 * t1e) :+ (t1h + kp866025403 * t1i)
      r5 = (tR + kp852868531 * tS) :+ (tT + kp852868531 * tU)
      r4 = (t13 - kp852868531 * t16) :+ (t19 - kp852868531 * t1a)
      r3 = (t1b - kp866025403 * t1e) :+ (t1h - kp866025403 * t1i)
      r2 = (tR - kp852868531 * tS) :+ (tT - kp852868531 * tU)
      r1 = (t13 + kp852868531 * t16) :+ (t19 + kp852868531 * t1a)
  MV.unsafeWrite xsout 0 $ (t5 + tg) :+ (t1f + t1g)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r8
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r7
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r6
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r5
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r4
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r3
  MV.unsafeWrite xsout 7 $ if sign == 1 then r7 else r2
  MV.unsafeWrite xsout 8 $ if sign == 1 then r8 else r1

-- | Length 10 hard-coded FFT.
kp951056516, kp559016994, kp250000000, kp618033988 :: Double
kp951056516 = 0.951056516295153572116439333379382143405698634
kp559016994 = 0.559016994374947424102293417182819058860154590
kp250000000 = 0.250000000000000000000000000000000000000000000
kp618033988 = 0.618033988749894848204586834365638117720309180
special10 :: Int -> MVCD s -> MVCD s -> ST s ()
special10 sign xsin xsout = do
  xr0 :+ xi0 <- MV.unsafeRead xsin 0 ; xr1 :+ xi1 <- MV.unsafeRead xsin 1
  xr2 :+ xi2 <- MV.unsafeRead xsin 2 ; xr3 :+ xi3 <- MV.unsafeRead xsin 3
  xr4 :+ xi4 <- MV.unsafeRead xsin 4 ; xr5 :+ xi5 <- MV.unsafeRead xsin 5
  xr6 :+ xi6 <- MV.unsafeRead xsin 6 ; xr7 :+ xi7 <- MV.unsafeRead xsin 7
  xr8 :+ xi8 <- MV.unsafeRead xsin 8 ; xr9 :+ xi9 <- MV.unsafeRead xsin 9
  let tj = xr0 + xr5 ; t3 = xr0 - xr5 ; t1b = xi0 + xi5 ; tN = xi0 - xi5
      tk = xr2 + xr7 ; t6 = xr2 - xr7 ; to = xr6 + xr1 ; tg = xr6 - xr1
      tl = xr8 + xr3 ; t9 = xr8 - xr3 ; tn = xr4 + xr9 ; td = xr4 - xr9
      tm = tk + tl ; t1j = tk - tl ; ta = t6 + t9 ; tU = t6 - t9
      tp = tn + to ; t1i = tn - to ; th = td + tg ; tV = td - tg
      tq = tm + tp ; t10 = tm - tp ; ti = ta + th ; ts = ta - th
      tw = xi2 - xi7 ; t15 = xi2 + xi7 ; t13 = xi6 + xi1 ; tG = xi6 - xi1
      t16 = xi8 + xi3 ; tz = xi8 - xi3 ; t12 = xi4 + xi9 ; tD = xi4 - xi9
      t1c = t15 + t16 ; t17 = t15 - t16 ; tO = tw + tz ; tA = tw - tz
      t1d = t12 + t13 ; t14 = t12 - t13 ; tP = tD + tG ; tH = tD - tG
      t1e = t1c + t1d ; t1g = t1c - t1d ; tQ = tO + tP ; tS = tO - tP
      tK = tH - kp618033988 * tA ; tI = tA + kp618033988 * tH
      tr = t3 - kp250000000 * ti ; tY = tV - kp618033988 * tU
      tW = tU + kp618033988 * tV ; tR = tN - kp250000000 * tQ
      tJ = tr - kp559016994 * ts ; tt = tr + kp559016994 * ts
      t1a = t17 + kp618033988 * t14 ; t18 = t14 - kp618033988 * t17
      tX = tR - kp559016994 * tS ; tT = tR + kp559016994 * tS
      tZ = tj - kp250000000 * tq ; t1m = t1j + kp618033988 * t1i
      t1k = t1i - kp618033988 * t1j ; t1f = t1b - kp250000000 * t1e
      t19 = tZ + kp559016994 * t10 ; t11 = tZ - kp559016994 * t10
      t1h = t1f - kp559016994 * t1g ; t1l = t1f + kp559016994 * t1g
      r9 = (tt + kp951056516 * tI) :+ (tT - kp951056516 * tW)
      r8 = (t11 - kp951056516 * t18) :+ (t1h + kp951056516 * t1k)
      r7 = (tJ + kp951056516 * tK) :+ (tX - kp951056516 * tY)
      r6 = (t19 - kp951056516 * t1a) :+ (t1l + kp951056516 * t1m)
      r5 = (t3 + ti) :+ (tN + tQ)
      r4 = (t19 + kp951056516 * t1a) :+ (t1l - kp951056516 * t1m)
      r3 = (tJ - kp951056516 * tK) :+ (tX + kp951056516 * tY)
      r2 = (t11 + kp951056516 * t18) :+ (t1h - kp951056516 * t1k)
      r1 = (tt - kp951056516 * tI) :+ (tT + kp951056516 * tW)
  MV.unsafeWrite xsout 0 $ (tj + tq) :+ (t1b + t1e)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r9
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r8
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r7
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r6
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r5
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r4
  MV.unsafeWrite xsout 7 $ if sign == 1 then r7 else r3
  MV.unsafeWrite xsout 8 $ if sign == 1 then r8 else r2
  MV.unsafeWrite xsout 9 $ if sign == 1 then r9 else r1

-- | Length 12 hard-coded FFT.
--kp866025403, kp500000000 :: Double
--kp866025403 = 0.866025403784438646763723170752936183471402627
--kp500000000 = 0.500000000000000000000000000000000000000000000
special12 :: Int -> MVCD s -> MVCD s -> ST s ()
special12 sign xsin xsout = do
  xr0  :+ xi0  <- MV.unsafeRead xsin 0  ; xr1  :+ xi1  <- MV.unsafeRead xsin 1
  xr2  :+ xi2  <- MV.unsafeRead xsin 2  ; xr3  :+ xi3  <- MV.unsafeRead xsin 3
  xr4  :+ xi4  <- MV.unsafeRead xsin 4  ; xr5  :+ xi5  <- MV.unsafeRead xsin 5
  xr6  :+ xi6  <- MV.unsafeRead xsin 6  ; xr7  :+ xi7  <- MV.unsafeRead xsin 7
  xr8  :+ xi8  <- MV.unsafeRead xsin 8  ; xr9  :+ xi9  <- MV.unsafeRead xsin 9
  xr10 :+ xi10 <- MV.unsafeRead xsin 10 ; xr11 :+ xi11 <- MV.unsafeRead xsin 11
  let t4 = xr4 + xr8 ; tA = xr8 - xr4 ; tS = xi4 - xi8 ; tr = xi4 + xi8
      tR = xr0 - kp500000000 * t4 ; t5 = xr0 + t4 ; ts = xi0 + tr
      tz = xi0 - kp500000000 * tr ; t9 = xr10 + xr2 ; tD = xr2 - xr10
      tV = xi10 - xi2 ; tw = xi10 + xi2 ; tU = xr6 - kp500000000 * t9
      ta = xr6 + t9 ; tx = xi6 + tw ; tC = xi6 - kp500000000 * tw
      tf = xr7 + xr11 ; t1d = xr11 - xr7 ; tJ = xi7 - xi11 ; t1b = xi7 + xi11
      tG = xr3 - kp500000000 * tf ; tg = xr3 + tf ; t1u = xi3 + t1b
      t1c = xi3 - kp500000000 * t1b ; tk = xr1 + xr5 ; t1i = xr5 - xr1
      t1t = t5 - ta ; tb = t5 + ta ; tO = xi1 - xi5 ; t1g = xi1 + xi5
      tL = xr9 - kp500000000 * tk ; tl = xr9 + tk ; t1x = ts + tx
      ty = ts - tx ; t1v = xi9 + t1g ; t1h = xi9 - kp500000000 * t1g
      tn = tg - tl ; tm = tg + tl ; t1y = t1u + t1v ; t1w = t1u - t1v
      tB = tz - kp866025403 * tA ; tZ = tz + kp866025403 * tA
      t10 = tC + kp866025403 * tD ; tE = tC - kp866025403 * tD
      t1o = t1c - kp866025403 * t1d ; t1e = t1c + kp866025403 * t1d
      t1l = tZ + t10 ; t11 = tZ - t10 ; t1j = t1h + kp866025403 * t1i
      t1p = t1h - kp866025403 * t1i ; tK = tG - kp866025403 * tJ
      t12 = tG + kp866025403 * tJ ; t13 = tL + kp866025403 * tO
      tP = tL - kp866025403 * tO ; tT = tR - kp866025403 * tS
      t15 = tR + kp866025403 * tS ; t1m = t1e + t1j ; t1k = t1e - t1j
      t18 = t12 + t13 ; t14 = t12 - t13 ; t16 = tU + kp866025403 * tV
      tW = tU - kp866025403 * tV ; t17 = t15 + t16 ; t19 = t15 - t16
      t1r = tB + tE ; tF = tB - tE ; t1s = t1o + t1p ; t1q = t1o - t1p
      tY = tK + tP ; tQ = tK - tP ; tX = tT + tW ; t1n = tT - tW
      r11 = (t19 + t1k) :+ (t11 - t14)
      r10 = (tX - tY) :+ (t1r - t1s)
      r9 = (t1t - t1w) :+ (tn + ty)
      r8 = (t17 + t18) :+ (t1l + t1m)
      r7 = (t1n + t1q) :+ (tF - tQ)
      r6 = (tb - tm) :+ (t1x - t1y)
      r5 = (t19 - t1k) :+ (t11 + t14)
      r4 = (tX + tY) :+ (t1r + t1s)
      r3 = (t1t + t1w) :+ (ty - tn)
      r2 = (t17 - t18) :+ (t1l - t1m)
      r1 = (t1n - t1q) :+ (tF + tQ)
  MV.unsafeWrite xsout 0 $ (tb + tm) :+ (t1x + t1y)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r11
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r10
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r9
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r8
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r7
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r6
  MV.unsafeWrite xsout 7 $ if sign == 1 then r7 else r5
  MV.unsafeWrite xsout 8 $ if sign == 1 then r8 else r4
  MV.unsafeWrite xsout 9 $ if sign == 1 then r9 else r3
  MV.unsafeWrite xsout 10 $ if sign == 1 then r10 else r2
  MV.unsafeWrite xsout 11 $ if sign == 1 then r11 else r1

-- | Length 14 hard-coded FFT.
kp974927912, kp801937735, kp900968867 :: Double
kp554958132, kp692021471, kp356895867 :: Double
kp974927912 = 0.974927912181823607018131682993931217232785801
kp801937735 = 0.801937735804838252472204639014890102331838324
kp900968867 = 0.900968867902419126236102319507445051165919162
kp554958132 = 0.554958132087371191422194871006410481067288862
kp692021471 = 0.692021471630095869627814897002069140197260599
kp356895867 = 0.356895867892209443894399510021300583399127187
special14 :: Int -> MVCD s -> MVCD s -> ST s ()
special14 sign xsin xsout = do
  xr0  :+ xi0  <- MV.unsafeRead xsin 0  ; xr1  :+ xi1  <- MV.unsafeRead xsin 1
  xr2  :+ xi2  <- MV.unsafeRead xsin 2  ; xr3  :+ xi3  <- MV.unsafeRead xsin 3
  xr4  :+ xi4  <- MV.unsafeRead xsin 4  ; xr5  :+ xi5  <- MV.unsafeRead xsin 5
  xr6  :+ xi6  <- MV.unsafeRead xsin 6  ; xr7  :+ xi7  <- MV.unsafeRead xsin 7
  xr8  :+ xi8  <- MV.unsafeRead xsin 8  ; xr9  :+ xi9  <- MV.unsafeRead xsin 9
  xr10 :+ xi10 <- MV.unsafeRead xsin 10 ; xr11 :+ xi11 <- MV.unsafeRead xsin 11
  xr12 :+ xi12 <- MV.unsafeRead xsin 12 ; xr13 :+ xi13 <- MV.unsafeRead xsin 13
  let tp = xr0 + xr7 ; t3 = xr0 - xr7 ; t1x = xi0 + xi7 ; t1b = xi0 - xi7
      tq = xr2 + xr9 ; t6 = xr2 - xr9 ; tr = xr12 + xr5 ; t9 = xr12 - xr5
      tx = xr8 + xr1 ; tn = xr8 - xr1 ; tw = xr6 + xr13 ; tk = xr6 - xr13
      to = tk + tn ; t1i = tn - tk ; tu = xr10 + xr3 ; tg = xr10 - xr3
      tt = xr4 + xr11 ; td = xr4 - xr11 ; t1M = tr - tq ; ts = tq + tr
      ta = t6 + t9 ; t1k = t9 - t6 ; t1L = tt - tu ; tv = tt + tu
      th = td + tg ; t1j = tg - td ; t1K = tw - tx ; ty = tw + tx
      tZ = to - kp356895867 * ta ; t14 = th - kp356895867 * to
      tz = ta - kp356895867 * th ; t1Z = ty - kp356895867 * ts
      t27 = ts - kp356895867 * tv ; t2c = tv - kp356895867 * ty
      t1B = xi4 + xi11 ; tE = xi4 - xi11 ; t1C = xi10 + xi3 ; tH = xi10 - xi3
      t1F = xi8 + xi1 ; tV = xi8 - xi1 ; t1E = xi6 + xi13 ; tS = xi6 - xi13
      t1z = xi12 + xi5 ; tO = xi12 - xi5 ; t1d = tE + tH ; tI = tE - tH
      t23 = t1F - t1E ; t1G = t1E + t1F ; t1D = t1B + t1C ; t24 = t1C - t1B
      t1y = xi2 + xi9 ; tL = xi2 - xi9 ; tW = tS - tV ; t1e = tS + tV
      t22 = t1y - t1z ; t1A = t1y + t1z ; tP = tL - tO ; t1c = tL + tO
      t1n = t1e - kp356895867 * t1c ; t1s = t1c - kp356895867 * t1d
      t1f = t1d - kp356895867 * t1e ; t1P = t1G - kp356895867 * t1A
      t1U = t1A - kp356895867 * t1D ; t1H = t1D - kp356895867 * t1G
      tA = to - kp692021471 * tz ; tX = tP + kp554958132 * tW
      t1t = t1e - kp692021471 * t1s ; t1v = t1k + kp554958132 * t1i
      tB = t3 - kp900968867 * tA ; tY = tI + kp801937735 * tX
      t1u = t1b - kp900968867 * t1t ; t1w = t1j + kp801937735 * t1v
      t10 = th - kp692021471 * tZ ; t11 = t3 - kp900968867 * t10
      t12 = tW + kp554958132 * tI ; t1o = t1d - kp692021471 * t1n
      t1q = t1i + kp554958132 * t1j ; t15 = ta - kp692021471 * t14
      t13 = tP - kp801937735 * t12 ; t1p = t1b - kp900968867 * t1o
      t1r = t1k - kp801937735 * t1q ; t16 = t3 - kp900968867 * t15
      t17 = tI - kp554958132 * tP ; t1g = t1c - kp692021471 * t1f
      t1l = t1j - kp554958132 * t1k ; t1I = t1A - kp692021471 * t1H
      t18 = tW - kp801937735 * t17 ; t1h = t1b - kp900968867 * t1g
      t1m = t1i - kp801937735 * t1l ; t1J = t1x - kp900968867 * t1I
      t1N = t1L + kp554958132 * t1M ; t2d = ts - kp692021471 * t2c
      t2f = t24 + kp554958132 * t22 ; t1Q = t1D - kp692021471 * t1P
      t1O = t1K - kp801937735 * t1N ; t2e = tp - kp900968867 * t2d
      t2g = t23 - kp801937735 * t2f ; t1R = t1x - kp900968867 * t1Q
      t1S = t1K + kp554958132 * t1L ; t20 = tv - kp692021471 * t1Z
      t25 = t23 + kp554958132 * t24 ; t1V = t1G - kp692021471 * t1U
      t1T = t1M + kp801937735 * t1S ; t21 = tp - kp900968867 * t20
      t26 = t22 + kp801937735 * t25 ; t1W = t1x - kp900968867 * t1V
      t1X = t1M - kp554958132 * t1K ; t28 = ty - kp692021471 * t27
      t2a = t22 - kp554958132 * t23 ; t1Y = t1L - kp801937735 * t1X
      t29 = tp - kp900968867 * t28 ; t2b = t24 - kp801937735 * t2a
      r13 = (tB + kp974927912 * tY) :+ (t1u + kp974927912 * t1w)
      r12 = (t21 + kp974927912 * t26) :+ (t1R + kp974927912 * t1T)
      r11 = (t16 + kp974927912 * t18) :+ (t1h + kp974927912 * t1m)
      r10 = (t2e + kp974927912 * t2g) :+ (t1J + kp974927912 * t1O)
      r9 = (t11 - kp974927912 * t13) :+ (t1p - kp974927912 * t1r)
      r8 = (t29 + kp974927912 * t2b) :+ (t1W + kp974927912 * t1Y)
      r7 = (t3 + ta + th + to) :+ (t1b + t1c + t1d + t1e)
      r6 = (t29 - kp974927912 * t2b) :+ (t1W - kp974927912 * t1Y)
      r5 = (t11 + kp974927912 * t13) :+ (t1p + kp974927912 * t1r)
      r4 = (t2e - kp974927912 * t2g) :+ (t1J - kp974927912 * t1O)
      r3 = (t16 - kp974927912 * t18) :+ (t1h - kp974927912 * t1m)
      r2 = (t21 - kp974927912 * t26) :+ (t1R - kp974927912 * t1T)
      r1 = (tB - kp974927912 * tY) :+ (t1u - kp974927912 * t1w)
  MV.unsafeWrite xsout 0 $ (tp + ts + tv + ty) :+ (t1x + t1A + t1D + t1G)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r13
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r12
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r11
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r10
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r9
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r8
  MV.unsafeWrite xsout 7 $ if sign == 1 then r7 else r7
  MV.unsafeWrite xsout 8 $ if sign == 1 then r8 else r6
  MV.unsafeWrite xsout 9 $ if sign == 1 then r9 else r5
  MV.unsafeWrite xsout 10 $ if sign == 1 then r10 else r4
  MV.unsafeWrite xsout 11 $ if sign == 1 then r11 else r3
  MV.unsafeWrite xsout 12 $ if sign == 1 then r12 else r2
  MV.unsafeWrite xsout 13 $ if sign == 1 then r13 else r1

-- | Length 15 hard-coded FFT.
--kp951056516, kp559016994, kp618033988 :: Double
--kp250000000, kp866025403, kp500000000 :: Double
--kp951056516 = 0.951056516295153572116439333379382143405698634
--kp559016994 = 0.559016994374947424102293417182819058860154590
--kp618033988 = 0.618033988749894848204586834365638117720309180
--kp250000000 = 0.250000000000000000000000000000000000000000000
--kp866025403 = 0.866025403784438646763723170752936183471402627
--kp500000000 = 0.500000000000000000000000000000000000000000000
special15 :: Int -> MVCD s -> MVCD s -> ST s ()
special15 sign xsin xsout = do
  xr0  :+ xi0  <- MV.unsafeRead xsin 0  ; xr1  :+ xi1  <- MV.unsafeRead xsin 1
  xr2  :+ xi2  <- MV.unsafeRead xsin 2  ; xr3  :+ xi3  <- MV.unsafeRead xsin 3
  xr4  :+ xi4  <- MV.unsafeRead xsin 4  ; xr5  :+ xi5  <- MV.unsafeRead xsin 5
  xr6  :+ xi6  <- MV.unsafeRead xsin 6  ; xr7  :+ xi7  <- MV.unsafeRead xsin 7
  xr8  :+ xi8  <- MV.unsafeRead xsin 8  ; xr9  :+ xi9  <- MV.unsafeRead xsin 9
  xr10 :+ xi10 <- MV.unsafeRead xsin 10 ; xr11 :+ xi11 <- MV.unsafeRead xsin 11
  xr12 :+ xi12 <- MV.unsafeRead xsin 12 ; xr13 :+ xi13 <- MV.unsafeRead xsin 13
  xr14 :+ xi14 <- MV.unsafeRead xsin 14
  let t1y = xr10 - xr5 ; t4 = xr5 + xr10 ; t1w = xi5 + xi10 ; tw = xi5 - xi10
      t5 = xr0 + t4 ; tt = xr0 - kp500000000 * t4
      t2l = xi0 + t1w ; t1x = xi0 - kp500000000 * t1w
      tx = tt - kp866025403 * tw ; tV = tt + kp866025403 * tw
      t1z = t1x + kp866025403 * t1y ; t1X = t1x - kp866025403 * t1y
      tk = xr11 + xr1 ; t1k = xr1 - xr11 ; tM = xi11 - xi1 ; t1i = xi11 + xi1
      tJ = xr6 - kp500000000 * tk ; tl = xr6 + tk ; t2c = xi6 + t1i
      t1j = xi6 - kp500000000 * t1i ; t1p = xr4 - xr14 ; tp = xr14 + xr4
      tN = tJ - kp866025403 * tM ; tZ = tJ + kp866025403 * tM
      tO = xr9 - kp500000000 * tp ; tq = xr9 + tp ; t1n = xi14 + xi4
      tR = xi14 - xi4 ; t2s = tl - tq ; tr = tl + tq
      t10 = tO + kp866025403 * tR ; tS = tO - kp866025403 * tR
      t1o = xi9 - kp500000000 * t1n ; t2d = xi9 + t1n
      t1O = t1j - kp866025403 * t1k ; t1l = t1j + kp866025403 * t1k
      t24 = tN - tS ; tT = tN + tS ; t1P = t1o - kp866025403 * t1p
      t1q = t1o + kp866025403 * t1p ; t2e = t2c - t2d ; t2n = t2c + t2d
      t1Z = t1O + t1P ; t1Q = t1O - t1P ; t1r = t1l - t1q ; t1B = t1l + t1q
      t11 = tZ + t10 ; t1H = tZ - t10 ; t9 = xr8 + xr13 ; t19 = xr13 - xr8
      tB = xi8 - xi13 ; t17 = xi8 + xi13 ; ty = xr3 - kp500000000 * t9
      ta = xr3 + t9 ; t2f = xi3 + t17 ; t18 = xi3 - kp500000000 * t17
      t1e = xr7 - xr2 ; te = xr2 + xr7 ; tC = ty - kp866025403 * tB
      tW = ty + kp866025403 * tB ; tD = xr12 - kp500000000 * te
      tf = xr12 + te ; t1c = xi2 + xi7 ; tG = xi2 - xi7 ; t2t = ta - tf
      tg = ta + tf ; tX = tD + kp866025403 * tG
      tH = tD - kp866025403 * tG ; t1d = xi12 - kp500000000 * t1c
      t2g = xi12 + t1c ; t1R = t18 - kp866025403 * t19
      t1a = t18 + kp866025403 * t19 ; t25 = tC - tH ; tI = tC + tH
      t1S = t1d - kp866025403 * t1e ; t1f = t1d + kp866025403 * t1e
      t2h = t2f - t2g ; t2m = t2f + t2g ; t1Y = t1R + t1S ; t1T = t1R - t1S
      t1g = t1a - t1f ; t1A = t1a + t1f ; t2a = tg - tr ; ts = tg + tr
      tY = tW + tX ; t1G = tW - tX ; t29 = t5 - kp250000000 * ts
      t2o = t2m + t2n ; t2q = t2m - t2n ; t2k = t2h + kp618033988 * t2e
      t2i = t2e - kp618033988 * t2h ; t2b = t29 - kp559016994 * t2a
      t2j = t29 + kp559016994 * t2a ; t2p = t2l - kp250000000 * t2o
      tU = tI + tT ; t1M = tI - tT ; t2r = t2p - kp559016994 * t2q
      t2v = t2p + kp559016994 * t2q ; t2w = t2t + kp618033988 * t2s
      t2u = t2s - kp618033988 * t2t ; t1L = tx - kp250000000 * tU
      t20 = t1Y + t1Z ; t22 = t1Y - t1Z ; t1N = t1L - kp559016994 * t1M
      t1V = t1L + kp559016994 * t1M ; t1W = t1T + kp618033988 * t1Q
      t1U = t1Q - kp618033988 * t1T ; t21 = t1X - kp250000000 * t20
      t1C = t1A + t1B ; t1E = t1A - t1B ; t23 = t21 - kp559016994 * t22
      t27 = t21 + kp559016994 * t22 ; t28 = t25 + kp618033988 * t24
      t26 = t24 - kp618033988 * t25 ; t1D = t1z - kp250000000 * t1C
      t12 = tY + t11 ; t14 = tY - t11 ; t1F = t1D + kp559016994 * t1E
      t1J = t1D - kp559016994 * t1E ; t1K = t1H - kp618033988 * t1G
      t1I = t1G + kp618033988 * t1H ; t13 = tV - kp250000000 * t12
      t1t = t13 - kp559016994 * t14 ; t15 = t13 + kp559016994 * t14
      t1s = t1g + kp618033988 * t1r ; t1u = t1r - kp618033988 * t1g
      r14 = (t15 + kp951056516 * t1s) :+ (t1F - kp951056516 * t1I)
      r13 = (t1N - kp951056516 * t1U) :+ (t23 + kp951056516 * t26)
      r12 = (t2b + kp951056516 * t2i) :+ (t2r - kp951056516 * t2u)
      r11 = (t15 - kp951056516 * t1s) :+ (t1F + kp951056516 * t1I)
      r10 = (tx + tU) :+ (t1X + t20)
      r9 = (t2j + kp951056516 * t2k) :+ (t2v - kp951056516 * t2w)
      r8 = (t1t - kp951056516 * t1u) :+ (t1J + kp951056516 * t1K)
      r7 = (t1N + kp951056516 * t1U) :+ (t23 - kp951056516 * t26)
      r6 = (t2j - kp951056516 * t2k) :+ (t2v + kp951056516 * t2w)
      r5 = (tV + t12) :+ (t1z + t1C)
      r4 = (t1V + kp951056516 * t1W) :+ (t27 - kp951056516 * t28)
      r3 = (t2b - kp951056516 * t2i) :+ (t2r + kp951056516 * t2u)
      r2 = (t1t + kp951056516 * t1u) :+ (t1J - kp951056516 * t1K)
      r1 = (t1V - kp951056516 * t1W) :+ (t27 + kp951056516 * t28)
  MV.unsafeWrite xsout 0 $ (t5 + ts) :+ (t2l + t2o)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r14
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r13
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r12
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r11
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r10
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r9
  MV.unsafeWrite xsout 7 $ if sign == 1 then r7 else r8
  MV.unsafeWrite xsout 8 $ if sign == 1 then r8 else r7
  MV.unsafeWrite xsout 9 $ if sign == 1 then r9 else r6
  MV.unsafeWrite xsout 10 $ if sign == 1 then r10 else r5
  MV.unsafeWrite xsout 11 $ if sign == 1 then r11 else r4
  MV.unsafeWrite xsout 12 $ if sign == 1 then r12 else r3
  MV.unsafeWrite xsout 13 $ if sign == 1 then r13 else r2
  MV.unsafeWrite xsout 14 $ if sign == 1 then r14 else r1

-- | Length 20 hard-coded FFT.
--kp951056516, kp559016994, kp618033988, kp250000000 :: Double
--kp951056516 = 0.951056516295153572116439333379382143405698634
--kp559016994 = 0.559016994374947424102293417182819058860154590
--kp618033988 = 0.618033988749894848204586834365638117720309180
--kp250000000 = 0.250000000000000000000000000000000000000000000
special20 :: Int -> MVCD s -> MVCD s -> ST s ()
special20 sign xsin xsout = do
  xr0  :+ xi0  <- MV.unsafeRead xsin 0  ; xr1  :+ xi1  <- MV.unsafeRead xsin 1
  xr2  :+ xi2  <- MV.unsafeRead xsin 2  ; xr3  :+ xi3  <- MV.unsafeRead xsin 3
  xr4  :+ xi4  <- MV.unsafeRead xsin 4  ; xr5  :+ xi5  <- MV.unsafeRead xsin 5
  xr6  :+ xi6  <- MV.unsafeRead xsin 6  ; xr7  :+ xi7  <- MV.unsafeRead xsin 7
  xr8  :+ xi8  <- MV.unsafeRead xsin 8  ; xr9  :+ xi9  <- MV.unsafeRead xsin 9
  xr10 :+ xi10 <- MV.unsafeRead xsin 10 ; xr11 :+ xi11 <- MV.unsafeRead xsin 11
  xr12 :+ xi12 <- MV.unsafeRead xsin 12 ; xr13 :+ xi13 <- MV.unsafeRead xsin 13
  xr14 :+ xi14 <- MV.unsafeRead xsin 14 ; xr15 :+ xi15 <- MV.unsafeRead xsin 15
  xr16 :+ xi16 <- MV.unsafeRead xsin 16 ; xr17 :+ xi17 <- MV.unsafeRead xsin 17
  xr18 :+ xi18 <- MV.unsafeRead xsin 18 ; xr19 :+ xi19 <- MV.unsafeRead xsin 19
  let t1N = xr0 - xr10 ; t3 = xr0 + xr10 ; t2L = xi0 + xi10 ; tN = xi0 - xi10
      tO = xr5 - xr15 ; t6 = xr5 + xr15 ; t2M = xi5 + xi15 ; t1Q = xi5 - xi15
      t1d = tO + tN ; tP = tN - tO ; tD = t3 + t6 ; t7 = t3 - t6
      t3b = t2L + t2M ; t2N = t2L - t2M ; t2f = t1N + t1Q ; t1R = t1N - t1Q
      t1o = xr8 - xr18 ; tp = xr8 + xr18 ; t2u = xi8 + xi18 ; t13 = xi8 - xi18
      t14 = xr13 - xr3 ; ts = xr13 + xr3 ; t2v = xi13 + xi3 ; t1r = xi13 - xi3
      t1t = xr12 - xr2 ; tw = xr12 + xr2 ; t2x = xi12 + xi2 ; t18 = xi12 - xi2
      tH = tp + ts ; tt = tp - ts ; t19 = xr17 - xr7 ; tz = xr17 + xr7
      t2y = xi17 + xi7 ; t1w = xi17 - xi7 ; t2w = t2u - t2v ; t35 = t2u + t2v
      tI = tw + tz ; tA = tw - tz ; t2z = t2x - t2y ; t36 = t2x + t2y
      t2U = tt - tA ; tB = tt + tA ; t2P = t2w + t2z ; t2A = t2w - t2z
      t3d = t35 + t36 ; t37 = t35 - t36 ; t15 = t13 - t14 ; t1h = t14 + t13
      t1i = t19 + t18 ; t1a = t18 - t19 ; t1s = t1o - t1r ; t29 = t1o + t1r
      t3j = tH - tI ; tJ = tH + tI ; t1x = t1t - t1w ; t2a = t1t + t1w
      t2n = t15 - t1a ; t1b = t15 + t1a ; t1T = t1s + t1x ; t1y = t1s - t1x
      t2b = t29 - t2a ; t2h = t29 + t2a ; t1j = t1h + t1i ; t1Y = t1h - t1i
      ta = xr4 + xr14 ; t1z = xr4 - xr14 ; t2B = xi4 + xi14 ; tS = xi4 - xi14
      tT = xr9 - xr19 ; td = xr9 + xr19 ; t2C = xi9 + xi19 ; t1C = xi9 - xi19
      t1E = xr16 - xr6 ; th = xr16 + xr6 ; t2E = xi16 + xi6 ; tX = xi16 - xi6
      tE = ta + td ; te = ta - td ; tY = xr1 - xr11 ; tk = xr1 + xr11
      t2F = xi1 + xi11 ; t1H = xi1 - xi11 ; t2D = t2B - t2C ; t32 = t2B + t2C
      tF = th + tk ; tl = th - tk ; t2G = t2E - t2F ; t33 = t2E + t2F
      t2V = te - tl ; tm = te + tl ; t2O = t2D + t2G ; t2H = t2D - t2G
      t3c = t32 + t33 ; t34 = t32 - t33 ; tU = tS - tT ; t1e = tT + tS
      t1f = tY + tX ; tZ = tX - tY ; t1D = t1z - t1C ; t26 = t1z + t1C
      t3i = tE - tF ; tG = tE + tF ; t1I = t1E - t1H ; t27 = t1E + t1H
      t2m = tU - tZ ; t10 = tU + tZ ; t1S = t1D + t1I ; t1J = t1D - t1I
      t28 = t26 - t27 ; t2g = t26 + t27 ; t2s = tm - tB ; tC = tm + tB
      t1g = t1e + t1f ; t1Z = t1e - t1f ; t2r = t7 - kp250000000 * tC
      t2Q = t2O + t2P ; t2S = t2O - t2P ; t2K = t2H + kp618033988 * t2A
      t2I = t2A - kp618033988 * t2H ; t2t = t2r - kp559016994 * t2s
      t2J = t2r + kp559016994 * t2s ; t2R = t2N - kp250000000 * t2Q
      tK = tG + tJ ; t30 = tG - tJ ; t2T = t2R - kp559016994 * t2S
      t2X = t2R + kp559016994 * t2S ; t2Y = t2V + kp618033988 * t2U
      t2W = t2U - kp618033988 * t2V ; t2Z = tD - kp250000000 * tK
      t3e = t3c + t3d ; t3g = t3c - t3d ; t31 = t2Z + kp559016994 * t30
      t39 = t2Z - kp559016994 * t30 ; t3a = t37 - kp618033988 * t34
      t38 = t34 + kp618033988 * t37 ; t3f = t3b - kp250000000 * t3e
      t1c = t10 + t1b ; t24 = t10 - t1b ; t3h = t3f + kp559016994 * t3g
      t3l = t3f - kp559016994 * t3g ; t3m = t3j - kp618033988 * t3i
      t3k = t3i + kp618033988 * t3j ; t23 = tP - kp250000000 * t1c
      t2i = t2g + t2h ; t2k = t2g - t2h ; t25 = t23 + kp559016994 * t24
      t2d = t23 - kp559016994 * t24 ; t2e = t2b - kp618033988 * t28
      t2c = t28 + kp618033988 * t2b ; t2j = t2f - kp250000000 * t2i
      t1k = t1g + t1j ; t1m = t1g - t1j ; t2l = t2j + kp559016994 * t2k
      t2p = t2j - kp559016994 * t2k ; t2q = t2n - kp618033988 * t2m
      t2o = t2m + kp618033988 * t2n ; t1l = t1d - kp250000000 * t1k
      t1U = t1S + t1T ; t1W = t1S - t1T ; t1n = t1l - kp559016994 * t1m
      t1L = t1l + kp559016994 * t1m ; t1M = t1J + kp618033988 * t1y
      t1K = t1y - kp618033988 * t1J ; t1V = t1R - kp250000000 * t1U
      t21 = t1V + kp559016994 * t1W ; t1X = t1V - kp559016994 * t1W
      t20 = t1Y - kp618033988 * t1Z ; t22 = t1Z + kp618033988 * t1Y
      r19 = (t2l + kp951056516 * t2o) :+ (t25 - kp951056516 * t2c)
      r18 = (t2t - kp951056516 * t2I) :+ (t2T + kp951056516 * t2W)
      r17 = (t1X + kp951056516 * t20) :+ (t1n - kp951056516 * t1K)
      r16 = (t31 - kp951056516 * t38) :+ (t3h + kp951056516 * t3k)
      r15 = (t2f + t2i) :+ (tP + t1c)
      r14 = (t2J + kp951056516 * t2K) :+ (t2X - kp951056516 * t2Y)
      r13 = (t1X - kp951056516 * t20) :+ (t1n + kp951056516 * t1K)
      r12 = (t39 + kp951056516 * t3a) :+ (t3l - kp951056516 * t3m)
      r11 = (t2l - kp951056516 * t2o) :+ (t25 + kp951056516 * t2c)
      r10 = (t7 + tC) :+ (t2N + t2Q)
      r9 = (t21 + kp951056516 * t22) :+ (t1L - kp951056516 * t1M)
      r8 = (t39 - kp951056516 * t3a) :+ (t3l + kp951056516 * t3m)
      r7 = (t2p + kp951056516 * t2q) :+ (t2d - kp951056516 * t2e)
      r6 = (t2J - kp951056516 * t2K) :+ (t2X + kp951056516 * t2Y)
      r5 = (t1R + t1U) :+ (t1d + t1k)
      r4 = (t31 + kp951056516 * t38) :+ (t3h - kp951056516 * t3k)
      r3 = (t2p - kp951056516 * t2q) :+ (t2d + kp951056516 * t2e)
      r2 = (t2t + kp951056516 * t2I) :+ (t2T - kp951056516 * t2W)
      r1 = (t21 - kp951056516 * t22) :+ (t1L + kp951056516 * t1M)
  MV.unsafeWrite xsout 0 $ (tD + tK) :+ (t3b + t3e)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r19
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r18
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r17
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r16
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r15
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r14
  MV.unsafeWrite xsout 7 $ if sign == 1 then r7 else r13
  MV.unsafeWrite xsout 8 $ if sign == 1 then r8 else r12
  MV.unsafeWrite xsout 9 $ if sign == 1 then r9 else r11
  MV.unsafeWrite xsout 10 $ if sign == 1 then r10 else r10
  MV.unsafeWrite xsout 11 $ if sign == 1 then r11 else r9
  MV.unsafeWrite xsout 12 $ if sign == 1 then r12 else r8
  MV.unsafeWrite xsout 13 $ if sign == 1 then r13 else r7
  MV.unsafeWrite xsout 14 $ if sign == 1 then r14 else r6
  MV.unsafeWrite xsout 15 $ if sign == 1 then r15 else r5
  MV.unsafeWrite xsout 16 $ if sign == 1 then r16 else r4
  MV.unsafeWrite xsout 17 $ if sign == 1 then r17 else r3
  MV.unsafeWrite xsout 18 $ if sign == 1 then r18 else r2
  MV.unsafeWrite xsout 19 $ if sign == 1 then r19 else r1

-- | Length 25 hard-coded FFT.
kp803003575, kp554608978, kp248028675, kp726211448 :: Double
kp525970792, kp992114701, kp851038619, kp912575812 :: Double
kp912018591, kp943557151, kp614372930, kp621716863 :: Double
kp994076283, kp734762448, kp772036680, kp126329378 :: Double
kp827271945, kp949179823, kp860541664, kp557913902 :: Double
kp249506682, kp681693190, kp560319534, kp998026728 :: Double
kp906616052, kp968479752, kp845997307, kp470564281 :: Double
kp062914667, kp921177326, kp833417178, kp541454447 :: Double
kp242145790, kp683113946, kp559154169, kp968583161 :: Double
kp904730450, kp831864738, kp871714437, kp939062505 :: Double
kp549754652, kp634619297, kp256756360 :: Double
--kp951056516, kp559016994, kp250000000, kp618033988 :: Double
kp803003575 = 0.803003575438660414833440593570376004635464850
kp554608978 = 0.554608978404018097464974850792216217022558774
kp248028675 = 0.248028675328619457762448260696444630363259177
kp726211448 = 0.726211448929902658173535992263577167607493062
kp525970792 = 0.525970792408939708442463226536226366643874659
kp992114701 = 0.992114701314477831049793042785778521453036709
kp851038619 = 0.851038619207379630836264138867114231259902550
kp912575812 = 0.912575812670962425556968549836277086778922727
kp912018591 = 0.912018591466481957908415381764119056233607330
kp943557151 = 0.943557151597354104399655195398983005179443399
kp614372930 = 0.614372930789563808870829930444362096004872855
kp621716863 = 0.621716863012209892444754556304102309693593202
kp994076283 = 0.994076283785401014123185814696322018529298887
kp734762448 = 0.734762448793050413546343770063151342619912334
kp772036680 = 0.772036680810363904029489473607579825330539880
kp126329378 = 0.126329378446108174786050455341811215027378105
kp827271945 = 0.827271945972475634034355757144307982555673741
kp949179823 = 0.949179823508441261575555465843363271711583843
kp860541664 = 0.860541664367944677098261680920518816412804187
kp557913902 = 0.557913902031834264187699648465567037992437152
kp249506682 = 0.249506682107067890488084201715862638334226305
kp681693190 = 0.681693190061530575150324149145440022633095390
kp560319534 = 0.560319534973832390111614715371676131169633784
kp998026728 = 0.998026728428271561952336806863450553336905220
kp906616052 = 0.906616052148196230441134447086066874408359177
kp968479752 = 0.968479752739016373193524836781420152702090879
kp845997307 = 0.845997307939530944175097360758058292389769300
kp470564281 = 0.470564281212251493087595091036643380879947982
kp062914667 = 0.062914667253649757225485955897349402364686947
kp921177326 = 0.921177326965143320250447435415066029359282231
kp833417178 = 0.833417178328688677408962550243238843138996060
kp541454447 = 0.541454447536312777046285590082819509052033189
kp242145790 = 0.242145790282157779872542093866183953459003101
kp683113946 = 0.683113946453479238701949862233725244439656928
kp559154169 = 0.559154169276087864842202529084232643714075927
kp968583161 = 0.968583161128631119490168375464735813836012403
kp904730450 = 0.904730450839922351881287709692877908104763647
kp831864738 = 0.831864738706457140726048799369896829771167132
kp871714437 = 0.871714437527667770979999223229522602943903653
kp939062505 = 0.939062505817492352556001843133229685779824606
kp549754652 = 0.549754652192770074288023275540779861653779767
kp634619297 = 0.634619297544148100711287640319130485732531031
kp256756360 = 0.256756360367726783319498520922669048172391148
--kp951056516 = 0.951056516295153572116439333379382143405698634
--kp559016994 = 0.559016994374947424102293417182819058860154590
--kp250000000 = 0.250000000000000000000000000000000000000000000
--kp618033988 = 0.618033988749894848204586834365638117720309180
special25 :: Int -> MVCD s -> MVCD s -> ST s ()
special25 sign xsin xsout = do
  xr0  :+ xi0  <- MV.unsafeRead xsin 0  ; xr1  :+ xi1  <- MV.unsafeRead xsin 1
  xr2  :+ xi2  <- MV.unsafeRead xsin 2  ; xr3  :+ xi3  <- MV.unsafeRead xsin 3
  xr4  :+ xi4  <- MV.unsafeRead xsin 4  ; xr5  :+ xi5  <- MV.unsafeRead xsin 5
  xr6  :+ xi6  <- MV.unsafeRead xsin 6  ; xr7  :+ xi7  <- MV.unsafeRead xsin 7
  xr8  :+ xi8  <- MV.unsafeRead xsin 8  ; xr9  :+ xi9  <- MV.unsafeRead xsin 9
  xr10 :+ xi10 <- MV.unsafeRead xsin 10 ; xr11 :+ xi11 <- MV.unsafeRead xsin 11
  xr12 :+ xi12 <- MV.unsafeRead xsin 12 ; xr13 :+ xi13 <- MV.unsafeRead xsin 13
  xr14 :+ xi14 <- MV.unsafeRead xsin 14 ; xr15 :+ xi15 <- MV.unsafeRead xsin 15
  xr16 :+ xi16 <- MV.unsafeRead xsin 16 ; xr17 :+ xi17 <- MV.unsafeRead xsin 17
  xr18 :+ xi18 <- MV.unsafeRead xsin 18 ; xr19 :+ xi19 <- MV.unsafeRead xsin 19
  xr20 :+ xi20 <- MV.unsafeRead xsin 20 ; xr21 :+ xi21 <- MV.unsafeRead xsin 21
  xr22 :+ xi22 <- MV.unsafeRead xsin 22 ; xr23 :+ xi23 <- MV.unsafeRead xsin 23
  xr24 :+ xi24 <- MV.unsafeRead xsin 24
  let t4 = xr5+xr20 ; t1S = xr5-xr20 ; t7 = xr10+xr15 ; t1T = xr10-xr15
      t4Q = t1T-kp618033988*t1S ; t1U = t1S+kp618033988*t1T
      t8 = t4+t7 ; t3a = t4-t7 ; t3c = xi5-xi20 ; t1y = xi5+xi20
      t39 = xr0-kp250000000*t8 ; t9 = xr0+t8
      t1B = xi10+xi15 ; t3d = xi10-xi15
      t3b = t39+kp559016994*t3a ; t45 = t39-kp559016994*t3a
      t3e = t3c+kp618033988*t3d ; t46 = t3d-kp618033988*t3c
      t1C = t1y+t1B ; t1Q = t1y-t1B ; t1P = xi0-kp250000000*t1C
      t1D = xi0+t1C ; t4P = t1P-kp559016994*t1Q
      t1R = t1P+kp559016994*t1Q ; t1Z = xr21-xr6 ; td = xr6+xr21
      t20 = xr16-xr11 ; tg = xr11+xr16 ; th = td+tg ; t24 = td-tg
      t26 = xi6-xi21 ; tT = xi6+xi21 ; tW = xi11+xi16 ; t27 = xi16-xi11
      t1X = tT-tW ; tX = tT+tW ; t2l = xr24-xr9 ; tm = xr9+xr24
      t2m = xr19-xr14 ; tp = xr14+xr19 ; tq = tm+tp ; t2c = tm-tp
      t2e = xi24-xi9 ; t12 = xi9+xi24 ; t15 = xi14+xi19 ; t2f = xi19-xi14
      t23 = xr1-kp250000000*th ; ti = xr1+th ; t2j = t15-t12
      t16 = t12+t15 ; tr = xr4+tq ; t2b = kp250000000 * tq - xr4
      t1W = xi1-kp250000000*tX ; tY = xi1+tX
      t21 = t1Z+kp618033988*t20 ; t4y = t20-kp618033988*t1Z
      t2i = xi4-kp250000000*t16 ; t17 = xi4+t16 ; ts = ti+tr
      t1K = ti-tr ; t18 = tY-t17 ; t1E = tY+t17
      t2n = t2l+kp618033988*t2m ; t4r = t2m-kp618033988*t2l
      t4x = t1W-kp559016994*t1X ; t1Y = t1W+kp559016994*t1X
      t4o = t2f-kp618033988*t2e ; t2g = t2e+kp618033988*t2f
      t4z = t4x+kp951056516*t4y ; t5f = t4x-kp951056516*t4y
      t3z = t1Y-kp951056516*t21 ; t22 = t1Y+kp951056516*t21
      t4q = t2i+kp559016994*t2j ; t2k = t2i-kp559016994*t2j
      t4s = t4q+kp951056516*t4r ; t5b = t4q-kp951056516*t4r
      t3C = t2k-kp951056516*t2n ; t2o = t2k+kp951056516*t2n
      t2d = t2b-kp559016994*t2c ; t4n = t2b+kp559016994*t2c
      t28 = t26-kp618033988*t27 ; t4v = t27+kp618033988*t26
      t3D = t2d-kp951056516*t2g ; t2h = t2d+kp951056516*t2g
      t4p = t4n+kp951056516*t4o ; t5c = t4n-kp951056516*t4o
      t4u = t23-kp559016994*t24 ; t25 = t23+kp559016994*t24
      t4w = t4u-kp951056516*t4v ; t5e = t4u+kp951056516*t4v
      t3A = t25-kp951056516*t28 ; t29 = t25+kp951056516*t28
      t2u = xr22-xr7 ; tw = xr7+xr22 ; t2v = xr17-xr12 ; tz = xr12+xr17
      tA = tw+tz ; t2z = tz-tw ; t2B = xi22-xi7 ; t1c = xi7+xi22
      t1f = xi12+xi17 ; t2C = xi12-xi17 ; t2s = t1f-t1c ; t1g = t1c+t1f
      t2J = xr8-xr23 ; tF = xr8+xr23 ; t2K = xr13-xr18 ; tI = xr13+xr18
      tJ = tF+tI ; t2O = tI-tF ; t2Q = xi23-xi8 ; t1l = xi8+xi23
      t1o = xi13+xi18 ; t2R = xi18-xi13 ; t2y = xr2-kp250000000*tA
      tB = xr2+tA ; t2H = t1o-t1l ; t1p = t1l+t1o ; tK = xr3+tJ
      t2N = xr3-kp250000000*tJ ; t2r = xi2-kp250000000*t1g
      t1h = xi2+t1g ; t2w = t2u+kp618033988*t2v
      t49 = t2v-kp618033988*t2u ; t2G = xi3-kp250000000*t1p
      t1q = xi3+t1p ; tL = tB+tK ; t1L = tB-tK ; t1r = t1h-t1q
      t1F = t1h+t1q ; t2S = t2Q+kp618033988*t2R
      t4j = t2R-kp618033988*t2Q ; t48 = t2r+kp559016994*t2s
      t2t = t2r-kp559016994*t2s ; t4g = t2K-kp618033988*t2J
      t2L = t2J+kp618033988*t2K ; t4a = t48+kp951056516*t49
      t57 = t48-kp951056516*t49 ; t3v = t2t-kp951056516*t2w
      t2x = t2t+kp951056516*t2w ; t4i = t2N+kp559016994*t2O
      t2P = t2N-kp559016994*t2O ; t4k = t4i-kp951056516*t4j
      t55 = t4i+kp951056516*t4j ; t3s = t2P+kp951056516*t2S
      t2T = t2P-kp951056516*t2S ; t2I = t2G-kp559016994*t2H
      t4f = t2G+kp559016994*t2H ; t2D = t2B-kp618033988*t2C
      t4c = t2C+kp618033988*t2B ; t3t = t2I+kp951056516*t2L
      t2M = t2I-kp951056516*t2L ; t4h = t4f-kp951056516*t4g
      t54 = t4f+kp951056516*t4g ; tM = ts+tL ; tO = ts-tL
      t4b = t2y+kp559016994*t2z ; t2A = t2y-kp559016994*t2z
      tN = t9-kp250000000*tM ; t4d = t4b+kp951056516*t4c
      t58 = t4b-kp951056516*t4c ; t3w = t2A+kp951056516*t2D
      t2E = t2A-kp951056516*t2D ; t1s = t18+kp618033988*t1r
      t1u = t1r-kp618033988*t18 ; tP = tN+kp559016994*tO
      t1t = tN-kp559016994*tO ; t1G = t1E+t1F ; t1I = t1E-t1F
      t1H = t1D-kp250000000*t1G ; t1J = t1H+kp559016994*t1I
      t1N = t1H-kp559016994*t1I ; t1M = t1K+kp618033988*t1L
      t1O = t1L-kp618033988*t1K ; t3H = t1R+kp951056516*t1U
      t1V = t1R-kp951056516*t1U ; t3f = t3b+kp951056516*t3e
      t3r = t3b-kp951056516*t3e ; t30 = t29+kp256756360*t22
      t2a = t22-kp256756360*t29 ; t2p = t2h+kp634619297*t2o
      t31 = t2o-kp634619297*t2h ; t33 = t2E+kp549754652*t2x
      t2F = t2x-kp549754652*t2E ; t2U = t2M-kp939062505*t2T
      t34 = t2T+kp939062505*t2M ; t3m = t2a-kp871714437*t2p
      t2q = t2a+kp871714437*t2p ; t3n = t2F-kp831864738*t2U
      t2V = t2F+kp831864738*t2U ; t2W = t2q+kp904730450*t2V
      t2Y = t2q-kp904730450*t2V ; t32 = t30-kp871714437*t31
      t3g = t30+kp871714437*t31 ; t3h = t33+kp831864738*t34
      t35 = t33-kp831864738*t34 ; t3i = t3g+kp904730450*t3h
      t3k = t3g-kp904730450*t3h ; t36 = t32+kp559154169*t35
      t38 = t35-kp683113946*t32 ; t2X = t1V-kp242145790*t2W
      t3o = t3m+kp559154169*t3n ; t3q = t3n-kp683113946*t3m
      t3j = t3f-kp242145790*t3i ; t2Z = t2X+kp541454447*t2Y
      t37 = t2X-kp541454447*t2Y ; t47 = t45+kp951056516*t46
      t53 = t45-kp951056516*t46 ; t3p = t3j-kp541454447*t3k
      t3l = t3j+kp541454447*t3k ; t5j = t4P+kp951056516*t4Q
      t4R = t4P-kp951056516*t4Q ; t5k = t55-kp062914667*t54
      t56 = t54+kp062914667*t55 ; t59 = t57+kp634619297*t58
      t5l = t58-kp634619297*t57 ; t5n = t5c-kp470564281*t5b
      t5d = t5b+kp470564281*t5c ; t5g = t5e+kp549754652*t5f
      t5o = t5f-kp549754652*t5e ; t5u = t56-kp845997307*t59
      t5a = t56+kp845997307*t59 ; t5v = t5d-kp968479752*t5g
      t5h = t5d+kp968479752*t5g ; t5i = t5a+kp906616052*t5h
      t5A = t5a-kp906616052*t5h ; t5D = t5k-kp845997307*t5l
      t5m = t5k+kp845997307*t5l ; t5p = t5n+kp968479752*t5o
      t5C = t5n-kp968479752*t5o ; t5s = t5m+kp906616052*t5p
      t5q = t5m-kp906616052*t5p ; t5w = t5u-kp560319534*t5v
      t5y = t5v+kp681693190*t5u ; t5E = t5C-kp681693190*t5D
      t5G = t5D+kp560319534*t5C ; t5r = t5j+kp249506682*t5q
      t5z = t53-kp249506682*t5i ; t5t = t5r-kp557913902*t5s
      t5x = t5r+kp557913902*t5s ; t5F = t5z+kp557913902*t5A
      t5B = t5z-kp557913902*t5A ; t4J = t4d-kp062914667*t4a
      t4e = t4a+kp062914667*t4d ; t4l = t4h-kp827271945*t4k
      t4K = t4k+kp827271945*t4h ; t4G = t4s-kp126329378*t4p
      t4t = t4p+kp126329378*t4s ; t4A = t4w+kp939062505*t4z
      t4H = t4z-kp939062505*t4w ; t4Y = t4e-kp772036680*t4l
      t4m = t4e+kp772036680*t4l ; t4Z = t4t-kp734762448*t4A
      t4B = t4t+kp734762448*t4A ; t4C = t4m+kp994076283*t4B
      t4E = t4m-kp994076283*t4B ; t4I = t4G+kp734762448*t4H
      t4T = t4G-kp734762448*t4H ; t4S = t4J+kp772036680*t4K
      t4L = t4J-kp772036680*t4K ; t4U = t4S+kp994076283*t4T
      t4W = t4S-kp994076283*t4T ; t4M = t4I-kp621716863*t4L
      t4O = t4L+kp614372930*t4I ; t4D = t47-kp249506682*t4C
      t50 = t4Y+kp614372930*t4Z ; t52 = t4Z-kp621716863*t4Y
      t4V = t4R+kp249506682*t4U ; t4F = t4D-kp557913902*t4E
      t4N = t4D+kp557913902*t4E ; t51 = t4V+kp557913902*t4W
      t4X = t4V-kp557913902*t4W ; t3I = t3t+kp126329378*t3s
      t3u = t3s-kp126329378*t3t ; t3x = t3v-kp470564281*t3w
      t3J = t3w+kp470564281*t3v ; t3L = t3A-kp634619297*t3z
      t3B = t3z+kp634619297*t3A ; t3E = t3C-kp827271945*t3D
      t3M = t3D+kp827271945*t3C ; t3S = t3u+kp912018591*t3x
      t3y = t3u-kp912018591*t3x ; t3T = t3B+kp912575812*t3E
      t3F = t3B-kp912575812*t3E ; t3G = t3y-kp851038619*t3F
      t3Y = t3y+kp851038619*t3F ; t41 = t3I-kp912018591*t3J
      t3K = t3I+kp912018591*t3J ; t3N = t3L+kp912575812*t3M
      t40 = t3L-kp912575812*t3M ; t3Q = t3K-kp851038619*t3N
      t3O = t3K+kp851038619*t3N ; t3U = t3S-kp525970792*t3T
      t3W = t3T+kp726211448*t3S ; t42 = t40-kp726211448*t41
      t44 = t41+kp525970792*t40 ; t3P = t3H+kp248028675*t3O
      t3X = t3r+kp248028675*t3G ; t3R = t3P-kp554608978*t3Q
      t3V = t3P+kp554608978*t3Q ; t3Z = t3X+kp554608978*t3Y
      t43 = t3X-kp554608978*t3Y
      r24 = (t3f+kp968583161*t3i) :+ (t1V+kp968583161*t2W)
      r23 = (t53+kp998026728*t5i) :+ (t5j-kp998026728*t5q)
      r22 = (t47+kp998026728*t4C) :+ (t4R-kp998026728*t4U)
      r21 = (t3r-kp992114701*t3G) :+ (t3H-kp992114701*t3O)
      r20 = (tP+kp951056516*t1s) :+ (t1J-kp951056516*t1M)
      r19 = (t3l+kp921177326*t3o) :+ (t2Z-kp921177326*t36)
      r18 = (t5B-kp860541664*t5E) :+ (t5x+kp860541664*t5y)
      r17 = (t4F+kp943557151*t4M) :+ (t51+kp943557151*t52)
      r16 = (t3Z-kp803003575*t42) :+ (t3V-kp803003575*t3W)
      r15 = (t1t-kp951056516*t1u) :+ (t1N+kp951056516*t1O)
      r14 = (t3p-kp833417178*t3q) :+ (t37+kp833417178*t38)
      r13 = (t5F-kp949179823*t5G) :+ (t5t-kp949179823*t5w)
      r12 = (t4N+kp949179823*t4O) :+ (t4X+kp949179823*t50)
      r11 = (t43-kp943557151*t44) :+ (t3R+kp943557151*t3U)
      r10 = (t1t+kp951056516*t1u) :+ (t1N-kp951056516*t1O)
      r9 = (t3p+kp833417178*t3q) :+ (t37-kp833417178*t38)
      r8 = (t5F+kp949179823*t5G) :+ (t5t+kp949179823*t5w)
      r7 = (t4N-kp949179823*t4O) :+ (t4X-kp949179823*t50)
      r6 = (t43+kp943557151*t44) :+ (t3R-kp943557151*t3U)
      r5 = (tP-kp951056516*t1s) :+ (t1J+kp951056516*t1M)
      r4 = (t3l-kp921177326*t3o) :+ (t2Z+kp921177326*t36)
      r3 = (t5B+kp860541664*t5E) :+ (t5x-kp860541664*t5y)
      r2 = (t4F-kp943557151*t4M) :+ (t51-kp943557151*t52)
      r1 = (t3Z+kp803003575*t42) :+ (t3V+kp803003575*t3W)
  MV.unsafeWrite xsout 0 $ (t9+tM) :+ (t1D+t1G)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r24
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r23
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r22
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r21
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r20
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r19
  MV.unsafeWrite xsout 7 $ if sign == 1 then r7 else r18
  MV.unsafeWrite xsout 8 $ if sign == 1 then r8 else r17
  MV.unsafeWrite xsout 9 $ if sign == 1 then r9 else r16
  MV.unsafeWrite xsout 10 $ if sign == 1 then r10 else r15
  MV.unsafeWrite xsout 11 $ if sign == 1 then r11 else r14
  MV.unsafeWrite xsout 12 $ if sign == 1 then r12 else r13
  MV.unsafeWrite xsout 13 $ if sign == 1 then r13 else r12
  MV.unsafeWrite xsout 14 $ if sign == 1 then r14 else r11
  MV.unsafeWrite xsout 15 $ if sign == 1 then r15 else r10
  MV.unsafeWrite xsout 16 $ if sign == 1 then r16 else r9
  MV.unsafeWrite xsout 17 $ if sign == 1 then r17 else r8
  MV.unsafeWrite xsout 18 $ if sign == 1 then r18 else r7
  MV.unsafeWrite xsout 19 $ if sign == 1 then r19 else r6
  MV.unsafeWrite xsout 20 $ if sign == 1 then r20 else r5
  MV.unsafeWrite xsout 21 $ if sign == 1 then r21 else r4
  MV.unsafeWrite xsout 22 $ if sign == 1 then r22 else r3
  MV.unsafeWrite xsout 23 $ if sign == 1 then r23 else r2
  MV.unsafeWrite xsout 24 $ if sign == 1 then r24 else r1


{-# LANGUAGE
  DataKinds,
  DeriveDataTypeable,
  FlexibleInstances,
  GADTs,
  MultiParamTypeClasses,
  TemplateHaskell,
  TypeFamilies #-}

{- |
Module      :  Data.Real.Constructible
Description :  Constructible real numbers
Copyright   :  © Anders Kaseorg, 2013
License     :  BSD-style

Maintainer  :  Anders Kaseorg <andersk@mit.edu>
Stability   :  experimental
Portability :  Non-portable (GHC extensions)

The constructible reals, 'Construct', are the subset of the real
numbers that can be represented exactly using field operations
(addition, subtraction, multiplication, division) and positive square
roots.  They support exact computations, equality comparisons, and
ordering.

>>> [((1 + sqrt 5)/2)^n - ((1 - sqrt 5)/2)^n :: Construct | n <- [1..10]]
[sqrt 5,sqrt 5,2*sqrt 5,3*sqrt 5,5*sqrt 5,8*sqrt 5,13*sqrt 5,21*sqrt 5,34*sqrt 5,55*sqrt 5]

>>> let f (a, b, t, p) = ((a + b)/2, sqrt (a*b), t - p*((a - b)/2)^2, 2*p)
>>> let (a, b, t, p) = f . f . f . f $ (1, 1/sqrt 2, 1/4, 1 :: Construct)
>>> floor $ ((a + b)^2/(4*t))*10**40
31415926535897932384626433832795028841971

>>> let qf (p, q) = ((p + sqrt (p^2 - 4*q))/2, (p - sqrt (p^2 - 4*q))/2 :: Construct)
>>> let [(v, w), (x, _), (y, _), (z, _)] = map qf [(-1, -4), (v, -1), (w, -1), (x, y)]
>>> z/2
-1/16 + 1/16*sqrt 17 + 1/8*sqrt (17/2 - 1/2*sqrt 17) + 1/4*sqrt (17/4 + 3/4*sqrt 17 - (3/4 + 1/4*sqrt 17)*sqrt (17/2 - 1/2*sqrt 17))

Constructible complex numbers may be built from constructible reals
using 'Complex' from the complex-generic library.

>>> (z/2 :+ sqrt (1 - (z/2)^2))^17
1 :+ 0
-}

module Data.Real.Constructible (
  Construct,
  deconstruct,
  fromConstruct,
  ConstructException (..)) where

import Control.Applicative ((<$>), (<*>), (<|>), empty)
import Control.Exception (Exception, ArithException (..), throw)
import Data.Complex.Generic (Complex (..))
import Data.Complex.Generic.TH (deriveComplexF)
import Data.Ratio ((%), numerator, denominator)
import Data.Typeable (Typeable)
import Math.NumberTheory.Roots (exactSquareRoot)
import Numeric.Search.Integer (search)
import Text.Read (Lexeme (..), Read (..), lexP, parens, prec, readListPrecDefault, step)
import Text.Read.Lex (numberToInteger)

data FieldShape = QShape | SqrtShape !FieldShape deriving Show

data Field k where
  Q :: Field 'QShape
  Sqrt :: !(Field k) -> !(Elt k) -> Field ('SqrtShape k)

instance Show (Field k) where
  showsPrec _ Q = showString "Q"
  showsPrec d (Sqrt k r) =
    showParen (d > 9) $ showsPrec 9 k . showString "[sqrt " . showsPrecK k 10 r . showString "]"

type family Elt (k :: FieldShape)
type instance Elt 'QShape = Rational
data SqrtElt k = SqrtZero | SqrtElt !(Elt k) !(Elt k)
type instance Elt ('SqrtShape k) = SqrtElt k

sqrtElt :: Field k -> Elt k -> Elt k -> SqrtElt k
sqrtElt k a b | isZeroK k a && isZeroK k b = SqrtZero
              | otherwise = SqrtElt a b

sqrtLift :: Field k -> Elt k -> SqrtElt k
sqrtLift k a = sqrtElt k a (zeroK k)

addK :: Field k -> Elt k -> Elt k -> Elt k
addK Q a b = a + b
addK Sqrt{} SqrtZero a = a
addK Sqrt{} a SqrtZero = a
addK (Sqrt k _) (SqrtElt a b) (SqrtElt c d) = sqrtElt k (addK k a c) (addK k b d)

mulK :: Field k -> Elt k -> Elt k -> Elt k
mulK Q a b = a * b
mulK Sqrt{} SqrtZero _ = SqrtZero
mulK Sqrt{} _ SqrtZero = SqrtZero
mulK (Sqrt k r) (SqrtElt a b) (SqrtElt c d) =
  SqrtElt (addK k (mulK k a c) (mulK k r (mulK k b d))) (addK k (mulK k a d) (mulK k b c))

sqK :: Field k -> Elt k -> Elt k
sqK Q a = a*a
sqK Sqrt{} SqrtZero = SqrtZero
sqK (Sqrt k r) (SqrtElt a b) =
  let c = mulK k a b
  in SqrtElt (addK k (sqK k a) (mulK k r (sqK k b))) (addK k c c)

subK :: Field k -> Elt k -> Elt k -> Elt k
subK Q a b = a - b
subK k@Sqrt{} SqrtZero a = negateK k a
subK Sqrt{} a SqrtZero = a
subK (Sqrt k _) (SqrtElt a b) (SqrtElt c d) = sqrtElt k (subK k a c) (subK k b d)

negateK :: Field k -> Elt k -> Elt k
negateK Q a = negate a
negateK Sqrt{} SqrtZero = SqrtZero
negateK (Sqrt k _) (SqrtElt a b) = SqrtElt (negateK k a) (negateK k b)

absK :: Field k -> Elt k -> Elt k
absK Q a = abs a
absK k a = if sgnK k a == LT then negateK k a else a

signumK :: Field k -> Elt k -> Rational
signumK Q a = signum a
signumK k a = case sgnK k a of LT -> -1; EQ -> 0; GT -> 1

divK :: Field k -> Elt k -> Elt k -> Elt k
divK Q a b = a / b
divK k a b = mulK k a (recipK k b)

recipK :: Field k -> Elt k -> Elt k
recipK Q a = recip a
recipK Sqrt{} SqrtZero = throw DivideByZero
recipK (Sqrt k r) (SqrtElt a b) =
  let c = recipK k (subK k (sqK k a) (mulK k r (sqK k b)))
  in SqrtElt (mulK k a c) (mulK k (negateK k b) c)

eqK :: Field k -> Elt k -> Elt k -> Bool
eqK Q a b = a == b
eqK Sqrt{} SqrtZero SqrtZero = True
eqK (Sqrt k _) (SqrtElt a b) (SqrtElt c d) = eqK k a c && eqK k b d
eqK Sqrt{} SqrtZero SqrtElt{} = False
eqK Sqrt{} SqrtElt{} SqrtZero = False

isZeroK :: Field k -> Elt k -> Bool
isZeroK Q a = a == 0
isZeroK Sqrt{} SqrtZero = True
isZeroK Sqrt{} SqrtElt{} = False

compareK :: Field k -> Elt k -> Elt k -> Ordering
compareK Q a b = compare a b
compareK k a b = sgnK k (subK k a b)

sgnK :: Field k -> Elt k -> Ordering
sgnK Q a = compare a 0
sgnK Sqrt{} SqrtZero = EQ
sgnK (Sqrt k r) (SqrtElt a b) = case (sgnK k a, sgnK k b) of
  (o, EQ) -> o
  (EQ, o) -> o
  (GT, GT) -> GT
  (LT, LT) -> LT
  (GT, LT) -> sgnK k (subK k (sqK k a) (mulK k r (sqK k b)))
  (LT, GT) -> sgnK k (subK k (mulK k r (sqK k b)) (sqK k a))

zeroK :: Field k -> Elt k
zeroK Q = 0
zeroK Sqrt{} = SqrtZero

fromRationalK :: Field k -> Rational -> Elt k
fromRationalK Q a = a
fromRationalK (Sqrt k _) a = sqrtLift k (fromRationalK k a)

sqrtK :: Field k -> Elt k -> Maybe (Elt k)
sqrtK Q a = (%) <$> exactSquareRoot (numerator a) <*> exactSquareRoot (denominator a)
sqrtK Sqrt{} SqrtZero = return SqrtZero
sqrtK (Sqrt k r) (SqrtElt a b)
  | isZeroK k b = sqrtLift k <$> sqrtK k a <|> SqrtElt (zeroK k) <$> sqrtK k (divK k a r)
  | otherwise = do
    n <- sqrtK k $ subK k (sqK k a) (mulK k r (sqK k b))
    let half = fromRationalK k (1 % 2)
        p = mulK k half (addK k a n)
        q = mulK k half b
        y1 = do
          c <- sqrtK k p
          return (SqrtElt c (divK k q c))
        y2 = do
          d <- sqrtK k $ divK k p r
          return (SqrtElt (divK k q d) d)
    y1 <|> y2

negateS, sqrtS :: (Int -> ShowS) -> Int -> ShowS
(-!), (+!), (*!), (/!) :: (Int -> ShowS) -> (Int -> ShowS) -> Int -> ShowS
infixl 6 +!, -!
infixl 7 *!, /!
negateS s d = showParen (d > 6) $ showChar '-' . s 7
(+!) s1 s2 d = showParen (d > 6) $ s1 6 . showString " + " . s2 7
(-!) s1 s2 d = showParen (d > 6) $ s1 6 . showString " - " . s2 7
(*!) s1 s2 d = showParen (d > 7) $ s1 7 . showChar '*' . s2 8
(/!) s1 s2 d = showParen (d > 7) $ s1 7 . showChar '/' . s2 8
sqrtS s d = showParen (d > 9) $ showString "sqrt " . s 10

mulSqrtS :: Field k -> Elt k -> Elt k -> Int -> ShowS
mulSqrtS k b r
  | eqK k b (fromRationalK k 1) = sqrtS (flip (showsPrecK k) r)
  | otherwise = flip (showsPrecK k) b *! sqrtS (flip (showsPrecK k) r)

showsPrecK :: Field k -> Int -> Elt k -> ShowS
showsPrecK Q d x
  | q == 1 = showsPrec d p
  | p < 0 = negateS (flip showsPrec (-p) /! flip showsPrec q) d
  | otherwise = (flip showsPrec p /! flip showsPrec q) d
  where
    p = numerator x
    q = denominator x
showsPrecK Sqrt{} _ SqrtZero = showChar '0'
showsPrecK (Sqrt k r) d (SqrtElt a b) = case sgnK k b of
  EQ -> showsPrecK k d a
  GT | isZeroK k a -> mulSqrtS k b r d
     | otherwise -> (flip (showsPrecK k) a +! mulSqrtS k b r) d
  LT | isZeroK k a -> negateS (mulSqrtS k (negateK k b) r) d
     | otherwise -> (flip (showsPrecK k) a -! mulSqrtS k (negateK k b) r) d

fromRatioK :: Floating a => Field k -> Elt k -> Elt k -> a
fromRatioK Q = \a b -> fromRational (a/b)
fromRatioK (Sqrt k r) = er where
  e = fromRatioK k
  s = sqrt (e r (fromRationalK k 1))
  er SqrtZero _ = 0
  er _ SqrtZero = throw DivideByZero
  er (SqrtElt a0 b0) (SqrtElt a1 b1) = case (sgnK k a, sgnK k b) of
    (_, EQ) -> e a n1
    (EQ, _) -> e b n1*s
    (GT, GT) -> x1
    (LT, LT) -> x1
    (GT, LT) -> x2
    (LT, GT) -> x2
    where
      a = subK k (mulK k a0 a1) (mulK k r (mulK k b0 b1))
      b = subK k (mulK k b0 a1) (mulK k a0 b1)
      n0 = subK k (sqK k a0) (mulK k r (sqK k b0))
      n1 = subK k (sqK k a1) (mulK k r (sqK k b1))
      x1 = e a n1 + e b n1*s
      x2 = recip $ e a n0 - e b n0*s

fromConstructK :: Floating a => Field k -> Elt k -> a
fromConstructK k a = fromRatioK k a (fromRationalK k 1)

-- |The type of constructible real numbers.
data Construct where
  C :: !(Field k) -> !(Elt k) -> Construct

deconstructK :: Field k -> Elt k -> Either Rational (Construct, Construct, Construct)
deconstructK Q a = Left a
deconstructK Sqrt{} SqrtZero = Left 0
deconstructK (Sqrt k r) (SqrtElt a b)
  | isZeroK k b = deconstructK k a
  | otherwise = Right (C k a, C k b, C k r)

{- |
Deconstruct a rational constructible number as a 'Rational', or an
irrational constructible number as a triple @(a, b, r)@ of simpler
constructible numbers representing @a + b*sqrt r@ (with @b /= 0@ and
@r > 0@).  Recursively calling 'deconstruct' on all triples will yield
a finite tree that terminates in 'Rational' leaves.

Note that two irrational constructible numbers that compare as equal
may deconstruct in different ways.
-}
deconstruct :: Construct -> Either Rational (Construct, Construct, Construct)
deconstruct (C k a) = deconstructK k a

data JoinK k1 k2 where
  JoinK :: !(Field k) -> (Elt k1 -> Elt k) -> (Elt k2 -> Elt k) -> JoinK k1 k2

joinK :: Field k1 -> Field k2 -> JoinK k1 k2
joinK Q k = JoinK k (fromRationalK k) id
joinK k Q = JoinK k id (fromRationalK k)
joinK k1 (Sqrt k2 r) = case joinK k1 k2 of
  JoinK k f1 f2 -> let r' = f2 r in case sqrtK k r' of
    Nothing ->
      let f2' SqrtZero = SqrtZero
          f2' (SqrtElt a b) = SqrtElt (f2 a) (f2 b)
      in JoinK (Sqrt k r') (sqrtLift k . f1) f2'
    Just s ->
      let f2' SqrtZero = zeroK k
          f2' (SqrtElt a b) = addK k (f2 a) (mulK k (f2 b) s)
      in JoinK k f1 f2'

instance Show Construct where
  showsPrec d (C k a) = showsPrecK k d a

instance Read Construct where
  readPrec =
    parens $
    pNum <|>
    prec 6 (pNegate <|> (step readPrec >>= pAddSub)) <|>
    prec 7 (step readPrec >>= pMulDiv) <|>
    prec 10 pSqrt
    where
      pNum = do {Number n <- lexP; maybe empty (return . fromInteger) (numberToInteger n)}
      pNegate = do {Symbol "-" <- lexP; a <- negate <$> step readPrec; return a <|> pAddSub a}
      pAddSub a = do {Symbol "+" <- lexP; b <- (a +) <$> step readPrec; return b <|> pAddSub b} <|>
                  do {Symbol "-" <- lexP; b <- (a -) <$> step readPrec; return b <|> pAddSub b}
      pMulDiv a = do {Symbol "*" <- lexP; b <- (a *) <$> step readPrec; return b <|> pMulDiv b} <|>
                  do {Symbol "/" <- lexP; b <- (a /) <$> step readPrec; return b <|> pMulDiv b}
      pSqrt = do {Ident "sqrt" <- lexP; a <- step readPrec; return (sqrt a)}
  readListPrec = readListPrecDefault

instance Eq Construct where
  C k1 a1 == C k2 a2 = case joinK k1 k2 of JoinK k f1 f2 -> eqK k (f1 a1) (f2 a2)

instance Ord Construct where
  compare (C k1 a1) (C k2 a2) = case joinK k1 k2 of JoinK k f1 f2 -> compareK k (f1 a1) (f2 a2)

instance Num Construct where
  C k1 a1 + C k2 a2 = case joinK k1 k2 of JoinK k f1 f2 -> C k (addK k (f1 a1) (f2 a2))
  C k1 a1 * C k2 a2 = case joinK k1 k2 of JoinK k f1 f2 -> C k (mulK k (f1 a1) (f2 a2))
  C k1 a1 - C k2 a2 = case joinK k1 k2 of JoinK k f1 f2 -> C k (subK k (f1 a1) (f2 a2))
  negate (C k x) = C k (negateK k x)
  abs (C k x) = C k (absK k x)
  signum (C k x) = C Q (signumK k x)
  fromInteger = C Q . fromInteger

instance Fractional Construct where
  C k1 a1 / C k2 a2 = case joinK k1 k2 of JoinK k f1 f2 -> C k (divK k (f1 a1) (f2 a2))
  recip (C k a) = C k (recipK k a)
  fromRational = C Q

-- |The type of exceptions thrown by impossible 'Construct' operations.
data ConstructException =
  -- |'toRational' was given an irrational constructible number.
  ConstructIrrational |
  -- |'sqrt' was given a negative constructible number.
  ConstructSqrtNegative |
  -- |'**' was given an exponent that is not a dyadic rational, or a transcendental function was called.
  Unconstructible String
  deriving (Eq, Ord, Typeable)

instance Show ConstructException where
  showsPrec _ ConstructIrrational = showString "cannot convert irrational Construct to rational"
  showsPrec _ ConstructSqrtNegative = showString "Construct sqrt: negative argument"
  showsPrec _ (Unconstructible s) = showString s . showString " is not constructible"

instance Exception ConstructException

{- |
This partial 'Floating' instance only supports 'sqrt' and '**' where
the exponent is a dyadic rational.  Passing a negative number to
'sqrt' will throw the 'ConstructSqrtNegative' exception.  All other
operations will throw the 'Unconstructible' exception.
-}
instance Floating Construct where
  sqrt (C k a)
    | sgnK k a == LT = throw ConstructSqrtNegative
    | otherwise = case sqrtK k a of
        Nothing -> C (Sqrt k a) (SqrtElt (zeroK k) (fromRationalK k 1))
        Just b -> C k b
  pi = throw (Unconstructible "pi")
  exp = throw (Unconstructible "exp")
  log = throw (Unconstructible "log")
  a ** b = go (numerator b') (denominator b') where
    b' = toRational b
    go p q = let (n, p') = divMod p q in a^^n*go' p' q
    go' 0 _ = 1
    go' p q = case divMod q 2 of
      (q', 0) -> sqrt (go p q')
      _ -> throw (Unconstructible "(** non-dyadic-rational)")
  logBase = throw (Unconstructible "logBase")
  sin = throw (Unconstructible "sin")
  tan = throw (Unconstructible "tan")
  cos = throw (Unconstructible "cos")
  asin = throw (Unconstructible "asin")
  atan = throw (Unconstructible "atan")
  acos = throw (Unconstructible "acos")
  sinh = throw (Unconstructible "sinh")
  tanh = throw (Unconstructible "tanh")
  cosh = throw (Unconstructible "cosh")
  asinh = throw (Unconstructible "asinh")
  atanh = throw (Unconstructible "atanh")
  acosh = throw (Unconstructible "acosh")

{- |
This 'Real' instance only supports 'toRational' on numbers that are in
fact rational.  'toRational' on an irrational number will throw the
'ConstructIrrational' exception.
-}
instance Real Construct where
  toRational = either id (\_ -> throw ConstructIrrational) . deconstruct

instance RealFrac Construct where
  properFraction (C Q x) = (m, C Q y) where (m, y) = properFraction x
  properFraction x = (fromInteger m, x - fromInteger m)
    where m = search ((> x) . fromInteger) - 1

instance Enum Construct where
  succ = (+ 1)
  pred = subtract 1
  toEnum = fromIntegral
  fromEnum = fromInteger . truncate
  enumFrom n = n `seq` (n : enumFrom (n + 1))
  enumFromThen n m = n `seq` m `seq` (n : enumFromThen m (m + m - n))
  enumFromTo n m = takeWhile (<= m) (enumFrom n)
  enumFromThenTo e1 e2 e3 = takeWhile predicate (enumFromThen e1 e2) where
    predicate | e2 >= e1 = (<= e3)
              | otherwise = (>= e3)

mk :: a -> a -> Complex a
mk = (:+)

toPair :: Complex a -> (a, a)
toPair (x :+ y) = (x, y)

deriveComplexF ''Complex ''Construct 'mk 'toPair

{- |
Evaluate a floating-point approximation for a constructible number.

To improve numerical stability, addition of numbers with different
signs is avoided using quadratic conjugation.

>>> fromConstruct $ sum (map sqrt [7, 14, 39, 70, 72, 76, 85]) - sum (map sqrt [13, 16, 46, 55, 67, 73, 79])
1.8837969820815017e-19
-}
fromConstruct :: Floating a => Construct -> a
fromConstruct (C k a) = fromConstructK k a