{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Types
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- Data types common used in statistics
module Statistics.Types
    ( -- * Confidence level
      CL
      -- ** Accessors
    , confidenceLevel
    , significanceLevel
      -- ** Constructors
    , mkCL
      -- ** Constants and conversion to nσ
    , cl95
      -- * Estimates and upper/lower limits
    , Estimate(..)
    -- , NormalErr(..)
    , ConfInt(..)
      -- ** Constructors
    -- , estimateNormErr
    , estimateFromInterval
    , estimateFromErr
      -- ** Accessors
    , confidenceInterval
    , Scale(..)
      -- * Other
    , Sample
    ) where

import Control.DeepSeq              (NFData(..))
import Data.Data                    (Data,Typeable)
import Data.Maybe                   (fromMaybe)
import GHC.Generics                 (Generic)

#if __GLASGOW_HASKELL__ == 704
import qualified Data.Vector.Generic
import qualified Data.Vector.Generic.Mutable
#endif

import Statistics.Internal
import Statistics.Types.Internal

----------------------------------------------------------------
-- Data type for confidence level
----------------------------------------------------------------

-- |
-- Confidence level. In context of confidence intervals it's
-- probability of said interval covering true value of measured
-- value. In context of statistical tests it's @1-α@ where α is
-- significance of test.
--
-- Since confidence level are usually close to 1 they are stored as
-- @1-CL@ internally. There are two smart constructors for @CL@:
-- 'mkCL' and 'mkCLFromSignificance' (and corresponding variant
-- returning @Maybe@). First creates @CL@ from confidence level and
-- second from @1 - CL@ or significance level.
--
-- >>> cl95
-- mkCLFromSignificance 0.05
--
-- Prior to 0.14 confidence levels were passed to function as plain
-- @Doubles@. Use 'mkCL' to convert them to @CL@.
newtype CL a = CL a
               deriving (Eq, Typeable, Data, Generic)

instance Show a => Show (CL a) where
  showsPrec n (CL p) = defaultShow1 "mkCLFromSignificance" p n
instance (Num a, Ord a, Read a) => Read (CL a) where
  readPrec = defaultReadPrecM1 "mkCLFromSignificance" mkCLFromSignificanceE

instance NFData   a => NFData   (CL a) where
  rnf (CL a) = rnf a

-- |
-- >>> cl95 > cl90
-- True
instance Ord a => Ord (CL a) where
  CL a <  CL b = a >  b
  CL a <= CL b = a >= b
  CL a >  CL b = a <  b
  CL a >= CL b = a <= b
  max (CL a) (CL b) = CL (min a b)
  min (CL a) (CL b) = CL (max a b)

-- | Create confidence level from probability β or probability
--   confidence interval contain true value of estimate. Will throw
--   exception if parameter is out of [0,1] range
--
-- >>> mkCL 0.95    -- same as cl95
-- mkCLFromSignificance 0.05
mkCL :: (Ord a, Num a) => a -> CL a
mkCL
  = fromMaybe (error "Statistics.Types.mkCL: probability is out if [0,1] range")
  . mkCLE

-- | Same as 'mkCL' but returns @Nothing@ instead of error if
--   parameter is out of [0,1] range
--
-- >>> mkCLE 0.95    -- same as cl95
-- Just (mkCLFromSignificance 0.05)
mkCLE :: (Ord a, Num a) => a -> Maybe (CL a)
mkCLE p
  | p >= 0 && p <= 1 = Just $ CL (1 - p)
  | otherwise        = Nothing

-- | Same as 'mkCLFromSignificance' but returns @Nothing@ instead of error if
--   parameter is out of [0,1] range
--
-- >>> mkCLFromSignificanceE 0.05    -- same as cl95
-- Just (mkCLFromSignificance 0.05)
mkCLFromSignificanceE :: (Ord a, Num a) => a -> Maybe (CL a)
mkCLFromSignificanceE p
  | p >= 0 && p <= 1 = Just $ CL p
  | otherwise        = Nothing

-- | Get confidence level. This function is subject to rounding
--   errors. If @1 - CL@ is needed use 'significanceLevel' instead
confidenceLevel :: (Num a) => CL a -> a
confidenceLevel (CL p) = 1 - p

-- | Get significance level.
significanceLevel :: CL a -> a
significanceLevel (CL p) = p

-- | 95% confidence level
cl95 :: Fractional a => CL a
cl95 = CL 0.05

----------------------------------------------------------------
-- Data type for p-value
----------------------------------------------------------------

-- | Newtype wrapper for p-value.
newtype PValue a = PValue a
               deriving (Eq,Ord, Typeable, Data, Generic)

instance Show a => Show (PValue a) where
  showsPrec n (PValue p) = defaultShow1 "mkPValue" p n
instance (Num a, Ord a, Read a) => Read (PValue a) where
  readPrec = defaultReadPrecM1 "mkPValue" mkPValueE

instance NFData a => NFData (PValue a) where
  rnf (PValue a) = rnf a

-- | Construct PValue. Returns @Nothing@ if argument is out of [0,1] range.
mkPValueE :: (Ord a, Num a) => a -> Maybe (PValue a)
mkPValueE p
  | p >= 0 && p <= 1 = Just $ PValue p
  | otherwise        = Nothing

----------------------------------------------------------------
-- Point estimates
----------------------------------------------------------------

-- |
-- A point estimate and its confidence interval. It's parametrized by
-- both error type @e@ and value type @a@. This module provides two
-- types of error: 'NormalErr' for normally distributed errors and
-- 'ConfInt' for error with normal distribution. See their
-- documentation for more details.
--
-- For example @144 ± 5@ (assuming normality) could be expressed as
--
-- > Estimate { estPoint = 144
-- >          , estError = NormalErr 5
-- >          }
--
-- Or if we want to express @144 + 6 - 4@ at CL95 we could write:
--
-- > Estimate { estPoint = 144
-- >          , estError = ConfInt
-- >                       { confIntLDX = 4
-- >                       , confIntUDX = 6
-- >                       , confIntCL  = cl95
-- >                       }
--
-- Prior to statistics 0.14 @Estimate@ data type used following definition:
--
-- > data Estimate = Estimate {
-- >      estPoint           :: {-# UNPACK #-} !Double
-- >    , estLowerBound      :: {-# UNPACK #-} !Double
-- >    , estUpperBound      :: {-# UNPACK #-} !Double
-- >    , estConfidenceLevel :: {-# UNPACK #-} !Double
-- >    }
--
-- Now type @Estimate ConfInt Double@ should be used instead. Function
-- 'estimateFromInterval' allow to easily construct estimate from same inputs.
data Estimate e a = Estimate
    { estPoint           :: !a
      -- ^ Point estimate.
    , estError           :: !(e a)
      -- ^ Confidence interval for estimate.
    } deriving (Eq, Read, Show, Generic
#if __GLASGOW_HASKELL__ >= 708
               , Typeable, Data
#endif
               )

instance (NFData   (e a), NFData   a) => NFData   (Estimate e a) where
    rnf (Estimate x dx) = rnf x `seq` rnf dx

-- | Confidence interval. It assumes that confidence interval forms
--   single interval and isn't set of disjoint intervals.
data ConfInt a = ConfInt
  { confIntLDX :: !a
    -- ^ Lower error estimate, or distance between point estimate and
    --   lower bound of confidence interval.
  , confIntUDX :: !a
    -- ^ Upper error estimate, or distance between point estimate and
    --   upper bound of confidence interval.
  , confIntCL  :: !(CL Double)
    -- ^ Confidence level corresponding to given confidence interval.
  }
  deriving (Read,Show,Eq,Typeable,Data,Generic)

instance NFData   a => NFData   (ConfInt a) where
    rnf (ConfInt x y _) = rnf x `seq` rnf y

----------------------------------------
-- Constructors

-- | Create estimate with asymmetric error.
estimateFromErr
  :: a                     -- ^ Central estimate
  -> (a,a)                 -- ^ Lower and upper errors. Both should be
                           --   positive but it's not checked.
  -> CL Double             -- ^ Confidence level for interval
  -> Estimate ConfInt a
estimateFromErr x (ldx,udx) cl = Estimate x (ConfInt ldx udx cl)

-- | Create estimate with asymmetric error.
estimateFromInterval
  :: Num a
  => a                     -- ^ Point estimate. Should lie within
                           --   interval but it's not checked.
  -> (a,a)                 -- ^ Lower and upper bounds of interval
  -> CL Double             -- ^ Confidence level for interval
  -> Estimate ConfInt a
estimateFromInterval x (lx,ux) cl
  = Estimate x (ConfInt (x-lx) (ux-x) cl)

----------------------------------------
-- Accessors

-- | Get confidence interval
confidenceInterval :: Num a => Estimate ConfInt a -> (a,a)
confidenceInterval (Estimate x (ConfInt ldx udx _))
  = (x - ldx, x + udx)

-- | Data types which could be multiplied by constant.
class Scale e where
  scale :: (Ord a, Num a) => a -> e a -> e a

instance Scale ConfInt where
  scale a (ConfInt l u cl) | a >= 0    = ConfInt  (a*l)  (a*u) cl
                           | otherwise = ConfInt (-a*u) (-a*l) cl

instance Scale e => Scale (Estimate e) where
  scale a (Estimate x dx) = Estimate (a*x) (scale a dx)


{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}

import           Numeric.LinearAlgebra

import           Grenade
import           Grenade.Layers.Internal.Convolution
import           Grenade.Layers.Internal.Pooling

import           Criterion.Main

main :: IO ()
main = do
  putStrLn $ "Benchmarking with type: " ++ nameF
  x :: S ('D2 60 60) <- randomOfShape
  y :: S ('D3 60 60 1) <- randomOfShape
  defaultMain
    [ bgroup
        "im2col"
        [ bench "im2col 28x28"     $ whnf (im2col 5 5 1 1) ((28 >< 28) [1 ..])
        , bench "im2col 100x100"   $ whnf (im2col 10 10 1 1) ((100 >< 100) [1 ..])
        , bench "im2col 3x416x416" $ whnf (vid2col 3 3 1 1 416 416) (((3 * 416) >< 416) [1 ..])
        ]
    , bgroup
        "col2im"
        [ bench "col2im 28x28"     $ whnf (col2im 5 5 1 1 28 28) ((576 >< 25) [1 ..])
        , bench "col2im 100x100"   $ whnf (col2im 10 10 1 1 100 100) ((8281 >< 100) [1 ..])
        , bench "col2im 3x416x416" $ whnf (col2vid 1 1 1 1 414 414) (((414 * 414) >< 27) [1 ..])
        ]
    , bgroup
        "poolfw"
        [ bench "poolforwards 3x4" $ whnf (poolForward 1 3 4 2 2 1 1) ((3 >< 4) [1 ..])
        , bench "poolforwards 28x28" $ whnf (poolForward 1 28 28 5 5 1 1) ((28 >< 28) [1 ..])
        , bench "poolforwards 100x100" $ whnf (poolForward 1 100 100 10 10 1 1) ((100 >< 100) [1 ..])
        ]
    , bgroup
        "poolbw"
        [ bench "poolbackwards 3x4" $ whnf (poolBackward 1 3 4 2 2 1 1 ((3 >< 4) [1 ..])) ((2 >< 3) [1 ..])
        , bench "poolbackwards 28x28" $ whnf (poolBackward 1 28 28 5 5 1 1 ((28 >< 28) [1 ..])) ((24 >< 24) [1 ..])
        , bench "poolbackwards 100x100" $ whnf (poolBackward 1 100 100 10 10 1 1 ((100 >< 100) [1 ..])) ((91 >< 91) [1 ..])
        ]
    , bgroup
        "padcrop"
        [ bench "pad 2D 60x60" $ nf (testRun2D Pad) x
        , bench "pad 3D 60x60" $ nf (testRun3D Pad) y
        , bench "crop 2D 60x60" $ nf (testRun2D' Crop) x
        , bench "crop 3D 60x60" $ nf (testRun3D' Crop) y
        ]
    ]
  putStrLn $ "Benchmarked with type: " ++ nameF

testRun2D :: Pad 1 1 1 1 -> S ('D2 60 60) -> S ('D2 62 62)
testRun2D = snd ... runForwards

testRun3D :: Pad 1 1 1 1 -> S ('D3 60 60 1) -> S ('D3 62 62 1)
testRun3D = snd ... runForwards

testRun2D' :: Crop 1 1 1 1 -> S ('D2 60 60) -> S ('D2 58 58)
testRun2D' = snd ... runForwards

testRun3D' :: Crop 1 1 1 1 -> S ('D3 60 60 1) -> S ('D3 58 58 1)
testRun3D' = snd ... runForwards

(...) :: (a -> b) -> (c -> d -> a) -> c -> d -> b
(...) = (.) . (.)


{-# OPTIONS_GHC  -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-missing-signatures #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, FlexibleContexts, TypeSynonymInstances #-}

---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------
-- |
-- | Module : First attempt at approximate counting
-- | Creator: Xiao Ling
-- | Created: 12/08/2015
-- | TODO   : test standard deviation of alpha, beta, and final version
-- |
---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

module Morris (
    morris
  , morris'
  , count
  , count'
  ) where

import Data.Random
import Data.Conduit
import Data.List.Split
import qualified Data.Conduit.List as Cl
import Control.Monad.Identity
import System.Environment

import Core
import Statistics

{-----------------------------------------------------------------------------
    I. Morris Algorithm list of counter
------------------------------------------------------------------------------}

-- * Count the number of items in `as` to within `eps` of actual
-- * with confidence `delta`
morris :: Eps -> Delta -> [a] -> IO Counter
morris e d as = runRVar (goMorris e d as) StdRandom

goMorris :: Eps -> Delta -> [a] -> RVar Counter
goMorris e d as = medianOfMeans $ Cl.sourceList as $$ count $ cs
  where cs = replicate (t*m) 0
        t  = round $ 1/(e^2*d)  :: Int
        m  = round . log $ 1/d
        medianOfMeans = fmap median' . (fmap . fmap) mean' . fmap (chunksOf t)

count :: [Counter] -> Sink a RVar [Counter]
count cs = (\c -> 2^(round c) - 1) `ffmap` Cl.foldM (\cs _ -> traverse incr cs) cs
  where ffmap = fmap . fmap

{-----------------------------------------------------------------------------
    II. Morris Algorithm list of list of counter
------------------------------------------------------------------------------}

-- * Count the number of items in `as` to within `eps` of actual
-- * with confidence `delta`
morris' :: Eps -> Delta -> [a] -> IO Counter
morris' e d as = runRVar (goMorris' e d as) StdRandom

-- * 160000
-- * Run on stream inputs `as` for t independent trials for `t = 1/eps^2 * d`,
-- * and `m` times in parallel, for `m = log(1/d)` and take the median
goMorris' :: Eps -> Delta -> [a] -> RVar Counter
goMorris' e d as = medianOfMeans $ Cl.sourceList as $$ count' $ ccs
      where
        medianOfMeans = fmap median' . (fmap . fmap) mean'
        ccs           = replicate m $ replicate t 0
        t             = round $ 1/(e^2*d)
        m             = round . log $ 1/d

-- * Given an m-long list `ccs` of lists (each of which is t-lengthd) of counters,
-- * consume the stream and output result
count' :: [[Counter]] -> Sink a RVar [[Counter]]
count' ccs = (\x -> 2^(round x) - 1) `fffmap` Cl.foldM (\xs _ -> incrs' xs) ccs
  where fffmap = fmap . fmap . fmap

-- * given a list of list of counters toss a coin for each counter and incr
-- * this can be flattened
incrs' :: [[Counter]] -> RVar [[Counter]]
incrs' = sequence . fmap (sequence . fmap incr)

{-----------------------------------------------------------------------------
    III. Utils
------------------------------------------------------------------------------}

-- * Increment a counter `x` with probability 1/2^x
incr :: Counter -> RVar Counter
incr x = do
  h <- toss . coin $ 0.5^(round x)
  return $ if isHead h then (seq () succ x) else seq () x

mean', median' :: (Floating a, Ord a, RealFrac a) => [a] -> Float
mean'   = fromIntegral . round . mean
median' = fromIntegral . round . median

{-----------------------------------------------------------------------------
    IV. Naive Implementation
------------------------------------------------------------------------------}

-- * 2x slower than morris'
-- * Run on stream inputs `xs` for t independent trials for `t = 1/eps`,
-- * and `m` times in parralell where `m = 1/(e^2 * d)`, take the median
morrisNaive :: Eps -> Delta -> [a] -> IO Counter
morrisNaive e d = fmap median' . replicateM m . morrisB t
  where (t,m) = (round $ 1/(e^2*d), round $ 1/d)

-- * Run Morris beta on stream inputs `xs` for `t` independent trials and average
morrisB :: Int -> [a] -> IO Counter
morrisB t =  fmap mean' . replicateM t . morrisA

-- * Run Morris alpha on stream inputs `xs`
morrisA :: [a] -> IO Counter
morrisA xs = flip runRVar StdRandom $ Cl.sourceList xs $$ alpha

-- * A step in morris Algorithm alpha
alpha :: Sink a RVar Counter
alpha = (\x -> 2^(round x) - 1) <$> Cl.foldM (\x _ -> incr x) 0


{-# LANGUAGE BangPatterns,RecordWildCards,FlexibleContexts,TypeFamilies #-}
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}

module Neuro where

{-@ LIQUID "--no-termination" @-}
{-@ LIQUID "--reflection" @-}
{-@ LIQUID "--no-total" @-}

import Codec.Compression.Zlib     (compress, decompress)

import Data.Binary                (Binary(..), encode, decode)
import Data.List                  (foldl')
import Foreign.Storable           (Storable)

import qualified Data.ByteString.Lazy  as BS
import qualified Data.Vector           as DV
      (Vector,
      toList,
      fromList,
      snoc,empty,
      foldl',
      scanl,scanr,
      zipWith,
      tail,init,last,zip,map, head)
import Numeric.LinearAlgebra
    ( (#>),
      reshape,
      vector,
      cmap,
      (<.>),
      (><),
      outer,
      vjoin,
      Element,
      Matrix,
      Container,
      Linear(scale),
      Numeric,
      RealOf,
      Transposable(tr),
      Normed(norm_2),
      Vector)
import System.Random.MWC as MWC
    ( Variate, asGenST, uniformVector, withSystemRandom )

newtype Network a = Network
                 { matrices   :: DV.Vector (Matrix a)
                 } deriving Show

instance (Element a, Binary a) => Binary (Network a) where
  put (Network ms) = put . DV.toList $ ms
  get = (Network . DV.fromList) `fmap` get

type ActivationFunction a = a -> a

type ActivationFunctionDerivative a = a -> a

trainNTimes :: (Floating (Vector a), Floating a, Numeric a, Num (Vector a), Container Vector a) => Int -> a -> ActivationFunction a -> ActivationFunctionDerivative a -> Network a -> Samples a -> Network a
trainNTimes n = trainUntil (\k _ _ -> k > n)

trainUntil :: (Floating (Vector a), Floating a, Numeric a, Num (Vector a), Container Vector a) => (Int -> Network a -> Samples a -> Bool) -> a -> ActivationFunction a -> ActivationFunctionDerivative a -> Network a -> Samples a -> Network a
trainUntil pr learningRate act act' net samples = go net 0
  where go n !k | pr k n samples = n
                | otherwise      = case backpropOnce learningRate act act' n samples of
                                    n' -> go n' (k+1)

createNetwork :: (Variate a, Storable a) => Int -> [Int] -> Int -> IO (Network a)
createNetwork nInputs hiddens nOutputs =
  fmap Network $ withSystemRandom . asGenST $ \gen -> go gen dimensions DV.empty
  where
        go _ [] !ms         = return ms
        go gen ((!n,!m):ds) ms = do
          !mat <- randomMat n m gen
          go gen ds (ms `DV.snoc` mat)
        randomMat n m g = reshape m `fmap` uniformVector g (n*m)
        dimensions      = zip (hiddens ++ [nOutputs]) $
                              (nInputs+1 : hiddens)

fromWeightMatrices :: Storable a => DV.Vector (Matrix a) -> Network a
fromWeightMatrices ws = Network ws

output :: (Floating (Vector a), Numeric a, Storable a, Num (Vector a)) => Network a -> ActivationFunction a -> Vector a -> Vector a
output (Network{..}) act input = DV.foldl' f (vjoin [input, 1]) matrices
  where f !inp m = cmap act $ m #> inp

outputs :: (Floating (Vector a), Numeric a, Storable a, Num (Vector a)) => Network a -> ActivationFunction a -> Vector a -> DV.Vector (Vector a)
outputs (Network{..}) act input = DV.scanl f (vjoin [input, 1]) matrices
  where f !inp m = cmap act $ m #> inp

deltas :: (Floating (Vector a), Floating a, Numeric a, Container Vector a, Num (Vector a)) => Network a -> ActivationFunctionDerivative a -> DV.Vector (Vector a) -> Vector a -> DV.Vector (Matrix a)
deltas (Network{..}) act' os expected = DV.zipWith outer (DV.tail ds) (DV.init os)
  where !dl = (DV.last os - expected) * (deriv $ DV.last os)
        !ds = DV.scanr f dl (DV.zip os matrices)
        f (!o, m) !del = deriv o * (tr m #> del)
        deriv = cmap act'

updateNetwork :: (Floating (Vector a), Floating a, Numeric a, Storable a, Num (Vector a), Container Vector a) => a -> ActivationFunction a -> ActivationFunctionDerivative a -> Network a -> Sample a -> Network a
updateNetwork alpha act act' n@(Network{..}) (input, expectedOutput) = Network $ DV.zipWith (+) matrices corr
    where !xs = outputs n act input
          !ds = deltas n act' xs expectedOutput
          !corr = DV.map (scale (-alpha)) ds

type Sample a = (Vector a, Vector a)

type Samples a = [Sample a]

backpropOnce :: (Floating (Vector a), Floating a, Numeric a, Num (Vector a), Container Vector a) => a -> ActivationFunction a -> ActivationFunctionDerivative a -> Network a -> Samples a -> Network a
backpropOnce rate act act' n samples = foldl' (updateNetwork rate act act') n samples

quadError :: (Floating (Vector a), Floating a, Fractional (RealOf a), Normed (Vector a), Numeric a) => ActivationFunction a -> Network a -> Samples a -> RealOf a
quadError act net samples = realToFrac $ foldl' (\err (inp, out) -> err + (norm_2 $ output net act inp - out)) 0 samples

tanh' :: Floating a => a -> a
tanh' x = let s = tanh x
           in 1 - s**2

loadNetwork :: (Storable a, Element a, Binary a) => FilePath -> IO (Network a)
loadNetwork fp = return . decode . decompress =<< BS.readFile fp

saveNetwork :: (Storable a, Element a, Binary a) => FilePath -> Network a -> IO ()
saveNetwork fp net = BS.writeFile fp . compress $ encode net


{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}

module Wyas.Parser.Primitives where

import Wyas.Types

import Text.ParserCombinators.Parsec hiding (spaces)
import Numeric (readOct, readHex)
import Data.Ratio ((%))
import Data.Complex (Complex (..))
import Control.Monad (liftM)

parseBool :: Parser LispVal
parseBool = do char '#'
               b <- parseTrue <|> parseFalse
               return $ Bool b
               where parseTrue  = char 't' >> return True
                     parseFalse = char 'f' >> return False

parseAtom :: Parser LispVal
parseAtom = do first <- letter <|> symbol
               rest <- many (letter <|> digit <|> symbol)
               return $ Atom (first:rest)

--
-- Char & String
--

parseChar :: Parser LispVal
parseChar = liftM Character (string "#\\" >> parseChar')
          where parseWS = (string " " <|> string "space") >> return ' '
                parseNewline = string "newline" >> return '\n'
                parseChar' = parseWS <|> parseNewline <|> anyChar

parseString :: Parser LispVal
parseString = do char '"'
                 x <- many (escapedChars <|> noneOf "\\\"")
                 char '"'
                 (return . String) x

--
-- Parsing Integers
--

parseNumber :: Parser LispVal
parseNumber = parsePlainNumber <|> parseRadixNumber

parsePlainNumber :: Parser LispVal
parsePlainNumber = liftM (Number . read) (many1 digit)

--
-- Radix Numbers
--

parseRadixNumber :: Parser LispVal
parseRadixNumber = char '#' >>
                   (
                        parseDecimal
                        <|> parseBinary
                        <|> parseOct
                        <|> parseHex
                   )

parseDecimal :: Parser LispVal
parseDecimal = do char 'd'
                  n <- many1 digit
                  (return . Number . read) n

parseBinary :: Parser LispVal
parseBinary = do char 'b'
                 n <- many $ oneOf "01"
                 (return . Number . bin2int) n

parseHex :: Parser LispVal
parseHex = do char 'x'
              n <- many $ oneOf "0123456789abcdefABCDEF"
              return . Number . readWith readHex $ n
              where readWith f s = fst $ head (f s)

parseOct :: Parser LispVal
parseOct = do char 'o'
              n <- many $ oneOf "01234567"
              return . Number . readWith readOct $ n
              where readWith f s = fst $ head (f s)

--
-- Numeric Tower
--

parseFloat :: Parser LispVal
parseFloat = do x <- many1 digit
                char '.'
                y <- many1 digit
                return $ Float (read (x ++ "." ++y))

parseRational :: Parser LispVal
parseRational = do n <- many1 digit
                   char '/'
                   d <- many1 digit
                   return $ Ratio $ read n % read d

parseComplex :: Parser LispVal
parseComplex = do x <- try parseFloat <|> parsePlainNumber
                  char '+'
                  y <- try parseFloat <|> parsePlainNumber
                  char 'i'
                  return $ Complex (toDouble x :+ toDouble y)

--
-- Helpers
--

escapedChars :: Parser Char
escapedChars = char '\\' >>
               (
                    char '\\' <|> char '"' <|>
                    parseNewline <|>
                    parseReturn <|>
                    parseTab
               )
               where parseNewline = char 'n' >> return '\n'
                     parseReturn  = char 'r' >> return '\r'
                     parseTab     = char 't' >> return '\t'

symbol :: Parser Char
symbol = oneOf "!$%|*+-/:<=>?@^_~"

spaces :: Parser ()
spaces = skipMany1 space

bin2int :: String -> Integer
bin2int = bin2int' 0
        where bin2int' digint "" = digint
              bin2int' digint (x:xs) = let old = 2 * digint + (if x == '0' then 0 else 1)
                                       in bin2int' old xs

-- TODO clean up
toDouble :: LispVal -> Double
toDouble (Float f) = f
toDouble (Number n) = fromIntegral n
toDouble _ = error "ERROR: not a double"


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Strict           #-}
module STC.Plan
  ( module DFT.Plan
  , module STC.Plan
  ) where

import           Control.Monad        as M
import           Data.Array.Repa      as R
import           Data.Complex
import           Data.List            as L
import           Data.Vector.Storable as VS
import           DFT.Plan
import           System.FilePath
import           System.Random
import           Control.Concurrent.Async

{-# INLINE generateRadomVector #-}
generateRadomVector ::
     (Storable e, Num e, Random e)
  => Int
  -> IO (VS.Vector (Complex e))
generateRadomVector len =
  newStdGen >>= return . VS.map (:+ 0) . VS.fromList . L.take len . randoms

makePlanDiscrete :: FilePath -> DFTPlan -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO DFTPlan
makePlanDiscrete folderPath initPlan nx ny numR2Freq numThetaFreq numRFreq numPhiFreq numRhoFreq = do
  importFFTWWisdom (folderPath </> "fftwwisdom.dat")
  let lens =
        [ numThetaFreq * numR2Freq ^ 2
        , nx * ny * numThetaFreq * numRFreq
        , numR2Freq ^ 2
        , numThetaFreq * numRFreq * numPhiFreq * numRhoFreq
        , numRhoFreq * numRFreq
        , numThetaFreq * numR2Freq ^ 2
        , numRFreq
        ]
  (initVec1:initVec2:initVec3:initVec4:initVec5:initVec6:initVec7:_) <-
   mapConcurrently generateRadomVector lens
  lock <- getFFTWLock
  plan <-
    fst <$>
    (dft1dGPlan
       lock
       initPlan
       [numThetaFreq, numR2Freq, numR2Freq]
       [1, 2]
       initVec1 >>= \(plan, vec) ->
       idft1dGPlan
         lock
         plan
         [numThetaFreq, numR2Freq, numR2Freq]
         [1, 2]
         vec >>= \(plan, _) ->
         dft1dGPlan lock plan [numRFreq, numThetaFreq, nx, ny] [0, 1] initVec2 >>= \(plan, vec) ->
           idft1dGPlan lock plan [numRFreq, numThetaFreq, nx, ny] [0, 1] vec >>= \(plan, vec) ->
             dft1dGPlan
               lock
               plan
               [numRFreq, numThetaFreq, numR2Freq, numR2Freq]
               [0]
               vec >>= \(plan, vec) ->
               idft1dGPlan
                 lock
                 plan
                 [numRFreq, numThetaFreq, numR2Freq, numR2Freq]
                 [0]
                 vec
            >>= \(plan, _) ->
             dft1dGPlan lock plan [numR2Freq, numR2Freq] [0, 1] initVec3 >>= \(plan, vec) ->
               idft1dGPlan lock plan [numR2Freq, numR2Freq] [0, 1] vec >>= \(plan, _) ->
                 dft1dGPlan
                   lock
                   plan
                   [numRFreq, numRhoFreq, numThetaFreq, numPhiFreq]
                   [0, 1]
                   initVec4 >>= \(plan, vec) ->
                   idft1dGPlan
                     lock
                     plan
                     [numRFreq, numRhoFreq, numThetaFreq, numPhiFreq]
                     [0, 1]
                     vec >>= \(plan, _) ->
                     dft1dGPlan lock plan [numRFreq, numRhoFreq] [0, 1] initVec5 >>= \(plan, vec) ->
                       idft1dGPlan lock plan [numRFreq, numRhoFreq] [0, 1] vec >>= \(plan, _) ->
                         idft1dGPlan
                           lock
                           plan
                           [numThetaFreq, numR2Freq, numR2Freq]
                           [1, 2]
                           initVec6 >>= \(plan, _) ->
                             dft1dGPlan lock plan [numRFreq] [0] initVec7 )
  exportFFTWWisdom (folderPath </> "fftwwisdom.dat")
  return plan

makePlan :: FilePath -> DFTPlan -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO DFTPlan
makePlan folderPath initPlan nx ny numR2Freq numThetaFreq numRFreq numPhiFreq numRhoFreq = do
  importFFTWWisdom (folderPath </> "fftwwisdom.dat")
  let lens =
        [ numRFreq * numThetaFreq * numR2Freq ^ 2
        , nx * ny * numThetaFreq * numRFreq
        , numR2Freq ^ 2
        , numThetaFreq * numRFreq * numPhiFreq * numRhoFreq
        , numRhoFreq * numRFreq
        , numThetaFreq * numR2Freq ^ 2
        ]
  (initVec1:initVec2:initVec3:initVec4:initVec5:initVec6:_) <-
   mapConcurrently generateRadomVector lens
  lock <- getFFTWLock
  plan <-
    fst <$>
    (dft1dGPlan
       lock
       initPlan
       [numRFreq, numThetaFreq, numR2Freq, numR2Freq]
       [0, 1, 2, 3]
       initVec1 >>= \(plan, vec) ->
       idft1dGPlan
         lock
         plan
         [numRFreq, numThetaFreq, numR2Freq, numR2Freq]
         [0, 1, 2, 3]
         vec >>= \(plan, _) ->
         dft1dGPlan lock plan [numRFreq, numThetaFreq, nx, ny] [0, 1] initVec2 >>= \(plan, vec) ->
           idft1dGPlan lock plan [numRFreq, numThetaFreq, nx, ny] [0, 1] vec -- >>= \(plan, vec) ->
             -- dft1dGPlan
             --   lock
             --   plan
             --   [numRFreq, numThetaFreq, numR2Freq, numR2Freq]
             --   [0]
             --   vec >>= \(plan, vec) ->
             --   idft1dGPlan
             --     lock
             --     plan
             --     [numRFreq, numThetaFreq, numR2Freq, numR2Freq]
             --     [0]
             --     vec
            >>= \(plan, _) ->
             dft1dGPlan lock plan [numR2Freq, numR2Freq] [0, 1] initVec3 >>= \(plan, vec) ->
               idft1dGPlan lock plan [numR2Freq, numR2Freq] [0, 1] vec >>= \(plan, _) ->
                 dft1dGPlan
                   lock
                   plan
                   [numRFreq, numRhoFreq, numThetaFreq, numPhiFreq]
                   [0, 1]
                   initVec4 >>= \(plan, vec) ->
                   idft1dGPlan
                     lock
                     plan
                     [numRFreq, numRhoFreq, numThetaFreq, numPhiFreq]
                     [0, 1]
                     vec >>= \(plan, _) ->
                     dft1dGPlan lock plan [numRFreq, numRhoFreq] [0, 1] initVec5 >>= \(plan, vec) ->
                       idft1dGPlan lock plan [numRFreq, numRhoFreq] [0, 1] vec >>= \(plan, _) ->
                         idft1dGPlan
                           lock
                           plan
                           [numThetaFreq, numR2Freq, numR2Freq]
                           [1, 2]
                           initVec6)
  exportFFTWWisdom (folderPath </> "fftwwisdom.dat")
  return plan

{-# INLINE makePlanFromArray #-}
makePlanFromArray ::
     (R.Source r (Complex Double))
  => DFTPlan
  -> R.Array r DIM4 (Complex Double)
  -> IO DFTPlan
makePlanFromArray initPlan arr = do
  let (Z :. (numRFreq) :. (numThetaFreq) :. (nx) :. (ny)) = extent arr
      initVec = VS.fromList . R.toList $ arr
  lock <- getFFTWLock
  fst <$>
    (dft1dGPlan lock initPlan [nx, ny] [0, 1] initVec >>= \(plan, vec) ->
       idft1dGPlan lock plan [nx, ny] [0, 1] vec >>= \(plan, vec) ->
         dft1dGPlan lock plan [numRFreq, numThetaFreq, nx, ny] [0, 1] vec >>= \(plan, vec) ->
           idft1dGPlan lock plan [numRFreq, numThetaFreq, nx, ny] [0, 1] vec)

-- {-# INLINE makePlan #-}
-- makePlan :: FilePath -> DFTPlan -> Int -> Int -> Int -> Int -> Int -> IO DFTPlan
-- makePlan folderPath initPlan nx ny numR2Freq numThetaFreq numRFreq = do
--   importFFTWWisdom (folderPath </> "fftwwisdom.dat")
--   initVec1 <-
--     VS.fromList . L.map (:+ 0) <$> M.replicateM (numR2Freq ^ 2) randomIO
--   initVec2 <-
--     VS.fromList . L.map (:+ 0) <$>
--     M.replicateM (nx * ny * numThetaFreq * numRFreq) randomIO
--   initVec3 <- VS.fromList . L.map (:+ 0) <$> M.replicateM (nx * ny) randomIO
--   lock <- getFFTWLock
--   plan <-
--     fst <$>
--     (dft1dGPlan lock initPlan [numR2Freq, numR2Freq] [0, 1] initVec1 >>= \(plan, vec) ->
--        idft1dGPlan lock plan [numR2Freq, numR2Freq] [0, 1] vec >>= \(plan, _) ->
--          dft1dGPlan lock plan [numRFreq, numThetaFreq, nx, ny] [0, 1] initVec2 >>= \(plan, vec) ->
--            idft1dGPlan lock plan [numRFreq, numThetaFreq, nx, ny] [0, 1] vec >>= \(plan, _) ->
--              dft1dGPlan lock plan [nx, ny] [0, 1] initVec3 >>= \(plan, vec) ->
--                idft1dGPlan lock plan [nx, ny] [0, 1] vec)
--   exportFFTWWisdom (folderPath </> "fftwwisdom.dat")
--   return plan


-- |
-- Copyright: (c) 2020-2021 Tom Westerhout
-- SPDX-License-Identifier: BSD-3-Clause
-- Maintainer: Tom Westerhout <14264576+twesterhout@users.noreply.github.com>
module Numeric.PRIMME.Dense
  ( -- * Treat dense matrices as linear operators
    primmeFromDense,
  )
where

import Control.Monad.ST (RealWorld)
import Data.Complex
import Data.Proxy
import Data.Vector.Storable (MVector, Vector)
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as MV
import Foreign.C.Types (CChar, CInt)
import Foreign.Marshal.Utils
import Foreign.Ptr (Ptr)
import Numeric.PRIMME.Types

type BlasInt = CInt

type BlasHemmType a =
  -- | SIDE
  Ptr CChar ->
  -- | UPLO
  Ptr CChar ->
  -- | M
  Ptr BlasInt ->
  -- | N
  Ptr BlasInt ->
  -- | ALPHA
  Ptr a ->
  -- | A
  Ptr a ->
  -- | LDA
  Ptr BlasInt ->
  -- | B
  Ptr a ->
  -- | LDB
  Ptr BlasInt ->
  -- | BETA
  Ptr a ->
  -- | C
  Ptr a ->
  -- | LDC
  Ptr BlasInt ->
  IO ()

foreign import ccall unsafe "ssymm_" ssymm_ :: BlasHemmType Float

foreign import ccall unsafe "dsymm_" dsymm_ :: BlasHemmType Double

foreign import ccall unsafe "chemm_" chemm_ :: BlasHemmType (Complex Float)

foreign import ccall unsafe "zhemm_" zhemm_ :: BlasHemmType (Complex Double)

hemm :: BlasDatatype a => Int -> Int -> a -> Vector a -> Int -> Vector a -> Int -> a -> MVector RealWorld a -> Int -> IO ()
hemm m n α a aStride b bStride β c cStride = do
  with (fromIntegral (fromEnum 'L') :: CChar) $ \side' ->
    with (fromIntegral (fromEnum 'U') :: CChar) $ \uplo' -> do
      with (fromIntegral m) $ \m' ->
        with (fromIntegral n) $ \n' ->
          with (fromIntegral aStride) $ \aStride' ->
            with (fromIntegral bStride) $ \bStride' ->
              with (fromIntegral cStride) $ \cStride' ->
                with α $ \α' ->
                  with β $ \β' ->
                    V.unsafeWith a $ \aPtr ->
                      V.unsafeWith b $ \bPtr ->
                        MV.unsafeWith c $ \cPtr ->
                          hemm' side' uplo' m' n' α' aPtr aStride' bPtr bStride' β' cPtr cStride'
  where
    hemm' :: forall b. BlasDatatype b => BlasHemmType b
    hemm' = case blasTag (Proxy :: Proxy b) of
      FloatTag -> ssymm_
      DoubleTag -> dsymm_
      ComplexFloatTag -> chemm_
      ComplexDoubleTag -> zhemm_

blockHemm :: BlasDatatype a => a -> Block a -> Block a -> a -> MBlock RealWorld a -> IO ()
blockHemm α (Block (m, n) aStride a) (Block (n', k) bStride b) β (MBlock (m', k') cStride c)
  | m /= n || m /= m' || n /= n' || k /= k' =
    error $
      "dimension mismatch: " <> show (m, n) <> " x " <> show (n', k) <> " = " <> show (m', k')
  | otherwise = hemm m' k' α a aStride b bStride β c cStride

-- | Treat a dense symmetric or Hermitian matrix as a operator. Internally we
-- call
-- [@?symm@](https://www.netlib.org/lapack/explore-html/db/dc9/group__single__blas__level3_ga8e8391a9873114d97e2b63e39fe83b2e.html#ga8e8391a9873114d97e2b63e39fe83b2e)
-- or
-- [@?hemm@](https://www.netlib.org/lapack/explore-html/db/def/group__complex__blas__level3_gad2d1853a142397404eae974b6574ece3.html#gad2d1853a142397404eae974b6574ece3)
-- BLAS functions so it is really important that the matrix is indeed Hermitian.
primmeFromDense ::
  BlasDatatype a =>
  -- | Matrix in column-major order
  Block a ->
  -- | Hermitian linear operator
  PrimmeOperator a
primmeFromDense a
  | isHermitian a = \b c -> blockHemm 1 a b 0 c
  | otherwise = error "expected a Hermitian matrix"

-- | Determine whether a matrix is Hermitian (or symmetric when @a@ is real).
--
-- /Note:/ this function returns 'False' for non-square matrices. No exceptions
-- are thrown.
isHermitian :: forall a. BlasDatatype a => Block a -> Bool
isHermitian (Block (n, n') stride v)
  | n == n' =
    -- Iterate in column-major order here and over the lower part of the matrix
    loop 0 (n - 1) $ \j ->
      loop (j + 1) n $ \i ->
        check i j
  | otherwise = False
  where
    access !i !j = v V.! (i + stride * j)
    check !i !j = access i j `unsafeEq` conj (access j i)
    loop !i !high f
      | i < high =
        if f i
          then loop (i + 1) high f
          else False
      | otherwise = True
    -- Yes, we really want exact binary comparison of floating point types
    unsafeEq :: a -> a -> Bool
    unsafeEq = case blasTag (Proxy :: Proxy a) of
      FloatTag -> (==)
      DoubleTag -> (==)
      ComplexFloatTag -> (==)
      ComplexDoubleTag -> (==)
    -- Return complex conjugate of a number.
    !conj = case blasTag (Proxy :: Proxy a) of
      FloatTag -> id
      DoubleTag -> id
      ComplexFloatTag -> Data.Complex.conjugate
      ComplexDoubleTag -> Data.Complex.conjugate


module Other (
    parseCsvToMatrixR,
    printCsvFromMatrixR,
    iterateM
  ) where

import Numeric.LinearAlgebra
import Data.List
import Data.List.Split

parseCsvToMatrixR :: FilePath -> IO (Matrix R)
parseCsvToMatrixR fp = do
  csv <- readFile fp
  return . fromLists . fmap (fmap (read :: String -> R) . splitOn ",") $ lines csv

printCsvFromMatrixR :: FilePath -> Matrix R -> IO ()
printCsvFromMatrixR fp m = do
  let csv = unlines . fmap (intercalate ", ") $ fmap show <$> toLists m
  writeFile fp csv

-- TODO: check monad rule
iterateM :: Monad m => (a -> m a) -> a -> [m a]
iterateM f x = iterate (f =<<) (return x)


module Main where

import Criterion.Main
import Statistics.Sample.Histogram.Magnitude
import Data.Functor.Identity

main = defaultMain
  [ bgroup "resolution" [ bench "1"  . nf (foldHist 1) $ Identity (1 :: Double)
                        , bench "2"  . nf (foldHist 2) $ Identity (1 :: Double)
                        , bench "3"  . nf (foldHist 3) $ Identity (1 :: Double)
                        ]
  , bgroup "size"       [ bench "0"      $ nf (foldHist 2) ([] :: [Double])
                        , bench "0..9"   $ nf (foldHist 2) [0..9 :: Double]
                        , bench "0..99"  $ nf (foldHist 2) [0..99 :: Double]
                        ]
  ]


module Day10 where

import Data.Function ((&))
import Data.List.Split
import qualified Data.List as L
import Data.Array
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Data.Char
import Data.Maybe (catMaybes, isJust, fromJust)
import Text.ParserCombinators.ReadP as P

import Data.Complex
import qualified Data.Matrix as M

import Lib

{-
--- Day 10: Adapter Array ---

Patched into the aircraft's data port, you discover weather forecasts of a massive tropical storm. Before you can figure out whether it will impact your vacation plans, however, your device suddenly turns off!

Its battery is dead.

You'll need to plug it in. There's only one problem: the charging outlet near your seat produces the wrong number of jolts. Always prepared, you make a list of all of the joltage adapters in your bag.

Each of your joltage adapters is rated for a specific output joltage (your puzzle input). Any given adapter can take an input 1, 2, or 3 jolts lower than its rating and still produce its rated output joltage.

In addition, your device has a built-in joltage adapter rated for 3 jolts higher than the highest-rated adapter in your bag. (If your adapter list were 3, 9, and 6, your device's built-in adapter would be rated for 12 jolts.)

Treat the charging outlet near your seat as having an effective joltage rating of 0.

Since you have some time to kill, you might as well test all of your adapters. Wouldn't want to get to your resort and realize you can't even charge your device!

If you use every adapter in your bag at once, what is the distribution of joltage differences between the charging outlet, the adapters, and your device?

For example, suppose that in your bag, you have adapters with the following joltage ratings:

16
10
15
5
1
11
7
19
6
12
4

With these adapters, your device's built-in joltage adapter would be rated for 19 + 3 = 22 jolts, 3 higher than the highest-rated adapter.

Because adapters can only connect to a source 1-3 jolts lower than its rating, in order to use every adapter, you'd need to choose them like this:

    The charging outlet has an effective rating of 0 jolts, so the only adapters that could connect to it directly would need to have a joltage rating of 1, 2, or 3 jolts. Of these, only one you have is an adapter rated 1 jolt (difference of 1).
    From your 1-jolt rated adapter, the only choice is your 4-jolt rated adapter (difference of 3).
    From the 4-jolt rated adapter, the adapters rated 5, 6, or 7 are valid choices. However, in order to not skip any adapters, you have to pick the adapter rated 5 jolts (difference of 1).
    Similarly, the next choices would need to be the adapter rated 6 and then the adapter rated 7 (with difference of 1 and 1).
    The only adapter that works with the 7-jolt rated adapter is the one rated 10 jolts (difference of 3).
    From 10, the choices are 11 or 12; choose 11 (difference of 1) and then 12 (difference of 1).
    After 12, only valid adapter has a rating of 15 (difference of 3), then 16 (difference of 1), then 19 (difference of 3).
    Finally, your device's built-in adapter is always 3 higher than the highest adapter, so its rating is 22 jolts (always a difference of 3).

In this example, when using every adapter, there are 7 differences of 1 jolt and 5 differences of 3 jolts.

Here is a larger example:

28
33
18
42
31
14
46
20
48
47
24
23
49
45
19
38
39
11
1
32
25
35
8
17
7
9
4
2
34
10
3

In this larger example, in a chain that uses all of the adapters, there are 22 differences of 1 jolt and 10 differences of 3 jolts.

Find a chain that uses all of your adapters to connect the charging outlet to your device's built-in adapter and count the joltage differences between the charging outlet, the adapters, and your device. What is the number of 1-jolt differences multiplied by the number of 3-jolt differences?

To begin, get your puzzle input.
-}

parse :: [String] -> [Integer]
parse ls = ls
         & map read

partA ns =
  let adapters = L.sort ns
      diffs = zipWith (-) adapters (0:adapters)
      ones = diffs & filter (==1) & length
      threes = diffs & filter (==3) & length
  in ones * (threes + 1)

day10 ls =
  let adapters = parse ls
  in partA adapters

{-
--- Part Two ---

To completely determine whether you have enough adapters, you'll need to figure out how many different ways they can be arranged. Every arrangement needs to connect the charging outlet to your device. The previous rules about when adapters can successfully connect still apply.

The first example above (the one that starts with 16, 10, 15) supports the following arrangements:

(0), 1, 4, 5, 6, 7, 10, 11, 12, 15, 16, 19, (22)
(0), 1, 4, 5, 6, 7, 10, 12, 15, 16, 19, (22)
(0), 1, 4, 5, 7, 10, 11, 12, 15, 16, 19, (22)
(0), 1, 4, 5, 7, 10, 12, 15, 16, 19, (22)
(0), 1, 4, 6, 7, 10, 11, 12, 15, 16, 19, (22)
(0), 1, 4, 6, 7, 10, 12, 15, 16, 19, (22)
(0), 1, 4, 7, 10, 11, 12, 15, 16, 19, (22)
(0), 1, 4, 7, 10, 12, 15, 16, 19, (22)

(The charging outlet and your device's built-in adapter are shown in parentheses.) Given the adapters from the first example, the total number of arrangements that connect the charging outlet to your device is 8.

The second example above (the one that starts with 28, 33, 18) has many arrangements. Here are a few:

(0), 1, 2, 3, 4, 7, 8, 9, 10, 11, 14, 17, 18, 19, 20, 23, 24, 25, 28, 31,
32, 33, 34, 35, 38, 39, 42, 45, 46, 47, 48, 49, (52)

(0), 1, 2, 3, 4, 7, 8, 9, 10, 11, 14, 17, 18, 19, 20, 23, 24, 25, 28, 31,
32, 33, 34, 35, 38, 39, 42, 45, 46, 47, 49, (52)

(0), 1, 2, 3, 4, 7, 8, 9, 10, 11, 14, 17, 18, 19, 20, 23, 24, 25, 28, 31,
32, 33, 34, 35, 38, 39, 42, 45, 46, 48, 49, (52)

(0), 1, 2, 3, 4, 7, 8, 9, 10, 11, 14, 17, 18, 19, 20, 23, 24, 25, 28, 31,
32, 33, 34, 35, 38, 39, 42, 45, 46, 49, (52)

(0), 1, 2, 3, 4, 7, 8, 9, 10, 11, 14, 17, 18, 19, 20, 23, 24, 25, 28, 31,
32, 33, 34, 35, 38, 39, 42, 45, 47, 48, 49, (52)

(0), 3, 4, 7, 10, 11, 14, 17, 20, 23, 25, 28, 31, 34, 35, 38, 39, 42, 45,
46, 48, 49, (52)

(0), 3, 4, 7, 10, 11, 14, 17, 20, 23, 25, 28, 31, 34, 35, 38, 39, 42, 45,
46, 49, (52)

(0), 3, 4, 7, 10, 11, 14, 17, 20, 23, 25, 28, 31, 34, 35, 38, 39, 42, 45,
47, 48, 49, (52)

(0), 3, 4, 7, 10, 11, 14, 17, 20, 23, 25, 28, 31, 34, 35, 38, 39, 42, 45,
47, 49, (52)

(0), 3, 4, 7, 10, 11, 14, 17, 20, 23, 25, 28, 31, 34, 35, 38, 39, 42, 45,
48, 49, (52)

In total, this set of adapters can connect the charging outlet to your device in 19208 distinct arrangements.

You glance back down at your bag and try to remember why you brought so many adapters; there must be more than a trillion valid ways to arrange them! Surely, there must be an efficient way to count the arrangements.

What is the total number of distinct ways you can arrange the adapters to connect the charging outlet to your device?
-}

partB ns =
  let upper = maximum ns + 3
      as = L.sort (0:upper:ns)
      diffs = zipWith (-) (tail as) as
      oneSeqs = splitOn [3] diffs
      ways = map cnt oneSeqs
  in product ways

cnt [] = 1
cnt (1:1:1:rest) = cnt (1:1:rest)    -- do 1:1:1:rest
                 + cnt (1:rest)      -- 2:1:rest
                 + cnt rest          -- 3:rest
cnt (1:1:rest)   = cnt (1:rest)      -- 1:1:rest
                 + cnt rest          -- 2:rest
cnt (1:rest)     = cnt rest          -- 1:rest

cnt' 0 = 1
cnt' 1 = cnt' 0
cnt' 2 = cnt' 1 + cnt' 0
cnt' n = cnt' (n-1) + cnt' (n-2) + cnt' (n-3)

day10b ls =
  let as = parse ls
  in partB as

{-
Matrix-wise:
  let the counts for n-3, n-2, n-1 be in a 3x1 matrix
  Then

  (n-2|   = ( 0 1 0 |  ( n-3 |
  |n-1|     | 0 0 1 |  | n-2 |
  |n  )     | 1 1 1 )  | n-1 )

Base case: (n=0, n=1, n=2) = (1 1 2)
So for n >= 3 we want

  (n-2|  = ( 0 1 0 | ^ (n-2)  ( 1 |
  |n-1|    | 0 0 1 |          | 1 |
  | n )    | 1 1 1 )          | 2 )

We have

λ_1 = 1/3 (1 + (19 - 3 sqrt(33))^(1/3) + (19 + 3 sqrt(33))^(1/3))
λ_2 = 1/3 - 1/6 (1 + i sqrt(3)) (19 - 3 sqrt(33))^(1/3) - 1/6 (1 - i sqrt(3)) (19 + 3 sqrt(33))^(1/3)
λ_3 = 1/3 - 1/6 (1 - i sqrt(3)) (19 - 3 sqrt(33))^(1/3) - 1/6 (1 + i sqrt(3)) (19 + 3 sqrt(33))^(1/3)

and eigenvectors
v_1 = (1/3 (-1 - (4 2^(2/3))/(13 + 3 sqrt(33))^(1/3) + (2 (13 + 3 sqrt(33)))^(1/3)), 1/3 (-1 - 2/(17 + 3 sqrt(33))^(1/3) + (17 + 3 sqrt(33))^(1/3)), 1)
v_2 = (-1/3 + (2 2^(2/3) (1 + i sqrt(3)))/(3 (13 + 3 sqrt(33))^(1/3)) - ((1 - i sqrt(3)) (13 + 3 sqrt(33))^(1/3))/(3 2^(2/3)), -1/3 + (1 - i sqrt(3))/(3 (17 + 3 sqrt(33))^(1/3)) - 1/6 (1 + i sqrt(3)) (17 + 3 sqrt(33))^(1/3), 1)
v_3 = (-1/3 + (2 2^(2/3) (1 - i sqrt(3)))/(3 (13 + 3 sqrt(33))^(1/3)) - ((1 + i sqrt(3)) (13 + 3 sqrt(33))^(1/3))/(3 2^(2/3)), -1/3 + (1 + i sqrt(3))/(3 (17 + 3 sqrt(33))^(1/3)) - 1/6 (1 - i sqrt(3)) (17 + 3 sqrt(33))^(1/3), 1)
-}

-- M = S.J.S^(-1)
type C = Complex Double
type Mat = M.Matrix C
s :: Mat
s = M.fromList 3 3 [0.295598, (-0.647799) :+ (-1.72143), (-0.647799) :+ (1.72143),
                    0.543689, (-0.771845) :+ (1.11514),  (-0.771845) :+ (-1.11514),
                    1, 1, 1]
j :: [C]
j = [1.83929,
              (-0.419643) :+ (-0.606291),
                                          (-0.419643) :+ (0.606291)]
s' :: Mat
s' = M.fromList 3 3 [(0.336228) :+ (-2.81377e-18), (0.519032) :+ (-4.34358e-18), (0.61842) - (5.17532e-18),
                     (-0.168114) :+ (0.198324), (-0.259516) :+ (-0.142222), (0.19079) :+ (0.0187006),
                     (-0.168114) :+ (-0.198324), (-0.259516) :+ (0.142222), (0.19079) :+ (-0.0187006)]

pow n =
  s `M.multStd2` j'' `M.multStd2` s'
  where
    j' :: [C]
    j' = map (**n) j
    j'' :: Mat
    j'' = M.diagonalList 3 0 j'

cnt'' 0 = 1
cnt'' 1 = 1
cnt'' 2 = 2
cnt'' n =
  let m = pow (n-2)
      v = M.fromList 3 1 [1, 1, 2]
      v' = m `M.multStd2` v
  in  v' M.! (3, 1)

approx :: Double -> C -> C -> Bool
approx err a b = (realPart $ abs (a - b)) < err


{-# LANGUAGE ScopedTypeVariables #-}

module Math.Probably.NelderMead where

import Math.Probably.FoldingStats

import Data.Ord
import Data.List
import Data.Maybe

import Debug.Trace

import Foreign.Storable

import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as L

{-mean, m2 :: V.Vector Double
mean = fromList [45.1,10.3]

cov :: Matrix Double
cov = (2><2) $ [5.0, 1,
                1, 1.5]

invCov = inv cov

lndet = log $ det cov

pdf = multiNormalByInv lndet invCov mean

m2 = fromList [55.1,20.3]

main = runRIO $ do
  io $ print $ pdf mean
  ap <- nmAdaMet (defaultAM {nsam =1000000}) pdf (fromList [3.0,0.8])
  {-iniampar <- sample $ initialAdaMet 500 5e-3 (pdf) $ fromList [30.0,8.0]
  io $ print iniampar
  froampar <- runAndDiscard 5000 (show . ampPar) iniampar $ adaMet False (pdf)
  io $ print froampar
  io $ print $ realToFrac (count_accept froampar) / (realToFrac $ count froampar) -}
  let iniSim = genInitial (negate . pdf) 0.1 $ fromList [3.0,0.5]
  io $ mapM_ print iniSim
  let finalSim =  goNm (negate . pdf) 1 iniSim
  io $ print $ finalSim
  io $ print $ hessianFromSimplex (negate . pdf) finalSim -}

type Simplex = [(V.Vector Double, Double)]

{-instance (Storable a, Num a) => Num (V.Vector a) where
   (+) = V.zipWith (+)
   (-) = V.zipWith (-)
   (*) = V.zipWith (*) -}

scale x = V.map (*x)

centroid :: Simplex -> V.Vector Double
centroid points = scale (recip l) $ sum $ map fst points
    where l = fromIntegral $ length points

nmAlpha = 1
nmGamma = 2
nmRho = 0.5
nmSigma = 0.5

secondLast (x:y:[]) = x
secondLast (_:xs) = secondLast xs

replaceLast xs x = init xs ++ [x]

{-hessianFromSimplex :: (V.Vector Double -> Double) -> [Int] -> [((Int, Int), Double)] -> Simplex -> (V.Vector Double, Matrix Double)
hessianFromSimplex f isInt fixed sim =
  let mat :: [V.Vector Double]
      mat = toRows $ fromColumns $ map fst sim
      fsw ((y0, ymin),ymax) = (y0, max (ymax-y0) (y0-ymin))
      swings = flip map mat $ runStat (fmap fsw $ meanF `both` minFrom 1e80 `both` maxFrom (-1e80)) . toList
      n = length swings
      xv = fromList $ map fst swings
      fxv = f  xv
      fixedpts = map fst fixed
      iswings i | i `elem` isInt = atLeastOne $snd $ swings!!i
                | otherwise = snd $ swings!!i
      funits d i | d/=i = 0
                 | i `elem` isInt = atLeastOne $ snd $ swings!!i
                 | otherwise = snd $ swings!!i
      units = flip map [0..n-1] $ \d -> V.generate n $ funits d
      --http://www.caspur.it/risorse/softappl/doc/sas_docs/ormp/chap5/sect28.htm
      fhess ij@ (i,j) | ij `elem` fixedpts = fromJust $ lookup ij fixed
                      | i>=j =
                         ((f $ xv + units!!i + units!!j)
                          - (f $ xv + units!!i - units!!j)
                          - (f $ xv - units!!i + units!!j)
                          + (f $ xv - units!!i - units!!j) )
                          / (4*(iswings i) * (iswings j))
                      | otherwise = 0.0
      hess1= buildMatrix n n fhess
      hess2 = buildMatrix n n $ \(i,j) ->if i>=j then hess1@@>(i,j)
                                                 else hess1@@>(j,i)

  -- we probably  ought to make pos-definite
  -- http://www.mathworks.com/matlabcentral/newsreader/view_thread/103174
  -- posdefify in R etc
  in (fromList (map (fst) swings), hess2) -}

atLeastOne :: Double -> Double
atLeastOne x | isNaN x || isInfinite x = 1.0
             | x < -1.0 || x > 1.0 = realToFrac $ round x
             | x < 0 = -1.0
             | otherwise = 1.0

genInitial :: (V.Vector Double -> Double) -> [Int] -> (Int -> Double) -> V.Vector Double -> Simplex
genInitial f isInt h x0 = sim where
  n = length $ V.toList x0
  unit d = V.generate n $ \j -> if j /=d then 0.0 else if d `elem` isInt then atLeastOne $ h j*(x0!d)
                                                                          else h j*(x0!d)
  mkv d = with f $ x0 + unit d
  sim = (x0, f x0) : map mkv [0..n-1]
  (!) = (V.!)

goNm :: (V.Vector Double -> Double) -> [Int] -> Double -> Int -> Int -> Simplex -> Simplex
goNm f' isInt tol nmin nmax sim' = go f' 0 $ sortBy (comparing snd) sim'  where
  go f i sim = let nsim = sortBy (comparing snd) $ (nmStep f isInt sim)
                   fdiff = abs $ snd (last nsim) - snd (head nsim)
               in case () of
                      _ |  (fdiff < tol && i>nmin) || i>nmax -> nsim
                        |  all (<0) (map snd sim) && any (>0) (map snd nsim) -> sim
                        |  any (isNaN) (map snd nsim) -> sim
                        |  otherwise   -> go f (i+1) nsim

goNmVerbose :: (V.Vector Double -> Double) -> [Int] -> Double -> Int -> Int -> Simplex -> Simplex
goNmVerbose f' isInt tol nmin nmax sim' = go f' 0 $ sortBy (comparing snd) sim' where
  go f i sim = let nsim = sortBy (comparing snd) $ (nmStep f isInt sim)
                   fdiff = trace ("1: "++ show (fst (head nsim)) ++ "\nlast: "++
                                show (fst (last nsim)) ++ "\n#"++show i++": "++
                                show (map snd nsim))
                            abs $ snd (last nsim) - snd (head nsim)
               in case () of
                    _ |  (fdiff < tol && i>nmin) || i>nmax -> nsim
                      |  all (<0) (map snd sim) && any (>0) (map snd nsim) -> sim
                      |  any (isNaN) (map snd nsim) -> sim
                      |  otherwise   -> go f (i+1) nsim

nmStep :: (V.Vector Double -> Double) -> [Int] -> Simplex -> Simplex
nmStep f isInt s0 = snext where
   x0 = centroid $ init s0
   xnp1 = fst (last s0)
   fxnp1 = snd (last s0)
   xr = x0 + nmAlpha * (x0 - xnp1)
   fxr = f xr
   fx1 = snd $ head s0
   snext = if fx1 <= fxr && fxr <= (snd $ secondLast s0)
              then replaceLast s0 (xr,fxr)
              else sexpand
   xe = x0 + nmGamma * (x0-xnp1)
   fxe = f xe
   sexpand = if fxr > fx1
                then scontract
                else if fxe < fxr
                        then replaceLast s0 (xe,fxe)
                        else replaceLast s0 (xr,fxr)
   xc = xnp1 + scale nmRho  (x0-xnp1)
   fxc = f xc
   scontract = if fxc < fxnp1
                  then replaceLast s0 (xc,fxc)
                  else sreduce
   sreduce = case s0 of
              p0@(x1,_):rest -> p0 : (flip map rest $ \(xi,_) -> with f $ x1+ scale nmRho (xi-x1))

with f x = (x, f x)


{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeApplications           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE UndecidableInstances       #-}

{-
A lot of error handling needs to be added to the code. For example
0 < hopsize < windowsize < fftsize needs to be reinforced.
-}

module Lib.STFT where

import qualified Data.Complex                  as C
import           Data.Proxy
import           Data.Type.Equality
import qualified Data.Vector                   as V
import           GHC.TypeNats
import           Numeric.FFT.Vector.Invertible

-- A small number
epsilon :: Double
epsilon = 2.2204460492503131e-16

-- |The magnitude spectrum of a signal
newtype MagnitudeSpectrum = MkMag (V.Vector Double) deriving Show

-- |The phase spectrum of a signal
newtype PhaseSpectrum = MkPhase (V.Vector Double) deriving Show

-- |Tuple of magnitude and phase Spectrum
newtype Spectrums = MkSpect (MagnitudeSpectrum, PhaseSpectrum) deriving Show

-- |A complex signal
newtype Signal = MkSignal (V.Vector (C.Complex Double))

-- |A Window
newtype WindowFn n = Window { runWindow :: Winsz n -> V.Vector (C.Complex Double) }

type family IsPo2 (m :: Nat) :: Bool where
  IsPo2 n = 2 ^ Log2 n == n

data FFTsz n where
  MkFFTsz :: (KnownNat n, IsPo2 n ~ 'True) => Proxy n -> FFTsz n

data Winsz n where
  MkWinsz :: KnownNat n => Proxy n -> Winsz n

data Hopsz n where
  MkHopsz :: KnownNat n => Proxy n -> Hopsz n

data Config h w f where
  MkConfig :: forall h w f. (KnownNat f, KnownNat w, KnownNat h, h <= w, w <= f) => Hopsz h -> Winsz w -> FFTsz f -> Config h w f

config :: Config 256 2048 2048
config = MkConfig hop win fft where
  hop = (MkHopsz (Proxy @256))
  win = (MkWinsz (Proxy @2048))
  fft = (MkFFTsz (Proxy @2048))

hamming :: forall n. KnownNat n => WindowFn n
hamming = Window $ \(MkWinsz _) -> V.generate size goHamm
  where
    size = fromIntegral $ natVal (Proxy @n) :: Int
    goHamm :: Int -> C.Complex Double
    goHamm i = (C.:+ 0) $ 0.54 - 0.46 * cos (2 * pi * fromIntegral i / (fromIntegral size - 1))

-- |Phase unwrapping algorithm. Converting to and from list for pattern matching is a little cumbersome.
unwrapPhase :: PhaseSpectrum -> PhaseSpectrum
unwrapPhase (MkPhase xs) = MkPhase $ V.fromList $ (diff (V.toList xs) 0)
  where
    diff (x:y:ys) accm
      | (y+accm) - x > pi    = x: diff (y + accm - (2 * pi):ys) (accm-(2*pi))
      | (y+accm) - x < (-pi) = x: diff (y+accm+(2*pi):ys) (accm+(2*pi))
      | otherwise             = x: diff (y+accm:ys) accm
    diff [x] _     = [x]
    diff []  _     = []

halfInt, halfIntPlus :: Int -> Int
halfIntPlus win = (win + 1) `div` 2
halfInt win = win `div` 2

-- |Takes a complex signal and fftsz performs the zero phase windowing
-- https://ccrma.stanford.edu/~jos/sasp/Zero_Phase_Zero_Padding.html
zeroPhaseZeroPad :: forall n. KnownNat n => FFTsz n -> Signal -> Signal
zeroPhaseZeroPad _ (MkSignal sig) = MkSignal $ positive V.++ zeros V.++ negative
  where
    fftsz = fromIntegral $ natVal (Proxy @n)
    win = V.length sig
    halfSig = halfInt win
    halfSigPlus = halfIntPlus win
    positive = V.slice halfSig halfSigPlus sig
    negative = V.slice 0 halfSig sig
    zeros = V.replicate (fftsz - halfSig - halfSigPlus) (0 C.:+ 0)

nearZero :: Double -> Bool
nearZero a = abs a <= 1e-12

-- |Calculates the magnitude spectrum in Db
magSpect :: Signal -> MagnitudeSpectrum
magSpect (MkSignal sig) = MkMag $ V.map (dB. near0 . C.magnitude) sig
  where
    dB x = 20 * logBase 10 x
    near0 x = if nearZero x then epsilon else x

-- |Calculates the phase spectrum
phaseSpect :: Signal -> PhaseSpectrum
phaseSpect (MkSignal vec) = unwrapPhase $ MkPhase $ V.map (C.phase . to0) vec
  where
    to0 x = go (C.realPart x) (C.imagPart x)
    go x y | nearZero x && nearZero y = 0 C.:+ 0
           | nearZero x               = 0 C.:+ y
           | nearZero y               = x C.:+ 0
           | otherwise                = x C.:+ y

-- | Takes a windowed signal and FFT size returns a the
-- magnitude and phase spectrums. Magnitude in Db, phase unwrapped,
-- both positive halfs of the spectrums
dftAnal :: forall n. KnownNat n => FFTsz n -> Signal -> Spectrums
dftAnal fftsz sig = MkSpect (magSpect trsf, phaseSpect trsf)
  where
      (MkSignal inputVec) = zeroPhaseZeroPad fftsz sig
      -- ^Positive spectrum includes sample 0
      positiveSpect = ((fromIntegral $ natVal (Proxy @n)) `div` 2) + 1
      trsf = MkSignal $ V.slice 0 positiveSpect (run dft inputVec)

-- | Splits the vector into chunks of size n that are
-- m distance apart. Static check that chunksize is larger than hop sz.
divvy :: forall n m a. (KnownNat n, KnownNat m) => Winsz n
      -> Hopsz m -> V.Vector a -> [V.Vector a]
divvy _ _ = go n' m'
  where
    n' = fromIntegral $ natVal (Proxy :: Proxy n)
    m' = fromIntegral $ natVal (Proxy :: Proxy m)

    go :: Int -> Int -> V.Vector a -> [V.Vector a]
    go x y vec
      | V.length vec <= x = []
      | otherwise = V.take x vec : go x y (V.drop y vec)

normalize :: Fractional a => V.Vector a -> V.Vector a
normalize win = fmap (/ V.foldl1' (+) win) win

-- | Takes an input signal, a window, an fftsize and a hop size and
-- computes the short time Fourier transform, returning a list of
-- magnitude and phase spectrums.
stft :: forall h w f. (KnownNat h, KnownNat w, KnownNat f) => Config h w f -> Signal
     -> [Spectrums]
stft (MkConfig hopsz winsz fftsz) (MkSignal sig) = fmap winDFT splitSig
  where
    win = runWindow hamming winsz
    halfWindow = floor (fromIntegral (natVal (Proxy @w)) / 2 :: Double)
    zs = V.replicate halfWindow (0 C.:+ 0)
    sigzs = zs V.++ sig V.++ zs
    splitSig = divvy winsz hopsz sigzs

    winDFT :: V.Vector (C.Complex Double) -> Spectrums
    winDFT vec = dftAnal fftsz (MkSignal $ V.zipWith (*) vec (normalize win))

-- Takes a tuple of vectors (Magnitude, Phase) and a window size
-- and returns the original signal
dftSynth :: forall n. KnownNat n => Winsz n
         -> Spectrums -> V.Vector (C.Complex Double)
dftSynth _ (MkSpect (MkMag magVec, MkPhase phaseVec)) =
  let win = fromIntegral $ natVal (Proxy @n)
      hwin = halfInt win
      hwinp = halfIntPlus win
      vec = V.zipWith (\x y -> (x, y)) magVec phaseVec
      posFreqs = fmap f vec where
        f (mag, phase) = (10**(mag/20) C.:+ 0) *
                         exp ((phase C.:+ 0) *
                         (0 C.:+ 1))
      negFreqs = (fmap f . V.reverse) (g vec) where
        g = (V.init . V.tail)
        f (mag, phase) = (10**(mag/20) C.:+ 0) *
                         exp ((phase C.:+ 0) *
                         (0 C.:+ (-1)))
      resultidft = run idft (posFreqs V.++ negFreqs)
  in V.slice (V.length resultidft - hwin)
                    hwin resultidft V.++ V.take hwinp resultidft

stftSynth :: forall h w. (KnownNat h, KnownNat w) => [Spectrums]
          -> Hopsz h -> Winsz w -> Signal
stftSynth magphase _ winsz =
  let hwinp = halfIntPlus $ fromIntegral $ natVal (Proxy @w)
      signalFrames = fmap (fmap (fromIntegral (natVal (Proxy @h)) * ) . dftSynth winsz ) magphase
      signalTuples = fmap (V.splitAt hwinp) signalFrames
      overlapAdd (x1, x2) (y1, y2) = (x1 V.++ V.zipWith (+) x2 y1, y2)
   in MkSignal $ V.drop hwinp $ fst (foldl overlapAdd (Prelude.head signalTuples) (Prelude.tail signalTuples))


import Control.Monad (liftM)
import Control.Parallel
import Data.Binary.Get (runGet)
import Graphics.Rendering.Cairo hiding (Matrix)
import Numeric.LinearAlgebra
import System.Random (mkStdGen, randoms)
import qualified Data.ByteString.Lazy as BS
import Gradient
import BinaryExtras
import RandomExtras
import Types
import Unsafe.Coerce
import GHC.Float
import Data.Binary.Get
import Data.Int
import Data.Word

opts = morrowind

main = do
  contents <- BS.readFile $ inputFile opts
  let arr0 = runGet (getManyF (rawFunction opts) $ imageWidth opts*imageHeight opts) contents
  let landscape = (imageHeight opts><imageWidth opts) $ arr0
--  landscape <- liftM ((imageHeight opts><imageWidth opts) . runGet (getAll $ imageWidth opts*imageHeight opts)) $ BS.readFile $ inputFile opts
  let jitter = randoms $ mkStdGen 53
  let [miny, maxy, minx, maxx] = map fromIntegral [1, imageHeight opts-2, 1, imageWidth opts-2]
  let (numpointsy, numpointsx) = (floor $ (maxy-miny)/(gridWidth opts), floor $ (maxx-minx)/(gridWidth opts))
  let regulargrid = [(y,x) | y <- [0..numpointsy-1], x<-[0..numpointsx-1]]
  let jitteredgrid = zipWith (\(y,x) (jy,jx) ->
        ( miny + (gridWidth opts)* (fromIntegral y + jy)
        , minx + (gridWidth opts) * (fromIntegral x + jx)
        )) regulargrid jitter
  let ascents = map (gradientStepper Ascent (ascentDelta opts) landscape) jitteredgrid
  s <- createImageSurface FormatARGB32
    (floor $ multiplier opts * (fromIntegral $ imageWidth opts))
    (floor $ multiplier opts * (fromIntegral $ imageHeight opts))
  renderWith s $ do
    setSourceRGBA 1 1 1 0.0
    paint
  mapM_ (drawLine (lineWidth opts) (cellWidth opts) (multiplier opts) s) ascents
  surfaceWriteToPNG s $ outputFile opts

drawLine line cell mult s lista = do
  renderWith s $ do
    setLineWidth line
    setLineCap LineCapRound
    go lista
  where
  go ((x1,y1,z1):loput@((x2,y2,z2):_)) = do
    let c = 1.0 - ((atan2 (abs(z1-z2)) cell)/(pi/2)) in setSourceRGB c c c
    moveTo (x1*mult) (y1*mult)
    lineTo (x2*mult) (y2*mult)
    stroke
    go loput
  go _ = return ()

-- Example usage

morrowind = Options
  { inputFile = "tesannwyn.raw"
  , imageWidth = 2688
  , imageHeight = 2816
  , gridWidth = 2.5
  , multiplier = 1.0
  , ascentDelta = 1.0
  , outputFile = "vv.png"
  , lineWidth = 0.35
  , cellWidth = 8.0
  , rawFunction = liftM ((fromIntegral :: Int16 -> Double) . (fromIntegral :: Word16 -> Int16)) getWord16le
  }

oblivion = Options
  { inputFile = "oblivion.raw"
  , imageWidth = 4288
  , imageHeight = 4128
  , gridWidth = 5
  , multiplier = 1.0
  , ascentDelta = 2.0
  , outputFile = "obl.png"
  , lineWidth = 0.5
  , cellWidth = 8.0
  , rawFunction = liftM ((fromIntegral :: Int16 -> Double) . (fromIntegral :: Word16 -> Int16)) getWord16le
  }

seworld = Options
  { inputFile = "seworld.raw"
  , imageWidth = 2048
  , imageHeight = 2048
  , gridWidth = 2.5
  , multiplier = 1.0
  , ascentDelta = 1.0
  , outputFile = "se.png"
  , lineWidth = 0.3
  , cellWidth = 8.0
  , rawFunction = liftM ((fromIntegral :: Int16 -> Double) . (fromIntegral :: Word16 -> Int16)) getWord16le
  }

mokki = Options
  { inputFile = "2mdem.flt"
  , imageWidth = 1857
  , imageHeight = 2136
  , gridWidth = 12.5
  , multiplier = 1.5
  , ascentDelta = 2.0
  , outputFile = "mok.png"
  , lineWidth = 0.5
  , cellWidth = 0.125
  , rawFunction = liftM (float2Double . unsafeCoerce) getWord32le
  }

turku = Options
  { inputFile = "pohja"
  , imageWidth = 513
  , imageHeight = 513
  , gridWidth = 1.25
  , multiplier = 2
  , ascentDelta = 1.0
  , outputFile = "turku.png"
  , lineWidth = 0.5
  , cellWidth = 8
  , rawFunction = liftM ((fromIntegral :: Int16 -> Double) . (fromIntegral :: Word16 -> Int16)) getWord16le
  }


module Parser where

import Data.Ratio
import Data.Complex

import Number
import LispData
import Text.ParserCombinators.Parsec hiding (spaces)
import Text.Parsec.Number

import LispData
--TODO Learn monads again and check what mapM is doing

-- Recognizes if a character is a valid scheme symbol
symbol :: Parser Char
symbol = oneOf "-.!#$%&|*+/:<=>?@^_~"
-- Skips one or more spaces
spaces1 :: Parser ()
spaces1 = skipMany1 space

escapedChars :: Parser Char
escapedChars = do
  _ <- char '\\'
  x <- oneOf "\"tn\\"
  case x of
    't' -> return '\t'
    'n' -> return '\n'
    'r' -> return '\r'
    '\\' -> return '\\'
    _ -> return x

-- Parses a string which starts with a " and ends with a"
-- TODO \\t \\n \\r \\ \"
parseString :: Parser LispVal
parseString = do
  _ <- char '"' --Starts with a "
  -- Stops at "
  x <- many $ escapedChars <|> noneOf "\""
  _ <- char '"' --ends with a "
  return $ String x

-- Parses a symbol
parseAtom :: Parser LispVal
parseAtom = do
  first <- (letter <|> symbol) <?> "I HATE PARSEC"
  --first <- choice symlpars
  --the following chars must be one of letter, digit or symbol
  rest <-  many (letter <|> digit <|> symbol)
  let atom = first :rest
  --catch special atoms
  case atom of "#t" -> return $ Bool True
               "#f" -> return $ Bool False
               ('-':x:_)   -> case x of
                   ' ' -> return $ Atom atom
                   _   -> parseNumber
                             --return $ (LispNumber . Integer . read) atom --TODO THIS IS NOT GOOD, try to parse -3o
               _    -> {-trace ("attom"++ show atom)-} (return $ Atom atom)

parseComplex :: Parser LispVal
parseComplex = do
  f <- parseNumber
  s <- char '+'
  n <- parseNumber
  i <- char 'i'
  let x = case f of
        ((LispNumber (Integer n))) -> (fromIntegral n :: Double)
        ((LispNumber (Rational n))) -> (realToFrac n)
        ((LispNumber (Real n))) -> n
        _ -> 0

  let y = case n of
        ((LispNumber (Integer p))) -> (fromIntegral p :: Double)
        ((LispNumber (Rational p))) -> (realToFrac p)
        ((LispNumber (Real p))) -> p
        _ -> 0
  return $ (LispNumber . Complex) (x :+ y)

parseNegFloat :: Parser LispVal
parseNegFloat = do
  s <-  sign
  beforeDot <- int
  _ <- char '.' <?> "Floating Point Parse Error: expecting ."
  afterDot <- int
  let d = s (read (show beforeDot ++ "." ++ (show afterDot)))
  return $ (LispNumber . Real) d

parseNegRational :: Parser LispVal
parseNegRational = do
  top <- int
  _ <- char '/'
  bottom <- int
  return $ (LispNumber . Rational) (top % bottom)

parseInteger :: Parser LispVal
parseInteger =  do
  int' <- many1 digit
  return $ (LispNumber . Integer . read) int'

parseNegInteger :: Parser LispVal
parseNegInteger =  do
  _ <-  char '-'
  int' <- many1 digit
  return $ (LispNumber . Integer . negate . read) int'

parseVector :: Parser LispVal
parseVector = do
  _ <- char '('
  vec <- sepBy parseExpr spaces1
  _ <- char ')'
  return $ Vector vec

parseList :: Parser LispVal
-- Parse lispExpr which hare seperated by one or more whitespace
parseList = List <$> sepBy parseExpr spaces1

parseDottedList :: Parser LispVal
parseDottedList = do
    -- what?
    head' <- endBy parseExpr spaces1
    -- parses a dot then exactly one space and saves the expression after the space
    tail' <- char '.' >> spaces1 >> parseExpr
    return $ DottedList head' tail'

-- TODO READ r5rs
parseQuoted :: Parser LispVal
parseQuoted = do
    _ <- char '\''
    x <- parseExpr
    return $ List [Atom "quote", x]

parseNumber = try parseNegFloat
              <|> try parseNegRational
              <|> try parseNegInteger --TODO WENN MIR WAS UM DIE OHREN FLIEGT LIEGTS HIER DRAN
              <|> parseInteger -- etc

parseExpr :: Parser LispVal
parseExpr = try parseAtom --first try to parse a atom
         <|> try parseComplex
         <|> parseNumber
         <|> parseString -- if this fails try to parse a string
         <|> parseQuoted
         <|> do _ <- char '('
                -- parses a normal list until it encounter a dot, at which point it will go back and sstart to parse
                -- a dotted list
                x <- try parseList <|> parseDottedList
                _ <- char ')'
                return x


{-# OPTIONS_GHC  -fno-warn-unused-binds -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-missing-signatures #-}
{-# LANGUAGE FlexibleInstances, ConstraintKinds, ExistentialQuantification, GADTs, RankNTypes, MultiParamTypeClasses   #-}
{-# LANGUAGE ImpredicativeTypes, RankNTypes, UndecidableInstances, FlexibleContexts, TypeSynonymInstances #-}

---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------
-- |
-- | Module : Count-Min Sketch
-- | Creator: Xiao Ling
-- | Created: 12/17/2015
-- |
---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

module CountMinSketch where

import Control.Monad.Random.Class
import Control.Monad.Random
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Identity

import Data.Matrix
import Data.Conduit
import qualified Data.Conduit.List as Cl
import qualified Data.Matrix as M

import Core
import Utils
import Statistics

{-----------------------------------------------------------------------------
  Types
------------------------------------------------------------------------------}

type W        = Int              -- * num cols
type D        = Int              -- * num rows
type P        = Int              -- * some prime   --> change this to Integer
type A        = Int              -- * coefficient a_j
type B        = Int              -- * coeeficient b_j
type Event    = Int              -- * some input event from
                                 -- * universe: {1, .., i, .. n}

type Sketch   = Matrix Int       -- * W x D matrix  of counters
type ABs      = Matrix Int       -- * 2 x D matrix  of a_j and b_j for j = 1..d
type Events   = Matrix Event     -- * 2 x D matrix of event i
type Hash     = Event -> ColIdx  -- * Maps event to d x 1 list of index to incr
type ColIdx   = [Int]            -- * indices of counters to increment

type Some m   = (MonadRandom m, MonadState (Sketch, Hash) m, MonadReader (D,W,P) m)

{-----------------------------------------------------------------------------
    Count Min Sketch
------------------------------------------------------------------------------}

{-----------------------------------------------------------------------------
    Helpers
------------------------------------------------------------------------------}

-- * initalize the sketch
sketch' :: D -> W -> Sketch
sketch' = zeros

-- * intialize random cofficients a_j, b_j, for d x 2 matrix:
-- * [ a_1 ... a_j ... a_d ]
-- * [ b_1 ... b_j ... b_d ]
ab' :: MonadRandom m => P -> D -> m ABs
ab' p d = (M.fromList 2 d . take (2*d)) <$> getRandomRs (1,p)

-- * h_j (i) = (a_j x i + b_j mod p) mod w
-- * sumRow-wise  [ a_1 ... a_j ... a_d ]  .*.  [ i_1 ...  i_d ]     mod p  mod w
-- *              [ b_1 ... b_j ... b_d ]       [ 1   ...  1   ]
-- * result:      [ idx_1, ..., idx_d   ]
-- *               where the indices start at 1
hash' :: P -> W -> D -> ABs -> Hash
hash' p w d ab = \i ->  go $ sumR (ab .*. is) ... (\v -> v `mod` p `mod` w)
    where go = fmap (+1) . toList
          is = is' d i

-- * map `i` <- event univese onto d x 2 matrix of form
-- * [ i_1 ... i_2 ]
-- * [ 1   ...  1  ]
is' :: D -> Event -> Events
is' d i = (i .+ (zeros 1 d)) <-> ones 1 d

-- * given hash function, construct a binary mask of size `w` x `d`
-- * to increment sketch
mask' :: W -> ColIdx -> Sketch
mask' w ks = let vec c w = zeros 1 (c-1) <|> single 1 <|> zeros 1 (w - c) in
    case ks of
        c:[] -> vec c w
        c:cs -> vec c w <-> mask' w cs

-- * given input i and some hash function `h`, and sketch `ms`,
-- * update `ms`
update' :: W -> D -> Hash -> Sketch -> Event -> Sketch
update' w d h ms i = mask' w (h i) .+. ms

maxi  = 30            :: Event
p     = 2^maxi - 1    :: P
(d,w) = (4,3)         :: (D,W)
i     = 12            :: Event

mab    = evalRandIO $ ab' p d
sketch = sketch' d w
mhashs = (hash' p w d)  <$> mab

update h i = update' w d h sketch i

mhash  = head <$> mhashs

--hs = hashF p w xs ys


{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module Simulation where

import AmpOp
    ( SignalState(..),
      State(TwoNodes),
      Output,
      Value,
      dc100,
      dc12,
      sen,
      ground,
      getSignalOutput,
      lm741,
      r1,
      r2,
      r3,
      r4,
      -- ampOpSpecial,
      ampOpBuffer,
      ampOpInverting,
      ampOpInvertingTest,
      ampOpInverting' )
import Circuit
import Signal
import Control.Monad.Fix
import Data.Complex

executeTimeSimulation :: SignalState -> (SignalState -> Either String (Circuit a SignalState)) -> Signal a -> [Metric] -> Either String [(Time, Value)]
executeTimeSimulation _ _ _ [] = Right []
executeTimeSimulation initialState buildCircuit input (t:ts) = buildCircuit initialState >>= \circuit -> do let result = circuit `simulate` input `at` t
                                                                                rest <- executeTimeSimulation result buildCircuit input ts
                                                                                Right $ (realPart t, realPart (getSignalOutput result `at` t)) : rest

executeTimeSimulation2 :: SignalState -> (SignalState -> Circuit a SignalState) -> Signal a -> [Metric] -> [(Metric, Output)]
executeTimeSimulation2 initialState buildCircuit input samples = fix calculate (initialState, [], samples)
    where calculate f (state, l, t:ts) = if null ts then next else f (newState, next, ts)
            where newState = buildCircuit state `simulate` input `at` t
                  next = l ++ [result]
                  result = (t, getSignalOutput newState `at` t)

iSignalState = SignalTwoNodes (dc100, ground)
iSignalState3 = SignalThreeNodes (dc100, dc100, dc100)
iSignalBuffer = SignalOneNode dc100
c0 = ampOpBuffer lm741
c1 = ampOpInverting lm741 r1 r2
c3 = ampOpInvertingTest lm741 r1 r2
-- cS = ampOpSpecial lm741 r1 r2 r3 r4

simulationSignal = executeTimeSimulation iSignalState c1 sen (map (:+ 0) [1..5])
simulationSignalTest = executeTimeSimulation2 iSignalState c3 sen (map (:+ 0) [1..5])
-- simulationSpecial = executeTimeSimulation iSignalState3 cS dc12 (map (:+ 0) [1])

iState = TwoNodes (100, 0)
c2 = ampOpInverting' lm741 r1 r2 12

simulation = c2 iState


module Numeric.FFT.Special.Primes
       ( special3, special5, special7, special11, special13 ) where

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

import           Numeric.FFT.Types

-- | Length 3 hard-coded FFT.
kp500000000, kp866025403 :: Double
kp866025403 = 0.866025403784438646763723170752936183471402627
kp500000000 = 0.500000000000000000000000000000000000000000000
special3 :: Int -> MVCD s -> MVCD s -> ST s ()
special3 sign xsin xsout = do
  xr0 :+ xi0 <- MV.unsafeRead xsin 0 ; xr1 :+ xi1 <- MV.unsafeRead xsin 1
  xr2 :+ xi2 <- MV.unsafeRead xsin 2
  let rp = xr1 + xr2 ; rm = xr1 - xr2
      ip = xi1 + xi2 ; im = xi1 - xi2
      tr = xr0 - kp500000000 * rp
      ti = xi0 - kp500000000 * ip
      r1 = (tr - kp866025403 * im) :+ (ti + kp866025403 * rm)
      r2 = (tr + kp866025403 * im) :+ (ti - kp866025403 * rm)
  MV.unsafeWrite xsout 0 $ (xr0 + rp) :+ (xi0 + ip)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r2
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r1

-- | Length 5 hard-coded FFT.
kp951056516, kp559016994, kp250000000, kp618033988 :: Double
kp951056516 = 0.951056516295153572116439333379382143405698634
kp559016994 = 0.559016994374947424102293417182819058860154590
kp250000000 = 0.250000000000000000000000000000000000000000000
kp618033988 = 0.618033988749894848204586834365638117720309180
special5 :: Int -> MVCD s -> MVCD s -> ST s ()
special5 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
  let ts = xr1 - xr4 ; t4 = xr1 + xr4 ; tt = xr2 - xr3 ; t7 = xr2 + xr3
      t8 = t4 + t7 ; ta = t4 - t7 ; te = xi1 - xi4 ; tm = xi1 + xi4
      tn = xi2 + xi3 ; th = xi2 - xi3 ; to = tm + tn ; tq = tm - tn
      ti = te + kp618033988 * th ; tk = th - kp618033988 * te
      t9 = xr0 - kp250000000 * t8 ; tu = ts + kp618033988 * tt
      tw = tt - kp618033988 * ts ; tp = xi0 - kp250000000 * to
      tb = t9 + kp559016994 * ta ; tj = t9 - kp559016994 * ta
      tr = tp + kp559016994 * tq ; tv = tp - kp559016994 * tq
      r4 = (tb + kp951056516 * ti) :+ (tr - kp951056516 * tu)
      r3 = (tj - kp951056516 * tk) :+ (tv + kp951056516 * tw)
      r2 = (tj + kp951056516 * tk) :+ (tv - kp951056516 * tw)
      r1 = (tb - kp951056516 * ti) :+ (tr + kp951056516 * tu)
  MV.unsafeWrite xsout 0 $ (xr0 + t8) :+ (xi0 + to)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r4
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r3
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r2
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r1

-- | Length 7 hard-coded FFT.
kp974927912, kp900968867, kp801937735 :: Double
kp692021471, kp356895867, kp554958132 :: Double
kp974927912 = 0.974927912181823607018131682993931217232785801
kp900968867 = 0.900968867902419126236102319507445051165919162
kp801937735 = 0.801937735804838252472204639014890102331838324
kp692021471 = 0.692021471630095869627814897002069140197260599
kp356895867 = 0.356895867892209443894399510021300583399127187
kp554958132 = 0.554958132087371191422194871006410481067288862
special7 :: Int -> MVCD s -> MVCD s -> ST s ()
special7 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
  let tI = xr6 - xr1 ; t4 = xr1 + xr6 ; tG = xr4 - xr3 ; ta = xr3 + xr4
      tT = tI + kp554958132 * tG ; tp = ta - kp356895867 * t4
      tH = xr5 - xr2 ; t7 = xr2 + xr5
      tJ = tH - kp554958132 * tI ; tO = tG + kp554958132 * tH
      tu = t7 - kp356895867 * ta ; tb = t4 - kp356895867 * t7
      tB = xi2 + xi5 ; tg = xi2 - xi5
      tC = xi3 + xi4 ; tm = xi3 - xi4 ; tA = xi1 + xi6 ; tj = xi1 - xi6
      tD = tB - kp356895867 * tC ; ts = tm + kp554958132 * tg
      tL = tC - kp356895867 * tA ; tQ = tA - kp356895867 * tB
      tx = tg - kp554958132 * tj ; tn = tj + kp554958132 * tm
      tc = ta - kp692021471 * tb ; tU = tH + kp801937735 * tT
      to = tg + kp801937735 * tn ; tR = tC - kp692021471 * tQ
      td = xr0 - kp900968867 * tc ; tt = tj - kp801937735 * ts
      tq = t7 - kp692021471 * tp ; tS = xi0 - kp900968867 * tR
      tr = xr0 - kp900968867 * tq ; tP = tI - kp801937735 * tO
      tM = tB - kp692021471 * tL ; ty = tm - kp801937735 * tx
      tv = t4 - kp692021471 * tu ; tK = tG - kp801937735 * tJ
      tN = xi0 - kp900968867 * tM ; tE = tA - kp692021471 * tD
      tw = xr0 - kp900968867 * tv ; tF = xi0 - kp900968867 * tE
      r6 = (td + kp974927912 * to) :+ (tS + kp974927912 * tU)
      r5 = (tr + kp974927912 * tt) :+ (tN + kp974927912 * tP)
      r4 = (tw + kp974927912 * ty) :+ (tF + kp974927912 * tK)
      r3 = (tw - kp974927912 * ty) :+ (tF - kp974927912 * tK)
      r2 = (tr - kp974927912 * tt) :+ (tN - kp974927912 * tP)
      r1 = (td - kp974927912 * to) :+ (tS - kp974927912 * tU)
  MV.unsafeWrite xsout 0 $ (xr0 + t4 + t7 + ta) :+ (xi0 + tA + tB + tC)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r6
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r5
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r4
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r3
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r2
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r1

-- | Length 11 hard-coded FFT.
kp989821441, kp959492973, kp918985947, kp876768831, kp830830026 :: Double
kp778434453, kp715370323, kp634356270, kp342584725, kp521108558 :: Double
kp989821441 = 0.989821441880932732376092037776718787376519372
kp959492973 = 0.959492973614497389890368057066327699062454848
kp918985947 = 0.918985947228994779780736114132655398124909697
kp876768831 = 0.876768831002589333891339807079336796764054852
kp830830026 = 0.830830026003772851058548298459246407048009821
kp778434453 = 0.778434453334651800608337670740821884709317477
kp715370323 = 0.715370323453429719112414662767260662417897278
kp634356270 = 0.634356270682424498893150776899916060542806975
kp342584725 = 0.342584725681637509502641509861112333758894680
kp521108558 = 0.521108558113202722944698153526659300680427422
special11 :: Int -> MVCD s -> MVCD s -> ST s ()
special11 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
  let t1u = xr10 - xr1 ; t4 = xr1 + xr10 ; t1q = xr6 - xr5 ; tg = xr5 + xr6;
      t1t = xr9 - xr2 ; t7 = xr2 + xr9 ; t1s = xr8 - xr3 ; ta = xr3 + xr8;
      t25 = t1u + kp521108558 * t1q ; t1W = t1q + kp521108558 * t1s
      tO = ta - kp342584725 * t4 ; th = t7 - kp342584725 * ta
      td = xr4 + xr7 ; t1r = xr7 - xr4
      tP = tg - kp634356270 * tO ; t1X = t1t - kp715370323 * t1W
      t26 = t1r + kp715370323 * t25 ; tF = t4 - kp342584725 * td
      ti = td - kp634356270 * th ; t1N = t1r - kp521108558 * t1t
      t1v = t1t - kp521108558 * t1u ; tG = t7 - kp634356270 * tF
      tX = tg - kp342584725 * t7 ; t1O = t1q + kp715370323 * t1N
      t1w = t1s - kp715370323 * t1v ; t1E = t1s + kp521108558 * t1r
      tY = t4 - kp634356270 * tX ; t16 = td - kp342584725 * tg
      t1F = t1u + kp715370323 * t1E ; t17 = ta - kp634356270 * t16
      to = xi3 - xi8 ; t1i = xi3 + xi8 ; t1k = xi5 + xi6 ; tA = xi5 - xi6
      t1h = xi2 + xi9 ; tr = xi2 - xi9 ; t1j = xi4 + xi7 ; tu = xi4 - xi7
      t20 = t1h - kp342584725 * t1i ; tK = tA + kp521108558 * to
      tT = tu - kp521108558 * tr ; t1g = xi1 + xi10 ; tx = xi1 - xi10
      t21 = t1j - kp634356270 * t20 ; tU = tA + kp715370323 * tT
      tL = tr - kp715370323 * tK ; tB = tx + kp521108558 * tA
      t1R = t1g - kp342584725 * t1j ; t1I = t1i - kp342584725 * t1g
      t1l = t1j - kp342584725 * t1k ; tC = tu + kp715370323 * tB
      t1S = t1h - kp634356270 * t1R ; t1J = t1k - kp634356270 * t1I
      t1m = t1i - kp634356270 * t1l ; t12 = to + kp521108558 * tu
      t1z = t1k - kp342584725 * t1h ; t1b = tr - kp521108558 * tx
      t13 = tx + kp715370323 * t12 ; t1A = t1g - kp634356270 * t1z
      t1c = to - kp715370323 * t1b ; tj = t4 - kp778434453 * ti
      tD = tr + kp830830026 * tC ; t22 = t1g - kp778434453 * t21
      t27 = t1t + kp830830026 * t26 ; tk = tg - kp876768831 * tj
      tE = to + kp918985947 * tD ; t23 = t1k - kp876768831 * t22
      t28 = t1s + kp918985947 * t27 ; tl = xr0 - kp959492973 * tk
      t1T = t1k - kp778434453 * t1S ; t24 = xi0 - kp959492973 * t23
      t1Y = t1u + kp830830026 * t1X ; t1U = t1i - kp876768831 * t1T
      t1Z = t1r - kp918985947 * t1Y ; t1V = xi0 - kp959492973 * t1U
      tH = tg - kp778434453 * tG ; tM = tx + kp830830026 * tL
      tQ = td - kp778434453 * tP ; tI = ta - kp876768831 * tH
      tN = tu - kp918985947 * tM ; tR = t7 - kp876768831 * tQ
      tV = to - kp830830026 * tU ; tJ = xr0 - kp959492973 * tI
      t1K = t1j - kp778434453 * t1J ; tS = xr0 - kp959492973 * tR
      tW = tx - kp918985947 * tV ; t1L = t1h - kp876768831 * t1K
      t1P = t1s - kp830830026 * t1O ; t1M = xi0 - kp959492973 * t1L
      tZ = ta - kp778434453 * tY ; t14 = tA - kp830830026 * t13
      t1Q = t1u - kp918985947 * t1P ; t1B = t1i - kp778434453 * t1A
      t10 = td - kp876768831 * tZ ; t15 = tr + kp918985947 * t14
      t11 = xr0 - kp959492973 * t10 ; t1C = t1j - kp876768831 * t1B
      t1G = t1q - kp830830026 * t1F ; t1n = t1h - kp778434453 * t1m
      t1D = xi0 - kp959492973 * t1C ; t1H = t1t + kp918985947 * t1G
      t1o = t1g - kp876768831 * t1n ; t1x = t1r - kp830830026 * t1w
      t18 = t7 - kp778434453 * t17 ; t1p = xi0 - kp959492973 * t1o
      t1y = t1q - kp918985947 * t1x ; t19 = t4 - kp876768831 * t18
      t1d = tu - kp830830026 * t1c ; t1a = xr0 - kp959492973 * t19
      t1e = tA - kp918985947 * t1d
      r10 = (tl + kp989821441 * tE) :+ (t24 + kp989821441 * t28)
      r9 = (tJ - kp989821441 * tN) :+ (t1V - kp989821441 * t1Z)
      r8 = (tS + kp989821441 * tW) :+ (t1M + kp989821441 * t1Q)
      r7 = (t11 - kp989821441 * t15) :+ (t1D - kp989821441 * t1H)
      r6 = (t1a + kp989821441 * t1e) :+ (t1p + kp989821441 * t1y)
      r5 = (t1a - kp989821441 * t1e) :+ (t1p - kp989821441 * t1y)
      r4 = (t11 + kp989821441 * t15) :+ (t1D + kp989821441 * t1H)
      r3 = (tS - kp989821441 * tW) :+ (t1M - kp989821441 * t1Q)
      r2 = (tJ + kp989821441 * tN) :+ (t1V + kp989821441 * t1Z)
      r1 = (tl - kp989821441 * tE) :+ (t24 - kp989821441 * t28)
  MV.unsafeWrite xsout 0 $ (xr0+t4+t7+ta+td+tg) :+ (xi0+t1g+t1h+t1i+t1j+t1k)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r10
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r9
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r8
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r7
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r6
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r5
  MV.unsafeWrite xsout 7 $ if sign == 1 then r7 else r4
  MV.unsafeWrite xsout 8 $ if sign == 1 then r8 else r3
  MV.unsafeWrite xsout 9 $ if sign == 1 then r9 else r2
  MV.unsafeWrite xsout 10 $ if sign == 1 then r10 else r1

-- | Length 13 hard-coded FFT.
kp875502302, kp520028571, kp575140729 :: Double
kp600477271, kp300462606, kp516520780 :: Double
kp968287244, kp503537032, kp251768516 :: Double
kp581704778, kp859542535, kp083333333 :: Double
kp957805992, kp522026385, kp853480001 :: Double
kp769338817, kp612264650, kp038632954 :: Double
kp302775637, kp514918778, kp686558370 :: Double
kp226109445, kp301479260 :: Double
--kp866025403, kp500000000 :: Double
kp875502302 = 0.875502302409147941146295545768755143177842006
kp520028571 = 0.520028571888864619117130500499232802493238139
kp575140729 = 0.575140729474003121368385547455453388461001608
kp600477271 = 0.600477271932665282925769253334763009352012849
kp300462606 = 0.300462606288665774426601772289207995520941381
kp516520780 = 0.516520780623489722840901288569017135705033622
kp968287244 = 0.968287244361984016049539446938120421179794516
kp503537032 = 0.503537032863766627246873853868466977093348562
kp251768516 = 0.251768516431883313623436926934233488546674281
kp581704778 = 0.581704778510515730456870384989698884939833902
kp859542535 = 0.859542535098774820163672132761689612766401925
kp083333333 = 0.083333333333333333333333333333333333333333333
kp957805992 = 0.957805992594665126462521754605754580515587217
kp522026385 = 0.522026385161275033714027226654165028300441940
kp853480001 = 0.853480001859823990758994934970528322872359049
kp769338817 = 0.769338817572980603471413688209101117038278899
kp612264650 = 0.612264650376756543746494474777125408779395514
kp038632954 = 0.038632954644348171955506895830342264440241080
kp302775637 = 0.302775637731994646559610633735247973125648287
kp514918778 = 0.514918778086315755491789696138117261566051239
kp686558370 = 0.686558370781754340655719594850823015421401653
kp226109445 = 0.226109445035782405468510155372505010481906348
kp301479260 = 0.301479260047709873958013540496673347309208464
--kp866025403 = 0.866025403784438646763723170752936183471402627
--kp500000000 = 0.500000000000000000000000000000000000000000000
special13 :: Int -> MVCD s -> MVCD s -> ST s ()
special13 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
  let t2d = xr8 - xr5 ; tf = xr8 + xr5 ; ta = xr10 + xr4 ; tq = xr10 - xr4
      ty = kp500000000 * ta - xr12
      tb = xr12 + ta ; tr = xr9 - xr3 ; t5 = xr3 + xr9 ; t6 = xr1 + t5
      tx = xr1 - kp500000000 * t5
      ti = xr11 + xr6 ; tt = xr11 - xr6 ; tu = xr7 - xr2 ; tl = xr7 + xr2
      tc = t6 + tb ; t2n = t6 - tb ; t2b = ti - tl ; tm = ti + tl
      t2e = tt + tu ; tv = tt - tu ; ts = tq - tr ; t2g = tr + tq
      tz = tx - ty ; t2a = tx + ty
      tA = tf - kp500000000 * tm
      tn = tf + tm
      t2f = t2d - kp500000000 * t2e
      t2o = t2d + t2e ; to = tc + tn ; tH = tc - tn
      t2h = t2f + kp866025403 * t2g ; t2k = t2f - kp866025403 * t2g
      tE = tz - tA ; tB = tz + tA ; tF = ts - tv ; tw = ts + tv
      t2j = t2a - kp866025403 * t2b ; t2c = t2a + kp866025403 * t2b
      t1R = xi8 + xi5 ; tM = xi8 - xi5 ; t17 = xi10 + xi4 ; t10 = xi10 - xi4
      t18 = kp500000000 * t17 - xi12
      t1l = xi12 + t17 ; tX = xi9 - xi3 ; t14 = xi3 + xi9 ; t1k = xi1 + t14
      t15 = xi1 - kp500000000 * t14
      tP = xi11 - xi6 ; t1a = xi11 + xi6 ; t1b = xi7 + xi2 ; tS = xi7 - xi2
      t1Q = t1k + t1l ; t1m = t1k - t1l ; t11 = tX + t10 ; t1W = t10 - tX
      t1X = tP - tS ; tT = tP + tS ; t1S = t1a + t1b ; t1c = t1a - t1b
      t19 = t15 + t18 ; t1Z = t15 - t18 ; t1j = tM + tT
      tU = tM - kp500000000 * tT
      t1T = t1R + t1S
      t20 = t1R - kp500000000 * t1S ; t12 = tU + kp866025403 * t11
      t1f = tU - kp866025403 * t11
      t21 = t1Z + t20 ; t24 = t1Z - t20 ; t27 = t1Q - t1T ; t1U = t1Q + t1T
      t1g = t19 - kp866025403 * t1c ; t1d = t19 + kp866025403 * t1c
      t25 = t1W - t1X ; t1Y = t1W + t1X
      tC = tw + kp301479260 * tB ; t1x = tB - kp226109445 * tw
      t1y = tF + kp686558370 * tE ; tG = tE - kp514918778 * tF
      t1n = t1j - kp302775637 * t1m ; t1G = t1m + kp302775637 * t1j
      t1u = t1d - kp038632954 * t12 ; t1e = t12 + kp038632954 * t1d
      t1h = t1f + kp612264650 * t1g ; t1v = t1g - kp612264650 * t1f
      t1J = t1x + kp769338817 * t1y ; t1z = t1x - kp769338817 * t1y
      t1H = t1u - kp853480001 * t1v ; t1w = t1u + kp853480001 * t1v
      t1I = t1G - kp522026385 * t1H ; t1O = t1H + kp957805992 * t1G
      tp = xr0 - kp083333333 * to ; t1E = t1e + kp853480001 * t1h
      t1i = t1e - kp853480001 * t1h ; t1q = tH - kp859542535 * tG
      tI = tG + kp581704778 * tH ; t1o = t1i + kp957805992 * t1n
      t1s = t1n - kp522026385 * t1i ; t1p = tp - kp251768516 * tC
      tD = tp + kp503537032 * tC ; t1C = t1w - kp968287244 * t1z
      t1A = t1w + kp968287244 * t1z ; tJ = tD + kp516520780 * tI
      t1N = tD - kp516520780 * tI ; t1D = t1p - kp300462606 * t1q
      t1r = t1p + kp300462606 * t1q ; t1t = t1r - kp575140729 * t1s
      t1B = t1r + kp575140729 * t1s ; t1L = t1D - kp520028571 * t1E
      t1F = t1D + kp520028571 * t1E ; t1K = t1I + kp875502302 * t1J
      t1M = t1I - kp875502302 * t1J ; t2D = t21 - kp226109445 * t1Y
      t22 = t1Y + kp301479260 * t21 ; t26 = t24 - kp514918778 * t25
      t2E = t25 + kp686558370 * t24 ; t2v = t2o - kp302775637 * t2n
      t2p = t2n + kp302775637 * t2o ; t2i = t2c - kp038632954 * t2h
      t2s = t2h + kp038632954 * t2c ; t2t = t2k + kp612264650 * t2j
      t2l = t2j - kp612264650 * t2k ; t2F = t2D - kp769338817 * t2E
      t2N = t2D + kp769338817 * t2E ; t2K = t2s + kp853480001 * t2t
      t2u = t2s - kp853480001 * t2t ; t2w = t2u + kp957805992 * t2v
      t2A = t2v - kp522026385 * t2u ; t1V = xi0 - kp083333333 * t1U
      t2m = t2i - kp853480001 * t2l ; t2C = t2i + kp853480001 * t2l
      t28 = t26 + kp581704778 * t27 ; t2y = t27 - kp859542535 * t26
      t2M = t2p - kp522026385 * t2m ; t2q = t2m + kp957805992 * t2p
      t23 = t1V + kp503537032 * t22 ; t2x = t1V - kp251768516 * t22
      t2O = t2M - kp875502302 * t2N ; t2Q = t2M + kp875502302 * t2N
      t2r = t23 + kp516520780 * t28 ; t29 = t23 - kp516520780 * t28
      t2z = t2x + kp300462606 * t2y ; t2J = t2x - kp300462606 * t2y
      t2P = t2J + kp520028571 * t2K ; t2L = t2J - kp520028571 * t2K
      t2B = t2z + kp575140729 * t2A ; t2H = t2z - kp575140729 * t2A
      t2I = t2C + kp968287244 * t2F ; t2G = t2C - kp968287244 * t2F
      r12 = (tJ - kp600477271 * t1o) :+ (t2r + kp600477271 * t2w)
      r11 =  (t1F + kp575140729 * t1K) :+ (t2L - kp575140729 * t2O)
      r10 = (t1t + kp520028571 * t1A) :+ (t2B - kp520028571 * t2G)
      r9 = (t1B + kp520028571 * t1C) :+ (t2H - kp520028571 * t2I)
      r8 = (t1N + kp600477271 * t1O) :+ (t29 - kp600477271 * t2q)
      r7 = (t1L + kp575140729 * t1M) :+ (t2P - kp575140729 * t2Q)
      r6 = (t1F - kp575140729 * t1K) :+ (t2L + kp575140729 * t2O)
      r5 = (t1N - kp600477271 * t1O) :+ (t29 + kp600477271 * t2q)
      r4 = (t1t - kp520028571 * t1A) :+ (t2B + kp520028571 * t2G)
      r3 = (t1B - kp520028571 * t1C) :+ (t2H + kp520028571 * t2I)
      r2 = (t1L - kp575140729 * t1M) :+ (t2P + kp575140729 * t2Q)
      r1 = (tJ + kp600477271 * t1o) :+ (t2r - kp600477271 * t2w)
  MV.unsafeWrite xsout 0 $ (xr0 + to) :+ (xi0 + t1U)
  MV.unsafeWrite xsout 1 $ if sign == 1 then r1 else r12
  MV.unsafeWrite xsout 2 $ if sign == 1 then r2 else r11
  MV.unsafeWrite xsout 3 $ if sign == 1 then r3 else r10
  MV.unsafeWrite xsout 4 $ if sign == 1 then r4 else r9
  MV.unsafeWrite xsout 5 $ if sign == 1 then r5 else r8
  MV.unsafeWrite xsout 6 $ if sign == 1 then r6 else r7
  MV.unsafeWrite xsout 7 $ if sign == 1 then r7 else r6
  MV.unsafeWrite xsout 8 $ if sign == 1 then r8 else r5
  MV.unsafeWrite xsout 9 $ if sign == 1 then r9 else r4
  MV.unsafeWrite xsout 10 $ if sign == 1 then r10 else r3
  MV.unsafeWrite xsout 11 $ if sign == 1 then r11 else r2
  MV.unsafeWrite xsout 12 $ if sign == 1 then r12 else r1