{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE Trustworthy #-}

{- |
Module      :  Data.Complex.Cyclotomic
Copyright   :  (c) Scott N. Walck 2012-2017
License     :  GPL-3 (see LICENSE)
Maintainer  :  Scott N. Walck <walck@lvc.edu>
Stability   :  experimental

The cyclotomic numbers are a subset of the complex numbers with
the following properties:

     1.  The cyclotomic numbers are represented exactly, enabling exact
     computations and equality comparisons.

     2.  The cyclotomic numbers contain the Gaussian rationals
     (complex numbers of the form 'p' + 'q' 'i' with 'p' and 'q' rational).
     As a consequence, the cyclotomic numbers are a dense subset of the
     complex numbers.

     3.  The cyclotomic numbers contain the square roots of all rational numbers.

     4.  The cyclotomic numbers form a field:  they are closed under addition, subtraction,
     multiplication, and division.

     5.  The cyclotomic numbers contain the sine and cosine of all rational
     multiples of pi.

     6.  The cyclotomic numbers can be thought of as the rational field extended
     with 'n'th roots of unity for arbitrarily large integers 'n'.

     Floating point numbers do not do well with equality comparison:

>(sqrt 2 + sqrt 3)^2 == 5 + 2 * sqrt 6
> -> False

     "Data.Complex.Cyclotomic" represents these numbers exactly, allowing equality comparison:

>(sqrtRat 2 + sqrtRat 3)^2 == 5 + 2 * sqrtRat 6
> -> True

     'Cyclotomic's can be exported as inexact complex numbers using the 'toComplex' function:

>e 6
> -> -e(3)^2
>real $ e 6
> -> 1/2
>imag $ e 6
> -> -1/2*e(12)^7 + 1/2*e(12)^11
>imag (e 6) == sqrtRat 3 / 2
> -> True
>toComplex $ e 6
> -> 0.5000000000000003 :+ 0.8660254037844384

     The algorithms for cyclotomic numbers are adapted from code by
     Martin Schoenert and Thomas Breuer in the GAP project <http://www.gap-system.org/>
     (in particular source files gap4r4\/src\/cyclotom.c and
     gap4r4\/lib\/cyclotom.gi).
-}

module Data.Complex.Cyclotomic
    ( Cyclotomic(..)
    , i
    , e
    , sqrtInteger
    , sqrtRat
    , sinDeg
    , cosDeg
    , sinRev
    , cosRev
    , gaussianRat
    , polarRat
    , polarRatDeg
    , polarRatRev
    , conj
    , real
    , imag
    , isReal
    , isRat
    , isGaussianRat
    , toComplex
    , toReal
    , toRat
    , goldenRatio
    , dft
    , dftInv
    , rootsQuadEq
    , heron
    )
    where

import Data.List
    ( nub
    )
import Data.Ratio
    ( (%)
    , numerator
    , denominator
    )
import Data.Complex
    ( Complex(..)
    , realPart
    )
import qualified Data.Map as M
    ( Map
    , empty
    , singleton
    , lookup
    , keys
    , elems
    , size
    , fromList
    , toList
    , mapKeys
    , filter
    , insertWith
    , delete
    , map
    , unionWith
    , findWithDefault
    , fromListWith
    )
import Math.NumberTheory.Primes.Factorisation
    ( factorise
    )

-- | A cyclotomic number.
data Cyclotomic = Cyclotomic { order  :: Integer
                             , coeffs :: M.Map Integer Rational
                             } deriving (Eq)

-- | @abs@ and @signum@ are partial functions.
--   A cyclotomic number is not guaranteed to have a cyclotomic absolute value.
--   When defined, @signum c@ is the complex number with magnitude 1 that has the same argument as c;
--   @signum c = c / abs c@.
instance Num Cyclotomic where
    (+) = sumCyc
    (*) = prodCyc
    (-) c1 c2 = sumCyc c1 (aInvCyc c2)
    negate = aInvCyc
    abs = absVal
    signum = sigNum
    fromInteger 0 = zeroCyc
    fromInteger n = Cyclotomic 1 (M.singleton 0 (fromIntegral n))

instance Fractional Cyclotomic where
    recip = invCyc
    fromRational 0 = zeroCyc
    fromRational r = Cyclotomic 1 (M.singleton 0 r)

-- | The primitive @n@th root of unity.
--   For example, @'e'(4) = 'i'@ is the primitive 4th root of unity,
--   and 'e'(5) = exp(2*pi*i/5) is the primitive 5th root of unity.
--   In general, 'e' 'n' = exp(2*pi*i/'n').
e :: Integer -> Cyclotomic
e n
    | n < 1      = error "e requires a positive integer"
    | n == 1     = Cyclotomic 1 (M.singleton 0 1)
    | otherwise  = cyclotomic n $ convertToBase n (M.singleton 1 1)

instance Show Cyclotomic where
    show (Cyclotomic n mp)
        | mp == M.empty  = "0"
        | otherwise      = leadingTerm rat n ex ++ followingTerms n xs
        where ((ex,rat):xs) = M.toList mp

showBaseExp :: Integer -> Integer -> String
showBaseExp n 1  = "e(" ++ show n ++ ")"
showBaseExp n ex = "e(" ++ show n ++ ")^" ++ show ex

leadingTerm :: Rational -> Integer -> Integer -> String
leadingTerm r _ 0 = showRat r
leadingTerm r n ex
    | r == 1     = t
    | r == (-1)  = '-' : t
    | r > 0      = showRat r ++ "*" ++ t
    | r < 0      = "-" ++ showRat (abs r) ++ "*" ++ t
    | otherwise  = ""
    where t = showBaseExp n ex

followingTerms :: Integer -> [(Integer,Rational)] -> String
followingTerms _ [] = ""
followingTerms n ((ex,rat):xs) = followingTerm rat n ex ++ followingTerms n xs

followingTerm :: Rational -> Integer -> Integer -> String
followingTerm r n ex
    | r == 1     = " + " ++ t
    | r == (-1)  = " - " ++ t
    | r > 0      = " + " ++ showRat r ++ "*" ++ t
    | r < 0      = " - " ++ showRat (abs r) ++ "*" ++ t
    | otherwise  = ""
    where t = showBaseExp n ex

showRat :: Rational -> String
showRat r
    | d == 1     = show n
    | otherwise  = show n ++ "/" ++ show d
    where
      n = numerator r
      d = denominator r

-- GAP function EB from gap4r4/lib/cyclotom.gi
eb :: Integer -> Cyclotomic
eb n
    | n < 1           = error "eb needs a positive integer"
    | n `mod` 2 /= 1  = error "eb needs an odd integer"
    | n == 1          = zeroCyc
    | otherwise       = let en = e n
                        in sum [en^(k*k `mod` n) | k <- [1..(n-1) `div` 2]]

sqrt2 :: Cyclotomic
sqrt2 = e 8 - e 8 ^ (3 :: Int)

-- | The square root of an 'Integer'.
sqrtInteger :: Integer -> Cyclotomic
sqrtInteger n
    | n == 0     = zeroCyc
    | n < 0      = i * sqrtPositiveInteger (-n)
    | otherwise  = sqrtPositiveInteger n

sqrtPositiveInteger :: Integer -> Cyclotomic
sqrtPositiveInteger n
    | n < 1      = error "sqrtPositiveInteger needs a positive integer"
    | otherwise  = let factors = factorise n
                       factor = product [p^(m `div` 2) | (p,m) <- factors]
                       nn     = product [p^(m `mod` 2) | (p,m) <- factors]
                   in case nn `mod` 4 of
                        1 -> fromInteger factor * (2 * eb nn + 1)
                        2 -> fromInteger factor * sqrt2 * sqrtPositiveInteger (nn `div` 2)
                        3 -> fromInteger factor * (-i) * (2 * eb nn + 1)
                        _ -> fromInteger factor * 2 * sqrtPositiveInteger (nn `div` 4)

-- | The square root of a 'Rational' number.
sqrtRat :: Rational -> Cyclotomic
sqrtRat r = prodRatCyc (1 % fromInteger den) (sqrtInteger (numerator r * den))
    where
      den = denominator r

-- | The square root of -1.
i :: Cyclotomic
i = e 4

-- | Make a Gaussian rational; @gaussianRat p q@ is the same as @p + q * i@.
gaussianRat :: Rational -> Rational -> Cyclotomic
gaussianRat p q = fromRational p + fromRational q * i

-- | A complex number in polar form, with rational magnitude @r@ and rational angle @s@
--   of the form @r * exp(2*pi*i*s)@; @polarRat r s@ is the same as @r * e q ^ p@,
--   where @s = p/q@.  This function is the same as 'polarRatRev'.
polarRat :: Rational    -- ^ magnitude
         -> Rational    -- ^ angle, in revolutions
         -> Cyclotomic  -- ^ cyclotomic number
polarRat r s
    = let p = numerator s
          q = denominator s
      in case p >= 0 of
           True  -> fromRational r * e q ^ p
           False -> conj $ fromRational r * e q ^ (-p)

-- | A complex number in polar form, with rational magnitude and rational angle
--   in degrees.
polarRatDeg :: Rational    -- ^ magnitude
            -> Rational    -- ^ angle, in degrees
            -> Cyclotomic  -- ^ cyclotomic number
polarRatDeg r deg
    = let s = deg / 360
          p = numerator s
          q = denominator s
      in case p >= 0 of
           True  -> fromRational r * e q ^ p
           False -> conj $ fromRational r * e q ^ (-p)

-- | A complex number in polar form, with rational magnitude and rational angle
--   in revolutions.
polarRatRev :: Rational    -- ^ magnitude
            -> Rational    -- ^ angle, in revolutions
            -> Cyclotomic  -- ^ cyclotomic number
polarRatRev r s
    = let p = numerator s
          q = denominator s
      in case p >= 0 of
           True  -> fromRational r * e q ^ p
           False -> conj $ fromRational r * e q ^ (-p)

-- | Complex conjugate.
conj :: Cyclotomic -> Cyclotomic
conj (Cyclotomic n mp)
    = mkCyclotomic n (M.mapKeys (\k -> (n-k) `mod` n) mp)

-- | Real part of the cyclotomic number.
real :: Cyclotomic -> Cyclotomic
real z = (z + conj z) / 2

-- | Imaginary part of the cyclotomic number.
imag :: Cyclotomic -> Cyclotomic
imag z = (z - conj z) / (2*i)

absVal :: Cyclotomic -> Cyclotomic
absVal c = let modsq = c * conj c
           in case toRat modsq of
                Just msq -> sqrtRat msq
                Nothing  -> error "abs not available for this number"

sigNum :: Cyclotomic -> Cyclotomic
sigNum 0 = zeroCyc
sigNum c = let modsq = c * conj c
           in if isRat modsq then c / absVal c
              else error "signum not available for this number"

convertToBase :: Integer -> M.Map Integer Rational -> M.Map Integer Rational
convertToBase n mp = foldr (\(p,r) m -> replace n p r m) mp (extraneousPowers n)

removeZeros :: M.Map Integer Rational -> M.Map Integer Rational
removeZeros = M.filter (/= 0)

-- Corresponds to GAP implementation.
-- Expects that convertToBase has already been done.
cyclotomic :: Integer -> M.Map Integer Rational -> Cyclotomic
cyclotomic ord = tryReduce . tryRational . gcdReduce . Cyclotomic ord

mkCyclotomic :: Integer -> M.Map Integer Rational -> Cyclotomic
mkCyclotomic ord = cyclotomic ord . removeZeros . convertToBase ord

-- | Step 1 of cyclotomic is gcd reduction.
gcdReduce :: Cyclotomic -> Cyclotomic
gcdReduce cyc@(Cyclotomic n mp) = case gcdCyc cyc of
                                    1 -> cyc
                                    d -> Cyclotomic (n `div` d) (M.mapKeys (`div` d) mp)

gcdCyc :: Cyclotomic -> Integer
gcdCyc (Cyclotomic n mp) = gcdList (n:M.keys mp)

-- | Step 2 of cyclotomic is reduction to a rational if possible.
tryRational :: Cyclotomic -> Cyclotomic
tryRational c
    | lenCyc c == fromIntegral phi && sqfree
        = case equalCoefficients c of
            Nothing -> c
            Just r  -> fromRational $ (-1)^(nrp `mod` 2)*r
    | otherwise
        = c
    where
      (phi,nrp,sqfree) = phiNrpSqfree (order c)

-- | Compute phi(n), the number of prime factors, and test if n is square-free.
--   We do these all together for efficiency, so we only call factorise once.
phiNrpSqfree :: Integer -> (Integer,Int,Bool)
phiNrpSqfree n = (phi,nrp,sqfree)
    where
      factors = factorise n
      phi = foldr (\p n' -> n' `div` p * (p-1)) n [p | (p,_) <- factors]
      nrp = length factors
      sqfree = all (<=1) [m | (_,m) <- factors]

equalCoefficients :: Cyclotomic -> Maybe Rational
equalCoefficients (Cyclotomic _ mp)
    = case ts of
        []    -> Nothing
        (x:_) -> if equal ts then Just x else Nothing
      where
        ts = M.elems mp

lenCyc :: Cyclotomic -> Int
lenCyc (Cyclotomic _ mp) = M.size $ removeZeros mp

-- | Step 3 of cyclotomic is base reduction
tryReduce :: Cyclotomic -> Cyclotomic
tryReduce c
    = foldr reduceByPrime c squareFreeOddFactors
      where
        squareFreeOddFactors = [p | (p,m) <- factorise (order c), p > 2, m <= 1]

reduceByPrime :: Integer -> Cyclotomic -> Cyclotomic
reduceByPrime p c@(Cyclotomic n _)
    = case mapM (\r -> equalReplacements p r c) [0,p..n-p] of
        Just cfs -> Cyclotomic (n `div` p) $ removeZeros $ M.fromList $ zip [0..(n `div` p)-1] (map negate cfs)
        Nothing  -> c

equalReplacements :: Integer -> Integer -> Cyclotomic -> Maybe Rational
equalReplacements p r (Cyclotomic n mp)
    =  case [M.findWithDefault 0 k mp | k <- replacements n p r] of
         [] -> error "equalReplacements generated empty list"
         (x:xs) | equal (x:xs) -> Just x
         _ -> Nothing

replacements :: Integer -> Integer -> Integer -> [Integer]
replacements n p r = takeWhile (>= 0) [r-s,r-2*s..] ++ takeWhile (< n) [r+s,r+2*s..]
    where s = n `div` p

replace :: Integer -> Integer -> Integer -> M.Map Integer Rational -> M.Map Integer Rational
replace n p r mp = case M.lookup r mp of
                     Nothing  -> mp
                     Just rat -> foldr (\k m -> M.insertWith (+) k (-rat) m) (M.delete r mp) (replacements n p r)

includeMods :: Integer -> Integer -> Integer -> [Integer]
includeMods n q start = [start] ++ takeWhile (>= 0) [start-q,start-2*q..] ++ takeWhile (< n) [start+q,start+2*q..]

removeExps :: Integer -> Integer -> Integer -> [Integer]
removeExps n 2 q = concatMap (includeMods n q) $ map ((n `div` q) *) [q `div` 2..q-1]
removeExps n p q = concatMap (includeMods n q) $ map ((n `div` q) *) [-m..m]
    where m = (q `div` p - 1) `div` 2

pqPairs :: Integer -> [(Integer,Integer)]
pqPairs n = map (\(p,k) -> (p,p^k)) (factorise n)

extraneousPowers :: Integer -> [(Integer,Integer)]
extraneousPowers n
    | n < 1      = error "extraneousPowers needs a postive integer"
    | otherwise  = nub $ concat [[(p,r) | r <- removeExps n p q] | (p,q) <- pqPairs n]

-- | Sum of two cyclotomic numbers.
sumCyc :: Cyclotomic -> Cyclotomic -> Cyclotomic
sumCyc (Cyclotomic o1 map1) (Cyclotomic o2 map2)
    = let ord = lcm o1 o2
          m1 = ord `div` o1
          m2 = ord `div` o2
          map1' = M.mapKeys (m1*) map1
          map2' = M.mapKeys (m2*) map2
      in mkCyclotomic ord $ M.unionWith (+) map1' map2'

-- | Product of two cyclotomic numbers.
prodCyc :: Cyclotomic -> Cyclotomic -> Cyclotomic
prodCyc (Cyclotomic o1 map1) (Cyclotomic o2 map2)
    = let ord = lcm o1 o2
          m1 = ord `div` o1
          m2 = ord `div` o2
      in mkCyclotomic ord $ M.fromListWith (+)
             [((m1*e1+m2*e2) `mod` ord,c1*c2) | (e1,c1) <- M.toList map1, (e2,c2) <- M.toList map2]

-- | Product of a rational number and a cyclotomic number.
prodRatCyc :: Rational -> Cyclotomic -> Cyclotomic
prodRatCyc 0 _                   = zeroCyc
prodRatCyc r (Cyclotomic ord mp) = Cyclotomic ord $ M.map (r*) mp

-- | Additive identity.
zeroCyc :: Cyclotomic
zeroCyc = Cyclotomic 1 M.empty

-- | Additive inverse.
aInvCyc :: Cyclotomic -> Cyclotomic
aInvCyc = prodRatCyc (-1)

multiplyExponents :: Integer -> Cyclotomic -> Cyclotomic
multiplyExponents j (Cyclotomic n mp)
    | gcd j n /= 1  = error "multiplyExponents needs gcd == 1"
    | otherwise     = mkCyclotomic n (M.mapKeys (\k -> j*k `mod` n) mp)

productOfGaloisConjugates :: Cyclotomic -> Cyclotomic
productOfGaloisConjugates c
    = product [multiplyExponents j c | j <- [2..ord], gcd j ord == 1]
      where
        ord = order c

-- | Multiplicative inverse.
invCyc :: Cyclotomic -> Cyclotomic
invCyc z = case toRat (z * prod) of
             Just r  -> prodRatCyc (1 / r) prod
             Nothing -> error "invCyc:  product of Galois conjugates not rational; this is a bug, please inform package maintainer"
    where
      prod = productOfGaloisConjugates z

-- | Is the cyclotomic a real number?
isReal :: Cyclotomic -> Bool
isReal c = c == conj c

-- | Is the cyclotomic a rational?
isRat :: Cyclotomic -> Bool
isRat (Cyclotomic 1 _) = True
isRat _                = False

-- | Is the cyclotomic a Gaussian rational?
isGaussianRat :: Cyclotomic -> Bool
isGaussianRat c = isRat (real c) && isRat (imag c)

-- | Original implementation of toComplex
origToComplex :: RealFloat a => Cyclotomic -> Complex a
origToComplex c = sum [fromRational r * en^p | (p,r) <- M.toList (coeffs c)]
    where en = exp (0 :+ 2*pi/n)
          n = fromIntegral (order c)

-- | Export as an inexact complex number.
-- This function avoids some error that origToComplex introduces.
toComplex :: RealFloat a => Cyclotomic -> Complex a
toComplex x = re :+ im
  where
    Just re = fromRational . toRational <$> (toReal (real x) :: Maybe Double)
    Just im = fromRational . toRational <$> (toReal (imag x) :: Maybe Double)

-- | Export as an inexact real number if possible.
toReal :: RealFloat a => Cyclotomic -> Maybe a
toReal c
    | isReal c   = Just $ realPart (origToComplex c)
    | otherwise  = Nothing

-- | Return an exact rational number if possible.
toRat :: Cyclotomic -> Maybe Rational
toRat (Cyclotomic 1 mp)
    | mp == M.empty  = Just 0
    | otherwise      = M.lookup 0 mp
toRat _ = Nothing

-- | Sine function with argument in degrees.
sinDeg :: Rational -> Cyclotomic
sinDeg d = let n = d / 360
               nm = abs (numerator n)
               dn = denominator n
               a = e dn^nm
           in fromRational(signum d) * (a - conj a) / (2*i)

-- | Cosine function with argument in degrees.
cosDeg :: Rational -> Cyclotomic
cosDeg d = let n = d / 360
               nm = abs (numerator n)
               dn = denominator n
               a = e dn^nm
           in (a + conj a) / 2

-- | Sine function with argument in revolutions.
sinRev :: Rational -> Cyclotomic
sinRev n = let nm = abs (numerator n)
               dn = denominator n
               a = e dn^nm
           in fromRational(signum n) * (a - conj a) / (2*i)

-- | Cosine function with argument in revolutions.
cosRev :: Rational -> Cyclotomic
cosRev n = let nm = abs (numerator n)
               dn = denominator n
               a = e dn^nm
           in (a + conj a) / 2

gcdList :: [Integer] -> Integer
gcdList [] = error "gcdList called on empty list"
gcdList (n:ns) = foldr gcd n ns

equal :: Eq a => [a] -> Bool
equal [] = True
equal [_] = True
equal (x:y:ys) = x == y && equal (y:ys)

-- | The golden ratio, @(1 + √5)/2@.
goldenRatio :: Cyclotomic
goldenRatio = (1 + sqrtRat 5) / 2

-- | Discrete Fourier transform,
--   @X_k = \sum_{n=0}^{N-1} x_n \cdot e^{-i 2 \pi \frac{k}{N} n}@.
dft :: [Cyclotomic] -> [Cyclotomic]
dft cs = [sum $ zipWith (*) [conj (e m^(k*n)) | n <- [0..]] cs | k <- [0..m-1]]
          where m = fromIntegral $ length cs

-- | Inverse discrete Fourier transform,
--   @x_n = \frac{1}{N} \sum_{k=0}^{N-1} X_k \cdot e^{i 2 \pi \frac{k}{N} n}@.
dftInv :: [Cyclotomic] -> [Cyclotomic]
dftInv cs = [minv * sum (zipWith (*) [e m^(k*n) | n <- [0..]] cs) | k <- [0..m-1]]
          where m = fromIntegral $ length cs
                minv = fromRational (1 % m)

-- | Solutions to the quadratic equation
--   a x^2 + b x + c = 0.
--   Returns 'Nothing' if a == 0.
rootsQuadEq :: Rational  -- ^ a
            -> Rational  -- ^ b
            -> Rational  -- ^ c
            -> Maybe (Cyclotomic,Cyclotomic)  -- ^ roots
rootsQuadEq a b c
    | a == 0     = Nothing
    | otherwise  = Just ((-bb + sqrtDisc)/(2*aa),(-bb - sqrtDisc)/(2*aa))
    where
      aa = fromRational a
      bb = fromRational b
      sqrtDisc = sqrtRat (b*b - 4*a*c)

-- | Heron's formula for the area of a triangle with
--   side lengths a, b, c.
heron :: Rational    -- ^ a
      -> Rational    -- ^ b
      -> Rational    -- ^ c
      -> Cyclotomic  -- ^ area of triangle
heron a b c
    = sqrtRat (s * (s-a) * (s-b) * (s-c))
      where
        s = (a + b + c) / 2


{-# LANGUAGE FlexibleContexts #-}

module Taylor where

import Data.Complex

-- also this is a vector space
data Taylor a = Integ a (Taylor a)

instance Show a => Show (Taylor a) where
  show = show . take 10 . toList

toList (Integ x xs) = x:toList xs

zero = Integ 0 zero

instance Num a => Num (Taylor a) where
  (a `Integ` as) + (b `Integ` bs)  =  (a + b)  `Integ`  (as + bs)
  (a `Integ` as) * (b `Integ` bs) = (a*b) `Integ`  (as * (b `Integ` bs) + (a `Integ` as) * bs)
  fromInteger x = integ (fromInteger x) 0
  negate (a `Integ` as) = negate a `Integ` negate as

constant :: Num a => a -> Taylor a
constant x = integ x 0

integ :: a -> Taylor a -> Taylor a
integ = Integ

sinx :: Taylor Integer
sinx = integ 0 cosx

cosx :: Taylor Integer
cosx = integ 1 (-sinx)

expx :: Taylor (Complex Double)
expx = integ 1 expx

-- expkx :: Taylor Double -> Taylor Double
-- expkx k = integ 1 (k*expx)

varx :: Taylor (Complex Double)
varx = integ 0 1

(*^) :: Num t => t -> Taylor t -> Taylor t
a *^ (Integ k ks) = Integ (a * k) (a *^ ks)

evalPart :: Fractional p => [p] -> p -> p -> p
evalPart [] _ _  = 0
evalPart (k:ks) n y = k + evalPart (((y/n) *) <$> ks) (n+1) y

eval :: Fractional p => Taylor p -> Int -> p -> p
eval t n x = evalPart (take n $ toList t) 1 x

-- f . g
-- integ ((f . g) 0) (D (f . g))
-- integ (f (g 0)) (D f . g * g')

compose :: (Eq a, Num a) => Taylor a -> Taylor a -> Taylor a
compose (Integ f0 f') g@(Integ g0 g') = Integ fg0 ((f' `compose` g) * g')
  where
    -- fg0 is the evaluation of f at point g0. (An infinite sum in the general case, but...)
    fg0 = if g0 == 0 then f0 else error "fg0: computation diverges"

-- >>> varx
-- [0,1,0,0,0,0,0,0,0,0]

-- >>> 3 * varx
-- [0.0,3.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0,0.0]

-- >>> expx `compose` ((constant (0 :+ 1) * varx))
-- [1.0 :+ 0.0,
--  0.0 :+ 1.0,
--  (-1.0) :+ 0.0,
--  0.0 :+ (-1.0),
--  1.0 :+ 0.0,
--  0.0 :+ 1.0,
--  (-1.0) :+ 0.0,
--  0.0 :+ (-1.0),
--  1.0 :+ 0.0,
--  0.0 :+ 1.0]


module Main where
import Plot
import Graphics.GD
import Data.Complex

imageDim :: Size
imageDim = (600,600)

-- How many iterations before  we declare the point doesn't diverge
maxIter = 96

-- How close successive tests must be before we declare they have converged
minDiff = 0.0001

-- formula to iterate
f z = 3 * z^4 - 1
-- derivative
f' z = 12 * ( z^3)

-- Coordinates in the complex plane to graph
-- First coordinate must be top left.
mbWindow :: Window
mbWindow = ( (-2.0, 2.0), (2.0, -2.0) ) -- Full view

main :: IO ()
main = drawPlot drawNewton imageDim mbWindow "newtons-method.png"

drawNewton :: Coordinate -> Color
drawNewton (x,y) = colorIterations $ newton (x :+ y) 0

-- Count number of iterations for the given point to diverge
-- Non-diverging points return 0
newton :: Complex Double -- Coordinate to test
       -> Int -- Current iteration
       -> Int -- Iterations before diverging
newton z iter
    | iter > maxIter = 0
    | ( abs $ magnitude r - magnitude z) > minDiff = newton r (iter + 1)
    | otherwise = iter
    where r = z - f z / f' z

colorIterations :: Int -> Color
colorIterations x
    | x > maxIter = rgb 255 255 255
    | otherwise = rgb (x^2) x (x*3)


-- | Module for operating on vectors and matrices. It includes some functions
-- for using bra-ket notation.
module DiracLists where

import Data.Complex
import Data.List (transpose)

-- This can be used to hide the standard operators.
-- import Prelude hiding ((+))
-- import qualified Prelude

-- | Function 'ket' provides basic functionality for producing vectors from the
-- canonical basis. Vectors and matrices are represented as lists and are stored
-- in column-order (as in Mathematica). Operations on vectors and matrices have
-- to be defined using new operators.
ket :: Int -> Int -> [Complex Double]
ket d i = (take i zeros) ++ [1] ++ (take (d-1-i) zeros)
  where zeros = replicate (d-1) 0

-- | The 'norm' function calculates the Euclidean norm of a vector.
norm :: [Complex Double] -> Double
norm a = sqrt $ realPart $ sum [ x^2 | x<-a ]

-- | The 'proj' function builds d-dimensional operator |i><j|.
proj :: Int -> Int -> Int -> [Complex Double]
proj d i j = outerWith (*) (ket d i) (ket d j)

-- | The 'outer' defines the form of outer product resulting in paris of elements.
outer :: [a] -> [b] -> [(a,b)]
outer a b = [ (x,y) | x<-a, y<-b ]

-- | General form of the outer product resulting in paris of elements.
outerWith :: (a -> b -> c) -> [a] -> [b] -> [c]
outerWith f a b = [ f x y | x<-a, y<-b ]

-- | Kronecker product is defined in terms of the outer product.
kron ::  Num a => [a] -> [a] -> [a]
kron a b = outerWith (*) a b

-- | Function 'overlap' for calculating the inner product of two vectors. In
-- Dirac notation this is represented as <v|w>.
overlap :: Num a => [a] -> [a] -> a
overlap vec1 vec2 = sum $ zipWith (*) vec1 vec2

-- | The scalar product is defined to be consistent with the other operators. It
-- is identical with the 'overlap' function and it suppose to resemble the
-- braket.
(<>) :: [Complex Double] -> [Complex Double] -> Complex Double
(<>) = overlap

-- | Definition of the vector addition for two complex vectors. The standard '+'
-- operator does not work, and it is not a good idead to hide it.
(+>) :: [Complex Double] -> [Complex Double] -> [Complex Double]
(+>) = zipWith (+)

-- | The multiplication of a vector by a scalar.
(.*) :: Complex Double -> [Complex Double] -> [Complex Double]
(.*) c v = [ c*x | x<-v ]

-- | Matrix-vector multiplication.
(#>) :: [[Complex Double]] -> [Complex Double] -> [Complex Double]
(#>) m v = [ overlap w v | w<-tm ]
  where tm = transpose m


module Hw3
    (Vec(..),
    pure',
    realV,
    imagV ) where

import Data.Complex

-- {-# LANGUAGE FlexibleInstances #-}
-- {-# LANGUAGE UndecidableInstances #-}
-- {-# LANGUAGE RebindableSyntax #-}
-- TODO:
-- Show
-- Num: +, -, *, negate, abs, sigsum, fromInteger
-- Fractional: /, fromRational
-- Floating: pi, exp, log, sin, cos, asin, acos, atan, sinh, cosh, asinh, acosh, atanh
-- Foldable: foldr
-- pure
-- realV
-- imagV

data Vec a = Vec [a]

instance Show a => Show (Vec a) where
    show (Vec a) = "[" ++ show' a ++ "]"

show' :: Show a => [a] -> [Char]
show' [] = ""
show' [x] = show x
show' (x:xs) = show x ++ " " ++ show' xs

instance Num a => Num (Vec a) where
    fromInteger x = Vec $ repeat $ fromInteger x
    (+) (Vec a) (Vec b) = Vec (zipWith (+) a b)
    (-) (Vec a) (Vec b) = Vec (zipWith (-) a b)
    (*) (Vec a) (Vec b) = Vec (zipWith (*) a b)
    negate (Vec a) = Vec (map (\x -> x * (-1)) a)
    abs (Vec a) = Vec (map abs a)
    signum (Vec a) = Vec (map signum a)

instance Fractional a => Fractional (Vec a) where
    (/) (Vec a) (Vec b) = Vec (zipWith (/) a b)
    fromRational x = Vec $ repeat $ fromRational x

instance Floating a => Floating (Vec a) where
    exp (Vec a) = Vec (map exp a)
    log (Vec a) = Vec (map log a)
    sin (Vec a) = Vec (map sin a)
    cos (Vec a) = Vec (map cos a)
    asin (Vec a) = Vec (map asin a)
    acos (Vec a) = Vec (map acos a)
    atan (Vec a) = Vec (map atan a)
    sinh (Vec a) = Vec (map sinh a)
    cosh (Vec a) = Vec (map cosh a)
    asinh (Vec a) = Vec (map asinh a)
    acosh (Vec a) = Vec (map acosh a)
    atanh (Vec a) = Vec (map atanh a)
    pi = Vec $ repeat pi

instance Foldable Vec where
    foldr f x (Vec a) = foldr f x a

pure' x = Vec $ repeat x
realV :: Num a => Vec a -> Vec (Complex a)
imagV :: Num a => Vec a -> Vec (Complex a)
realV (Vec a) = Vec(map (:+ 0) a)
imagV (Vec a) = Vec(map (0:+) a)


module Section_2_3_3 where

import Numeric.LinearAlgebra

and' :: Double -> Double -> Double
and' x1 x2 =
  let x = vector [x1, x2]
      w = vector [0.5, 0.5]
      b = (-0.7)
      tmp = w <.> x + b
   in if tmp <= 0
         then 0
         else 1

nand :: Double -> Double -> Double
nand x1 x2 =
  let x = vector [x1, x2]
      w = vector [(-0.5), (-0.5)]
      b = 0.7
      tmp = w <.> x + b
   in if tmp <= 0
         then 0
         else 1

or' :: Double -> Double -> Double
or' x1 x2 =
  let x = vector [x1, x2]
      w = vector [0.5, 0.5]
      b = (-0.2)
      tmp = w <.> x + b
   in if tmp <= 0
         then 0
         else 1


{-|
Module: MachineLearning.LeastSquaresModel
Description: Least Squares Model
Copyright: (c) Alexander Ignatyev, 2016
License: BSD-3
Stability: experimental
Portability: POSIX

-}

module MachineLearning.LeastSquaresModel
(
  LeastSquaresModel(..)
)

where

import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra((<>), (#>), (<.>))
import qualified Numeric.LinearAlgebra.Data as LAD
import qualified Data.Vector.Storable as V

import qualified MachineLearning.Regularization as R

import MachineLearning.Model

data LeastSquaresModel = LeastSquares

instance Model LeastSquaresModel where
  hypothesis LeastSquares x theta = x #> theta

  cost LeastSquares lambda x y theta =
    let m = x #> theta - y
        nExamples = fromIntegral $ LA.rows x
        regTerm = R.costReg lambda theta
    in (LA.sumElements (m * m) * 0.5 + regTerm) / nExamples

  gradient LeastSquares lambda x y theta = ((LA.tr x) #> (x #> theta - y) + regTerm) / nExamples
    where nExamples = fromIntegral $ LAD.rows x
          regTerm = R.gradientReg lambda theta


module FEECa.Utility.Quadrature where

import Math.Combinatorics.Exact.Factorial
import Numeric.LinearAlgebra.HMatrix
-- import Numeric.LinearAlgebra.Data
import FEECa.Utility.Utility (pairM)

-- | Type synomnym to represent a quadrature as a list pairs
-- | of nodes and corresponding weights, the first element being the node
-- | and the second the weight.
type Quadrature = [(Double, Double)]

-- | Type synomym for the coefficients a_i, b_i, c_i of the recurrence relation of
-- | a given est of orthogonal polynomials.
type Coeff a = (Int -> a)

-- | Compute the Gauss-Jacobi quadrature of degree n and parameters alpha = a
-- | and beta = b.
gaussJacobiQuadrature :: Int -> Int -> Int -> Quadrature
gaussJacobiQuadrature = golubWelsch

-- | Compute the Gauss-Jacobi quadrature of degree n and parameters alpha = a
-- | and beta = b shifted and scaled to the interval [0,1].
gaussJacobiQuadrature' :: Int -> Int -> Int -> Quadrature
gaussJacobiQuadrature' alpha beta n = transform (gaussJacobiQuadrature alpha beta n)
    where transform = map (pairM scale1 id)
          scale1 x = 0.5 + x/2
          -- scale2 y = y

-- | Compute the Gauss-Legendre quadrature of degree n.
gaussLegendreQuadrature :: Int -> Quadrature
gaussLegendreQuadrature = golubWelsch 0 0

-- | Golub-Welsch algorithm as described in "Calculation of Gauss Quadrature
-- | Rules" (Golub, Welsch).
golubWelsch :: Int -> Int -> Int -> Quadrature
golubWelsch alpha beta n = extract $ eigSH' (buildMatrix n a b c)
    where a = a_jac alpha beta
          b = b_jac alpha beta
          c = c_jac alpha beta
          extract (v, m) = zip (toList v)
                               (square (toList (head (toRows m))))
          square  = map (** 2)
          -- TODO: why is scale defined but not used?
          -- normalize l = map ((2 / sum l) *) l
          -- alpha' = fromIntegral alpha
          -- scale = map ((2.0**(1.0+ alpha') / (1 + alpha')) *)

gamma :: Int -> Int -> Double
gamma a b = fromInteger (2^(a + b + 1) * factorial a * factorial b) /
            fromInteger (factorial (a + b + 1))

-- Build the tridiagonal matrix used in the Golub-Welsch algorithm.
buildMatrix :: Int -> Coeff Double -> Coeff Double -> Coeff Double -> Matrix Double
buildMatrix n a b c = (n >< n) $ concat [ p1 i ++ [p2 i] ++ p3 i | i <- [1..n] ]
    where p1 i = replicate (i - 2) 0 ++ f1 i
          p2 i = - (b i / a i)
          p3 i = f2 i ++ replicate (n - i - 1) 0
          f1 i = [ beta (i-1) | i > 1 ]
          f2 i = [ beta  i    | i < n ]
          beta i = sqrt (c (i + 1) / (a i * a (i+1)))

-- | Evaluate an orthogonal Polynomial using the coefficient functions describing
-- | its recurrence relation.
orthogonalPolynomial :: Int -> Int -> Int -> Double -> Double
orthogonalPolynomial n alpha beta x
    | n == 0     = 1.0
    | n > 0      = orthogonalPolynomial' n 1 alpha beta x 1.0 0.0
    | otherwise  = error $ "orthogonalPolynomial: n = " ++ show n ++ " < 0"

-- Iterative implementation of the recursion relations for orthogonal polynomials.
-- See article by Golub and Welsch.
orthogonalPolynomial' ::
  Int -> Int -> Int -> Int ->
  Double -> Double -> Double -> Double
orthogonalPolynomial' n i alpha beta x pi1 pi2
    | n == i     = p_i
    | otherwise  = orthogonalPolynomial' n (i+1) alpha beta x p_i pi1
    where  p_i  = (a i * x + b i) * pi1 - c i * pi2
           a    = a_jac alpha beta
           b    = b_jac alpha beta
           c    = c_jac alpha beta

-- a_i coefficient for Jacobi polynomials as defined in the paper by
-- Golub and Welsch.
a_jac :: Int -> Int -> Coeff Double
a_jac alpha beta i
    | (2*i + alpha + beta) <= 2 = 1
    | otherwise = i2ab * (i2ab - 1) * (i2ab -2) / den_jac alpha beta i
  where i2ab = fromIntegral (2 * i + alpha + beta)

-- b_i coefficient for Jacobi polynomials as defined in the paper by
-- Golub and Welsch.
b_jac :: Int -> Int -> Coeff Double
b_jac alpha beta i
    | (2*i + alpha + beta) <= 2 = 0
    | otherwise = (2*i' + a' + b' - 1) * (a'*a' - b'*b') / den_jac alpha beta i
  where a' = fromIntegral alpha
        b' = fromIntegral beta
        i' = fromIntegral i

-- c_i coefficient for Jacobi polynomials as defined in the paper by
-- Golub and Welsch.
c_jac :: Int -> Int -> Coeff Double
c_jac alpha beta i
    | (2*i + alpha + beta) <= 2 = 0
    | otherwise = 2 * (i' + a' - 1) * (i' + b' - 1) * (2*i' + a' + b') /
                  den_jac alpha beta i
  where a' = fromIntegral alpha
        b' = fromIntegral beta
        i' = fromIntegral i

-- Common denominator for the coefficient functions of the recurrence relation
-- for the Jacobi integrals.
den_jac :: Int -> Int -> Int -> Double
den_jac alpha beta i =
    fromIntegral (2*i * (i + alpha + beta) * (2*i + alpha + beta - 2))

-- | Evaluate Jacobi Polynomial.
jacobiP :: Int -> Int -> Int -> Double -> Double
jacobiP alpha beta n = orthogonalPolynomial n alpha beta

-- | Evaluate Legendre polynomial of degree n at x.
legendreP :: Int -> Double -> Double
legendreP n = orthogonalPolynomial n 0 0


import Numeric.LinearAlgebra
import Test.Hspec

import Lib
    ( forwardPropogate,
      sigmoid,
      weightsWithInitializer,
      runBatch,
      updateParameters,
      getLayer,
      ActivationFunction (..),
      Activation (..),
      Parameters,
      Gradients,
      Layer (..)
    )

main :: IO ()
main = hspec $ do
  describe "Lib.forwardPropogate" $ do
    it "correctly performs forward propogation" $ do
      let
        activationFunction = ActivationFunction { f=flip (/) 100, f'= \_ -> 1/100 }
        input    = (1><3) [1..]
        layers   = [
                    Layer{layerParameters=((3><4) [1..], fromList [1,1,1,1]),activationFunction=activationFunction},
                    Layer{layerParameters=((4><2) [1..], fromList [2,2]),activationFunction=activationFunction}
                   ]
        expected = [input, (1><4) [0.39,0.45,0.51,0.57], (1><2) [10.28 / 100, 12.2 / 100]] :: [Matrix Double]
        activations = forwardPropogate input layers
      map postActivation activations `shouldBe` expected
  describe "Lib.runBatch" $ do
    it "correctly backpropogates" $ do
      let
        input = (1><1) [1] :: Matrix Double
        expected = (1><1) [1]
        initialWeights = weightsWithInitializer 0.05 [1,1,1]
        initialBiases = map fromList [[0.05], [0.05]] :: [Vector Double]
        zippedInitialParameters = zip initialWeights initialBiases
        activationFunctions = [sigmoid,sigmoid]
        layers = zipWith getLayer zippedInitialParameters activationFunctions
        expectedGradients = [((1><1) [ -1.4970312464482186e-3 ], fromList [-1.4970312464482186e-3]),((1><1) [ -6.303013286946654e-2 ], fromList [-0.12006215555353811])]
        actualGradients = runBatch input expected layers
      actualGradients `shouldBe` expectedGradients
    describe "Lib.updateParameters" $ do
      it "correctly updates parameters" $ do
        let
          learningRate = 0.1
          regularizationTerm = 0.01
          parameters = [((1><2) [1,2], fromList [1,1])] :: [Parameters]
          gradients = [((1><2) [1,1], fromList [1,1])] :: [Gradients]
          expectedUpdatedParameters = [((1><2) [0.899, 1.899], fromList [0.9,0.9])] :: [Parameters]
          actualUpdatedParameters = updateParameters learningRate regularizationTerm gradients parameters
        actualUpdatedParameters `shouldBe` expectedUpdatedParameters


module Ch03.Matrix where

import Prelude hiding (and, or)
import Numeric.LinearAlgebra

import Control.Exception

-- Matrix
as :: Matrix R
as = matrix 4 [1,2,3,4]
--  (1><4)
-- [ 1.0, 2.0, 3.0, 4.0 ]

as' :: Vector R
as' = vector [1,2,3,4]
-- [1.0,2.0,3.0,4.0]

bs :: Matrix R
bs = (3><2) [1..6]
-- (3><2)
--  [ 1.0, 2.0
--  , 3.0, 4.0
--  , 5.0, 6.0 ]

-- Dimensions
ndim  :: Matrix t -> Int
ndim     = rows

shape :: Matrix t -> (Int, Int)
shape xs = (rows xs, cols xs)

t1 = assert (shape as == (1,4)) "OK"
t2 = assert (shape bs == (3,2)) "OK"

-- Inner Product
as1 :: Matrix R
as1 = (2><2) [1..4]
bs1 :: Matrix R
bs1 = (2><2) [5..8]

as1bs1 :: Matrix R
as1bs1 = as1 <> bs1
-- (2><2)
--  [ 19.0, 22.0
--  , 43.0, 50.0 ]

as2 :: Matrix R
as2 = (2><3) [1..6]
bs2 :: Matrix R
bs2 = (3><2) [1..6]

as2bs2 :: Matrix R
as2bs2 = as2 <> bs2
-- (2><2)
--  [ 22.0, 28.0
--  , 49.0, 64.0 ]

c :: Matrix R
c = (2><2) [1..4]

-- Inconsistent Dimensions
as2c :: Matrix R
as2c = as2 <> c
-- *** Exception: inconsistent dimensions in matrix product (2,3) x (2,2)
-- CallStack (from HasCallStack):
--   error, called at src/Internal/LAPACK.hs:56:31 in hmatrix-0.17.0.2-HoBfYSJ1dMG9PoVkmbcnW2:Internal.LAPACK


module Numeric.Fourier
    ( fft
    , ifft

    -- * Testing
    , prop_fourier
    )
  where

import Data.Complex ( cis, realPart, Complex )
import Data.Vector.Unboxed ( Unbox, Vector, (!) )

import qualified Data.Vector.Unboxed as V

{-----------------------------------------------------------------------------
    Fast Fourier transformation
------------------------------------------------------------------------------}
-- | Compute the discrete Fourier transform (DFT) of a vector
-- using a fast Fourier transform (FFT) algorithm.
--
-- The discrete Fourier transform is defined as
--
-- > (fft xs) ! k = sum [ exp(- j*k * 2*pi*i/n) * (xs ! j) | j <- [0..(n-1)] ]
-- >   where n = length xs
--
-- Let $n$ be the length of the input vector.
-- The algorithm recursively divides this vector into parts of equal lengths.
-- Consequently, the running time is $O(n \log n)$ if $n$ is a power of two.
-- However, the running time will degrade to $O(n^2)$
-- if $n$ contains prime factors other than $2$.
fft :: Vector (Complex Double) -> Vector (Complex Double)
fft xs
    | n <= 1    = xs
    | even n    = fftStep xs
    | otherwise = dftSlow xs
  where
    n = V.length xs

-- | Perform an fft step on a vector of even, nonzero length.
--
-- TODO: Perform more operations in-place.
fftStep :: Vector (Complex Double) -> Vector (Complex Double)
fftStep xs =
        V.izipWith (\k ev od -> ev + xi k * od) dftL dftR
    <>  V.izipWith (\k ev od -> ev - xi k * od) dftL dftR
  where
    n  = V.length xs
    n2 = n `div` 2

    -- exp(- 2πi·k (2j+1)/n) = exp(- 2πi k/n) * exp(- 2πi·kj/(2n))
    xi k = cis (- 2*pi* fromIntegral k/fromIntegral n)

    xsEven = V.generate n2 $ \j -> xs ! (2*j)
    xsOdd  = V.generate n2 $ \j -> xs ! (2*j+1)

    dftL = fft xsEven
    dftR = fft xsOdd

-- | Inverse of the discrete fourier transform.
--
-- Implemented using 'fft'.
ifft :: Vector (Complex Double) -> Vector (Complex Double)
ifft xs = V.generate n $ \k ->
    (if k == 0 then ys ! 0 else ys ! (n-k)) / fromIntegral n
  where
    ys = fft xs
    n = V.length xs

{-----------------------------------------------------------------------------
    Testing
------------------------------------------------------------------------------}
-- | Definition of the discrete Fourier transform (DFT).
-- Slow, for testing only.
dftSlow :: Vector (Complex Double) -> Vector (Complex Double)
dftSlow xs = V.generate n $ \k ->
    V.sum $ V.imap (\j x -> cis (- 2*pi * double (k*j) / double n) * x) xs
  where
    double = fromIntegral
    n = V.length xs

-- | Test whether the 'fft' function really is a Fourier transform,
-- i.e. gives the same result as 'dftSlow'.
prop_fourier :: Vector (Complex Double) -> Bool
prop_fourier xs = fft xs `approx` dftSlow xs
  where
    dist xs ys = realPart $ V.sum $ V.zipWith (\x y -> abs (x-y)) xs ys
    approx xs ys = dist xs ys / dist xs (V.map (const 0) ys) < eps
    eps = 1e-15


-- ex5_01.hs

import Statistics.Distribution
import Statistics.Distribution.DiscreteUniform

y1, y2 :: DiscreteUniform
y1 = discreteUniform 3
y2 = discreteUniform 3

ss = [(i,j)
     | i <- [1..3], j <- [1..3]
     ]

ps = [(probability y1 i)*(probability y1 j)
     | i <- [1..3], j <- [1..3]
     ]

main = do
  putStrLn $ "The sample space is: " ++ show ss
  putStrLn $ "The corresponding probabilities: " ++ show ps
  putStrLn $ "sum ps = " ++ show (sum ps)


module CORDICSpec where

import qualified Clash.Prelude as Clash
import Clash.Prelude (Signal, Vec(..), BitVector, Index, Signed, Unsigned, SFixed, Bit, SNat(..),
                      simulate, simulate_lazy, listToVecTH, KnownNat, pack, unpack, (++#), mealy, mux, bundle, unbundle,
                      HiddenClockResetEnable, sample, System)
import Test.Hspec
import Test.QuickCheck hiding (sample)

import qualified Data.Complex as C
import Clash.DSP.CORDIC

approxEqual :: Double -> Double -> Bool
approxEqual x y = abs (x - y) < 0.0001

--CORDIC testing
spec = describe "CORDIC" $ do
    specify "vector mode"    $ property prop_CORDICVectorMode
    specify "rotation mode " $ property prop_CORDICRotationMode
    specify "pipelined "     $ property prop_CORDICPipelined

consts :: Vec 100 (SFixed 32 32)
consts = $(listToVecTH (Prelude.take 100 arctans))

--Test CORDIC vector mode by calculating the magnitude and phase of a complex number
prop_CORDICVectorMode =
    forAll (choose (0, 500000000)) $ \(x :: Double) -> --Restrict the input ranges so that the error does not grow beyond what approxEqual considers acceptable
        forAll (choose (0, 500000000)) $ \(y :: Double) ->
            let res     = doIt $ CordicState (fromRational (toRational x) :+ fromRational (toRational y)) 0
                cplxNum = x C.:+ y
            in     approxEqual (kValue 100 * realToFrac (realPart (cplx res))) (C.magnitude cplxNum)
                && approxEqual (realToFrac (arg res)) (C.phase cplxNum)
    where

    doIt :: CordicState (SFixed 32 32) (SFixed 32 32) -> CordicState (SFixed 32 32) (SFixed 32 32)
    doIt = cordicSteps (\(CordicState (_ :+ y) _) -> y < 0) (0 :: Index 100) consts

--Test CORDIC rotation mode by calculating the real and imaginary part of a complex number given in polar form
prop_CORDICRotationMode =
    forAll (choose (0, 5000)) $ \(x :: Double) ->  --Restrict the input ranges so that the error does not grow beyond what approxEqual considers acceptable
        forAll (choose (0, 0.75)) $ \(y :: Double) ->
            let res     = doIt $ CordicState (fromRational (toRational x) :+ 0) (fromRational (toRational y))
            in     approxEqual (kValue 100 * realToFrac (realPart (cplx res))) (x * Prelude.cos y)
                && approxEqual (kValue 100 * realToFrac (imagPart (cplx res))) (x * Prelude.sin y)
    where

    doIt :: CordicState (SFixed 32 32) (SFixed 32 32) -> CordicState (SFixed 32 32) (SFixed 32 32)
    doIt = cordicSteps (\(CordicState _ a) -> a > 0) (0 :: Index 100) consts

--Test CORDIC vector mode by calculating the magnitude and phase of a complex number
prop_CORDICPipelined =
    forAll (choose (0, 500000000)) $ \(x :: Double) -> --Restrict the input ranges so that the error does not grow beyond what approxEqual considers acceptable
        forAll (choose (0, 500000000)) $ \(y :: Double) ->
            let res     = doIt $ CordicState (fromRational (toRational x) :+ fromRational (toRational y)) 0
                cplxNum = x C.:+ y
            in     approxEqual (kValue 100 * realToFrac (realPart (cplx res))) (C.magnitude cplxNum)
                && approxEqual (realToFrac (arg res)) (C.phase cplxNum)
    where

    doIt :: CordicState (SFixed 32 32) (SFixed 32 32) -> CordicState (SFixed 32 32) (SFixed 32 32)
    doIt input
        = last
        $ take 12
        $ sample @System
        $ cordicPipeline (\(CordicState (_ :+ y) _) -> y < 0) (0 :: Index 100) (Clash.unconcat (SNat @ 10) consts) (pure True)
        $ pure input


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

Regularization.
-}

module MachineLearning.NeuralNetwork.Regularization
(
  Regularization(..)
  , forwardReg
  , backwardReg
)

where

import MachineLearning.Types (R, Matrix)
import qualified Numeric.LinearAlgebra as LA
import MachineLearning.Regularization (Regularization(..))

-- | Calcaulates regularization for forward propagation.
-- It takes regularization parameter and theta list.
forwardReg :: Regularization -> [(Matrix, Matrix)] -> R
forwardReg RegNone _ = 0
forwardReg (L2 lambda) thetaList = 0.5 * lambda * (sum $ map LA.norm_2 $ snd $ unzip thetaList)

-- | Calculates regularization for step of backward propagation.
-- It takes regularization parameter and theta.
backwardReg :: Regularization -> Matrix -> Matrix
backwardReg RegNone _ = 0
backwardReg (L2 lambda) w = w * (LA.scalar lambda)


import Data.Array.CArray
import Data.Complex
import Data.List (intercalate, transpose)
import Math.FFT (dft, idft)

type Vector = CArray Int (Complex Double)

(.*), (.+) :: Vector -> Vector -> Vector
a .* b = liftArray2 (*) a b
a .+ b = liftArray2 (+) a b

normalize :: Double -> Vector -> Vector
normalize dx v =
  let factor = 1 / sqrt dx / norm2 v :+ 0
   in liftArray (factor *) v

data Parameters = Parameters
  { xmax :: Double
  , res :: Int
  , dt :: Double
  , timesteps :: Int
  , dx :: Double
  , x :: Vector
  , dk :: Double
  , ks :: Vector
  , imTime :: Bool
  }

defaultParameters :: Parameters
defaultParameters = makeParameters 10 512 0.01 1000 True

makeParameters :: Double -> Int -> Double -> Int -> Bool -> Parameters
makeParameters xmax res dt timesteps imTime =
  let fi = fromIntegral
      rng = (0, res - 1)
      ks = [0 .. div res 2 - 1] ++ [-div res 2 .. -1]
   in Parameters
        xmax
        res
        dt
        timesteps
        (2 * xmax / fi res)
        (listArray rng $
         map (\n -> xmax * (-1 + 2 * fi n / fi res) :+ 0) [1 .. res])
        (pi / xmax)
        (listArray rng $ map ((:+ 0) . (pi / xmax *) . fi) ks)
        imTime

data Operators = Operators
  { v :: Vector
  , rStep :: Vector
  , kStep :: Vector
  , wfc :: Vector
  }

makeOperators :: Parameters -> Complex Double -> Complex Double -> Operators
makeOperators param v0 wfc0 =
  let rng = (0, res param - 1)
      time
        | imTime param = dt param :+ 0
        | otherwise = 0 :+ dt param
      v = liftArray (\x -> 0.5 * (x - v0) ^ 2) (x param)
      rStep = liftArray (\x -> exp (-0.5 * time * x)) v
      kStep = liftArray (\k -> exp (-0.5 * time * k ^ 2)) (ks param)
      wfc = liftArray (\x -> exp (-(x - wfc0) ^ 2 / 2)) (x param)
   in Operators v rStep kStep (normalize (dx param) wfc)

evolve :: Parameters -> Operators -> [Operators]
evolve param op@(Operators _ rStep kStep _) = iterate splitop op
  where
    splitop op = op {wfc = wfc' op}
    wfc' = norm . (rStep .*) . idft . (kStep .*) . dft . (rStep .*) . wfc
    norm = if imTime param then normalize (dx param) else id

calculateEnergy :: Parameters -> Operators -> Double
calculateEnergy param ops = (* dx param) . sum . map realPart $ elems totalE
  where
    totalE = potentialE .+ kineticE
    potentialE = wfcConj .* v ops .* wfc ops
    kineticOp = liftArray ((/ 2) . (^ 2)) (ks param)
    kineticE = wfcConj .* idft (kineticOp .* dft (wfc ops))
    wfcConj = liftArray conjugate $ wfc ops

-- Use gnuplot to make an animated  GIF using ../gnuplot/plot_output.plt
-- $ gnuplot -e "folder='../haskell'" plot_output.plt
printEvolution :: Parameters -> [Operators] -> IO ()
printEvolution param =
  mapM_ (export . (format <$>)) . zip [0 ..] . take 100 . skip
  where
    skip (x:xs) = x : skip (drop (div (timesteps param) 100 - 1) xs)
    format (Operators v _ _ wfc) =
      let density = liftArray ((^ 2) . abs) wfc
          values = map (map (show . realPart) . elems) [x param, density, v]
       in intercalate "\n" $ map (intercalate "\t") $ transpose values
    export (i, f) = writeFile ("output" ++ pad (show i) ++ ".dat") f
    pad n = replicate (5 - length n) '0' ++ n

main :: IO ()
main = do
  let p = defaultParameters
      o = makeOperators p 0 4
      evol = evolve p o
  print $ calculateEnergy p (evol !! timesteps p)
  printEvolution p evol


import Data.Complex (cis, phase)

meanAngle
  :: RealFloat c
  => [c] -> c
meanAngle = (/ pi) . (* 180) . phase . sum . map (cis . (/ 180) . (* pi))

main :: IO ()
main =
  mapM_
    (\angles ->
        putStrLn $
        "The mean angle of " ++
        show angles ++ " is: " ++ show (meanAngle angles) ++ " degrees")
    [[350, 10], [90, 180, 270, 360], [10, 20, 30]]


module Main where

import qualified Numeric.LinearAlgebra as LA
import qualified MachineLearning.Types as T
import qualified MachineLearning as ML
import qualified MachineLearning.Classification.OneVsAll as OVA
import qualified MachineLearning.PCA as PCA
import qualified MachineLearning.LogisticModel as LM

processFeatures :: T.Matrix -> T.Matrix
processFeatures = ML.addBiasDimension . (ML.mapFeatures 2)

calcAccuracy :: T.Matrix -> T.Vector -> [T.Vector] -> Double
calcAccuracy x y thetas = OVA.calcAccuracy y yPredicted
  where yPredicted = OVA.predict x thetas

printOptPath x optPath =
  let thetas = optPath LA.?? (LA.All, LA.Drop 2)
      thetas_norm = LA.col $ map (LA.norm_2) $ LA.toRows . log $ 1 - LM.sigmoid (thetas LA.<> LA.tr x)
  in LA.disp 3 $ (optPath LA.?? (LA.All, LA.Take 2)) LA.||| thetas_norm

printInfinities x thetaList =
  let thetas = LA.fromColumns thetaList
      y :: T.Matrix
      y = log $ 1-LM.sigmoid (x LA.<> thetas)
      inf = 1/0
      xList = LA.toRows x
      x' = LA.fromRows $ map (\(xi, _) -> xList !! xi) $ LA.find (<=(-inf)) y
      z = x' LA.<> thetas
      h = LM.sigmoid z
      h' = 1 - h
      logh = log h
      logh' = log h'
  in do
    putStrLn "X"
    LA.disp 3 x'
    putStrLn "Z = X * Theta"
    LA.disp 3 z
    putStrLn "h(Theta) = sigmoid(Z)"
    LA.disp 3 h
    putStrLn "1 - h(Theta)"
    LA.disp 3 h'
    putStrLn "log (h(Theta))"
    LA.disp 3 logh
    putStrLn "log (1-h(Theta))"
    LA.disp 3 logh'

main = do
  -- Step 1. Data loading.
  -- Step 1.1 Training Data loading.
  (x, y) <- pure ML.splitToXY <*> LA.loadMatrix "samples/digits_classification/optdigits.tra"
  -- Step 1.1 Testing Data loading.
  (xTest, yTest) <- pure ML.splitToXY <*> LA.loadMatrix "samples/digits_classification/optdigits.tes"

  -- Step 2. Outputs and features preprocessing.
  let numLabels = 10
      x' = processFeatures x
      (reduceDims, reducedDimensions, x1) = PCA.getDimReducer x' 10
      initialTheta = LA.konst 0 (LA.cols x1)
      initialThetaList = replicate numLabels initialTheta
  -- Step 3. Learning.
      (thetaList, optPath) = OVA.learn (OVA.BFGS2 0.1 0.5) 0.0001 30 (OVA.L2 30) numLabels x1 y initialThetaList
  -- Step 4. Prediction and checking accuracy
      accuracyTrain = calcAccuracy x1 y thetaList
      accuracyTest = calcAccuracy (reduceDims $ processFeatures xTest) yTest thetaList

  -- Step 5. Printing results.
  putStrLn "\n=== Numerical Issues Demonstration ==="

  putStrLn $ "\nNumber of iterations to learn: " ++ show (map LA.rows optPath)

  putStrLn $ "\nReduced from " ++ show (LA.cols x') ++ " to " ++ show (LA.cols x1) ++ " dimensions"

  putStrLn "\nOptimization Paths (# iter, J(Theta), norm_2(Theta))"
  mapM_ (printOptPath x1) optPath

  print "\nDisplay numerical issues"
  printInfinities x1 thetaList

  putStrLn $ "\nAccuracy on train set (%): " ++ show (accuracyTrain*100)
  putStrLn $ "Accuracy on test set (%): " ++ show (accuracyTest*100)


module Trade.Algorithm.Bollinger where

import qualified Data.Vector as Vec
import Data.Vector (Vector)

import Statistics.Sample (mean, stdDev)

-- import Trade.Render.Svg.Plot

import Debug.Trace

-- number stddev
newtype BolK = BolK Int deriving (Show)

-- rolling window
newtype BolWin = BolWin Int deriving (Show)

meanStDev :: BolWin -> Vector Double -> (Vector (Double, Double), Vector (Double, Double))
meanStDev (BolWin l) v
  | l > Vec.length v = error $ "meanStDev: input vector to short: " ++ show l ++ "/" ++ show (Vec.length v)
meanStDev (BolWin l) v =
  let len = Vec.length v
      f a =
        let u = Vec.slice a l v
        in (mean u, stdDev u)
      idx = Vec.generate (len-l) (fromIntegral . (l+))
      (ms, ss) = Vec.unzip $ Vec.generate (len-l) f
  in (Vec.zip idx ms, Vec.zip idx ss)

data Bollinger = Bollinger {
  n :: BolWin
  , k :: BolK
  , bMean :: Vector (Double, Double)
  , bStDev :: Vector (Double, Double)
  } deriving (Show)

bollinger :: BolK -> BolWin -> Vector Double -> Bollinger
bollinger k n = uncurry (Bollinger n k) . meanStDev n

{-
bollinger2Lines :: String -> BolK -> BolWin -> Vector Double -> [PlotItem Vector Double]
bollinger2Lines str k@(BolK j) n v =
  let Bollinger _ _ ms ss = bollinger k n v
      k' = fromIntegral j
      f j (i, m) (_, s) = (i, m + j*s)
  in [ Line (str ++ " μ") ms
     , Line (str ++ " " ++ show j ++ "σ") (Vec.zipWith (f k') ms ss)
     , Line (str ++ " " ++ show j ++ "σ") (Vec.zipWith (f (-k')) ms ss) ]
-}


{-|
Module      : MachineLearning.Model.Measure
Description : TIR expression data structures
Copyright   : (c) Fabricio Olivetti de Franca, 2022
License     : GPL-3
Maintainer  : fabricio.olivetti@gmail.com
Stability   : experimental
Portability : POSIX

Performance measures for Regression and Classification.
-}
module MachineLearning.Model.Measure
  ( Measure(..)
  , toMeasure
  , measureAll
  , _rmse
  )
  where

import Data.Semigroup (Sum(..))

import qualified Numeric.LinearAlgebra       as LA
import qualified Numeric.Morpheus.Statistics as Stat
import qualified Data.Vector.Storable        as V

type Vector = LA.Vector Double
-- * Performance measures

-- | A performance measure has a string name and a function that
-- takes a vector of the true values, a vector of predict values
-- and returns a `Double`.
data Measure = Measure { _name :: String
                       , _fun  :: Vector -> Vector -> Double -- ^ true values -> predicted values -> measure
                       }

instance Show Measure where
  show (Measure n _) = n

-- | Mean for a vector of doubles
mean :: Vector -> Double
mean xs = V.sum xs / fromIntegral (V.length xs)
{-# INLINE mean #-}

-- | Variance for a vector of doubles
var :: Vector -> Double
var xs = sum' / fromIntegral (V.length xs)
  where
    mu   = mean xs
    sum' = V.foldl (\s x -> s + (x-mu)^(2 :: Int)) 0 xs
{-# INLINE var #-}

-- | generic mean error measure
meanError :: (Vector -> Vector) -- ^ a function to be applied to the error terms (abs, square,...)
          -> Vector             -- ^ target values
          -> Vector             -- ^ fitted values
          -> Double
meanError op ys ysHat = mean $ op $ ysHat - ys
{-# INLINE meanError #-}

-- * Common error measures for regression:
-- MSE, MAE, RMSE, NMSE, r^2

-- | Mean Squared Error
mse :: Vector -> Vector -> Double
--mse           = meanError (^(2 :: Int))
mse ys ysHat = mean $ (ysHat - ys) ^(2 :: Int)
{-# INLINE mse #-}

-- | Mean Absolute Error
mae :: Vector -> Vector -> Double
mae ys ysHat = mean $ abs (ysHat - ys) -- meanError abs
{-# INLINE mae #-}

-- | Normalized Mean Squared Error
nmse :: Vector -> Vector -> Double
nmse ys ysHat = mse ysHat ys / var ys
{-# INLINE nmse #-}

-- | Root of the Mean Squared Error
rmse :: Vector -> Vector -> Double
rmse ys ysHat = sqrt $ mse ysHat ys
{-# INLINE rmse #-}

-- | negate R^2 - minimization metric
rSq :: Vector -> Vector -> Double
rSq ys ysHat = negate (1 - r/t)
  where
    ym      = Stat.mean ys
    t       = sumOfSq $ V.map (\yi -> yi - ym) ys
    r       = sumOfSq $ ys - ysHat
    sumOfSq = V.foldl (\s di -> s + di^(2 :: Int)) 0
{-# INLINE rSq #-}

-- * Regression measures
_rmse, _mae, _nmse, _r2 :: Measure
_rmse = Measure "RMSE" rmse
_mae  = Measure "MAE" mae
_nmse = Measure "NMSE" nmse
_r2   = Measure "R^2" rSq

-- * Classification measures
_accuracy,_recall,_precision,_f1,_logloss :: Measure
_accuracy  = Measure "Accuracy" accuracy
_recall    = Measure "Recall" recall
_precision = Measure "Precision" precision
_f1        = Measure "F1" f1
_logloss   = Measure "Log-Loss" logloss

-- | Accuracy: ratio of correct classification
accuracy :: Vector -> Vector -> Double
accuracy ys ysHat = -equals/tot
  where
    ys'    = map round $ LA.toList ys
    ysHat' = map round $ LA.toList ysHat
    (Sum equals, Sum tot) = foldMap cmp $ zip ysHat' ys'
    cmp :: (Integer, Integer) -> (Sum Double, Sum Double)
    cmp (yH, y)
      | yH == y   = (Sum 1, Sum 1)
      | otherwise = (Sum 0, Sum 1)

-- | Precision: ratio of correct positive classification
precision :: Vector -> Vector -> Double
precision ys ysHat = equals/tot
  where
    ys'    = map round $ LA.toList ys
    ysHat' = map round $ LA.toList ysHat
    (Sum equals, Sum tot) = foldMap cmp $ zip ysHat' ys'
    cmp :: (Integer, Integer) -> (Sum Double, Sum Double)
    cmp (1, 1)  = (Sum 1, Sum 1)
    cmp (1, 0)  = (Sum 0, Sum 1)
    cmp (_, _) = (Sum 0, Sum 0)

-- | Recall: ratio of retrieval of positive labels
recall :: Vector -> Vector -> Double
recall ys ysHat = equals/tot
  where
    ys'    = map round $ LA.toList ys
    ysHat' = map round $ LA.toList ysHat
    (Sum equals, Sum tot) = foldMap cmp $ zip ysHat' ys'

    cmp :: (Integer, Integer) -> (Sum Double, Sum Double)
    cmp (1, 1)  = (Sum 1, Sum 1)
    cmp (0, 1)  = (Sum 0, Sum 1)
    cmp (_, _) = (Sum 0, Sum 0)

-- | Harmonic average between Precision and Recall
f1 :: Vector -> Vector -> Double
f1 ys ysHat = 2*prec*rec/(prec+rec)
  where
    prec = precision ysHat ys
    rec  = recall ysHat ys

-- | LogLoss of a classifier that returns a probability.
logloss :: Vector -> Vector -> Double
logloss ys ysHat = mean $ -(ys * log ysHat' + (1 - ys)*log(1 - ysHat'))
  where
    ysHat' = LA.cmap (min (1.0 - 1e-15) . max 1e-15) ysHat

-- | List of all measures
measureAll :: [Measure]
measureAll = [_rmse, _mae, _nmse, _r2
             , _accuracy, _recall, _precision, _f1, _logloss
             ]

-- | Read a string into a measure
toMeasure :: String -> Measure
toMeasure input
  | null cmp  = error ("Invalid measure: " ++ input)
  | otherwise = (snd.head) cmp
  where
    cmp                       = filter fst $ map isThis measureAll
    isThis m@(Measure name _) = (name == input, m)


{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}
module NeuralNetwork where
import Control.Arrow hiding (app)
import Control.Monad
import Control.Monad.Trans.State.Lazy
import Data.List
import Numeric.LinearAlgebra.HMatrix
import System.Random
import qualified Data.Vector.Storable as V

-- ActivationFunction wraps a function with its derivative, along with a name (for printing)
data ActivationFunction a = AF (a -> a) (a -> a) String
instance Show (ActivationFunction a) where show (AF _ _ n) = "ActivationFunction " ++ n

tanhAF = AF tanh (\x -> 1 - (tanh x)^2) "tanh"
logisticAF = AF f (\x -> f x * (1 - f x)) "logistic" where f x = (1 / (1 + exp (-x)))

data NeuralNetwork a = NN {
    getWeightMatrices :: [Matrix a],
    getActivationFunction :: ActivationFunction a
    } deriving Show

applyNN :: Numeric a => NeuralNetwork a -> Vector a -> Vector a
applyNN (NN mats (AF theta _ _)) x = foldl' ((cmap theta .) . flip (app . tr) . V.cons 1) x mats

-- (forwardPropagate nn x) returns the values at all the intermediate layers, before and after the activation function is applied
forwardPropagate :: Numeric a => NeuralNetwork a -> Vector a -> ([Vector a], [Vector a])
forwardPropagate (NN mats (AF theta _ _)) x = first tail . unzip $ scanl aux (undefined, V.cons 1 x) mats where
    aux (_,z) w = let v = app (tr w) z in (v, V.cons 1 (cmap theta v))

-- (backPropagate nn x y) returns all the errors (in the same shape as the weights) of applying nn to x, with target value y
backPropagate :: (Num (Vector a), Numeric a) => NeuralNetwork a -> Vector a -> Vector a -> [Matrix a]
backPropagate nn@(NN mats (AF theta theta' _)) x y = gradient where
    deltaStep (ds, d) (v, w) = let d' = (cmap theta' v) * (V.tail $ app w d) in (d':ds, d')
    (v:vs, zs) = first reverse $ forwardPropagate nn x
    ws = reverse mats
    dLast = 2 * (cmap theta v - y)
    ds = fst $ foldl' deltaStep ([dLast], dLast) (zip vs ws)
    gradient = zipWith outer zs ds

batchUpdate alpha nn@(NN oldWeights _) dataset = let
    (gradient, size) = foldr (\(x, y) (gr, n) -> (zipWith (+) gr (backPropagate nn x y), n+1)) (cycle [scalar 0], 0) dataset
    step = map (*scalar (alpha / size)) gradient
    newWeights = zipWith (-) oldWeights step
    in nn {getWeightMatrices = newWeights}

stochasticGradientDescent dataset alpha nn = foldl' (\nn' pt -> batchUpdate alpha nn' [pt]) nn dataset

initializeMatrix mkEntry (m, n) = runState (fmap (matrix m) $ replicateM (m*n) (state mkEntry))

randomlyWeightedNetwork seed dims af = NN (evalState (mapM mkMat (zip dims (tail dims))) (mkStdGen seed)) af where
    mkMat (m, n) = state $ initializeMatrix (randomR (-1, 1)) (n,m+1)


module Main where

import Neural.Matrix
import Numeric.LinearAlgebra
import Test.Hspec

{- Simple Net
   1
      [3, 2, -2] -> 1  |-1.5| = -0.5 -> 0                 bias
   2                    bias              [-2, 0.5] -> 7 | -3 | -> 4
      [-1, 2, 3] -> 12 | +2 | =  14 -> 14
   3
-}

zeroVec = vector [0.0,0.0]
zeroNet = [(relu, zeroVec, matrix 2 [0,0,0,0]), (relu, vector [0], matrix 1 [0,0])]
vTest = vector [1, 2, 3]
mTest = matrix 2 [3.0, -1.0, 2.0, 2.0, -2.0, 3.0]
simpleNet = [(relu, vector [-1.5, 2.0], mTest), (relu, vector [-3.0], matrix 1 [-2.0, 0.5])]

main :: IO ()
main = hspec $ do
  describe "Check feed layer" $ do
    it "passes trivial case" $ do
      (feedLayer (zeroVec, zeroVec) (head zeroNet)) `shouldBe` (zeroVec, zeroVec)
    it "passes simple case" $ do
      (feedLayer (vTest, vTest) (head simpleNet)) `shouldBe` (vector [-0.5,14.0], vector [0.0,14.0])

  describe "Check forward pass" $ do
    it "passes trivial case" $ do
      let zp = [(zeroVec, zeroVec), (zeroVec, zeroVec),
                (vector [0.0], vector [0.0])]
      (forwardPass zeroVec zeroNet) `shouldBe` zp
    it "passes simple case" $ do
      let fp = [(vector [1.0,2.0,3.0], vector [1.0,2.0,3.0]),
                (vector [-0.5,14.0], vector [0.0,14.0]),
                (vector [4.0], vector [4.0])]
      (forwardPass vTest simpleNet) `shouldBe` fp

  describe "Check chain" $ do
    it "passes trivial case" $ do
      let (_, _, zm) = last zeroNet
      let ze = vector [0.0]
      (chain (zeroVec, zm) ze) `shouldBe` zeroVec
    it "passes simple case" $ do
      let tl = vector [-0.5,14]
      let (_, _, lw) = last simpleNet
      let e = vector [0.5]
      let chained = vector [0,0.25]
      (chain (tl, lw) e) `shouldBe` chained

  describe "Check back prop" $ do
    it "passes simple case" $ do
      let tls = [zeroVec, vector [0]]
      let lws = map (\(_, _, x) -> x) zeroNet
      (backProp (vector [0]) tls lws) `shouldBe` tls


{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

{-# LANGUAGE ViewPatterns #-}

import           Numeric.Sundials.ARKode.ODE
import           Numeric.LinearAlgebra
import           Graphics.Plot

vanderpol mu = do
    let xdot nu _t [x,v] = [v, -x + nu * v * (1-x*x)]
        xdot _ _ _ = error "vanderpol RHS not defined"
        ts = linspace 1000 (0,50)
        sol = toColumns $ odeSolve (xdot mu) [1,0] ts
    mplot (ts : sol)
    mplot sol

harmonic w d = do
    let xdot u dd _t [x,v] = [v, a*x + b*v] where a = -u*u; b = -2*dd*u
        xdot _ _ _ _ = error "harmonic RHS not defined"
        ts = linspace 100 (0,20)
        sol = odeSolve (xdot w d) [1,0] ts
    mplot (ts : toColumns sol)

kepler v a = mplot (take 2 $ toColumns sol) where
    xdot _t [x,y,vx,vy] = [vx,vy,x*k,y*k]
        where g=1
              k=(-g)*(x*x+y*y)**(-1.5)
    xdot _ _ = error "kepler RHS not defined"
    ts = linspace 100 (0,30)
    sol = odeSolve xdot [4, 0, v * cos (a*degree), v * sin (a*degree)] ts
    degree = pi/180

main = do
    vanderpol 2
    harmonic 1 0
    harmonic 1 0.1
    kepler 0.3 60
    kepler 0.4 70
    vanderpol' 2

-- example of odeSolveV with jacobian
vanderpol' mu = do
    let xdot nu _t (toList->[x,v]) = fromList [v, -x + nu * v * (1-x*x)]
        xdot _ _ _ = error "vanderpol' RHS not defined"
        jac _ (toList->[x,v]) = (2><2) [ 0          ,          1
                                       , -1-2*x*v*mu, mu*(1-x**2) ]
        jac _ _ = error "vanderpol' Jacobian not defined"
        ts = linspace 1000 (0,50)
        hi = pure $ (ts!1 - ts!0) / 100.0
        sol = toColumns $ odeSolveV (SDIRK_5_3_4 jac) hi 1E-8 1E-8 (xdot mu) (fromList [1,0]) ts
    mplot sol


module AoC2021.Day06 where

import           Data.Semigroup        (stimes)
import           Numeric.LinearAlgebra ((#>), (><))
import qualified Numeric.LinearAlgebra as M
import qualified Parsers               as P

-- Linear (in growth days) time algorithm ----------------------------------------------------------
-- See Leslie Matrices (https://en.wikipedia.org/wiki/Leslie_matrix)

leslieMatrix :: M.Matrix Double -- Use double, to use optimized matrix multiplication of hmatrix
leslieMatrix = (9><9) [ 0, 1, 0, 0, 0, 0, 0, 0, 0 -- Count 1 -> 0
                      , 0, 0, 1, 0, 0, 0, 0, 0, 0 -- Count 2 -> 1
                      , 0, 0, 0, 1, 0, 0, 0, 0, 0 -- Count 3 -> 2
                      , 0, 0, 0, 0, 1, 0, 0, 0, 0 -- Count 4 -> 3
                      , 0, 0, 0, 0, 0, 1, 0, 0, 0 -- Count 5 -> 4
                      , 0, 0, 0, 0, 0, 0, 1, 0, 0 -- Count 6 -> 5,
                      , 1, 0, 0, 0, 0, 0, 0, 1, 0 -- Count 7 -> 6, 0 -> 6 (re-spawn, instead of dying)
                      , 0, 0, 0, 0, 0, 0, 0, 0, 1 -- Count 8 -> 7
                      , 1, 0, 0, 0, 0, 0, 0, 0, 0 -- Count 9 -> 8, 0 -> 8 (spawn child with 8)
                      ]

projectNDays :: Int -> M.Matrix Double -> M.Matrix Double
projectNDays = stimes

day0 :: [Int] -> M.Vector Double
day0 = M.vector . zipWith count [0..8] . repeat
  where count x = fromIntegral . length . filter (==x)

solve' :: Int -> [Int] -> Int
solve' days fishes = round $ M.sumElements dayN
  where dayN = projectNDays days leslieMatrix #> day0 fishes
----------------------------------------------------------------------------------------------------

-- Exponential (in growth days) time algorithm -----------------------------------------------------
-- | Calculate the number of fishes spawned by one fish within d days
f :: Int -> Int
f d = (1+) . sum . map (f . childOffset) $ [0 .. nSpawn - 1]
  where
    childOffset i = d-9-(7*i)
    nSpawn = ceiling $ fromIntegral d / 7

-- | Total number of fishes within d days, given a list of fishes with their initial counter
solve :: Int -> [Int] -> Int
solve d = sum . map (f . (d-))
----------------------------------------------------------------------------------------------------

solve01 :: String -> String
solve01 input = case P.runParser P.parseIntegerList () "" input of
  Left e   -> show e
  Right is -> show (solve' 80 is)

-- | Way to inefficient, maybe solve the sum of f?
solve02 :: String -> String
solve02 input = case P.runParser P.parseIntegerList () "" input of
  Left e   -> show e
  Right is -> show (solve' 256 is)


module Polymorphic where

import Data.Complex
import Data.Ratio
import Prelude hiding (product)

stringLength :: String -> Int
stringLength x = case x of
                [] -> 0
                (x:xs) -> 1 + stringLength xs

integerListLength :: [Integer] -> Int
integerListLength x = case x of
                [] -> 0
                (x:xs) -> 1 + integerListLength xs

-- | A polymorphic length function
polymorphicLength :: [a] -> Int
polymorphicLength list = case list of
  []     -> 0
  _ : xs -> 1 + polymorphicLength xs

-- | A polymorphic reverse function
reverseOf :: [a] -> [a]
reverseOf xs = case xs of
            [] -> []
            c: cs -> reverseOf cs ++ [c]

-- | A polymorphic isPalindrome function
isPalindrome :: (Eq a) => [a]  -> Bool
isPalindrome xs
                     | null xs = True
                     | xs == reverseOf xs = True
                     | otherwise = False

-- | A polymorphic list equality function
listEqual :: (Eq a) => [a] -> [a] -> Bool
listEqual list1 list2 = case (list1, list2) of
  ([], [])       -> True
  ([], _ )       -> False
  (_ , [])       -> False
  (x: xs, y: ys) -> (x == y) && (xs `listEqual` ys)

isMonotonicallyIncreasing :: (Ord a) => [a]  -> Bool
isMonotonicallyIncreasing list = case list of
                             []         -> True
                             [x]        -> True
                             i1: i2: is | i1 <= i2  -> isMonotonicallyIncreasing (i2: is)
                                        | otherwise -> False

normaliseVector :: (Floating a) => [a] -> [a]
normaliseVector vector = divideByScalar vector (norm vector)

divideByScalar :: (Fractional a) => [a] -> a -> [a]
divideByScalar vector' scalar = case vector' of
                        []    -> []
                        f: fs -> (f / scalar): divideByScalar fs scalar

norm :: (Floating  a) => [a] -> a
norm vector' = sqrt (sumSqr vector')
     where
                 sumSqr :: (Num a) => [a] -> a
                 sumSqr vector'' = case vector'' of
                    []    -> 0
                    f: fs -> f*f + sumSqr fs

reallyPolymorphicLength :: (Integral b) => [a] -> b
reallyPolymorphicLength list = case list of
  []    -> 0
  _: xs -> 1 + reallyPolymorphicLength xs

printLargestAsString :: (Ord a, Show a) => [a] -> String
printLargestAsString list =
  "The largest element in the list is " ++ show (maximum list)

rationalZero :: Ratio Integer
floatZero    :: Float
doubleZero   :: Double
complexZero  :: Complex Double

rationalZero = 0
floatZero    = 0.0
doubleZero   = 0.0
complexZero  = mkPolar 0.0 0.0

product :: undefined -- TODO
product = undefined -- TODO


module Fixtures where

import qualified Statistics.Matrix as M
import qualified Statistics.Matrix.Types as T

f :: Int -> Int -> Double
f a b = (c + d + 1) / (d + 1) where
  c = fromIntegral a
  d = fromIntegral b

g :: Int -> Int -> Double
g a b = (c + d + 1) / (c * d + 1) where
  c = fromIntegral a
  d = fromIntegral b

c :: [[Double]]
c = [[1.0, 2.0, 3.0], [4.0, 5.0, 6.0], [7.0, 8.0, 9.0]]

d :: [[Double]]
d = [[3.0, 2.5, 1.6], [5.5, 2.3, 6.9], [3.7, 9.1, 10.0]]

matA :: T.Matrix
matA = M.generate 3 3 f

matB :: T.Matrix
matB = M.generate 3 3 g

matC :: T.Matrix
matC = M.fromRowLists c

matD :: T.Matrix
matD = M.fromRowLists d

matId :: T.Matrix
matId = M.ident 3


-- nonlinear least-squares fitting

import Numeric.GSL.Fitting
import Numeric.LinearAlgebra

xs = map return [0 .. 39]
sigma = 0.1
ys = map return $ toList $ fromList (map (head . expModel [5,0.1,1]) xs)
            + scalar sigma * (randomVector 0 Gaussian 40)

dat :: [([Double],([Double],Double))]

dat = zip xs (zip ys (repeat sigma))

expModel [a,lambda,b] [t] = [a * exp (-lambda * t) + b]

expModelDer [a,lambda,b] [t] = [[exp (-lambda * t), -t * a * exp(-lambda*t) , 1]]

(sol,path) = fitModelScaled 1E-4 1E-4 20 (expModel, expModelDer) dat [1,0,0]

main = do
    print dat
    print path
    print sol


module Quadratic where

import Data.Complex

data Quadratic = Quadratic { a :: Double, b :: Double, c :: Double } deriving Show

type RootT = Complex Double

data Roots = Roots RootT RootT deriving Show

-- | Calculates roots of a polynomial and return set of roots
roots :: Quadratic -> Roots

-- Trivial, all constants are zero, error roots are not defined
roots (Quadratic 0 0 _) = error "Not a quadratic polynomial"

-- Is a polynomial of degree 1, x = -c / b
roots (Quadratic 0.0 b c) = let root = ( (-c) / b :+ 0)
                            in Roots root root

-- b^2 - 4ac = 0
roots (Quadratic a b c) =
  let discriminant = b * b - 4 * a * c
  in rootsInternal (Quadratic a b c) discriminant

rootsInternal :: Quadratic -> Double -> Roots
-- Discriminant is zero, roots are real
rootsInternal q d | d == 0 = let r = (-(b q) / 2.0 / (a q))
                                 root = r :+ 0
                             in Roots root root

-- Discriminant is negative, roots are complex
rootsInternal q d | d < 0 = Roots (realpart :+ complexpart) (realpart :+ (-complexpart))
  where plusd = -d
        twoa = 2.0 * (a q)
        complexpart = (sqrt plusd) / twoa
        realpart = - (b q) / twoa

-- discriminant is positive, all roots are real
rootsInternal q d = Roots (root1 :+ 0) (root2 :+ 0)
  where plusd = -d
        twoa = 2.0 * (a q)
        dpart = (sqrt plusd) / twoa
        prefix = - (b q) / twoa
        root1 = prefix + dpart
        root2 = prefix - dpart


import Control.Monad
import qualified Data.Vector.Storable as VS
import Numeric.LinearAlgebra
    ( (><), ident, Additive(add), Linear(scale) )
import Numeric.Minimization.QuadProgPP ( solveQuadProg )
import Test.Tasty ( defaultMain, testGroup, TestTree )
import Test.Tasty.HUnit ( testCase, assertEqual, assertFailure )
import Test.HUnit.Approx ( assertApproxEqual )
import Debug.Trace
import Numeric.LinearAlgebra.HMatrix (tr)

main :: IO ()
main = defaultMain tests

tests :: TestTree
tests = testGroup "small"
    [ problem0
    , problem1
    , problemQuadprogppDemo
    ]

-- Problem 0
-- minimize: 2(x-1)^2 + (y-4)^2
-- s.t.: x >= 0, y >= 0, x + 2y <= 2
problem0 :: TestTree
problem0 = testCase "Problem 0" $ do
    let answer = solveQuadProg
            ( (2><2)
                [ 4, 0
                , 0, 2
                ]
            , VS.fromList [-4, -8]
            )
            Nothing
            ( Just
                ( (3><2)
                    [ 1, 0
                    , 0, 1
                    ,-1,-2
                    ]
                , VS.fromList [0, 0, 2]
                )
            )
    (actual, best) <- case answer of
        Left err -> assertFailure $ show err
        Right x -> return x
    let expected = VS.fromList [2/9, 8/9] :: VS.Vector Double
    assertEqual "The answer should have the expected length"
        (VS.length expected)
        (VS.length actual)
    VS.zipWithM_ (assertApproxEqual "" 1e-12) (traceShowId expected) (traceShowId actual)

-- Problem 1
-- Same as Problem 0, but substitute:
--  s = x
--  t = x + y
--  u = x - y
-- and add a small positive constant to the diagonal elements to keep
-- the problem positive definite.
problem1 :: TestTree
problem1 = testCase "Problem 1" $ do
    let answer = solveQuadProg
            ((3><3)
                [   1, 2/3, 1/3
                , 2/3, 2/3,   0
                , 1/3,   0, 1/3
                ] `add` (1e-12 `scale` ident 3)
            , VS.fromList [-2, -4, 2]
            )
            (Just
                ( (1><3) [-3, 2, 1]
                , VS.fromList [0]
                )
            )
            (Just
                ((3><3)
                    [ 1,    0,    0
                    , 0,  1/3, -1/3
                    , 0, -4/3,  1/3
                    ]
                , VS.fromList [0, 0, 2]
                )
            )
    (actual, best) <- case answer of
        Left err -> assertFailure $ show err
        Right x -> return x
    let expected = VS.fromList [2/9, 10/9, -14/9] :: VS.Vector Double
    assertEqual "The answer should have the expected length"
        (traceShowId $ VS.length expected)
        (traceShowId $ VS.length actual)
    VS.zipWithM_ (assertApproxEqual "" 1e-5)
        (traceShowId expected)
        (traceShowId actual)

problemQuadprogppDemo :: TestTree
problemQuadprogppDemo = testCase "Problem quadpropp demo" $ do
    let answer = solveQuadProg
            ((2><2)
                [  4, -2
                , -2,  4 ]
            , VS.fromList [6, 0]
            )
            (Just
                ( (1><2) [1, 1]
                , VS.fromList [-3]
                )
            )
            (Just
                ((3><2)
                    [ 1, 0
                    , 0, 1
                    , 1, 1 ]
                , VS.fromList [0, -2, 0]
                )
            )
    (actual, best) <- case answer of
        Left err -> assertFailure $ show err
        Right x -> return x
    let epsilon = 1e-5
    assertApproxEqual "best" epsilon 12 best
    let expected = VS.fromList [1, 2] :: VS.Vector Double
    assertEqual "The answer should have the expected length"
        (traceShowId $ VS.length expected)
        (traceShowId $ VS.length actual)
    VS.zipWithM_ (assertApproxEqual "" epsilon)
        (traceShowId expected)
        (traceShowId actual)


module AlgorithmsSpec where

import qualified Statistics.Matrix as M
import qualified Statistics.Matrix.Types as T
import qualified Statistics.Matrix.Algorithms as Alg
import qualified Statistics.Matrix.Function as Func
import qualified Statistics.Matrix.Mutable as Mut

import Utils

qrDecompositionInvariant :: T.Matrix -> Bool
qrDecompositionInvariant mat =
  (M.multiply (fst res) (snd res)) == mat
  where
    res = Alg.qr mat

qrFirstOrthoInvariant :: T.Matrix -> Bool
qrFirstOrthoInvariant mat = Utils.isOrtho (fst res)
  where
    res = Alg.qr mat

qrSecondTriInvariant :: T.Matrix -> Bool
qrSecondTriInvariant mat = Utils.isUpperTri (snd res)
  where
    res = Alg.qr mat


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE ViewPatterns      #-}
module Tests.Transform
    (
      tests
    ) where

import Data.Bits ((.&.), shiftL)
import Data.Complex (Complex((:+)))
import Data.Functor ((<$>))
import Numeric.Sum (kbn, sumVector)
import Statistics.Function (within)
import Statistics.Transform (CD, dct, fft, idct, ifft)
import Test.Framework (Test, testGroup)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import Test.QuickCheck ( Positive(..), Arbitrary(..), Blind(..), (==>), Gen
                       , choose, vectorOf, counterexample, forAll)
import Test.QuickCheck.Property (Property(..))
import Tests.Helpers (testAssertion)
import Text.Printf (printf)
import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U

tests :: Test
tests = testGroup "fft" [
          testProperty "t_impulse"        t_impulse
        , testProperty "t_impulse_offset" t_impulse_offset
        , testProperty "ifft . fft = id"  (t_fftInverse $ ifft . fft)
        , testProperty "fft . ifft = id"  (t_fftInverse $ fft . ifft)
        , testProperty "idct . dct = id [up to scale]"
            (t_fftInverse (\v -> U.map (/ (2 * fromIntegral (U.length v))) $ idct $ dct v))
        , testProperty "dct . idct = id [up to scale]"
            (t_fftInverse (\v -> U.map (/ (2 * fromIntegral (U.length v))) $ idct $ dct v))
          -- Exact small size DCT
          -- 1
        , testDCT [1] $ [2]
          -- 2
        , testDCT [1,0] $ map (*2) [1, cos (pi/4)   ]
        , testDCT [0,1] $ map (*2) [1, cos (3*pi/4) ]
          -- 4
        , testDCT [1,0,0,0] $ map (*2) [1, cos(  pi/8), cos( 2*pi/8), cos( 3*pi/8)]
        , testDCT [0,1,0,0] $ map (*2) [1, cos(3*pi/8), cos( 6*pi/8), cos( 9*pi/8)]
        , testDCT [0,0,1,0] $ map (*2) [1, cos(5*pi/8), cos(10*pi/8), cos(15*pi/8)]
        , testDCT [0,0,0,1] $ map (*2) [1, cos(7*pi/8), cos(14*pi/8), cos(21*pi/8)]
          -- Exact small size IDCT
          -- 1
        , testIDCT [1] [1]
          -- 2
        , testIDCT [1,0]            [1,         1          ]
        , testIDCT [0,1] $ map (*2) [cos(pi/4), cos(3*pi/4)]
          -- 4
        , testIDCT [1,0,0,0]            [1,            1,            1,            1            ]
        , testIDCT [0,1,0,0] $ map (*2) [cos(   pi/8), cos( 3*pi/8), cos( 5*pi/8), cos( 7*pi/8) ]
        , testIDCT [0,0,1,0] $ map (*2) [cos( 2*pi/8), cos( 6*pi/8), cos(10*pi/8), cos(14*pi/8) ]
        , testIDCT [0,0,0,1] $ map (*2) [cos( 3*pi/8), cos( 9*pi/8), cos(15*pi/8), cos(21*pi/8) ]
        ]

-- A single real-valued impulse at the beginning of an otherwise zero
-- vector should be replicated in every real component of the result,
-- and all the imaginary components should be zero.
t_impulse :: Double -> Positive Int -> Bool
t_impulse k (Positive m) = U.all (c_near i) (fft v)
  where v = i `G.cons` G.replicate (n-1) 0
        i = k :+ 0
        n = 1 `shiftL` (m .&. 6)

-- If a real-valued impulse is offset from the beginning of an
-- otherwise zero vector, the sum-of-squares of each component of the
-- result should equal the square of the impulse.
t_impulse_offset :: Double -> Positive Int -> Positive Int -> Property
t_impulse_offset k (Positive x) (Positive m)
  -- For numbers smaller than 1e-162 their square underflows and test
  -- fails spuriously
  = abs k >= 1e-100 ==> U.all ok (fft v)
  where v = G.concat [G.replicate xn 0, G.singleton i, G.replicate (n-xn-1) 0]
        ok (re :+ im) = within ulps (re*re + im*im) (k*k)
        i  = k :+ 0
        xn = x `rem` n
        n  = 1 `shiftL` (m .&. 6)

-- Test that (ifft . fft ≈ id)
--
-- Approximate equality here is tricky. Smaller values of vector tend
-- to have large relative error. Thus we should test that vectors as
-- whole are approximate equal.
t_fftInverse :: (HasNorm (U.Vector a), U.Unbox a, Num a, Show a, Arbitrary a)
             => (U.Vector a -> U.Vector a) -> Property
t_fftInverse roundtrip =
  forAll (Blind <$> genFftVector) $ \(Blind x) ->
    let n  = G.length x
        x' = roundtrip x
        d  = G.zipWith (-) x x'
        nd = vectorNorm d
        nx = vectorNorm x
    in counterexample "Original vector"
     $ counterexample (show x )
     $ counterexample "Transformed one"
     $ counterexample (show x')
     $ counterexample (printf "Length = %i" n)
     $ counterexample (printf "|x - x'| / |x| = %.6g" (nd / nx))
     $ nd <= 3e-14 * nx

-- Test discrete cosine transform
testDCT :: [Double] -> [Double] -> Test
testDCT (U.fromList -> vec) (U.fromList -> res)
  = testAssertion ("DCT test for " ++ show vec)
  $ vecEqual 3e-14 (dct vec) res

-- Test inverse discrete cosine transform
testIDCT :: [Double] -> [Double] -> Test
testIDCT (U.fromList -> vec) (U.fromList -> res)
  = testAssertion ("IDCT test for " ++ show vec)
  $ vecEqual 3e-14 (idct vec) res

----------------------------------------------------------------

-- With an error tolerance of 8 ULPs, a million QuickCheck tests are
-- likely to all succeed. With a tolerance of 7, we fail around the
-- half million mark.
ulps :: Int
ulps = 8

c_near :: CD -> CD -> Bool
c_near (a :+ b) (c :+ d) = within ulps a c && within ulps b d

-- Arbitrary vector for FFT od DCT
genFftVector :: (U.Unbox a, Arbitrary a) => Gen (U.Vector a)
genFftVector = do
  n <- (2^)  <$> choose (1,9::Int)    -- Size of vector
  G.fromList <$> vectorOf n arbitrary -- Vector to transform

-- Ad-hoc type class for calculation of vector norm
class HasNorm a where
  vectorNorm :: a -> Double

instance HasNorm (U.Vector Double) where
  vectorNorm = sqrt . sumVector kbn . U.map (\x -> x*x)

instance HasNorm (U.Vector CD) where
  vectorNorm = sqrt . sumVector kbn . U.map (\(x :+ y) -> x*x + y*y)

-- Approximate equality for vectors
vecEqual :: Double -> U.Vector Double -> U.Vector Double -> Bool
vecEqual ε v u
  = vectorNorm (U.zipWith (-) v u) < ε * vectorNorm v


module Polymorphic where

import Data.Complex
import Data.Ratio
import Prelude hiding (product)

stringLength :: String -> Int
stringLength x = case x of
  [] -> 0
  ['a',_] -> 1
  _:xs -> 1 + stringLength xs

integerListLength :: [Integer] -> Int
integerListLength n = case n of
  [] -> 0
  _:xs -> 1 + integerListLength xs

-- | A polymorphic length function
polymorphicLength :: [a] -> Int
polymorphicLength list = case list of
  []     -> 0
  _ : xs -> 1 + polymorphicLength xs

-- | A polymorphic reverse function
reverseOf :: [a] -> [a]
reverseOf n = case n of
  [] -> []
  x:xs -> reverseOf xs ++ [x]

-- | A polymorphic isPalindrome function
isPalindrome :: (Eq a) => [a] -> Bool
isPalindrome list = list == reverseOf list

-- | A polymorphic list equality function
listEqual :: (Eq a) => [a] -> [a] -> Bool
listEqual list1 list2 = case (list1,list2) of
  ([],[] )-> True
  ([],_) -> False
  (_,[]) -> False
  (x:xs,y:ys) -> (x==y) && (xs `listEqual` ys)

isMonotonicallyIncreasing :: (Ord a) => [a] -> Bool
isMonotonicallyIncreasing list = case list of
  [] -> True
  i1:i2:is
    |i1<=i2 -> isMonotonicallyIncreasing (i2:is)
    |otherwise -> False
  [_] -> True

normaliseVector :: (Floating a) => [a] -> [a]
normaliseVector vector = divideByScalar vector (norm vector)

divideByScalar :: (Fractional a) =>[a] -> a -> [a]
divideByScalar vector' scalar = case vector' of
   [] -> []
   f: fs -> (f / scalar): divideByScalar fs scalar

norm :: (Floating a) => [a] -> a
norm vector' = sqrt(sumSqr vector')
  where
  sumSqr :: (Num a)=> [a] -> a
  sumSqr vector'' = case vector'' of
    []    -> 0
    f: fs -> f*f + sumSqr fs

reallyPolymorphicLength :: (Integral b) => [a] -> b
reallyPolymorphicLength list = case list of
  []    -> 0
  _: xs -> 1 + reallyPolymorphicLength xs

printLargestAsString :: (Ord a, Show a) => [a] -> String
printLargestAsString list =
  "The largest element in the list is " ++ show (maximum list)

rationalZero :: Ratio Integer
floatZero    :: Float
doubleZero   :: Double
complexZero  :: Complex Double

rationalZero = 0
floatZero    = 0.0
doubleZero   = 0.0
complexZero  = mkPolar 0.0 0.0

product :: (Num a, Eq a) => a -> a -> a
product x y = case y of
  0->0
  1->x
  _->x+product x(y-1)


module NeuralNet.Activation (
  Activation (Sigmoid, Tanh, ReLU),
  forward,
  backward
) where

import Numeric.LinearAlgebra

data Activation = Sigmoid | Tanh | ReLU
  deriving (Eq, Show)

e :: Double
e = exp 1

forward :: Activation -> Matrix Double -> Matrix Double
forward Sigmoid = cmap (\x -> 1 / (1 + (e ** (-x))))
forward Tanh = cmap (\x -> ((e ** x) - (e ** (-x))) / (e ** x + e ** (-x)))
forward ReLU = cmap (max 0)

backward :: Activation -> Matrix Double -> Matrix Double -> Matrix Double
backward Sigmoid dA z = dA * (s * (1 - s))
  where s = cmap (\x -> 1 / (1 + exp x)) (-z)
backward Tanh _ _ = error "Unsure of impl"
backward ReLU dA z = dA * step z


import Statistics.Distribution
import Statistics.Distribution.Normal

nd :: NormalDistribution
nd = normalDistr 0.0 1.0

main = do
  putStrLn $ "P( 2< Z) =      " ++ show (complCumulative nd 2)
  putStrLn $ "P(-2<=Z<=2)=    " ++ show (cumulative nd 2 - cumulative nd (-2))
  putStrLn $ "P( 0<=Z<=1.73)= " ++ show (cumulative nd 1.73 - cumulative nd 0)


-- PCA.hs
-- Compiles to library.
-- This library contains the functions needed to perform principle
-- component anlysis on vectorized data.
module PCA
( Hyperplane (..)
, mean
, saveHyperplane
, loadHyperplane
, linRegression
, distance
) where

import Numeric.LinearAlgebra.HMatrix
import Numeric.LinearAlgebra.Data
import Data.Packed.Matrix
import Data.Packed.Vector

data Hyperplane = Hyperplane Int (Vector Double) (Matrix Double) deriving (Show, Read)
-- First argument is the dimension of the ambient space.
-- Second argument is some vector in the hyperplane.
-- Rows of third argument form the basis of the parallel
-- linear subspace.
-- The Hyperplane is the coset of the second arg mod the third arg.

saveHyperplane :: FilePath -> Hyperplane -> IO ()
-- Saves a hyperplane in machine-readable plaintext format.
saveHyperplane f h = writeFile f (show h)

loadHyperplane :: FilePath -> IO Hyperplane
-- Loads a hyperplane that was saved in the syntax of `save`.
loadHyperplane f = readFile f >>= (return . read)

mean :: Matrix Double -> Vector Double
-- Returns the average of the rows of a matrix.
mean x = scale n . sum . toRows $ x
  where
  n = 1 / (fromIntegral . rows $ x) :: Double

normalize :: Matrix Double -> Matrix Double
-- Subtracts the average of/from the rows of a matrix.
normalize x = x - (fromRows . replicate (rows x) . mean $ x)

linRegression :: Int -> Matrix Double -> Hyperplane
-- Finds the best-fit hyperplane of the rows of a matrix.
-- First argument is the threshold to use a singular value.
-- Second argument is your data, rows are individual datapoints.
-- The first argument controls the size of the hyperplane.
-- If the first argument is too small, the hyperplane will just be
-- the whole space. If the first argument is too big, the hyper-
-- plane will just be a single point.
linRegression numsv inmat = Hyperplane n m rows
  where
  n = cols inmat
  m = mean inmat
  normalizedmat = normalize inmat
  (_,rows) = trimSVDRight numsv normalizedmat

trimSVDRight :: Int -> Matrix Double -> (Vector Double, Matrix Double)
-- Returns partial diagonal and right-side factor from SVD of
-- a matrix.
trimSVDRight numsv inmat = (v, outmat)
  where
  n' = min numsv (dim v1 - 1)
  (v1,m1) = rightSV inmat
  v = fromList . take n' . toList $ v1
  outmat = trans $ takeColumns (dim v) m1

distance :: Hyperplane -> Vector Double -> Double
-- Finds the distance from a vector to a hyperplane.
distance (Hyperplane n hv m) v
  | cols m == 0 = norm_2 v'
  | rows m == 0 = norm_2 v'
  | otherwise   = norm_2 $ distancevec
  where
  v' = v - hv
  distancevec = let a = m #> v'
                    b = trans m #> a in
                a `seq` b `seq` (b - v')


{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Statistics.Array
  ( median
  , quartiles
  , listDerivative
  , mad
  , bowleySkew
  ) where

import Control.Monad (forM_)
import Data.Primitive.Contiguous (Contiguous, Element, index, write)
import Statistics.Array.Types (Quartiles(..),AscList(..))

import qualified Data.Primitive.Contiguous as Arr
import qualified Data.Primitive.Sort as Arr
import qualified Statistics.Array.Types as Asc

median :: (Contiguous arr, Element arr a)
  => AscList arr a -> a
median (AscList arr) = Arr.index arr (Arr.size arr `div` 2)

quartiles :: (Contiguous arr, Element arr a)
  => AscList arr a -> Quartiles a
quartiles (AscList arr) = Quartiles
  { q1 = Arr.index arr (len `div` 4)
  , q2 = Arr.index arr (len `div` 2)
  , q3 = Arr.index arr (3 * len `div` 4)
  }
  where
  len = Arr.size arr

-- hmmm, I guess I'm going with Int64 here to match with Chronos
-- times will be stored in number of nanoseconds after unix epoch
-- which allows me times up to about the year 2262

-- so:
--   check skew of time diffs
--   check dispersion of time diffs (median absolute deviation)
--   check skew of data sizes
--   check dispersion of time diffs (median absolute deviation)
--   check size of data (at the mode)

-- | Median of absolute deviations.
-- This is a measure of dispersion that is more robust than standard deviation.
mad :: forall arr a.
     (Contiguous arr, Element arr a, Ord a, Num a)
  => AscList arr a -> a
mad asc@(AscList arr) =
  let m = median asc
      devs = (\x -> abs (x - m)) `Arr.map` arr :: arr a
      devsAsc = Arr.sort devs
   in median $ Asc.unsafeFromAscendingArray devsAsc

listDerivative :: (Contiguous arr, Element arr a, Num a)
  => AscList arr a -> arr a
listDerivative (AscList arr) = Arr.create $ do
  let len' = Arr.size arr - 1
  diffs <- Arr.new len'
  forM_ [0 .. len' - 1] $ \i -> do
    write diffs i (index arr (i + 1) - index arr i)
  pure diffs

bowleySkew :: (Integral a) => Quartiles a -> Double
bowleySkew Quartiles{q1,q2,q3}
  -- the limit as q1 approaches q3 is of course dependant on the direction of approach in the 3d space {q1,q2,q3}
  -- realistically, I'm going to call this zero, since real data has no approach, and the dirac distribution has zero skew
  | q1 == q3 = 0.0
  -- if `q1 == q2`, then skew simplifies to `(q3 - q1) / (q3 - q1)`, or `1`
  | q2 == q1 = 1.0
  -- similarly, if `q2 == q3`, then skew simplifies to `-1`
  | q2 == q3 = -1.0
  -- I'm not sure if either of those situations are reliable indicators of skew, though
  | otherwise = (realToFrac $ q3 + q1 - 2*q2) / (realToFrac $ q3 - q1)


-- example 3.19

import Statistics.Distribution
import Statistics.Distribution.Poisson

-- Let a half-hour be our unital time.
pd :: PoissonDistribution
pd = poisson 1.0

p :: Int -> Double
p = probability pd

main = do
  putStrLn $ "the patrol will miss during the 0th period: " ++ show (p 0)
  putStrLn $ "the patrol will miss during the 1th period: " ++ show (p 1)
  putStrLn $ "the patrol will miss during the 2th period: " ++ show (p 2)
  putStrLn $ "the patrol will miss at least once:         " ++ show (1 - p 0)


{-# language TypeApplications #-}

module BaseSpec where

import Data.Complex
import Data.Fixed (mod')
import Data.Semigroup
import Geometry
import Geometry.Testing
import Test.Hspec
import Test.Invariant
import Test.QuickCheck hiding (scale)

spec :: Spec
spec = do
  describe "Direction" $ do
    describe "equality" $ do
      it "1" $ asDeg 0 == asDeg 360
      it "2" $ asDeg 10 == asDeg 370
      it "3" $ 45 == asCmp @Direction (1 :+ 1)
      it "4" $ 90 == asCmp @Direction (0 :+ 1)
      it "5" $ 90 == asDeg (90 + 1e-12)
      it "6" $ asCmp @Direction (2 :+ 3) == asCmp @Direction (4 :+ 6)

    describe "inequality" $ do
      it "1" $ asDeg 0 <= asDeg 360
      it "2" $ asDeg 0 < asDeg 360.0001
      it "3" $ property $ \a -> 0 <= turns a && turns a <= 1

    describe "isomorphism" $ do
      it "asRad" $ property $ \x -> (rad . asRad) x ~= x `mod'` (2*pi)
      it "asDeg" $ property $ \x -> (deg . asDeg) x ~= x `mod'` 360
      it "asTurns" $ property $ \x -> (turns . asTurns) x ~= x `mod'` 1

    describe "radians" $ do
      it "1" $ rad 10 ~= rad 370
      it "2" $ rad (-10) ~= rad 350

  describe "Affine" $ do
    describe "isomorphism" $ do
      it "1" $ property $ cmp `inverts` xy
      it "2" $ property $ xy `inverts` cmp

    describe "dot" $ do
      it "pair" $ dot @XY @XY (1, 2) (3, 6) == 15
      it "complex" $ dot @Cmp @Cmp (1 :+ 2) (3 :+ 6) == 15
      it "orthogonality" $ property $ \x ->
        not (isZero x) ==> rotate 90 x `isOrthogonal` (x :: XY)

    describe "cross" $ do
      it "pair" $ cross @XY @XY (1, 2) (3, 6) == 0
      it "complex" $ cross @Cmp @Cmp (1 :+ 2) (3 :+ 6) == 0

    describe "norm" $ do
      it "pair" $ norm @XY (3, 4) == 5
      it "complex" $ norm @Cmp (3 :+ 4) == 5

    describe "normalize" $ do
      it "pair" $ norm (normalize @XY (3, 4)) == 1
      it "complex" $ norm (normalize @Cmp (3 :+ 4)) == 1
      it "trivial" $ normalize @Cmp 0 == 0

    describe "opposite" $
      it "1" $ property $ \x -> x `isOpposite` opposite @XY x

  describe "Transformations" $ do
    describe "translate" $ do
      it "1" $ translate' @XY @XY (10, 20) (3, 4)  == (13, 24)
      it "2" $ translate' @XY @Cmp 10 (3, 4)  == (13, 4)
      it "3" $ translate' @Cmp @XY (3, 4) 10  == 13 :+ 4

    it "scale" $ scale @XY 10 (3, 4)  == (30, 40)
    it "scaleX" $ scaleX @XY 10 (3, 4) ~= (30, 4)
    it "scaleY" $ scaleY @XY 10 (3, 4) ~= (3, 40)

    describe "scaleAt" $ do
      it "1" $ scaleAt' @XY @XY (3, 4) 10 (3, 4)  == (3, 4)
      it "2" $ scaleAt' @XY @XY (0, 0) 10 (3, 4)  == (30, 40)
      it "3" $ scaleAt' @XY @XY (1, 1) 10 (3, 4)  == (21, 31)
      it "4" $ scaleAt' @XY @XY (1, 1) 10 (0, 0)  == (-9, -9)

    describe "rotate" $ do
      it "1" $ rotate @XY 0 (3, 4)  == (3, 4)
      it "2" $ rotate @XY 90 (3, 4)  ~= (-4, 3)
      it "3" $ rotate @XY 360 (3, 4)  == (3, 4)
      it "4" $ rotate @XY (asCmp (0 :+ 1)) (3, 4) ~= (-4, 3)

    describe "rotateAt" $ do
      it "1" $ rotateAt' @XY @XY (0, 0) 0 (3, 4) == (3, 4)
      it "2" $ rotateAt' @XY @XY (3, 4) 90 (3, 4) == (3, 4)
      it "3" $ rotateAt' @XY @XY (1, 0) 90 (0, 0) ~= (1, -1)
      it "4" $ rotateAt' @XY @XY (1, 1) 180 (0, 0) ~= (2, 2)

  describe "distanceTo" $ do
    let c1 = aCircle
        c2 = aCircle # scale 2
        c3 = aCircle # scale 3
    it "1" $ property $ \x -> distanceTo (c1 @-> x) c2 ~= 1
    it "2" $ property $ \x -> distanceTo (c3 @-> x) c2 ~= 1
    it "3" $ distanceTo aPoint c2 == 2
    it "4" $ distanceTo aPoint c3 == 3
    it "5" $ property $ \x a ->
      let l1 = aLine # rotate a
          l2 = l1 # translate' (normal l1 0)
      in distanceTo (l1 @-> x) l2 ~= 1
    it "6" $ property $ \x (Positive n) ->
      let t1 = regularPoly (n + 3)
          t2 = t1 # scale 2
      in distanceTo (t1 @-> x) t2 ~= cos (pi/ fromIntegral (n + 3))

  describe "Box" $ do
    let l = Segment (1:+2, 4:+6)
    it "0" $ box l == ((1,2),(4,6))
    it "1" $ (left.lower.corner $ l) == 1:+2
    it "2" $ (right.lower.corner $ l) == 4:+2
    it "3" $ (left.upper.corner $ l) == 1:+6
    it "4" $ (right.upper.corner $ l) == 4:+6
    it "5" $ figureHeight l == 4
    it "6" $ figureWidth l == 3

  describe "AlmostEqual" $ do
    it "1" $ property $ \i j -> let _ = (i :: Int, j :: Int)
                                in (i == j) == (i ~= j)
    it "2" $ property $ \i j -> let _ = (i :: Maybe Int, j :: Maybe Int)
                                in (i == j) == (i ~= j)