{-# LANGUAGE FlexibleContexts #-}

module TheField where

import           Data.Complex
import           Data.Char
import           Data.List as L
import           Graphics.Rendering.Chart.Easy hiding (transform)
import           Graphics.Rendering.Chart.Backend.Diagrams
--
import           TheField.Image
import           TheField.Plot

i :: Num a => a -> Complex a
i n = 0 :+ n

e :: Floating a => Complex a
e = exp 1 :+ 0

s :: [Complex Double]
s = [ 2 + i 2
    , 3 + i 2
    , 1.75 + i 1
    , 2 + i 1
    , 2.25 + i 1
    , 2.5 + i 1
    , 2.75 + i 1
    , 3 + i 1
    , 3.25 + i 1
    ]

-- Task 1.4.1
plotComplex :: EC (Layout Double Double) ()
plotComplex = plot' pts 4 4
  where pts = s

-- Task 1.4.3
plotTranslate :: EC (Layout Double Double) ()
plotTranslate = plot' pts 5 5
  where pts = [ pt + (1 + i 2) | pt <- s ]

-- Task 1.4.4
plotEyeCentral :: EC (Layout Double Double) ()
plotEyeCentral = plot' pts 4 4
  where pts = [ - 1 * (2 :+ 2) + pt | pt <- s ]

-- Task 1.4.7
plotScaled :: EC (Layout Double Double) ()
plotScaled = plot' pts 4 4
  where pts = [ 0.5 * pt | pt <- s ]

-- Task 1.4.8
plotRotation :: EC (Layout Double Double) ()
plotRotation = plot' pts 4 4
  where pts = [ i 0.5 * pt | pt <- s ]

-- Task 1.4.9
plotTranslatedRotation :: EC (Layout Double Double) ()
plotTranslatedRotation = plot' pts 4 4
  where pts = [ (i 0.5 * pt) + i (-1) + 2 | pt <- s ]

-- Task 1.4.10
plotImage :: [(Double, Double)] -> EC (Layout Double Double) ()
plotImage img = plot' pts 200 200
  where pts = [ x :+ y | (x, y) <- img ]

examplePng :: IO [(Double, Double)]
examplePng = do
  withIntensity 120 . pixels <$> readImage "./src/TheField/img01.png"
  where
    withIntensity ins pts =
      [ (fromIntegral x, fromIntegral y) | (x, y, pxl) <- pts, intensity pxl > ins ]

-- Task 1.4.17
plotE :: EC (Layout Double Double) ()
plotE = plot' pts 2 2
  where pts = [ e ** ((x * pi :+ 0) * i 2 / (n :+ 0)) | x <- [0..n-1] ]
        n = 20

-- Task 1.4.18
plotRotation' :: EC (Layout Double Double) ()
plotRotation' = plot' pts 4 4
  where pts = [ pt * e ** i (pi / 4) | pt <- s ]

-- Task 1.4.19
plotImageRotation :: [(Double, Double)] -> EC (Layout Double Double) ()
plotImageRotation img = plot' pts 200 200
  where
    pts = [ rotate $ x :+ y | (x, y) <- img ]
    rotate pt = pt * e ** i (pi / 4)

-- Task 1.4.20
plotMultipleOperations :: [(Double, Double)] -> EC (Layout Double Double) ()
plotMultipleOperations img = plot' pts 200 200
  where
    pts = [ scale . rotate . transform $ x :+ y | (x, y) <- img ]
    rotate = (*) (e ** i (pi / 4))
    scale = (*) 0.5
    transform = (+) (-1 * (100 :+ 100))

-- Task 1.5.1
message :: [String]
message =
  [ "10101"
  , "00100"
  , "10101"
  , "01011"
  , "11001"
  , "00011"
  , "01011"
  , "10101"
  , "00100"
  , "11001"
  , "11010"
  ]

decryptMessage :: String
decryptMessage = decryptCyphertext [1,0,0,0,1] message

decryptCyphertext :: [Int] -> [String] -> String
decryptCyphertext key = L.foldr ((:) . decode) ""
  where
    decode = decodeChar . decodeNumber . L.map (uncurry decryptBit) . zip key . L.map toBit
    toBit b = if b == '1' then 1 else 0

-- try all possible keys in attempt to find the answer
brute :: [([Int], String)]
brute = L.map (\k -> (k, decryptCyphertext k message)) keys
  where
    keys = [ [a,b,c,d,e] | a <- [0..1], b <- [0..1], c <- [0..1], d <- [0..1], e <- [0..1] ]

decryptBit :: Int -> Int -> Int
decryptBit k v = (k + v) `mod` 2

decodeNumber :: [Int] -> Int
decodeNumber str = L.foldr ((+) . uncurry decode) 0 $ zip [0..] (reverse str)
  where decode idx val = val * 2 ^ idx

decodeChar :: Int -> Char
decodeChar n =
  case n' of
    26 -> ' '
    _ -> chr $ n' + 65
  where n' = n `mod` 27

-- Task 1.7.10
sumComplexNumbersA :: EC (Layout Double Double) ()
sumComplexNumbersA = plotComplexAddition (3.0 :+ 1.0) (2.0 :+ 2.0)

sumComplexNumbersB :: EC (Layout Double Double) ()
sumComplexNumbersB = plotComplexAddition ((-1.0) :+ 2.0) (1.0 :+ (-1.0))

sumComplexNumbersC :: EC (Layout Double Double) ()
sumComplexNumbersC = plotComplexAddition (2.0 :+ 0.0) ((-3.0) :+ 0.001)

sumComplexNumbersD :: EC (Layout Double Double) ()
sumComplexNumbersD = plotComplexAddition (4 * (0.0 :+ 2.0)) (0.001 :+ 1.0)

generateImages :: IO ()
generateImages = do
  toFile def "./src/TheField/task-1.4.1.svg" plotComplex
  toFile def "./src/TheField/task-1.4.3.svg" plotTranslate
  toFile def "./src/TheField/task-1.4.4.svg" plotEyeCentral
  toFile def "./src/TheField/task-1.4.7.svg" plotScaled
  toFile def "./src/TheField/task-1.4.8.svg" plotRotation
  toFile def "./src/TheField/task-1.4.9.svg" plotTranslatedRotation
  toFile def "./src/TheField/task-1.4.10.svg" =<< plotImage <$> examplePng
  toFile def "./src/TheField/task-1.4.17.svg" plotE
  toFile def "./src/TheField/task-1.4.18.svg" plotRotation'
  toFile def "./src/TheField/task-1.4.19.svg" =<< plotImageRotation <$> examplePng
  toFile def "./src/TheField/task-1.4.20.svg" =<< plotMultipleOperations <$> examplePng
  toFile def "./src/TheField/task-1.7.10-a.svg" sumComplexNumbersA
  toFile def "./src/TheField/task-1.7.10-b.svg" sumComplexNumbersB
  toFile def "./src/TheField/task-1.7.10-c.svg" sumComplexNumbersC
  toFile def "./src/TheField/task-1.7.10-d.svg" sumComplexNumbersD


module Math.AlgebraicNumbers.Overloads where
import Math.AlgebraicNumbers.Prelude
import Math.AlgebraicNumbers.Class
import Math.AlgebraicNumbers.AReal
import Math.AlgebraicNumbers.AComplex
import qualified Prelude
import qualified Data.Complex

-- Prelude functions generalized from Integral a to GCDDomain a / EuclideanDomain a

gcd :: (GCDDomain a) => a -> a -> a
gcd = gcdD

lcm :: (GCDDomain a) => a -> a -> a
lcm = lcmD

divMod :: (EuclideanDomain a) => a -> a -> (a, a)
divMod = divModD

infixl 7 `div`, `mod`

div, mod :: (EuclideanDomain a) => a -> a -> a
div = divD
mod = modD

class Sqrt a where
  sqrt :: a -> a
  maybeSqrt :: a -> Maybe a

instance Sqrt Prelude.Float where
  sqrt = Prelude.sqrt
  maybeSqrt x | x >= 0 = Just $ Prelude.sqrt x
              | otherwise = Nothing

instance Sqrt Prelude.Double where
  sqrt = Prelude.sqrt
  maybeSqrt x | x >= 0 = Just $ Prelude.sqrt x
              | otherwise = Nothing

instance (RealFloat a) => Sqrt (Data.Complex.Complex a) where
  sqrt = Prelude.sqrt
  maybeSqrt = Just . Prelude.sqrt

instance Sqrt AReal where
  sqrt = sqrtA
  maybeSqrt x | x >= 0 = Just $ sqrtA x
              | otherwise = Nothing

instance Sqrt AComplex where
  sqrt = sqrtAN
  maybeSqrt = Just . sqrtAN

-- toRational?


{-# LANGUAGE MultiParamTypeClasses #-}

module Stats where

import           Control.Applicative
import           Control.Monad.State
import           Data.Random
import           Data.Random.Distribution.Exponential
import           Data.Random.Source.PureMT
import qualified Data.Vector                          as V
import           Data.Word
import qualified Statistics.Sample.Histogram          as S

seed :: Word64
seed = 123

sampleStream :: (Num t, Distribution d t) => d t -> [t]
sampleStream distribution = evalState (iterateM $ sample distribution) (pureMT seed)

iterateM :: (Applicative m) => m a -> m [a]
iterateM f = liftA2 (:) f (iterateM f)

sampleVector :: (Num t, Distribution d t) => d t -> Int -> V.Vector t
sampleVector distribution size = V.fromList . take size $ sampleStream distribution

sampleExp :: Int -> V.Vector Double
sampleExp = sampleVector (Exp 1)

sampleExp' :: Int -> V.Vector Double
sampleExp' = fmap (negate . log) . sampleVector StdUniform

expHistograms :: (V.Vector Double, V.Vector Double)
expHistograms = S.histogram 30 (sampleExp 1000)

expHistograms' :: (V.Vector Double, V.Vector Double)
expHistograms' = S.histogram 30 (sampleExp' 1000)

mean :: Floating a => V.Vector a -> a
mean xs = V.sum xs / fromIntegral (V.length xs)

var :: Floating a => V.Vector a -> a
var xs = mean (fmap (** 2) xs) - mean xs ** 2

isCloseWithTolerance :: (Ord a, Floating a) => a -> a -> a -> a -> Bool
isCloseWithTolerance aTol rTol x y = abs (x - y) <= aTol + rTol * abs y

isClose :: (Ord a, Floating a) => a -> a -> Bool
isClose = isCloseWithTolerance 1e-8 1e5


module Regression
 ( simpleRegression ) where

import Data.List
import Data.Maybe
import Control.Monad
import Statistics

simpleRegression :: (Floating a) => [a] -> [a] -> (Maybe a, Maybe a)
simpleRegression x y  = (slope, intercept)
                  where
                    slope      = (/) <$> covariance x y <*> variance x
                    intercept  = subtract <$> mean y <*> ((*) <$> slope <*> mean x)


import Debug.Trace
import Data.Complex

traceIdShow :: Show a => a -> a
traceIdShow x = trace (show x) x

tracef :: Show b => (a->b) -> a -> a
tracef f x = trace (show $ f x) x

type Coord = Complex Float

data Action = Turn Coord
            | Forward Float
            | Move Coord
  deriving Show

data Ship = Ship Coord Coord
  deriving Show

act :: Ship -> Action -> Ship
act (Ship orientation position) (Turn a)
  = traceIdShow $
    trace ("Turning "++ show a) $
    Ship (orientation * a) position
act (Ship orientation position) (Forward d)
  = traceIdShow $
    trace ("Forward "++ show d) $
    Ship orientation (position + orientation * (d:+0))
act (Ship orientation position) (Move p)
  = traceIdShow $
    trace ("Moving "++ show p) $
    Ship orientation (position + p)

-- part 2 changes the orientation to be a waypoint. Because we
-- represent the orientation as a complex number, the changes we make
-- are minimal: we apply moves to the waypoint rather than the ship's
-- position. Also, when calling act, change the start position of the
-- waypoint.
act2 :: Ship -> Action -> Ship
act2 (Ship waypoint position) (Turn a)
  = traceIdShow $
    trace ("Turning "++ show a) $
    Ship (waypoint * a) position
act2 (Ship waypoint position) (Forward d)
  = traceIdShow $
    trace ("Forward "++ show d) $
    Ship waypoint (position + waypoint * (d:+0))
act2 (Ship waypoint position) (Move p)
  = traceIdShow $
    trace ("Moving "++ show p) $
    Ship (waypoint + p) position

main = interact $ (++ "\n") .  show . length
  . tracef ((\d-> "Part 2: " ++ show d)
            . manhatten
            . foldl act2 (Ship (10:+1) (0:+0)))
  . tracef ((\d-> "Part 1: " ++ show d)
            . manhatten
            . foldl act (Ship (1:+0) (0:+0)))
  . map toAction . lines

toAction (a:vs) | a == 'N' = Move $ 0 :+ v
                | a == 'S' = Move $ 0 :+ (-1 * v)
                | a == 'E' = Move $ v :+ 0
                | a == 'W' = Move $ (-1 * v) :+ 0
                | a == 'L' = Turn $  cis $ v / 180 * pi
                | a == 'R' = Turn $  cis $ -1 * v / 180 * pi
                | a == 'F' = Forward $  v
                | otherwise = error $ "unknown action "++ show a
  where v = read vs :: Float

manhatten :: Ship -> Int
manhatten (Ship _ p) = round $ abs(realPart p) + abs(imagPart p)


{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types            #-}
{-# LANGUAGE ViewPatterns          #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Apollonian
-- Copyright   :  (c) 2011, 2016 Brent Yorgey
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  byorgey@cis.upenn.edu
--
-- Generation of Apollonian gaskets.  Any three mutually tangent
-- circles uniquely determine exactly two others which are mutually
-- tangent to all three.  This process can be repeated, generating a
-- fractal circle packing.
--
-- See J. Lagarias, C. Mallows, and A. Wilks, \"Beyond the Descartes
-- circle theorem\", /Amer. Math. Monthly/ 109 (2002), 338--361.
-- <http://arxiv.org/abs/math/0101066>.
--
-- A few examples:
--
-- > import Diagrams.TwoD.Apollonian
-- > apollonian1 = apollonianGasket 0.01 2 2 2
--
-- <<diagrams/src_Diagrams_TwoD_Apollonian_apollonian1.svg#diagram=apollonian1&width=400>>
--
-- > import Diagrams.TwoD.Apollonian
-- > apollonian2 = apollonianGasket 0.01 2 3 3
--
-- <<diagrams/src_Diagrams_TwoD_Apollonian_apollonian2.svg#diagram=apollonian2&width=400>>
--
-- > import Diagrams.TwoD.Apollonian
-- > apollonian3 = apollonianGasket 0.01 2 4 7
--
-- <<diagrams/src_Diagrams_TwoD_Apollonian_apollonian3.svg#diagram=apollonian3&width=400>>
--
-----------------------------------------------------------------------------

module Diagrams.TwoD.Apollonian
       ( -- * Circles

         Circle(..), mkCircle, center, radius

         -- * Descartes' Theorem
       , descartes, other, initialConfig

         -- * Apollonian gasket generation

       , apollonian

         -- ** Kissing sets

       , KissingSet(..), kissingSets, flipSelected, selectOthers

         -- ** Apollonian trees

       , apollonianTrees, apollonianTree

         -- * Diagram generation

       , drawCircle
       , drawGasket
       , apollonianGasket

       ) where

import           Data.Complex
import qualified Data.Foldable    as F
import           Data.Maybe       (catMaybes)
import           Data.Tree

import           Diagrams.Prelude hiding (center, radius)

import           Control.Arrow    (second, (&&&))

------------------------------------------------------------
--  Circles
------------------------------------------------------------

-- | Representation for circles that lets us quickly compute an
--   Apollonian gasket.
data Circle n = Circle
  { bend :: n
    -- ^ The bend is the reciprocal of signed
    --   radius: a negative radius means the
    --   outside and inside of the circle are
    --   switched.  The bends of any four mutually
    --   tangent circles satisfy Descartes'
    --   Theorem.
  , cb   :: Complex n
    -- ^ /Product/ of bend and center represented
    --   as a complex number.  Amazingly, these
    --   products also satisfy the equation of
    --   Descartes' Theorem.
  }
  deriving (Eq, Show)

-- | Create a @Circle@ given a signed radius and a location for its center.
mkCircle :: Fractional n =>
            n -- ^ signed radius
         -> P2 n     -- ^ center
         -> Circle n
mkCircle r (unp2 -> (x,y)) = Circle (1/r) (b*x :+ b*y)
  where b = 1/r

-- | Get the center of a circle.
center :: Fractional n => Circle n -> P2 n
center (Circle b (cbx :+ cby)) = p2 (cbx / b, cby / b)

-- | Get the (unsigned) radius of a circle.
radius :: Fractional n => Circle n -> n
radius = abs . recip . bend

liftF :: RealFloat n => (forall a. Floating a => a -> a) -> Circle n -> Circle n
liftF f (Circle b c) = Circle (f b) (f c)

liftF2 :: RealFloat n => (forall a. Floating a => a -> a -> a) ->
          Circle n -> Circle n -> Circle n
liftF2 f (Circle b1 cb1) (Circle b2 cb2) = Circle (f b1 b2) (f cb1 cb2)

instance RealFloat n => Num (Circle n) where
  (+)           = liftF2 (+)
  (-)           = liftF2 (-)
  (*)           = liftF2 (*)
  negate        = liftF negate
  abs           = liftF abs
  fromInteger n = Circle (fromInteger n) (fromInteger n)

instance RealFloat n => Fractional (Circle n) where
  (/)   = liftF2 (/)
  recip = liftF recip

-- | The @Num@, @Fractional@, and @Floating@ instances for @Circle@
--   (all simply lifted elementwise over @Circle@'s fields) let us use
--   Descartes' Theorem directly on circles.
instance RealFloat n => Floating (Circle n) where
  sqrt = liftF sqrt

------------------------------------------------------------
--  Descartes' Theorem
------------------------------------------------------------

-- XXX generalize these for higher dimensions?

-- | Descartes' Theorem states that if @b1@, @b2@, @b3@ and @b4@ are
--   the bends of four mutually tangent circles, then
--
--   @
--     b1^2 + b2^2 + b3^2 + b4^2 = 1/2 * (b1 + b2 + b3 + b4)^2.
--   @
--
--   Surprisingly, if we replace each of the @bi@ with the /product/
--   of @bi@ and the center of the corresponding circle (represented
--   as a complex number), the equation continues to hold! (See the
--   paper referenced at the top of the module.)
--
--   @descartes [b1,b2,b3]@ solves for @b4@, returning both solutions.
--   Notably, @descartes@ works for any instance of @Floating@, which
--   includes both @Double@ (for bends), @Complex Double@ (for
--   bend/center product), and @Circle@ (for both at once).
descartes :: Floating n => [n] -> [n]
descartes [b1,b2,b3] = [r + s, -r + s]
  where r = 2 * sqrt (b1*b2 + b1*b3 + b2*b3)
        s = b1+b2+b3
descartes _ = error "descartes must be called on a list of length 3"

-- | If we have /four/ mutually tangent circles we can choose one of
--   them to replace; the remaining three determine exactly one other
--   circle which is mutually tangent.  However, in this situation
--   there is no need to apply 'descartes' again, since the two
--   solutions @b4@ and @b4'@ satisfy
--
--   @
--     b4 + b4' = 2 * (b1 + b2 + b3)
--   @
--
--   Hence, to replace @b4@ with its dual, we need only sum the other
--   three, multiply by two, and subtract @b4@.  Again, this works for
--   bends as well as bend/center products.
other :: Num n => [n] -> n -> n
other xs x = 2 * sum xs - x

-- | Generate an initial configuration of four mutually tangent
--   circles, given just the signed bends of three of them.
initialConfig :: RealFloat n => n -> n -> n -> [Circle n]
initialConfig b1 b2 b3 = cs ++ [c4]
  where cs     = [Circle b1 0, Circle b2 ((b2/b1 + 1) :+ 0), Circle b3 cb3]
        a      = 1/b1 + 1/b2
        b      = 1/b1 + 1/b3
        c      = 1/b2 + 1/b3
        x      = (b*b + a*a - c*c)/(2*a)
        y      = sqrt (b*b - x*x)
        cb3    = b3*x :+ b3*y
        [c4,_] = descartes cs

------------------------------------------------------------
--  Gasket generation
------------------------------------------------------------

select :: [a] -> [(a, [a])]
select [] = []
select (x:xs) = (x,xs) : (map . second) (x:) (select xs)

-- | The basic idea of a kissing set is supposed to represent a set of
--   four mutually tangent circles with one selected, though in fact
--   it is more general than that: it represents any set of objects
--   with one distinguished object selected.
data KissingSet n = KS { selected :: n, others :: [n] }
  deriving (Show)

-- | Generate all possible kissing sets from a set of objects by
--   selecting each object in turn.
kissingSets :: [n] -> [KissingSet n]
kissingSets = map (uncurry KS) . select

-- | \"Flip\" the selected circle to the 'other' circle mutually tangent
--   to the other three.  The new circle remains selected.
flipSelected :: Num n => KissingSet n -> KissingSet n
flipSelected (KS c cs) = KS (other cs c) cs

-- | Make the selected circle unselected, and select each of the
--   others, generating a new kissing set for each.
selectOthers :: KissingSet n -> [KissingSet n]
selectOthers (KS c cs) = [ KS c' (c:cs') | (c',cs') <- select cs ]

-- | Given a threshold radius and a list of /four/ mutually tangent
--   circles, generate the Apollonian gasket containing those circles.
--   Stop the recursion when encountering a circle with an (unsigned)
--   radius smaller than the threshold.
apollonian :: RealFloat n => n -> [Circle n] -> [Circle n]
apollonian thresh cs
  = (cs++)
  . concat
  . map (maybe [] flatten . prune p . fmap selected)
  . apollonianTrees
  $ cs
  where
    p c = radius c >= thresh

-- | Given a set of /four/ mutually tangent circles, generate the
--   infinite Apollonian tree rooted at the given set, represented as
--   a list of four subtrees.  Each node in the tree is a kissing set
--   with one circle selected which has just been flipped.  The three
--   children of a node represent the kissing sets obtained by
--   selecting each of the other three circles and flipping them.  The
--   initial roots of the four trees are chosen by selecting and
--   flipping each of the circles in the starting set. This
--   representation has the property that each circle in the
--   Apollonian gasket is the selected circle in exactly one node
--   (except that the initial four circles never appear as the
--   selected circle in any node).
apollonianTrees :: RealFloat n => [Circle n] -> [Tree (KissingSet (Circle n))]
apollonianTrees = map (apollonianTree . flipSelected) . kissingSets

-- | Generate a single Apollonian tree from a root kissing set.  See
--   the documentation for 'apollonianTrees' for an explanation.
apollonianTree :: RealFloat n => KissingSet (Circle n) -> Tree (KissingSet (Circle n))
apollonianTree = unfoldTree (id &&& (map flipSelected . selectOthers))

-- | Prune a tree at the shallowest points where the predicate is not
--   satisfied.
prune :: (a -> Bool) -> Tree a -> Maybe (Tree a)
prune p (Node a ts)
  | not (p a) = Nothing
  | otherwise = Just $ Node a (catMaybes (map (prune p) ts))

------------------------------------------------------------
--  Diagram generation
------------------------------------------------------------

-- | Draw a circle.
drawCircle :: (Renderable (Path V2 n) b, TypeableFloat n) =>
              Circle n -> QDiagram b V2 n Any
drawCircle c = circle (radius c) # moveTo (center c)
                                 # fcA transparent

-- | Draw a generated gasket, using a line width 0.003 times the
--   radius of the largest circle.
drawGasket :: (Renderable (Path V2 n) b, TypeableFloat n) =>
              [Circle n] -> QDiagram b V2 n Any
drawGasket cs = F.foldMap drawCircle cs

-- | Draw an Apollonian gasket: the first argument is the threshold;
--   the recursion will stop upon reaching circles with radii less than
--   it. The next three arguments are bends of three circles.
apollonianGasket :: (Renderable (Path V2 n) b, TypeableFloat n)
                 => n -> n -> n -> n -> QDiagram b V2 n Any
apollonianGasket thresh b1 b2 b3 = drawGasket . apollonian thresh $ (initialConfig b1 b2 b3)

------------------------------------------------------------
-- Some notes on floating-point error
-- (only for the intrepid)
------------------------------------------------------------
{-

-- code from Gerald Gutierrez, personal communication

module Main where

import           Data.Complex
import           Diagrams.Backend.SVG.CmdLine
import           Diagrams.Prelude

-- ------^---------^---------^---------^---------^---------^---------^--------

data Circle = Circle Double (Complex Double) deriving (Show)

descartes a b c
  = (s + r, s - r)
  where
    s = a + b + c
    r = 2 * sqrt ((a * b) + (b * c) + (c * a))

descartesDual a b c d
  = 2 * (a + b + c) - d

soddies (Circle k1 b1) (Circle k2 b2) (Circle k3 b3)
  = ( Circle k4 b4
    , Circle k5 b5 )
  where
    (k4, k5) = descartes k1 k2 k3
    (b4, b5) = descartes b1 b2 b3

soddiesDual (Circle k1 b1) (Circle k2 b2) (Circle k3 b3) (Circle k4 b4)
  = Circle (descartesDual k1 k2 k3 k4) (descartesDual b1 b2 b3 b4)

mutuallyTangentCirclesFromTriangle z1 z2 z3
  = ( Circle k1 (z1 * (k1 :+ 0))
    , Circle k2 (z2 * (k2 :+ 0))
    , Circle k3 (z3 * (k3 :+ 0)) )
  where
    a = magnitude (z2 - z3)
    b = magnitude (z3 - z1)
    c = magnitude (z1 - z2)
    s = (a + b + c) / 2
    k1 = 1 / (s - a)
    k2 = 1 / (s - b)
    k3 = 1 / (s - c)

main :: IO ()
main = mainWith picture

pic = mainWith picture

mkCircle :: Circle -> Diagram B
mkCircle (Circle k b)
  = circle (1 / k) # moveTo (p2 (realPart z, imagPart z))
  where
    z = b / (k :+ 0)

picture :: Diagram B
picture
  = mkCircle c1 <> mkCircle c2 <> mkCircle c3 <> mkCircle c4 <> mkCircle c5
  where
    (c1, c2, c3) = mutuallyTangentCirclesFromTriangle z1 z2 z3
    (c4, c5) = soddies c1 c2 c3

    -- z1 = 0 :+ 0
    -- z2 = 3 :+ 0
    -- z3 = 0 :+ 4

    -- z1 = (-0.546) :+ (-0.755)
    -- z2 = ( 0.341) :+ (-0.755)
    -- z3 = (-0.250) :+ ( 0.428)

ofsBad = 0.15397 -- doesn't work
ofsGood = 0.15398 -- works

ofs = ofsGood

z1 = ofs + ((-0.546) :+ (-0.755))
z2 = ofs + (( 0.341) :+ (-0.755))
z3 = ofs + ((-0.250) :+ ( 0.428))

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

Email to Gerald Gutierrez, 30 Sep 2016:

I got a chance to sit down and think hard about your code today, and
I think I have figured out what the problem is.

If you look at the outputs of 'soddies c1 c2 c3' using the two
different values for 'ofs', you will see that they are *almost* the
same, except that the complex numbers have been switched (though in
fact their real components are almost the same so you only notice the
difference in the imaginary components).  This clearly causes
incorrect results since the y-coordinates represented by the imaginary
components are now getting scaled by different bend values.  So the
resulting circles are of the right size and have (close to) the
correct x-coordinates, but their y-coordinates are wrong.

The problem is that in the 'soddies' function, you make independent
calls to 'descartes k1 k2 k3' (to solve for the bends) and 'descartes
b1 b2 b3' (to solve for the bend-center products), and then *assume*
that they return their solutions *in the same order*, so that you can
match up the first values to make one circle and the second values to
make another circle.  I would guess that this is *usually* true but
apparently not when certain values are hovering right around a branch
cut of sqrt, or something like that.

I think my code in Diagrams.TwoD.Apollonian suffers from the same
problem.  Ultimately I think it is due to the inherent inaccuracy of
floating-point numbers; there is nothing wrong with the formula
itself.  It would be nice to figure out how to correct for this, but I
am not sure how off the top of my head.  The interesting thing is that
switching the bend-center products does not seem to violate the
generalized Descartes' Theorem at all --- so it would seem that it
does not actually completely characterize mutually tangent circles,
that is, there exist sets of circles satisfying the theorem which are
not in fact mutually tangent.

-}


{-# LANGUAGE FlexibleContexts #-}

module SVM
  ( multiplyByItself
  , testmatrix
  , testvector
  , replicateVector
  , replicateVectorSquared
  , makeLabelAgreementMatrix
  , makeQuadraticMatrix
  , testmatrixsize
  , alphasQuadProg
  , trainPLAandSVM
  , countSV
  ) where

import           LinearRegression                (createMatrixX,
                                                  createRandomPoints,
                                                  createVectorY,
                                                  makeTargetFunction, y)
import           Numeric.LinearAlgebra
import           Numeric.LinearAlgebra.Data
import           Numeric.LinearAlgebra.HMatrix   as HMatrix
import           Numeric.Minimization.QuadProgPP
import           PLA

----------------------------------------------------
-- Solutions to Homework 7 on SVM
----------------------------------------------------
-- | a test matrix - not part of homework
testmatrix :: Matrix R
testmatrix = matrix 2 [1, 1, 1, -1, -1, -1, 3, 4, 5, 6]

testmatrixsize = size testmatrix

-- | a test vector - not part of homework
testvector :: Vector R
testvector = vector [-1, 1, 1, -1, 1]

-- | create a matrix where every entry x_n_m is the dot product of the nth vector with the mth vector
multiplyByItself :: Matrix R -> Matrix R
multiplyByItself matrixA = matrixA HMatrix.<> (tr matrixA)

-- | make a matrix where every entry corresponds to the product of the labels of the corresponding data - it will be 1 if they agree and -1 otherwise
makeLabelAgreementMatrix :: Vector R -> Matrix R
makeLabelAgreementMatrix labelvector =
  diag labelvector HMatrix.<> replicateVectorSquared labelvector

-- | make a matrix form a vector by repeating the vector n times and arranging into n rows, each corresponding to the vector
replicateVector :: Int -> Vector R -> Matrix R
replicateVector n v = fromRows $ replicate n v

-- | make a squared matrix from a vector, such that each rows corresponds to the vector
replicateVectorSquared :: Vector R -> Matrix R
replicateVectorSquared v = replicateVector (size v) v

-- | makes the matrix to pass to quadratix programming
makeQuadraticMatrix :: Matrix R -> Vector R -> Matrix R
makeQuadraticMatrix dataMatrix labelVector =
  multiplyByItself dataMatrix * makeLabelAgreementMatrix labelVector

makeQuadraticMatrix' :: Matrix R -> Vector R -> Matrix R
makeQuadraticMatrix' dataMatrix labelVector = quadMatrix + smallValtoDiag
  where
    quadMatrix = makeQuadraticMatrix dataMatrix labelVector
    smallValtoDiag = diag $ konst 0.00000000001 (size labelVector)

-- | solves quadratic Programming on the input data matrix and label Vector
alphasQuadProg ::
     Matrix R -> Vector R -> Either QuadProgPPError (Vector R, Double)
alphasQuadProg dataMatrix labelVector =
  solveQuadProg
    (matrixA, vectorB)
    (Just (labelVecMatrix, zeros))
    (Just (idMatrix, zeros))
  where
    matrixA = makeQuadraticMatrix' dataMatrix labelVector
    vectorB = konst (-1) (size labelVector)
    labelVecMatrix = diag labelVector
    idMatrix = ident (size labelVector)
    zeros = konst 0 (size labelVector)

-- | Creates the data matrix from a list of data points
createDataMatrix :: [(R, R)] -> Matrix R
createDataMatrix listOfPoints = matrix 2 listOfNumbers
  where
    listOfNumbers = concat [[a, b] | (a, b) <- listOfPoints]

setSmallTo0 x
  | x < (10 ** (-4)) = 0
  | otherwise = x

countSV vector = length . filter (/= 0) $ toList vector

-- | trains a perceptron and SVM
trainPLAandSVM :: Int -> IO ()
trainPLAandSVM n
    --making target function, training and testing points
    -----------------------------------------------------
 = do
  target <- makeTargetFunction
  trainpoints <- createRandomPoints n
  testpoints <- createRandomPoints 1000
  let trainX = createDataMatrix trainpoints
  let trainY = createVectorY (y target) trainpoints
  let testX = createDataMatrix testpoints
  let testY = createVectorY (y target) testpoints
    --Perceptron
    ---------------------------------
  let initialWeights = (0, 0, 0)
  (finalWeights, epochs) <-
    trainPLAWithInitial initialWeights trainpoints target
  let misclassifiedTestPoints =
        length $ filter (isMisclassified target finalWeights) testpoints
  let prob = fromIntegral misclassifiedTestPoints / 1000
    --SVM
    --------------------------
  let quadmatrix = makeQuadraticMatrix trainX trainY
  let labelVecMatrix = asColumn trainY
  let alphas = alphasQuadProg trainX trainY
  let alphasModified = fmap (cmap setSmallTo0 . fst) alphas
  let numSVs = fmap countSV alphasModified
    --Printing the output
    ---------------------------
  putStrLn "Perceptron:"
  putStrLn "-------------------------"
  putStr "Weights: "
  print finalWeights
  putStr "Epochs: "
  print epochs
  putStr "Probability f /= g: "
  print prob
  putStrLn "Support Vector Machine:"
  putStrLn "-------------------------"
  putStr "Alphas:"
  print alphas
  putStr "Alphas very small set ot 0:"
  print alphasModified
  putStr "number of SVs:"
  print numSVs


module GaussianPinwheel where

import           Control.Parallel.Strategies
import           Data.Array.Repa                          as R
import           Data.Complex                             as C
import           Data.List                                as L
import           Data.Vector.Storable                     as VS
import           Data.Vector.Unboxed                      as VU
import           STC.Plan
import           Filter.Utils
import qualified FourierPinwheel.Filtering                as FP
import           FourierPinwheel.GaussianEnvelopePinwheel
import           Graphics.Rendering.Chart.Backend.Cairo
import           Graphics.Rendering.Chart.Easy
import           Image.IO
import           Math.Gamma
import           Pinwheel.FourierSeries2D
import           System.Directory
import           System.Environment
import           System.FilePath
import           Text.Printf
import           Utils.BLAS
import           Utils.Distribution
import           Utils.List

main = do
  args@(numR2FreqsStr:numThetaFreqStr:numRFreqStr:numPointStr:numThetaStr:numRStr:angularFreqStr:radialFreqStr:stdStr:sigmaStr:_) <-
    getArgs
  let numR2Freqs = read numR2FreqsStr :: Int
      numThetaFreq = read numThetaFreqStr :: Int
      numRFreq = read numRFreqStr :: Int
      numPoint = read numPointStr :: Int
      numTheta = read numThetaStr :: Int
      numR = read numRStr :: Int
      angularFreq = read angularFreqStr :: Int
      radialFreq = read radialFreqStr :: Int
      std = read stdStr :: Double
      sigma = read sigmaStr :: Double
      periodR2 = fromIntegral numR2Freqs
      periodEnv = periodR2 ^ 2 / 4
      folderPath = "output/test/GaussianPinwheel"
  createDirectoryIfMissing True folderPath
  --DFT Plan
  initVec <- generateRadomVector (numR2Freqs ^ 2)
  lock <- getFFTWLock
  plan <-
    fst <$>
    (idft1dGPlan lock emptyPlan [numR2Freqs, numR2Freqs] [0, 1] initVec >>= \(plan, vec) ->
       dft1dGPlan lock plan [numR2Freqs, numR2Freqs] [0, 1] vec)
  let a = 1 / (std * sqrt 2)
      pinwheelCoef =
        centerHollowArray numR2Freqs $
        createFrequencyArray
          numR2Freqs
          (gaussianPinwheelFourierCoefficients
             numR2Freqs
             periodR2
             a
             sigma
             angularFreq
             radialFreq
             periodEnv)
  plotImageRepaComplex (folderPath </> "GaussianPinwheelCoef.png") .
    ImageRepa 8 . computeS . extend (Z :. (1 :: Int) :. All :. All) $
    pinwheelCoef
  pinwheel <-
    dftExecute plan (DFTPlanID IDFT1DG [numR2Freqs, numR2Freqs] [0, 1]) .
    VU.convert . toUnboxed . computeS . makeFilter2D $
    pinwheelCoef
  plotImageRepaComplex (folderPath </> "GaussianPinwheel.png") .
    ImageRepa 8 .
    computeS .
    extend (Z :. (1 :: Int) :. All :. All) .
    makeFilter2DInverse .
    fromUnboxed (Z :. numR2Freqs :. numR2Freqs) . VS.convert $
    pinwheel
  let pinwheel1 =
        computeS $
        createFrequencyArray
          numR2Freqs
          (\phi rho ->
             ((exp ((-1) * (rho / std) ^ 2 / 2)) :+ 0) *
             (rho :+ 0) **
             (sigma :+ ((-2) * pi * fromIntegral radialFreq / log periodEnv)) *
             cis ((-phi) * fromIntegral angularFreq))
  pinwheelCoef1 <-
    dftExecute plan (DFTPlanID DFT1DG [numR2Freqs, numR2Freqs] [0, 1]) .
    VU.convert . toUnboxed . computeS . makeFilter2D $
    pinwheel1
  plotImageRepaComplex (folderPath </> "GaussianPinwheelCoef1.png") .
    ImageRepa 8 .
    computeS .
    extend (Z :. (1 :: Int) :. All :. All) .
    makeFilter2DInverse .
    fromUnboxed (Z :. numR2Freqs :. numR2Freqs) . VS.convert $
    pinwheelCoef1
  plotImageRepaComplex (folderPath </> "GaussianPinwheel1.png") .
    ImageRepa 8 .
    computeS .
    extend (Z :. (1 :: Int) :. All :. All) .
    -- makeFilter2DInverse .
    fromUnboxed (Z :. numR2Freqs :. numR2Freqs) . VS.convert . toUnboxed $
    pinwheel1


module DFTSpec (
  dftSpec
)
where
import Test.Hspec
import Test.QuickCheck
import Control.Exception (evaluate)
import DFT (dft, idft)
import Data.Complex
import Data.List (zip, repeat)

dftSpec :: Spec
dftSpec = do
  describe "dft and inverse dft tests..." $ do
    it "checks whether composition of inverse dft and dft returns the original sequence" $
      property $ prop_dft_correct

prop_dft_correct :: [Float] -> Bool
prop_dft_correct xs = are_numbers_nearly_equal ((idft . dft . map (\x -> x :+ 0) ) ys) ys
  where ys = preprocess xs

preprocess :: [Float] -> [Float]
preprocess [] = []
preprocess xs = take targetLength (xs ++ (repeat 0))
  where targetLength = 2 ^ ceiling (log ((fromIntegral . length) xs) / log 2)

are_numbers_nearly_equal :: [Complex Float] -> [Float] -> Bool
are_numbers_nearly_equal [] [] = True
are_numbers_nearly_equal (x:xs) (y:ys)
  | realPartsEq = are_numbers_nearly_equal xs ys
  | otherwise   = False
  where realPartsEq = nearly_equal (realPart x) y

nearly_equal :: Float -> Float -> Bool
nearly_equal x y = abs (x - y) <= 1e-4


module NeuralNet.Example (
  Example,
  ExampleSet (),
  createExampleSet,
  exampleSetX,
  exampleSetY,
  exampleSetM,
  exampleSetN,
  splitExampleSet
) where

import Numeric.LinearAlgebra
import Data.List (nub)

type Example = ([Double], Double)

data ExampleSet = ExampleSet [Example] (Matrix Double) (Matrix Double)
  deriving (Show, Eq)

createExampleSet :: [Example] -> ExampleSet
createExampleSet e
  | numUniqueExampleSizes > 1  = error ("All examples must have same size (given " ++ show uniqueExampleSizes ++ ")")
  | numUniqueExampleSizes == 0 = error "No examples provided"
  | n == 0                     = error "Empty example provided"
  | otherwise                  = ExampleSet e x y
    where
      exampleSizes = map (length . fst) e
      uniqueExampleSizes = nub exampleSizes
      numUniqueExampleSizes = length uniqueExampleSizes
      n = head exampleSizes
      x = tr (fromLists (map fst e))
      y = fromLists [map snd e]

exampleSetX :: ExampleSet -> Matrix Double
exampleSetX (ExampleSet _ x _) = x

exampleSetY :: ExampleSet -> Matrix Double
exampleSetY (ExampleSet _ _ y) = y

exampleSetN :: ExampleSet -> Int
exampleSetN = rows . exampleSetX

exampleSetM :: ExampleSet -> Int
exampleSetM (ExampleSet e _ _) = length e

splitExampleSet :: Double -> ExampleSet -> (ExampleSet, ExampleSet)
splitExampleSet ratio (ExampleSet e _ _) = (createExampleSet leftExamples, createExampleSet rightExamples)
  where
    (leftExamples, rightExamples) = splitAt (round (ratio * fromIntegral (length e))) e


import Data.Complex

main :: IO ()
main = do let res = dft (map (\x -> x :+ 0) [1..10])
       	  putStrLn $ show res

dft :: RealFloat a => [Complex a] -> [Complex a]
dft x = map (\(_, k) -> singleDFT k idxList) idxList
  where idxList = zip x [0..]

singleDFT :: RealFloat a => Int -> [(Complex a, Int)] -> Complex a
singleDFT k x = sum $ map (\(e, n) -> (e *) $ fCoeff k n $ length x) $ x

fCoeff :: RealFloat a => Int -> Int -> Int -> Complex a
fCoeff k n n_tot = exp (0.0 :+ ((-2.0) * pi * (fromIntegral $ k * n) / (fromIntegral n_tot)))


module Fourier.FFT where

import Control.Parallel.Strategies
import Data.Complex(Complex,Complex((:+)),realPart,imagPart)
import Data.Matrix(matrix,fromList)

-- Cooley & Tukey Fast Fourier transformation of a sequence
fft :: [Double] -> [Complex Double]
fft xs = dft xs

-- Typical Discrete Fourier transformation of a sequence
dft :: [Double] -> [Complex Double]
dft [] = []
dft xs = do { k <- [0..length xs - 1]
  ; let re = xk k xs cos
  ; let im = -1 * (xk k xs sin)
  ; return (re :+ im)}

-- Calculate the sum of coefficience at [k]
-- Formula: xk = sum x[n] f(2pi * k * n/N)
xk :: Int -> [Double] -> (Double -> Double) -> Double
xk k xs f = let ys = do { (i,x) <- zip [0..] xs
  ; let n = fromIntegral $ length xs
  ; return (x * f( 2.0 * pi * (fromIntegral k) * (fromIntegral i) / n)) }
    in sum ys


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

Regularization.
-}

module MachineLearning.Regularization
(
  Regularization(..)
  , costReg
  , gradientReg
)

where

import MachineLearning.Types (R, Vector)
import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as LA

-- | Regularization
data Regularization = RegNone -- ^ No regularization
                    | L2 R    -- ^ L2 Regularization

-- | Calculates regularization for Model.cost function.
-- It takes regularization parameter and theta.
costReg :: Regularization -> Vector -> R
costReg RegNone _ = 0
costReg (L2 lambda) theta = (thetaReg LA.<.> thetaReg) * lambda * 0.5
  where thetaReg = V.tail theta

-- | Calculates regularization for Model.gradient function.
-- It takes regularization parameter and theta.
gradientReg :: Regularization -> Vector -> Vector
gradientReg RegNone _ = 0
gradientReg (L2 lambda) theta = (LA.scalar lambda) * thetaReg
  where thetaReg = theta V.// [(0, 0)]


module PCA.GPExample where

import Universum hiding (transpose, Vector)

import Data.Vector.Unboxed as V (fromList)

import Data.Array.Repa
import Numeric.LinearAlgebra.Repa hiding (Matrix, Vector)

import PCA.GaussianProcess
import PCA.Types
import PCA.Util

testList :: [Double]
testList = [ -5.0
           , -4.79591837
           , -4.59183673
           , -4.3877551
           , -4.18367347
           , -3.97959184
           , -3.7755102
           , -3.57142857
           , -3.36734694
           , -3.16326531
           , -2.95918367
           , -2.75510204
           , -2.55102041
           , -2.34693878
           , -2.14285714
           , -1.93877551
           , -1.73469388
           , -1.53061224
           , -1.32653061
           , -1.12244898
           , -0.91836735
           , -0.71428571
           , -0.51020408
           , -0.30612245
           , -0.10204082
           ,  0.10204082
           ,  0.30612245
           ,  0.51020408
           ,  0.71428571
           ,  0.91836735
           ,  1.12244898
           ,  1.32653061
           ,  1.53061224
           ,  1.73469388
           ,  1.93877551
           ,  2.14285714
           ,  2.34693878
           ,  2.55102041
           ,  2.75510204
           ,  2.95918367
           ,  3.16326531
           ,  3.36734694
           ,  3.57142857
           ,  3.7755102
           ,  3.97959184
           ,  4.18367347
           ,  4.3877551
           ,  4.59183673
           ,  4.79591837
           ,  5.0
           ]

xTest :: Vector D Double
xTest = delay $ fromUnboxed (Z :. 50) (V.fromList testList)

inputObserve :: InputObservations Double
inputObserve = InputObservations xTest

computeSD
    :: Shape sh
    => Array D sh Double
    -> Array U sh Double
computeSD = computeS @D @_ @_ @U

sqDist
    :: Vector D Double
    -> Vector D Double
    -> Matrix D Double
sqDist vec1 vec2 = matrixSquare vec1 ++^ (transposeMatrix matrix2')
     where
         matrix2' = matrixSquare vec2 --^
                      ((delay . smap ((*) 2)) $
                      matrix1 `mulS` matrix2)
         matrixSquare matrix = smap flipExp matrix
         flipExp = (flip (^)) 2
         matrix1 = toMatrix' $ vec1
         matrix2 = transposeMatrix . toMatrix' $ vec2

kernelFunction
    :: Vector D Double
    -> Vector D Double
    -> Matrix D Double
kernelFunction matrix1 matrix2 =
    smap fun $ sqDist matrix1 matrix2
    where
        fun = exp . ((*) (-0.5)) . ((*) (1/0.1))

xTrainList :: [Double]
xTrainList =
    [ -4
    , -3
    , -2
    , -1
    , 1
    ]

xTrain :: Vector D Double
xTrain = delay $ fromUnboxed (Z :. 5) (V.fromList xTrainList)

yTrain :: Vector D Double
yTrain = smap sin xTrain

testTrainingData :: GPTrainingData Double
testTrainingData = GPTrainingData xTrain yTrain

k, kS, l, lK :: Matrix D Double
k = kernelFunction xTrain xTrain
kS = kernelFunction xTrain xTest
l = cholSH (k +^ (delay . smap (* 0.0005) $ identD 50))
lK = fromMaybe (error "izviniti") (delay <$> linearSolveS l kS)

testGaussianProcess :: GaussianProcess Double
testGaussianProcess = GaussianProcess kernelFunction


module MachineLearning.NeuralNetwork.WeightInitializationTest
(
  tests
)

where

import Test.Framework (testGroup)
import Test.Framework.Providers.HUnit
import Test.HUnit
import Test.HUnit.Approx
import Test.HUnit.Plus
import Control.Monad (replicateM)
import qualified Data.Vector.Storable as V
import qualified Numeric.LinearAlgebra as LA
import qualified Numeric.Morpheus.Statistics as Stat
import qualified Control.Monad.Random as RndM
import MachineLearning.NeuralNetwork.WeightInitialization

assertDistribution eps x mu e = do
  let mean = Stat.mean x
  assertApproxEqual "mean" eps mu mean
  assertBool "maximum" $ (V.maximum x) <= e
  assertBool "minimum" $ (V.minimum x) >= (-e)

generateData algo n sz = do
   rndList <- replicateM n $ RndM.evalRandIO (algo sz)
   let (bs, ws) = unzip rndList
       b = LA.flatten $ LA.fromBlocks [bs]
       w = LA.flatten $ LA.fromBlocks [ws]
   return (b, w)

testWeightInitAlgo eps algo n sz mu e = do
  (b, w) <- generateData algo n sz
  assertDistribution eps b 0 0
  assertDistribution eps w mu e

heEps (r, c) = sqrt (2/(fromIntegral $ r + c))
nguyenEps (r, c) = (sqrt 6) / (sqrt . fromIntegral $ r + c)

sz = (7, 5)

tests = [ testGroup "flatten" [
            testCase "hu" $ testWeightInitAlgo 1e-1 he 100 sz 0 (heEps sz)
            , testCase "nguyen" $ testWeightInitAlgo 1e-1 nguyen 100 sz 0 (nguyenEps sz)
            ]
        ]


module AI.Learning.Perceptron where

import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Util

perceptronPredict :: Vector Double -> Matrix Double -> Vector Double
perceptronPredict weights x = step (x <> weights)

perceptronCost :: Vector Double -> Vector Double -> Vector Double -> Double
perceptronCost y yhat = undefined

----------------------
-- Gradient Descent --
----------------------

gradientDescent :: (Vector Double -> Vector Double) -- f
                -> Vector Double                    -- x0
                -> Double                           -- alpha
                -> Double                           -- tol
                -> Vector Double
gradientDescent g x0 alpha tol = go x0 (fun x0)
    where
        go x x' = if converged x x'
                    then x'
                    else go x' (fun x')
        converged a b = norm b / norm a - 1 < tol
        fun x = gradientDescentStep g alpha x

gradientDescentStep :: (Vector Double -> Vector Double) -> Double -> Vector Double -> Vector Double
gradientDescentStep g alpha x = x - alpha `scale` g x


module Main where

import qualified Statistics.Matrix as M
import qualified Statistics.Matrix.Fast as F
import qualified Statistics.Matrix.Fast.Algorithms as FA
import           Statistics.Matrix (Matrix (..))
import qualified Statistics.Matrix.Algorithms as A

import qualified Data.Vector.Unboxed         as U
import           Data.Vector.Unboxed         (Vector)

import qualified System.Random.MWC as Mwc

import qualified Chronos.Bench as C

n :: Int
n = 100

testVector :: IO (Vector Double)
testVector = do
    gen <- Mwc.create
    Mwc.uniformVector gen (n*n)

testMatrix :: IO Matrix
testMatrix = do
    vec <- testVector
    return $ Matrix n n vec

runtimelight :: Vector Double -> Matrix -> IO ()
runtimelight v a = do
    let
      v2 = U.take n v

    C.defaultMainWith (C.defaultConfig {C.timeout = Just 3}) [
                   C.bench "norm" M.norm v2,
                   C.bench "Fast.norm" F.norm v2,

                   C.bench "multiplyV" (M.multiplyV a) (v2),
                   C.bench "Fast.multiplyV" (F.multiplyV a) (v2),

                   C.bench "transpose" M.transpose a,
                   C.bench "Fast.transpose" F.transpose a ,
                   C.bench "ident" M.ident n,
                   C.bench "diag" M.diag v2
                   ]

runtimeheavy :: Matrix -> Matrix -> IO ()
runtimeheavy a b = do

    C.defaultMainWith (C.defaultConfig {C.timeout = Just 1}) [
                   C.bench "multiply" (M.multiply a) b,
                   C.bench "Fast.multiply" (F.multiply a) b,
                   C.bench "qr" A.qr a,
                   C.bench "Fast.qr" FA.qr a
                   ]

main :: IO ()
main = do
    v <- testVector
    a <- testMatrix
    b <- testMatrix

    --
    putStrLn "---Benchmarking light operations---"
    -- we split heavy and light, we lose some precision in the bar plots from chronos
    runtimelight v a
    putStrLn "---Benchmarking heavy operations---"
    runtimeheavy a b


-- | This module provides generic functionality to deal with ensembles in
-- statistical mechanics.

module StatisticalMechanics.Ensemble where

import Numeric.Log

import Statistics.Probability

-- | The state probability functions provide conversion from some types @a@
-- into non-normalized probabilities. For "real" applications, using the
-- @logProbability@ function is preferred. This functions allows for easy
-- abstraction when types @a@ are given as fractions of some actual value (say:
-- deka-cal), or are discretized.
--
-- The returned values are not normalized, because we do not now the total
-- evidence @Z@ until integration over all states has happened -- which is not
-- feasible in a number of problems.
--
-- TODO replace @()@ with temperature and results with non-normalized @P@ or
-- @LogP@, depending. At some point we want to have type-level physical
-- quantities, hence the need for the second type.

class StateProbability a where
  -- | Given a temperature and a state "energy", return the corresponding
  -- non-normalized probability.
  stateProbability
    ∷ Double
    -- ^ this is @k*T@
    → a
    -- ^ the energy (or discretized energy)
    → Probability NotNormalized Double
    -- ^ probability of being in state @a@, but only proportional up to @1/Z@.
  stateLogProbability
    ∷ Double
    -- ^ this is @1/(k * T)@
    → a
    -- ^ the energy (or discretized energy)
    → Log (Probability NotNormalized Double)
    -- ^ resulting probability

instance StateProbability Double where
  stateProbability kT x = Prob . exp . negate $ x/kT
  {-# Inline stateProbability #-}
  --stateLogProbability kT x = Exp . log . Prob . exp . negate $ x/kT
  stateLogProbability kT x = Exp . Prob . negate $ x/kT
  {-# Inline stateLogProbability #-}


import Data.Array.CArray
import Data.Complex
import Math.FFT (dft, idft) -- Binding to fftw

type Vector = CArray Int (Complex Double)

calculateEnergy :: Double -> Vector -> Vector -> Vector -> Double
calculateEnergy dx kin pot wfc = (* dx) . sum . map realPart $ elems total
  where
    total = liftArray2 (+) kineticE potentialE
    potentialE = wfcConj .* pot .* wfc
    kineticE = wfcConj .* idft (kin .* dft wfc)
    wfcConj = liftArray conjugate wfc
    a .* b = liftArray2 (*) a b


module Hw5
    (Signal,
    Vec(..),
    rd,
    absolute,
    range,
    dft,
    idft,
    realV,
    low_pass',
    low_pass,
    fft,
    ifft,
    makeNoise)
    where

import Data.Complex
import Debug.Trace
import GHC.Base (liftA2)
import System.Random
-- import Control.Monad.Reader

-- {-# LANGUAGE  KindSignatures  #-}
-- {-# LANGUAGE  MultiParamTypeClasses  #-}

newtype Vec a = Vec {runVec :: [a]}
newtype  Reader r a = Reader { runReader  :: r -> a }
type Signal = Vec (Complex Double)

imagV :: Num a => Vec a -> Vec (Complex a)
realV :: Num a => Vec a -> Vec (Complex a)
range :: Double -> Double -> Double -> [Double]
absolute :: Vec (Complex Double) -> Vec Double
rd :: Int -> Vec Double -> Vec Double
twiddle :: Double -> Double -> Signal
dft :: Signal -> Signal
idft :: Signal -> Signal
mask :: Int -> Int -> Signal
fft :: Signal -> Signal
ifft :: Signal -> Signal
makeNoise :: Random a => Int -> Int -> a -> a -> Vec a

makeNoise seed n low high =
    let x = mkStdGen seed
        genNum l h = randomR (l, h)
        genList 1 l h g = [c] where (c,y) = genNum l h g
        genList n l h g = c : genList (n-1) l h y where (c,y) = genNum l h g
        in
            Vec $ genList n low high x

length' (Vec x) = length x

rd n = fmap (\x -> fromIntegral (round $ c * x) / c)
    where c = 10^n

absolute = fmap (\(r:+i) -> sqrt(r*r + i*i))

range from to count = map (\x -> from + x * step) [0..count-1]
    where step = (to - from)/count

imagV (Vec a) = Vec $ map (0:+) a
realV (Vec a) = Vec $ map (:+0) a

instance Show a => Show (Vec a) where
    show (Vec lst) = "[" ++ drop 1 lst' ++ "]"
        where
            lst' = mconcat $ map (\x -> " " ++ show x) lst

instance Functor Vec where
    fmap f (Vec x) = Vec $ map f x

instance Applicative Vec where
    pure = Vec . repeat
    (Vec f) <*> (Vec x) = Vec $ zipWith ($) f x
    liftA2 f (Vec x) (Vec y) = Vec $ zipWith f x y

instance Foldable Vec where
    foldr f c (Vec a) = Prelude.foldr f c a

instance Semigroup (Vec a) where
    Vec a <> Vec b = Vec $ a ++ b

instance Monoid (Vec a) where
    mempty = Vec []

instance Num a => Num (Vec a) where
    (+) = liftA2 (+)
    (-) = liftA2 (-)
    (*) = liftA2 (*)
    negate = fmap negate
    abs = fmap abs
    signum = fmap signum
    fromInteger x = pure $ fromInteger x

instance (Floating a) => Fractional (Vec a) where
    (/) = liftA2 (/)
    fromRational x = pure $ fromRational x

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

mask freq n = realV $ Vec $ one ++ zero ++ one where
    one = (take freq $ repeat 1)
    zero = (take (n-freq*2) $ repeat 0)

low_pass' :: Int -> Signal -> Signal

low_pass' v sig =
    let
        m = mask v $ length sig
    in idft $ m * dft sig

twiddle n k =
    let a = [0.. (n - 1)]
        f x = exp (0:+ x * (-2*pi*k / n))
    in Vec $ fmap f a

dft x =
    let bigN = fromIntegral $ length x -- length of x
        n = Vec [0 .. bigN-1]
        f k = sum $ x * twiddle bigN k
    in fmap f n

idft x =
    let bigN = fromIntegral $ length x -- length of x
        cX = fmap conjugate x
        n = Vec [0 .. bigN-1]
        diC = (1.0 / bigN) :+ 0
        f k = sum $ cX * twiddle bigN k
    in conj diC $ fmap f n

conj :: Complex Double -> Signal -> Signal
conj b (Vec a) = fmap (\y -> b * conjugate y) (Vec a)

twidd n k = exp( imagV $ k * pure (-2 * pi / fromIntegral n) )
twiddI n k = exp( imagV $ k * pure (2 * pi / fromIntegral n) )

trace_fft m x = trace (m ++ ": " ++ (show $ rd 2 $ absolute x)) x -- debugging helper to print fft results
fft x
    | n <= 16 = dft x
    | n <= 1 = x
    | otherwise =
        let (even, odd) = split $ runVec x
            (e, o) = (fft $ Vec even, fft $ Vec odd)
            k = Vec [0..]
            p = twidd n k
        in
            (e + p * o) <> (e - p * o)

    where
        n = length x
        split [] = ([], [])
        split [a] = ([a], [])
        split (a:b:c) = (a:x, b:y)
            where (x,y) = split c

ifft x
    | n <= 16 = idft x
    | n <= 1 = x
    | otherwise =
        let (even, odd) = split $ runVec x
            (e, o) = (fft $ Vec even, fft $ Vec odd)
            -- k = Vec [0..]
            bigN = fromIntegral n
            cE = fmap conjugate e
            cO = fmap conjugate o
            diC = (-1.0 / bigN) :+ 0
            p = twiddI n $ Vec [0..]
        in
            conj diC (e + p * o) <> conj diC (e - p * o)

    where
        n = length x
        split [] = ([], [])
        split [a] = ([a], [])
        split (a:b:c) = (a:x, b:y)
            where (x,y) = split c

low_pass :: Int -> Signal -> Signal

low_pass v sig =
    let
        m = mask v $ length sig
    in ifft $ m * fft sig


-----------------------------------------------------------------------------
-- |
-- Module      :  Finance.Hqfl.Pricer.Black
-- Copyright   :  (C) 2016 Mika'il Khan
-- License     :  (see the file LICENSE)
-- Maintainer  :  Mika'il Khan <co.kleisli@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
----------------------------------------------------------------------------
{-# LANGUAGE FlexibleInstances #-}

module Finance.Hqfl.Pricer.Black where

import Finance.Hqfl.Instrument
import Statistics.Distribution.Normal
import Data.Random

class Black a where
  price :: a -> Double -> Double -> Double

instance Black (Option Future) where
  price (Option (Future f) m European k t) r v =
    case m of
       Call -> exp (-r * t) * (f * cdf normal d1 - k * cdf normal d2)
       Put  -> exp (-r * t) * (k * cdf normal (-d2) - f * cdf normal (-d1))
    where d1 = (log (f / k) + ((v * v) / 2) * t) / (v * sqrt t)
          d2 = d1 - v * sqrt t
          normal = Normal (0 :: Double) 1


-- |

module DaySeven (examineFile) where
import Data.Vector.Unboxed (Vector, fromList, (!))
import qualified Data.Vector.Unboxed as V
import Statistics.Sample (mean)
import Statistics.Function (sort)

findOptimalFuelp2 :: Vector Int -> Int
findOptimalFuelp2 xs = minimum $ map (`calcFuel` xs) $ meanPositions xs
  where
    calcFuel = calcFuelBy sumOfNats

findOptimalFuelp1 :: Vector Int -> Int
findOptimalFuelp1 xs = (`calcFuel` xs) $ medianPos xs
  where
    calcFuel = calcFuelBy id

calcFuelBy :: (Int -> Int) -> Int -> Vector Int -> Int
calcFuelBy f x = V.foldl (\total pos -> total + f (abs (pos - x))) 0

-- | the sum of natural numbers
sumOfNats :: Int -> Int
sumOfNats n =  ((n*n) + n) `div` 2

meanPositions :: Vector Int -> [Int]
meanPositions vs = (map floor <> map ceiling) [mean $ V.map fromIntegral vs]

medianPos :: Vector Int -> Int
medianPos = floor . (\v -> sort v ! floor (fromIntegral (V.length v) / 2)) . V.map fromIntegral

examineFile :: String -> IO [Int]
examineFile xs = do
  positions <- fromList . (\x -> read $ "["++x++"]") <$> readFile xs
  return $ map (\f -> f positions) [findOptimalFuelp1,findOptimalFuelp2]


{-# language BangPatterns #-}
{-|
Module      : Fitness
Description : Fitness Function for Genetic Algorithm for Poly Regression
Copyright   : (c) Fabricio Olivetti de Franca, 2021
License     : GPL-3
Maintainer  : fabricio.olivetti@gmail.com
Stability   : experimental
Portability : POSIX
|-}

module Fitness (evalFitness, decode) where

import GA

import Data.List (foldl')
import Data.List.Split hiding (split)
import Numeric.LinearAlgebra ((<\>),(#>),(|||), sumElements, size, Matrix, Vector, fromRows, fromList)

-- | Creates a fitness function
evalFitness :: Int            -- ^ number of terms
            -> [[Double]]     -- ^ matrix X
            -> Vector Double  -- ^ vector y
            -> Solution (Poly n)       -- ^ solution to evaluate
            -> Solution (Poly n)
evalFitness nTerms xss ys sol =
  case _fitness sol of
       Nothing -> sol{ _coeffs = Just betas, _fitness = Just f }
       _       -> sol
  where
    zss    = decode xss (map _getPoly $ _chromo sol)
    betas  = zss <\> ys
    ysHat  = zss #> betas
    f      = mse ys ysHat

-- | Decodes the polynomial into a transformed matrix
decode :: [[Double]] -> [(Bool, Int)] -> Matrix Double
decode xss chromo = fromRows (map (evalPoly chromo) xss)

-- | Eval a single row from the dataset
evalPoly :: [(Bool, Int)] -> [Double] -> Vector Double
evalPoly chromo xs = fromList $ foldl' joinTerms [1.0] terms
  where
    nVars = length xs
    ix    = cycle [0..nVars-1]
    xss   = cycle xs
    terms = zip3 chromo xss ix

    joinTerms ts   ((False,_), _, 0)   = 1.0 : ts
    joinTerms ts   ((False,_), _, _)   = ts
    joinTerms ts   ((True, k), x, 0)   = x^k : ts
    joinTerms (t:ts) ((True,k), x, ix) = t * x^k : ts

-- | Calculates the mean squared error
mse :: Vector Double -> Vector Double -> Double
mse ys ysHat = s / fromIntegral (size ys)
  where
    s = sumElements $ (ys - ysHat)^2


-- |
-- Module      : Southpaw.Picasso.Shapes
-- Description : Various functions for creating mathematical shapes
-- Copyright   : (c) Jonatan H Sundqvist, year
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental|stable
-- Portability : POSIX (not sure)
--

-- Created date year

-- TODO | -
--        -

-- SPEC | -
--        -

---------------------------------------------------------------------------------------------------
-- API
---------------------------------------------------------------------------------------------------
module Southpaw.Picasso.Shapes where

---------------------------------------------------------------------------------------------------
-- We'll need these
---------------------------------------------------------------------------------------------------
import Data.Complex

import Southpaw.Math.Constants

---------------------------------------------------------------------------------------------------
-- Function
---------------------------------------------------------------------------------------------------
-- Geometry ---------------------------------------------------------------------------------------
-- |
-- TODO: Start angle
-- TODO: Invalid arguments (eg. sides < 3) (use Maybe?)
-- TODO: Make polymorphic
-- TODO: Move to geometry section
-- polygon :: (Floating f, RealFloat f) => Int -> f -> Complex f -> [Complex f]
polygon :: Integral int => int -> Double -> Complex Double -> [Complex Double]
polygon sides radius origin = [ let θ = arg n in origin + ((radius * cos θ):+(radius * sin θ)) | n <- [1..sides]]
    where arg n = fromIntegral n * (2*π)/fromIntegral sides

-- |
-- TODO: Simplify and expound comments
arrow :: Complex Double -> Complex Double -> Double -> Double -> Double -> [Complex Double]
arrow from to sl sw hw = [from     + straight (sw/2), --
                          shaftEnd + straight (sw/2), --
                          shaftEnd + straight (hw/2), --
                          to,                         --
                          shaftEnd - straight (hw/2), --
                          shaftEnd - straight (sw/2), --
                          from     - straight (sw/2)] --
    where along a b distance = (a +) . mkPolar distance . snd . polar $ b-a -- Walk distance along the from a to b
          normal a b = let (mag, arg) = polar (b-a) in mkPolar mag (arg+π/2)
          shaftEnd = along from to sl --
          straight = along (0:+0) (normal from to) -- Vector perpendicular to the centre line


module Mand where
import Data.List.Split
import Data.Scientific as Scientific
import Data.Complex

type CS = Complex Scientific
type S = Scientific

makeSci :: String -> String -> Scientific
makeSci a b = read (a ++ "e" ++ b) :: Scientific

csqrt :: (Floating a, RealFloat a) => Complex a -> Complex a
csqrt x = (m * cos (t) :+ m * sin(t))
  where
    p = polar x
    m = sqrt $ fst p
    t = (snd p)/2

--cubed_iteration c z  = c + z * cos (z ** z)
cubed_iteration :: RealFloat a => Complex a -> Complex a -> Complex a
cubed_iteration c z = c + z * z * z

new_iteration :: RealFloat a => Complex a -> Complex a -> Complex a -> Complex a
new_iteration c n_z o_z = c + n_z * o_z

zzcosMask :: RealFloat a => Complex a -> Bool
zzcosMask (x :+y) = ((x > -0.95 && x < 0.1) && (y < 0.47 && y > -0.47)) || (( x <= -0.95 && x > -1.25) && (abs y < 0.42)) || (abs y < 0.2 && x <= -1.25 && x > -1.45) || (abs y < 0.4 && x >= 0.1 && x < 0.2) || (abs y < 0.17 && (x > 0.6 && x < 0.78)) || (abs y < 0.11 && x > 0.4 && x <= 0.85)

zzcos_iteration :: RealFloat a => Complex a -> Complex a -> Complex a
zzcos_iteration c z = c + z * z * (cos z)

mand_iteration :: RealFloat a => Complex a -> Complex a -> Complex a
mand_iteration c z  = c + z*z

mand_pow_iteration :: RealFloat a => Int -> Complex a -> Complex a -> Complex a
mand_pow_iteration pow c z  = c + z^pow

mand_iterationA :: CS -> CS -> CS
mand_iterationA (c:+b) (z:+x)  = (c + z*z - x* x) :+ (b + 2*z*x)

cexp :: Floating a => Complex a -> Complex a
cexp (a :+ b) = (s * cos b :+ s * sin b)
  where
    s = exp a

csin :: RealFloat a => Complex a -> Complex a
csin x = ((realPart c1 + realPart c2)/2 :+ (imagPart c1 + imagPart c2)/2)
 where
  c1 = exp x
  c2 = exp $ negate x

cpow :: RealFloat a => Complex a -> Complex a -> Complex a
cpow x y = cexp $ y * log  x

mand :: (RealFloat a) => Either (Complex a) CS -> Int -> Int
mand (Left c) max = general mand_iteration (Just mandSive) c max
mand (Right c) _ = generalA mand_iterationA c

sciMagnitude :: Complex Scientific  -> Scientific
sciMagnitude (a :+b) = a * a + b * b

mandSive :: RealFloat a => Complex a -> Bool
mandSive c@(x:+y) = ( let b = c + (1:+0) in realPart(b*(conjugate b)) < 0.05) ||((x < 0) && ( realPart (c * (conjugate c))  < 0.4)) ||(x < 0.25 && x  >= 0 && abs y  < 0.5)  -- takes 16 seconds

--( let b = a + (1:+0) in realPart(b*(conjugate b)) < 0.05) ||((realPart a < 0) && ( realPart (a * (conjugate a))  < 0.4)) ||(realPart a < 0.25 && realPart a >= 0 && abs (imagPart a) < 0.5) =  max -1  -- takes 16 seconds

general :: RealFloat a => (Complex a -> Complex a -> Complex a) -> Maybe (Complex a -> Bool)  -> Complex a -> Int -> Int
general g Nothing a max = count_iterations 0 (0 :+ 0) a
  where
    count_iterations n e x
      | n == max = max -1
      | realPart (x * (conjugate x)) > 4 = n
      | otherwise = count_iterations (n +1) e $ g a x
general g (Just sive) a max
--  | ((realPart a) < 0.25) && ((realPart a) > (-0.5)) && (abs (imagPart a) < 0.5) = 255 takes 21 secods
-- removed real check: (imagPart a == 0 && realPart a < 0.25 && realPart a > -2) ||
  | sive a = max - 1
  | otherwise = count_iterations 0 (0 :+ 0) a
  where
    count_iterations n e x
      | n == max = max -1
      | realPart (x * (conjugate x)) > 4 = n
      | otherwise = count_iterations (n +1) e $ g a x

generalA :: (CS -> CS -> CS) -> CS -> Int
generalA g a = count_iterations 0 (0 :+ 0) a
  where
    count_iterations n e x
      -- | n >= 255  = 255
      | n >= 16581375 = 16581375
      -- if using sci
      -- | (sciMagnitude x ) > (makeSci "4" "0") = n
      -- | otherwise = count_iterations (n + 1) e  $ g a $ roundComplex x
      -- if using float
      | (realPart x)^2 + (imagPart x)^2 > 4 = n
      | otherwise = count_iterations (n +1) e $ g a $ roundComplex x

general_list_R ::  (Complex Scientific -> Complex Scientific -> Complex Scientific) -> Complex Scientific -> [Complex Scientific]
general_list_R g a = get_list 0 a (0 :+ 0)
  where
    get_list 1000 _ _  = []
    get_list n (c :+d) (e :+ f)
      | (sciMagnitude (e :+ f)) > (scientific 2 0) = []
      | otherwise = (e:+f):  (get_list (n +1) (c :+d) ( g (c :+ d) (roundComplex (e :+ f))))
-- takes 1:13 to do 1000 iterations using roundComplex

general_list ::  (Complex Scientific -> Complex Scientific -> Complex Scientific) -> Complex Scientific -> [Complex Scientific]
general_list g (a :+ b) = get_list 0  (a :+ b) (0 :+ 0)
  where
    get_list 40  _ _  = []
    get_list n (c :+d) (e :+ f)
      | (sciMagnitude (e :+ f)) > (makeSci "2" "2") = []
      | otherwise = (e:+f):  (get_list (n +1) (c :+d) ( g (c :+ d) (e :+ f)))

general_list_D :: RealFloat a => (Complex a -> Complex a -> Complex a) -> Complex a -> [Complex a]
general_list_D g x = getlist 0 x (0 :+ 0)
  where
    getlist 1000 _ _ = []
    getlist n c z
      | realPart (z * conjugate z)> 4 = []
      | otherwise = z: (getlist (n +1) c (g c z))

roundSci' :: Scientific -> Scientific
roundSci' s = makeSci (getSign:cut) getExp
  where
    num = splitOn "e" $ show s
    removeSign = if s < 0 then tail (num !! 0) else (num !! 0)
    getSign = if s < 0 then '-'  else ' '
    getExp = if (length num) == 1 then "0" else num !! 1
    cut = take 100  removeSign

--rounds t 20 dp
roundSci :: Scientific -> Scientific
roundSci s
  | d <  0  = s
  | otherwise = scientific (div (coefficient s) (10^d)) $ d + base10Exponent s
  where
    d = (digitCount $ coefficient s) - 20

digitCount :: Integer -> Int
digitCount = go 1 . abs
    where
        go ds n = if n >= 10 then go (ds + 1) (n `div` 10) else ds
--(fromInteger $ round $ f * (10^n)) / (10.0^^n)
--Integer
roundComplex :: Complex Scientific -> Complex Scientific
roundComplex (a :+ b) = (roundSci' a :+ roundSci' b)


-- file: Astro/Kepler.hs
-- Various forms of Kepler's equation with efficient solvers

module Astro.Kepler ( eKepler
		    , gKepler
		    , solveEKepler
		    , solveGKepler
		    , keplerPropagate
		    )
	where

import Astro.Stumpff
import Astro.Misc

import Complex
import Debug.Trace
import Numeric.GSL
import Numeric.LinearAlgebra
import Text.Printf (printf)

-- Shorthands and such
type CD = Complex Double
type VD = Vector Double

-- Elliptic Kepler's equation
eKepler :: (Floating a) => a -> a -> a
eKepler e ea = ea - e * sin ea

-- General Variable Formulation of Kepler's eq
gKepler :: Double -> Double -> Double -> Double -> Double -> Double
gKepler r0 eta0 zeta0 beta x =
	r0 * x + eta0 * stumpff_G 2 beta x + zeta0 * stumpff_G 3 beta x

-- Solve Elliptic Kepler's equation iteratively
solveEKepler :: (Floating a) => a -> a -> a
solveEKepler e m =
	iterate 0 m m
	where
	--iterate n ea m | trace ("n,E: " ++ show n ++ " " ++ show ea) False = undefined
	iterate n ea m
		| ea' == ea || n > maxit = ea'
		| otherwise = iterate (n+1) ea' m
		where
		    fd = 1.0 - e * cos ea
		    fdd = e * sin ea
		    f = eKepler e ea - m
		    ea' = ea - f / sqrt (fd^2 - f * fdd)
	maxit = 10

-- Solve General Kepler's eq iteratively
--solveGKepler :: Double -> Double -> Double -> Double -> Double -> Double -> Double
solveGKepler r0 eta0 zeta0 beta x0 t (tol,maxIt) =
	if abs lastErr > tol
		then head sol `debug`
			("solveGKepler: iter. incomp., error: "
				++(show lastErr))
		else head sol
	where
		(sol,path) = root Hybrids tol maxIt f [x0]
		lastErr = (last.last) $ toLists path
		f vx = [gKepler r0 eta0 zeta0 beta (head vx) - t]

-- Solve r, v given r0, v0, gravitational parameter, delta_t
--keplerPropagate ::  VD -> VD -> Double -> (Double, Int) -> (VD,VD)
keplerPropagate dt (tol,maxIt) rv vv =
	(scale f rv + scale g vv , scale fd rv + scale gd vv)
	where (r0, v0) = (norm rv, norm vv)
	      tau = dt -- working in units where G(m_1+m_2) = 1
	      eta0 = rv <.> vv
	      beta = 2/r0 - v0^2
	      zeta0 = 1 - beta * r0
	      x = solveGKepler r0 eta0 zeta0 beta 0.0 tau (tol,maxIt)
	      r = r0 + eta0 * stumpff_G 1 beta x + zeta0 * stumpff_G 2 beta x
	      f = 1 - stumpff_G 2 beta x / r0
	      g = tau - stumpff_G 3 beta x
	      fd = - stumpff_G 1 beta x / (r * r0)
	      gd = 1 - stumpff_G 2 beta x / r


import Data.Complex

mandelbrot a = iterate (\z -> z^2 + a) 0 !! 50

main = mapM_ putStrLn [[if magnitude (mandelbrot (x :+ y)) < 2 then '*' else ' '
                           | x <- [-2, -1.9685 .. 0.5]]
                       | y <- [1, 0.95 .. -1]]


module Main where

import Data.Complex

main :: IO ()
main = do
  putStrLn "hello world"

maxIter :: Int
maxIter = 10000

-- data Scale = {
--                ULCorner :: Point
--                DRCorner :: Point
--                XScale :: Double
--                YScale :: Double
--              }

-- Simple boolean test to see if a point is in the set
isInSet :: RealFloat a => a -> a -> Bool
isInSet r i = case escapeTime r i of
              Nothing -> True
              Just _ -> False

-- Escape Time of Nothing means the point never escaped
escapeTime :: RealFloat a => a -> a -> Maybe Int
escapeTime r i
    | numIter == maxIter = Nothing
    | otherwise = Just numIter
    where numIter = mandel r i

-- Figures out how many iterations a point takes to escape
-- Or stops after maxIter iterations
mandel :: RealFloat a => a -> a -> Int
mandel r i = length . takeWhile ((<= 2) . magnitude) .
    take maxIter $ iterate (\z -> z^2 + (r :+ i)) 0


import Data.Complex (cis, phase)

meanAngle = (/ pi) . (* 180) . phase . sum . map (cis . (/ 180) . (* pi))

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


{-# LANGUAGE Rank2Types, BangPatterns, ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Numeric.AD.Newton
-- Copyright   :  (c) Edward Kmett 2010
-- License     :  BSD3
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  GHC only
--
-----------------------------------------------------------------------------

module Numeric.AD.Newton
    (
    -- * Newton's Method (Forward AD)
      findZero
    , inverse
    , fixedPoint
    , extremum
    -- * Gradient Ascent/Descent (Reverse AD)
    , gradientDescent
    , gradientAscent
    , conjugateGradientDescent
    , conjugateGradientAscent
    ) where

import Prelude hiding (all, mapM, sum)
import Data.Functor
import Data.Foldable (all, sum)
import Data.Traversable
import Numeric.AD.Types
import Numeric.AD.Mode.Forward (diff, diff')
import Numeric.AD.Mode.Reverse (grad, gradWith')
import Numeric.AD.Internal.Combinators
import Numeric.AD.Internal.Composition

-- | The 'findZero' function finds a zero of a scalar function using
-- Newton's method; its output is a stream of increasingly accurate
-- results.  (Modulo the usual caveats.) If the stream becomes constant
-- ("it converges"), no further elements are returned.
--
-- Examples:
--
-- >>> take 10 $ findZero (\x->x^2-4) 1
-- [1.0,2.5,2.05,2.000609756097561,2.0000000929222947,2.000000000000002,2.0]
--
-- >>> import Data.Complex
-- >>> last $ take 10 $ findZero ((+1).(^2)) (1 :+ 1)
-- 0.0 :+ 1.0
findZero :: (Fractional a, Eq a) => (forall s. Mode s => AD s a -> AD s a) -> a -> [a]
findZero f = go where
  go x = x : if x == xn then [] else go xn where
    (y,y') = diff' f x
    xn = x - y/y'
{-# INLINE findZero #-}

-- | The 'inverse' function inverts a scalar function using
-- Newton's method; its output is a stream of increasingly accurate
-- results.  (Modulo the usual caveats.) If the stream becomes
-- constant ("it converges"), no further elements are returned.
--
-- Example:
--
-- >>> last $ take 10 $ inverse sqrt 1 (sqrt 10)
-- 10.0
inverse :: (Fractional a, Eq a) => (forall s. Mode s => AD s a -> AD s a) -> a -> a -> [a]
inverse f x0 y = findZero (\x -> f x - lift y) x0
{-# INLINE inverse  #-}

-- | The 'fixedPoint' function find a fixedpoint of a scalar
-- function using Newton's method; its output is a stream of
-- increasingly accurate results.  (Modulo the usual caveats.)
--
-- If the stream becomes constant ("it converges"), no further
-- elements are returned.
--
-- >>> last $ take 10 $ fixedPoint cos 1
-- 0.7390851332151607
fixedPoint :: (Fractional a, Eq a) => (forall s. Mode s => AD s a -> AD s a) -> a -> [a]
fixedPoint f = findZero (\x -> f x - x)
{-# INLINE fixedPoint #-}

-- | The 'extremum' function finds an extremum of a scalar
-- function using Newton's method; produces a stream of increasingly
-- accurate results.  (Modulo the usual caveats.) If the stream
-- becomes constant ("it converges"), no further elements are returned.
--
-- >>> last $ take 10 $ extremum cos 1
-- 0.0
extremum :: (Fractional a, Eq a) => (forall s. Mode s => AD s a -> AD s a) -> a -> [a]
extremum f = findZero (diff (decomposeMode . f . composeMode))
{-# INLINE extremum #-}

-- | The 'gradientDescent' function performs a multivariate
-- optimization, based on the naive-gradient-descent in the file
-- @stalingrad\/examples\/flow-tests\/pre-saddle-1a.vlad@ from the
-- VLAD compiler Stalingrad sources.  Its output is a stream of
-- increasingly accurate results.  (Modulo the usual caveats.)
--
-- It uses reverse mode automatic differentiation to compute the gradient.
gradientDescent :: (Traversable f, Fractional a, Ord a) => (forall s. Mode s => f (AD s a) -> AD s a) -> f a -> [f a]
gradientDescent f x0 = go x0 fx0 xgx0 0.1 (0 :: Int)
    where
        (fx0, xgx0) = gradWith' (,) f x0
        go x fx xgx !eta !i
            | eta == 0     = [] -- step size is 0
            | fx1 > fx     = go x fx xgx (eta/2) 0 -- we stepped too far
            | zeroGrad xgx = [] -- gradient is 0
            | otherwise    = x1 : if i == 10
                                  then go x1 fx1 xgx1 (eta*2) 0
                                  else go x1 fx1 xgx1 eta (i+1)
            where
                zeroGrad = all (\(_,g) -> g == 0)
                x1 = fmap (\(xi,gxi) -> xi - eta * gxi) xgx
                (fx1, xgx1) = gradWith' (,) f x1
{-# INLINE gradientDescent #-}

-- | Perform a gradient descent using reverse mode automatic differentiation to compute the gradient.
gradientAscent :: (Traversable f, Fractional a, Ord a) => (forall s. Mode s => f (AD s a) -> AD s a) -> f a -> [f a]
gradientAscent f = gradientDescent (negate . f)
{-# INLINE gradientAscent #-}

-- | Perform a conjugate gradient descent using reverse mode automatic differentiation to compute the gradient.
conjugateGradientDescent :: (Traversable f, Fractional a, Ord a) =>
                (forall s. Mode s => f (AD s a) -> AD s a) -> f a -> [f a]
conjugateGradientDescent f x0 = go x0 d0 d0
  where
    dot x y = sum $ zipWithT (*) x y
    d0 = negate <$> grad f x0
    go xi ri di = xi : go xi1 ri1 di1
      where
        ai  = last $ take 20 $ extremum (\a -> f $ zipWithT (\x d -> lift x + a * lift d) xi di) 0
        xi1 = zipWithT (\x d -> x + ai*d) xi di
        ri1 = negate <$> grad f xi1
        bi1 = max 0 $ dot ri1 (zipWithT (-) ri1 ri) / dot ri1 ri1
        -- bi1 = max 0 $ sum (zipWithT (\a b -> a * (a - b)) ri1 ri) / dot ri1 ri1
        di1 = zipWithT (\r d -> r * bi1*d) ri1 di
{-# INLINE conjugateGradientDescent #-}

-- | Perform a conjugate gradient ascent using reverse mode automatic differentiation to compute the gradient.
conjugateGradientAscent :: (Traversable f, Fractional a, Ord a) => (forall s. Mode s => f (AD s a) -> AD s a) -> f a -> [f a]
conjugateGradientAscent f = conjugateGradientDescent (negate . f)
{-# INLINE conjugateGradientAscent #-}


-- figure 2.1

import qualified Data.Vector as V

import Statistics.Sample
import Statistics.Sample.Histogram (histogram)

dice :: V.Vector Double
dice = V.fromList [1,2,3,4,5,6]

main = do
  putStrLn $ "the range: " ++ show (range dice)
  putStrLn $ "the mean:  " ++ show (mean dice)
  putStrLn $ "the harmonic mean, which is defined by 6 / (sum $ map (1/) [1..6]): " ++ show (harmonicMean dice)
  putStrLn $ "the standard deviation: " ++ show (stdDev dice)

  let (bs,hs) = histogram 6 dice
  putStrLn $ "the histogram is of course uniform: " ++ show (hs :: V.Vector Int)
  putStrLn $ "the (lower) boundaries: " ++ show bs


module BuckinghamPi
    (
    FundamentalUnit(..),
    DimensionalVariable(..),
    DimensionlessVariable(..),
    Exponent(..),
    generatePiGroups,
    numFundamentalUnits
    ) where

import           Control.Applicative
import           Data.List                     (nub, (\\))
import           Numeric.LinearAlgebra.Data
import           Numeric.LinearAlgebra.HMatrix
import           Text.Printf                   (printf)

-- Define sum type for fundamental units (M,L,T,Theta).
data FundamentalUnit = Mass | Length | Time | Temperature deriving (Eq,Show)

-- Define type synonym for Exponent.
type Exponent = Double

-- A variable is defined by the name, along with units, which is a list of tuples which contains
-- the FundamentalUnit along with an exponent.
data DimensionalVariable = DimensionalVariable {name :: String, units :: [(FundamentalUnit, Exponent)]} deriving (Eq,Show)

-- Define data type for a dimensionless variable.
data DimensionlessVariable = DimensionlessVariable {dimensionalVariables :: [DimensionalVariable], exponents :: [Exponent]} deriving (Eq)

-- Define function which normalizes exponents so that the smallest value is +/- 1.
normalizeExponents :: [Exponent] -> [Exponent]
normalizeExponents exps = map (/factor) exps
  where
    minExp = minimum exps
    factor = minExp * signum minExp

-- Define show instance for a dimensionless variable.
instance Show DimensionlessVariable where
  show (DimensionlessVariable dimVars exps) = concatMap (uncurry (printf "%s^(%.4f) ")) $ filter (\t -> abs (snd t) > 1.0e-6) $ zip (map name dimVars) (normalizeExponents exps)

getFundamentalUnits :: DimensionalVariable -> [FundamentalUnit]
getFundamentalUnits dimVar = map fst $ units dimVar

getUniqueFundamentalUnits :: [DimensionalVariable] -> [FundamentalUnit]
getUniqueFundamentalUnits = nub . concatMap getFundamentalUnits

numFundamentalUnits :: [DimensionalVariable] -> Int
numFundamentalUnits = length . getUniqueFundamentalUnits

-- Define function that computes the number of dimensionless groups given a list of dimensional variables.
computeNumberOfGroups :: [DimensionalVariable] -> Int
computeNumberOfGroups dimensionalVars = length dimensionalVars - numFundamentalUnits dimensionalVars

-- Define function that returns nonrepeating variables.
getNonrepeatingVars :: [DimensionalVariable] -> [Int] -> [DimensionalVariable]
getNonrepeatingVars dimVars repeatedIndices = [dimVars !! i | i <- [0..(length dimVars - 1)], i `notElem` repeatedIndices]

-- Define a function that returns the exponent on a given unit in the given dimensional variable.
getExponent :: FundamentalUnit -> DimensionalVariable -> Exponent
getExponent unit dimVar
  | unit `elem` map fst (units dimVar) = snd $ head $ filter (\u -> fst u == unit) $ units dimVar
  | otherwise = 0.0

-- Define a function that returns the equation that must be solved.
getEquation ::  [DimensionalVariable] -> FundamentalUnit -> [Exponent]
getEquation varCombination funUnit = map (getExponent funUnit) varCombination

getVariableCombinations :: [DimensionalVariable] -> [DimensionalVariable] -> [[DimensionalVariable]]
getVariableCombinations repeatingVars = map (\x -> repeatingVars ++ [x])

buildMatrix :: [DimensionalVariable] -> [FundamentalUnit] -> Matrix Double
buildMatrix varCombination funUnits = fromLists $ map (getEquation varCombination) funUnits

findDimensionlessGroup :: [FundamentalUnit] -> [DimensionalVariable] -> DimensionlessVariable
findDimensionlessGroup funUnits dimVars = DimensionlessVariable dimVars (concat . toLists $ nullspace $ buildMatrix dimVars funUnits)

-- Define function which takes a list of dimensional variables along with a list of integers
-- that identifies which are the repeated variables, and returns a list of dimensionless variables.
generatePiGroups :: [DimensionalVariable] -> [Int] -> [DimensionlessVariable]
generatePiGroups dimVars repeatingVarInds = map (findDimensionlessGroup funUnits) (getVariableCombinations repeatingVars nonrepeatingVars)
  where
    repeatingVars = [dimVars !! i | i <- repeatingVarInds]
    nonrepeatingVars = dimVars \\ repeatingVars
    funUnits = getUniqueFundamentalUnits dimVars


import Numeric.LinearAlgebra
import Graphics.Plot
import Numeric.GSL.Special(erf_Z, erf)

sombrero n = f x y where
    (x,y) = meshdom range range
    range = linspace n (-2,2)
    f x y = exp (-r2) * cos (2*r2) where
        r2 = x*x+y*y

f x =  sin x + 0.5 * sin (5*x)

gaussianPDF = erf_Z
cumdist x = 0.5 * (1+ erf (x/sqrt 2))

main = do
    let x = linspace 1000 (-4,4)
    mplot [f x]
    mplot [x, mapVector cumdist x, mapVector gaussianPDF x]
    mesh (sombrero 40)


module Fibon.Analyse.Statistics(
    computeSummary
  , Summary(..)
  , Estimate(..)
  , ConfidenceInterval(..)
)
where

import Statistics.Sample
import qualified Data.Vector.Unboxed as V

data Summary =
    Min
  | GeoMean
  | ArithMean
  | Max
  deriving(Read, Show)

data Estimate a = Estimate {
      ePoint  :: !a
    , eStddev :: !a
    , eSize   :: !Int
    , eCI     :: Maybe (ConfidenceInterval a)
  }
  deriving (Read, Show)

data ConfidenceInterval a = ConfidenceInterval {
      eLowerBound       :: !a
    , eUpperBound       :: !a
    , eConfidenceLevel  :: !Double
}
  deriving (Read, Show)

instance Functor Estimate where
  fmap f e = e {
      ePoint  = f (ePoint e)
    , eStddev = f (eStddev e)
    , eCI     = maybe Nothing (Just . fmap f) (eCI e)
  }

instance Functor ConfidenceInterval where
  fmap f c = c {
      eLowerBound = f (eLowerBound c)
    , eUpperBound = f (eUpperBound c)
  }

computeSummary :: Summary -> Sample -> Estimate Double
computeSummary summaryType vec =
  Estimate {
      ePoint  = sumF summaryType vec
    , eStddev = stdDev vec -- TODO: this is wrong stddev for geoMean
    , eSize   = V.length vec
    , eCI     = Nothing
  }
  where
  sumF ArithMean = mean
  sumF GeoMean   = geometricMean
  sumF Max       = V.maximum
  sumF Min       = V.minimum


#!/usr/bin/env runhaskell
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
import ClassyPrelude hiding ((<>)) -- this <> is for semigroups (usually better)
import Data.Monoid ((<>)) -- ... but HMatrix only has Monoid
import Numeric.LinearAlgebra (tr) -- transpose
import qualified Numeric.LinearAlgebra as HMatrix
import qualified Data.Text.Format as Format

main = do
  -- Load the term-document matrix
  putStrLn "Loading"
  matrix <- HMatrix.loadMatrix "termdoc.txt"
  (u, sigma, vt) <- stochasticTruncatedSVD 50 2 matrix

  print $ HMatrix.size u
  print $ HMatrix.size sigma
  print $ HMatrix.size vt

-- Stochastic SVD. See Halko, Martinsson, and Tropp, 2010 for an explanation
stochasticTruncatedSVD :: Int -> Int -> HMatrix.Matrix Double -> IO (HMatrix.Matrix Double, HMatrix.Vector Double, HMatrix.Matrix Double)
stochasticTruncatedSVD top_vectors num_iterations original = do
  let (m, n) = HMatrix.size original
  let k = top_vectors + 10
  -- Stage A
  putStrLn "Stage A\n\tPower Iteration"
  omega <- HMatrix.randn n k
  let
    y 0 = original <> omega
    y n = seq (y (n-1)) $ original <> tr original <> y (n-1)
  bigY <- return $! y num_iterations -- Force evaluation here
  putStrLn "\tOrthogonalizing"
  q <- return $! HMatrix.orth bigY

  -- Stage B
  putStrLn "Stage B"
  let b = tr q <> original
      (uhat, sigma, vt) = HMatrix.thinSVD b
      u = q <> uhat

  return $! (HMatrix.takeColumns top_vectors u,
    HMatrix.subVector 0 top_vectors sigma,
    HMatrix.takeRows top_vectors $ tr vt)
  --putStrLn "Checking"
  --let ahat = u <> HMatrix.diag sigma <> tr vt

  --Format.print "MSE of approximation {}\n" [HMatrix.sumElements ((a-ahat)^2) / (fromIntegral $ m*n)]


module Main where

import Lib
import Data.Complex
import Graphics.Image

width = 750
height = 500
scaleDivisor = 250

xOffset = 2
yOffset = 1

isInMandelbrotSet :: Complex Double -> Complex Double -> Int -> Int
isInMandelbrotSet c z 0 = 0
isInMandelbrotSet c z itterations | (Data.Complex.magnitude z)  < 4 = isInMandelbrotSet c (z**2 + c) (itterations - 1)
                                  | (Data.Complex.magnitude z) >= 4 = itterations

calculatePixel :: Int -> Int -> Pixel RGB Double
calculatePixel y x = PixelRGB  0 0 value where
    real = (fromIntegral x / scaleDivisor) - xOffset
    imag = (fromIntegral y / scaleDivisor) - yOffset
    value = ((fromIntegral (isInMandelbrotSet (real :+ imag) 0 1000)) / 1000)

main = do
    let image = makeImageR VS (height, width) (\(y, x) -> calculatePixel y x)
    writeImageExact PNG [] "output.png" image


module EvalSpec where

import Data.Array
import Test.Hspec
import Interpreter
import Expression
import Operation
import Prelude hiding ((+), (*))
import qualified Prelude as P
import Data.Complex

spec :: Spec
spec = do
    describe "eval basics" $ do
        specify "real scalar 01" $ do
            let x = var "x"
                y = var "y"
                valMap = subs [("x", 1), ("y", 3)] []
            eval valMap x `shouldBe` 1
            eval valMap y `shouldBe` 3
            eval valMap (x + y) `shouldBe` 4
            eval valMap (x * y) `shouldBe` 3
            eval valMap (x .* y) `shouldBe` 3
            eval valMap (x <.> y) `shouldBe` 3
        specify "real scalar 02" $ do
            let x = var "x"
                y = var "y"
                valMap = subs [("x", 100), ("y", 300)] []
            eval valMap x `shouldBe` 100
            eval valMap y `shouldBe` 300
            eval valMap (x + y) `shouldBe` 400
            eval valMap (x * y) `shouldBe` 30000
            eval valMap (x .* y) `shouldBe` 30000
            eval valMap (x <.> y) `shouldBe` 30000
        specify "complex scalar 01" $ do
            let x = var "x"
                y = var "y"
                z1 = x +: y
                z2 = y +: x
                valMap = subs [("x", 1), ("y", 3)] []
            eval valMap z1 `shouldBe` (1 :+ 3)
            eval valMap z2 `shouldBe` (3 :+ 1)
            eval valMap (y * z1) `shouldBe` 3 P.* (1 :+ 3)
            eval valMap (z2 * z1) `shouldBe` (3 :+ 1) P.* (1 :+ 3)
            eval valMap (z2 .* z1) `shouldBe` (3 :+ 1) P.* (1 :+ 3)
            eval valMap (z2 <.> z1) `shouldBe` (3 :+ 1) P.* (1 :+ 3)
        specify "real 1d 01" $ do
            let x = var1d 4 "x"
                y = var1d 4 "y"
                s = var "s"
                valMap = subs [("s", 3)] [("x", listArray (0, 3) [1, 1, 1, 1]), ("y", listArray (0, 3) [1, 1, 1, 1])]
            elems (eval valMap x) `shouldBe` [1, 1, 1, 1]
            elems (eval valMap (x + y)) `shouldBe` [2, 2, 2, 2]
            elems (eval valMap (s * x)) `shouldBe` [3, 3, 3, 3]
            elems (eval valMap (x .* y)) `shouldBe` [1, 1, 1, 1]
            eval valMap (x <.> y) `shouldBe` 4
        specify "complex 1d 01" $ do
            let x = var1d 4 "x"
                y = var1d 4 "y"
                s = var "s"
                valMap = subs [("s", 3)] [("x", listArray (0, 3) [1, 1, 1, 1]), ("y", listArray (0, 3) [2, 2, 2, 2])]
                z = x +: y
                listZ = [1 :+ 2, 1 :+ 2, 1 :+ 2, 1 :+ 2]
            elems (eval valMap z) `shouldBe` listZ
            elems (eval valMap (z + z)) `shouldBe` zipWith (P.+) listZ listZ
            elems (eval valMap (s * z)) `shouldBe` map (P.* 3) listZ
            elems (eval valMap (z .* z)) `shouldBe` zipWith (P.*) listZ listZ
            eval valMap (z <.> z) `shouldBe` P.sum (zipWith (P.*) listZ listZ)


{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Chi-Squared test for uniformity.
module Uniformity (testUniformity) where

import Data.List                    (intercalate)
import Data.List                    (foldl')
import Numeric                      (showFFloat)
import Numeric.SpecFunctions        (incompleteGamma)
import Test.Framework.Providers.API (Test, TestName)

import qualified Data.Map as Map

import MiniQC as QC

-- | \( \lim_{n\to\infty} \mathrm{Pr}(V \le v) = \ldots \)
chiDist
    :: Int     -- ^ k, categories
    -> Double  -- ^ v, value
    -> Double
chiDist k x = incompleteGamma (0.5 * v) (0.5 * x) where
  v = fromIntegral (k - 1)

-- | When the distribution is uniform,
--
-- \[
-- \frac{1}{n} \sum_{s = 1}^k \frac{Y_s^2}{p_s} - n
-- \]
--
-- simplifies to
--
-- \[
-- \frac{k}{n} \sum_{s=1}^k Y_s^2 - n
-- \]
--
-- when \(p_s = \frac{1}{k} \), i.e. \(k\) is the number of buckets.
--
calculateV :: Int -> Map.Map k Int -> Double
calculateV k data_ = chiDist k v
  where
    v          = fromIntegral k * fromIntegral sumY2 / fromIntegral n - fromIntegral n
    V2 n sumY2 = foldl' sumF (V2 0 0) (Map.elems data_) where
        sumF (V2 m m2) x = V2 (m + x) (m2 + x * x)

-- Strict pair of 'Int's, used as an accumulator.
data V2 = V2 !Int !Int

countStream :: Ord a => Stream a -> Int -> Map.Map a Int
countStream = go Map.empty where
    go !acc s n
        | n <= 0    = acc
        | otherwise = case s of
            x :> xs -> go (Map.insertWith (+) x 1 acc) xs (pred n)

testUniformityRaw :: forall a. (Ord a, Show a) => Int -> Stream a -> Either String Double
testUniformityRaw k s
    | Map.size m > k = Left $ "Got more elements (" ++ show (Map.size m, take 5 $ Map.keys m) ++ " than expected (" ++ show k ++ ")"
    | p > 0.999999   = Left $
        "Too impropabable p-value: " ++ show p ++ "\n" ++ table
        [ [ show x, showFFloat (Just 3) (fromIntegral y / fromIntegral n :: Double) "" ]
        | (x, y) <- take 20 $ Map.toList m
        ]
    | otherwise      = Right p
  where
    -- each bucket to have roughly 128 elements
    n :: Int
    n = k * 128

    -- buckets from the stream
    m :: Map.Map a Int
    m = countStream s n

    -- calculate chi-squared value
    p :: Double
    p = calculateV k m

testUniformityQC :: (Ord a, Show a) => Int -> Stream a -> QC.Property
testUniformityQC k s = case testUniformityRaw k s of
    Left err -> QC.counterexample err False
    Right _  -> QC.property True

-- | Test that generator produces values uniformly.
--
-- The size is scaled to be at least 20.
--
testUniformity
    :: forall a b. (Ord b, Show b)
    => TestName
    -> QC.Gen a  -- ^ Generator to test
    -> (a -> b)    -- ^ Partitioning function
    -> Int         -- ^ Number of partittions
    -> Test
testUniformity name gen f k = QC.testMiniProperty name
    $ QC.forAllBlind (streamGen gen)
    $ testUniformityQC k . fmap f

-------------------------------------------------------------------------------
-- Infinite stream
-------------------------------------------------------------------------------

data Stream a = a :> Stream a deriving (Functor)
infixr 5 :>

streamGen :: QC.Gen a -> QC.Gen (Stream a)
streamGen g = gs where
    gs = do
        x <- g
        xs <- gs
        return (x :> xs)

-------------------------------------------------------------------------------
-- Table
-------------------------------------------------------------------------------

table :: [[String]] -> String
table cells = unlines rows
  where
    cols      :: Int
    rowWidths :: [Int]
    rows      :: [String]

    (cols, rowWidths, rows) = foldr go (0, repeat 0, []) cells

    go :: [String] -> (Int, [Int], [String]) -> (Int, [Int], [String])
    go xs (c, w, yss) =
        ( max c (length xs)
        , zipWith max w (map length xs ++ repeat 0)
        , intercalate "   " (take cols (zipWith fill xs rowWidths))
          : yss
        )

    fill :: String -> Int -> String
    fill s n = s ++ replicate (n - length s) ' '


module Math.Probably.Circular where

import Math.Probably.FoldingStats
import Numeric.LinearAlgebra
import Control.Applicative

--approximate method first mentioned http://en.wikipedia.org/wiki/Mean_of_circular_quantities
circularMean :: Fold Double Double
circularMean = before (after vmean getAngle) toCartesian where
  vmean = pure (scale) <*> after realLengthF recip <*> sumF
  getAngle v = atan2 (v@>1) (v@>0)
  toCartesian alpha = fromList [cos alpha, sin alpha]

--http://webspace.ship.edu/pgmarr/Geo441/Lectures/Lec%2016%20-%20Directional%20Statistics.pdf
circularDispersion :: Fold Double Double
circularDispersion = after (both xs ys) getR where
  xs = before sumF cos
  ys = before sumF sin
  getR (x,y) = sqrt (x*x + y*y)

--example for running statistic

runCircularMean :: [Double] -> Double
runCircularMean = runStat circularMean


module ActivationFunction
    ( step'
    , sigmoid
    , relu
    , softMax'
    ) where

import Numeric.LinearAlgebra

step' :: (Element b, Container c a, Ord a, Num a, Num b) => c a -> c b
step' = cmap (\x -> if x>0 then 1 else 0)

sigmoid :: (Container c b, Floating b) => c b -> c b
sigmoid = cmap (\x -> 1 / (1 + exp(-x)))

relu :: (Container c b, Ord b, Num b) => c b -> c b
relu = cmap (max 0)

-- This function is deprecated, causes overflow.
softMax :: (Container c b, Floating b) => c b -> c b
softMax xs = cmap (/sumCexp) $ cexp xs
    where sumCexp = (sumElements . cexp) xs

softMax' :: (Container c b, Floating b) => c b -> c b
softMax' xs = cmap (/sumCexp) $ cexp' xs
    where sumCexp = (sumElements . cexp') xs

cexp :: (Container c b, Floating b) => c b -> c b
cexp = cmap exp

cexp' :: (Container c b, Floating b) => c b -> c b
cexp' xs = cexp $ cmap (subtract $ maxElement xs) xs


module Math(hamming, preemphasis, sliding, toMesh, spectrogram) where

import RIO
import RIO.List (mapAccumL, zipWith)
import Control.Parallel.Strategies
import Data.Complex
import qualified Numeric.FFT as NF

sliding :: Int -> Int -> a -> [a] -> [[a]]
sliding step size padding xs
    | len < size = [xs ++ replicate (size - len) padding]
    | otherwise  = take size xs : sliding step size padding (drop step xs)
    where len = length xs

preemphasis :: Complex Double -> [Complex Double] -> [Complex Double]
preemphasis emph = snd . mapAccumL (\prev y -> (y, y - emph * prev)) 0.0

hamming :: [Complex Double] -> [Complex Double]
hamming signal = let len = length signal
                  in zipWith (*) signal $ hamming' len 0.53

hamming' :: Int -> Complex Double -> [Complex Double]
hamming' n alpha =
    let beta = 1 - alpha
     in [alpha - beta * cos(2 * pi * fromIntegral i / (fromIntegral n - 1)) | i <- [0..n - 1]]

toMesh :: (Num c) => [[c]] -> [[(c, c, c)]]
toMesh dd = do
    (x, fs) <- zip ([1..] :: [Integer]) dd
    return $ do
        (y, p) <- zip ([0..] :: [Integer]) fs
        return (fromIntegral x, fromIntegral y, p)

spectrogram :: Int -> Int -> [Complex Double] -> [[Complex Double]]
spectrogram step len signal = let ft = take (len `div` 2) . NF.fft . hamming
                                  windows = sliding step len 0 signal
                                  nWindows = length windows
                                  strat = parListChunk (nWindows `div` 4) rdeepseq
                              in ft <$> windows `using` strat


{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Statistics.Distribution.Beta
-- Copyright   :  (C) 2012 Edward Kmett,
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  DeriveDataTypeable
--
----------------------------------------------------------------------------
module Statistics.Distribution.Beta
  ( BetaDistribution(..)
  , betaDistr
  ) where

import Numeric.SpecFunctions
import Numeric.MathFunctions.Constants (m_NaN)
import qualified Statistics.Distribution as D
import Data.Typeable

data BetaDistribution = BD
 { bdAlpha :: {-# UNPACK #-} !Double
 , bdBeta  :: {-# UNPACK #-} !Double
 } deriving (Eq,Read,Show,Typeable)

betaDistr :: Double -> Double -> BetaDistribution
betaDistr a b
  | a < 0 = error $ msg ++ "alpha must be positive. Got " ++ show a
  | b < 0 = error $ msg ++ "beta must be positive. Got " ++ show b
  | otherwise = BD a b
  where msg = "Statistics.Distribution.Beta.betaDistr: "
{-# INLINE betaDistr #-}

instance D.Distribution BetaDistribution where
  cumulative (BD a b) x
    | x <= 0 = 0
    | otherwise = incompleteBeta a b x
  {-# INLINE cumulative #-}

instance D.Mean BetaDistribution where
  mean (BD a b) = a / (a + b)
  {-# INLINE mean #-}

instance D.MaybeMean BetaDistribution where
  maybeMean = Just . D.mean
  {-# INLINE maybeMean #-}

instance D.Variance BetaDistribution where
  variance (BD a b) = a*b / (apb*apb*(apb+1))
    where apb = a + b
  {-# INLINE variance #-}

-- invert a monotone function
invertMono :: (Double -> Double) -> Double -> Double -> Double -> Double
invertMono f l0 h0 b = go l0 h0 where
  go l h
    | h - l < epsilon = m
    | otherwise = case compare (f m) b of
      LT -> go m h
      EQ -> m
      GT -> go l m
    where m = l + (h-l)/2
          epsilon = 1e-12
{-# INLINE invertMono #-}

instance D.ContDistr BetaDistribution where
  density (BD a b) x
   | a <= 0 || b <= 0 = m_NaN
   | x <= 0 = 0
   | x >= 1 = 0
   | otherwise = exp $ (a-1)*log x + (b-1)*log (1-x) - logBeta a b
  {-# INLINE density #-}

  quantile d p
    | p < 0 = error $ "probability must be positive. Got " ++ show p
    | p > 1 = error $ "probability must be less than 1. Got " ++ show p
    | otherwise = invertMono (D.cumulative d) 0 1 p
  {-# INLINE quantile #-}

instance D.MaybeVariance BetaDistribution where
  maybeVariance = Just . D.variance
  {-# INLINE maybeVariance #-}

-- TODO: D.ContGen for rbeta