{-# 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 : Test approx median
-- | Creator: Xiao Ling
-- | Created: 12/14/2015
-- | see    : http://www.serpentine.com/criterion/tutorial.html
-- |
---------------------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

module TapproxMedian where

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

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

import Core
import Statistics
import ApproxMedian

{-----------------------------------------------------------------------------
  Benchmark  counter vs counter'
------------------------------------------------------------------------------}

main :: IO ()
main = return ()


{-# LANGUAGE TypeOperators, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables, ImplicitParams, PackageImports, ViewPatterns #-}
module Target.Heston where

import Target.Prelude
import qualified Data.Record as R
import Prelude hiding (scanl,repeat,replicate)
import Data.Record.Combinators ((!!!))
import Data.Kind
import Data.List (transpose)
import Data.TypeFun
import Numeric.LinearAlgebra hiding (diag, linspace, svd, )
import Math.Probably.Sampler hiding (uniform,primOneOf,logNormal,invGamma,binomial,gamma,oneOf,bernoulli, normal, unit, unormal,multiNormal)
import qualified Data.Text as T
import Foreign.Storable (Storable)
import Data.STRef
import Control.Monad.ST
import Control.Monad (forM, forM_)
import qualified Data.Vector.Storable.Mutable as VSM
import qualified Data.Vector.Storable as VS
import Foreign.Storable.Tuple

(.==.) :: (Eq a) => (a -> ((a -> Double)))
(.==.) = \((x::a)) -> \((y::a)) -> if (x==y) then 1.000 else 0.000

scanl :: (((a -> ((b -> a)))) -> ((a -> ((([b]) -> ([a]))))))
scanl = \(((_arg0)::(a -> ((b -> a))))) -> \((_arg1)) -> \(((_arg2)::[b])) -> case (_arg0,((_arg1,_arg2))) of {((op::(a -> ((b -> a)))),(acc,[])) -> acc:[]; ((op::(a -> ((b -> a)))),(acc,(x:(xs::[b])))) -> acc:((scanl op (op acc x)) xs)}

fromTo :: (BayNum a) => (a -> ((a -> ([a]))))
fromTo = \((n::a)) -> \((m::a)) -> if (n<m) then (n:(fromTo (n+1) m)) else (n:[])

bigSum :: (Int -> ((Int -> ((((Int -> Double)) -> Double)))))
bigSum = \((lo::Int)) -> \((hi::Int)) -> \((f::(Int -> Double))) -> sum (map f (fromTo lo hi))

replicate :: (Int -> ((a -> ([a]))))
replicate = \(((_arg0)::Int)) -> \((_arg1)) -> case (_arg0,_arg1) of {(0,x) -> []; ((n::Int),x) -> x:(replicate (n-1) x)}

neg :: (BayNum a) => (a -> a)
neg = \((x::a)) -> 0-x

ix :: (Int -> ((([a]) -> a)))
ix = \(((_arg0)::Int)) -> \(((_arg1)::[a])) -> case (_arg0,_arg1) of {(0,(x:_)) -> x; ((n::Int),(_:(xs::[a]))) -> ix (n-1) xs}

linspace :: (Double -> ((Double -> ((Double -> ([Double]))))))
linspace = \((from::Double)) -> \((to::Double)) -> \((num::Double)) -> let {(dt::Double) = (to-from)/num;
 (is::[Double]) = fromTo 0 (num-1);
 } in map (\((i::Double)) -> ((unround i)*dt)+from) is

countSamples :: ((Prob a) -> (Maybe Int))
countSamples = \(((_arg0)::Prob a)) -> case _arg0 of {Samples (xs::[a]) -> Just (length xs); Sampler _ -> Nothing}

unit :: Prob Double
unit = Sampler primUnit

primOneOf :: (([a]) -> ((Seed -> ((a,Seed)))))
primOneOf = \((xs::[a])) -> \((seed::Seed)) -> let {((u::Double),(nextSeed::Seed)) = primUnit seed;
 (idx::Int) = floor (u*(unround (length xs)));
 } in ((ix idx xs),nextSeed)

append :: (([a]) -> ((([a]) -> ([a]))))
append = \(((_arg0)::[a])) -> \(((_arg1)::[a])) -> case (_arg0,_arg1) of {([],(ys::[a])) -> ys; ((x:(xs::[a])),(ys::[a])) -> x:(append xs ys)}

invlogit :: (Double -> Double)
invlogit = \((x::Double)) -> 1/(1+(exp (0.000-x)))

logit :: (Double -> Double)
logit = \((x::Double)) -> log (x/(1-x))

boolToReal :: (Bool -> Double)
boolToReal = \(((_arg0)::Bool)) -> case _arg0 of {True  -> 1.000; False  -> 0.000}

for :: (Int -> ((Int -> ((((Int -> (Prob a))) -> (Prob ([a])))))))
for = \((n::Int)) -> \((m::Int)) -> \((s::(Int -> (Prob a)))) -> if (n<m) then ((s n)>>=(\(x) -> ((for (n+1) m) s)>>=(\((xs::[a])) -> return (x:xs)))) else ((s n)>>=(\(v) -> return (v:[])))

repeat :: (Int -> (((Prob a) -> (Prob ([a])))))
repeat = \((n::Int)) -> \((sam::Prob a)) -> (for 1 n) (\((i::Int)) -> sam)

square :: (BayNum a) => (a -> a)
square = \((x::a)) -> x*x

step :: (BayNum a,BayNum b) => (a -> b)
step = \((x::a)) -> if (x<0) then 0 else 1

fac :: (Int -> Int)
fac = \(((_arg0)::Int)) -> case _arg0 of {1 -> 1; (n::Int) -> n*(fac (n-1))}

zipWithNats :: (BayNum b) => (([a]) -> ((b -> ([(b,a)]))))
zipWithNats = \(((_arg0)::[a])) -> \(((_arg1)::b)) -> case (_arg0,_arg1) of {([],_) -> []; ((x:(xs::[a])),(n::b)) -> ((n,x)):(zipWithNats xs (n+1))}

unSamples :: ((Prob a) -> ([a]))
unSamples = \(Samples (xs::[a])) -> xs

chainPlot :: ((Prob Double) -> Plot)
chainPlot = \(Samples (xs::[Double])) -> Plot [] (return ((Points (zipWithNats xs 0)):[]))

style :: (([(T.Text,T.Text)]) -> ((Plot -> Plot)))
style = \((opts::[(T.Text,T.Text)])) -> \(Plot (pos::[(T.Text,T.Text)]) (plr::Prob ([Radian]))) -> Plot pos (fmap (\((lrs::[Radian])) -> (Options opts lrs):[]) plr)

distPlot0 :: ((Prob Double) -> Plot)
distPlot0 = \(((_arg0)::Prob Double)) -> case _arg0 of {Samples (xs::[Double]) -> Plot ((((T.pack "range-y"),(T.pack "0"))):[]) (return ((Histogram xs):[])); (sampler::Prob Double) -> Plot ((((T.pack "range-y"),(T.pack "0"))):[]) ((repeat 2000 sampler)>>=(\((xs::[Double])) -> return ((Histogram xs):[])))}

distPlot :: ((Prob Double) -> Plot)
distPlot = \((p::Prob Double)) -> style ((((T.pack "fill"),(T.pack "pop_colour"))):((((T.pack "fill-opacity"),(T.pack "0.3"))):((((T.pack "stroke"),(T.pack "none"))):((((T.pack "bar-width"),(T.pack "0.8"))):[])))) (distPlot0 p)

histogram :: (BayNum a) => (([a]) -> Plot)
histogram = \((xs::[a])) -> Plot [] (return ((Options ((((T.pack "fill"),(T.pack "pop_colour"))):((((T.pack "fill-opacity"),(T.pack "0.3"))):((((T.pack "stroke"),(T.pack "none"))):((((T.pack "bar-width"),(T.pack "0.8"))):[])))) ((Histogram (map unround xs)):[])):[]))

unPlot :: (Plot -> (Prob ([Radian])))
unPlot = \(Plot _ (x::Prob ([Radian]))) -> x

over :: (([Plot]) -> Plot)
over = \((plots::[Plot])) -> Plot [] ((mapM unPlot plots)>>=(\((items::[[Radian]])) -> return (map (\((Plot (os::[(T.Text,T.Text)]) _,(rdns::[Radian]))) -> Options os rdns) (zip plots items))))

scatterPlot :: (BayNum a,BayNum b) => (([(a,b)]) -> Plot)
scatterPlot = \((xys::[(a,b)])) -> style ((((T.pack "fill"),(T.pack "pop_colour"))):((((T.pack "marker-size"),(T.pack "30"))):((((T.pack "marker"),(T.pack "circle"))):((((T.pack "stroke"),(T.pack "none"))):[])))) (Plot [] (return ((Points (map (\(((x::a),(y::b))) -> ((unround x),(unround y))) xys)):[])))

linePlot :: (BayNum a,BayNum b) => (([(a,b)]) -> Plot)
linePlot = \((xys::[(a,b)])) -> style ((((T.pack "stroke"),(T.pack "pop_colour"))):((((T.pack "stroke-width"),(T.pack "2"))):[])) (Plot [] (return ((Lines (map (\(((x::a),(y::b))) -> ((unround x),(unround y))) xys)):[])))

plines :: (BayNum a,BayNum b) => ((Prob ([(a,b)])) -> Plot)
plines = \((plns::Prob ([(a,b)]))) -> style ((((T.pack "stroke-opacity"),(T.pack "0.2"))):((((T.pack "stroke-width"),(T.pack "2"))):[])) (Plot [] (repeat 50 (fmap (\((xys::[(a,b)])) -> Lines (map (\(((x::a),(y::b))) -> ((unround x),(unround y))) xys)) plns)))

ppoints :: ((Prob ([(Double,Double)])) -> Plot)
ppoints = \((ppts::Prob ([(Double,Double)]))) -> Plot ((((T.pack "fill"),(T.pack "pop_colour"))):[]) (repeat 50 (fmap Points ppts))

sigPlot :: (((Double -> Double)) -> Plot)
sigPlot = \((sig::(Double -> Double))) -> Plot ((((T.pack "fill"),(T.pack "pop_colour"))):((((T.pack "stroke-width"),(T.pack "2"))):[])) (return ((Timeseries sig):[]))

thin :: (Int -> ((([a]) -> ([a]))))
thin = \((skip::Int)) -> \((xs::[a])) -> map snd (filter (\(((i::Int),x)) -> (mod i (skip+1))==0) (zip (fromTo 0 ((length xs)-1)) xs))

thinTo :: (Int -> ((([a]) -> ([a]))))
thinTo = \((n::Int)) -> \((xs::[a])) -> let {(nxs::Int) = length xs;
 (ratio::Int) = round ((unround nxs)/(unround n));
 } in thin ratio xs

psigPlot :: ((Prob ((Double -> Double))) -> Plot)
psigPlot = \(((_arg0)::Prob ((Double -> Double)))) -> case _arg0 of {Samples (sigs::[(Double -> Double)]) -> Plot ((((T.pack "fill"),(T.pack "pop_colour"))):((((T.pack "stroke-opacity"),(T.pack "0.2"))):((((T.pack "stroke-width"),(T.pack "2"))):[]))) (return (map Timeseries (thinTo 20 sigs))); Sampler (f::(Seed -> ((((Double -> Double)),Seed)))) -> Plot ((((T.pack "fill"),(T.pack "pop_colour"))):((((T.pack "stroke-opacity"),(T.pack "0.2"))):((((T.pack "stroke-width"),(T.pack "2"))):[]))) ((repeat 20 (Sampler f))>>=(\((sigs::[(Double -> Double)])) -> return (map Timeseries sigs)))}

psigNPlot :: (Int -> (((Prob ((Double -> Double))) -> Plot)))
psigNPlot = \(((_arg0)::Int)) -> \(((_arg1)::Prob ((Double -> Double)))) -> case (_arg0,_arg1) of {((n::Int),Samples (sigs::[(Double -> Double)])) -> Plot ((((T.pack "fill"),(T.pack "pop_colour"))):((((T.pack "stroke-opacity"),(T.pack "0.2"))):((((T.pack "stroke-width"),(T.pack "2"))):[]))) (return (map Timeseries (thinTo n sigs))); ((n::Int),Sampler (f::(Seed -> ((((Double -> Double)),Seed))))) -> Plot ((((T.pack "fill"),(T.pack "pop_colour"))):((((T.pack "stroke-opacity"),(T.pack "0.1"))):((((T.pack "stroke-width"),(T.pack "2"))):[]))) ((repeat n (Sampler f))>>=(\((sigs::[(Double -> Double)])) -> return (map Timeseries sigs)))}

probBoolToP :: ((Prob Bool) -> (Prob Double))
probBoolToP = \(((_arg0)::Prob Bool)) -> case _arg0 of {Sampler (f::(Seed -> ((Bool,Seed)))) -> (repeat 200 (Sampler f))>>=(\((bs::[Bool])) -> probBoolToP (Samples bs)); Samples (bs::[Bool]) -> let {(yeas::[Bool]) = filter id bs;
 } in return ((unround (length yeas))/(unround (length bs)))}

pcurve :: (([(Double,(Prob Bool))]) -> Plot)
pcurve = \((xps::[(Double,(Prob Bool))])) -> Plot [] (let {(xs::[Double]) = map fst xps;
 } in (mapM (probBoolToP.snd) xps)>>=(\((ps::[Double])) -> return ((Lines (zip xs ps)):[])))

plotStyle :: (([(T.Text,T.Text)]) -> ((Plot -> Plot)))
plotStyle = \(((_arg0)::[(T.Text,T.Text)])) -> \(((_arg1)::Plot)) -> case (_arg0,_arg1) of {((opts::[(T.Text,T.Text)]),Plot (pos::[(T.Text,T.Text)]) (plr::Prob ([Radian]))) -> Plot (append opts pos) plr; ((opts::[(T.Text,T.Text)]),PlotRow (pos::[(T.Text,T.Text)]) (plr::[Plot])) -> PlotRow (append opts pos) plr; ((opts::[(T.Text,T.Text)]),PlotColumn (pos::[(T.Text,T.Text)]) (plr::[Plot])) -> PlotColumn (append opts pos) plr; ((opts::[(T.Text,T.Text)]),PlotStack (pos::[(T.Text,T.Text)]) (plr::[(T.Text,Plot)])) -> PlotStack (append opts pos) plr; ((opts::[(T.Text,T.Text)]),PlotGrid (pos::[(T.Text,T.Text)]) (x::Int) (y::Int) (plr::[(T.Text,Plot)])) -> ((PlotGrid (append opts pos) x) y) plr}

wide :: (Plot -> Plot)
wide = plotStyle ((((T.pack "width"),(T.pack "750"))):[])

aspect :: (Double -> ((Plot -> Plot)))
aspect = \((x::Double)) -> plotStyle ((((T.pack "aspect"),(showReal x))):[])

besides :: (([Plot]) -> Plot)
besides = PlotRow []

above :: (([Plot]) -> Plot)
above = PlotColumn []

axisLabels :: (T.Text -> ((T.Text -> ((Plot -> Plot)))))
axisLabels = \((xlab::T.Text)) -> \((ylab::T.Text)) -> \(Plot (popts::[(T.Text,T.Text)]) (plns::Prob ([Radian]))) -> Plot ((((T.pack "axis-x-label"),xlab)):((((T.pack "axis-y-label"),ylab)):popts)) plns

unPlotOpts :: (Plot -> ([(T.Text,T.Text)]))
unPlotOpts = \(Plot (os::[(T.Text,T.Text)]) (x::Prob ([Radian]))) -> os

sigLast :: (((Double -> Double)) -> Double)
sigLast = \((sig::(Double -> Double))) -> case observeSig sig of {ObservedSignal (dt::Double) (t0::Double) (pts::Vector Double) -> pts@>((dim pts)-1); ObservedXYSignal (pts::Vector ((Double,Double))) -> snd (pts@>((dim pts)-1))}

sigTail :: (((Double -> Double)) -> ([Double]))
sigTail = \((sig::(Double -> Double))) -> case observeSig sig of {ObservedSignal (dt::Double) (t0::Double) (pts::Vector Double) -> vecToList pts}

sigNPts :: (((Double -> Double)) -> Int)
sigNPts = \((sig::(Double -> Double))) -> case observeSig sig of {ObservedSignal (dt::Double) (t0::Double) (pts::Vector Double) -> dim pts; ObservedXYSignal (pts::Vector ((Double,Double))) -> dim pts}

between :: (BayNum a) => (a -> ((a -> ((a -> Bool)))))
between = \((lo::a)) -> \((hi::a)) -> \((x::a)) -> (x>lo)&&(x<hi)

runP :: (a -> ((((a -> ((c,d)))) -> c)))
runP = \(xs) -> \((my::(a -> ((c,d))))) -> fst (my xs)

runP1 :: (((a -> ((b,c)))) -> ((a -> b)))
runP1 = \((my::(a -> ((b,c))))) -> \(xs) -> fst (my xs)

returnP :: (a -> ((b -> ((a,b)))))
returnP = \(x) -> \(xs) -> (x,xs)

bindP :: (((a -> ((b,c)))) -> ((((b -> ((c -> f)))) -> ((a -> f)))))
bindP = \((f::(a -> ((b,c))))) -> \((g::(b -> ((c -> f))))) -> \(xs) -> let {(x,xs') = f xs;
 } in g x xs'

headP :: (([a]) -> ((a,([a]))))
headP = \(((_arg0)::[a])) -> case _arg0 of {(x:(xs::[a])) -> (x,xs); [] -> bayError (T.pack "headP: empty list")}

takeP :: (Int -> ((([a]) -> ((([a]),([a]))))))
takeP = \((n::Int)) -> \((xs::[a])) -> ((take n xs),(drop n xs))

forP :: (([a]) -> ((((a -> ((c -> ((d,c)))))) -> ((c -> ((([d]),c)))))))
forP = \(((_arg0)::[a])) -> \(((_arg1)::(a -> ((c -> ((d,c))))))) -> \((_arg2)) -> case (_arg0,((_arg1,_arg2))) of {([],((f::(a -> ((c -> ((d,c)))))),xs)) -> ([],xs); ((a:(as::[a])),((f::(a -> ((c -> ((d,c)))))),xs)) -> (bindP (f a) (\(y) -> bindP (forP as f) (\((ys::[d])) -> returnP (y:ys)))) xs}

noP :: (a -> (((),a)))
noP = \(xs) -> ((),xs)

fmapP :: (((a -> b)) -> ((((c -> ((a,e)))) -> ((c -> ((b,e)))))))
fmapP = \((f::(a -> b))) -> \((mx::(c -> ((a,e))))) -> bindP mx (\(x) -> returnP (f x))

fixP :: (Int -> (((Prob a) -> (Prob (Prob a)))))
fixP = \(((_arg0)::Int)) -> \(((_arg1)::Prob a)) -> case (_arg0,_arg1) of {((n::Int),Sampler (f::(Seed -> ((a,Seed))))) -> (repeat n (Sampler f))>>=(\((xs::[a])) -> return (Samples xs)); ((n::Int),Samples (xs::[a])) -> return (Samples (thinTo n xs))}

diag :: ((Vector Double) -> (Matrix Double))
diag = \((v::Vector Double)) -> fillM (((dim v),(dim v))) (\(((i::Int),(j::Int))) -> if (i==j) then (v@>i) else 0.000)

diagL :: (([Double]) -> (Matrix Double))
diagL = diag.listToVec

mmap :: (BayNum a,BayNum b) => (((a -> b)) -> (((Matrix a) -> (Matrix b))))
mmap = \((f::(a -> b))) -> \((m::Matrix a)) -> fillM (mdims m) (\(((i::Int),(j::Int))) -> f (m@@>((i,j))))

transM :: (BayNum a) => ((Matrix a) -> (Matrix a))
transM = \((m::Matrix a)) -> fillM (mdims m) (\(((i::Int),(j::Int))) -> m@@>((j,i)))

ident :: (BayNum a) => (a -> (Matrix Double))
ident = \((n::a)) -> diagL (map (const 1) (fromTo 1 n))

meanL :: (([Double]) -> Double)
meanL = \((xs::[Double])) -> (sum xs)/(unround (length xs))

varL :: (([Double]) -> Double)
varL = \((xs::[Double])) -> let {(mu::Double) = meanL xs;
 } in (sum (map (\((x::Double)) -> (x-mu)*(x-mu)) xs))/(unround ((length xs)-1))

popvarL :: (([Double]) -> Double)
popvarL = \((xs::[Double])) -> let {(mu::Double) = meanL xs;
 } in (sum (map (\((x::Double)) -> (x-mu)*(x-mu)) xs))/(unround (length xs))

minL :: (([Double]) -> Double)
minL = \(((x::Double):(xs::[Double]))) -> (foldl min x) xs

maxL :: (([Double]) -> Double)
maxL = \(((x::Double):(xs::[Double]))) -> (foldl max x) xs

getT :: ((a) -> (((b) -> ((a,b)))))
getT = \(dt) -> \(tmax) -> (dt,tmax)

pearson :: (([(Double,Double)]) -> Double)
pearson = \((xys::[(Double,Double)])) -> let {(xs::[Double]) = map fst xys;
 (ys::[Double]) = map snd xys;
 (mx::Double) = meanL xs;
 (my::Double) = meanL ys;
 (sx::Double) = sqrt (varL xs);
 (sy::Double) = sqrt (varL ys);
 (invN::Double) = 1.000/(unround ((length xys)-1));
 } in invN*(sum (map (\(((x::Double),(y::Double))) -> ((x-mx)/sx)*((y-my)/sy)) xys))

data Strategy a =
   GStrategy (((((Vector Double) -> ((Double,(Vector Double))))) -> (((Vector Double) -> ((a -> ((((Double,(Vector Double))) -> (Prob (((((Vector Double),a)),((Double,(Vector Double)))))))))))))) (((Vector Double) -> a))
   |VStrategy (((((Vector Double) -> Double)) -> (((Vector Double) -> ((a -> ((Double -> (Prob (((((Vector Double),a)),Double))))))))))) (((Vector Double) -> a))
intBetweenLogPdf :: (BayNum d) => (a -> ((b -> ((c -> d)))))
intBetweenLogPdf = \(lo) -> \(hi) -> \(x) -> 1

anyLogPdf :: (a -> Double)
anyLogPdf = \(x) -> 1.000

d :: ((Double) -> ((((Double -> Double)) -> ((Double -> Double)))))
d = \((dt::Double)) -> \((w::(Double -> Double))) -> \((t::Double)) -> ((w t)-(w (t-dt)))/dt

unormal :: Prob Double
unormal = unit>>=(\((u1::Double)) -> unit>>=(\((u2::Double)) -> return ((sqrt ((0.000-2.000)*(log u1)))*(cos ((2.000*pi)*u2)))))

gammaAux :: (Double -> ((Double -> (Prob Double))))
gammaAux = \((a::Double)) -> \((b::Double)) -> let {(d::Double) = a-(1.000/3.000);
 (c::Double) = 1.000/(3.000*(sqrt d));
 } in unormal>>=(\((x::Double)) -> let {(cx::Double) = c*x;
 (v::Double) = (1.000+cx)**3.000;
 (x_2::Double) = x*x;
 (x_4::Double) = x_2*x_2;
 } in if (cx<(-1.000)) then (gammaAux a b) else (unit>>=(\((u::Double)) -> if ((u<(1.000-(3.310e-2*x_4)))||((log u)<((0.500*x_2)+(d*((1.000-v)+(log v)))))) then (return ((b*d)*v)) else (gammaAux a b))))

gamma :: (Double -> ((Double -> (Prob Double))))
gamma = \((k::Double)) -> \((theta::Double)) -> if (k<1.000) then (unit>>=(\((u::Double)) -> (gamma (1.000+k) theta)>>=(\((x::Double)) -> return (x*(u**(1.000/k)))))) else (gammaAux k theta)

improper_uniform :: Prob Double
improper_uniform = gamma 1 0.100

improper_uniformLogPdf :: (a -> Double)
improper_uniformLogPdf = \(_) -> 1.000

improper_uniform_positive :: Prob Double
improper_uniform_positive = gamma 1 1

unfoldN :: (Int -> ((Int -> ((a -> ((((Int -> ((a -> (Prob a))))) -> (Prob ([a])))))))))
unfoldN = \((n::Int)) -> \((m::Int)) -> \(lastx) -> \((s::(Int -> ((a -> (Prob a)))))) -> if (n<m) then ((s n lastx)>>=(\(x) -> (((unfoldN (n+1) m) x) s)>>=(\((xs::[a])) -> return (x:xs)))) else ((s n lastx)>>=(\(v) -> return (v:[])))

unfold :: (Int -> ((a -> ((((a -> (Prob a))) -> (Prob ([a])))))))
unfold = \((n::Int)) -> \(x0) -> \((s::(a -> (Prob a)))) -> ((unfoldN 1 n) x0) (\((i::Int)) -> s)

improper_uniformInit :: Double
improper_uniformInit = 1.000

ser :: Double
ser = 1.000

normal :: (Double -> ((Double -> (Prob Double))))
normal = \((mean::Double)) -> \((variance::Double)) -> unormal>>=(\((u::Double)) -> return ((u*(sqrt variance))+mean))

rwmTrans :: (BayNum a) => ((((Vector Double) -> Double)) -> (((Vector Double) -> ((((Double,((Double,a)))) -> ((Double -> (Prob (((((Vector Double),((Double,((Double,a)))))),Double))))))))))
rwmTrans = \((posterior::((Vector Double) -> Double))) -> \((xi::Vector Double)) -> \(((sigma::Double),((i::Double),(iaccept::a)))) -> \((pi::Double)) -> (fmap listToVec (mapM (\((x::Double)) -> normal x sigma) (vecToList xi)))>>=(\((xstar::Vector Double)) -> let {(pstar::Double) = posterior xstar;
 (ratio::Double) = exp (pstar-pi);
 } in unit>>=(\((u::Double)) -> let {(accept::Bool) = u<ratio;
 (sigmaNext::Double) = if accept then (sigma*((min 1.400 (1+(5.000/i)))**3)) else (sigma*(max 0.714 (1-(5.000/i))));
 } in return (if accept then ((((xstar,((sigmaNext,(((i+1),(iaccept+1))))))),pstar)) else ((((xi,((sigmaNext,(((i+1),iaccept)))))),pi)))))

rwmIni :: (a -> ((Double,((Double,Double)))))
rwmIni = \(_) -> (0.100,((1.000,0.000)))

rwm :: Strategy ((Double,((Double,Double))))
rwm = VStrategy rwmTrans rwmIni

malaTrans :: ((((Vector Double) -> ((Double,a)))) -> (((Vector Double) -> ((Double -> ((((Double,a)) -> (Prob (((((Vector Double),Double)),((Double,a))))))))))))
malaTrans = \((postgrad::((Vector Double) -> ((Double,a))))) -> \((xi::Vector Double)) -> \((sigma::Double)) -> \(((pi::Double),gradienti)) -> let {(xstarMean::Vector Double) = xi;
 } in (fmap listToVec (mapM (\((x::Double)) -> normal x sigma) (vecToList xi)))>>=(\((xstar::Vector Double)) -> let {((pstar::Double),gradientStar) = postgrad xstar;
 (ratio::Double) = exp (pstar-pi);
 } in unit>>=(\((u::Double)) -> let {(accept::Bool) = u<ratio;
 (sigmaNext::Double) = sigma;
 } in return (if accept then ((((xstar,sigmaNext)),((pstar,gradientStar)))) else ((((xi,sigmaNext)),((pi,gradienti)))))))

malaIni :: (BayNum b) => (a -> b)
malaIni = \(vini) -> 1

mala :: Strategy Double
mala = GStrategy malaTrans malaIni

uniform :: (Double -> ((Double -> (Prob Double))))
uniform = \((lo::Double)) -> \((hi::Double)) -> unit>>=(\((x::Double)) -> return ((x*(hi-lo))+lo))

oneOf :: (([a]) -> (Prob a))
oneOf = \((xs::[a])) -> (fmap floor (uniform 0.000 (unround (length xs))))>>=(\((idx::Int)) -> return (ix idx xs))

oneOfLogPdf :: (([a]) -> ((b -> Double)))
oneOfLogPdf = \((xs::[a])) -> \(_) -> 1.000/(unround (length xs))

uniformLogPdf :: (Double -> ((Double -> ((Double -> Double)))))
uniformLogPdf = \((lo::Double)) -> \((hi::Double)) -> \((x::Double)) -> if ((x<hi)&&(x>lo)) then ((log 1)-(log (hi-lo))) else (0.000-1.000e20)

intBetween :: (BayNum a) => (a -> ((a -> (Prob Int))))
intBetween = \((lo::a)) -> \((hi::a)) -> unit>>=(\((x::Double)) -> return (floor ((x*(unround ((hi+1)-lo)))+(unround lo))))

any :: Prob a
any = undefined

improper_uniform_positiveLogPdf :: (BayNum a) => (a -> Double)
improper_uniform_positiveLogPdf = \((x::a)) -> if (x>0) then 1.000 else (0.000-1.000e20)

oneTo :: (BayNum a) => (a -> (Prob Int))
oneTo = \((n::a)) -> (uniform 0.500 ((unround n)+0.500))>>=(\((x::Double)) -> return (round x))

oneToLogPdf :: (BayNum a) => (a -> ((a -> Double)))
oneToLogPdf = \((hi::a)) -> \((x::a)) -> if ((x<(hi+1))&&(x>0)) then 1.000 else (0.000-1.000e10)

normalLogPdf :: (Double -> ((Double -> ((Double -> Double)))))
normalLogPdf = \((mean::Double)) -> \((variance::Double)) -> \((x::Double)) -> ((log 1)-(0.500*(log ((2.000*pi)*variance))))-(((x-mean)**2)/(2*variance))

logNormal :: (Double -> ((Double -> (Prob Double))))
logNormal = \((mean::Double)) -> \((variance::Double)) -> fmap exp (normal mean variance)

logNormalLogPdf :: (Double -> ((Double -> ((Double -> Double)))))
logNormalLogPdf = \((mean::Double)) -> \((variance::Double)) -> \((x::Double)) -> (log (1/(sqrt ((2.000*pi)*variance))))+(0.000-((((log x)-mean)*((log x)-mean))/(2*variance)))

normalLines :: (Double -> ((Double -> ([(Double,Double)]))))
normalLines = \((mean::Double)) -> \((v::Double)) -> let {(f::(Double -> ((Double,Double)))) = \((x::Double)) -> (x,(exp ((normalLogPdf mean v) x)));
 } in map f ((linspace (mean-(3*(sqrt v))) (mean+(3*(sqrt v)))) 50)

binomialProb :: (Int -> ((Double -> ((Int -> Double)))))
binomialProb = \((n::Int)) -> \((p::Double)) -> \((k::Int)) -> ((choose n k)*(p^k))*((1.000-p)^(n-k))

binomialLogProb :: (Int -> ((Double -> ((Int -> Double)))))
binomialLogProb = \((n::Int)) -> \((p::Double)) -> \((k::Int)) -> ((log (choose n k))+((unround k)*(log p)))+((unround (n-k))*(log (1.000-p)))

bernoulli :: (Double -> (Prob Bool))
bernoulli = \((p::Double)) -> unit>>=(\((u::Double)) -> return (u<p))

bernoulli01 :: (Double -> (Prob Int))
bernoulli01 = \((p::Double)) -> unit>>=(\((u::Double)) -> if (u<p) then (return 1) else (return 0))

bernoulliLogPdf :: (Double -> ((Bool -> Double)))
bernoulliLogPdf = \((p::Double)) -> \((b::Bool)) -> log (((p*((2*(boolToReal b))-1))+1)-(boolToReal b))

bernoulli01LogPdf :: (Double -> ((Double -> Double)))
bernoulli01LogPdf = \((p::Double)) -> \((b::Double)) -> log (((p*((2*b)-1))+1)-b)

countTrue :: (BayNum a) => (([Bool]) -> a)
countTrue = \(((_arg0)::[Bool])) -> case _arg0 of {[] -> 0; (True :(bs::[Bool])) -> 1+(countTrue bs); (False :(bs::[Bool])) -> countTrue bs}

binomial :: (BayNum a) => (Int -> ((Double -> (Prob a))))
binomial = \((n::Int)) -> \((p::Double)) -> (repeat n (unit>>=(\((u::Double)) -> return (u<p))))>>=(\((bools::[Bool])) -> return (countTrue bools))

exponential :: (Double -> (Prob Double))
exponential = \((lam::Double)) -> unit>>=(\((u::Double)) -> return (neg ((log u)/lam)))

exponentialLogPdf :: (Double -> ((Double -> Double)))
exponentialLogPdf = \((lam::Double)) -> \((x::Double)) -> lam*(exp ((0.000-lam)*x))

poissonAux :: (BayNum a) => (Double -> ((a -> ((Double -> (Prob a))))))
poissonAux = \((bigl::Double)) -> \((k::a)) -> \((p::Double)) -> if (p>bigl) then (unit>>=(\((u::Double)) -> (poissonAux bigl (k+1)) (p*u))) else (return (k-1))

poisson :: (Double -> (Prob Int))
poisson = \((lam::Double)) -> (poissonAux (exp (0.000-lam)) 0) 1

poissonLogPdf :: (Double -> ((Int -> Double)))
poissonLogPdf = \((lam::Double)) -> \((x::Int)) -> ((lam**(unround x))*(exp (0.000-lam)))/(unround (fac x))

betaAux :: (Int -> (Prob Double))
betaAux = \((n::Int)) -> (repeat n unit)>>=(\((us::[Double])) -> return (log (product us)))

beta :: (Int -> ((Int -> (Prob Double))))
beta = \((a::Int)) -> \((b::Int)) -> (betaAux a)>>=(\((g1::Double)) -> (betaAux b)>>=(\((g2::Double)) -> return (g1/(g1+g2))))

cof :: [Double]
cof = 76.180:((-86.505):(24.014:((-1.232):(1.209e-3:((-5.395e-6):[])))))

gammaln :: (Double -> Double)
gammaln = \((xx::Double)) -> let {(tmp'::Double) = (xx+5.500)-((xx+0.500)*(log (xx+5.500)));
 (ser'::Double) = ser+(sum (map (\(((y::Double),(c::Double))) -> c/(xx+y)) (zip (fromTo 1 7) cof)));
 } in (0.000-tmp')+(log ((2.507*ser')/xx))

betaf :: (Double -> ((Double -> Double)))
betaf = \((z::Double)) -> \((w::Double)) -> exp (((gammaln z)+(gammaln w))-(gammaln (z+w)))

betaLogPdf :: (Int -> ((Int -> ((Double -> Double)))))
betaLogPdf = \((a::Int)) -> \((b::Int)) -> \((x::Double)) -> log (((1.000/(betaf (unround a) (unround b)))*(x^(a-1)))*((1.000-x)^(b-1)))

invGamma :: (Double -> ((Double -> (Prob Double))))
invGamma = \((a::Double)) -> \((b::Double)) -> (gamma a (1.000/b))>>=(\((g::Double)) -> return (1.000/g))

wiener :: ((Double) -> (((Double) -> (Prob ((Double -> Double))))))
wiener = \((dt::Double)) -> \((tmax::Double)) -> let {(n::Int) = (round (tmax/dt))+1;
 } in (repeat n unormal)>>=(\((ns::[Double])) -> let {(etas::[Double]) = map (\((u::Double)) -> u*(sqrt dt)) ns;
 } in return ((pack dt (0.000-dt)) (listToVec ((scanl (\((x::Double)) -> \((y::Double)) -> x+y) 0.000) etas))))

multiNormal :: ((Vector Double) -> (((Matrix Double) -> (Prob (Vector Double)))))
multiNormal = \((vmean::Vector Double)) -> \((cov::Matrix Double)) -> (repeat (dim vmean) (normal 0 1))>>=(\((ns::[Double])) -> let {((u::Matrix Double):((s::Matrix Double):((v::Matrix Double):[]))) = svd cov;
 (j::Matrix Double) = mXm (mXm v (mmap sqrt s)) (transM v);
 } in return (vmean+(mXv j (listToVec ns))))

wieners :: ((Double) -> (((Double) -> (((Matrix Double) -> (Prob ([(Double -> Double)])))))))
wieners = \((dt::Double)) -> \((tmax::Double)) -> \((cov::Matrix Double)) -> let {(n_time_pts::Int) = (round (tmax/dt))+2;
 (n_dims::Int) = fst (mdims cov);
 (zeroV::Vector Double) = fillV n_dims (const 0.000);
 (scale_cov::Matrix Double) = dt*%cov;
 } in ((unfold n_time_pts zeroV) (\((vlast::Vector Double)) -> (multiNormal zeroV scale_cov)>>=(\((etas::Vector Double)) -> return (vlast+etas))))>>=(\((vs::[Vector Double])) -> let {(ll::[[Double]]) = transL (map vecToList vs);
 } in return (map (\((ys::[Double])) -> (pack dt (0.000-dt)) (listToVec ys)) ll))

diff :: ((Double) -> ((((Double -> Double)) -> ((Double -> Double)))))
diff = \((dt::Double)) -> \((w::(Double -> Double))) -> \((t::Double)) -> ((w t)-(w (t-dt)))/dt

decide :: (Double -> (((Vector Double) -> (((Prob a) -> (((((Vector Double) -> ((a -> Double)))) -> (Vector Double))))))))
decide = \((tol::Double)) -> \((ini::Vector Double)) -> \((dist::Prob a)) -> \((util::((Vector Double) -> ((a -> Double))))) -> (optimise tol ini) (\((vaction::Vector Double)) -> expect (fmap (util vaction) dist))

nsig :: (((Double -> Double)) -> ((Double -> (Prob ((Double -> Double))))))
nsig = \((sig::(Double -> Double))) -> \((v::Double)) -> case observeSig sig of {ObservedSignal (dt::Double) (t0::Double) (vpts::Vector Double) -> (repeat (dim vpts) (normal 0 v))>>=(\((ns::[Double])) -> return ((pack dt t0) (listToVec (map (\(((x::Double),(y::Double))) -> x+y) (zip ns (vecToList vpts))))))}

quantile :: (Double -> (((Prob Double) -> Double)))
quantile = \((x::Double)) -> \(Samples (xs::[Double])) -> let {(total::Int) = length xs;
 (under::Int) = length (filter (\((y::Double)) -> x<y) xs);
 } in (unround under)/(unround total)

gammaLogPdf :: (Double -> ((Double -> ((Double -> Double)))))
gammaLogPdf = \((k::Double)) -> \((theta::Double)) -> \((x::Double)) -> ((((k-1)*(log x))+((0.000-x)/theta))-(k*(log theta)))-(gammaln k)

invGammaLogPdf :: (Double -> ((Double -> ((Double -> Double)))))
invGammaLogPdf = \((a::Double)) -> \((b::Double)) -> \((x::Double)) -> log ((((b**a)/(exp (gammaln a)))*(x**((0.000-a)-1)))*(exp ((0.000-b)/x)))

cookAssert :: ((Prob Double) -> SamplerDensity)
cookAssert = \((s::Prob Double)) -> SamplerDensity s (uniformLogPdf 0 1)

multiNormalLogPdf :: (a -> ((b -> c)))
multiNormalLogPdf = \(vmean) -> \(cov) -> undefined

invWishart :: (Double -> (((Matrix Double) -> (Prob (Matrix Double)))))
invWishart = \((nu::Double)) -> \((s::Matrix Double)) -> undefined

invWishartLogPdf :: (a -> ((b -> ((c -> d)))))
invWishartLogPdf = \(nu) -> \(s) -> \(w) -> undefined

scandyn' :: (BayNum a) => (((Int -> ((odes -> ((sdes -> ((sdes -> ((a,odes)))))))))) -> ((a -> ((Int -> ((sdes -> ((odes -> ((([odes]) -> ((([sdes]) -> ((a,([odes]))))))))))))))))
scandyn' = \(((_arg0)::(Int -> ((odes -> ((sdes -> ((sdes -> ((a,odes))))))))))) -> \(((_arg1)::a)) -> \(((_arg2)::Int)) -> \((_arg3)) -> \((_arg4)) -> \(((_arg5)::[odes])) -> \(((_arg6)::[sdes])) -> case (_arg0,((_arg1,((_arg2,((_arg3,((_arg4,((_arg5,_arg6))))))))))) of {((f::(Int -> ((odes -> ((sdes -> ((sdes -> ((a,odes)))))))))),((p::a),(_,(_,(_,((odeacc::[odes]),[])))))) -> (p,(reverse odeacc)); ((f::(Int -> ((odes -> ((sdes -> ((sdes -> ((a,odes)))))))))),((p0::a),((i::Int),(sdelast,(odecurr,((odeacc::[odes]),(sde:(sdes::[sdes])))))))) -> let {((p1::a),odenext) = ((f i odecurr) sdelast) sde;
 } in (((((scandyn' f (p0+p1)) (i+1)) sde) odenext) (odenext:odeacc)) sdes}

scandyn :: (BayNum a) => (((Int -> ((odes -> ((sdes -> ((sdes -> ((a,odes)))))))))) -> ((odes -> ((sdes -> ((([sdes]) -> ((a,([odes]))))))))))
scandyn = \((f::(Int -> ((odes -> ((sdes -> ((sdes -> ((a,odes))))))))))) -> \(initode) -> \(initsde) -> \((sdes::[sdes])) -> (((((scandyn' f 0) 0) initsde) initode) []) sdes

tmax :: Double
tmax = 10.000

dt :: Double
dt = 1.000e-2

samples :: (BayNum a) => a
samples = 2000

heston :: Prob ((R.X R.:& V R.::: (Double -> Double) R.:& S R.::: (Double -> Double)) (Id KindStar))
heston = (gamma 1 1)>>=(\((k::Double)) -> (gamma 1 0.100)>>=(\((th::Double)) -> (gamma 1 0.100)>>=(\((eta::Double)) -> (normal 0 0.100)>>=(\((mu::Double)) -> (wiener dt tmax)>>=(\((w1::(Double -> Double))) -> (wiener dt tmax)>>=(\((w2::(Double -> Double))) -> (gamma 1 0.100)>>=(\((v_0::Double)) -> (uniform 0.000 2.000)>>=(\((s_0::Double)) -> let {v = solveODE (\v-> \((t::Double)) -> (k*(th-v))+((eta*(sqrt v))*((d dt w1) t))) tmax dt v_0;
s = solveODE (\s-> \((t::Double)) -> (mu*s)+(((sqrt (v t))*s)*((d dt w2) t))) tmax dt s_0;
} in return (R.X R.:& V R.:= (v) R.:& S R.:= (s))))))))))

heston1 :: Prob ((R.X R.:& V R.::: (Double -> Double) R.:& S R.::: (Double -> Double)) (Id KindStar))
heston1 = (return (R.X R.:& S_0 R.:= (1.000) R.:& V_0 R.:= (2.000e-2) R.:& Mu R.:= (5.000e-2) R.:& Eta R.:= (0.100) R.:& Th R.:= (2.000e-2) R.:& K R.:= (1.000))::Prob ((R.X R.:& S_0 R.::: Double R.:& V_0 R.::: Double R.:& Mu R.::: Double R.:& Eta R.::: Double R.:& Th R.::: Double R.:& K R.::: Double) (Id KindStar)))>>=(\(((_pars)::((R.X R.:& S_0 R.::: Double R.:& V_0 R.::: Double R.:& Mu R.::: Double R.:& Eta R.::: Double R.:& Th R.::: Double R.:& K R.::: Double) (Id KindStar)))) -> let {(k::Double) = _pars!!!K;
 } in let {(th::Double) = _pars!!!Th;
 } in let {(eta::Double) = _pars!!!Eta;
 } in let {(mu::Double) = _pars!!!Mu;
 } in let {(v_0::Double) = _pars!!!V_0;
 } in let {(s_0::Double) = _pars!!!S_0;
 } in (wiener dt tmax)>>=(\((_w_v)) -> (wiener dt tmax)>>=(\((_w_s)) -> let {v = solveODE (\v-> \((t::Double)) -> (k*(th-v))+((eta*(sqrt v))*((d dt _w_v) t))) tmax dt v_0;
s = solveODE (\s-> \((t::Double)) -> (mu*s)+(((sqrt (v t))*s)*((d dt _w_s) t))) tmax dt s_0;
} in return (R.X R.:& V R.:= (v) R.:& S R.:= (s)))))

data S = S deriving Show
instance R.Name S where
   name = S
data V = V deriving Show
instance R.Name V where
   name = V
data K = K deriving Show
instance R.Name K where
   name = K
data Th = Th deriving Show
instance R.Name Th where
   name = Th
data Eta = Eta deriving Show
instance R.Name Eta where
   name = Eta
data Mu = Mu deriving Show
instance R.Name Mu where
   name = Mu
data V_0 = V_0 deriving Show
instance R.Name V_0 where
   name = V_0
data S_0 = S_0 deriving Show
instance R.Name S_0 where
   name = S_0
data Posterior = Posterior deriving Show
instance R.Name Posterior where
   name = Posterior
data Postgrad = Postgrad deriving Show
instance R.Name Postgrad where
   name = Postgrad
data VToRec = VToRec deriving Show
instance R.Name VToRec where
   name = VToRec
data Inisam = Inisam deriving Show
instance R.Name Inisam where
   name = Inisam

target = do
  ((fakedata::((R.X R.:& V R.::: (Double -> Double) R.:& S R.::: (Double -> Double)) (Id KindStar))))::((R.X R.:& V R.::: (Double -> Double) R.:& S R.::: (Double -> Double)) (Id KindStar)) <- sample (heston1::Prob ((R.X R.:& V R.::: (Double -> Double) R.:& S R.::: (Double -> Double)) (Id KindStar)))
  --fail "done"
  let prims :: ((R.X R.:& Inisam R.::: Prob ([Double]) R.:& VToRec R.::: ((Vector Double) -> ((R.X R.:& V R.::: (Double -> Double) R.:& V_0 R.::: Double R.:& Mu R.::: Double R.:& Eta R.::: Double R.:& Th R.::: Double R.:& K R.::: Double) (Id KindStar))) R.:& Postgrad R.::: ((Vector Double) -> ((Double,(Vector Double)))) R.:& Posterior R.::: (([Double]) -> Double)) (Id KindStar))
      prims = let {s::(Double -> Double) = (fakedata!!!S);
 posterior = runP1 (bindP (fmapP (\((_x)) -> exp _x) headP) (\(k) -> bindP (fmapP (\((_x)) -> exp _x) headP) (\(th) -> bindP (fmapP (\((_x)) -> exp _x) headP) (\(eta) -> bindP headP (\(mu) -> bindP (fmapP (\((_x)) -> exp _x) headP) (\(v_0) -> bindP (fmapP (\(s) -> v_0:(map (\(_x ) -> exp _x) s)) (takeP$((round (tmax/dt))-1))) (\(v__obsSig) -> bindP (returnP ((packL dt 0) v__obsSig)) (\(v) -> returnP (((gammaLogPdf 1 1) k)+(((gammaLogPdf 1 0.100) th)+(((gammaLogPdf 1 0.100) eta)+(((normalLogPdf 0 0.100) mu)+(((gammaLogPdf 1 0.100) v_0)+(((uniformLogPdf 0.000 2.000) (s 0))+(let {scanfun = \(i) -> \([]) -> \((v_last:(s_last:[]))) -> \((v_next:(s_next:[]))) -> let {t = (unround i)*dt;
 v = const v_last;
 s = const s_last;
 pthis = (0+((normalLogPdf (v_last+(dt*(k*(th-(v t))))) (dt*((eta*(sqrt (v t)))*(eta*(sqrt (v t)))))) v_next))+((normalLogPdf (s_last+(dt*(mu*(s t)))) (dt*(((sqrt (v t))*(s t))*((sqrt (v t))*(s t))))) s_next);
 } in (pthis,[]);
 (pdynsys,dynsysres) = ((scandyn scanfun []) ((v 0):((s 0):[]))) (transL ((tail v__obsSig):((sigTail s):[])));
 } in pdynsys+0)))))))))))))));
 postgrad = \(_v ) -> runST$((newSTRef 0)>>=(\(postref) -> (VSM.replicate (dim _v) 0)>>=(\(gradref) -> (newSTRef (0::Int))>>=(\(countref) -> let {post_incr = addSTRef postref;
 grad_incr = addMV gradref;
 count_incr = incrSTRef countref;
 } in (count_incr 1)>>=(\((_k_pos)) -> let {k = exp (_v@>_k_pos);
 } in (((post_incr ((\((x::Double)) -> ((((1-1)*(log x))+((0.000-x)/1))-(1*(log 1)))-(gammaln 1)) k))>>(grad_incr _k_pos (((\((_x)) -> (exp _x)*1) (_v@>_k_pos))*((((0+((1-1)*((1/k)*1)))+((0+(1*(0-1)))/(1*1)))-0)-0))))>>(return ()))>>((count_incr 1)>>=(\((_th_pos)) -> let {th = exp (_v@>_th_pos);
 } in (((post_incr ((\((x::Double)) -> ((((1-1)*(log x))+((0.000-x)/0.100))-(1*(log 0.100)))-(gammaln 1)) th))>>(grad_incr _th_pos (((\((_x)) -> (exp _x)*1) (_v@>_th_pos))*((((0+((1-1)*((1/th)*1)))+((0+(0.100*(0-1)))/(0.100*0.100)))-0)-0))))>>(return ()))>>((count_incr 1)>>=(\((_eta_pos)) -> let {eta = exp (_v@>_eta_pos);
 } in (((post_incr ((\((x::Double)) -> ((((1-1)*(log x))+((0.000-x)/0.100))-(1*(log 0.100)))-(gammaln 1)) eta))>>(grad_incr _eta_pos (((\((_x)) -> (exp _x)*1) (_v@>_eta_pos))*((((0+((1-1)*((1/eta)*1)))+((0+(0.100*(0-1)))/(0.100*0.100)))-0)-0))))>>(return ()))>>((count_incr 1)>>=(\((_mu_pos)) -> let {mu = _v@>_mu_pos;
 } in (((post_incr ((\((x::Double)) -> ((log 1)-(0.500*(log ((2.000*pi)*0.100))))-(((x-0)**2)/(2*0.100))) mu))>>(grad_incr _mu_pos (0-((0+((2*0.100)*((2*(mu-0))*(1-0))))/((2*0.100)*(2*0.100))))))>>(return ()))>>((count_incr 1)>>=(\((_v_0_pos)) -> let {v_0 = exp (_v@>_v_0_pos);
 } in (((post_incr ((\((x::Double)) -> ((((1-1)*(log x))+((0.000-x)/0.100))-(1*(log 0.100)))-(gammaln 1)) v_0))>>(grad_incr _v_0_pos (((\((_x)) -> (exp _x)*1) (_v@>_v_0_pos))*((((0+((1-1)*((1/v_0)*1)))+((0+(0.100*(0-1)))/(0.100*0.100)))-0)-0))))>>(return ()))>>(((post_incr ((\(_) -> (log 1)-(log (2.000-0.000))) (s 0.000)))>>(return ()))>>((count_incr ((round (tmax/dt))-1))>>=(\(v__startpos) -> let {v__obsSig = vcons v_0 (vmap (\((_x)) -> exp _x) ((slice v__startpos ((round (tmax/dt))-1)) _v));
 v = (pack dt 0) v__obsSig;
 } in (forM (fromTo 1 ((round (tmax/dt))-1)) (\((_timeix)) -> let {t = (unround _timeix)*dt;
 t__last = (unround (_timeix-1))*dt;
 v__last = v t__last;
 s__last = s t__last;
 } in ((return ())>>(let {v__next = v t;
 v__mean = v__last+(dt*(k*(th-v__last)));
 v__var = dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)));
 } in (post_incr (((log 1)-(0.500*(log ((2*pi)*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last))))))))-(((v__next-(v__last+(dt*(k*(th-v__last)))))**2)/(2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last))))))))>>((((((return ())>>(let {(_v__next_pos) = v__startpos+(_timeix-1);
 } in grad_incr _v__next_pos (((\((_x)) -> (exp _x)*1) (_v@>_v__next_pos))*(0-((0+((2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))*((2*(v__next-(v__last+(dt*(k*(th-v__last))))))*(1-0))))/((2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))*(2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))))))))>>(grad_incr _eta_pos (((\((_x)) -> (exp _x)*1) (_v@>_eta_pos))*((0-(0+(0.500*((1/((2*pi)*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last))))))*(0+((2*pi)*(0+(dt*((0+((eta*(sqrt v__last))*(0+((sqrt v__last)*1))))+((eta*(sqrt v__last))*(0+((sqrt v__last)*1))))))))))))-((0+(0-(((v__next-(v__last+(dt*(k*(th-v__last)))))**2)*(0+(2*(0+(dt*((0+((eta*(sqrt v__last))*(0+((sqrt v__last)*1))))+((eta*(sqrt v__last))*(0+((sqrt v__last)*1)))))))))))/((2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))*(2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))))))))>>(grad_incr _th_pos (((\((_x)) -> (exp _x)*1) (_v@>_th_pos))*(0-((0+((2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))*((2*(v__next-(v__last+(dt*(k*(th-v__last))))))*(0-(0+(0+(dt*(0+(k*(1-0))))))))))/((2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))*(2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))))))))>>(grad_incr _k_pos (((\((_x)) -> (exp _x)*1) (_v@>_k_pos))*(0-((0+((2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))*((2*(v__next-(v__last+(dt*(k*(th-v__last))))))*(0-(0+(0+(dt*(0+((th-v__last)*1)))))))))/((2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))*(2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))))))))>>(let {(_v__last_pos) = if (_timeix==1) then _v_0_pos else (v__startpos+(_timeix-2));
 } in grad_incr _v__last_pos (((\((_x)) -> (exp _x)*1) (_v@>_v__last_pos))*((0-(0+(0.500*((1/((2*pi)*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last))))))*(0+((2*pi)*(0+(dt*((0+((eta*(sqrt v__last))*(0+(eta*((0.500*(1/(sqrt v__last)))*1)))))+((eta*(sqrt v__last))*(0+(eta*((0.500*(1/(sqrt v__last)))*1)))))))))))))-(((0+((2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))*((2*(v__next-(v__last+(dt*(k*(th-v__last))))))*(0-(1+(0+(dt*(0+(k*(0-1))))))))))+(0-(((v__next-(v__last+(dt*(k*(th-v__last)))))**2)*(0+(2*(0+(dt*((0+((eta*(sqrt v__last))*(0+(eta*((0.500*(1/(sqrt v__last)))*1)))))+((eta*(sqrt v__last))*(0+(eta*((0.500*(1/(sqrt v__last)))*1))))))))))))/((2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))*(2*(dt*((eta*(sqrt v__last))*(eta*(sqrt v__last)))))))))))))>>(let {s__next = s t;
 s__mean = s__last+(dt*(mu*s__last));
 s__var = dt*(((sqrt v__last)*s__last)*((sqrt v__last)*s__last));
 } in (post_incr (((log 1)-(0.500*(log ((2*pi)*s__var))))-(((s__next-s__mean)**2)/(2*s__var))))>>(((return ())>>(grad_incr _mu_pos (1*(0-((0+((2*(dt*(((sqrt v__last)*s__last)*((sqrt v__last)*s__last))))*((2*(s__next-(s__last+(dt*(mu*s__last)))))*(0-(0+(0+(dt*(0+(s__last*1)))))))))/((2*(dt*(((sqrt v__last)*s__last)*((sqrt v__last)*s__last))))*(2*(dt*(((sqrt v__last)*s__last)*((sqrt v__last)*s__last))))))))))>>(let {(_v__last_pos) = if (_timeix==1) then _v_0_pos else (v__startpos+(_timeix-2));
 } in grad_incr _v__last_pos (((\((_x)) -> (exp _x)*1) (_v@>_v__last_pos))*((0-(0+(0.500*((1/((2*pi)*(dt*(((sqrt v__last)*s__last)*((sqrt v__last)*s__last)))))*(0+((2*pi)*(0+(dt*((0+(((sqrt v__last)*s__last)*(0+(s__last*((0.500*(1/(sqrt v__last)))*1)))))+(((sqrt v__last)*s__last)*(0+(s__last*((0.500*(1/(sqrt v__last)))*1)))))))))))))-((0+(0-(((s__next-(s__last+(dt*(mu*s__last))))**2)*(0+(2*(0+(dt*((0+(((sqrt v__last)*s__last)*(0+(s__last*((0.500*(1/(sqrt v__last)))*1)))))+(((sqrt v__last)*s__last)*(0+(s__last*((0.500*(1/(sqrt v__last)))*1))))))))))))/((2*(dt*(((sqrt v__last)*s__last)*((sqrt v__last)*s__last))))*(2*(dt*(((sqrt v__last)*s__last)*((sqrt v__last)*s__last)))))))))))))>>((readSTRef postref)>>=(\(postval) -> (unsafeFreeze gradref)>>=(\(gradval) -> return ((postval,gradval)))))))))))))))))))));
 vToRec = \(theta) -> runP (toList theta) (bindP (fmapP (\((_x)) -> exp _x) headP) (\(k) -> bindP (fmapP (\((_x)) -> exp _x) headP) (\(th) -> bindP (fmapP (\((_x)) -> exp _x) headP) (\(eta) -> bindP headP (\(mu) -> bindP (fmapP (\((_x)) -> exp _x) headP) (\(v_0) -> bindP (fmapP (\(s) -> v_0:(map (\(_x ) -> exp _x) s)) (takeP$((round (tmax/dt))-1))) (\(v__obsSig) -> bindP (returnP ((packL dt 0) v__obsSig)) (\(v) -> returnP (R.X R.:& V R.:= (v) R.:& V_0 R.:= (v_0) R.:& Mu R.:= (mu) R.:& Eta R.:= (eta) R.:& Th R.:= (th) R.:& K R.:= (k))))))))));
 inisam = (gamma 1 1)>>=(\(k) -> (gamma 1 0.100)>>=(\(th) -> (gamma 1 0.100)>>=(\(eta) -> (normal 0 0.100)>>=(\(mu) -> (gamma 1 0.100)>>=(\(v_0) -> (uniform 0.000 2.000)>>=(\(s_0) -> (wiener dt tmax)>>=(\(w2) -> (wiener dt tmax)>>=(\(w1) -> let {v = solveODE (\v-> \((t::Double)) -> (k*(th-v))+((eta*(sqrt v))*((d dt w1) t))) tmax dt v_0;
s = solveODE (\s-> \((t::Double)) -> (mu*s)+(((sqrt (v t))*s)*((d dt w2) t))) tmax dt s_0;
} in return (concat (((log k):[]):(((log th):[]):(((log eta):[]):((mu:[]):(((log v_0):[]):((map (\((_x)) -> log _x) (sigTail v)):[])))))))))))))));

 } in R.X R.:& Inisam R.:= (inisam) R.:& VToRec R.:= (vToRec) R.:& Postgrad R.:= (postgrad) R.:& Posterior R.:= (posterior)
  let post :: ((Vector Double) -> Double)
      post = (prims!!!Posterior) . VS.toList
  let postgrad :: ((Vector Double) -> ((Double,(Vector Double))))
      postgrad = prims!!!Postgrad
  let vtorec :: ((Vector Double) -> ((R.X R.:& V R.::: (Double -> Double) R.:& V_0 R.::: Double R.:& Mu R.::: Double R.:& Eta R.::: Double R.:& Th R.::: Double R.:& K R.::: Double) (Id KindStar)))
      vtorec = prims!!!VToRec
  let inisam :: Prob (Vector Double)
      inisam = fmap (VS.fromList) $ prims!!!Inisam
  return (post, postgrad,vtorec,inisam)


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module DFT.FFI where

