module Deanie.Measure (
    measure

  -- * queries

  , integrate
  , expectation
  , variance
  , mgf
  , cgf
  , cdf
  ) where

import Control.Monad
import Data.List (foldl')
import Deanie.Language
import Control.Foldl (Fold)
import Numeric.Integration.TanhSinh
import Numeric.SpecFunctions

newtype Measure a = Measure ((a -> Double) -> Double)

integrate :: (a -> Double) -> Measure a -> Double
integrate f (Measure nu) = nu f

expectation :: Measure Double -> Double
expectation = integrate id

variance :: Measure Double -> Double
variance nu = integrate (^ 2) nu - expectation nu ^ 2

mgf :: Measure Double -> Double -> Double
mgf mu t = integrate (\x -> exp (t * x)) mu

cgf :: Measure Double -> Double -> Double
cgf mu = log . mgf mu

cdf :: Measure Double -> Double -> Double
cdf nu x = integrate (negativeInfinity `to` x) nu where
  negativeInfinity :: Double
  negativeInfinity = negate (1 / 0)

  to :: (Num a, Ord a) => a -> a -> a -> a
  to a b x
    | x >= a && x <= b = 1
    | otherwise        = 0

instance Functor Measure where
  fmap f nu = Measure $ \g ->
    integrate (g . f) nu

instance Applicative Measure where
  pure x = Measure (\f -> f x)
  Measure h <*> Measure g = Measure $ \f ->
    h (\k -> g (f . k))

instance Monad Measure where
  return x  = Measure (\f -> f x)
  rho >>= g = Measure $ \f ->
    integrate (\nu -> integrate f (g nu)) rho

fromMassFunction :: Foldable f => (a -> Double) -> f a -> Measure a
fromMassFunction f support = Measure $ \g ->
  foldl' (\acc x -> acc + f x * g x) 0 support

fromDensityFunction :: (Double -> Double) -> Measure Double
fromDensityFunction d = Measure $ \f ->
    quadratureTanhSinh (\x -> f x * d x)
  where
    quadratureTanhSinh = result . last . everywhere trap

mbernoulli :: Double -> Measure Bool
mbernoulli p = fromMassFunction (pmf p) [False, True] where
  pmf p x
    | p < 0 || p > 1 = 0
    | otherwise      = if x then p else 1 - p

mbeta :: Double -> Double -> Measure Double
mbeta a b = fromDensityFunction (density a b) where
  density a b p
    | p < 0 || p > 1 = 0
    | otherwise      = 1 / exp (logBeta a b) * p ** (a - 1) * (1 - p) ** (b - 1)

mgamma :: Double -> Double -> Measure Double
mgamma a b = fromDensityFunction (density a b) where
  density a b x
    | a < 0 || b < 0 = 0
    | otherwise  =
       b ** a / exp (logGamma a) * x ** (a - 1) * exp (negate (b * x))

mgaussian :: Double -> Double -> Measure Double
mgaussian m s = fromDensityFunction (density m s) where
  density m s x
    | s <= 0    = 0
    | otherwise =
        1 / (s * sqrt (2 * pi)) *
          exp (negate ((x - m) ^^ 2) / (2 * (s ^^ 2)))

measure :: Program a -> Measure a
measure = iterM $ \case
    ProgramF (InL term) -> evalAlg term
    ProgramF (InR term) -> join (runAp measure term)
  where
    evalAlg = \case
      BernoulliF p k  -> mbernoulli p >>= k
      BetaF a b k     -> mbeta a b >>= k
      GammaF a b k    -> mgamma a b >>= k
      GaussianF m s k -> mgaussian m s >>= k


{-# LANGUAGE BangPatterns #-}
module LINreg2 (mmlLinearRegLP, diagl, rowM, colM,(<+>), (<->), foldl'Rnf
                , mkZ,realignedNpieces,lineFun, mmlCorr-- ,vmean,vvar,vstDiv,vvarM,vunStdNorm,vstNorm, corrRoundCentre
                , standardizedFit,relFit, corr,nCorrV,logg
                ) where

import Numeric.LinearAlgebra
import Numeric.GSL.Statistics as S
import Control.DeepSeq (NFData, rnf)
import Numeric.GSL.Statistics (mean,variance,variance_m,stddev)
import Control.Parallel (pseq)
import Data.Ord (comparing)
import Data.List (transpose, nub,minimumBy,foldl')
import LMisc
import Data.Time
import IO

ident n = (diag . fromList) (take n $ repeat 1) :: Matrix Double

vector xs = fromList xs :: Vector Double
diagl = diag . vector
rowM = asRow . vector
colM = asColumn . vector
-------------------------------------------------------
foldl'Rnf :: (NFData a) => (a -> b -> a) -> a -> [b] -> a
foldl'Rnf f z xs = lgo z xs
    where
        lgo z   []      = z
        lgo z (x:xs)    = lgo z' xs
            where
                z' = rnf (f z x) `pseq` (f z x)

------ standardise by subtracting the mean and dividing by the standard deviation
vstNorm       xs            = mapVector (\ a -> (a - m) / std) xs
                 where m    = mean xs
                       std  = sqrt $ variance_m m xs

-- unstandardising
vunStdNorm m std vs  = mapVector (\a -> std * a + m)  vs

--mean,variance,variance_m,stddev)
vunStdNorm' vs = vunStdNorm (mean vs) (stddev vs)  vs
-----------------------------------------------------------------------------------------------
logg a      --     = log a
      | a <= 0     = a
      | otherwise  = log a
-------------------------------------------------------
infix 1  <+>
(<+>) :: Matrix Double -> Matrix Double -> Matrix Double
m1  <+>    m2   = fromRows $ zipWith (zipVectorWith (+)) (toRows m1) (toRows m2)

(<->) :: Matrix Double -> Matrix Double -> Matrix Double
m1  <->    m2  =  fromRows $ zipWith (zipVectorWith (-)) (toRows m1) (toRows m2)
--}

-- adds a to the diadonal elements of ma
mkZ :: Double -> Matrix Double -> Matrix Double
mkZ  a   ma  = mapMatrixWithIndex (pli a) (trans ma <>  ma)
    where  pli b (!i,!j) v = if i == j then v + b else v

mmlLinearRegLP :: Vector Double ->  Double -> Double -> Matrix Double -> (Double, (Vector Double, (Double, Vector Double))) -- Vector Double
mmlLinearRegLP     xs     m   r  ys  =  (ans, (xTy, (sig, abar)))
                where
                  z       =   mkZ m ys -- make the Z matrix
                  n       =   fromIntegral $ rows  ys
                  !mM     =   n + k  + 1
                  !rest   =   log r + 0.5 * log (2 * mM * abs (det z)) + (n / 2) -- cd (k+1)
                  --abar   =   (inv z) <> (trans ys) <>  xs --
                  abar_aux    =    toColumns $ linearSolveLS z (asColumn ((trans ys) <>  xs))
                  abar    =  head abar_aux
                  !k      =   fromIntegral $ cols z
                  sigSq   =    (xs <.> xs)  - ( xs <.> (ys <> abar))
                  !sig    =   sqrt (sigSq / n)
                  xTy     =     (ys <>  abar) -- predictions fromList . manyInvNS1 Nothing $ toList
                  ans     =   (mM/2) * log (2 * pi) + n * log sig - 0.5 * (k + 1) * log k + rest -- k is 2 here
----
mmlMLwithAbar ::Vector Double ->  Vector Double ->  Double -> Double -> Matrix Double -> Double
mmlMLwithAbar abar     xs     m   r  ys  =  ans
                where
                  z       =   mkZ m ys -- make the Z matrix
                  n       =   fromIntegral $ rows  ys
                  !mM     =   n + k  + 1
                  !k      =   fromIntegral $ cols z
                  !rest   =   log r + 0.5 * logg (2 * mM * abs (det z)) + (n / 2) -- cd (k+1)
                  sigSq   =   (xs <.> xs)  - ( xs <.> (ys <> abar))
                  !sig    =   sqrt (sigSq / n)
                  xTy     =     (ys <>  abar) -- predictions fromList . manyInvNS1 Nothing $ toList
                  ans     =   (mM/2) * log (2 * pi) + n * log sig - 0.5 * (k + 1) * log m + rest

--- realigning a matrix
--- map mkMatrix : [[(Matrix Double,[Int])]]
realignedNpieces :: Int ->  --- number of interventions
    Int ->                  --- minimum length of each sub group
   -- Int ->                  -- maximum length of each subgroup
    [[Double]] ->             --- the list of values
    [(Matrix Double,[Int])] --- the matrix for analysis, along with the locations of interventions
realignedNpieces n m  =  nub . concatMap combMatrix . transpose . map  mkMatrix -- map (\ks -> (newMX, ks)) ctts
    where
        ---
        combMatrix :: [(Matrix Double,[Int])] -> [(Matrix Double, [Int]) ]
        combMatrix mcI  = map (\ks -> (newMX, ks)) cts
            where
                (mxx, cts) = unzip mcI
                newMX      = appendByColumns mxx
        mkMatrix :: [Double] ->  [(Matrix Double,[Int])]
        mkMatrix xs      =   [(reAlign ps ,ks) |
                                let nPnms  =  nPiecesP n m Nothing xs
                                , (ps,ks) <-   nPnms
                                ]
            where
                nPns             = []
                len              = length xs
                cons a vs        = join [fromList [a] , vs]
                app2rows f       = fromRows . map f  . toRows
                tS'              = app2rows (cons 1) . trans . app2rows vstNorm . fromLists --vstNorm
                reAlign          = tS' . adjustMatrix . fillZeroes_aux len 0 1
appendByColumns :: Element t => [Matrix t] -> Matrix t
appendByColumns  = fromRows . concatMap toRows

-- draw a best fit line through a list of points
lineFun :: Vector Double -> (Double,Double)
lineFun vs = (ks @> 1, ks @> 0)
    where
        mx          =  (fst . head . realignedNpieces 0 1 . (: [])) [1 .. fromIntegral $ dim  vs]
        (_,(_,ks))  =  snd $ mmlLinearRegLP (vstNorm vs) 1 1  mx

--
-- finding mormalized correlation using  using MML
mmlCorr :: [Double] -> [Double] -> Double
mmlCorr xs ys =  nCorrV (fromList xs) (fromList ys)

mmlCorr1  xs ys =  (mmlCorr_aux (Just n) xs ys)/ (mmlCorr_aux Nothing [1 .. fromIntegral n] [1 .. fromIntegral n])
    where
        n           = (minimum . map length) [xs, ys]
        mmlCorr_aux mN xs' ys' = (ks @> 1)
            where
                stNorm      =  toList . vstNorm . fromList
                yss         =  (stNorm . maybe ys' (flip take ys')) mN
                vss         =  (vstNorm . fromList . maybe ys' (flip take xs')) mN
                (_,(_,ks))  =  snd $ mmlLinearRegLP vss 1 1  mx
                mx          =  (fst . head . realignedNpieces 0 1 . (: [])) yss

-- relative fit of twoe straight line functions
relFit :: [Double] -> [Double] -> Double
relFit xs ys   = relFit_1 (vstNorm $ fromList xs) (vstNorm $ fromList ys)
relFit_1  xs ys =   abs ((mly  - mlx)  /  mlx)
    where
        mly    = mmlMLwithAbar ab  ys  1 1  (mx ys)
        (mlx,(_,(_,ab))) =   mmlFun  xs
        mx   xs'     =  (fst . head . realignedNpieces 0 1 . (: [])) [1 .. fromIntegral $ dim xs']
        mmlFun vs    =  mmlLinearRegLP vs 1 1  (mx vs)

---pearsons correlation
corr xs  ys  =  S.correlation (fromList xs) (fromList ys)

-- normalised correlation
nCorrV xs ys  = (S.correlation (subVector 0 n xs) (subVector 0 n ys))
    where
         n    =  min (dim xs) (dim ys)

---
standardizedFit  :: [Vector Double] -> Double
standardizedFit [] = 0
standardizedFit ks@(_:_) = S.stddev . fromList $ map mSgLn ks
    where
        mSgLn  ys    = mmlMLwithAbar ab  ys  1 1  (mx ys)
        (_,(_,(_,ab)))   = minimumBy (comparing fst) $ map mmlFun ks -- (fst . snd . snd)
        mx   xs'     =  (fst . head . realignedNpieces 0 1 . (: [])) [1 .. fromIntegral $ dim xs']
        mmlFun vs    =  mmlLinearRegLP vs 1 1  (mx vs)


