{- | Test of learning

In this example, two networks are used : 'simple' which is the reference and 'wrong' which is a wrong start.
The goal is to use test patterns to learn the right 'simple' network from 'wrong'. Only the values are learnt.
The topology of both networks is the same.

@
simple :: (['TDV' Bool],'SBN' 'CPT')
simple = 'runBN' $ do
    a <- 'variable' \"a\" ('t' :: Bool)
    b <- 'variable' \"b\" ('t' :: Bool)
--
    'proba' a '~~' [0.4,0.6]
    'cpt' b [a] '~~' [0.8,0.2,0.2,0.8]
--
    return [a,b]
@

and 'wrong' where the probability for a is wrong.

@
wrong :: (['TDV' Bool],'SBN' 'CPT')
wrong = 'runBN' $ do
    a <- 'variable' \"a\" ('t' :: Bool)
    b <- 'variable' \"b\" ('t' :: Bool)
--
    'proba' a '~~' [0.2,0.8]
    'cpt' b [a] '~~' [0.8,0.2,0.2,0.8]
--
    return [a,b]
@

So, the first thing to do is generate test patterns. We are using the 'discreteAncestralSampler' for this. This function is
generating a sequence of graphs. We are just interested in the values. So, we get the values with 'allVertexValues'.

@
generatePatterns :: IO [[DVI]]
generatePatterns = do
    let (vars\@[a,b],exampleG) = simple
    r <- 'runSampling' 5000 0 ('discreteAncestralSampler' exampleG)
    return (map 'allVertexValues' r)
@

Once we have the data, we can try to learn the network:

@
emTest = do
  samples <- generatePatterns
  let (_,simpleG) = simple
      (_,wrongG) = wrong
  print simpleG
  'printGraphValues' simpleG
  'printGraphValues' wrongG
--
  'printGraphValues' ('learnEM' samples wrongG)
@

First, we display the topology of the graph and the values for the reference graph and the wrong one.
Then, we use the 'learnEM' function to learn a new network from the samples. And, we print the new values to check.

-}
module Bayes.Examples.EMTest(
    -- * Test function
    emTest
  ) where

import Bayes.Sampling
import System.Random.MWC.CondensedTable
import qualified Data.Vector as V
import Bayes.Factor
import Bayes
import Bayes.FactorElimination
import Data.Maybe(fromJust)
import Bayes.BayesianNetwork
import Bayes.Factor.CPT
import Statistics.Sample.Histogram
import Bayes.EM

simple :: ([TDV Bool],SBN CPT)
simple = runBN $ do
    a <- variable "a" (t :: Bool)
    b <- variable "b" (t :: Bool)

    proba a ~~ [0.4,0.6]
    cpt b [a] ~~ [0.8,0.2,0.2,0.8]

    return [a,b]

wrong :: ([TDV Bool],SBN CPT)
wrong = runBN $ do
    a <- variable "a" (t :: Bool)
    b <- variable "b" (t :: Bool)

    proba a ~~ [0.2,0.8]
    cpt b [a] ~~ [0.8,0.2,0.2,0.8]

    return [a,b]

setJust vertex v = Just v

generatePatterns :: IO [[DVI]]
generatePatterns = do
    let (vars@[a,b],exampleG) = simple
    r <- runSampling 5000 0 (discreteAncestralSampler exampleG)
    return (map allVertexValues r)

emTest = do
  samples <- generatePatterns
  let (_,simpleG) = simple
      (_,wrongG) = wrong
  print simpleG
  printGraphValues simpleG
  printGraphValues wrongG

  printGraphValues (learnEM samples wrongG)


module Raytracer.Geometry where