import qualified Foreign.C.Types as C
import Foreign.C.String (CString)
import Foreign.Ptr (Ptr)
import Data.Complex (Complex)

#include <fftw3.h>

type FFTWFlag = C.CUInt

#{enum FFTWFlag,
 , c_measure         = FFTW_MEASURE
 , c_destroy_input   = FFTW_DESTROY_INPUT
 , c_unaligned       = FFTW_UNALIGNED
 , c_conserve_memory = FFTW_CONSERVE_MEMORY
 , c_exhaustive      = FFTW_EXHAUSTIVE
 , c_preserve_input  = FFTW_PRESERVE_INPUT
 , c_patient         = FFTW_PATIENT
 , c_estimate        = FFTW_ESTIMATE
 }

type FFTWSign = C.CInt

#{enum FFTWSign,
 , c_forward = FFTW_FORWARD
 , c_backward = FFTW_BACKWARD
 }

type FFTWKind = C.CInt

#{enum FFTWKind,
 , c_r2hc    = FFTW_R2HC
 , c_hc2r    = FFTW_HC2R
 , c_dht     = FFTW_DHT
 , c_redft00 = FFTW_REDFT00
 , c_redft10 = FFTW_REDFT10
 , c_redft01 = FFTW_REDFT01
 , c_redft11 = FFTW_REDFT11
 , c_rodft00 = FFTW_RODFT00
 , c_rodft10 = FFTW_RODFT10
 , c_rodft01 = FFTW_RODFT01
 , c_rodft11 = FFTW_RODFT11
 }