{-# LANGUAGE CPP, TypeOperators, TypeFamilies #-}
{-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-}
{-# OPTIONS_GHC -Wall #-}

-- {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP
-- {-# OPTIONS_GHC -fno-warn-unused-binds   #-} -- TEMP

#define CustomComplex

#if !defined CustomComplex
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for HasRep
#endif

----------------------------------------------------------------------
-- |
-- Module      :  ConCat.Complex
-- Copyright   :  (c) 2015 Conal Elliott and David Banas
-- License     :  BSD3
--
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
--
-- Simplified Complex type
----------------------------------------------------------------------

module ConCat.Complex (Complex(..),cis) where

#if defined CustomComplex
import Control.Applicative (liftA2)
import Data.Typeable
import Data.Data
import Test.QuickCheck (Arbitrary(..),CoArbitrary(..))
#else
import Data.Complex
#endif

#if defined CustomComplex
infixl 1 :+
data Complex a = a :+ a deriving (Functor,Eq,Show,Typeable,Data,Ord)

-- | The nonnegative magnitude of a complex number.
-- {-# SPECIALISE magnitude :: Complex Double -> Double #-}
magnitude :: (RealFloat a) => Complex a -> a

magnitude (x:+y) = sqrt (x*x + y*y)

-- From Data.Complex

-- magnitude (x:+y) =  scaleFloat k
--                      (sqrt (sqr (scaleFloat mk x) + sqr (scaleFloat mk y)))
--                     where k  = max (exponent x) (exponent y)
--                           mk = - k
--                           sqr z = z * z

-- | The phase of a complex number, in the range @(-'pi', 'pi']@.
-- If the magnitude is zero, then so is the phase.
-- {-# SPECIALISE phase :: Complex Double -> Double #-}
phase :: (RealFloat a) => Complex a -> a
phase (0 :+ 0)   = 0            -- SLPJ July 97 from John Peterson
phase (x:+y)     = atan2 y x

-- | Complex Identity Scaler
-- Returns a point on the unit circle, such that the angle between the
-- vector to that point and the positive x-axis is equal to the function
-- argument, given in radians.
cis :: (RealFloat a) => a -> Complex a
cis w = cos w :+ sin w

instance  (RealFloat a) => Num (Complex a)  where
    -- {-# SPECIALISE instance Num (Complex Float) #-}
    -- {-# SPECIALISE instance Num (Complex Double) #-}
    (x:+y) + (x':+y')   =  (x+x') :+ (y+y')
    (x:+y) - (x':+y')   =  (x-x') :+ (y-y')
    (x:+y) * (x':+y')   =  (x*x'-y*y') :+ (x*y'+y*x')
    negate (x:+y)       =  negate x :+ negate y
    abs z               =  magnitude z :+ 0
    signum (0:+0)       =  0
    signum z@(x:+y)     =  x/r :+ y/r  where r = magnitude z
    fromInteger n       =  fromInteger n :+ 0
    {-# INLINE (+)         #-}
    {-# INLINE (-)         #-}
    {-# INLINE (*)         #-}
    {-# INLINE negate      #-}
    {-# INLINE abs         #-}
    {-# INLINE signum      #-}
    {-# INLINE fromInteger #-}

instance  (RealFloat a) => Fractional (Complex a)  where
    -- {-# SPECIALISE instance Fractional (Complex Float) #-}
    -- {-# SPECIALISE instance Fractional (Complex Double) #-}
    recip z@(x:+y) = x/mag :+ (-y)/mag where mag = magnitude z
--     (x:+y) / (x':+y')   =  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d
--                            where x'' = scaleFloat k x'
--                                  y'' = scaleFloat k y'
--                                  k   = - max (exponent x') (exponent y')
--                                  d   = x'*x'' + y'*y''

    fromRational a      =  fromRational a :+ 0

instance  (RealFloat a) => Floating (Complex a) where
    -- {-# SPECIALISE instance Floating (Complex Float) #-}
    -- {-# SPECIALISE instance Floating (Complex Double) #-}
    pi             =  pi :+ 0
    exp (x:+y)     =  expx * cos y :+ expx * sin y
                      where expx = exp x
    log z          =  log (magnitude z) :+ phase z

    sqrt (0:+0)    =  0
    sqrt z@(x:+y)  =  u :+ (if y < 0 then -v else v)
                      where (u,v) = if x < 0 then (v',u') else (u',v')
                            v'    = abs y / (u'*2)
                            u'    = sqrt ((magnitude z + abs x) / 2)

    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y
    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)
    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
                      where sinx  = sin x
                            cosx  = cos x
                            sinhy = sinh y
                            coshy = cosh y

    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x
    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x
    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)
                      where siny  = sin y
                            cosy  = cos y
                            sinhx = sinh x
                            coshx = cosh x

    asin z@(x:+y)  =  y':+(-x')
                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
    acos z         =  y'':+(-x'')
                      where (x'':+y'') = log (z + ((-y'):+x'))
                            (x':+y')   = sqrt (1 - z*z)
    atan z@(x:+y)  =  y':+(-x')
                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))

    asinh z        =  log (z + sqrt (1+z*z))
    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))
    atanh z        =  0.5 * log ((1.0+z) / (1.0-z))

instance Arbitrary a => Arbitrary (Complex a) where
  arbitrary = liftA2 (:+) arbitrary arbitrary
  shrink (x :+ y) = map (uncurry (:+)) (shrink (x,y))

instance CoArbitrary a => CoArbitrary (Complex a) where
  coarbitrary (x :+ y) = coarbitrary x . coarbitrary y

#endif


module Mandelbrot where

import Graphics.UI.GLUT
import Control.Monad
import Data.Int
import Data.Complex
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import Data.IORef
import qualified Data.ByteString as B
import           Graphics.Rendering.OpenGL.Capture (capturePPM)
import           Graphics.Image
import           System.Directory (removeFile)
import Data.List.Split (splitOn)

convert :: FilePath -> FilePath -> Bool -> IO ()
convert input output remove = do
  ppm <- readImageRGBA VU input
  writeImage output ppm
  when remove $ removeFile input

iterations = 40

x // y = fromIntegral x / fromIntegral y

-- Divides [a] into [[a], [a], ...] with each sublist of length n,
-- except the last sublist which has length <= n.
chunkify n [] = []
chunkify n xs = let (xs', rest) = splitAt n xs
                in xs' : chunkify n rest

-- Converts a coordinate in screen space to a vertex.
pix2vert (Size w h) (x, y) = Vertex2 ((3 // w * fromIntegral x) - 2.0)
                             ((2 // h * fromIntegral y) - 1.0)

-- List of all of the vertices that represent screen pixels.
vertices :: IO [Vertex2 GLfloat]
vertices = get windowSize >>= \(Size w h) ->
           return $ [pix2vert (Size w h) (x, y) | x <- [0..w-1], y <- [0..h-1]]

-- Gets the color for a number of iterations.
color3 r g b = Color3 r g b
getcolor :: Int -> Int -> Color3 Float
getcolor iterations iter
  | iter == iterations = color3 0.1 0.1 0.1
  | otherwise          = color3 (amt*0.5) (amt * 0.5) (amt*0.5)
  where amt = iter // iterations

-- Returns the number of iterations <= the maximum iterations of the
-- Mandelbrot set at the given vertex.
mandel numIterations horizontalShift verticalShift zoom (Vertex2 r i) =
  length . takeWhile (\z -> Data.Complex.magnitude z <= 2) .
  take numIterations $
  iterate (\z -> z^2 + (((r / zoom) + horizontalShift) :+ ((i / zoom) + verticalShift))) 0

-- plots one point.
drawVert iter horShift verShift zoom v = do
  horShift' <- get horShift
  verShift' <- get verShift
  zoom' <- get zoom
  color . (getcolor iter) $ mandel iter horShift' verShift' zoom' v
  vertex v

-- draws the whole fractal
display :: IORef Int -> IORef GLfloat -> IORef GLfloat -> IORef GLfloat ->  IO ()
display numIter horShift verShift zoom = do
  -- clear [ ColorBuffer ]
  displayCallback $= (vertices >>= (display' numIter horShift verShift zoom) . (\x -> [x]))
  get currentWindow >>= postRedisplay

-- draws all the vertices in slices (to update the display while drawing).
display' :: IORef Int -> IORef GLfloat -> IORef GLfloat -> IORef GLfloat -> [[Vertex2 GLfloat]] -> IO ()
display' numIter horShift verShift zoom chunks = do
  iter <- get numIter
  mapM_ (render iter) chunks
  displayCallback $= display numIter horShift verShift zoom
  -- exitWith ExitSuccess
  where render iter' points = do
          renderPrimitive Points (mapM_ (drawVert iter' horShift verShift zoom) points)
          flush

-- keyboard :: Key -> KeyState -> p1 -> p2 -> IO ()
-- keyboard :: IORef GLfloat -> IORef GLfloat -> Key -> KeyState -> p3 -> p4 -> IO ()
keyboard numIter horShift verShift zoom (Char keyPressed) Down _ _ = case keyPressed of
   ' '   -> postRedisplay Nothing
   '\27' -> exitWith ExitSuccess
   '\100' -> do
     val <- shiftAmount zoom
     horShift $~! (+ val)
     displayCallback $= display numIter horShift verShift zoom
   '\97' -> do
     val <- shiftAmount zoom
     horShift $~! (+ (-val))
     displayCallback $= display numIter horShift verShift zoom
   '\115' -> do
     val <- shiftAmount zoom
     verShift $~! (+ (-val))
     displayCallback $= display numIter horShift verShift zoom
   '\119' -> do
     val <- shiftAmount zoom
     verShift $~! (+ val)
     displayCallback $= display numIter horShift verShift zoom
   '\61' -> do
     val <- get zoom
     zoom $~! (+ val)
     displayCallback $= display numIter horShift verShift zoom
   '\45' -> do
     val <- get zoom
     zoom $~! (+ (-(val / 2)))
     displayCallback $= display numIter horShift verShift zoom
   '\49' -> do
     resetIter numIter
     displayCallback $= display numIter horShift verShift zoom
   '\50' -> do
     resetIter numIter
     numIter $~! (+ (20))
     displayCallback $= display numIter horShift verShift zoom
   '\51' -> do
     resetIter numIter
     numIter $~! (+ (100))
     displayCallback $= display numIter horShift verShift zoom
   '\52' -> do
     resetIter numIter
     numIter $~! (+ (400))
     displayCallback $= display numIter horShift verShift zoom
   '\53' -> do
     resetIter numIter
     numIter $~! (+ (1000))
     displayCallback $= display numIter horShift verShift zoom

   'c' -> do
     horShift' <- get horShift
     verShift' <- get verShift
     zoom' <- get zoom
     let name = show horShift' ++ "," ++
                show verShift' ++ "," ++
                show zoom'

     putStrLn ""
     putStrLn ""
     putStrLn "Writing out file:"
     putStrLn $ "images/" ++ name ++ ".png"
     putStrLn ""
     let ppm = "images/" ++ name ++ ".ppm"
         png = "images/" ++ name ++ ".png"
     (>>=) capturePPM (B.writeFile ppm)
     Mandelbrot.convert ppm png True

   _     -> return ()
keyboard _ _ _ _ _ _ _ _ = return ()

shiftAmount zoom = do
  val <- get zoom
  pure (0.1 / val)

resetIter numIter = do
  val <- get numIter
  numIter $~! (+ (iters + (-val)))

parseFile' (file) = return
  where [x, y, z] = splitOn "," $ (splitOn ".png" file) !! 0
        return = ((read x :: GLfloat), (read y :: GLfloat), (read z :: GLfloat))

parseFile :: [String] -> (GLfloat, GLfloat, GLfloat)
parseFile [justOne] = parseFile' $ (splitOn "images/" justOne) !! 1
parseFile _ = (0.0, 0.0, 1.0)

iters = 20
mandelMain = do
  (_, file) <- getArgsAndInitialize
  mapM putStrLn file
  let (initHor, initVer, initZoom) = parseFile file

  initialDisplayMode $= [ SingleBuffered, RGBMode ]
  initialWindowSize $= Size 1200 1024
  initialWindowPosition $= Position 100 100
  createWindow "Mandelbrot"
  clearColor $= Color4 0 0 0 0
  matrixMode $= Projection
  loadIdentity
  ortho (-2) 1 (-1) 1 (-1) 1
  -- fullScreen
  numIter <- newIORef iters
  horShift <- newIORef initHor
  verShift <- newIORef initVer
  zoom <- newIORef initZoom
  keyboardMouseCallback $= Just (keyboard numIter horShift verShift zoom)
  displayCallback $= (display numIter horShift verShift zoom)
  idleCallback $= Just (idle numIter)
  mainLoop

idle :: IORef Int -> IdleCallback
idle numIter = do
  val <- get numIter
  let newVal = if val < 50 then 5 else 100
  numIter $~! (+ 0)
  postRedisplay Nothing


-- example 3.11

import Statistics.Distribution
import Statistics.Distribution.Geometric

g :: GeometricDistribution
g = geometric 0.02

main = do
  putStrLn $ "the rate of engines which survive two hours: "
          ++ show (1 - cumulative g 2.0)
  putStrLn $ "the rate of engines which survive two hours: "
          ++ show (complCumulative g 2.0)
  putStrLn $ "the rate of engines which survive two hours: "
          ++ show (1 - sum (map (probability g) [0 .. 2]))


{-|
Module      : Mandlebrot
Description :
Copyright   : (c) Jason Chen, 2021
License     : MIT
Maintainer  : chezbgone (at) gmail dot com
Stability   : experimental
-}
{-# LANGUAGE NamedFieldPuns #-}
module Mandlebrot where

import Data.Complex
import Data.List (iterate')
import Codec.Picture

import Interpolation

data Resolution = Resolution { width :: Int, height :: Int }

data Bounds = Bounds { top    :: Double
                     , bottom :: Double
                     , left   :: Double
                     , right  :: Double
                     }

data ComputationProps = ComputationProps
    { maxIterations :: Int
    , escapeRadius :: Double
    }

data RenderProps = RenderProps
    { resolution :: Resolution
    , bounds     :: Bounds
    }

data MandlebrotProps = MandlebrotProps
    { computationProps :: ComputationProps
    , renderProps      :: RenderProps
    }

magnitude2 :: RealFloat a => Complex a -> a
magnitude2 (x :+ y) = x*x + y*y

inCardioid :: Complex Double -> Bool
inCardioid (x :+ y) =
    let q = (x - 1/4)^2 + y^2
     in q * (q + x - 1/4) <= 1/4 * y^2

inBulb1 :: Complex Double -> Bool
inBulb1 (x :+ y) = (x + 1)^2 + y^2 <= 1/16

-- https://en.wikipedia.org/wiki/Plotting_algorithms_for_the_Mandelbrot_set#Cardioid_/_bulb_checking
mandlebrotEsc' :: ComputationProps -> Complex Double -> Int
mandlebrotEsc' ComputationProps{ maxIterations, escapeRadius } c =
    let f z = z^2 + c
        orbit = iterate' f 0
     in length $ takeWhile (\p -> magnitude2 p < escapeRadius^2)
              $ take maxIterations orbit

-- optimized
mandlebrotEsc :: ComputationProps -> Complex Double -> Int
mandlebrotEsc cp c = if inCardioid c || inBulb1 c
                         then maxIterations cp
                         else mandlebrotEsc' cp c

xs = (255*) <$> [0, 0.16, 0.42, 0.6425, 0.8575]
rs = [0, 32, 237, 255, 0]
gs = [7, 107, 255, 170, 2]
bs = [100, 203, 255, 0, 0]

rf = interpolate $ piecewiseMonotonicCurve $ zip xs rs
gf = interpolate $ piecewiseMonotonicCurve $ zip xs gs
bf = interpolate $ piecewiseMonotonicCurve $ zip xs bs

intPixel :: Int -> PixelRGB8
intPixel esc =
    let esc' = fromIntegral esc
     in PixelRGB8 (round $ rf esc') (round $ gf esc') (round $ bf esc')

mandlebrotInt :: MandlebrotProps -> DynamicImage
mandlebrotInt mp =
    let cp = computationProps mp
        RenderProps{ resolution=Resolution{ width, height }
                   , bounds=Bounds{ top, bottom, left, right } } = renderProps mp
        dx = (right - left) / fromIntegral width
        dy = (top - bottom) / fromIntegral height
        complex x y = (left + fromIntegral x * dx) :+ (top - fromIntegral y * dy)
     in ImageRGB8 $ generateImage (\x y -> intPixel $ mandlebrotEsc cp $ complex x y) width height


{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE BangPatterns #-}

module Lib
    ( trilinear
    , resample
    , affine
    , array_correlation
    , fisher_transform
    , naive_12p_registration
    ) where

import Data.Array.Repa
import qualified Data.Array.Repa as Repa
import Data.Array.Repa.Algorithms.Matrix
import Statistics.Sample
import Data.Array.Repa.Repr.Unboxed

type DIM3D = (Z :. Double :. Double :. Double)

trilinear :: (Unbox a, Floating a, Fractional a) => Array U DIM3 a -> DIM3D -> a
trilinear !arr !(Z :. x :. y :. z) =
  let
    x0 = floor x
    x1 = ceiling x :: Int
    y0 = floor y
    y1 = ceiling y :: Int
    z0 = floor z
    z1 = ceiling z :: Int
    in let
      v000 = arr ! (Z :. x0 :. y0 :. z0)
      v100 = arr ! (Z :. x1 :. y0 :. z0)
      v010 = arr ! (Z :. x0 :. y1 :. z0)
      v110 = arr ! (Z :. x1 :. y1 :. z0)
      v001 = arr ! (Z :. x0 :. y0 :. z1)
      v101 = arr ! (Z :. x1 :. y0 :. y1)
      v011 = arr ! (Z :. x0 :. y1 :. y1)
      v111 = arr ! (Z :. x1 :. y1 :. y1)
      xd = if x0 /= x1 then
        ((fromIntegral x0) - (realToFrac x)) / (fromIntegral (x0 - x1)) else
        0
      yd = if y0 /= y1 then
        ((fromIntegral y0) - (realToFrac y)) / (fromIntegral (y0 - y1)) else
        0
      zd = if z0 /= z1 then
        ((fromIntegral z0) - realToFrac z) / (fromIntegral (z0 - z1)) else
        0
      in let
        c00 = v000 * (1 - xd) + v100 * xd
        c01 = v001 * (1 - xd) + v101 * xd
        c10 = v010 * (1 - xd) + v110 * xd
        c11 = v011 * (1 - xd) + v111 * xd
        in let
          c0 = c00 * (1 - yd) + c10 * yd
          c1 = c01 * (1 - yd) + c11 * yd
          in  c0 * (1 - zd) + c1 * zd

resample ::
  (Floating a, Floating b, Unbox a, Unbox b, Fractional a, Fractional b) =>
  Array U DIM3 a ->
  (DIM3 -> DIM3D) -> --fun from coordinate system to coordinate system
  (Array U DIM3 a -> DIM3D -> b) -> --interpolator
  Array D DIM3 b

resample !arr !xfm !interp =
  Repa.traverse arr id xfm_and_interp
  where
    xfm_and_interp = \_ d -> ((interp arr (xfm d)))

affine ::
  (Unbox a, Floating a, Fractional a, Real a) =>
  DIM3 -> Array U DIM2 a -> DIM3D

affine !(Z :. x :. y  :. z) !xfm =
  (Z :. x' :. y' :. z')
  where
    [x',y',z',_] = (toList (mmultS (computeS $ Repa.map realToFrac xfm) pnt_array))
      where
        pnt_array = (fromListUnboxed
                     (Z :. (3 :: Int) :. (1 :: Int))
                     (fmap fromIntegral [x,y,z])) -- :: Array U DIM2 Double

array_correlation ::
  (Unbox a, Real a, Fractional a) => Array U DIM3 a -> Array U DIM3 a -> a
array_correlation !arr1 !arr2 =
  realToFrac
   (correlation
    (toUnboxed
     (computeS
      (Repa.zipWith coerce_and_tuple
         arr1 arr2))))
  where
     coerce_and_tuple x y = (realToFrac x, realToFrac y)

fisher_transform = atanh

-- Test code
naive_12p_registration ::
  (Unbox a, Floating a, Fractional a, Real a) =>
  Array U DIM3 a -> [a] -> a

naive_12p_registration !arr !params =
  array_correlation arr (computeS $ resample arr (flip affine xfm) trilinear)
  where
    xfm = fromListUnboxed (Z :. 4 :. 4) params


{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-}

module Fuml.Supervised.KNN where

import Numeric.LinearAlgebra
import Data.List (sortBy)
import Data.Ord (comparing)
import Fuml.Core
import Fuml.Base.KNN
import Control.Monad.Identity

data KNN a = KNN {
   knnPoints :: [(Vector Double, a)]
  }

generalKNN :: Int -> (Vector Double -> Vector Double -> Double) -> ([(Double, a)] -> b) -> Supervisor Identity a (KNN a) b
generalKNN k dist vote  = Supervisor $ \_ theData ->
  return $ Predict (KNN theData) $ \v ->
   let ptDist (v1, y) = (dist v v1,y)
       nns = take k $ sortBy (comparing fst) $ map ptDist $ theData
   in vote nns

binaryKNN :: Int -> Supervisor Identity Bool (KNN Bool) Double
binaryKNN k = generalKNN k euclideanDistance weightedBoolVote

catKNN :: Eq a => Int -> Supervisor Identity a (KNN a) a
catKNN k = generalKNN k euclideanDistance weightedMajorityVote

regressKNN :: Int -> Supervisor Identity Double (KNN Double) Double
regressKNN k = generalKNN k euclideanDistance weightedAvgVote


module AugLag where

import Numeric.LinearAlgebra
import Numeric.NLOPT

{-
See https://www.mat.univie.ac.at/~neum/glopt/coconut/Benchmark/Library1_new_v1.html

Alkyl problem in AMPL format:
var x2 := 1.745, >= 0, <= 2;
var x3 := 1.2, >= 0, <= 1.6;
var x4 := 1.1, >= 0, <= 1.2;
var x5 := 3.048, >= 0, <= 5;
var x6 := 1.974, >= 0, <= 2;
var x7 := 0.893, >= 0.85, <= 0.93;
var x8 := 0.928, >= 0.9, <= 0.95;
var x9 := 8, >= 3, <= 12;
var x10 := 3.6, >= 1.2, <= 4;
var x11 := 1.45, >= 1.45, <= 1.62;
var x12 := 1, >= 0.99, <= 1.01010101010101;
var x13 := 1, >= 0.99, <= 1.01010101010101;
var x14 := 1, >= 0.9, <= 1.11111111111111;
var x15 := 1, >= 0.99, <= 1.01010101010101;

minimize obj:  - 6.3*x5*x8 + 5.04*x2 + 0.35*x3 + x4 + 3.36*x6;

subject to
e2:  - 0.819672131147541*x2 + x5 - 0.819672131147541*x6 = 0;
e3: 0.98*x4 - x7*(0.01*x5*x10 + x4) = 0;
e4:  - x2*x9 + 10*x3 + x6 = 0;
e5: x5*x12 - x2*(1.12 + 0.13167*x9 - 0.0067*x9*x9) = 0;
e6: x8*x13 - 0.01*(1.098*x9 - 0.038*x9*x9) - 0.325*x7 - 0.57425 = 0;
e7: x10*x14 + 22.2*x11 - 35.82 = 0;
e8: x11*x15 - 3*x8 + 1.33 = 0;
-}
alkyl :: [Double] -> Either Result Solution
alkyl x0 =
  let lb = fromList [0, 0, 0, 0, 0, 0.85, 0.9, 3, 1.2, 1.45, 0.99, 0.99, 0.9, 0.99]
      ub = fromList [2, 1.6, 1.2, 5, 2, 0.93, 0.95, 12, 4, 1.62, 1.01010101010101, 1.01010101010101, 1.11111111111111, 1.01010101010101]
      objf x = - 6.3 * x ! 3 * x ! 6 + 5.04 * x ! 0 + 0.35 * x ! 1 + x ! 2 + 3.36 * x ! 4
      stop = ObjectiveRelativeTolerance 1e-12 :| []
      eqCons =
        [ EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> -0.819672131147541 * x ! 0 + x ! 3 - 0.819672131147541 * x ! 4),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> 0.98 * x ! 2 - x ! 5 * (0.01 * x ! 3 * x ! 8 + x ! 2)),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> - x ! 0 * x ! 7 + 10 * x ! 1 + x ! 4),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> x ! 3 * x ! 10 - x ! 0 * (1.12 + 0.13167 * x ! 7 - 0.0067 * x ! 7 * x ! 7)),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> x ! 6 * x ! 11 - 0.01 * (1.098 * x ! 7 - 0.038 * x ! 7 * x ! 7) - 0.325 * x ! 5 - 0.57425),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> x ! 8 * x ! 12 + 22.2 * x ! 9 - 35.82),
              eqConstraintTolerance = 1e-10
            },
          EqualityConstraint
            { eqConstraintFunctions = Scalar (\x -> x ! 9 * x ! 13 - 3 * x ! 6 + 1.33),
              eqConstraintTolerance = 1e-10
            }
        ]
      problem = AugLagProblem eqCons [] (AUGLAG_EQ_LOCAL subproblem)
      subproblem = LocalProblem (fromIntegral $ size lb) stop algorithm
      algorithm = SBPLX objf [LowerBounds lb, UpperBounds ub] Nothing
   in minimizeAugLag problem (fromList x0)


module Internal
  where
import Data.Complex

type Cplx = Complex Double

toCplx :: Double -> Cplx
toCplx x = x :+ 0.0

getPhiK :: Cplx -> (Cplx, Int)
getPhiK phi
  | realPart phi > pi/2 =
    until (\(x,_) -> realPart x <= pi/2) (\(x,k) -> (x-pi,k+1)) (phi,0)
  | realPart phi < -pi/2 =
    until (\(x,_) -> realPart x >= -pi/2) (\(x,k) -> (x+pi,k-1)) (phi,0)
  | otherwise = (phi,0)

atanC :: Cplx -> Cplx
atanC z = i * (log(1-i*z) - log(1+i*z)) / 2
  where
    i = 0.0 :+ 1.0


-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Packed.Vector
-- Copyright   :  (c) Alberto Ruiz 2009
-- License     :  GPL
--
-- Maintainer  :  Alberto Ruiz <aruiz@um.es>
-- Stability   :  provisional
--
-- Random vectors and matrices.
--
-----------------------------------------------------------------------------

module Data.Packed.Random (
    Seed,
    RandDist(..),
    randomVector,
    gaussianSample,
    uniformSample
) where

import Numeric.GSL.Vector
import Data.Packed
import Numeric.ContainerBoot
import Numeric.LinearAlgebra.Algorithms

type Seed = Int

-- | Obtains a matrix whose rows are pseudorandom samples from a multivariate
-- Gaussian distribution.
gaussianSample :: Seed
               -> Int -- ^ number of rows
               -> Vector Double -- ^ mean vector
               -> Matrix Double -- ^ covariance matrix
               -> Matrix Double -- ^ result
gaussianSample seed n med cov = m where
    c = dim med
    meds = konst 1 n `outer` med
    rs = reshape c $ randomVector seed Gaussian (c * n)
    m = rs `mXm` cholSH cov `add` meds

-- | Obtains a matrix whose rows are pseudorandom samples from a multivariate
-- uniform distribution.
uniformSample :: Seed
               -> Int -- ^ number of rows
               -> [(Double,Double)] -- ^ ranges for each column
               -> Matrix Double -- ^ result
uniformSample seed n rgs = m where
    (as,bs) = unzip rgs
    a = fromList as
    cs = zipWith subtract as bs
    d = dim a
    dat = toRows $ reshape n $ randomVector seed Uniform (n*d)
    am = konst 1 n `outer` a
    m = fromColumns (zipWith scale cs dat) `add` am


module Main where

import Codec.Picture
import Codec.Picture.Gif
import Codec.Picture.Png
import Codec.Picture.Types
import Control.Parallel
import Control.Parallel.Strategies
import Data.Complex
import Data.List.Split
import Data.Vector.Storable
import System.Environment

main = do
  putStrLn "Resolution: "
  size <- read <$> getLine
  putStrLn "Iterations: "
  iters <- read <$> getLine
  writePng "out.png" $ genFractal size iters 2

genFractal :: Int -> Int -> Complex Double -> Image Pixel8
genFractal size iters comp = Image size size $ fromList pixels
  where
    pixels =
      [genPixel comp (i `mod` size) (i `div` size) | i <- [0 .. size * size `div` 2]] `using`
      parList rdeepseq :: [Pixel8]
    genPixel comp x y =
      fromIntegral $ div 0xff iters * (iters - boundedUntil comp) :: Pixel8
      where
        boundedUntil =
          isBounded iters $
          fromIntegral (x - div size 2) / (fromIntegral size / 3) :+
          fromIntegral (y - div size 2) / (fromIntegral size / 3)

isBounded iters c comp = isBounded' 1 c
  where
    isBounded' i z
      | i == iters = i
      | magnitude z > 2 = i
      | otherwise = isBounded' (i + 1) $ (z ** comp) + c


module CommonFunctions where

import Data.Complex

-- f(z) = z^2 + c
f1 :: Complex Double -> Complex Double -> Complex Double
f1 c z = z**2 + c

-- below is valid haskell
-- f1 :: Double -> Double -> Double
-- f1 a b = a**2 + b


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE BangPatterns #-}
-- |
-- Module      : Statistics.Correlation.Pearson
--
module Statistics.Correlation
    ( -- * Pearson correlation
      pearson
    , pearsonMatByRow
      -- * Spearman correlation
    , spearman
    , spearmanMatByRow
    ) where

import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import Statistics.Matrix
import Statistics.Sample
import Statistics.Test.Internal (rankUnsorted)

----------------------------------------------------------------
-- Pearson
----------------------------------------------------------------

-- | Pearson correlation for sample of pairs. Exactly same as
-- 'Statistics.Sample.correlation'
pearson :: (G.Vector v (Double, Double), G.Vector v Double)
        => v (Double, Double) -> Double
pearson = correlation
{-# INLINE pearson #-}

-- | Compute pairwise pearson correlation between rows of a matrix
pearsonMatByRow :: Matrix -> Matrix
pearsonMatByRow m
  = generateSym (rows m)
      (\i j -> pearson $ row m i `U.zip` row m j)
{-# INLINE pearsonMatByRow #-}

----------------------------------------------------------------
-- Spearman
----------------------------------------------------------------

-- | compute spearman correlation between two samples
spearman :: ( Ord a
            , Ord b
            , G.Vector v a
            , G.Vector v b
            , G.Vector v (a, b)
            , G.Vector v Int
            , G.Vector v Double
            , G.Vector v (Double, Double)
            , G.Vector v (Int, a)
            , G.Vector v (Int, b)
            )
         => v (a, b)
         -> Double
spearman xy
  = pearson
  $ G.zip (rankUnsorted x) (rankUnsorted y)
  where
    (x, y) = G.unzip xy
{-# INLINE spearman #-}

-- | compute pairwise spearman correlation between rows of a matrix
spearmanMatByRow :: Matrix -> Matrix
spearmanMatByRow
  = pearsonMatByRow . fromRows . fmap rankUnsorted . toRows
{-# INLINE spearmanMatByRow #-}


module Util.Numeric where

import Control.Arrow (second)
import Numeric.Log
import Numeric.SpecFunctions (logGamma)

average :: Fractional a => [a] -> a
average = go 0 0 where
  go n x [] = x / fromIntegral n
  go n x (z : zs) = go (n + 1) (x + z) zs

shiftByMax :: (Precise d, RealFloat d, Ord d) => [(a, Log d)] -> [(a, Log d)]
shiftByMax xs = map (second (/ x')) xs
  where x' = maximum $ map snd xs

exponentiateWeights :: (Precise d, RealFloat d, Ord d) => [(a, Log d)] -> [(a, d)]
exponentiateWeights = map (second (exp . ln)) . shiftByMax

weightedAverage :: Fractional a => [(a, a)] -> a
weightedAverage = go 0 0 where
  go w x [] = x / w
  go w x ((y, ll) : ys) = go (w + ll) (ll * y + x) ys

weightedAverageGeneric :: Fractional a => (a -> b -> b) -> b -> (b -> b -> b) -> [(b, a)] -> b
weightedAverageGeneric scale zero plus = go 0 zero where
  go w x [] = scale (recip w) x
  go w x ((y, ll) : ys) = go (w + ll) (scale ll y `plus` x) ys

logFact :: Int -> Double
logFact n = logGamma (fromIntegral (n + 1))


{-# LANGUAGE UndecidableInstances #-} --For the BitPack instance
module Clash.DSP.Complex where

import Clash.Prelude

import GHC.Generics
import Test.QuickCheck

import qualified Data.Complex as C

{-| I defined my own complex type so that I can write a Num instance without the RealFloat constraint. TODO: think about whether this is really a good idea. -}
data Complex a = a :+ a deriving (Show, Lift, Generic, ShowX, NFDataX, Functor, Foldable, Traversable, Eq, Ord)

deriving instance (BitPack a, KnownNat (BitSize a)) => BitPack (Complex a)

instance Num a => Num (Complex a) where
    (a :+ b) + (c :+ d) = (a + c) :+ (b + d)
    (a :+ b) - (c :+ d) = (a - c) :+ (b - d)
    (a :+ b) * (c :+ d) = (a * c - b * d) :+ (a * d + b * c)
    fromInteger x       = (fromInteger x :+ 0)

instance Applicative Complex where
    pure a = a :+ a
    f :+ g <*> a :+ b = f a :+ g b

instance Arbitrary a => Arbitrary (Complex a)
    where
    arbitrary = liftA2 (:+) arbitrary arbitrary

instance Default a => Default (Complex a)
    where
    def = def :+ def

realPart :: Complex a -> a
realPart (x :+ _) = x

imagPart :: Complex a -> a
imagPart (_ :+ y) = y

fromComplex (a C.:+ b) = a :+ b
toComplex   (a :+ b)   = a C.:+ b

conjugate :: Num a => Complex a -> Complex a
conjugate (x :+ y) = x :+ (-y)

cMul
    :: ExtendingNum a b
    => ExtendingNum (MResult a b) (MResult a b)
    => Complex a
    -> Complex b
    -> Complex (AResult (MResult a b) (MResult a b))
cMul (xr :+ xi) (yr :+ yi)
    =  ((xr `mul` yr) `sub` (xi `mul` yi))
    :+ ((xr `mul` yi) `add` (xi `mul` yr))

cMul3
    :: ExtendingNum b b
    => ExtendingNum a a
    => ExtendingNum a (AResult b b)
    => ExtendingNum b (AResult a a)
    => ExtendingNum (MResult b (AResult a a)) (MResult a (AResult b b))
    => Complex a
    -> Complex b
    -> Complex (AResult (MResult b (AResult a a)) (MResult a (AResult b b)))
cMul3 (xr :+ xi) (yr :+ yi)
    =  (k1 `sub` k3)
    :+ (k1 `add` k2)
    where
    k1 = yr `mul` (xr `add` xi)
    k2 = xr `mul` (yi `sub` yr)
    k3 = xi `mul` (yr `add` yi)

cMulPipe
    :: HiddenClockResetEnable dom
    => ExtendingNum a b
    => ExtendingNum (MResult a b) (MResult a b)
    => NFDataX (MResult a b)
    => NFDataX (AResult (MResult a b) (MResult a b))
    => Signal dom Bool
    -> Signal dom (Complex a)
    -> Signal dom (Complex b)
    -> Signal dom (Complex (AResult (MResult a b) (MResult a b)))
cMulPipe en x y
    = liftA2 (:+) rr ri
    where
    --Products
    xryr = regEn (errorX "initial xryr") en $ liftA2 mul (realPart <$> x) (realPart <$> y)
    xiyi = regEn (errorX "initial xiyi") en $ liftA2 mul (imagPart <$> x) (imagPart <$> y)
    xryi = regEn (errorX "initial xryi") en $ liftA2 mul (realPart <$> x) (imagPart <$> y)
    xiyr = regEn (errorX "initial xiyr") en $ liftA2 mul (imagPart <$> x) (realPart <$> y)
    --Sums
    rr   = regEn (errorX "initial rr")   en $ liftA2 sub xryr xiyi
    ri   = regEn (errorX "initial ri")   en $ liftA2 add xryi xiyr

cMul3Pipe
    :: HiddenClockResetEnable dom
    => ExtendingNum b b
    => ExtendingNum a a
    => ExtendingNum a (AResult b b)
    => ExtendingNum b (AResult a a)
    => ExtendingNum (MResult b (AResult a a)) (MResult a (AResult b b))
    => NFDataX (AResult a a)
    => NFDataX (AResult b b)
    => NFDataX (MResult b (AResult a a))
    => NFDataX (MResult a (AResult b b))
    => NFDataX (AResult (MResult b (AResult a a)) (MResult a (AResult b b)))
    => NFDataX a
    => NFDataX b
    => Signal dom Bool
    -> Signal dom (Complex a)
    -> Signal dom (Complex b)
    -> Signal dom (Complex (AResult (MResult b (AResult a a)) (MResult a (AResult b b))))
cMul3Pipe en x y
    =  liftA2 (:+) rr ri
    where
    --Sums
    xSum    = regEn (errorX "initial xSum")    en $ liftA2 add (realPart <$> x) (imagPart <$> x)
    yDiff   = regEn (errorX "initial yDiff")   en $ liftA2 sub (imagPart <$> y) (realPart <$> y)
    ySum    = regEn (errorX "initial ySum")    en $ liftA2 add (realPart <$> y) (imagPart <$> y)
    --Delays
    xD      = regEn (errorX "initial xD") en x
    yD      = regEn (errorX "initial yD") en y
    --Products
    yrXSum  = regEn (errorX "initial yrXSum")  en $ liftA2 mul (realPart <$> yD) xSum
    xrYDiff = regEn (errorX "initial xrYDiff") en $ liftA2 mul (realPart <$> xD) yDiff
    xiYSum  = regEn (errorX "initial xiYSum")  en $ liftA2 mul (imagPart <$> xD) ySum
    --Sums
    rr      = regEn (errorX "initial rr")      en $ liftA2 sub yrXSum xiYSum
    ri      = regEn (errorX "initial ri")      en $ liftA2 add yrXSum xrYDiff


-- |
-- Defines Log-domain probability density functions

{-# LANGUAGE ViewPatterns, NoMonomorphismRestriction, FlexibleInstances #-}
module Math.Probably.PDF where

import qualified Math.Probably.Student as S
import Numeric.LinearAlgebra
import Control.Spoon
import Control.DeepSeq
import qualified Data.Vector.Storable as VS

-- | The type of probablility density functions
type PDF a = a->Double

instance Show (a->Double) where
    show f = error "Math.Prob.PDF: showing function"

instance Eq (a->Double) where
    f == g = error "Math.Prob.PDF: comparing functions!"

instance Num a => Num (a->Double) where
    f + g = \x-> f x + g x
    f * g = \x-> f x * g x
    f - g = \x-> f x - g x
    abs f = \x -> abs (f x)
    signum f = \x-> signum $ f x
    fromInteger = error $ "Math.Prob.PDF: frominteger on function"

-- | Uniform distributions
uniform :: (Real a, Fractional a) => a-> a-> PDF a
uniform from to = \x-> if x>=from && x <=to
                               then log $ realToFrac $ 1/(to-from )
                               else 0

--http://en.wikipedia.org/wiki/Normal_distribution
-- | Normal distribution
gauss :: (Real a, Floating a) => a-> a-> PDF a
gauss mean sd x = realToFrac $ negate $ (x-mean)**2/(2*sd*sd) + log(sd*sqrt(2*pi))

-- | Normal distribution by variance
normal :: (Real a, Floating a) => a-> a-> a -> a
normal = normalLogPdf

normalLogPdf :: (Real a, Floating a) => a-> a-> a -> a
normalLogPdf mean variance x
   = ((log 1)-(0.500*(log ((2.000*pi)*variance))))-(((x-mean)**2)/(2*variance))

-- | Normal distribution, specialised for Doubles
gaussD :: Double -> Double-> PDF Double
gaussD mean sd x = negate $ (x-mean)**2/(2*sd*sd) + log(sd*sqrt(2*pi))

gammafun = exp . S.gammaln

-- | <http://en.wikipedia.org/wiki/Gamma_distribution>
gammaD :: Double -> Double -> PDF Double
gammaD k theta x = log $ x**(k-1)*(exp(-x/theta)/(theta**k*(exp (S.gammaln k))))

invGammaD :: Double -> Double -> PDF Double
invGammaD a b x =log $ (b**a/gammafun a)*(1/x)**(a+1)*exp(-b/x)

logNormal m var x = negate $ log (x*sqrt(2*pi*var)) + (log x - m)**2 / (2*var)

logNormalD :: Double -> Double-> PDF Double
logNormalD = logNormal

-- | Beta distribution
beta a b x = log $ (recip $ S.beta a b) * x ** (a-1) * (1-x) ** (b-1)

-- | Binomial distribution. This is the Probability Mass Function, not PDF
binomial :: Int -> Double -> PDF Int
binomial n p k =
    let realk = realToFrac k
    in log (realToFrac (choose (toInteger n) (toInteger k))) + realk * log( p ) + (realToFrac $ n-k) * log( (1-p) )
 where --http://blog.plover.com/math/choose.html
   choose :: Integer -> Integer -> Integer
   choose n 0 = 1
   choose 0 k = 0
   choose (n) (k) |  k > n `div` 2 = choose n (n-k)
                  |  otherwise = (choose (n-1) (k-1)) * (n) `div` (k)

-- | the joint distribution of two independent distributions
zipPdfs :: Num a => PDF a -> PDF b -> PDF (a,b)
zipPdfs fx fy (x,y) = fx x + fy y

-- | the multiplication of two PDFS
mulPdf :: Num a => PDF a -> PDF a -> PDF a
mulPdf d1 d2 = \x -> (d1 x + d2 x)

--instance Num a => Num (PDF a) where

--instance NFData (Matrix Double)
--   where rnf mat = mapMatrix (\x-> x `seq` 1.0::Double) mat `seq` ()

-- | multivariate normal
multiNormal :: Vector Double -> Matrix Double -> PDF (Vector Double)
multiNormal mu sigma =
  let k = realToFrac $ dim mu
      invSigma =  inv sigma
      mat1 = head . head . toLists
  in \x-> log (recip ((2*pi)**(k/2) * sqrt(det sigma))) + (mat1 $ negate $ 0.5*(asRow $ x-mu) `multiply` invSigma `multiply` (asColumn $ x-mu) )

multiNormalByInv :: Double -> Matrix Double -> Vector Double -> PDF (Vector Double)
multiNormalByInv lndet invSigma mu =
  let k = realToFrac $ dim mu
      mat1 = head . head . toLists
  in \x-> log 1 - (k/2)*log (2*pi) - lndet/2 + (mat1 $ negate $ 0.5*(asRow $ x-mu) `multiply` invSigma `multiply` (asColumn $ x-mu) )

multiNormalByInvFixCov ::  Matrix Double -> Vector Double -> PDF (Vector Double)
multiNormalByInvFixCov invSigma mu =
  let k = realToFrac $ dim mu
      mat1 = head . head . toLists
  in \x-> (mat1 $ negate $ 0.5*(asRow $ x-mu) `multiply` invSigma `multiply` (asColumn $ x-mu) )

multiNormalIndep :: Vector Double -> Vector Double -> PDF (Vector Double)
multiNormalIndep vars mus xs= VS.sum $ VS.zipWith3 (\var mu x -> normalLogPdf mu var x) vars mus xs

{-mu1 = 2 |> [0, 0::Double]
sig1 = (2><2)[1::Double, 0,
              0, 1]

tst = multiNormal mu1 sig1 mu1
tsta = inv sig1
tstb = det sig1
tstc = let mu = mu1
           sigma = sig1
           x = mu1
           invSigma = inv sigma
       in (asRow $ x-mu) `multiply` invSigma `multiply` (asColumn $ x-mu)  -}

posdefify m =
   let (eigvals, eigvecM) = eigSH $ mkSym {- $ trace (show m) -}  m
       n = rows m
       eigValsVecs = map f $ zip (toList eigvals) (toColumns eigvecM)
       f (val,vec) = (abs val,vec)
       q = fromColumns $ map snd eigValsVecs
       bigLambda = diag $ fromList $ map fst eigValsVecs
   in mkSym $ q `multiply` bigLambda `multiply` inv q

mkSym m = buildMatrix (rows m) (cols m)$ \(i,j) ->if i>=j then m @@>(i,j)
                                                           else m @@>(j,i)


{-# LANGUAGE RankNTypes #-}

module Kalman
  ( movingAverage,
    System (..),
    Estimate (..),
    Measurement (..),
    genSigmas,
    ekf,
    ut,
    ukf,
    weightedCrossCov,
    runKF,
  )
where

import Control.Applicative
import Numeric.AD
import Numeric.AD.Internal.Reverse
import Numeric.LinearAlgebra
import Sim
import System.Random

type Sigmas = [[Double]]

data System = System
  { fA, fH :: forall a. Floating a => ([a] -> [a]),
    kQ, kR :: Matrix Double
  }

data Estimate = Estimate
  { sX :: Vector Double,
    sP :: Matrix Double
  }
  deriving (Show)

-- Simple 2 tap FIR to appx moving average filter
movingAverage :: [Vector Double] -> [Vector Double]
movingAverage = scanl1 (\v1 v2 -> (0.9 * v1) + (0.1 * v2))

-- kalman :: System -> Estimate -> Measurement -> Estimate
-- kalman (System a c q r) (Estimate x p) z = Estimate x' p' where
--   -- Convert lists to matrices since we have linear system
--   lA = fromLists a
--   lC = fromLists c
--   -- prediction step
--   px = lA #> x
--   pp = lA <> p <> tr lA + q
--   -- update step
--   g = pp <> tr lC <> inv (lC <> pp <> tr lC + r)
--   x' = px + g #> (z - lC #> px)
--   p' = (ident (size x) - g <> lC) <> pp

runKF :: (System -> Estimate -> Measurement -> Estimate) -> System -> Estimate -> [Measurement] -> [Estimate]
runKF kf sys = scanl (kf sys)

ekf :: System -> Estimate -> Measurement -> Estimate
ekf (System fA fH kQ kR) (Estimate x p) z = Estimate x' p'
  where
    -- prediction step
    a = fromLists (jacobian fA (toList x))
    px = fA $ toList x
    pp = a <> p <> tr a + kQ
    -- update step
    h = fromLists $ jacobian fH px
    k = pp <> tr h <> inv (h <> pp <> tr h + kR)
    x' = vector px + k #> (z - vector (take (size z) $ fH px))
    p' = (ident (size x) - k <> h) <> pp

genSigmas :: Estimate -> Double -> Sigmas
genSigmas (Estimate x p) c = sigmas
  where
    -- Cholesky Factorization to get sqrt of matrix
    cP = scale (sqrt c) $ chol $ sym p
    -- Add/sub the sqrt covariance matrix from the current estimate of x
    xs = fromLists $ replicate (size x) (toList x)
    pos = toLists $ xs + cP
    neg = toLists $ xs - cP
    -- Combine all sigma points including the original estimate of x at the head
    sigmas = [toList x] ++ pos ++ neg

-- Unscented Transformation
ut :: [Vector Double] -> [Double] -> [Double] -> Estimate
ut xs wm wc = Estimate x' p'
  where
    -- Weight each sigma by scaling factor
    xw = getZipList $ scale <$> ZipList wm <*> ZipList xs
    x' = sum xw
    -- Compute forecasted state statistics
    v1 = map (\v -> fromColumns [v - x']) xs
    v2 = map (\v -> fromRows [v - x']) xs
    cov = getZipList $ (<>) <$> ZipList v1 <*> ZipList v2
    covw = getZipList $ scale <$> ZipList wc <*> ZipList cov
    p' = sum covw

weightedCrossCov :: Vector Double -> [Vector Double] -> Vector Double -> [Vector Double] -> [Double] -> Matrix Double
weightedCrossCov v1 vs1 v2 vs2 wc = cP
  where
    vs1' = map (\v -> fromColumns [v - v1]) vs1
    vs2' = map (\v -> fromRows [v - v2]) vs2
    cov = getZipList $ (<>) <$> ZipList vs1' <*> ZipList vs2'
    covw = getZipList $ scale <$> ZipList wc <*> ZipList cov
    cP = sum covw

ukf :: System -> Estimate -> Measurement -> Estimate
ukf (System fA fH kQ kR) (Estimate x p) z = Estimate xh ph
  where
    l = fromIntegral $ size x
    m = fromIntegral $ size z
    alpha = 1e-3
    ki = 0
    beta = 2

    lambda = alpha ^ 2 * (l + ki) - l
    c = l + lambda

    wm = (lambda / c) : replicate (2 * fromIntegral (size x)) (0.5 / c)
    wc = ((lambda / c) + (1 - alpha ^ 2 + beta)) : replicate (2 * fromIntegral (size x)) (0.5 / c)

    -- Generate sigma points around current estimate
    sigmas = genSigmas (Estimate x p) c

    -- Run sigmas through non linear function to produce new points
    xs = map (fromList . fA) sigmas
    zs = map (fromList . fH) sigmas

    Estimate x' cX = ut xs wm wc
    Estimate z' cZ = ut zs wm wc

    -- Calculate the weighted cross covariance
    cXZ = weightedCrossCov x' xs z' zs wc

    kK = cXZ <> inv (cZ + kR)
    xh = x' + kK #> (z - z')
    ph = (cX + kQ) - kK <> (cZ + kR) <> tr kK


module CubicBezier ( CubicBezier (..)
                   , pointAt
                   , bezierSplitAt
                   , isClockwise
                   , inflectionPoints
                   , realInflectionPoint
                   ) where

import Linear
import Control.Lens
import Data.Complex

data CubicBezier = CubicBezier { _p1 :: V2 Double
                               , _c1 :: V2 Double
                               , _c2 :: V2 Double
                               , _p2 :: V2 Double
                               } deriving Show

pointAt :: CubicBezier -> Double -> V2 Double
pointAt bezier t =  ((1 - t) ** 3) *^ _p1 bezier +
                    ((1 - t) ** 2) * 3 * t *^ _c1 bezier +
                    (t ** 2) * (1 - t) * 3 *^ _c2 bezier +
                    (t ** 3) *^ _p2 bezier

bezierSplitAt :: CubicBezier -> Double -> (CubicBezier, CubicBezier)
bezierSplitAt bezier t = (CubicBezier (_p1 bezier) p0 p01 dp, CubicBezier dp p12 p2 (_p2 bezier))
    where
        p0 = _p1 bezier + t *^ (_c1 bezier - _p1 bezier)
        p1 = _c1 bezier + t *^ (_c2 bezier - _c1 bezier)
        p2 = _c2 bezier + t *^ (_p2 bezier - _c2 bezier)

        p01 = p0 + t *^ (p1 - p0)
        p12 = p1 + t *^ (p2 - p1)

        dp = p01 + t *^ (p12 - p01)

isClockwise :: CubicBezier -> Bool
isClockwise bezier = s < 0
    where
        s = (_c1 bezier ^. _x - _p1 bezier  ^. _x) * (_c1 bezier ^. _y + _p1 bezier ^. _y)
          + (_c2 bezier ^. _x - _c1 bezier  ^. _x) * (_c2 bezier ^. _y + _c1 bezier ^. _y)
          + (_p2 bezier ^. _x - _c2 bezier  ^. _x) * (_p2 bezier ^. _y + _c2 bezier ^. _y)
          + (_p1 bezier ^. _x - _p2 bezier  ^. _x) * (_p1 bezier ^. _y + _p2 bezier ^. _y)

inflectionPoints :: CubicBezier -> (Complex Double, Complex Double)
inflectionPoints bezier = (t1, t2)
    where
        pa = _c1 bezier - _p1 bezier
        pb = _c2 bezier - _c1 bezier - pa
        pc = _p2 bezier - _c2 bezier - pa - 2 *^ pb

        a = (pb ^. _x * pc ^. _y - pb ^. _y * pc ^. _x) :+ 0
        b = (pa ^. _x * pc ^. _y - pa ^. _y * pc ^. _x) :+ 0
        c = (pa ^. _x * pb ^. _y - pa ^. _y * pb ^. _x) :+ 0

        t1 = (-b + sqrt (b * b  - 4 * a * c)) / (2 * a)
        t2 = (-b - sqrt (b * b  - 4 * a * c)) / (2 * a)

realInflectionPoint :: Complex Double -> Bool
realInflectionPoint c = imagPart c == 0 && realPart c > 0 && realPart c < 1


import Data.Complex

-- Cooley-Tukey
fft [] = []
fft [x] = [x]
fft xs = zipWith (+) ys ts ++ zipWith (-) ys ts
    where n = length xs
          ys = fft evens
          zs = fft odds
          (evens, odds) = split xs
          split [] = ([], [])
          split [x] = ([x], [])
          split (x:y:xs) = (x:xt, y:yt) where (xt, yt) = split xs
          ts = zipWith (\z k -> exp' k n * z) zs [0..]
          exp' k n = cis $ -2 * pi * (fromIntegral k) / (fromIntegral n)

main = mapM_ print $ fft [1,1,1,1,0,0,0,0]


module Main where

import Math.Probably.Sampler
import Math.Probably.RandIO
import Math.Probably.FoldingStats

import Numeric.LinearAlgebra

import Math.Probably.Unscented

import Graphics.Gnewplot.Exec
import Graphics.Gnewplot.Types
import Graphics.Gnewplot.Style
import Graphics.Gnewplot.Panels
import Graphics.Gnewplot.Instances
import Graphics.Gnewplot.Histogram

dt = 0.1

f v =  fromList [t1, x0 + dt * sin (t1) + noisex]
  where t0 = v @> 0
        x0 = v @> 1
        noiset = v @> 2
        noisex = v @> 3
        t1 = t0+dt + noiset

f' v =  fromList [t1, x0 + dt * sin (t1) ]
  where t0 = v @> 0
        x0 = v @> 1
        t1 = t0+dt

g v = fromList [t1+noiset, x1+noisex]
  where t1 = v @> 0
        x1 = v @> 1
        noiset = v @> 2
        noisex = v @> 3

g' v = fromList [t1, x1]
  where t1 = v @> 0
        x1 = v @> 1

procCov = (2><2) [0.001, 0,
                  0,     0.01]

obsCov = (2><2) [0.01, 0,
                  0,     0.01]

--obsCov = (1><1)  [0.01]

testUT = do
  let cov = (2><2) [0.1,0.08,0.08,0.1]
      mn = (2 |> [1,1])
      xform v = let [x,y] = toList v in fromList [x*x, y*y]
      mkpt = ((\[x,y] -> (x,y)) .toList)
  pts <- sample $ sequence $ replicate 1000 $ multiNormal mn cov
  let (mnU, covU, sigmapts) = unscentedTransform (mn,cov) xform
  let xformPts = map xform pts
  io $ gnuplotOnScreen $ map mkpt pts :+: map mkpt sigmapts --  :+: map mkpt xformPts
  io $ print mnU
  io $ print covU
  (mnE, covE) <- sample $ smellyTransform (multiNormal mn cov) 1000 xform
  io $ print mnE
  io $ print covE

main = runRIO $ do
     xyvs <- sample $ simDynamical 2000 f g procCov obsCov (fromList [0, 0.1])
     --let xyvs = flip map xyvs' $ \(xv,yv) -> (xv,negate yv)
--     pts <- sample $ sequence $ replicate 1000 $ lastSDESampler dt
     --w <- sample $ fmap (eulerMaruyama dt 0 a b) $ weiner dt 1
     let xhats = unscentedKalmanFilterAdditive f' g' procCov obsCov (fromList [0,0], ((2><2) [1,0,0,1])) $ map snd xyvs
     let get s f =  (s, Lines [] $ zip [(0::Double)..] $ map f xyvs)
     io $ gnuplotOnScreen $ get "y" ((@>1) . snd) :+: get "x" ((@>1) . fst)
                            :+: ("xhat", Lines [] $ zip [(0::Double)..] $ map ((@>1) . fst)  xhats)
     io $ print $ take 10 $ map snd xyvs

     testUT
--     io $ gnuplotOnScreen $ get "x" ((@>1) . fst)
--     io $ print $ runStat meanSDF $ pts


module NeuralA where

import Numeric.LinearAlgebra

x = vector [-5.0,-4.9..5.0]
y1 = cmap sigmoid x

sigmoid :: Double -> Double
sigmoid x = 1.0 / (1.0 + exp(-x))

step_func :: Double -> Double
step_func x
  | x > 0.0 = 1.0
  | otherwise = 0.0

relu :: Double -> Double
relu x
  | x > 0.0 = x
  | otherwise = 0.0


module Embadd where

import Control.Arrow (second)
import Data.Function (on)
import Data.List (foldl', sortBy)
import Data.Map.Strict (Map, empty, findWithDefault, insertWith, size)
import qualified Data.Map.Strict as M (fromList, toList, size, lookup)
import Data.Array (listArray, elems)

import Numeric.LinearAlgebra as LA
import System.Console.Readline

import Numeric.Statistics.PCA

import Graphics.Rendering.Chart hiding (Vector)
import Graphics.Rendering.Chart.Backend.Cairo
import Data.Default.Class
import Control.Lens hiding ((<.>))

type VDict = Map String (Vector R)

data Expr = Wrd String
          | Plus Expr Expr
          | UnMinus Expr
          | NullExpr

cosineD a b = (a LA.<.> b) / (norm_2 a * norm_2 b)

chart ws = toRenderable layout
  where
    layout = layout_title .~ ""
           $ layout_plots .~ [toPlot texts]
           $ def

    texts = plot_annotation_values .~ ws
          $ plot_annotation_angle .~ 0 -- degrees
          $ plot_annotation_style .~ fontStyle
          $ plot_annotation_hanchor .~ HTA_Centre -- the horizontal anchor around which the text is rotated
          $ plot_annotation_vanchor .~ VTA_Centre -- the vertical anchor
          $ def

    fontStyle = font_size .~ 16
              $ font_weight .~ FontWeightBold
              $ def

parseExpr :: Expr -> [String] -> Expr
parseExpr NullExpr ("-":w:ws) = parseExpr (UnMinus (Wrd w)) ws
parseExpr NullExpr (w:ws) = parseExpr (Wrd w) ws
parseExpr e ("+":w:ws) = parseExpr (Plus e (Wrd w)) ws
parseExpr e ("-":w:ws) = parseExpr (Plus e (UnMinus (Wrd w))) ws
parseExpr e [] = e
parseExpr _ _ = NullExpr

sumExpr vecDict (Plus e1 e2) = do
  a <- sumExpr vecDict e1
  b <- sumExpr vecDict e2
  return $ a + b
sumExpr vecDict (UnMinus e) = do
  x <- sumExpr vecDict e
  return $ - x
sumExpr vecDict (Wrd w) = M.lookup w vecDict

nearest vDict v1 = map fst . sortBy (flip compare `on` (cosineD v1 . snd)) $ M.toList vDict

eWrds (Wrd w) = [w]
eWrds (UnMinus e) = eWrds e
eWrds (Plus a b) = eWrds a ++ eWrds b

readEvalPrintLoop :: VDict -> IO ()
readEvalPrintLoop vecDict = do
  maybeLine <- readline "> "
  case words <$> maybeLine of
    Nothing     -> return () -- EOF / control-d
    Just ("PCA":wrds) -> do
      addHistory $ unwords ("PCA":wrds)
      case mapM (`M.lookup` vecDict) wrds :: Maybe [Vector R] of
        Nothing -> putStrLn "error: OOV"
        Just vcs -> do
          let vData = listArray (1, LA.size $ head vcs) . toRows $ fromColumns vcs
              reduced = toColumns . fromRows . elems . pcaTransform vData . snd $ pcaN vData 2
          print reduced
          renderableToFile def "pca.png" . chart . map (\(w,v) -> (v ! 0, v ! 1, w)) $ zip wrds reduced
          return ()
      readEvalPrintLoop vecDict
    Just wrds -> do
      addHistory $ unwords wrds
      case parseExpr NullExpr wrds of
        NullExpr -> putStrLn "bad parse"
        e -> case sumExpr vecDict e of
          Just eSum -> putStrLn . unlines . take 7 . filter (\x -> (x `notElem` eWrds e)) $ nearest vecDict eSum
          Nothing -> putStrLn "error: OOV"
      readEvalPrintLoop vecDict

computeNorm :: FilePath -> IO ()
computeNorm vectorFile = do
  vectorCont <- readFile vectorFile
  let vLine (w:ws) = (w, vector $ map read ws :: Vector Double)
      norms = map (second (show . norm_2) . vLine . words) . drop 1 . lines $ vectorCont
  mapM_ (putStrLn .  (\(a, b) -> a ++ "\t" ++ b)) norms


module Main where

import Numeric.LinearAlgebra
import Hoqus.Dirac

main = do
  let dim = 12
  let a = ket dim 3
  let b = ket dim 6
  let res0 = a <.> b
  let res1 = a <.> a
  print res0
  print res1


{-# LANGUAGE DataKinds #-}
module Grenade.Utils.LinearAlgebra
    ( sumV
    , sumM
    , squareV
    , squareM
    ) where

import           GHC.TypeLits
import           Grenade.Types
import           Numeric.LinearAlgebra.Static

sumV :: (KnownNat n) => R n -> RealNum
sumV v = v <.> 1

sumM :: (KnownNat m, KnownNat n) => L m n -> RealNum
sumM m = (m #> 1) <.> 1

squareV :: (KnownNat n) => R n -> R n
squareV v = dvmap (^ (2 :: Int)) v

squareM :: (KnownNat m, KnownNat n) => L m n ->  L m n
squareM m = dmmap (^ (2 :: Int)) m

-- v :: R 10
-- v = vector [1..10]

-- m :: L 3 3
-- m = matrix [-3..5]


{-|
Module      : Julia
Description : Computing Julia sets
Copyright   : (c) Jason Chen, 2021
License     : MIT
Maintainer  : chezbgone (at) gmail dot com
Stability   : experimental
-}
{-# LANGUAGE NamedFieldPuns #-}
module Julia where

import Data.Complex
import Data.List (iterate')
import Codec.Picture

import Interpolation

data Resolution = Resolution { width :: Int, height :: Int }

data Bounds = Bounds { top    :: Double
                     , bottom :: Double
                     , left   :: Double
                     , right  :: Double
                     }

data ComputationProps = ComputationProps
    { maxIterations :: Int
    , escapeRadius :: Double
    }

data RenderProps = RenderProps
    { resolution :: Resolution
    , bounds     :: Bounds
    }

data JuliaProps = JuliaProps
    { computationProps :: ComputationProps
    , renderProps      :: RenderProps
    }

escapeTime :: (Complex Double -> Complex Double) -- f
           -> ComputationProps
           -> Complex Double -- init
           -> Int
escapeTime f ComputationProps{ maxIterations, escapeRadius } init =
    length $ takeWhile (\z -> magnitude z < escapeRadius)
           $ take maxIterations
           $ iterate' f init

escapePixel :: Int -> PixelRGB8
escapePixel = undefined

gridToComplex :: RenderProps -> Int -> Int -> Complex Double
gridToComplex RenderProps{ resolution, bounds } x y
  = (left + xStep * fromIntegral x) :+ (top + yStep * fromIntegral y)
      where Resolution {width, height} = resolution
            Bounds {top, bottom, left, right} = bounds
            xStep = (right - left) / fromIntegral width
            yStep = (top - bottom) / fromIntegral height

generateJulia :: JuliaProps
              -> (Complex Double -> Complex Double) -- f
              -> FilePath
              -> IO ()
generateJulia JuliaProps{ computationProps, renderProps }
              f filepath = writePng filepath image
    where image = generateImage compute width height
          Resolution{ width, height } = resolution renderProps
          compute :: Int -> Int -> PixelRGB8
          compute x y = escapePixel $ escapeTime f computationProps
                                    $ gridToComplex renderProps x y


{-|
Module: MachineLearning.NeuralNetwork.WeightInitialization
Description: Weight Initialization
Copyright: (c) Alexander Ignatyev, 2017
License: BSD-3
Stability: experimental
Portability: POSIX

Various Weight Initialization algorithms.
-}

module MachineLearning.NeuralNetwork.WeightInitialization
(
  nguyen
  , he
)

where

import qualified Numeric.LinearAlgebra as LA
import qualified Control.Monad.Random as RndM
import MachineLearning.Types (Matrix)
import MachineLearning.Random (getRandomRMatrixM)

-- | Weight Initialization Algorithm discussed in Nguyen at al.: https://web.stanford.edu/class/ee373b/nninitialization.pdf
-- Nguyen, Derrick, Widrow, B. Improving the learning speed of 2-layer neural networks by choosing initial values of adaptive weights.
-- In Proc. IJCNN, 1990; 3: 21-26.
nguyen :: RndM.RandomGen g => (Int, Int) -> RndM.Rand g (Matrix, Matrix)
nguyen (r, c) = do
  let b = LA.konst 0 (1, r)
      eps = (sqrt 6) / (sqrt . fromIntegral $ r + c)
  w <- getRandomRMatrixM r c (-eps, eps)
  return (b, w)

-- | Weight Initialization Algorithm discussed in He at al.: https://arxiv.org/abs/1502.01852
-- Kaiming He, Xiangyu Zhang, Shaoqing Ren, Jian Sun.
-- Delving Deep into Rectifiers: Surpassing Human-Level Performance on ImageNet Classification.
he :: RndM.RandomGen g => (Int, Int) -> RndM.Rand g (Matrix, Matrix)
he (r, c) = do
  let b = LA.konst 0 (1, r)
      eps = sqrt (2/(fromIntegral $ r + c))
  w <- getRandomRMatrixM r c (-eps, eps)
  return (b, w)


-- | The method of moments can be used to estimate a number of commonly used distributions.  This module is still under construction as I work out the best way to handle morphisms from the Moments3 type to types of other distributions.  For more information, see the wikipedia entry: <https://en.wikipedia.org/wiki/Method_of_moments_(statistics)>

module HLearn.Models.Distributions.Univariate.Geometric
    ( Geometric
    )
    where

import Control.DeepSeq
import GHC.TypeLits
import qualified Data.Vector.Unboxed as U
import Data.Vector.Unboxed.Deriving

import qualified Statistics.Distribution as S
import Statistics.Distribution.Geometric

import HLearn.Algebra
import HLearn.Models.Distributions.Common
import HLearn.Models.Distributions.Univariate.Internal.Moments
import HLearn.Models.Distributions.Visualization.Gnuplot

-------------------------------------------------------------------------------
-- Geometric

newtype Geometric prob dp = Geometric {  moments :: (Moments3 dp) }
    deriving (Read,Show,Eq,Ord,Monoid,Group)

instance (Num dp) => HomTrainer (Geometric prob dp) where
    type Datapoint (Geometric prob dp) = dp
    train1dp dp = Geometric $ train1dp dp

instance (Num dp) => Probabilistic (Geometric prob dp) where
    type Probability (Geometric prob dp) = prob

instance (Integral dp, Floating prob) => PDF (Geometric prob dp) where
    pdf dist dp = p*(1-p)^^dp
        where
            p = geo_p dist

instance
    ( PDF (Geometric prob dp)
    , Show prob
    , Show dp
    , Ord dp
    , Ord prob
    , Fractional prob
    , RealFrac prob
    , Integral dp
    ) => PlottableDistribution (Geometric prob dp)
        where

    plotType _ = Points

    samplePoints dist = [min..max]
        where
            min = 0
            max = maximum [20,round $ 3*(fromIntegral $ mean dist)]

geo_p :: (Fractional prob, Integral dp) => Geometric prob dp -> prob
geo_p (Geometric dist) = 1/((fromIntegral $ m1 dist)/(fromIntegral $ m0 dist) +1)

instance (Integral dp, RealFrac prob) => Mean (Geometric prob dp) where
    mean dist = round $ 1/(geo_p dist)

instance (Integral dp, Fractional prob) => Variance (Geometric prob dp) where
    variance dist = (1-p)/(p*p)
        where
            p = geo_p dist


{-# LANGUAGE FlexibleContexts #-}
{- |
Module      : Language.Scheme.Numerical
Copyright   : Justin Ethier
Licence     : MIT (see LICENSE in the distribution)

Maintainer  : github.com/justinethier
Stability   : experimental
Portability : portable

This module implements the numerical tower.
-}

module Language.Scheme.Numerical (
 -- * Generic functions
   numSub
 , numMul
 , numDiv
 , numAdd
 , numMod
 , numRationalize
 , numBoolBinopEq
 , numBoolBinopGt
 , numBoolBinopGte
 , numBoolBinopLt
 , numBoolBinopLte
 , numCast
 , numDenominator
 , numNumerator
 , numInexact2Exact
 , numExact2Inexact
 , num2String
 , unpackNum
 , numericBinop
 -- * Floating point functions
 , numFloor
 , numCeiling
 , numTruncate
 , numRound
 , numExpt
 , numSqrt
 , numExp
 , numLog
 -- * Trigonometric functions
 , numSin
 , numCos
 , numTan
 , numAsin
 , numAcos
 , numAtan
 -- * Complex functions
 , buildComplex
 , numMakePolar
 , numRealPart
 , numImagPart
 , numMagnitude
 , numAngle
 , numMakeRectangular
 -- * Predicates
 , isComplex
 , isReal
 , isRational
 , isInteger
 , isNumber
 , isFloatAnInteger
 , isNumNaN
 , isNumInfinite
 , isNumFinite
 , isNumExact
 , isNumInexact
) where
import Language.Scheme.Types

import Control.Monad.Error
import Data.Char hiding (isNumber)
import Data.Complex
import Data.Fixed
import Data.Ratio
import Numeric
import Text.Printf

-- |A helper function to perform a numeric operation on two values
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop _ singleVal@[_] = throwError $ NumArgs (Just 2) singleVal
numericBinop op aparams = mapM unpackNum aparams >>= return . Number . foldl1 op

-- - Begin GenUtil - http://repetae.net/computer/haskell/GenUtil.hs
foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
foldlM f v (x : xs) = (f v x) >>= \ a -> foldlM f a xs
foldlM _ v [] = return v

foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a
foldl1M f (x : xs) = foldlM f x xs
foldl1M _ _ = error "Unexpected error in foldl1M"
-- end GenUtil

{- FUTURE: as a general comment here, operations need to be more permissive of the
numerical types they accept. Within reason, a user should not have to know
what numerical type they are passing when using these functions -}

-- |Add the given numbers
numAdd :: [LispVal] -> ThrowsError LispVal
numAdd [] = return $ Number 0
numAdd aparams = do
  foldl1M (\ a b -> doAdd =<< (numCast [a, b])) aparams
  where doAdd (List [(Number a), (Number b)]) = return $ Number $ a + b
        doAdd (List [(Float a), (Float b)]) = return $ Float $ a + b
        doAdd (List [(Rational a), (Rational b)]) = return $ Rational $ a + b
        doAdd (List [(Complex a), (Complex b)]) = return $ Complex $ a + b
        doAdd _ = throwError $ Default "Unexpected error in +"

-- |Subtract the given numbers
numSub :: [LispVal] -> ThrowsError LispVal
numSub [] = throwError $ NumArgs (Just 1) []
numSub [Number n] = return $ Number $ -1 * n
numSub [Float n] = return $ Float $ -1 * n
numSub [Rational n] = return $ Rational $ -1 * n
numSub [Complex n] = return $ Complex $ -1 * n
numSub aparams = do
  foldl1M (\ a b -> doSub =<< (numCast [a, b])) aparams
  where doSub (List [(Number a), (Number b)]) = return $ Number $ a - b
        doSub (List [(Float a), (Float b)]) = return $ Float $ a - b
        doSub (List [(Rational a), (Rational b)]) = return $ Rational $ a - b
        doSub (List [(Complex a), (Complex b)]) = return $ Complex $ a - b
        doSub _ = throwError $ Default "Unexpected error in -"

-- |Multiply the given numbers
numMul :: [LispVal] -> ThrowsError LispVal
numMul [] = return $ Number 1
numMul aparams = do
  foldl1M (\ a b -> doMul =<< (numCast [a, b])) aparams
  where doMul (List [(Number a), (Number b)]) = return $ Number $ a * b
        doMul (List [(Float a), (Float b)]) = return $ Float $ a * b
        doMul (List [(Rational a), (Rational b)]) = return $ Rational $ a * b
        doMul (List [(Complex a), (Complex b)]) = return $ Complex $ a * b
        doMul _ = throwError $ Default "Unexpected error in *"

-- |Divide the given numbers
numDiv :: [LispVal] -> ThrowsError LispVal
numDiv [] = throwError $ NumArgs (Just 1) []
numDiv [Number 0] = throwError $ DivideByZero
numDiv [Rational 0] = throwError $ DivideByZero
numDiv [Number n] = return $ Rational $ 1 / (fromInteger n)
numDiv [Float n] = return $ Float $ 1.0 / n
numDiv [Rational n] = return $ Rational $ 1 / n
numDiv [Complex n] = return $ Complex $ 1 / n
numDiv aparams = do
  foldl1M (\ a b -> doDiv =<< (numCast [a, b])) aparams
  where doDiv (List [(Number a), (Number b)])
            | b == 0 = throwError $ DivideByZero
            | (mod a b) == 0 = return $ Number $ div a b
            | otherwise = -- Not an integer
                return $ Rational $ (fromInteger a) / (fromInteger b)
        doDiv (List [(Float a), (Float b)])
            | b == 0.0 = throwError $ DivideByZero
            | otherwise = return $ Float $ a / b
        doDiv (List [(Rational a), (Rational b)])
            | b == 0 = throwError $ DivideByZero
            | otherwise = return $ Rational $ a / b
        doDiv (List [(Complex a), (Complex b)])
            | b == 0 = throwError $ DivideByZero
            | otherwise = return $ Complex $ a / b
        doDiv _ = throwError $ Default "Unexpected error in /"

-- |Take the modulus of the given numbers
numMod :: [LispVal] -> ThrowsError LispVal
numMod [] = return $ Number 1
numMod aparams = do
  foldl1M (\ a b -> doMod =<< (numCast [a, b])) aparams
  where doMod (List [(Number a), (Number b)]) = return $ Number $ mod' a b
        doMod (List [(Float a), (Float b)]) = return $ Float $ mod' a b
        doMod (List [(Rational a), (Rational b)]) = return $ Rational $ mod' a b
        doMod (List [(Complex _), (Complex _)]) = throwError $ Default "modulo not implemented for complex numbers"
        doMod _ = throwError $ Default "Unexpected error in modulo"

-- |Compare a series of numbers using a given numeric comparison
--  function and an array of lisp values
numBoolBinopCompare :: (LispVal
                    -> LispVal -> Either LispError LispVal)
                    -> LispVal -> [LispVal] -> Either LispError LispVal
numBoolBinopCompare cmp n1 (n2 : ns) = do
  (n1', n2') <- numCast' (n1, n2)
  result <- cmp n1' n2'
  case result of
    Bool True -> numBoolBinopCompare cmp n2' ns
    _ -> return $ Bool False
numBoolBinopCompare _ _ _ = return $ Bool True

-- |Numeric equals
numBoolBinopEq :: [LispVal] -> ThrowsError LispVal
numBoolBinopEq [] = throwError $ NumArgs (Just 0) []
numBoolBinopEq (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a == b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Rational a) (Rational b) = return $ Bool $ f a b
    cmp (Complex a) (Complex b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in ="

-- |Numeric greater than
numBoolBinopGt :: [LispVal] -> ThrowsError LispVal
numBoolBinopGt [] = throwError $ NumArgs (Just 0) []
numBoolBinopGt (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a > b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Rational a) (Rational b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in >"

-- |Numeric greater than equal
numBoolBinopGte :: [LispVal] -> ThrowsError LispVal
numBoolBinopGte [] = throwError $ NumArgs (Just 0) []
numBoolBinopGte (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a >= b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Rational a) (Rational b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in >="

-- |Numeric less than
numBoolBinopLt :: [LispVal] -> ThrowsError LispVal
numBoolBinopLt [] = throwError $ NumArgs (Just 0) []
numBoolBinopLt (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a < b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Rational a) (Rational b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in <"

-- |Numeric less than equal
numBoolBinopLte :: [LispVal] -> ThrowsError LispVal
numBoolBinopLte [] = throwError $ NumArgs (Just 0) []
numBoolBinopLte (n : ns) = numBoolBinopCompare cmp n ns
  where
    f a b = a <= b
    cmp (Number a) (Number b) = return $ Bool $ f a b
    cmp (Float a) (Float b) = return $ Bool $ f a b
    cmp (Rational a) (Rational b) = return $ Bool $ f a b
    cmp _ _ = throwError $ Default "Unexpected error in <="

-- |Accept two numbers and cast one of them to the appropriate type, if necessary
numCast' :: (LispVal, LispVal) -> ThrowsError (LispVal, LispVal)
numCast' (a@(Number _), b@(Number _)) = return $ (a, b)
numCast' (a@(Float _), b@(Float _)) = return $ (a, b)
numCast' (a@(Rational _), b@(Rational _)) = return $ (a, b)
numCast' (a@(Complex _), b@(Complex _)) = return $ (a, b)
numCast' ((Number a), b@(Float _)) = return $ (Float $ fromInteger a, b)
numCast' ((Number a), b@(Rational _)) = return $ (Rational $ fromInteger a, b)
numCast' ((Number a), b@(Complex _)) = return $ (Complex $ fromInteger a, b)
numCast' (a@(Float _), (Number b)) = return $ (a, Float $ fromInteger b)
numCast' (a@(Float _), (Rational b)) = return $ (a, Float $ fromRational b)
numCast' ((Float a), b@(Complex _)) = return $ (Complex $ a :+ 0, b)
numCast' (a@(Rational _), (Number b)) = return $ (a, Rational $ fromInteger b)
numCast' ((Rational a), b@(Float _)) = return $ (Float $ fromRational a, b)
numCast' ((Rational a), b@(Complex _)) = return $ (Complex $ (fromInteger $ numerator a) / (fromInteger $ denominator a), b)
numCast' (a@(Complex _), (Number b)) = return $ (a, Complex $ fromInteger b)
numCast' (a@(Complex _), (Float b)) = return $ (a, Complex $ b :+ 0)
numCast' (a@(Complex _), (Rational b)) = return $ (a, Complex $ (fromInteger $ numerator b) / (fromInteger $ denominator b))
numCast' (a, b) = case a of
               Number _ -> doThrowError b
               Float _ -> doThrowError b
               Rational _ -> doThrowError b
               Complex _ -> doThrowError b
               _ -> doThrowError a
  where doThrowError num = throwError $ TypeMismatch "number" num

-- |Accept two numbers and cast one of them to the appropriate type, if necessary
numCast :: [LispVal] -> ThrowsError LispVal
numCast [a, b] = do
  (a', b') <- numCast' (a, b)
  pure $ List [a', b']
numCast _ = throwError $ Default "Unexpected error in numCast"

-- |Convert the given number to a rational
numRationalize :: [LispVal] -> ThrowsError LispVal
numRationalize [(Number n)] = return $ Rational $ toRational n
numRationalize [(Float n)] = return $ Rational $ toRational n
numRationalize [n@(Rational _)] = return n
numRationalize [x] = throwError $ TypeMismatch "number" x
numRationalize badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Round the given number
numRound :: [LispVal] -> ThrowsError LispVal
numRound [n@(Number _)] = return n
numRound [(Rational n)] = return $ Number $ round n
numRound [(Float n)] = return $ Float $ fromInteger $ round n
numRound [(Complex n)] = do
  return $ Complex $ (fromInteger $ round $ realPart n) :+ (fromInteger $ round $ imagPart n)
numRound [x] = throwError $ TypeMismatch "number" x
numRound badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Floor the given number
numFloor :: [LispVal] -> ThrowsError LispVal
numFloor [n@(Number _)] = return n
numFloor [(Rational n)] = return $ Number $ floor n
numFloor [(Float n)] = return $ Float $ fromInteger $ floor n
numFloor [(Complex n)] = do
  return $ Complex $ (fromInteger $ floor $ realPart n) :+ (fromInteger $ floor $ imagPart n)
numFloor [x] = throwError $ TypeMismatch "number" x
numFloor badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Take the ceiling of the given number
numCeiling :: [LispVal] -> ThrowsError LispVal
numCeiling [n@(Number _)] = return n
numCeiling [(Rational n)] = return $ Number $ ceiling n
numCeiling [(Float n)] = return $ Float $ fromInteger $ ceiling n
numCeiling [(Complex n)] = do
  return $ Complex $ (fromInteger $ ceiling $ realPart n) :+ (fromInteger $ ceiling $ imagPart n)
numCeiling [x] = throwError $ TypeMismatch "number" x
numCeiling badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Truncate the given number
numTruncate :: [LispVal] -> ThrowsError LispVal
numTruncate [n@(Number _)] = return n
numTruncate [(Rational n)] = return $ Number $ truncate n
numTruncate [(Float n)] = return $ Float $ fromInteger $ truncate n
numTruncate [(Complex n)] = do
  return $ Complex $ (fromInteger $ truncate $ realPart n) :+ (fromInteger $ truncate $ imagPart n)
numTruncate [x] = throwError $ TypeMismatch "number" x
numTruncate badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Sine
numSin :: [LispVal] -> ThrowsError LispVal
numSin [(Number n)] = return $ Float $ sin $ fromInteger n
numSin [(Float n)] = return $ Float $ sin n
numSin [(Rational n)] = return $ Float $ sin $ fromRational n
numSin [(Complex n)] = return $ Complex $ sin n
numSin [x] = throwError $ TypeMismatch "number" x
numSin badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Cosine
numCos :: [LispVal] -> ThrowsError LispVal
numCos [(Number n)] = return $ Float $ cos $ fromInteger n
numCos [(Float n)] = return $ Float $ cos n
numCos [(Rational n)] = return $ Float $ cos $ fromRational n
numCos [(Complex n)] = return $ Complex $ cos n
numCos [x] = throwError $ TypeMismatch "number" x
numCos badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Tangent
numTan :: [LispVal] -> ThrowsError LispVal
numTan [(Number n)] = return $ Float $ tan $ fromInteger n
numTan [(Float n)] = return $ Float $ tan n
numTan [(Rational n)] = return $ Float $ tan $ fromRational n
numTan [(Complex n)] = return $ Complex $ tan n
numTan [x] = throwError $ TypeMismatch "number" x
numTan badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Arcsine
numAsin :: [LispVal] -> ThrowsError LispVal
numAsin [(Number n)] = return $ Float $ asin $ fromInteger n
numAsin [(Float n)] = return $ Float $ asin n
numAsin [(Rational n)] = return $ Float $ asin $ fromRational n
numAsin [(Complex n)] = return $ Complex $ asin n
numAsin [x] = throwError $ TypeMismatch "number" x
numAsin badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Arccosine
numAcos :: [LispVal] -> ThrowsError LispVal
numAcos [(Number n)] = return $ Float $ acos $ fromInteger n
numAcos [(Float n)] = return $ Float $ acos n
numAcos [(Rational n)] = return $ Float $ acos $ fromRational n
numAcos [(Complex n)] = return $ Complex $ acos n
numAcos [x] = throwError $ TypeMismatch "number" x
numAcos badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Arctangent
numAtan :: [LispVal] -> ThrowsError LispVal
numAtan [(Number n)] = return $ Float $ atan $ fromInteger n
numAtan [Number y, Number x] = return $ Float $ phase $ (fromInteger x) :+ (fromInteger y)
numAtan [(Float n)] = return $ Float $ atan n
numAtan [Float y, Float x] = return $ Float $ phase $ x :+ y
numAtan [(Rational n)] = return $ Float $ atan $ fromRational n
numAtan [Rational y, Rational x] = return $ Float $ phase $ (fromRational x) :+ (fromRational y)
numAtan [(Complex n)] = return $ Complex $ atan n
numAtan [x] = throwError $ TypeMismatch "number" x
numAtan badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Take the square root of the given number
numSqrt :: [LispVal] -> ThrowsError LispVal
numSqrt [(Number n)] = if n >= 0 then return $ Float $ sqrt $ fromInteger n
                                 else return $ Complex $ sqrt ((fromInteger n) :+ 0)
numSqrt [(Float n)] = if n >= 0 then return $ Float $ sqrt n
                                else return $ Complex $ sqrt (n :+ 0)
numSqrt [(Rational n)] = numSqrt [Float $ fromRational n]
numSqrt [(Complex n)] = return $ Complex $ sqrt n
numSqrt [x] = throwError $ TypeMismatch "number" x
numSqrt badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Raise the first number to the power of the second
numExpt :: [LispVal] -> ThrowsError LispVal
numExpt [(Number n), (Number p)] = return $ Float $ (fromInteger n) ^ p
numExpt [(Rational n), (Number p)] = return $ Float $ (fromRational n) ^ p
numExpt [(Float n), (Number p)] = return $ Float $ n ^ p
numExpt [(Complex n), (Number p)] = return $ Complex $ n ^ p
numExpt [_, y] = throwError $ TypeMismatch "integer" y
numExpt badArgList = throwError $ NumArgs (Just 2) badArgList

{- numExpt params = do
  foldl1M (\a b -> doExpt =<< (numCast [a, b])) params
  where doExpt (List [(Number a), (Number b)]) = return $ Float $ (fromInteger a) ^ (fromInteger b)
--        doExpt (List [(Rational a), (Rational b)]) = return $ Float $ fromRational $ a ^ b
        doExpt (List [(Float a), (Float b)]) = return $ Float $ a ^ b
--        doExpt (List [(Complex a), (Complex b)]) = return $ Complex $ a ^ b -}

-- |Take the exponent of the given number
numExp :: [LispVal] -> ThrowsError LispVal
numExp [(Number n)] = return $ Float $ exp $ fromInteger n
numExp [(Float n)] = return $ Float $ exp n
numExp [(Rational n)] = return $ Float $ exp $ fromRational n
numExp [(Complex n)] = return $ Complex $ exp n
numExp [x] = throwError $ TypeMismatch "number" x
numExp badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Compute the log of a given number
numLog :: [LispVal] -> ThrowsError LispVal
numLog [(Number n)] = return $ Float $ log $ fromInteger n
numLog [Number n, Number base] = return $ Float $ logBase (fromInteger base) (fromInteger n)
numLog [(Float n)] = return $ Float $ log n
numLog [Float n, Number base] = return $ Float $ logBase (fromInteger base) n
numLog [(Rational n)] = return $ Float $ log $ fromRational n
numLog [Rational n, Number base] = return $ Float $ logBase (fromInteger base) (fromRational n)
numLog [(Complex n)] = return $ Complex $ log n
numLog [Complex n, Number base] = return $ Complex $ logBase (fromInteger base) n
numLog [x] = throwError $ TypeMismatch "number" x
numLog badArgList = throwError $ NumArgs (Just 1) badArgList

-- Complex number functions

-- |Create a complex number
buildComplex :: LispVal
             -- ^ Real part
             -> LispVal
             -- ^ Imaginary part
             -> ThrowsError LispVal
             -- ^ Complex number
buildComplex (Number x) (Number y) = return $ Complex $ (fromInteger x) :+ (fromInteger y)
buildComplex (Number x) (Rational y) = return $ Complex $ (fromInteger x) :+ (fromRational y)
buildComplex (Number x) (Float y) = return $ Complex $ (fromInteger x) :+ y
buildComplex (Rational x) (Number y) = return $ Complex $ (fromRational x) :+ (fromInteger y)
buildComplex (Rational x) (Rational y) = return $ Complex $ (fromRational x) :+ (fromRational y)
buildComplex (Rational x) (Float y) = return $ Complex $ (fromRational x) :+ y
buildComplex (Float x) (Number y) = return $ Complex $ x :+ (fromInteger y)
buildComplex (Float x) (Rational y) = return $ Complex $ x :+ (fromRational y)
buildComplex (Float x) (Float y) = return $ Complex $ x :+ y
buildComplex x y = throwError $ TypeMismatch "number" $ List [x, y]

-- |Create a complex number given its real and imaginary parts
numMakeRectangular :: [LispVal] -> ThrowsError LispVal
numMakeRectangular [x, y] = buildComplex x y
numMakeRectangular badArgList = throwError $ NumArgs (Just 2) badArgList

-- |Create a complex number from its magnitude and phase (angle)
numMakePolar :: [LispVal] -> ThrowsError LispVal
numMakePolar [(Float x), (Float y)] = return $ Complex $ mkPolar x y
numMakePolar [(Float _), y] = throwError $ TypeMismatch "real" y
numMakePolar [x, (Float _)] = throwError $ TypeMismatch "real real" $ x
numMakePolar badArgList = throwError $ NumArgs (Just 2) badArgList

-- |The phase of a complex number
numAngle :: [LispVal] -> ThrowsError LispVal
numAngle [(Complex c)] = return $ Float $ phase c
numAngle [x] = throwError $ TypeMismatch "complex number" x
numAngle badArgList = throwError $ NumArgs (Just 1) badArgList

-- |The nonnegative magnitude of a complex number
numMagnitude :: [LispVal] -> ThrowsError LispVal
numMagnitude [(Complex c)] = return $ Float $ magnitude c
numMagnitude [x] = throwError $ TypeMismatch "complex number" x
numMagnitude badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Retrieve real part of a complex number
numRealPart :: [LispVal] -> ThrowsError LispVal
numRealPart [(Complex c)] = return $ Float $ realPart c
numRealPart [n@(Float _)] = return n
numRealPart [n@(Rational _)] = return n
numRealPart [n@(Number _)] = return n
numRealPart [x] = throwError $ TypeMismatch "complex number" x
numRealPart badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Retrieve imaginary part of a complex number
numImagPart :: [LispVal] -> ThrowsError LispVal
numImagPart [(Complex c)] = do
  let n = imagPart c
      f = Float n
  if isFloatAnInteger f
     then return $ Number $ floor n
     else return f
numImagPart [(Float _)] = return $ Number 0
numImagPart [(Rational _)] = return $ Number 0
numImagPart [(Number _)] = return $ Number 0
numImagPart [x] = throwError $ TypeMismatch "complex number" x
numImagPart badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Take the numerator of the given number
numNumerator :: [LispVal] -> ThrowsError LispVal
numNumerator [n@(Number _)] = return n
numNumerator [(Rational r)] = return $ Number $ numerator r
numNumerator [(Float f)] = return $ Float $ fromInteger . numerator . toRational $ f
numNumerator [x] = throwError $ TypeMismatch "rational number" x
numNumerator badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Take the denominator of the given number
numDenominator :: [LispVal] -> ThrowsError LispVal
numDenominator [Number _] = return $ Number 1
numDenominator [(Rational r)] = return $ Number $ denominator r
numDenominator [(Float f)] = return $ Float $ fromInteger $ denominator $ toRational f
numDenominator [x] = throwError $ TypeMismatch "rational number" x
numDenominator badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Convert an exact number to inexact
numExact2Inexact :: [LispVal] -> ThrowsError LispVal
numExact2Inexact [(Number n)] = return $ Float $ fromInteger n
numExact2Inexact [(Rational n)] = return $ Float $ fromRational n
numExact2Inexact [n@(Float _)] = return n
numExact2Inexact [n@(Complex _)] = return n
numExact2Inexact [badType] = throwError $ TypeMismatch "number" badType
numExact2Inexact badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Convert an inexact number to exact
numInexact2Exact :: [LispVal] -> ThrowsError LispVal
numInexact2Exact [n@(Number _)] = return n
numInexact2Exact [n@(Rational _)] = return n
numInexact2Exact [(Float n)] = return $ Number $ round n
numInexact2Exact [c@(Complex _)] = numRound [c]
numInexact2Exact [badType] = throwError $ TypeMismatch "number" badType
numInexact2Exact badArgList = throwError $ NumArgs (Just 1) badArgList

-- |Convert a number to a string; radix is optional, defaults to base 10
num2String :: [LispVal] -> ThrowsError LispVal
num2String [(Number n)] = return $ String $ show n
num2String [(Number n), (Number radix)] = do
  case radix of
    2 -> do -- Nice tip from StackOverflow question #1959715
             return $ String $ showIntAtBase 2 intToDigit n ""
    8 -> return $ String $ printf "%o" n
    10 -> return $ String $ printf "%d" n
    16 -> return $ String $ printf "%x" n
    _ -> throwError $ BadSpecialForm "Invalid radix value" $ Number radix
num2String [n@(Rational _)] = return $ String $ show n
num2String [(Float n)] = return $ String $ show n
num2String [n@(Complex _)] = return $ String $ show n
num2String [x] = throwError $ TypeMismatch "number" x
num2String badArgList = throwError $ NumArgs (Just 1) badArgList

-- | Determine if the given value is not a number
isNumNaN :: [LispVal] -> ThrowsError LispVal
isNumNaN ([Float n]) = return $ Bool $ isNaN n
isNumNaN _ = return $ Bool False

-- | Determine if number is infinite
isNumInfinite :: [LispVal] -> ThrowsError LispVal
isNumInfinite ([Float n]) = return $ Bool $ isInfinite n
isNumInfinite _ = return $ Bool False

-- | Determine if number is not infinite
isNumFinite :: [LispVal] -> ThrowsError LispVal
isNumFinite ([Number _]) = return $ Bool True
isNumFinite ([Float n]) = return $ Bool $ not $ isInfinite n
isNumFinite ([Complex _]) = return $ Bool True
isNumFinite ([Rational _]) = return $ Bool True
isNumFinite _ = return $ Bool False

-- | Determine if number is exact
isNumExact :: [LispVal] -> ThrowsError LispVal
isNumExact ([Number _]) = return $ Bool True
isNumExact ([Float _]) = return $ Bool False
isNumExact ([Complex _]) = return $ Bool False -- TODO: could be either
isNumExact ([Rational _]) = return $ Bool True
isNumExact _ = return $ Bool False

-- | Determine if number is inexact
isNumInexact :: [LispVal] -> ThrowsError LispVal
isNumInexact ([Number _])   = return $ Bool False
isNumInexact ([Float _])    = return $ Bool True
isNumInexact ([Complex _])  = return $ Bool True
isNumInexact ([Rational _]) = return $ Bool False
isNumInexact _ = return $ Bool False

-- |Predicate to determine if given value is a number
isNumber :: [LispVal] -> ThrowsError LispVal
isNumber ([Number _]) = return $ Bool True
isNumber ([Float _]) = return $ Bool True
isNumber ([Complex _]) = return $ Bool True
isNumber ([Rational _]) = return $ Bool True
isNumber _ = return $ Bool False

-- |Predicate to determine if given number is complex.
--  Keep in mind this does not just look at the types
isComplex :: [LispVal] -> ThrowsError LispVal
isComplex ([Complex _]) = return $ Bool True
isComplex ([Number _]) = return $ Bool True
isComplex ([Rational _]) = return $ Bool True
isComplex ([Float _]) = return $ Bool True
isComplex _ = return $ Bool False

-- |Predicate to determine if given number is a real.
--  Keep in mind this does not just look at the types
isReal :: [LispVal] -> ThrowsError LispVal
isReal ([Number _]) = return $ Bool True
isReal ([Rational _]) = return $ Bool True
isReal ([Float _]) = return $ Bool True
isReal ([Complex c]) = do
  imagPt <- numImagPart [(Complex c)]
  isExact <- isNumExact [imagPt]
  isZero <- numBoolBinopEq [imagPt, (Number 0)]
  case (isExact, isZero) of
    (Bool True, Bool True) -> return $ Bool True
    _ -> return $ Bool False
isReal _ = return $ Bool False

-- |Predicate to determine if given number is a rational.
--  Keep in mind this does not just look at the types
isRational :: [LispVal] -> ThrowsError LispVal
isRational ([Number _]) = return $ Bool True
isRational ([Rational _]) = return $ Bool True
isRational ([Float n]) = return $ Bool $ not $ isInfinite n
isRational _ = return $ Bool False

-- |Predicate to determine if given number is an integer.
--  Keep in mind this does not just look at the types;
--  a floating point input value can return true, for example.
isInteger :: [LispVal] -> ThrowsError LispVal
isInteger ([Number _]) = return $ Bool True
isInteger ([Complex n]) = do
  return $ Bool $ (isFloatAnInteger $ Float $ realPart n) && (isFloatAnInteger $ Float $ imagPart n)
isInteger ([Rational n]) = do
    let numer = abs $ numerator n
    let denom = abs $ denominator n
    return $ Bool $ (numer >= denom) && ((mod numer denom) == 0)
isInteger ([n@(Float _)]) = return $ Bool $ isFloatAnInteger n
isInteger _ = return $ Bool False

-- |A utility function to determine if given value is a floating point
--  number representing an whole number (integer).
isFloatAnInteger :: LispVal -> Bool
isFloatAnInteger (Float n) =
    ((floor n) :: Integer) == ((ceiling n) :: Integer)
isFloatAnInteger _ = False

-- - end Numeric operations section ---

-- |Extract an integer from the given value, throwing a type error if
--  the wrong type is passed.
unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum notNum = throwError $ TypeMismatch "number" notNum