import Numeric.LinearAlgebra.Data (Vector, (|>), toList, (!), fromList, toList)
import Numeric.LinearAlgebra.Data (fromColumns, asColumn, toColumns)
import Data.Maybe.HT (toMaybe)
import Data.Monoid (First(First), Monoid, getFirst, mempty, mappend, mconcat)
import Numeric.LinearAlgebra (luSolve, luPacked, pinv, (<>))
import Control.Applicative ((<*>), pure)
import Control.Monad (join)
import Data.Foldable (find)
import Data.List (sort)
import Data.Function (on)
import Data.Maybe (isJust)
import Data.Bool.HT (if')

(|*) = (*).(3|>).repeat

all_of :: [(a -> Bool)] -> a -> Bool
all_of conditions value = and $ conditions <*> (pure value)

type Pos = Vector Double
type Dir = Vector Double

-- This represents a ray of the form r = ax + b
data Ray = Ray Dir Pos deriving (Show)
calc_ray (Ray a b) n1 = round_to $ (n1 |* a) + b
  where
  round_to = fromList . map (epsilon_round 6) . toList
  epsilon_round n f = (fromInteger $ round $ f * (10^n)) / (10.0^^n)

-- This computes the ray that goes from the first point to the second
rayTo :: Pos -> Pos -> Ray
p1 `rayTo` p2 = Ray (p2 - p1) p1

-- This wraps a collision with a ray and an object
-- The `a` is what the object was holding, and the double is how far down the
-- ray the collision occured (used to find the "first" collision)
data Collision a = Collision Double a deriving (Show)

dist (Collision d _) = d

instance Eq (Collision a) where
  (==) = (==) `on` dist

instance Ord (Collision a) where
  compare = compare `on` dist

class Intersectable a where
	intersection :: Ray -> a b -> Maybe (Collision b)

ray_plane_intersect :: Ray -> Plane a -> (Vector Double)
ray_plane_intersect (Ray r1 r2) (Plane a p1 p2 p3) = head.toColumns.(\m -> (luSolve.luPacked) m (asColumn (r2 - p3))) $ fromColumns [p1, p2, -1 |* r1]

-- This represents a plane of the form p = ax + by + c
data Plane a = Plane a Dir Dir Pos deriving (Show)
calc_plane (Plane _ a b c) n1 n2 = (n1 |* a) + (n2 |* b) + c

instance Intersectable Plane where
	intersection ray plane@(Plane a _ _ _) = find (all_of [not.isInfinite, (>0)] . dist) $ Just $ Collision n a
		where
		n = (ray_plane_intersect ray plane) ! 2

-- Each of these Vectors represent a point in 3-space
data Triangle a = Triangle a Pos Pos Pos deriving (Show)

instance Intersectable Triangle where
	intersection ray (Triangle a p1 p2 p3) = if' (not $ all_of [all (>0), (1>).sum] [n1,n2]) Nothing $ find (all_of [not.isInfinite, (>0)] . dist) $ Just $ Collision n a
		where
		plane = Plane a (p2 - p1) (p3 - p1) p1
		(n1:n2:n:_) = toList $ ray_plane_intersect ray plane

-- We'll call a collection of triangles a mesh...
data Mesh a = Mesh [Triangle a] deriving (Show)

-- Most of this is just proxying the list of triangles.
instance Monoid (Mesh a) where
	mempty = Mesh []
	mappend (Mesh l1) (Mesh l2) = Mesh $ mappend l1 l2

instance Intersectable Mesh where
	-- We'll return, for the mesh, the first one we hit
	intersection ray (Mesh triangles) = join $ find isJust $ sort $ fmap (intersection ray) triangles

-- This function takes a point and two vectors and generates a mesh representing that square
square a v1 v2 p1 = Mesh [Triangle a p1 (p1 + v1) (p1 + v1 + v2), Triangle a (p1 + v1 + v2) (p1 + v2) p1]

-- This function takes a point and three vectors and generates a mesh representing that cube
cube a v1 v2 v3 p1 = mconcat $ fmap (uncurry3 $ square a) [(v1, v2, p1), (v2, v3, p1), (v3, v1, p1), (neg v1, neg v2, p2), (neg v2, neg v3, p2), (neg v3, neg v1, p2)]
	where
	p2 = p1 + v1 + v2 + v3
	neg = ((-1) |*)
	uncurry3 func (a, b, c) = func a b c


{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE InstanceSigs              #-}
{-# LANGUAGE LambdaCase                #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE PartialTypeSignatures     #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeApplications          #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeInType                #-}
{-# LANGUAGE UndecidableInstances      #-}

module Learn.Neural.Layer.Recurrent.LSTM (
  LSTM
  ) where

import           Data.Kind
import           Data.Singletons.Prelude
import           GHC.Generics                   (Generic)
import           GHC.Generics.Numeric
import           GHC.TypeLits
import           Learn.Neural.Layer
import           Numeric.BLAS
import           Numeric.Backprop
import           Numeric.Backprop.Iso
import           Statistics.Distribution
import           Statistics.Distribution.Normal
import qualified Generics.SOP                   as SOP

data LSTM :: Type

instance ( BLAS b
         , KnownNat i
         , KnownNat o
         , Floating (b '[o])
         , Floating (b '[o,i])
         , Floating (b '[o,o])
         )
        => Component LSTM b '[i] '[o] where

    data CParam LSTM b '[i] '[o] =
        LP { _lpForgetInp     :: !(b '[o,i])
           , _lpForgetState   :: !(b '[o,o])
           , _lpForgetBias    :: !(b '[o])
           , _lpRememberInp   :: !(b '[o,i])
           , _lpRememberState :: !(b '[o,o])
           , _lpRememberBias  :: !(b '[o])
           , _lpCommitInp     :: !(b '[o,i])
           , _lpCommitState   :: !(b '[o,o])
           , _lpCommitBias    :: !(b '[o])
           , _lpOutInp        :: !(b '[o,i])
           , _lpOutState      :: !(b '[o,o])
           , _lpOutBias       :: !(b '[o])
           }
      deriving (Generic)
    data CState LSTM b '[i] '[o] =
        LS { _lsCellState   :: !(b '[o])
           , _lsHiddenState :: !(b '[o])
           }
      deriving (Generic)
    type CConstr LSTM b '[i] '[o] = (Num (b '[o,i]), Num (b '[o,o]), Num (b '[o]))
    data CConf   LSTM b '[i] '[o] = forall d. ContGen d => LC d

    componentOp :: forall s. (Num (b '[i]), Num (b '[o]), CConstr LSTM b '[i] '[o])
        => OpB s '[b '[i], CParam LSTM b '[i] '[o], CState LSTM b '[i] '[o]] '[b '[o], CState LSTM b '[i] '[o]]
    componentOp = bpOp . withInps $ \(x :< p :< s :< Ø) -> do
        fI :< fS :< fB :< rI :< rS :< rB :< cI :< cS :< cB :< oI :< oS :< oB :< Ø <- gTuple #<~ p
        sC :< sH :< Ø <- gTuple #<~ s
        let forget   = sum [ matVecOp .$ (fI :< x  :< Ø)
                           , matVecOp .$ (fS :< sH :< Ø)
                           , fB
                           ]
            remember = sum [ matVecOp .$ (rI :< x  :< Ø)
                           , matVecOp .$ (rS :< sH :< Ø)
                           , rB
                           ]
            commit   = sum [ matVecOp .$ (cI :< x  :< Ø)
                           , matVecOp .$ (cS :< sH :< Ø)
                           , cB
                           ]
            out      = sum [ matVecOp .$ (oI :< x  :< Ø)
                           , matVecOp .$ (oS :< sH :< Ø)
                           , oB
                           ]
        forget'   <- tmapOp logistic ~$ (forget   :< Ø)
        remember' <- tmapOp logistic ~$ (remember :< Ø)
        commit'   <- tmapOp tanh     ~$ (commit   :< Ø)
        out'      <- tmapOp logistic ~$ (out      :< Ø)
        sC'       <- tmapOp tanh ~$ ((forget' * sC + remember' * commit') :< Ø)
        finalOut  <- bindVar $ out' * sC'
        s' :< Ø   <- isoVar (from (gTuple @(CState LSTM b '[i] '[o])) . tup1)
                            (sC' :< finalOut :< Ø)
        return $ finalOut :< s' :< Ø
      where
        logistic :: Floating a => a -> a
        logistic x = 1 / (1 + exp (-x))

    defConf = LC (normalDistr 0 0.01)
    initParam = \case
      i `SCons` SNil -> \case
        so@(o `SCons` SNil) -> \(LC d) g -> do
          LP <$> genA (o `SCons` (i `SCons` SNil)) (\_ -> realToFrac <$> genContVar d g)
             <*> genA (o `SCons` (o `SCons` SNil)) (\_ -> realToFrac <$> genContVar d g)
             <*> genA so                           (\_ -> realToFrac <$> genContVar d g)
             <*> genA (o `SCons` (i `SCons` SNil)) (\_ -> realToFrac <$> genContVar d g)
             <*> genA (o `SCons` (o `SCons` SNil)) (\_ -> realToFrac <$> genContVar d g)
             <*> genA so                           (\_ -> realToFrac <$> genContVar d g)
             <*> genA (o `SCons` (i `SCons` SNil)) (\_ -> realToFrac <$> genContVar d g)
             <*> genA (o `SCons` (o `SCons` SNil)) (\_ -> realToFrac <$> genContVar d g)
             <*> genA so                           (\_ -> realToFrac <$> genContVar d g)
             <*> genA (o `SCons` (i `SCons` SNil)) (\_ -> realToFrac <$> genContVar d g)
             <*> genA (o `SCons` (o `SCons` SNil)) (\_ -> realToFrac <$> genContVar d g)
             <*> genA so                           (\_ -> realToFrac <$> genContVar d g)
        _ -> error "inaccessible"
      _ -> error "inaccessible"
    initState _ so (LC d) g =
        LS <$> genA so (\_ -> realToFrac <$> genContVar d g)
           <*> genA so (\_ -> realToFrac <$> genContVar d g)

instance ( BLAS b
         , KnownNat i
         , KnownNat o
         , Floating (b '[o])
         , Floating (b '[o,i])
         , Floating (b '[o,o])
         )
      => ComponentLayer 'Recurrent LSTM b '[i] '[o] where
    componentRunMode = RMNotFF

instance SOP.Generic (CState LSTM b '[i] '[o])
instance SOP.Generic (CParam LSTM b '[i] '[o])

instance (Num (b '[o,i]), Num (b '[o,o]), Num (b '[o])) => Num (CParam LSTM b '[i] '[o]) where
    (+)         = genericPlus
    (-)         = genericMinus
    (*)         = genericTimes
    negate      = genericNegate
    abs         = genericAbs
    signum      = genericSignum
    fromInteger = genericFromInteger

instance (Fractional (b '[o,i]), Fractional (b '[o,o]), Fractional (b '[o])) => Fractional (CParam LSTM b '[i] '[o]) where
    (/)          = genericDivide
    recip        = genericRecip
    fromRational = genericFromRational

instance (Floating (b '[o,i]), Floating (b '[o,o]), Floating (b '[o])) => Floating (CParam LSTM b '[i] '[o]) where
    pi      = genericPi
    exp     = genericExp
    (**)    = genericPower
    log     = genericLog
    logBase = genericLogBase
    sin     = genericSin
    cos     = genericCos
    tan     = genericTan
    asin    = genericAsin
    acos    = genericAcos
    atan    = genericAtan
    sinh    = genericSinh
    cosh    = genericCosh
    tanh    = genericTanh
    asinh   = genericAsinh
    acosh   = genericAcosh
    atanh   = genericAtanh

instance (Num (b '[o,i]), Num (b '[o,o]), Num (b '[o])) => Num (CState LSTM b '[i] '[o]) where
    (+)         = genericPlus
    (-)         = genericMinus
    (*)         = genericTimes
    negate      = genericNegate
    abs         = genericAbs
    signum      = genericSignum
    fromInteger = genericFromInteger

instance (Fractional (b '[o,i]), Fractional (b '[o,o]), Fractional (b '[o])) => Fractional (CState LSTM b '[i] '[o]) where
    (/)          = genericDivide
    recip        = genericRecip
    fromRational = genericFromRational

instance (Floating (b '[o,i]), Floating (b '[o,o]), Floating (b '[o])) => Floating (CState LSTM b '[i] '[o]) where
    pi      = genericPi
    exp     = genericExp
    (**)    = genericPower
    log     = genericLog
    logBase = genericLogBase
    sin     = genericSin
    cos     = genericCos
    tan     = genericTan
    asin    = genericAsin
    acos    = genericAcos
    atan    = genericAtan
    sinh    = genericSinh
    cosh    = genericCosh
    tanh    = genericTanh
    asinh   = genericAsinh
    acosh   = genericAcosh
    atanh   = genericAtanh


-- https://github.com/minoki/my-atcoder-solutions
{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
import           Control.Exception           (assert)
import           Control.Monad
import           Data.Bits
import qualified Data.ByteString.Builder     as BSB
import qualified Data.ByteString.Char8       as BS
import           Data.Char                   (isSpace)
import           Data.Coerce
import           Data.Complex
import           Data.Int                    (Int64)
import           Data.List                   (unfoldr)
import qualified Data.Vector.Generic         as G
import qualified Data.Vector.Unboxed         as U
import qualified Data.Vector.Unboxed.Mutable as UM
import           System.IO                   (stdout)

main = do
  n <- readLn @Int -- n <= 10^5
  (as,bs) <- fmap U.unzip $ U.replicateM n $ do
    [a,b] <- unfoldr (BS.readInt . BS.dropWhile isSpace) <$> BS.getLine
    return (a,b)
  let p, q :: Poly U.Vector Int
      p = Poly $ normalizePoly (0 `U.cons` as)
      q = Poly $ normalizePoly (0 `U.cons` bs)
      -- v = coeffAsc (p * q)
      !v = coeffAsc p `mulFFT` coeffAsc q
      !l = U.length v
  BSB.hPutBuilder stdout $ mconcat
    [ if k < l then
        BSB.intDec (v U.! k) <> BSB.char8 '\n' -- <= 10^9
      else
        BSB.string8 "0\n"
    | k <- [1..2*n]
    ]

--
-- Fast Fourier Transform (FFT)
--

halve :: G.Vector vec a => vec a -> vec a
halve v = let n = G.length v
          in G.generate (n `quot` 2) $ \j -> v G.! (j * 2)

fft :: forall vec a. (Num a, G.Vector vec a)
    => [vec a] -- ^ For a primitive n-th root of unity @u@, @iterate halve [1,u,u^2 .. u^(n-1)]@
    -> vec a -- ^ a polynomial of length n (= 2^k for some k)
    -> vec a
fft (u:u2) f | n == 1 = f
             | otherwise = let !n2 = n `quot` 2
                               r0, r1', t0, t1' :: vec a
                               r0 = G.generate n2 $ \j -> (f G.! j) + (f G.! (j + n2))
                               r1' = G.generate n2 $ \j -> ((f G.! j) - (f G.! (j + n2))) * u G.! j
                               !t0 = fft u2 r0
                               !t1' = fft u2 r1'
                           in G.generate n $ \j -> if even j then t0 G.! (j `quot` 2) else t1' G.! (j `quot` 2)
  where n = G.length f

mulFFT :: U.Vector Int -> U.Vector Int -> U.Vector Int
mulFFT !f !g = let n' = U.length f + U.length g - 2
                   k = finiteBitSize n' - countLeadingZeros n'
                   !_ = assert (n' < 2^k) ()
                   n = bit k
                   u :: U.Vector (Complex Double)
                   u = U.generate n $ \j -> cis (fromIntegral j * (2 * pi / fromIntegral n))
                   us = iterate halve u
                   f' = U.generate n $ \j -> if j < U.length f then
                                               fromIntegral (f U.! j)
                                             else
                                               0
                   g' = U.generate n $ \j -> if j < U.length g then
                                               fromIntegral (g U.! j)
                                             else
                                               0
                   f'' = fft us f'
                   g'' = fft us g'
                   fg = U.generate n $ \j -> (f'' U.! j) * (g'' U.! j)
                   fg' = fft (map (U.map conjugate) us) fg
               in U.generate n $ \j -> round (realPart (fg' U.! j) / fromIntegral n)

--
-- Univariate polynomial
--

newtype Poly vec a = Poly { coeffAsc :: vec a } deriving Eq

normalizePoly :: (Eq a, Num a, G.Vector vec a) => vec a -> vec a
normalizePoly v | G.null v || G.last v /= 0 = v
                | otherwise = normalizePoly (G.init v)

addPoly :: (Eq a, Num a, G.Vector vec a) => vec a -> vec a -> vec a
addPoly v w = case compare n m of
                LT -> G.generate m $ \i -> if i < n
                                           then v G.! i + w G.! i
                                           else w G.! i
                GT -> G.generate n $ \i -> if i < m
                                           then v G.! i + w G.! i
                                           else v G.! i
                EQ -> normalizePoly $ G.zipWith (+) v w
  where n = G.length v
        m = G.length w

subPoly :: (Eq a, Num a, G.Vector vec a) => vec a -> vec a -> vec a
subPoly v w = case compare n m of
                LT -> G.generate m $ \i -> if i < n
                                           then v G.! i - w G.! i
                                           else negate (w G.! i)
                GT -> G.generate n $ \i -> if i < m
                                           then v G.! i - w G.! i
                                           else v G.! i
                EQ -> normalizePoly $ G.zipWith (-) v w
  where n = G.length v
        m = G.length w

naiveMulPoly :: (Num a, G.Vector vec a) => vec a -> vec a -> vec a
naiveMulPoly v w = G.generate (n + m - 1) $
                   \i -> sum [(v G.! (i-j)) * (w G.! j) | j <- [max (i-n+1) 0..min i (m-1)]]
  where n = G.length v
        m = G.length w

doMulP :: (Eq a, Num a, G.Vector vec a) => Int -> vec a -> vec a -> vec a
doMulP n !v !w | n <= 16 = naiveMulPoly v w
doMulP n !v !w
  | G.null v = v
  | G.null w = w
  | G.length v < n2 = let (w0, w1) = G.splitAt n2 w
                          u0 = doMulP n2 v w0
                          u1 = doMulP n2 v w1
                      in G.generate (G.length v + G.length w - 1)
                         $ \i -> case () of
                                   _ | i < n2     ->  u0 `at` i
                                     | i < n      -> (u0 `at` i) + (u1 `at` (i - n2))
                                     | i < n + n2 -> (u1 `at` (i - n2))
  | G.length w < n2 = let (v0, v1) = G.splitAt n2 v
                          u0 = doMulP n2 v0 w
                          u1 = doMulP n2 v1 w
                      in G.generate (G.length v + G.length w - 1)
                         $ \i -> case () of
                                   _ | i < n2     ->  u0 `at` i
                                     | i < n      -> (u0 `at` i) + (u1 `at` (i - n2))
                                     | i < n + n2 -> (u1 `at` (i - n2))
  | otherwise = let (v0, v1) = G.splitAt n2 v
                    (w0, w1) = G.splitAt n2 w
                    v0_1 = v0 `addPoly` v1
                    w0_1 = w0 `addPoly` w1
                    p = doMulP n2 v0_1 w0_1
                    q = doMulP n2 v0 w0
                    r = doMulP n2 v1 w1
                    -- s = (p `subPoly` q) `subPoly` r -- p - q - r
                    -- q + s*X^n2 + r*X^n
                in G.generate (G.length v + G.length w - 1)
                   $ \i -> case () of
                             _ | i < n2     ->   q `at` i
                               | i < n      -> ((q `at` i) + (p `at` (i - n2))) - ((q `at` (i - n2)) + (r `at` (i - n2)))
                               | i < n + n2 -> ((r `at` (i - n)) + (p `at` (i - n2))) - ((q `at` (i - n2)) + (r `at` (i - n2)))
                               | otherwise  ->   r `at` (i - n)
  where n2 = n `quot` 2
        at :: (Num a, G.Vector vec a) => vec a -> Int -> a
        at v i = if i < G.length v then v G.! i else 0
{-# INLINE doMulP #-}

mulPoly :: (Eq a, Num a, G.Vector vec a) => vec a -> vec a -> vec a
mulPoly !v !w = let k = ceiling ((log (fromIntegral (max n m)) :: Double) / log 2) :: Int
                in doMulP (2^k) v w
  where n = G.length v
        m = G.length w
{-# INLINE mulPoly #-}

zeroPoly :: (G.Vector vec a) => Poly vec a
zeroPoly = Poly G.empty

constPoly :: (Eq a, Num a, G.Vector vec a) => a -> Poly vec a
constPoly 0 = Poly G.empty
constPoly x = Poly (G.singleton x)

scalePoly :: (Eq a, Num a, G.Vector vec a) => a -> Poly vec a -> Poly vec a
scalePoly a (Poly xs)
  | a == 0 = zeroPoly
  | otherwise = Poly $ G.map (* a) xs

valueAtPoly :: (Num a, G.Vector vec a) => Poly vec a -> a -> a
valueAtPoly (Poly xs) t = G.foldr' (\a b -> a + t * b) 0 xs

instance (Eq a, Num a, G.Vector vec a) => Num (Poly vec a) where
  (+) = coerce (addPoly :: vec a -> vec a -> vec a)
  (-) = coerce (subPoly :: vec a -> vec a -> vec a)
  negate (Poly v) = Poly (G.map negate v)
  (*) = coerce (mulPoly :: vec a -> vec a -> vec a)
  fromInteger = constPoly . fromInteger
  abs = undefined; signum = undefined

divModPoly :: (Eq a, Fractional a, G.Vector vec a) => Poly vec a -> Poly vec a -> (Poly vec a, Poly vec a)
divModPoly f g@(Poly w)
  | G.null w = error "divModPoly: divide by zero"
  | degree f < degree g = (zeroPoly, f)
  | otherwise = loop zeroPoly (scalePoly (recip b) f)
  where
    g' = toMonic g
    b = leadingCoefficient g
    -- invariant: f == q * g + scalePoly b p
    loop q p | degree p < degree g = (q, scalePoly b p)
             | otherwise = let q' = Poly (G.drop (degree' g) (coeffAsc p))
                           in loop (q + q') (p - q' * g')

    toMonic :: (Fractional a, G.Vector vec a) => Poly vec a -> Poly vec a
    toMonic f@(Poly xs)
      | G.null xs = zeroPoly
      | otherwise = Poly $ G.map (* recip (leadingCoefficient f)) xs

    leadingCoefficient :: (Num a, G.Vector vec a) => Poly vec a -> a
    leadingCoefficient (Poly xs)
      | G.null xs = 0
      | otherwise = G.last xs

    degree :: G.Vector vec a => Poly vec a -> Maybe Int
    degree (Poly xs) = case G.length xs - 1 of
      -1 -> Nothing
      n  -> Just n

    degree' :: G.Vector vec a => Poly vec a -> Int
    degree' (Poly xs) = case G.length xs of
      0 -> error "degree': zero polynomial"
      n -> n - 1

-- 組立除法
-- second constPoly (divModByDeg1 f t) = divMod f (Poly (G.fromList [-t, 1]))
divModByDeg1 :: (Eq a, Num a, G.Vector vec a) => Poly vec a -> a -> (Poly vec a, a)
divModByDeg1 f t = let w = G.postscanr (\a b -> a + b * t) 0 $ coeffAsc f
                   in (Poly (G.tail w), G.head w)


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}

{--
 - Author: haym
 -
 - Helper functions common to multiple projects
--}

module Lib where

import Control.Monad
import Control.Monad.State
import Data.Char
import Data.Colour.Names
import Data.Maybe

import Data.Complex
import Graphics.Rendering.Chart.Backend.Diagrams
import Graphics.Rendering.Chart.Easy
import System.Process

type C = Complex Double

class Mag a where
    mag :: a -> Double

instance Mag Double where
    mag = id

instance Mag C where
    mag = magnitude

plotPoints' :: FilePath -> String -> Double -> [(Double, Double)] -> IO ()
plotPoints' file title rad xs = plotPoints file title rad xs >> callCommand ("inkview " ++ file)

plotPoints :: FilePath -> String -> Double -> [(Double, Double)] -> IO ()
plotPoints = plotPointsColor black

plotPointsColor :: Colour Double -> FilePath -> String -> Double -> [(Double, Double)] -> IO ()
plotPointsColor color file title rad xs = toFile def file $ do
        layout_title .= title
        plot (pointsConfig color rad <$> points "points" xs)

pointsConfig :: Colour Double -> Double -> PlotPoints x y -> PlotPoints x y
pointsConfig color rad
    = set (plot_points_style.point_color) (opaque color)
    . set (plot_points_style.point_radius) rad

diverges :: (Mag a) => Int -> (a -> a) -> a -> Bool
diverges maxIters func x0 = any (\x -> mag x > 4) . take maxIters $ iterate func x0

c2t :: Complex Double -> (Double, Double)
c2t (r :+ i) = (r, i)

letterCoeff :: Char -> Double
letterCoeff c = fromIntegral (fromEnum (toLower c) - fromEnum 'a') / 10 - 1.2

type Attractor = (Double -> Double -> Double, Double -> Double -> Double)

mkAttractor :: [Double] -> Attractor
mkAttractor cs = (fx, fy)
    where
        getNum = get >>= \case
            (x:xs) -> put xs >> return x
            _ -> return 0
        mkMap = do
            n <- replicateM 6 getNum
            return $ case n of
                [a1, a2, a3, a4, a5, a6] ->
                    let f x y = a1 + a2*x + a3*x*x + a4*x*y + a5*y + a6*y*y
                    in f
                [] -> error "lol"

        [fx, fy] = evalState (replicateM 2 mkMap) cs

attrFromLetters :: String -> Attractor
attrFromLetters = mkAttractor . fmap letterCoeff

runAttractor :: Attractor -> (Double, Double) -> (Double, Double)
runAttractor (fx, fy) (x, y) = (fx x y, fy x y)

class VSpace a where
    (^+) :: a -> a -> a
    (^*) ::  Double -> a -> a

instance VSpace Double where
    (^+) = (+)
    (^*) = (*)

instance VSpace (Double, Double) where
    (^+) (x0, y0) (x1, y1) = (x0 + x1, y0 + y1)
    (^*) a (x, y) = (a*x, a*y)

instance VSpace (Double, Double, Double) where
    (^+) (x0, y0, z0) (x1, y1, z1) = (x0 + x1, y0 + y1, z0 + z1)
    (^*) a (x, y, z) = (a*x, a*y, a*z)

rkStep :: (VSpace a) => (a -> a) -> Double -> (Double, a) -> (Double, a)
rkStep f dt (t, y) = (t + dt, y ^+ ((dt / 6)^*(k1 ^+ (2.0^*k2) ^+ (2.0^*k3) ^+ k4)))
    where
        k1 = f y
        k2 = f (y ^+ ((0.5*dt)^*k1))
        k3 = f (y ^+ ((0.5*dt)^*k2))
        k4 = f (y ^+ (dt^*k3))

rkStep' :: (VSpace a) => (a -> a -> a) -> Double -> (Double, a, a) -> (Double, a, a)
rkStep' f dt (t, y, y') = (t + dt, y ^+ (dt^*y'), y'New)
    where
        y'New = y' ^+ ((dt / 6)^*(k1 ^+ (2.0^*k2) ^+ (2.0^*k3) ^+ k4))
        k1 = f y y'
        k2 = f y (y' ^+ ((0.5*dt)^*k1))
        k3 = f y (y' ^+ ((0.5*dt)^*k2))
        k4 = f y (y' ^+ (dt^*k3))

eulerStep' :: VSpace a => (a -> a -> a) -> Double -> (Double, a, a) -> (Double, a, a)
eulerStep' a dt (t, y, y') = (tNew, yNew, y'New)
    where
    y'New = y' ^+ (dt^*a y y')
    yNew = y ^+ (dt^*y'New)
    tNew = t + dt

eulerStep :: (VSpace a) => (a -> a) -> Double -> (Double, a) -> (Double, a)
eulerStep f dt (t, y) = (t + dt, y ^+ (dt^*f y))


{-# LANGUAGE BangPatterns #-}
module ML.NN.Training
       (
           -- * Training networks
           TrainingConfig(..)
       ,   Sample(..)
       ,   Gradient(..)
       ,   sgd
       ,   gradientDescentCore

           -- * Internal (exposed for testing)
       ,   computeZsAndAs
       ) where

import           ML.CostFunctions (CostDerivative, mse')
import           ML.NN
import           ML.NN.ActivationFunction (ActivationFunctionDerivative)
import           ML.Sample (Sample(..))

import           Control.Monad.Random (evalRandIO)
import           Control.Monad.Random.Extended (vshuffle)
import           Control.Monad.State (State, evalState, get, put)
import           Data.Foldable (foldl')
import           Data.List (unfoldr)
import qualified Data.Vector as V
import           Numeric.LinearAlgebra (Matrix, R, Vector, (#>), (<>), asColumn, asRow, cmap, konst, outer, size, tr)

-- | Configuration for training a network.
data TrainingConfig = TrainingConfig
                      { trainingEta :: R  -- ^ η - Learning rate.
                      , trainingActivation :: ActivationFunction
                      , trainingActivationDerivative :: ActivationFunctionDerivative
                      , trainingCostDerivative :: CostDerivative
                      }

-- | The gradient of the network.
data Gradient = Gradient
                { gradientNablaB :: {-# UNPACK #-} !(V.Vector (Vector R))
                , gradientNablaW :: {-# UNPACK #-} !(V.Vector (Matrix R))
                } deriving (Read, Show)

sumGradients :: V.Vector Gradient -> Gradient
sumGradients = V.foldl1' addGradient
    where (Gradient !lb !lw) `addGradient` (Gradient !rb !rw) =
              Gradient (V.zipWith (+) lb rb) (V.zipWith (+) lw rw)

-- | Return z and activation values for each layer in the network.
--
-- The values are returned in reverse order for use by the
-- backpropogation algorithm.  We the State monad so it's more
-- explicit that the output activation of one layer is the input to
-- the next.
computeZsAndAs :: ActivationFunction -> Network -> Vector R -> ([Vector R], [Vector R])
computeZsAndAs act (Network layers) input = (reverse zs, reverse (input:as))
    where (zs, as) = unzip $ evalState (mapM computeZA layers) input

          computeZA :: Layer -> State (Vector R) (Vector R, Vector R)
          computeZA (Layer b w) = do
              x <- get
              let z = w #> x + b
                  a = cmap act z
              put a
              pure $ (z,a)

-- | Compute the gradient for the training example.
backpropogation :: ActivationFunction
                -> ActivationFunctionDerivative
                -> CostDerivative
                -> Network
                -> Sample
                -> Gradient
backpropogation act act' cost' !net@(Network !layers) (Sample !x !y) =
    Gradient (V.reverse $ V.cons nablaB_L nablaBs) (V.reverse $ V.cons nablaW_L nablaWs)
    where (z:zs, a:a':as) = computeZsAndAs act net x
          delta_L  = cost' a y * cmap act' z
          nablaB_L = delta_L
          nablaW_L = asColumn delta_L <> asRow a'
          (nablaBs, nablaWs) =
              backpropogationBackwardsPass act' delta_L zs as (reverse $ tail layers)

-- | Perform the backwards pass of the backpropogation algorithm.
--
-- Traverse the previously reverse z values, activations, and layers
-- from layer L to 2.  We thread the delta value along as state
backpropogationBackwardsPass :: ActivationFunctionDerivative
                             -> Vector R    -- ^ delta for the last layer.
                             -> [Vector R]  -- ^ zs in reverse order.
                             -> [Vector R]  -- ^ activations in reverse order.
                             -> [Layer]     -- ^ Layers L to 2.
                             -> (V.Vector (Vector R), V.Vector (Matrix R))  -- ^
backpropogationBackwardsPass act' delta_L zs as layers = V.unzip output
    where !output = V.fromList $ evalState (mapM processLayer (zip3 layers zs as)) delta_L

          processLayer :: (Layer, Vector R, Vector R) -> State (Vector R) (Vector R, Matrix R)
          processLayer ((Layer _bias weights), z, a) = do
              delta <- get
              let actPrime = cmap act' z
                  delta'   = (tr weights #> delta) * actPrime
              put delta'
              pure (delta', delta' `outer` a)

-- | Update the network's weights and biases by applying gradient
--   descent for the given sample input.
gradientDescentCore :: TrainingConfig -> V.Vector Sample -> Network -> Network
gradientDescentCore (TrainingConfig eta act act' cost') !trainingData !net@(Network !layers) =
    Network layers'
    where sampleGradients :: V.Vector Gradient
          !sampleGradients = V.map (backpropogation act act' cost' net) trainingData

          Gradient !nablaB !nablaW = sumGradients sampleGradients

          !layers' = V.toList $ V.zipWith3 updateWeightsAndBiases (V.fromList layers) nablaB nablaW

          updateWeightsAndBiases :: Layer -> Vector R -> Matrix R -> Layer
          updateWeightsAndBiases (Layer b w) nb nw =
              Layer (b-(konst (eta/numSamples) (size b)) * nb)
                    (w-(konst (eta/numSamples) (size w)) * nw)
              where numSamples = fromIntegral $ length trainingData

-- | Train the neural network using stochastic gradient descent.
sgd :: TrainingConfig
    -> Int  -- ^ epochs
    -> Int  -- ^ mini-batch size
    -> V.Vector Sample
    -> Network
    -> IO Network
sgd trainingConfig !epochs !miniBatchSize !trainingData !network = trainEpoch 0 network
    where trainEpoch epoch !net
              | epoch == epochs = putStrLn "done!" >> pure net
              | otherwise = do
                    !shuffledTrainingData <- evalRandIO $ vshuffle trainingData
                    let miniBatches = miniBatchSize `vChunksOf` shuffledTrainingData
                        !net' = foldl' (flip (gradientDescentCore trainingConfig)) net miniBatches
                    putStrLn $ "Completed epoch: " ++ show epoch
                    trainEpoch (epoch+1) net'

vChunksOf :: Int -> V.Vector a -> [V.Vector a]
vChunksOf n vec = Data.List.unfoldr makeChunk vec
    where makeChunk :: V.Vector a -> Maybe (V.Vector a, V.Vector a)
          makeChunk v | V.null v  = Nothing
                      | otherwise = Just $ V.splitAt n v


{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
-- |
-- Module     : Foreign.BLAS.Level2
-- Copyright  : Copyright (c) 2010, Patrick Perry <patperry@gmail.com>
-- License    : BSD3
-- Maintainer : Patrick Perry <patperry@gmail.com>
-- Stability  : experimental
--
-- Matrix-Vector operations.
--

module Foreign.BLAS.Level2 (
    BLAS2(..),
    ) where

import Data.Complex
import Foreign( Ptr, Storable, with )

import Foreign.BLAS.Types
import Foreign.BLAS.Level1
import Foreign.BLAS.Double
import Foreign.BLAS.Zomplex

-- | Types with matrix-vector operations.
class (BLAS1 a) => BLAS2 a where
    gbmv :: Trans -> Int -> Int -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO ()
    gemv :: Trans -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO ()
    gerc :: Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO ()
    geru :: Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO ()

    hbmv :: Uplo -> Int -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO ()
    hemv :: Uplo -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> a -> Ptr a -> Int -> IO ()
    her  :: Uplo -> Int -> Double -> Ptr a -> Int -> Ptr a -> Int -> IO ()
    her2 :: Uplo -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO ()
    hpmv :: Uplo -> Int -> a -> Ptr a -> Ptr a -> Int -> a -> Ptr a -> Int -> IO ()
    hpr  :: Uplo -> Int -> Double -> Ptr a -> Int -> Ptr a -> IO ()
    hpr2 :: Uplo -> Int -> a -> Ptr a -> Int -> Ptr a -> Int -> Ptr a -> IO ()

    tbmv :: Uplo -> Trans -> Diag -> Int -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO ()
    tbsv :: Uplo -> Trans -> Diag -> Int -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO ()
    tpmv :: Uplo -> Trans -> Diag -> Int -> Ptr a -> Ptr a -> Int -> IO ()
    tpsv :: Uplo -> Trans -> Diag -> Int -> Ptr a -> Ptr a -> Int -> IO ()
    trmv :: Uplo -> Trans -> Diag -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO ()
    trsv :: Uplo -> Trans -> Diag -> Int -> Ptr a -> Int -> Ptr a -> Int -> IO ()

withEnum :: (Enum a, Storable a) => Int -> (Ptr a -> IO b) -> IO b
withEnum = with . toEnum
{-# INLINE withEnum #-}

instance BLAS2 Double where
    gemv transa m n alpha pa lda px incx beta py incy =
        withTrans transa $ \ptransa ->
        withEnum m $ \pm ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
        with beta $ \pbeta ->
        withEnum incy $ \pincy ->
            dgemv ptransa pm pn palpha pa plda px pincx pbeta py pincy
    {-# INLINE gemv #-}

    gbmv transa m n kl ku alpha pa lda px incx beta py incy =
        withTrans transa $ \ptransa ->
        withEnum m $ \pm ->
        withEnum n $ \pn ->
        withEnum kl $ \pkl ->
        withEnum ku $ \pku ->
        with alpha $ \palpha ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
        with beta $ \pbeta ->
        withEnum incy $ \pincy ->
            dgbmv ptransa pm pn pkl pku palpha pa plda px pincx pbeta py pincy
    {-# INLINE gbmv #-}

    trmv uplo trans diag n pa lda px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
            dtrmv puplo ptrans pdiag pn pa plda px pincx
    {-# INLINE trmv #-}

    tpmv uplo trans diag n pap px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum incx $ \pincx ->
            dtpmv puplo ptrans pdiag pn pap px pincx
    {-# INLINE tpmv #-}

    tpsv uplo trans diag n pap px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum incx $ \pincx ->
            dtpsv puplo ptrans pdiag pn pap px pincx
    {-# INLINE tpsv #-}

    tbmv uplo trans diag n k pa lda px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum k $ \pk ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
            dtbmv puplo ptrans pdiag pn pk pa plda px pincx
    {-# INLINE tbmv #-}

    trsv uplo trans diag n pa lda px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
            dtrsv puplo ptrans pdiag pn pa plda px pincx
    {-# INLINE trsv #-}

    tbsv uplo trans diag n k pa lda px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum k $ \pk ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
            dtbsv puplo ptrans pdiag pn pk pa plda px pincx
    {-# INLINE tbsv #-}

    hemv uplo n alpha pa lda px incx beta py incy =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
        with beta $ \pbeta ->
        withEnum incy $ \pincy ->
            dsymv puplo pn palpha pa plda px pincx pbeta py pincy
    {-# INLINE hemv #-}

    hbmv uplo n k alpha pa lda px incx beta py incy =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        withEnum k $ \pk ->
        with alpha $ \palpha ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
        with beta $ \pbeta ->
        withEnum incy $ \pincy ->
            dsbmv puplo pn pk palpha pa plda px pincx pbeta py pincy
    {-# INLINE hbmv #-}

    gerc m n alpha px incx py incy pa lda =
        withEnum m $ \pm ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
        withEnum incy $ \pincy ->
        withEnum lda $ \plda ->
            dger pm pn palpha px pincx py pincy pa plda
    {-# INLINE gerc #-}

    geru = gerc
    {-# INLINE geru #-}

    her uplo n alpha px incx pa lda =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
        withEnum lda $ \plda ->
            dsyr puplo pn palpha px pincx pa plda
    {-# INLINE her #-}

    her2 uplo n alpha px incx py incy pa lda =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
        withEnum incy $ \pincy ->
        withEnum lda $ \plda ->
            dsyr2 puplo pn palpha px pincx py pincy pa plda
    {-# INLINE her2 #-}

    hpmv uplo n alpha pap px incx beta py incy =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
        with beta $ \pbeta ->
        withEnum incy $ \pincy ->
            dspmv puplo pn palpha pap px pincx pbeta py pincy
    {-# INLINE hpmv #-}

    hpr uplo n alpha px incx pap =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
            dspr puplo pn palpha px pincx pap
    {-# INLINE hpr #-}

    hpr2 uplo n alpha px incx py incy pap =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
        withEnum incy $ \pincy ->
            dspr2 puplo pn palpha px pincx py pincy pap
    {-# INLINE hpr2 #-}

instance BLAS2 (Complex Double) where
    gemv transa m n alpha pa lda px incx beta py incy =
        withTrans transa $ \ptransa ->
        withEnum m $ \pm ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
        with beta $ \pbeta ->
        withEnum incy $ \pincy ->
            zgemv ptransa pm pn palpha pa plda px pincx pbeta py pincy
    {-# INLINE gemv #-}

    gbmv transa m n kl ku alpha pa lda px incx beta py incy =
        withTrans transa $ \ptransa ->
        withEnum m $ \pm ->
        withEnum n $ \pn ->
        withEnum kl $ \pkl ->
        withEnum ku $ \pku ->
        with alpha $ \palpha ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
        with beta $ \pbeta ->
        withEnum incy $ \pincy ->
            zgbmv ptransa pm pn pkl pku palpha pa plda px pincx pbeta py pincy
    {-# INLINE gbmv #-}

    trmv uplo trans diag n pa lda px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
            ztrmv puplo ptrans pdiag pn pa plda px pincx
    {-# INLINE trmv #-}

    tpmv uplo trans diag n pap px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum incx $ \pincx ->
            ztpmv puplo ptrans pdiag pn pap px pincx
    {-# INLINE tpmv #-}

    tpsv uplo trans diag n pap px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum incx $ \pincx ->
            ztpsv puplo ptrans pdiag pn pap px pincx
    {-# INLINE tpsv #-}

    tbmv uplo trans diag n k pa lda px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum k $ \pk ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
            ztbmv puplo ptrans pdiag pn pk pa plda px pincx
    {-# INLINE tbmv #-}

    trsv uplo trans diag n pa lda px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
            ztrsv puplo ptrans pdiag pn pa plda px pincx
    {-# INLINE trsv #-}

    tbsv uplo trans diag n k pa lda px incx =
        withUplo uplo $ \puplo ->
        withTrans trans $ \ptrans ->
        withDiag diag $ \pdiag ->
        withEnum n $ \pn ->
        withEnum k $ \pk ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
            ztbsv puplo ptrans pdiag pn pk pa plda px pincx
    {-# INLINE tbsv #-}

    hemv uplo n alpha pa lda px incx beta py incy =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
        with beta $ \pbeta ->
        withEnum incy $ \pincy ->
            zhemv puplo pn palpha pa plda px pincx pbeta py pincy
    {-# INLINE hemv #-}

    hbmv uplo n k alpha pa lda px incx beta py incy =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        withEnum k $ \pk ->
        with alpha $ \palpha ->
        withEnum lda $ \plda ->
        withEnum incx $ \pincx ->
        with beta $ \pbeta ->
        withEnum incy $ \pincy ->
            zhbmv puplo pn pk palpha pa plda px pincx pbeta py pincy
    {-# INLINE hbmv #-}

    gerc m n alpha px incx py incy pa lda =
        withEnum m $ \pm ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
        withEnum incy $ \pincy ->
        withEnum lda $ \plda ->
            zgerc pm pn palpha px pincx py pincy pa plda
    {-# INLINE gerc #-}

    geru m n alpha px incx py incy pa lda =
        withEnum m $ \pm ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
        withEnum incy $ \pincy ->
        withEnum lda $ \plda ->
            zgeru pm pn palpha px pincx py pincy pa plda
    {-# INLINE geru #-}

    her uplo n alpha px incx pa lda =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
        withEnum lda $ \plda ->
            zher puplo pn palpha px pincx pa plda
    {-# INLINE her #-}

    her2 uplo n alpha px incx py incy pa lda =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
        withEnum incy $ \pincy ->
        withEnum lda $ \plda ->
            zher2 puplo pn palpha px pincx py pincy pa plda
    {-# INLINE her2 #-}

    hpmv uplo n alpha pap px incx beta py incy =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
        with beta $ \pbeta ->
        withEnum incy $ \pincy ->
            zhpmv puplo pn palpha pap px pincx pbeta py pincy
    {-# INLINE hpmv #-}

    hpr uplo n alpha px incx pap =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
            zhpr puplo pn palpha px pincx pap
    {-# INLINE hpr #-}

    hpr2 uplo n alpha px incx py incy pap =
        withUplo uplo $ \puplo ->
        withEnum n $ \pn ->
        with alpha $ \palpha ->
        withEnum incx $ \pincx ->
        withEnum incy $ \pincy ->
            zhpr2 puplo pn palpha px pincx py pincy pap
    {-# INLINE hpr2 #-}


{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
-- |
-- Module    : Statistics.Distribution.Hypergeometric
-- Copyright : (c) 2009 Bryan O'Sullivan
-- License   : BSD3
--
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : portable
--
-- The Hypergeometric distribution.  This is the discrete probability
-- distribution that measures the probability of /k/ successes in /l/
-- trials, without replacement, from a finite population.
--
-- The parameters of the distribution describe /k/ elements chosen
-- from a population of /l/, with /m/ elements of one type, and
-- /l/-/m/ of the other (all are positive integers).

module Statistics.Distribution.Hypergeometric
    (
      HypergeometricDistribution
    -- * Constructors
    , hypergeometric
    -- ** Accessors
    , hdM
    , hdL
    , hdK
    ) where

import Data.Aeson (FromJSON, ToJSON)
import Data.Binary (Binary)
import Data.Data (Data, Typeable)
import GHC.Generics (Generic)
import Numeric.MathFunctions.Constants (m_epsilon)
import Numeric.SpecFunctions (choose)
import qualified Statistics.Distribution as D
import Data.Binary (put, get)
import Control.Applicative ((<$>), (<*>))

data HypergeometricDistribution = HD {
      hdM :: {-# UNPACK #-} !Int
    , hdL :: {-# UNPACK #-} !Int
    , hdK :: {-# UNPACK #-} !Int
    } deriving (Eq, Read, Show, Typeable, Data, Generic)

instance FromJSON HypergeometricDistribution
instance ToJSON HypergeometricDistribution

instance Binary HypergeometricDistribution where
    get = HD <$> get <*> get <*> get
    put (HD x y z) = put x >> put y >> put z

instance D.Distribution HypergeometricDistribution where
    cumulative = cumulative

instance D.DiscreteDistr HypergeometricDistribution where
    probability = probability

instance D.Mean HypergeometricDistribution where
    mean = mean

instance D.Variance HypergeometricDistribution where
    variance = variance

instance D.MaybeMean HypergeometricDistribution where
    maybeMean = Just . D.mean

instance D.MaybeVariance HypergeometricDistribution where
    maybeStdDev   = Just . D.stdDev
    maybeVariance = Just . D.variance

instance D.Entropy HypergeometricDistribution where
  entropy = directEntropy

instance D.MaybeEntropy HypergeometricDistribution where
  maybeEntropy = Just . D.entropy

variance :: HypergeometricDistribution -> Double
variance (HD m l k) = (k' * ml) * (1 - ml) * (l' - k') / (l' - 1)
  where m' = fromIntegral m
        l' = fromIntegral l
        k' = fromIntegral k
        ml = m' / l'

mean :: HypergeometricDistribution -> Double
mean (HD m l k) = fromIntegral k * fromIntegral m / fromIntegral l

directEntropy :: HypergeometricDistribution -> Double
directEntropy d@(HD m _ _) =
    negate . sum $
  takeWhile (< negate m_epsilon) $
  dropWhile (not . (< negate m_epsilon)) $
  [ let x = probability d n in x * log x | n <- [0..m]]

hypergeometric :: Int               -- ^ /m/
               -> Int               -- ^ /l/
               -> Int               -- ^ /k/
               -> HypergeometricDistribution
hypergeometric m l k
  | not (l > 0)            = error $ msg ++ "l must be positive"
  | not (m >= 0 && m <= l) = error $ msg ++ "m must lie in [0,l] range"
  | not (k > 0 && k <= l)  = error $ msg ++ "k must lie in (0,l] range"
  | otherwise = HD m l k
    where
      msg = "Statistics.Distribution.Hypergeometric.hypergeometric: "

-- Naive implementation
probability :: HypergeometricDistribution -> Int -> Double
probability (HD mi li ki) n
  | n < max 0 (mi+ki-li) || n > min mi ki = 0
  | otherwise =
      choose mi n * choose (li - mi) (ki - n) / choose li ki

cumulative :: HypergeometricDistribution -> Double -> Double
cumulative d@(HD mi li ki) x
  | isNaN x      = error "Statistics.Distribution.Hypergeometric.cumulative: NaN argument"
  | isInfinite x = if x > 0 then 1 else 0
  | n <  minN    = 0
  | n >= maxN    = 1
  | otherwise    = D.sumProbabilities d minN n
  where
    n    = floor x
    minN = max 0 (mi+ki-li)
    maxN = min mi ki


{-# LANGUAGE FlexibleContexts, RankNTypes #-}

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-type-defaults      #-}
module Main where
import Control.Monad.ST (runST)
import qualified Data.Vector.Unboxed as U
import Control.Monad (replicateM)
import System.Random.MWC
import Statistics.Distribution
import Statistics.Distribution.Uniform
import Statistics.Distribution.Normal
import Statistics.Distribution.Exponential
import Graphics.Rendering.Chart
import Graphics.Rendering.Chart.Easy
import Graphics.Rendering.Chart.Backend.Diagrams
import Data.Default.Class
import Control.Lens

plotNumbers xs t = toRenderable $ do
  layout_title .= t
  plot $ fmap histToPlot $ liftEC $ do
    plot_hist_bins .= 15
    plot_hist_values .= xs
    plot_hist_norm_func .= const id

-- lineare Kongruenzmethode:
createRandom a b m = random
  where random x = let y = ((a * x) + b) `mod` m in (y:random y)

main = do
    putStrLn $ show $ take 100 $ createRandom 4 1 9 5

    -- erzeuge gleichverteilten Zufallszahlengenerator
    -- dieser Generator erzeugt immer die gleiche Folge an Zufallszahlen!
    -- Das ist hilfreich um reproduzierbare Simulationen zu haben
    -- Um unterschiedliche Zuffalszahlen, bei jedem Lauf zu erhalten,
    -- sollte create mit createSystemRandom ersetzt werden
    mwc <- create
    n_uniform <- replicateM 1000 $ genContVar (uniformDistr 0 5) mwc
    renderableToFile def "histogramm_uniform.svg" (plotNumbers n_uniform "Standardverteilung mit a = 0 und b = 5")
    n_exp <- replicateM 1000 $ genContVar (exponential 0.6) mwc
    renderableToFile def "histogramm_exp.svg" (plotNumbers n_exp "Exponentialverteilung mit λ = 0.6")
    n_normal <- replicateM 1000 $ genContVar (normalDistr 0.9 1) mwc
    renderableToFile def "histogramm_normal.svg" (plotNumbers n_normal "Gaussverteilung mit μ = 0.9 und σ = 1")


module Number where
import Data.Complex --Complex
import Data.Ratio --Rational

data LispNumber = Integer Integer -- Stores a Haskell Integer
                | Real Double | Rational Rational
                | Complex (Complex Double) deriving(Eq)

instance Show LispNumber where show = showNumber

instance Num LispNumber where
  (Integer a)  + (Integer b) = Integer $ a + b
  (Integer a)  + (Real b) = Real $ fromInteger a + b
  (Integer a)  + (Rational b) = Rational $ fromInteger  a + b
  (Integer a)  + (Complex b) = Complex $ fromInteger a + b

  (Real a)  + (Real b) = Real $ a + b
  (Real a)  + (Integer b) = Real $ a + fromInteger b
  (Real a)  + (Rational b) = Real $ a + fromRational b
  --(Real a)  + (Complex b) = Complex $

  (Rational a)  + (Rational b) = Rational $ a + b
  (Complex a)  + (Complex b) = Complex $ a + b

  (Integer a)  - (Integer b) = Integer $ a - b
  (Integer a)  - (Real b) = Real $ fromInteger a - b
  (Integer a)  - (Rational b) = Rational $ fromInteger  a - b
  (Integer a)  - (Complex b) = Complex $ fromInteger a - b

  (Real a)  - (Real b) = Real $ a - b
  (Rational a)  - (Rational b) = Rational $ a - b
  (Complex a)  - (Complex b) = Complex $ a - b

  (Integer a)  * (Integer b) = Integer $ a * b
  (Real a)  * (Real b) = Real $ a * b
  (Rational a)  * (Rational b) = Rational $ a * b
  (Complex a)  * (Complex b) = Complex $ a * b

  abs (Integer a)  = Integer $ abs a
  abs (Real a)     = Real $ abs a
  abs (Rational a) = Rational $ abs a
  abs (Complex a)   = Complex $ abs a

  fromInteger  = Integer

  signum (Integer a)  = Integer $ signum a
  signum (Real a)     = Real $ signum a
  signum (Rational a) = Rational $ signum a
  signum (Complex a)   = Complex $ signum a

instance Fractional LispNumber where
  (Integer a) / (Integer b)   = Rational $ a % b
  (Real a) / (Real b)         = Real $ a / b
  (Complex a) / (Complex b)   = Complex $ a / b
  (Rational a) / (Rational b) = Rational $ a / b

  fromRational = Rational

instance Ord LispNumber where
  compare (Integer a) (Integer b) = compare a b
  compare (Integer a) (Rational b) = compare (fromIntegral a) b
  compare (Integer a) (Real b) = compare (fromIntegral a) b
  compare (Integer a) (Complex b) = error "Cant order complex numbers"

  compare (Rational b) (Integer a)= compare b (fromIntegral a)
  compare (Real b) (Integer a)= compare b (fromIntegral a)
  compare (Complex b) (Integer a) = error "Cant order complex numbers"

  compare (Real a) (Real b) = compare a b
  compare (Rational a) (Rational b) = compare a b
  compare (Complex _) (Complex _) = error "Cant order complex numbers"

showNumber :: LispNumber -> String
showNumber (Integer a)  = show a
showNumber (Complex a)  = show a
showNumber (Rational a) = show (numerator a) ++ "/" ++ show (denominator a)
showNumber (Real a)     = show a


{-
 -  <DeclList> ::= { (<FunDecl> | <ValDecl>) }
 -
 -  <FunDecl> ::= 'fun' <Ident> <Ident> '=' <Exp>
 -
 -  <ValDecl> ::= 'val' <Ident> '=' <Exp>
 -
 -  <Expr> ::= <Comp>
 -           | 'if' <Expr> 'then' <Expr> 'else' <Expr>
 -           | 'let' <DeclList> 'in' <Expr> 'end'
 -           | 'fn' <Ident> '=>' <Expr>
 -
 -  <Comp> ::= <Plus> { ('>' | '=' | '<') <Plus> }
 -
 -  <Plus> ::= <Mult> { ('+' | '-') <Mult> }
 -
 -  <Mult> ::= <App>  { ('*' | '/') <App> }
 -
 -  <App>  ::= <Fact> { <Fact> }
 -
 -  <Fact> ::= '(' <Expr> ')'
 -          |  <Integer>
 -          |  <Identifier>
 -}

 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RankNTypes #-}

 {-# LANGUAGE FlexibleContexts #-}

 module Hw8 () where

 -- import Hw1
 -- import Hw2
 -- import Hw3
 -- import Hw4
 -- import Hw5
 -- import Hw6
 -- import Hw7
 import Data.Time.Clock
 import Data.Complex

 import Text.Parsec
 import Text.Parsec.Expr
 import Text.Parsec.Prim (unexpected)
 import Text.Parsec.Language (emptyDef)
 import Data.Either
 import qualified Text.Parsec.Token as Token

 -- Abstract Syntax Tree ----------------------------------------------------------------------------------

 -- function/variable declaration
 data Decl = Fun String String Exp -- fun f x = e;
           | Val String Exp        -- val x = e;

 -- expressions
 data Exp = Lt Exp Exp     -- e1 < e2
         | Gt Exp Exp     -- e1 > e2
         | Eq Exp Exp     -- e1 = e2
         | Plus Exp Exp   -- e1 + e2
         | Minus Exp Exp  -- e1 - e2
         | Times Exp Exp  -- e1 * e2
         | Div Exp Exp    -- e1 div e2
         | Var String     -- x
         | If Exp Exp Exp -- if e0 then e1 else e2
         | Fn String Exp  -- fn x => e
         | Let [Decl] Exp -- let val x = e0; fun f = e1; in e2 end
         | App Exp Exp    -- e1 e2
         | Const Integer  -- n

 instance Show Decl where
   show (Fun f x e) = "fun " ++ f ++ " " ++ x ++ " = " ++ show e
   show (Val x e) = "val " ++ x ++ " = " ++ show e

 instance Show Exp where
   show (Const x) = show x
   show (Plus t1 t2) = showBop t1 "+" t2
   show (Times t1 t2) = showBop t1 "*" t2
   show (Minus t1 t2) = showBop t1 "-" t2
   show (Div t1 t2) = showBop t1 "/" t2
   show (Lt t1 t2) = showBop t1 "<" t2
   show (Gt t1 t2) = showBop t1 ">" t2
   show (Eq t1 t2) = showBop t1 "=" t2
   show (If t0 t1 t2) = "if " ++ show t0 ++ " then " ++ show t1 ++ " else " ++ show t2
   show (Var s) = s
   show (App t1 t2) = "(" ++ show t1 ++ " " ++ show t2 ++ ")"
   show (Fn x t) = "(fn " ++ x ++ " => " ++ show t ++ ")"
   show (Let decls e) = "(let " ++ show decls ++ " in " ++ show e ++ " end)"

 showBop t1 op t2 = "(" ++ show t1 ++ " " ++ op ++ " " ++ show t2 ++ ")"

 -- Parser definitions ----------------------------------------------------------------------------------

 type Parser = Parsec [Char] ()

 -- Runner

 -- print AST or error
 run :: Show a => Parser a -> String -> IO()
 run p input = putStrLn $ case parse p "" input of
       Left error -> show error
       Right x    -> show x

 -- return Either AST or parse error
 runParser :: Parser a -> String -> Either ParseError a
 runParser p input = parse p "" input

 -- Lexer

 lexeme p = do { x <- p; skipMany space <?> ""; return x }  -- get rid of trailing spaces

 symbol name = lexeme $ string name                         -- parse string and then remove spaces

 lexer :: Token.TokenParser ()
 lexer = Token.makeTokenParser style
   where style = emptyDef {
           Token.reservedOpNames = ["+","*","-","=", ">", "<", "in"],
           Token.reservedNames = ["let", "in", "end"]
           }

 parens :: Parser a -> Parser a
 parens = Token.parens lexer

 ident :: Parser String                                     -- raw identifier
 ident = (lexeme $ many1 letter) <?> "identifier"

 integer :: Parser Integer                                  -- parse integer and return numeric value
 integer = (read <$> (lexeme $ many1 digit)) <?> "integer"

 keyword :: String -> Parser ()                             -- make keyword parser with backtrack
 keyword name = (try $ symbol name) >> return ()

 if_ = keyword "if"                                         -- keyword parsers
 then_ = keyword "then"
 else_ = keyword "else"
 fn_ = keyword "fn"
 fun_ = keyword "fun"
 let_ = keyword "let"
 in_ = keyword "in"
 end_ = keyword "end"
 val_ = keyword "val"
 assign_ = keyword "="
 gt_ = keyword ">"
 lt_ = keyword "<"
 eq_ = keyword "="
 pl_ = keyword "+"
 mn_ = keyword "-"
 tm_ = keyword "*"
 dv_ = keyword "/"
 fatArrow_ = keyword "=>"
 sCol_ = keyword ";"

 identifier :: Parser String                                -- identifier that won't collide with keywords
 identifier = try $ do
     name <- ident
     if name `elem` reserved
       then unexpected ("reserved word " ++ name) -- throw parse error
       else return name
   where
     reserved = ["if", "then", "else", "fn", "fun", "let", "in", "end", "val"]

 -- Parser for the (phrase) grammar

 prog :: Parser [Decl]
 prog = skipMany space >> declList                              -- skip leading spaces

 declList :: Parser [Decl]                                      -- parse a list of function or variable declarations
 declList = many $ valDecl <|> funDecl

 funDecl :: Parser Decl
 funDecl = do
   fun_
   name <- identifier
   param <- identifier
   assign_
   t1 <- parseExpression
   return (Fun name param t1)

 valDecl :: Parser Decl
 valDecl = do
   val_
   name <- identifier
   assign_
   t1 <- parseExpression
   return (Val name t1)

 parseExpression :: Parser Exp
 parseExpression =  parseIf <|> parseLet <|> expr

 parseApp :: Parser Exp
 parseApp = ((factor `chainl1` (return App)) <?> "parseApp expr")

 expr = expr' `chainl1` compOp
 expr' = term `chainl1` addOp
 term    = parseApp `chainl1` mulOp
 factor  =  parseVar <|> parseInt <|> parseFn <|> parens expr

 compOp = do {gt_ ; return gtExpr}
         <|> do {lt_ ; return ltExpr}
         <|> do {eq_ ; return eqExpr}

 mulOp   =   do{ tm_ ; return tmExpr   }
         <|> do{ dv_ ; return dvExpr }

 addOp   =   do{ pl_ ; return plExpr }
         <|> do{ mn_ ; return mlExpr }

 gtExpr :: Exp -> Exp -> Exp
 gtExpr = Gt

 ltExpr :: Exp -> Exp -> Exp
 ltExpr = Lt

 eqExpr :: Exp -> Exp -> Exp
 eqExpr = Eq

 tmExpr :: Exp -> Exp -> Exp
 tmExpr = Times

 dvExpr :: Exp -> Exp -> Exp
 dvExpr = Div

 plExpr :: Exp -> Exp -> Exp
 plExpr = Plus

 mlExpr :: Exp -> Exp -> Exp
 mlExpr = Minus

 parseIf :: Parser Exp
 parseIf = do
   if_
   cond <- parseExpression
   then_
   true <- parseExpression
   else_
   false <- parseExpression
   return (If cond true false)

 parseFn :: Parser Exp
 parseFn = do
   fn_
   name <- identifier
   fatArrow_
   exp <- parseExpression
   return (Fn name exp)

 -- parseLet :: Parser Exp
 -- parseLet = do
 --   let_
 --   decl <- parseExpression
 --   in_
 --   exp <- parseExpression
 --   end_
 --   return (Let decl exp)

 parseVar :: Parser Exp
 parseVar = Var `fmap` identifier

 parseInt :: Parser Exp
 parseInt = Const `fmap` integer

 parseLet :: Parser Exp
 parseLet = do
   let_
   decls <- declList
   in_
   exp <- parseExpression
   end_
   return (Let decls exp)
 -- Test code ----------------------------------------------------------------------------------

--  main :: IO ()
--  main = do

--          let fact = "fun fact x = if x < 1 then 1 else x * fact (x-1)\n"
--          let it = "val it = let val y = 10 val z = 15 in fact y end"
--          let fnFn = "fun f x = fn z => y"

--          let d = (fact ++ it)
--          let test =  "val x = x * 5 / 5 - 5\n"
--          let test2 =  "fun fact x = 5\n"
--          let test3 = "if x > 1 then 1 else -1"
--          let test4 = "fun fact x = y"
--          let bla = (test ++ test2 ++ test3)
--          -- run prog bla
--          run prog d

 -- main = do
     -- Hw2
     -- let n = 2^5
     -- let s1 = map (\x -> sin(20*pi*x) + sin(40*pi*x)/2) $ range 0 1 n
     -- -- print $ split [1..64]
     -- -- print(rd 3 s1)
     -- start <- getCurrentTime
     -- let dft1 = map (\x -> x/n) $ absolute $ dft s1
     -- print(rd 2 dft1)
     -- end <- getCurrentTime
     -- print (diffUTCTime end start)
     -- start2 <- getCurrentTime
     -- let fft1 = map (\x -> x/n) $ absolute $ fft s1
     -- print(rd 2 fft1)
     -- end2 <- getCurrentTime
     -- print (diffUTCTime end2 start2)
     -- let v1 = Vec [1.0,2.0,3.0]
     -- let v2 = Vec [2,3,4]
     -- let v3 = Vec [-10,0,10]

     -- Hw3
     -- print $ v1 == v2
     -- print $ show v3
     -- print $ v1 + v2
     -- print $ v1 - v2
     -- print $ v1 * v2
     -- print $ v1 / v3
     -- print $ negate v1
     -- print $ signum v3
     -- print $ abs v3
     -- print $ foldr (*) 1 v1
     -- print $ sin $ v1 * (pi / 2)
     -- print $ v1 + (pure' $ sqrt 2)
     -- print $ realV v1
     -- print $ pure' 'a'

     -- let v1 = Vec [1.123,2.213,3.321]
     -- let v2 = Vec [2,3,4]
     -- let v3 = Vec [-10,0,10]
     -- print $ v1 + v2
     -- print $ v1 - v2
     -- print $ v1 * v2
     -- print $ v1 / v2
     -- print $ negate v1
     -- print $ signum v3
     -- print $ abs v3
     -- print $ v1 + 10
     -- print $ v2 + 1.2
     -- print $ v1 + (pure' $ sqrt 2)
     -- print $ realV v1
     -- print $ imagV v1
     -- print $ realV v1 + imagV v2
     -- print $ sin $ v1 * (pi / 2)
     -- print $ sum v1

     -- Hw4
     -- let n = fromIntegral 2^8
     -- let s1 = realV $ Vec $ fmap (\x -> sin(20*pi*x) + sin(40*pi*x)/2) $ range 0 1 n
     -- print $ fmap (\z -> conjugate z) s1
     -- print s1
     -- start <- getCurrentTime
     -- let dft1 = fmap (/n) $ absolute $ dft s1
     -- print(rd 2 dft1)
     -- let n = fromIntegral 2^8
     -- let s1 = fmap (\x -> sin(20*pi*x) + sin(40*pi*x)/2) $ Vec $ range 0 1 n
     -- print(rd 3 s1)
     -- print s1
     -- let dft1 = fmap (/n) $ absolute $ dft s1
     -- print(rd 2 dft1)
     -- print(rd 2 $ fmap (/n) $ absolute $ idft $ dft s1)
     -- print(rd 2 $ fmap (/n) $ absolute $ ifft $fft s1)

     -- end <- getCurrentTime
     -- print (diffUTCTime end start)
     -- start2 <- getCurrentTime
     -- let fft1 = fmap (/n) $ absolute $ fft s1
     -- print(rd 2 fft1)
     -- end2 <- getCurrentTime
     -- print (diffUTCTime end2 start2)

     -- let v1 = Vec [1,2,3]
     -- print $ v1 + v2
     -- print $ rd 2 v1
     -- let n = fromIntegral 2^8
     -- let s1 = fmap (\x -> sin(20*pi*x) + sin(40*pi*x)/2) $ Vec $ range 0 1 n
     -- print(rd 3 s1)
     -- print(rd 3 $ fmap (\(r:+_) -> r) $ low_pass' 15 $ realV s1)
     -- print(rd 3 $ fmap (\(r:+_) -> r) $ low_pass 15 $ realV s1)
     -- let a = [2,4,1,11,9]
     -- let b = [3,1,5,0,2]
     -- print $ maxList a
     -- print $ maxList' (<) a
     -- print $ rd 1 $ makeNoise 12345 10 0.0 1.0
     -- let n' = 2^8
     -- let noise = makeNoise 0 n' (-1.0) 1.0
     -- let n = fromIntegral n'
     -- let s = fmap (\x -> sin(20*pi*x) + sin(40*pi*x)/2) $ Vec $ range 0 1 n
     -- let s1 = s + noise
     -- -- noisy signal
     -- print(rd 2 s1)
     -- -- noisy frequency
     -- print (rd 2 $ fmap (/n) $ absolute $ dft $ realV s1)
     -- -- filtered signal (dft)
     -- print (rd 3 $ fmap (\(r:+_) -> r) $ low_pass' 15 $ realV s1)
     -- -- filtered signal (fft)
     -- print (rd 2 $ fmap (\(r:+_) -> r) $ low_pass 15 $ realV s1)


module P18b where
import Data.Complex (magnitude)
import Data.Char (isNumber)
import Data.Maybe (fromMaybe)
import Data.List (tails)
import Data.Tuple (swap)

data SnailNumber = RegularNumber Int | NumberPair SnailNumber SnailNumber deriving (Eq, Show)

run :: String -> Int
run = maximum . map (snailMagnitude . snailSum) . pairs . parse

parse :: String -> [SnailNumber]
parse = map (fst . parseNumber) . lines

parseNumber :: String -> (SnailNumber, String)
parseNumber ('[':xs) =
    let (left, ',':xs') = parseNumber xs
        (right, xs'') = parseNumber xs'
    in (NumberPair left right, tail xs'')
parseNumber xs =
    let (n, xs') = span isNumber xs
    in (RegularNumber (read n), xs')

snailSum :: (SnailNumber, SnailNumber) -> SnailNumber
snailSum (a, b) = snailAdd a b

snailAdd :: SnailNumber -> SnailNumber -> SnailNumber
snailAdd a b = snailReduce (snailAdd' a b)

snailAdd' :: SnailNumber -> SnailNumber -> SnailNumber
snailAdd' = NumberPair

snailReduce :: SnailNumber -> SnailNumber
snailReduce x =
    let x' = snailReduce' x
    in if x == x' then x' else snailReduce x'

snailReduce' :: SnailNumber -> SnailNumber
snailReduce' x =
    let x' = explode x
    in fromMaybe x' (split x')

explode :: SnailNumber -> SnailNumber
explode x =
    let (x', _, _) = explode' 0 x
    in x'

explode' :: Int -> SnailNumber -> (SnailNumber, Int, Int)
explode' 4 (NumberPair (RegularNumber left) (RegularNumber right)) = (RegularNumber 0, left, right)
explode' depth (NumberPair left right) =
    let (left', expLeft1, expRight1) = explode' (depth+1) left
        (right', expLeft2, expRight2) = explode' (depth+1) (incrementLeft right expRight1)
        left'' = incrementRight left' expLeft2
    in  (NumberPair left'' right', expLeft1, expRight2)
explode' _ x = (x, 0, 0)

incrementLeft :: SnailNumber -> Int -> SnailNumber
incrementLeft (RegularNumber x) a = RegularNumber (x+a)
incrementLeft (NumberPair left right) x = NumberPair (incrementLeft left x) right

incrementRight :: SnailNumber -> Int -> SnailNumber
incrementRight (RegularNumber x) a = RegularNumber (x+a)
incrementRight (NumberPair left right) x = NumberPair left (incrementRight right x)

split :: SnailNumber -> Maybe SnailNumber
split n@(RegularNumber x) = if x > 9 then Just (NumberPair (RegularNumber x') (RegularNumber (x - x'))) else Nothing
    where x' = x `div` 2
split (NumberPair left right) =
    case split left of
        Just left' -> Just (NumberPair left' right)
        Nothing -> case split right of
            Just right' -> Just (NumberPair left right')
            Nothing -> Nothing

snailMagnitude :: SnailNumber -> Int
snailMagnitude (RegularNumber x) = x
snailMagnitude (NumberPair left right) = 3*snailMagnitude left + 2*snailMagnitude right

pairs :: [a] -> [(a, a)]
pairs xs =
    let ps = concatMap (\xs' -> map (\x -> (head xs', x)) (tail xs')) $ filter (not . null) (tails xs)
    in ps ++ map swap ps


{-# LANGUAGE Strict, StrictData #-}
{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DefaultSignatures #-}

------------------------------------------------
-- |
-- Module    :  Numeric.Algebra.Presentation
-- Copyright :  (c) Jun Yoshida 2019
-- License   :  BSD3
--
-- Matrix presentations of morphisms
--
------------------------------------------------

module Numeric.Algebra.Presentation where

import GHC.Generics (Generic)
import Control.DeepSeq (NFData, force)

import Control.Monad
import Control.Monad.ST

import Data.Foldable

import qualified Numeric.LinearAlgebra as LA
import qualified Numeric.LinearAlgebra.Devel as LA

import Numeric.Algebra.FreeModule
import Numeric.Matrix.Integral
import Numeric.F2 (F2)
import qualified Numeric.Matrix.F2 as F2
import qualified Numeric.Matrix.F2.Mutable as F2

---------------
-- * Classes
---------------
-- | Class which provides matrix presentations for homomorphisms with coefficients in a.
class (Eq a, Num a, NFData a, Semigroup (Mat a), NFData (Vec a), NFData (Mat a)) => Coefficient a where
  type Vec a = v | v -> a
  -- ^ The type of vectors with coefficients in a.
  type Mat a = m | m -> a
  -- ^ The type of matrices with coefficients in a.
  ident :: Int -> Mat a
  -- ^ Presentation of the identity of the given rank.
  present :: (Integral a', NFData a', Ord c, NFData c) => (b->FreeMod a' c) -> [b] -> [c] -> Mat a
  -- ^ Present a linear map in a matrix form with respect to a given bases
  vecToList :: Vec a -> [a]
  -- ^ Vec a is convertible to a list.
  rankVec :: Vec a -> Int
  -- ^ The rank of the module where the given vector lies.
  rankDom :: Mat a -> Int
  -- ^ The rank of the domain of the given matrix.
  rankCod :: Mat a -> Int
  -- ^ The rank of the codomain of the given matrix.
  fromVecs :: (Foldable t) => t (Vec a) -> Mat a
  -- ^ Give a matrix whose image is spanned by given vectors.
  -- Typically, it is the matrix with given vectors as columns.
  toVecs :: Mat a -> [Vec a]
  -- ^ Give a set of vectors which span the image of the matrix.
  -- Typically, it is the set of column vectors.
  -- ^ The scalar matrix of the given size.
  (@|>) :: Mat a -> Vec a -> Vec a
  -- ^ Multiplication of matrices and vectors.
  scale :: a -> Vec a -> Vec a
  -- ^ Scalar multiplication on vectors.
  scalar :: Int -> a -> Mat a
  -- ^ Scalar * identity matrix.
  -- | Default implementations
  ident n = scalar n 1
  rankVec = length . vecToList
  (@|>) x = head . toVecs . (x<>) . fromVecs . (:[])
  scale x v = scalar (rankVec v) x @|> v
  scalar n x = fromVecs (map (scale x) (toVecs (ident n)))

-- | Matrix presentations with normal forms.
class (Coefficient a, NFData (NormalForm a)) => Normalized a where
  data NormalForm a
  -- ^ The type of normal forms.
  fromNF :: NormalForm a -> Mat a
  -- ^ Convert into a matrix form.
  -- >> let xnf = toNF x
  -- Then
  -- >> x <> basisDom xnf == basisCod xnf <> fromNF xnf
  basisDom :: NormalForm a -> Mat a
  -- ^ The basis matrix on the domain.
  -- It should be invertible.
  basisCod :: NormalForm a -> Mat a
  -- ^ The basis matrix on the codomain.
  -- It should be invertible.
  toNF :: Mat a -> NormalForm a
  -- ^ Compute the normal form.
  invariants :: NormalForm a -> [a]
  -- ^ Each normal form should contain the data of "invariant factors;" e.g. those for Smith normal forms of matrices with coefficients in a PID.

------------------------------------------------
-- * Instances in terms of LA.Z using hmatrix
------------------------------------------------
instance Coefficient (LA.Z) where
  type Vec LA.Z = LA.Vector LA.Z
  type Mat LA.Z = LA.Matrix LA.Z
  ident = LA.ident
  present f dom cod
    = let domRk = length dom
          codRk = length cod
      in runST $ do
    stMat <- LA.newUndefinedMatrix LA.RowMajor codRk domRk
    forM_ [0..domRk-1] $ \j -> do
      let !vals = force $ f (dom !!j)
      forM_ [0..codRk-1] $ \i -> do
        let coeff = getCoeff (cod !! i) vals
        LA.unsafeWriteMatrix stMat i j (fromIntegral coeff)
    LA.unsafeFreezeMatrix stMat
  vecToList = LA.toList
  rankVec = LA.size
  rankDom = LA.cols
  rankCod = LA.rows
  fromVecs = LA.fromColumns . toList
  toVecs = LA.toColumns
  (@|>) = (LA.#>)
  scale = LA.scale

instance Normalized (LA.Z) where
  -- | Presentation in Smith normal forms.
  data NormalForm LA.Z = SmithNF {
    _invFactor :: LA.Vector LA.Z, -- Invariant factor
    _basisS :: LA.Matrix LA.Z,    -- basis for source
    _basisT :: LA.Matrix LA.Z     -- basis for target
    } deriving (Show, Generic, NFData)
  fromNF (SmithNF invs bss bts)
    = runST $ do
    stMat <- LA.newMatrix 0 (LA.cols bts) (LA.cols bss)
    forM_ [0..(LA.size invs)-1] $ \i ->
      LA.writeMatrix stMat i i  (invs `LA.atIndex` i)
    LA.unsafeFreezeMatrix stMat
  basisDom = _basisS
  basisCod = _basisT
  toNF x
    = let (u,s,v) = smithRep x
      in SmithNF (LA.takeDiag s) v u
  invariants = LA.toList . _invFactor

---------------------------------
-- * Instances in terms of F2
---------------------------------
instance Coefficient F2 where
  type Vec F2 = F2.VectorF2
  type Mat F2 = F2.MatrixF2
  ident = F2.ident
  present f dom cod
    = let domRk = length dom
          codRk = length cod
      in runST $ do
    stMat <- F2.unsafeNewMatrixF2 codRk domRk
    forM_ [0..domRk-1] $ \j -> do
      let !vals = force $ f (dom !!j)
      forM_ [0..codRk-1] $ \i -> do
        let coeff = getCoeff (cod !! i) vals
        F2.unsafeWriteMatrixF2 stMat i j (fromIntegral coeff :: F2)
    F2.unsafeFreezeMatrixF2 stMat
  vecToList = F2.toList
  rankVec = F2.sizeF2
  rankDom = F2.cols
  rankCod = F2.rows
  fromVecs = F2.fromColumns . toList
  toVecs = F2.toColumns
  scalar = F2.scalar

instance Normalized F2 where
  data NormalForm F2 =
    DiagNF {-# UNPACK #-} !Int {-# UNPACK #-} !F2.MatrixF2 {-# UNPACK #-} !F2.MatrixF2
    deriving (Show, Generic,NFData)
  invariants (DiagNF rk _ _) = replicate rk 1
  basisDom (DiagNF _ bss _) = bss
  basisCod (DiagNF _ _ bst) = bst
  fromNF (DiagNF rk bss bst) = F2.diagRectL (rankCod bst) (rankCod bss) (repeat 1 :: [Int])
  toNF x
    = let (u,rk,v) = F2.diagRep x
      in DiagNF rk v u


{-# LANGUAGE NoMonomorphismRestriction #-}
import Numeric.LinearAlgebra
import Linear.V1
import Linear.V2
import Linear.V3
import Linear.Quaternion
import Linear.Matrix
import Vectorization
import Space
import Kalman

-- Aided Inertial Navigation -- Example 5.4

pe0 = (V2 (V2 100 0) (V2 0 100))
xe0 = V2 0 0
se0 = (xe0,pe0)

he0 (V2 x _) = V1 x
he1 (V2 _ y) = V1 y
he2 (V2 x y) = V1 (x*0.7 + 0.3*y)
he3 (V2 x y) = V1 (x*0.5 + y*0.5)

m0 = (he0,re0,ye0)
m1 = (he1,re1,ye1)
m2 = (he2,re2,ye2)
m3 = (he3,re3,ye3)

mlist = [m0,m1,m2,m3]

re0 = V1 1
re1 = V1 1
re2 = V1 1
re3 = V1 1

ye0 = V1 10.24
ye1 = V1 21.20
ye2 = V1 13.91
ye3 = V1 14.84

measure' (h,r,y) = measure h r y
sef = foldr measure' se0 mlist

se1 = measure he0 re0 ye0 se0
se2 = measure he1 re1 ye1 se1
se3 = measure he2 re2 ye2 se2
se4 = measure he3 re3 ye3 se3


{-# LANGUAGE DataKinds #-}

module Matrix
  ( Matrix4
  , Vector3
  , vec3
  , perspective
  , identity
  , withFloatMatrix
  , translate
  , projection
  , normalize
  , xHat
  , yHat
  , zHat
  , cross
  , vector3ToFloatList
  , unwrap
  ) where

import           Data.Maybe
import           Foreign.C.Types
import           Foreign.Ptr
import qualified Numeric.LinearAlgebra        as L
import qualified Numeric.LinearAlgebra.Devel  as D
import           Numeric.LinearAlgebra.Static

type Matrix4 = L 4 4

type Vector3 = R 3

xHat = vec3 1 0 0

yHat = vec3 0 1 0

zHat = vec3 0 0 1

--type Matrix4 = Matrix4 Double
perspective :: Double -> Double -> Double -> Double -> Matrix4
perspective near far fov aspect = build gen
  where
    gen i j =
      case (i, j) of
        (0, 0) -> 1.0 / (aspect * tan (fov / 2.0))
        (1, 1) -> 1.0 / tan (fov / 2.0)
        (2, 2) -> -(far + near) / (far - near)
        (2, 3) -> -2.0 * far * near / (far - near)
        (3, 2) -> -1.0
        _      -> 0.0

identity :: Matrix4
identity = eye

translate :: Vector3 -> Matrix4
translate v = t ||| col (v & 1.0)
  where
    (t, _) = splitCols eye

projection :: Double -> Matrix4
projection = perspective 0.1 10000.0 (pi / 4.0)

withFloatMatrix ::
     Matrix4 -> (D.MatrixOrder -> CInt -> CInt -> Ptr Float -> IO r) -> IO r
withFloatMatrix m f = D.applyRaw singleM id (f (D.orderOf singleM))
  where
    singleM = L.single $ unwrap m

withFloatVector :: Vector3 -> (CInt -> Ptr Float -> IO r) -> IO r
withFloatVector m = D.applyRaw singleV id
  where
    singleV = L.single $ unwrap m

--normalize :: Vector3 -> Vector3
normalize v = realToFrac a * v
  where
    a = 1.0 / norm_2 v

vector3ToFloatList :: Vector3 -> [Float]
vector3ToFloatList = L.toList . L.single . unwrap


{-# LANGUAGE DataKinds
           , GADTs
           , KindSignatures
           , OverloadedLists
           , ScopedTypeVariables
           , TypeApplications #-}

module MorphGine.Data.Primitives where

import qualified Data.Vector.Storable  as VS
import qualified Numeric.LinearAlgebra as L
import           Numeric.LinearAlgebra ((><))
import qualified Numeric.LinearAlgebra.Data as DL --(flatten, reshape,cmap)
import           GHC.Ptr (Ptr(..))
import           GHC.TypeLits
import qualified Graphics.Rendering.OpenGL.GL as GL
import           Graphics.Rendering.OpenGL.GL (($=))
import qualified Graphics.GL as GLRaw
import           Graphics.GL (GLfloat)

data Matrix :: * -> Nat -> Nat -> * where
  M :: VS.Storable a => L.Matrix a -> Matrix a m n

withPtr :: (VS.Storable a, L.Element a) => Matrix a m n -> (Ptr a -> IO b) -> IO b
withPtr (M x) = VS.unsafeWith . L.flatten $ x

projection :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Matrix GLfloat 4 4
projection fov aspect near far = M . (4><4) $ [ t/aspect, 0, 0, 0
                                               , 0,        t, 0, 0
                                               , 0,        0, (far+near)/(near-far), (2*far*near)/(near-far)
                                               , 0,        0,-1, 0]
  where t = 1 / tan (fov/2)

degProjection :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> Matrix  GLfloat 4 4
degProjection = projection . (/180) . (*pi)