-- | A plan is an opaque foreign object.
type Plan = Ptr FFTWPlan

type FFTWPlan = ()

-- We use "safe" calls for anything which could take a while so that it won't block
-- other Haskell threads.

-- | Simple plan execution
foreign import ccall safe "fftw3.h fftw_execute" c_execute
    :: Plan -> IO ()

-- Execute a plan on different memory than the plan was created for.
-- Alignment /must/ be the same.  If we parallelize a transform of
-- multi-dimensional data by making separate calls within an un-transformed
-- dimension, it is possible that the alignment constraint would not be
-- fulfilled.  However, this only poses a problem for real transforms with odd
-- transform dimension.
foreign import ccall safe "fftw3.h fftw_execute_dft" c_execute_dft
    :: Plan -> Ptr (Complex Double) -> Ptr (Complex Double) -> IO ()
foreign import ccall safe "fftw3.h fftw_execute_dft_r2c" c_execute_dft_r2c
    :: Plan -> Ptr Double -> Ptr (Complex Double) -> IO ()
foreign import ccall safe "fftw3.h fftw_execute_dft_c2r" c_execute_dft_c2r
    :: Plan -> Ptr (Complex Double) -> Ptr Double -> IO ()
foreign import ccall safe "fftw3.h fftw_execute_r2r" c_execute_r2r
    :: Plan -> Ptr Double -> Ptr Double -> IO ()

foreign import ccall safe "fftw3.h fftw_export_wisdom_to_string"
        c_export_wisdom_string :: IO CString

foreign import ccall safe "fftw3.h fftw_export_wisdom_to_filename"
        c_export_wisdom_filename :: CString -> IO C.CInt

foreign import ccall safe "fftw3.h fftw_import_wisdom_from_string"
        c_import_wisdom_string :: CString -> IO C.CInt

foreign import ccall safe "fftw3.h fftw_import_wisdom_from_filename"
        c_import_wisdom_filename :: CString -> IO C.CInt

foreign import ccall safe "fftw3.h fftw_import_system_wisdom"
        c_import_wisdom_system :: IO C.CInt

-- | Frees memory allocated by 'fftw_malloc'.  Currently, we only need this to
-- free the wisdom string.
foreign import ccall safe "fftw3.h fftw_free" c_free :: Ptr a -> IO ()

foreign import ccall safe "fftw3.h fftw_destroy_plan" c_destroy_plan ::  Plan -> IO ()

foreign import ccall safe "fftw3.h fftw_cleanup" c_cleanup :: IO ()

foreign import ccall safe "fftw3.h fftw_plan_dft_2d" c_plan_dft_2d :: C.CInt -> C.CInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> C.CInt -> FFTWFlag -> IO Plan

foreign import ccall safe "fftw3.h fftw_plan_dft_1d" c_plan_dft_1d :: C.CInt -> Ptr (Complex Double) -> Ptr (Complex Double) -> C.CInt -> FFTWFlag -> IO Plan

foreign import ccall safe "fftw3.h fftw_plan_dft_r2c_1d" c_plan_dft_r2c_1d :: C.CInt -> Ptr C.CDouble -> Ptr (Complex Double) -> FFTWFlag -> IO Plan

foreign import ccall safe "fftw3.h fftw_plan_many_dft" c_plan_many_dft :: C.CInt -> Ptr C.CInt -> C.CInt -> Ptr (Complex Double) -> Ptr C.CInt -> C.CInt -> C.CInt -> Ptr (Complex Double) -> Ptr C.CInt -> C.CInt -> C.CInt -> C.CInt -> FFTWFlag -> IO Plan

foreign import ccall safe "fftw3.h fftw_plan_dft_r2c_2d" c_plan_dft_r2c_2d :: C.CInt -> C.CInt -> Ptr C.CDouble -> Ptr (Complex Double) -> FFTWFlag -> IO Plan


{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances #-}

{-| Various utiliy signal processing functions -}
module SDR.Util (
    -- * Classes
    Mult,
    mult,

    -- * Conversion to floating point for reception
    -- ** RTLSDR
    interleavedIQUnsigned256ToFloat,
    interleavedIQUnsignedByteToFloat,
    interleavedIQUnsignedByteToFloatSSE,
    interleavedIQUnsignedByteToFloatAVX,
    interleavedIQUnsignedByteToFloatFast,

    -- ** BladeRF
    interleavedIQSigned2048ToFloat,
    interleavedIQSignedWordToFloat,
    interleavedIQSignedWordToFloatSSE,
    interleavedIQSignedWordToFloatAVX,
    interleavedIQSignedWordToFloatFast,

    -- * Conversion from floating point for transmission
    -- ** BladeRF
    complexFloatToInterleavedIQSigned2048,
    complexFloatToInterleavedIQSignedWord,

    -- * Scaling
    scaleC,
    scaleCSSE,
    scaleCAVX,
    scaleFast,

    -- * Mapping over complex numbers
    cplxMap,

    -- * Frequency shifting
    halfBandUp,
    quarterBandUp,

    -- * Data streams
    streamString,
    streamRandom,

    -- * Automatic gain control
    agc,
    agcPipe,

    -- * Squashing initialization into the Pipe
    combineInit,
    combineInitTrans
    ) where

import           Foreign.C.Types
import           Data.Complex
import qualified Data.Vector.Generic          as VG
import qualified Data.Vector.Generic.Mutable  as VGM
import qualified Data.Vector.Storable         as VS
import qualified Data.Vector.Storable.Mutable as VSM
import           Control.Monad.Primitive
import           Data.Coerce
import           Foreign.Ptr
import           System.IO.Unsafe
import           Foreign.Storable.Complex
import           Control.Monad
import qualified System.Random.MWC as R
import           Data.Bits
import           Pipes
import qualified Pipes.Prelude as P
import           Data.Word
import           Foreign.Storable
import           Control.Arrow as A
import           Data.Tuple

import           SDR.CPUID
import           SDR.VectorUtils
import           SDR.PipeUtils

-- | A class for things that can be multiplied by a scalar.
class Mult a b where
    mult :: a -> b -> a

instance (Num a) => Mult a a where
    mult = (*)

instance (Num a) => Mult (Complex a) a where
    mult (x :+ y) z = (x * z) :+ (y * z)

-- | Create a vector of complex floating samples from a vector of interleaved I Q components. Each input element ranges from 0 to 255. This is the format that RTLSDR devices use.
{-# INLINE interleavedIQUnsigned256ToFloat #-}
interleavedIQUnsigned256ToFloat :: (Num a, Integral a, Num b, Fractional b, VG.Vector v1 a, VG.Vector v2 (Complex b)) => v1 a -> v2 (Complex b)
interleavedIQUnsigned256ToFloat input = VG.generate (VG.length input `quot` 2) convert
    where
    {-# INLINE convert #-}
    convert idx  = convert' (input `VG.unsafeIndex` (2 * idx)) :+ convert' (input `VG.unsafeIndex` (2 * idx + 1))
    {-# INLINE convert' #-}
    convert' val = (fromIntegral val - 128) / 128

foreign import ccall unsafe "convertC"
    convertC_c :: CInt -> Ptr CUChar -> Ptr CFloat -> IO ()

-- | Same as `interleavedIQUnsigned256ToFloat` but written in C and specialized for unsigned byte inputs and Float outputs.
interleavedIQUnsignedByteToFloat :: VS.Vector CUChar -> VS.Vector (Complex Float)
interleavedIQUnsignedByteToFloat inBuf = unsafePerformIO $ do
    outBuf <- VGM.new $ VG.length inBuf `quot` 2
    VS.unsafeWith inBuf $ \iPtr ->
        VSM.unsafeWith (coerce outBuf) $ \oPtr ->
            convertC_c (fromIntegral $ VG.length inBuf) iPtr oPtr
    VG.freeze outBuf

foreign import ccall unsafe "convertCSSE"
    convertCSSE_c :: CInt -> Ptr CUChar -> Ptr CFloat -> IO ()

-- | Same as `interleavedIQUnsigned256ToFloat` but written in C using SSE intrinsics and specialized for unsigned byte inputs and Float outputs.
interleavedIQUnsignedByteToFloatSSE :: VS.Vector CUChar -> VS.Vector (Complex Float)
interleavedIQUnsignedByteToFloatSSE inBuf = unsafePerformIO $ do
    outBuf <- VGM.new $ VG.length inBuf `quot` 2
    VS.unsafeWith inBuf $ \iPtr ->
        VSM.unsafeWith (coerce outBuf) $ \oPtr ->
            convertCSSE_c (fromIntegral $ VG.length inBuf) iPtr oPtr
    VG.freeze outBuf

foreign import ccall unsafe "convertCAVX"
    convertCAVX_c :: CInt -> Ptr CUChar -> Ptr CFloat -> IO ()

-- | Same as `interleavedIQUnsigned256ToFloat` but written in C using AVX intrinsics and specialized for unsigned byte inputs and Float outputs.
interleavedIQUnsignedByteToFloatAVX :: VS.Vector CUChar -> VS.Vector (Complex Float)
interleavedIQUnsignedByteToFloatAVX inBuf = unsafePerformIO $ do
    outBuf <- VGM.new $ VG.length inBuf `quot` 2
    VS.unsafeWith inBuf $ \iPtr ->
        VSM.unsafeWith (coerce outBuf) $ \oPtr ->
            convertCAVX_c (fromIntegral $ VG.length inBuf) iPtr oPtr
    VG.freeze outBuf

-- | Same as `interleavedIQUnsigned256ToFloat` but uses the fastest SIMD instruction set your processor supports and specialized for unsigned byte inputs and Float outputs.
interleavedIQUnsignedByteToFloatFast :: CPUInfo -> VS.Vector CUChar -> VS.Vector (Complex Float)
interleavedIQUnsignedByteToFloatFast info = featureSelect info interleavedIQUnsignedByteToFloat [(hasAVX2, interleavedIQUnsignedByteToFloatAVX), (hasSSE42, interleavedIQUnsignedByteToFloatSSE)]

-- | Create a vector of complex float samples from a vector of interleaved I Q components. Each input element ranges from -2048 to 2047. This is the format that the BladeRF uses.
{-# INLINE interleavedIQSigned2048ToFloat #-}
interleavedIQSigned2048ToFloat :: (Num a, Integral a, Num b, Fractional b, VG.Vector v1 a, VG.Vector v2 (Complex b)) => v1 a -> v2 (Complex b)
interleavedIQSigned2048ToFloat input = VG.generate (VG.length input `quot` 2) convert
    where
    {-# INLINE convert #-}
    convert idx  = convert' (input `VG.unsafeIndex` (2 * idx)) :+ convert' (input `VG.unsafeIndex` (2 * idx + 1))
    {-# INLINE convert' #-}
    convert' val = fromIntegral val / 2048

foreign import ccall unsafe "convertCBladeRF"
    convertCBladeRF_c :: CInt -> Ptr CShort -> Ptr CFloat -> IO ()

-- | Same as `interleavedIQUnsigned256ToFloat` but written in C and specialized for signed short inputs and Float outputs.
interleavedIQSignedWordToFloat :: VS.Vector CShort -> VS.Vector (Complex Float)
interleavedIQSignedWordToFloat inBuf = unsafePerformIO $ do
    outBuf <- VGM.new $ VG.length inBuf `quot` 2
    VS.unsafeWith inBuf $ \iPtr ->
        VSM.unsafeWith (coerce outBuf) $ \oPtr ->
            convertCBladeRF_c (fromIntegral $ VG.length inBuf) iPtr oPtr
    VG.freeze outBuf

foreign import ccall unsafe "convertCSSEBladeRF"
    convertCSSEBladeRF_c :: CInt -> Ptr CShort -> Ptr CFloat -> IO ()

-- | Same as `interleavedIQUnsigned256ToFloat` but written in C using SSE intrinsics and specialized for signed short inputs and Float outputs.
interleavedIQSignedWordToFloatSSE :: VS.Vector CShort -> VS.Vector (Complex Float)
interleavedIQSignedWordToFloatSSE inBuf = unsafePerformIO $ do
    outBuf <- VGM.new $ VG.length inBuf `quot` 2
    VS.unsafeWith inBuf $ \iPtr ->
        VSM.unsafeWith (coerce outBuf) $ \oPtr ->
            convertCSSEBladeRF_c (fromIntegral $ VG.length inBuf) iPtr oPtr
    VG.freeze outBuf

foreign import ccall unsafe "convertCAVXBladeRF"
    convertCAVXBladeRF_c :: CInt -> Ptr CShort -> Ptr CFloat -> IO ()

-- | Same as `interleavedIQUnsigned256ToFloat` but written in C using AVX intrinsics and specialized for signed short inputs and Float outputs.
interleavedIQSignedWordToFloatAVX :: VS.Vector CShort -> VS.Vector (Complex Float)
interleavedIQSignedWordToFloatAVX inBuf = unsafePerformIO $ do
    outBuf <- VGM.new $ VG.length inBuf `quot` 2
    VS.unsafeWith inBuf $ \iPtr ->
        VSM.unsafeWith (coerce outBuf) $ \oPtr ->
            convertCAVXBladeRF_c (fromIntegral $ VG.length inBuf) iPtr oPtr
    VG.freeze outBuf

-- | Same as `interleavedIQSigned2048ToFloat` but uses the fastest SIMD instruction set your processor supports and specialized for signed short inputs and Float outputs.
interleavedIQSignedWordToFloatFast :: CPUInfo -> VS.Vector CShort -> VS.Vector (Complex Float)
interleavedIQSignedWordToFloatFast info = featureSelect info interleavedIQSignedWordToFloat [(hasAVX2, interleavedIQSignedWordToFloatAVX), (hasSSE42, interleavedIQSignedWordToFloatSSE)]

-- | Create a vector of interleaved I Q component integral samples from a vector of complex Floats. Each input ranges from -2048 to 2047. This is the format the BladeRF uses.
complexFloatToInterleavedIQSigned2048 :: (Integral b, RealFrac a, VG.Vector v1 (Complex a), VG.Vector v2 b) => v1 (Complex a) -> v2 b
complexFloatToInterleavedIQSigned2048 input = VG.generate (VG.length input * 2) convert
    where
    {-# INLINE convert #-}
    convert idx
        | even idx = convert' $ realPart (input `VG.unsafeIndex` (idx `quot` 2))
        | odd  idx = convert' $ imagPart (input `VG.unsafeIndex` (idx `quot` 2))
    {-# INLINE convert' #-}
    convert' val = round $ val * 2048

foreign import ccall unsafe "convertBladeRFTransmit"
    convertBladeRFTransmit_c :: CInt -> Ptr CFloat -> Ptr CShort -> IO ()

-- | Same as `complexFloatToInterleavedIQSigned2048` but written in C and specialized for Float inputs and signed short outputs.
complexFloatToInterleavedIQSignedWord :: VS.Vector (Complex Float) -> VS.Vector CShort
complexFloatToInterleavedIQSignedWord inBuf = unsafePerformIO $ do
    outBuf <- VGM.new $ VG.length inBuf * 2
    VS.unsafeWith (coerce inBuf) $ \iPtr ->
        VSM.unsafeWith outBuf $ \oPtr ->
            convertBladeRFTransmit_c (fromIntegral $ VG.length inBuf * 2) iPtr oPtr
    VG.freeze outBuf

-- | Scaling
foreign import ccall unsafe "scale"
    scale_c :: CInt -> CFloat -> Ptr CFloat -> Ptr CFloat -> IO ()

-- | Scale a vector, written in C
scaleC :: Float                      -- ^ Scale factor
       -> VS.Vector Float            -- ^ Input vector
       -> VS.MVector RealWorld Float -- ^ Output vector
       -> IO ()
scaleC factor inBuf outBuf =
    VS.unsafeWith (coerce inBuf) $ \iPtr ->
        VSM.unsafeWith (coerce outBuf) $ \oPtr ->
            scale_c (fromIntegral (VG.length inBuf)) (coerce factor) iPtr oPtr

foreign import ccall unsafe "scaleSSE"
    scaleSSE_c :: CInt -> CFloat -> Ptr CFloat -> Ptr CFloat-> IO ()

-- | Scale a vector, written in C using SSE intrinsics
scaleCSSE :: Float                      -- ^ Scale factor
          -> VS.Vector Float            -- ^ Input vector
          -> VS.MVector RealWorld Float -- ^ Output vector
          -> IO ()
scaleCSSE factor inBuf outBuf =
    VS.unsafeWith (coerce inBuf) $ \iPtr ->
        VSM.unsafeWith (coerce outBuf) $ \oPtr ->
            scaleSSE_c (fromIntegral (VG.length inBuf)) (coerce factor) iPtr oPtr

foreign import ccall unsafe "scaleAVX"
    scaleAVX_c :: CInt -> CFloat -> Ptr CFloat -> Ptr CFloat -> IO ()

-- | Scale a vector, written in C using AVX intrinsics
scaleCAVX :: Float                      -- ^ Scale factor
          -> VS.Vector Float            -- ^ Input vector
          -> VS.MVector RealWorld Float -- ^ Output vector
          -> IO ()
scaleCAVX factor inBuf outBuf =
    VS.unsafeWith (coerce inBuf) $ \iPtr ->
        VSM.unsafeWith (coerce outBuf) $ \oPtr ->
            scaleAVX_c (fromIntegral (VG.length inBuf)) (coerce factor) iPtr oPtr

-- | Scale a vector. Uses the fastest SIMD instruction set your processor supports.
scaleFast :: CPUInfo -> Float -> VS.Vector Float -> VS.MVector RealWorld Float -> IO ()
scaleFast info = featureSelect info scaleC [(hasAVX, scaleCAVX), (hasSSE42, scaleCSSE)]

-- | Apply a function to both parts of a complex number
cplxMap :: (a -> b)  -- ^ The function
        -> Complex a -- ^ Input complex number
        -> Complex b -- ^ Output complex number
cplxMap f (x :+ y) = f x :+ f y

-- | Multiplication by this vector shifts all frequencies up by 1/2 of the sampling frequency
halfBandUp :: (VG.Vector v n, Num n)
           => Int -- ^ The length of the Vector
           -> v n
halfBandUp size = VG.generate size func
    where
    func idx
        | even idx  = 1
        | otherwise = -1

-- | Multiplication by this vector shifts all frequencies up by 1/4 of the sampling frequency
quarterBandUp :: (VG.Vector v (Complex n), Num n)
              => Int -- ^ The length of the Vector
              -> v (Complex n)
quarterBandUp size = VG.generate size func
    where
    func idx
        | m == 0 = 1    :+ 0
        | m == 1 = 0    :+ 1
        | m == 2 = (-1) :+ 0
        | m == 3 = 0    :+ (-1)
        where
        m = idx `mod` 4

-- | A Producer that streams vectors of the bits that make up the string argument concatenated repeatedly. Each bit is encoded as a float with value (+1) for 1 and (-1) for 0.
streamString :: forall m b. (FiniteBits b, Monad m)
             => [b] -- ^ The string whose bits are to be streamed
             -> Int -- ^ The size of each streamed vector
             -> Producer (VS.Vector Float) m ()
streamString str size = P.unfoldr (return . Right . func) (str, 0)
    where
    bitsPerChar = finiteBitSize (undefined :: b)
    toFloat :: Bool -> Float
    toFloat x   = if x then 1 else (-1)
    func = vUnfoldr size funcy
        where
        funcy ([], offsetChar) = funcy (str, 0)
        funcy (rem@(x:xs), offsetChar)
            | offsetChar == bitsPerChar = funcy (xs, 0)
            | otherwise                 = (toFloat $ testBit x offsetChar, (rem, offsetChar + 1))

-- | A Producer that streams vectors of random bits. Each bit is encoded as a float with value (+1) for 1 and (-1) for 0.
streamRandom :: forall m. PrimMonad m
             => Int -- ^ The size of each streamed vector
             -> Producer (VS.Vector Float) m ()
streamRandom size = do
    gen   <- lift R.create
    start <- lift $ R.uniform gen
    P.unfoldr (liftM Right . func gen) (start, 0)
    where
    toFloat :: Bool -> Float
    toFloat x   = if x then 1 else (-1)
    func :: R.Gen (PrimState m) -> (Word64, Int) -> m (VS.Vector Float, (Word64, Int))
    func gen = vUnfoldrM size funcy
        where
        funcy (current, offset) = do
            let res =  toFloat $ testBit current offset
            if offset == 63 then do
                current' <- R.uniform gen
                return (res, (current', 0))
            else return (res, (current, offset+1))

(a :+ b) `cdiv` y = (a/y) :+ (b/y)
(a :+ b) `cmul` y = (a*y) :+ (b*y)

-- | Simple automatic gain control
agc :: (Num a, Storable a, RealFloat a)
    => a                          -- ^ a
    -> a                          -- ^ reference
    -> a                          -- ^ initial state
    -> VS.Vector (Complex a)      -- ^ input vector
    -> (a, VS.Vector (Complex a)) -- ^ (final state, output vector)
agc mu reference state input = A.first snd $ swap $ vUnfoldr (VS.length input) go (0, state)
    where
    go (offset, state) =
        let
            corrected = (input VS.! offset) `cmul` state
            state'    = state + mu * (reference - magnitude corrected)
        in  (corrected, (offset + 1, state'))

-- | Simple automatic gain control pipe
agcPipe :: (Num a, Storable a, RealFloat a, Monad m)
        => a -- ^ a
        -> a -- ^ reference
        -> Pipe (VS.Vector (Complex a)) (VS.Vector (Complex a)) m ()
agcPipe mu reference = pMapAccum (agc mu reference) 1

-- | Specializes to combineInit :: IO (Pipe a b IO ()) -> Pipe a b IO ()
combineInit :: (Monad m, MonadTrans t, Monad (t m)) => m (t m a) -> t m a
combineInit = join . lift

-- | Specializes to combineInitTrans :: EitherT String IO (Pipe a b IO ()) -> Pipe a b (EitherT String IO) ()
combineInitTrans :: (Monad (t1 m), Monad (t (t1 m)), MonadTrans t, Monad m, MFunctor t, MonadTrans t1) => (t1 m) ((t m) a) -> t (t1 m) a
combineInitTrans = combineInit . fmap (hoist lift)


{-# LANGUAGE TypeFamilies #-}
-- | The "pair of vectors" implementation of vectors of dual numbers.
-- This is much faster than "vector of pairs" implementation, but terribly
-- hard to use in case of scalar dual numbers, in particular to efficiently
-- construct in @ST@ such pairs of vectors from monadic operations that create
-- vector elements (a bit easier in @IO@, but so far we managed to avoid @IO@).
-- For this reason, this representation is currently used only to represent
-- the inputs of functions, that is, dual numbers with initial values
-- of parameters and, in case of dual components that are delta-expressions,
-- with @Delta@ variables assigned to each.
module HordeAd.Core.PairOfVectors
  ( DualNumberVariables
  , makeDualNumberVariables, var0, vars, var1, var2, varX, varS
  , ifoldMDual', foldMDual', ifoldlDual', foldlDual'
  ) where

import Prelude

import qualified Data.Array.DynamicS as OT
import qualified Data.Array.ShapedS as OS
import qualified Data.Strict.Vector as Data.Vector
import qualified Data.Vector.Generic as V
import           GHC.Exts (inline)
import           Numeric.LinearAlgebra (Matrix, Vector)

import HordeAd.Core.DualClass (Dual)
import HordeAd.Core.DualNumber

-- These are optimized as "pair of vectors" representing vectors of @DualNumber@
-- in an efficient way (especially, or only, with gradient descent,
-- where the vectors are reused in some ways).

type DualNumberVariables d r =
  ( Domain0 r
  , Data.Vector.Vector (Dual d r)
  , Domain1 r
  , Data.Vector.Vector (Dual d (Vector r))
  , Domain2 r
  , Data.Vector.Vector (Dual d (Matrix r))
  , DomainX r
  , Data.Vector.Vector (Dual d (OT.Array r))
  )

makeDualNumberVariables
  :: Domains r
  -> ( Data.Vector.Vector (Dual d r)
     , Data.Vector.Vector (Dual d (Vector r))
     , Data.Vector.Vector (Dual d (Matrix r))
     , Data.Vector.Vector (Dual d (OT.Array r)) )
  -> DualNumberVariables d r
{-# INLINE makeDualNumberVariables #-}
makeDualNumberVariables (params0, params1, params2, paramsX)
                        (vs0, vs1, vs2, vsX)
  = (params0, vs0, params1, vs1, params2, vs2, paramsX, vsX)

var0 :: IsScalar d r => DualNumberVariables d r -> Int -> DualNumber d r
var0 (vValue, vVar, _, _, _, _, _, _) i = D (vValue V.! i) (vVar V.! i)

-- Unsafe, but handy for toy examples.
vars :: IsScalar d r => DualNumberVariables d r -> [DualNumber d r]
vars vec = map ( var0 vec) [0 ..]

var1 :: DualNumberVariables d r -> Int -> DualNumber d (Vector r)
var1 (_, _, vValue, vVar, _, _, _, _) i = D (vValue V.! i) (vVar V.! i)

var2 :: DualNumberVariables d r -> Int -> DualNumber d (Matrix r)
var2 (_, _, _, _, vValue, vVar, _, _) i = D (vValue V.! i) (vVar V.! i)

varX :: DualNumberVariables d r -> Int -> DualNumber d (OT.Array r)
varX (_, _, _, _, _, _, vValue, vVar) i = D (vValue V.! i) (vVar V.! i)

varS :: (IsScalar d r, OS.Shape sh)
     => DualNumberVariables d r -> Int -> DualNumber d (OS.Array sh r)
varS (_, _, _, _, _, _, vValue, vVar) i =
  inline fromXS $ D (vValue V.! i) (vVar V.! i)

ifoldMDual' :: forall a d r m. (Monad m, IsScalar d r)
             => (a -> Int -> DualNumber d r -> m a)
             -> a
             -> DualNumberVariables d r
             -> m a
{-# INLINE ifoldMDual' #-}
ifoldMDual' f a (vecR, vecD, _, _, _, _, _, _) = do
  let g :: a -> Int -> r -> m a
      g !acc i valX = do
        let !b = D valX (vecD V.! i)
        f acc i b
  V.ifoldM' g a vecR

foldMDual' :: forall a d r m. (Monad m, IsScalar d r)
            => (a -> DualNumber d r -> m a)
            -> a
            -> DualNumberVariables d r
            -> m a
{-# INLINE foldMDual' #-}
foldMDual' f a (vecR, vecD, _, _, _, _, _, _) = do
  let g :: a -> Int -> r -> m a
      g !acc i valX = do
        let !b = D valX (vecD V.! i)
        f acc b
  V.ifoldM' g a vecR

ifoldlDual' :: forall a d r. IsScalar d r
             => (a -> Int -> DualNumber d r -> a)
             -> a
             -> DualNumberVariables d r
             -> a
{-# INLINE ifoldlDual' #-}
ifoldlDual' f a (vecR, vecD, _, _, _, _, _, _) = do
  let g :: a -> Int -> r -> a
      g !acc i valX =
        let !b = D valX (vecD V.! i)
        in f acc i b
  V.ifoldl' g a vecR

foldlDual' :: forall a d r. IsScalar d r
            => (a -> DualNumber d r -> a)
            -> a
            -> DualNumberVariables d r
            -> a
{-# INLINE foldlDual' #-}
foldlDual' f a (vecR, vecD, _, _, _, _, _, _) = do
  let g :: a -> Int -> r -> a
      g !acc i valX =
        let !b = D valX (vecD V.! i)
        in f acc b
  V.ifoldl' g a vecR


{- |
   Description :  Parse arguments needed for the bmm simulator
   Copyright   :  (c) Dominik Schrempf 2017
   License     :  GPLv3

   Maintainer  :  dominik.schrempf@gmail.com
   Stability   :  unstable
   Portability :  non-portable (not tested)

Provides a data type with all options and a parser.

* Changelog

-}

module ArgParse
  ( BMMArgs(..)
  , parseBMMArgs
  ) where

import qualified Data.Attoparsec.Text         as A
import           Data.Semigroup               ((<>))
import           Data.Text                    (pack, unpack)
import qualified Defaults                     as Def
import           DNAModel                     (DNAModelSpec(..))
import           RateMatrix                   (StationaryDist)
import           Numeric.LinearAlgebra        (norm_1, size, vector)
import           Options.Applicative
import qualified Text.PrettyPrint.ANSI.Leijen as Doc
import           Tools                        (nearlyEq)

-- Convenience function to read in more complicated command line options with
-- attoparsec and optparse
-- (https://github.com/pcapriotti/optparse-applicative#option-readers).
attoReadM :: A.Parser a -> ReadM a
attoReadM p = eitherReader (A.parseOnly p . pack)

-- | Combined option and argument data structure.
data BMMArgs = BMMArgs
  { -- | Name of output counts file.
    outFileName    :: String
    -- | Mutation model specification.
  , dnaModelSpec   :: DNAModelSpec
    -- | Shape parameter of gamma rate heterogeneity.
  , gammaShape     :: Maybe Double
    -- | Number of gamma rate heterogeneity categories.
  , gammaNCat      :: Maybe Int
    -- | Virtual population size of boundary mutation model.
  , popSize        :: Int
    -- | Heterozygosity value (2Nu).
  , heterozygosity :: Double
    -- | Tree height in boundary mutation model units.
  , treeHeight     :: Double
    -- | Tree type or scenario (ILS, Yule).
  , treeType       :: String
    -- | Yule speciation rate.
  , treeYuleRate   :: Maybe Double
    -- | Number of sites to simulate.
  , nSites         :: Int
    -- | Seed of the random number generator.
  , seed           :: String }

-- Composition of all options.
bmSimOptions :: Parser BMMArgs
bmSimOptions = BMMArgs
  <$> outFileNameOpt
  <*> dnaModelOpt
  <*> gammaShapeOpt
  <*> gammaNCatOpt
  <*> popSizeOpt
  <*> heterozygosityOpt
  <*> treeHeightOpt
  <*> treeTypeOpt
  <*> treeYuleRateOpt
  <*> nSitesOpt
  <*> seedOpt

-- | The impure IO action that reads the arguments and prints out help if
-- needed. Maybe put this into Main.hs?
parseBMMArgs :: IO BMMArgs
parseBMMArgs = execParser $
  info (helper <*> bmSimOptions)
  (fullDesc
    <> progDesc "Simulate count files using the boundary mutation model."
    <> header "Boundary mutation model simulator"
    <> footerDoc models )
  where
    models = Just $ foldl1 (Doc.<$>) (map Doc.text strs)
    strs   = [ "Available mutation models:"

             , "  - HKY model with transition to transversion ratio kappa and a state frequency vector."
             , "    Specified with \"-m HKY[DOUBLE][DOUBLE,DOUBLE,DOUBLE,DOUBLE]\"."
             , "  - GTR model with five rate parameters and state frequency vector."
             , "    Specified with \"-m HKY[DOUBLE,DOUBLE,DOUBLE,DOUBLE,DOUBLE][DOUBLE,DOUBLE,DOUBLE,DOUBLE]\"."
             , ""
             , "Note: The state frequency vector has to sum up to 1.0 and only has three free parameters." ]

-- General things and options.
outFileNameOpt :: Parser String
outFileNameOpt = strOption
  ( long "output"
    <> short 'o'
    <> metavar "NAME"
    <> value Def.outFileName
    <> showDefault
    <> help "Write output files to NAME.[cf.gz|log|tree]" )

-- Read a stationary frequency of the form `pi_A,pi_C,pi_G,...`.
parseStateFreq :: A.Parser StationaryDist
parseStateFreq = do
  _ <- A.char '['
  f <- vector <$> A.sepBy A.double (A.char ',')
  _ <- A.char ']'
  if size f /= nAlleles
    then error "Length of stationary frequency vector is faulty, only DNA models are supported."
  else if nearlyEq 1e-6 (norm_1 f) 1.0 then return f
    else error $ "Stationary frequencies sum to " ++ show (norm_1 f) ++ " but should sum to 1.0."
    -- Nucleotide count hard coded. See `BndState.nAlleles`. However, I cannot
    -- take different numbers depending on the mutation model because optparse has
    -- an applicative interface and not a monadic one. Also, allowing vectors of
    -- arbitrary size is undesirable because of meaningless error messages.
    where nAlleles = 4

dnaModelOpt :: Parser DNAModelSpec
dnaModelOpt = option (attoReadM parseDNAModelSpec)
  ( long "mutation-model"
    <> short 'm'
    <> metavar "MODEL"
    <> value Def.dnaModelSpec
    <> showDefault
    <> help "Set the mutation model; available models are shown below" )

parseParams :: A.Parser [Double]
parseParams = do
  _ <- A.char '['
  params <- A.sepBy1 A.double (A.char ',')
  _ <- A.char ']'
  return params

parseDNAModelSpec :: A.Parser DNAModelSpec
parseDNAModelSpec = do
  m  <- A.takeWhile (/= '[')
  case unpack m of
       "JC" -> return JC
       "HKY" -> do
         ps <- parseParams
         f  <- parseStateFreq
         if length ps /= 1
           then error "HKY model only has one parameter, kappa."
           else return $ HKY (head ps) f
       "GTR" -> do
         ps <- parseParams
         f  <- parseStateFreq
         if length ps /= 5
           then error "GTR model has five parameters."
           else return $ GTR (head ps) (ps !! 1) (ps !! 2) (ps !! 3) (ps !! 4) f
       _ -> error "Model string could not be parsed."

gammaShapeOpt :: Parser (Maybe Double)
gammaShapeOpt = optional $ option auto
  ( long "gamma-shape"
    <> metavar "DOUBLE"
    <> help "Activate gamma rate heterogeneity and set gamma shape parameter (default: off)" )

gammaNCatOpt :: Parser (Maybe Int)
gammaNCatOpt = optional $ option auto
  ( long "gamma-ncat"
    <> metavar "INT"
    <> help "Set the number of gamma rate categories (no default value)" )

popSizeOpt :: Parser Int
popSizeOpt = option auto
  ( short 'N'
    <> metavar "DOUBLE"
    <> value Def.popSize
    <> showDefault
    <> help "Set the virtual population size" )

heterozygosityOpt :: Parser Double
heterozygosityOpt = option auto
  ( long "heterozygosity"
    <> short 't'
    <> metavar "DOUBLE"
    <> value Def.heterozygosity
    <> showDefault
    <> help "Set heterozygosity" )

treeHeightOpt :: Parser Double
treeHeightOpt = option auto
  ( long "tree-height"
    <> short 'H'
    <> metavar "DOUBLE"
    <> value Def.treeHeight
    <> showDefault
    <> help "Set tree height [average number of substitutions]" )

treeTypeOpt :: Parser String
treeTypeOpt = strOption
  ( long "tree-type"
    <> metavar "TYPE"
    <> value Def.treeType
    <> showDefault
    <> help "Set tree type; ILS or Yule")

treeYuleRateOpt :: Parser (Maybe Double)
treeYuleRateOpt = optional $ option auto
  ( long "tree-yule-rate"
  <> metavar "DOUBLE"
  <> help "Set the speciation rate of Yule tree (no default value)")

nSitesOpt :: Parser Int
nSitesOpt = option auto
  ( long "nsites"
    <> short 'n'
    <> metavar "INT"
    <> value Def.nSites
    <> showDefault
    <> help "Set number of sites to simulate" )

seedOpt :: Parser String
seedOpt = strOption
  ( long "seed"
    <> short 's'
    <> metavar "INT"
    <> value "random"
    <> showDefault
    <> help "Set seed for the random number generator" )


{-# LANGUAGE ForeignFunctionInterface #-}
module Grenade.Layers.Internal.Pad (
    pad
  , crop
  ) where

import qualified Data.Vector.Storable as U ( unsafeToForeignPtr0, unsafeFromForeignPtr0 )

import           Foreign ( mallocForeignPtrArray, withForeignPtr )
import           Foreign.Ptr ( Ptr )

import           Numeric.LinearAlgebra ( flatten, Matrix )
import qualified Numeric.LinearAlgebra.Devel as U

import           System.IO.Unsafe ( unsafePerformIO )

pad :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
pad channels padLeft padTop padRight padBottom rows cols rows' cols' m
 = let outMatSize      = rows' * cols' * channels
       vec             = flatten m
   in unsafePerformIO $ do
     outPtr        <- mallocForeignPtrArray outMatSize
     let (inPtr, _) = U.unsafeToForeignPtr0 vec

     withForeignPtr inPtr $ \inPtr' ->
       withForeignPtr outPtr $ \outPtr' ->
         pad_cpu inPtr' channels rows cols padLeft padTop padRight padBottom outPtr'

     let matVec = U.unsafeFromForeignPtr0 outPtr outMatSize
     return (U.matrixFromVector U.RowMajor (rows' * channels) cols' matVec)
{-# INLINE pad #-}

foreign import ccall unsafe
    pad_cpu
      :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()

crop :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Matrix Double -> Matrix Double
crop channels padLeft padTop padRight padBottom rows cols _ _ m
 = let outMatSize      = rows * cols * channels
       vec             = flatten m
   in unsafePerformIO $ do
     outPtr        <- mallocForeignPtrArray outMatSize
     let (inPtr, _) = U.unsafeToForeignPtr0 vec

     withForeignPtr inPtr $ \inPtr' ->
       withForeignPtr outPtr $ \outPtr' ->
         crop_cpu inPtr' channels rows cols padLeft padTop padRight padBottom outPtr'

     let matVec = U.unsafeFromForeignPtr0 outPtr outMatSize
     return (U.matrixFromVector U.RowMajor (rows * channels) cols matVec)

foreign import ccall unsafe
    crop_cpu
      :: Ptr Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Ptr Double -> IO ()


{-|
  Safe immutable intermediate (functional) Matlab data structures.

  This provides an alternative representation of Matlab data structures which can be marshalled to and from 'MXArray'.
  An instance of 'Show' is provided which creates Matlab expressions.
-}
module Foreign.Matlab.Array.IMX (
    IMXData(..),
    IMXArray,
    IMXArrayElem (imxConstr, imxArray),

    -- * Interface with "Foreign.Matlab.Array"
    imxData, iMXData,
    imxFun, iMXFun,
    withIMXData, takeIMXData,
    withIMXDataList,

    -- * Construction and access
    imxSize,
    listIMX, scalarIMX,
    imxList, imxScalar,
    listIMXStruct,
    imxStructList
  ) where

import           Control.Monad
import           Data.Array.IArray
import           Data.Complex
import           Data.List
import qualified Data.Map.Strict as DM
import           Foreign.Matlab.Util
import           Foreign.Matlab.Internal
import           Foreign.Matlab.Types
import           Foreign.Matlab.Array

type IMXArray a = Array MIndex a
-- |The basic immutable (functional) representation of Matlab data structures, representing a generic 'MXArray'
data IMXData =
    IMXNull
  | IMXCell     (IMXArray IMXData)
  | IMXStruct   [String] (Array (MIndex,Int) IMXData) -- ^ field name list and array mapping (index,field index) to values
  | IMXLogical  (IMXArray MLogical)
  | IMXChar     (IMXArray MChar)
  | IMXDouble   (IMXArray MDouble)
  | IMXSingle   (IMXArray MSingle)
  | IMXInt8     (IMXArray MInt8)
  | IMXUint8    (IMXArray MUint8)
  | IMXInt16    (IMXArray MInt16)
  | IMXUint16   (IMXArray MUint16)
  | IMXInt32    (IMXArray MInt32)
  | IMXUint32   (IMXArray MUint32)
  | IMXInt64    (IMXArray MInt64)
  | IMXUint64   (IMXArray MUint64)
  | IMXComplexDouble    (IMXArray (MComplex MDouble))
  | IMXComplexSingle    (IMXArray (MComplex MSingle))
  | IMXObject   String IMXData -- ^ object class name and object data, currently always IMXStruct
  deriving (Eq)

type IMXFun = [IMXData] -> Int -> IO [IMXData]

fixMSize :: MSize -> [a] -> MSize
fixMSize s l = maybe s (\i -> replaceIndex s i (length l `div` negate (product s))) $ elemIndex (-1) s

-- |Create an sized array for 'IMXData' from a sequential list of elements.  'MSize' may contain at most one -1 value, which will be inferred from the length of the list.
listIMXArray :: MSize -> [e] -> IMXArray e
listIMXArray s l = listArray (mSizeRange (fixMSize s l)) l

-- |Create a scalar (array) for 'IMXData'
scalarIMXArray :: e -> IMXArray e
scalarIMXArray e = listIMXArray [] [e]

class IMXArrayElem a where
  -- |Generic 'IMXData' 'IMXArray' constructor
  imxConstr :: IMXArray a -> IMXData
  -- |Generic 'IMXData' 'IMXArray' accessor
  imxArray :: IMXData -> Maybe (IMXArray a)
instance IMXArrayElem IMXData  where { imxConstr = IMXCell    ; imxArray (IMXCell    a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MLogical where { imxConstr = IMXLogical ; imxArray (IMXLogical a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MChar    where { imxConstr = IMXChar    ; imxArray (IMXChar    a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MDouble  where { imxConstr = IMXDouble  ; imxArray (IMXDouble  a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MSingle  where { imxConstr = IMXSingle  ; imxArray (IMXSingle  a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MInt8    where { imxConstr = IMXInt8    ; imxArray (IMXInt8    a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MUint8   where { imxConstr = IMXUint8   ; imxArray (IMXUint8   a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MInt16   where { imxConstr = IMXInt16   ; imxArray (IMXInt16   a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MUint16  where { imxConstr = IMXUint16  ; imxArray (IMXUint16  a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MInt32   where { imxConstr = IMXInt32   ; imxArray (IMXInt32   a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MUint32  where { imxConstr = IMXUint32  ; imxArray (IMXUint32  a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MInt64   where { imxConstr = IMXInt64   ; imxArray (IMXInt64   a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem MUint64  where { imxConstr = IMXUint64  ; imxArray (IMXUint64  a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem (MComplex MDouble) where { imxConstr = IMXComplexDouble ; imxArray (IMXComplexDouble a) = Just a ; imxArray _ = Nothing }
instance IMXArrayElem (MComplex MSingle) where { imxConstr = IMXComplexSingle ; imxArray (IMXComplexSingle a) = Just a ; imxArray _ = Nothing }

-- |Generic 'IMXData' list constructor.  Specified 'MSize' may contain at most one -1 value, which will be inferred from the length of the list.
listIMX :: IMXArrayElem a => MSize -> [a] -> IMXData
listIMX s = imxConstr . listIMXArray s
-- |Generic 'IMXData' scalar constructor
scalarIMX :: IMXArrayElem a => a -> IMXData
scalarIMX = imxConstr . scalarIMXArray
--emptyIMX :: IMXArrayElem a => a -> IMXData
--emptyIMX a = listIMX [0] ([] `asTypeOf` [a])

-- |Generic 'IMXData' array size accessor
imxSize :: IMXData -> MSize
imxSize IMXNull = [0]
imxSize (IMXCell    a) = mRangeSize (bounds a)
imxSize (IMXLogical a) = mRangeSize (bounds a)
imxSize (IMXChar    a) = mRangeSize (bounds a)
imxSize (IMXDouble  a) = mRangeSize (bounds a)
imxSize (IMXSingle  a) = mRangeSize (bounds a)
imxSize (IMXInt8    a) = mRangeSize (bounds a)
imxSize (IMXUint8   a) = mRangeSize (bounds a)
imxSize (IMXInt16   a) = mRangeSize (bounds a)
imxSize (IMXUint16  a) = mRangeSize (bounds a)
imxSize (IMXInt32   a) = mRangeSize (bounds a)
imxSize (IMXUint32  a) = mRangeSize (bounds a)
imxSize (IMXInt64   a) = mRangeSize (bounds a)
imxSize (IMXUint64  a) = mRangeSize (bounds a)
imxSize (IMXComplexDouble a) = mRangeSize (bounds a)
imxSize (IMXComplexSingle a) = mRangeSize (bounds a)
imxSize (IMXStruct _ a) = mRangeSize (r0,r1) where ((r0,_),(r1,_)) = bounds a
imxSize (IMXObject _ d) = imxSize d

-- |Generic 'IMXData' list accessor
imxList :: IMXArrayElem a => IMXData -> Maybe [a]
imxList = fmap elems . imxArray
-- |Generic 'IMXData' scalar accessor
imxScalar :: IMXArrayElem a => IMXData -> Maybe a
imxScalar a = case imxList a of
  Just [x] -> Just x
  _ -> Nothing

-- |Create a sized struct array from a sequential list of consecutive field values (@[i0f0,i0f1,...,i0fM,i1f0,i1f1,....,iNfM]@).
listIMXStruct :: [String] -> MSize -> [IMXData] -> IMXData
listIMXStruct f s l = IMXStruct f $ listArray r l where
  n = length f
  r = ((r0,0),(r1,pred n))
  (r0,r1) = mSizeRange $ tail $ fixMSize (n:s) l

-- |Access a struct as list of fields and list of consecutive field values
imxStructList :: IMXData -> Maybe ([String], [IMXData])
imxStructList (IMXStruct f v) = Just (f, elems v)
imxStructList _ = Nothing

-- |Create an immutable representation from an 'MXArray'
imxData :: MXArray a -> IO IMXData
imxData a = do
  t <- mxArrayClass a
  c <- if t /= MXClassNull then mxArrayIsComplex a else return undefined
  imxc t c where

  imxc :: MXClass -> Bool -> IO IMXData
  imxc MXClassNull _            = return IMXNull
  imxc MXClassCell False        = IMXCell       =.< imxa (imxData . mCell)
  imxc MXClassStruct False      = do
    s <- mxArraySize a'
    fv <- mxArrayGetAll a'
    f <- if null fv then mStructFields a' else return (map fst (DM.toList $ _mStruct (head fv)))
    listIMXStruct f s =.< mapM imxData (concatMap (map snd . DM.toList . _mStruct) fv)
  imxc MXClassLogical False     = IMXLogical    =.< imxa return
  imxc MXClassChar False        = IMXChar       =.< imxa return
  imxc MXClassDouble False      = IMXDouble     =.< imxa return
  imxc MXClassSingle False      = IMXSingle     =.< imxa return
  imxc MXClassInt8 False        = IMXInt8       =.< imxa return
  imxc MXClassUint8 False       = IMXUint8      =.< imxa return
  imxc MXClassInt16 False       = IMXInt16      =.< imxa return
  imxc MXClassUint16 False      = IMXUint16     =.< imxa return
  imxc MXClassInt32 False       = IMXInt32      =.< imxa return
  imxc MXClassUint32 False      = IMXUint32     =.< imxa return
  imxc MXClassInt64 False       = IMXInt64      =.< imxa return
  imxc MXClassUint64 False      = IMXUint64     =.< imxa return
  imxc MXClassDouble True       = IMXComplexDouble      =.< imxa return
  imxc MXClassSingle True       = IMXComplexSingle      =.< imxa return
  imxc MXClassObject False      = do
    Just c <- mObjectGetClass a'
    IMXObject c =.< imxc MXClassStruct False
  imxc t c = fail ("imxData: unhandled mxArray type " ++ show t ++ if c then "(complex)" else "")

  imxa :: MXArrayComponent a => (a -> IO b) -> IO (IMXArray b)
  imxa f = do
    s <- mxArraySize a'
    listIMXArray s =.< mapM f =<< mxArrayGetAll a'

  a' = unsafeCastMXArray a

-- |Create a new 'MXArray' from a functional representation.
iMXData :: IMXData -> IO MAnyArray
iMXData = imxd where
  imxd :: IMXData -> IO MAnyArray
  imxd IMXNull = return $ anyMXArray mNullArray
  imxd (IMXCell a) = imxa a (MCell .=< iMXData)
  imxd (IMXStruct f a) = do
    let ((r0,_),(r1,_)) = bounds a
    m <- createStruct (mRangeSize (r0,r1)) f
    zipWithM_ (\i -> mStructSetFields m (mOffset i) <=< mapM iMXData) [0..] (segment (length f) (elems a))
    return $ anyMXArray m
  imxd (IMXLogical a)   = imxa a return
  imxd (IMXChar a)      = imxa a return
  imxd (IMXDouble a)    = imxa a return
  imxd (IMXSingle a)    = imxa a return
  imxd (IMXInt8 a)      = imxa a return
  imxd (IMXUint8 a)     = imxa a return
  imxd (IMXInt16 a)     = imxa a return
  imxd (IMXUint16 a)    = imxa a return
  imxd (IMXInt32 a)     = imxa a return
  imxd (IMXUint32 a)    = imxa a return
  imxd (IMXInt64 a)     = imxa a return
  imxd (IMXUint64 a)    = imxa a return
  imxd (IMXComplexDouble a) = imxa a return
  imxd (IMXComplexSingle a) = imxa a return
  imxd (IMXObject c a) = do
    m <- imxd a
    mObjectSetClass (unsafeCastMXArray m) c
    return m

  imxa :: MXArrayComponent b => IMXArray a -> (a -> IO b) -> IO MAnyArray
  imxa a f = do
    m <- createMXArray (mRangeSize (bounds a))
    mxArraySetAll m =<< mapM f (elems a)
    return $ anyMXArray m

withIMXData :: IMXData -> (MAnyArray -> IO a) -> IO a
withIMXData d f = do
  a <- iMXData d
  r <- f a
  freeMXArray a
  return r

withIMXDataList :: [IMXData] -> ([MAnyArray] -> IO a) -> IO a
withIMXDataList = mapWith withIMXData

takeIMXData :: MXArray a -> IO IMXData
takeIMXData a = do
  d <- imxData a
  freeMXArray a
  return d

imxFun :: MFun -> IMXFun
imxFun fun a no =
  mapWith withIMXData a $ \m ->
  fun m no >>= mapM takeIMXData

iMXFun :: IMXFun -> MFun
iMXFun fun a no = do
  ia <- mapM imxData a
  fun ia no >>= mapM iMXData

showsApp :: String -> ShowS -> ShowS
showsApp f a s = f ++ '(' : a (')' : s)

{-
showsReshape :: (MIndex,MIndex) -> ShowS -> ShowS
showsReshape (MSubs [],MSubs []) a s = a s
showsReshape (MSubs [],MSubs []) a s = a s
showsReshape r a s = "reshape(" ++ a (',' : shows (realMSize $ mRangeSize r) (')' : s))

showsIMXArrayDelimWith :: (Char,Char,Char) -> (a -> ShowS) -> IMXArray a -> ShowS
showsIMXArrayDelimWith d f a = showsReshape (bounds a) $ showsMListWith d f (elems a)
showsIMXArrayWith :: (a -> ShowS) -> IMXArray a -> ShowS
showsIMXArrayWith = showsIMXArrayDelimWith ('[',',',']')
showsIMXArray :: Show a => IMXArray a -> ShowS
showsIMXArray = showsIMXArrayWith shows
-}

showsMList :: (Char,Char,Char) -> (a -> ShowS) -> [a] -> ShowS
showsMList (l,_,r) _ [] s = l : r : s
showsMList (l,d,r) f (x:xs) s = l : f x (shml xs) where
  shml [] = r : s
  shml (x:xs) = d : f x (shml xs)

showsReshape :: MSize -> (Char -> ShowS) -> ShowS
showsReshape [] f s = f ' ' s
showsReshape [_] f s = f ';' s
showsReshape [1,_] f s = f ',' s
showsReshape z f s = "reshape(" ++ f ' ' (',' : showsMList ('[',' ',']') shows (realMSize z) (')' : s))

showsIMXGenArray :: (Char,Char) -> (a -> ShowS) -> IMXArray a -> ShowS
showsIMXGenArray (l,r) f a = showsReshape (mRangeSize $ bounds a) $ \d -> showsMList (l,d,r) f (elems a)
showsIMXArrayWith :: (a -> ShowS) -> IMXArray a -> ShowS
showsIMXArrayWith = showsIMXGenArray ('[',']')
showsIMXArray :: Show a => IMXArray a -> ShowS
showsIMXArray = showsIMXArrayWith shows

showsComplex :: (Show a, RealFloat a) => Complex a -> ShowS
showsComplex (x:+y) s = "complex(" ++ shows x (',' : shows y (')' : s))

showsMString :: String -> ShowS
showsMString s = showChar '\'' . showString s . showChar '\''

showsIMX :: IMXData -> ShowS
showsIMX IMXNull = showString "[]"
showsIMX (IMXCell a) = showsIMXGenArray ('{','}') shows a
showsIMX (IMXStruct f a) = showsReshape (mRangeSize (r0,r1)) $ \d ->
  showString "struct" . showsMList ('(',',',')') (shf d) (zip f v) where
  shf d (f,v) s = showsMString f $ ',' : showsMList ('{',d,'}') showsIMX v s
  v = transpose $ segment (length f) $ elems a
  ((r0,_),(r1,_)) = bounds a
showsIMX (IMXLogical a) = showsApp "logical"  $ showsIMXArray a
showsIMX (IMXChar a)    = showsApp "char"     $ showsIMXArray a
showsIMX (IMXDouble a)  =                       showsIMXArray a
showsIMX (IMXSingle a)  = showsApp "single"   $ showsIMXArray a
showsIMX (IMXInt8 a)    = showsApp "int8"     $ showsIMXArray a
showsIMX (IMXUint8 a)   = showsApp "uint8"    $ showsIMXArray a
showsIMX (IMXInt16 a)   = showsApp "int16"    $ showsIMXArray a
showsIMX (IMXUint16 a)  = showsApp "uint16"   $ showsIMXArray a
showsIMX (IMXInt32 a)   = showsApp "int32"    $ showsIMXArray a
showsIMX (IMXUint32 a)  = showsApp "uint32"   $ showsIMXArray a
showsIMX (IMXInt64 a)   = showsApp "int64"    $ showsIMXArray a
showsIMX (IMXUint64 a)  = showsApp "uint64"   $ showsIMXArray a
showsIMX (IMXComplexDouble a)   = showsIMXArrayWith showsComplex a
showsIMX (IMXComplexSingle a)   = showsApp "single" $ showsIMXArrayWith showsComplex a
showsIMX (IMXObject c a) = showsApp "class" $ showsIMX a . showChar ',' . showsMString c

instance Show IMXData where
  showsPrec _ = showsIMX


{-#LANGUAGE ForeignFunctionInterface#-}
-- |This  module provides slow but functional means for exporting images from and to
--  CArrays, which can easily be passed into foreign functions.
module CV.Conversions (
     -- Arrays of Double
     copyCArrayToImage
    ,copy8UCArrayToImage
    ,copyImageToCArray
     -- Arrays of Float
    ,copyFCArrayToImage
    ,copyImageToFCArray
    -- * Complex arrays
    ,copyComplexCArrayToImage
    ,copyImageToComplexCArray
    -- * Copying
    ,copyImageToExistingCArray
    -- * Acquiring images from pointers
    ,unsafe8UC_RGBFromPtr
    ,unsafe8UC_BGRFromPtr
    ,unsafe8UC_MONOFromPtr
    ,acquireImageSlowF'
    ,acquireImageSlow'
    ,acquireImageSlow8URGB'
    ) where

import Data.Complex as C

import CV.Image
import Data.Word

import Data.Array.CArray
import Data.Array.IArray

import Foreign.C.Types
import Foreign.Ptr
import System.IO.Unsafe

unsafe8UC_RGBFromPtr :: (Int,Int) -> Ptr Word8 -> IO (Image RGB D8)
unsafe8UC_RGBFromPtr (w,h) ptr = S `fmap`  creatingBareImage (acquireImageSlow8URGB' w h ptr)

unsafe8UC_BGRFromPtr :: (Int,Int) -> Ptr Word8 -> IO (Image RGB D8)
unsafe8UC_BGRFromPtr (w,h) ptr = S `fmap`  creatingBareImage (acquireImageSlow8UBGR' w h ptr)

unsafe8UC_MONOFromPtr :: (Int,Int) -> Ptr Word8 -> IO (Image GrayScale D8)
unsafe8UC_MONOFromPtr (w,h) ptr = S `fmap`  creatingBareImage (acquireImageSlow8U' w h ptr)

-- |Copy the contents of a CArray into CV.Image type.
copy8UCArrayToImage :: CArray (Int,Int) Word8 -> Image GrayScale D8
copy8UCArrayToImage carr = S $ unsafePerformIO $
                          creatingBareImage (withCArray carr (acquireImageSlow8U' w h))
    where
     ((sx,sy),(ex,ey)) = bounds carr
     (w,h) = (fromIntegral $ ex-sx+1, fromIntegral $ ey-sy+1)
--
-- |Copy the contents of a CArray into CV.Image type.
copyCArrayToImage :: CArray (Int,Int) Double -> Image GrayScale D32
copyCArrayToImage carr = S $ unsafePerformIO $
                          creatingBareImage (withCArray carr (acquireImageSlow' w h))
    where
     ((sx,sy),(ex,ey)) = bounds carr
     (w,h) = (fromIntegral $ ex-sx+1, fromIntegral $ ey-sy+1)

-- |Copy CArray of floats to image
copyFCArrayToImage :: CArray (Int,Int) Float -> Image GrayScale D32
copyFCArrayToImage carr = S $ unsafePerformIO $
                          creatingBareImage (withCArray carr (acquireImageSlowF' w h))
    where
     ((sx,sy),(ex,ey)) = bounds carr
     (w,h) = (fromIntegral $ ex-sx+1, fromIntegral $ ey-sy+1)

-- |Copy D32 grayscale image to CArray
copyImageToFCArray :: Image GrayScale D32 -> CArray (Int,Int) Float
copyImageToFCArray (S img) = unsafePerformIO $
         withBareImage img $ \cimg ->
          createCArray ((0,0),(w-1,h-1)) (exportImageSlowF' cimg) --({#call exportImageSlow#} cimg)
    where
     (w,h) = getSize img

-- |Copy the real part of an array to image
copyComplexCArrayToImage :: CArray (Int,Int) (C.Complex Double) -> Image GrayScale D32
copyComplexCArrayToImage carr = S $ unsafePerformIO $
                          creatingBareImage (withCArray carr (acquireImageSlowComplex' w h))
    where
     ((sx,sy),(ex,ey)) = bounds carr
     (w,h) = (fromIntegral $ ex-sx+1, fromIntegral $ ey-sy+1)

-- |Copy the contents of a CV.Image into a CArray.
copyImageToCArray :: Image GrayScale D32 -> CArray (Int,Int) Double
copyImageToCArray (S img) = unsafePerformIO $
         withBareImage img $ \cimg ->
          createCArray ((0,0),(w-1,h-1)) (exportImageSlow' cimg) --({#call exportImageSlow#} cimg)
    where
     (w,h) = getSize img
-- |Copy the contents of CV.Image into a pre-existing CArray.
--
copyImageToExistingCArray (S img) arr =
         withBareImage img $ \cimg ->
          withCArray arr $ \carr -> (exportImageSlow' cimg carr) --({#call exportImageSlow#} cimg)
    where
     (w,h) = getSize img

-- |Copy image as a real part of a complex CArray
copyImageToComplexCArray :: Image GrayScale D32 -> CArray (Int,Int) (C.Complex Double)
copyImageToComplexCArray (S img) = unsafePerformIO $
         withBareImage img $ \cimg ->
          createCArray ((0,0),(w-1,h-1)) (exportImageSlowComplex' cimg) --({#call exportImageSlow#} cimg)
    where
     (w,h) = getSize img

foreign import ccall safe "CV/cvWrapLeo.h exportImageSlow"
  exportImageSlow' :: ((Ptr (BareImage)) -> ((Ptr Double) -> (IO ())))

foreign import ccall safe "CV/cvWrapLeo.h exportImageSlowF"
  exportImageSlowF' :: ((Ptr (BareImage)) -> ((Ptr Float) -> (IO ())))

foreign import ccall safe "CV/cvWrapLeo.h exportImageSlowComplex"
  exportImageSlowComplex' :: ((Ptr (BareImage)) -> ((Ptr (C.Complex Double)) -> (IO ())))

foreign import ccall safe "CV/cvWrapLeo.h acquireImageSlow"
  acquireImageSlow' :: (Int -> (Int -> ((Ptr Double) -> (IO (Ptr (BareImage))))))

foreign import ccall safe "CV/cvWrapLeo.h acquireImageSlowF"
  acquireImageSlowF' :: (Int -> (Int -> ((Ptr Float) -> (IO (Ptr (BareImage))))))

foreign import ccall safe "CV/cvWrapLeo.h acquireImageSlow8URGB"
  acquireImageSlow8URGB' :: (Int -> (Int -> ((Ptr Word8) -> (IO (Ptr (BareImage))))))

foreign import ccall safe "CV/cvWrapLeo.h acquireImageSlow8UBGR"
  acquireImageSlow8UBGR' :: (Int -> (Int -> ((Ptr Word8) -> (IO (Ptr (BareImage))))))

foreign import ccall safe "CV/cvWrapLeo.h acquireImageSlow8U"
  acquireImageSlow8U' :: (Int -> (Int -> ((Ptr Word8) -> (IO (Ptr (BareImage))))))

foreign import ccall safe "CV/cvWrapLeo.h acquireImageSlowComplex"
  acquireImageSlowComplex' :: (Int -> (Int -> ((Ptr (C.Complex Double)) -> (IO (Ptr (BareImage))))))