module Main where

import qualified Numeric.LinearAlgebra as LA
import qualified MachineLearning as ML
import qualified MachineLearning.Regression as MLR

main = do
  -- Step 1. Data loading
  m <- LA.loadMatrix "linear_regression/data.txt"
  let (x, y) = ML.splitToXY m

  -- Step 2. Feature Normalization
      muSigma = ML.meanStddev x
      xNorm = ML.featureNormalization muSigma x
      x1 = ML.addBiasDimension xNorm

  -- Step 3. Learning using 3 methods:
  -- NE: Normal Equation (exact solution)
  -- GD: Gradient Descent (basic iterative method)
  -- BFGS: BFGS (most advanced iterative method)
      zeroTheta = LA.konst 0 (LA.cols x1)
      thetaNE = MLR.normalEquation x1 y
      (thetaGD, optPathGD) = MLR.minimize (MLR.GradientDescent 0.01) MLR.LeastSquares 0.0001 5000 MLR.RegNone x1 y zeroTheta
      (thetaBFGS, optPathBFGS) = MLR.minimize (MLR.BFGS2 0.1 0.1)    MLR.LeastSquares 0.0001 1500 MLR.RegNone x1 y zeroTheta

  -- Step 4. Prediction
      xPredict = LA.matrix 2 [1650, 3]
      xPredict1 = ML.addBiasDimension $ ML.featureNormalization muSigma xPredict
      yPredictNE = MLR.hypothesis MLR.LeastSquares xPredict1 thetaNE
      yPredictGD = MLR.hypothesis MLR.LeastSquares xPredict1 thetaGD
      yPredictBFGS = MLR.hypothesis MLR.LeastSquares xPredict1 thetaBFGS

  -- Step 5. Printing results
  putStrLn "\n=== Linear Regression Sample Application ===\n"
  putStrLn "Feature normalization, mu:"
  LA.disp 4 $ fst muSigma
  putStrLn "Feature normalization, sigma:"
  LA.disp 4 $ snd muSigma
  putStrLn "Normilized features:"
  LA.dispShort 10 10 4 $ x LA.||| xNorm

  putStrLn ""
  putStrLn $ "Theta (Normal Equation):  " ++ (show thetaNE)
  putStrLn $ "Theta (Gradient Descent): " ++ (show thetaGD)
  putStrLn $ "Theta (BFGS):             " ++ (show thetaBFGS)

  putStrLn ""
  putStrLn $ "Prediction (Normal Equation):  " ++ (show yPredictNE)
  putStrLn $ "Prediction (Gradient Descent): " ++ (show yPredictGD)
  putStrLn $ "Prediction (BFGS):             " ++ (show yPredictBFGS)

  putStrLn ""
  putStrLn "Optimization Path (Gradient Descent):"
  LA.dispShort 20 10 4 optPathGD
  putStrLn "Optimization Path (BFGS2):"
  LA.disp 3 optPathBFGS


import Statistics.Distribution -- (mean, stdDev)
import Statistics.Distribution.Gamma

gd :: GammaDistribution
gd = gammaDistr a b
       where
         a = 3.1 -- shape parameter k
         b = 2.0 -- scale parameter theta

m = mean gd
s = stdDev gd

main = do
  putStrLn $ "The mean is: " ++ show m ++ " and the standard deviation: " ++ show s
  let k = (22.5 - m)/s
  putStrLn $ "k-value is: " ++ show k
  putStrLn $ "P( Y>22.5)= " ++ show (complCumulative gd 22.5)
  let tchebycheff = 1/k^2
  putStrLn $ "Using Tchebysheff's theorem, P( |Y-m|> " ++ show k ++ "*s ) <= 1/k^2 = " ++ show tchebycheff


module Y2016.M12.D14.Exercise where

import Data.Complex

-- import available via 1HaskellADay git repository

import Data.Matrix

{--
I'm thinking about quantum computation. IBM has released a 5-qubit computer
for public experimentation. So, let's experiment.

One way to go about that is to dive right in, so, yes, if you wish: dive
right in.

Another approach is to comprehend the maths behind quantum computation.

So, let's look at that.

I was going to bewail that Shor's prime factors algorithm needs 7 qubits to
work, but, NEWSFLASH! IBM has added Shor's algorithm to their API, so ...

CANCEL BEWAILMENT.

*ahem*

Moving on.

First, let's look at qubits. Qubits are 'bra-ket'ted numbers (ket numbers)
with the representation

|0> =  | 1 |   or    |1> = | 0 |
       | 0 |               | 1 |

OOH! MATRICES!

exercise 1. Represent ket0 and ket1 states as matrices in Haskell
--}

type Qubit = Matrix (Complex Float)  --- where Float is 1 or 0 but okay

ket0, ket1 :: Qubit
ket0 = undefined
ket1 = undefined

{--
It MAY be helpful to have a show-instance of a qubit that abbreviates the
complex number to something more presentable. Your choice.

A qubit state is most-times in a super-position of |0> or |1> and we represent
that as

|ψ> = α|0> + β|1>

And we KNOW that |α|² + |β|² = 1

YAY! Okay. Whatever.

So, we have a qubit at |0>-state and we want to flip it to |1>-state, or vice
versa. How do we do that?

We put it through a Pauli X gate

The Pauli X operator is =  | 0 1 |
                           | 1 0 |

That is to say, zero goes to 1 and 1 goes to zero.

excercise 2: represent the Pauli X, Y, and Z operators
--}

type PauliOperator = Matrix (Complex Float)

pauliX, pauliY, pauliZ :: PauliOperator
pauliX = undefined
pauliY = undefined
pauliZ = undefined

-- exercise 3: rotate the qubits ket0 and ket1 through the pauliX operator
-- (figure out what that means). The intended result is:

-- X|0> = |1> and X|1> = |0>

-- what are your results?

rotate :: PauliOperator -> Qubit -> Qubit
rotate p q = undefined


{- Assignment 1
 - Name: Omar Alkersh
 - Date: 22/09/2018
 -}
module Assign_1 where
import           Data.Complex

macid :: String
macid = "alkersho"
{-
 - Throughout this file I will be referring to https://proofwiki.org/wiki/Cardano%27s_Formula
 - and the variables listed within it.
 - Equation in the form of: ax^3 + bx^2 + cx + d = 0
-}
{- -----------------------------------------------------------------
 - cubicQ
 - -----------------------------------------------------------------
 - Description: Finds Q, refer to website
 -}
cubicQ :: Double -> Double -> Double -> Double
cubicQ a b c = ((3*a*c)-b^2)/(9*a^2)

{- -----------------------------------------------------------------
 - cubicR
 - -----------------------------------------------------------------
 - Description: Finds R using
 -}
cubicR :: Double -> Double -> Double -> Double -> Double
cubicR a b c d = ((9*a*b*c)-(27*a^2*d)-(2*b^3))/(54*a^3)

{- -----------------------------------------------------------------
 - cubicDisc
 - -----------------------------------------------------------------
 - Description: Finds the discriminant
 - when the disc > 0, there is one real solution
 - when the disc = 0, there are two real solutions
 - when the disc < 0, there are three real solutions
 -}
cubicDisc :: Double -> Double -> Double
cubicDisc q r = q^3 + r^2

--Returns the cube root of a number
cubeRoot :: Double -> Double
cubeRoot x = x ** (1/3)

{- -----------------------------------------------------------------
 - cubicS
 - -----------------------------------------------------------------
 - Description: Finds S using Q and R
 -}
cubicS :: Double -> Double -> Double
cubicS q r = cubeRoot(r+sqrt(q^3 + r^2))

{- -----------------------------------------------------------------
 - cubicT
 - -----------------------------------------------------------------
 - Description: Finds T using Q and R
 -}
cubicT :: Double -> Double -> Double
cubicT q r = cubeRoot(r-sqrt(q^3 + r^2))

{- -----------------------------------------------------------------
 - cubicRealSolutions
 - -----------------------------------------------------------------
 - Description: Finds the roots/solutions of the cubic equaition
 - when the disc > 0, there is one real solution
 - when the disc = 0, there are two real solutions
 - when the disc < 0, there are three real solutions
 -}
cubicRealSolutions :: Double -> Double -> Double -> Double -> [Double]
cubicRealSolutions a b c d =
  let
    q = cubicQ a b c
    r = cubicR a b c d
    s = cubicS q r
    t = cubicT q r
    x1 = s + t - (b / (3*a))
    x2 = -((s+t)/2)-(b/3*a)+((sqrt 3 / 2)*(s-t))
    tol = 1e-5
    in if cubicDisc q r > 0
     then [x1]
     else if abs (cubicDisc q r) == 0.0
       then [x1, x2, x2]
       else []
{- -----------------------------------------------------------------
 - Test Cases
 - -----------------------------------------------------------------
 -}

--test returns True if test succeds
--Formulae in question:
-- x^3 + 3x^2 + 3x + 1 = (x+1)^3
-- x^3 - 6x^2 + 9x + 0 = x(x-3)^2
test :: (Double, Double) -> (Double, Double) -> (Double, Double) -> Bool
test xs1 xs2 xs3 = let
 a = fst xs1 * fst xs2 * fst xs3
 b = fst xs1 * fst xs2 * snd xs3 + fst xs1 * snd xs2 * fst xs3 + snd xs1 * fst xs2 * fst xs3
 c = fst xs1 * snd xs2 * snd xs3 + snd xs1 * fst xs2 * snd xs3 + snd xs1 * snd xs2 * fst xs3
 d = snd xs1 * snd xs2 * snd xs3
 x1 = -(snd xs1 / fst xs1)
 x2 = -(snd xs2 / fst xs2)
 x3 = -(snd xs3 / fst xs3)
 in cubicRealSolutions a b c d == [x1, x2, x2] || cubicRealSolutions a b c d == [] || cubicRealSolutions a b c d == [x1]


module LinearRegression where
import Util
import GradientDescent
import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Util
import Debug.Trace

-- The cost function J
-- Compute regularized cost for linear regression with multiple variables
-- computes the cost of using theta as the parameter for linear
-- regression to fit the data points in X and y, returns double of cost and gradient
computeCost :: Matrix Double -> Matrix Double -> Matrix Double -> Double -> (Double, Matrix Double)
computeCost x y theta lambda = (cost, gradient)
    where
      m = fromIntegral $ rows y
      tempTheta = accum theta (*) [((0,0),0)]
      cost = ( 1/(2*m) ) * sumElements (((x <> theta) - y) ^2 ) + (lambda/(2*m)) * sumElements (tempTheta ^ 2)
      gradient = ctrans $ (scalar (1/m)) * ( sumColumns  ((x <> theta - y) * x) ) + (scalar (lambda/m)) * (ctrans tempTheta)

linearRegressionGD x y initial_theta alpha num_iters lambda = gradientDescent gradFunc initial_theta alpha num_iters
    where
      gradFunc t = snd (computeCost x y t lambda)

-- The prediction function
predict xi theta = xi <> theta

-- Generate learning curves
learningCurvesLinearRegression ::
                   Matrix Double ->
                   Matrix Double ->
                   Matrix Double ->
                   Matrix Double ->
                   Double ->
                   Double ->
                   Int ->
                   [(Double,Double,Int)]
learningCurvesLinearRegression x y xval yval lambda alpha iter = learningCurves trainFunc costFunc x y xval yval 1
  where
    initial_theta = ((cols x)><1) (repeat 1)
    trainFunc tx ty = linearRegressionGD tx ty initial_theta alpha iter lambda
    costFunc tx ty tt = fst $ computeCost tx ty tt 0


module MatrixPlus where

import Numeric.LinearAlgebra as N
import Test.QuickCheck

dummyMatrix :: (Field a) => Matrix a
dummyMatrix = (0 N.><0) []

mapMatrix :: (Field a)
  => (a -> a)
  -> Matrix a
  -> Matrix a
mapMatrix f x = (r N.><c) y
  where x' = toList (flatten x)
        y = map f x'
        r = rows x
        c = cols x

zipMatricesWith :: (Field a)
  => (a -> a -> a)
  -> Matrix a
  -> Matrix a
  -> Matrix a
zipMatricesWith f x y = (r N.><c) z
  where x' = toList (flatten x)
        y' = toList (flatten y)
        z = zipWith f x' y'
        r = rows x
        c = cols x

hadamardProduct :: (Field a)
  => Matrix a
  -> Matrix a
  -> Matrix a
hadamardProduct = zipMatricesWith (*)

average :: (Field a)
  => Matrix a
  -> a
average m = sum ms / fromIntegral (length ms)
  where ms = toList (flatten m)

magnitude :: (Field a, Floating a)
  => Matrix a
  -> a
magnitude x =
  if cols x == 1
  then sqrt (sum xsxs)
  else error "not a column vector"
    where xs = toList (flatten x)
          xsxs = zipWith (*) xs xs

pseudoMagnitude :: (Field a, Floating a)
  => Matrix a
  -> a
pseudoMagnitude m = sqrt (sum msms)
    where ms = toList (flatten m)
          msms = zipWith (*) ms ms

-- | Inputs, outputs and targets are represented as column vectors instead of lists
type ColumnVector a = Matrix a

-- | Convert a list to a column vector
listToColumnVector :: (Ord a, Field a)
    -- | the list to convert
    => [a]
    -- | the resulting column vector
    -> ColumnVector a
listToColumnVector x = (len N.><1 ) x
    where len = length x

-- | Convert a column vector to a list
columnVectorToList :: (Ord a, Field a)
    -- | The column vector to convert
    => ColumnVector a
    -- | The resulting list
    -> [a]
columnVectorToList = toList . flatten

-- | Testable property:
-- | If we take a non-empty list, we should be able to convert it to a column vector
-- | and back, and get the result we started with.
-- | To test this property, in GHCi type: quickCheck prop_tocolumnVectorToListRoundtrippable
prop_tocolumnVectorToListRoundtrippable :: [Double] -> Property
prop_tocolumnVectorToListRoundtrippable x =
    (length x > 0) ==>
        -- collect x $ -- uncomment to view test data
        (columnVectorToList (listToColumnVector x) == x)


module Main where

import Numeric.NLOPT
import Numeric.LinearAlgebra (fromList, toList)

main :: IO ()
main = do
    let objf x = let [x1, x2, x3] = toList x
                 in 3 * x1 * x1 + 2 * x1 * x2 + x1 * x3
                    + 2.5 * x2 * x2 + 2 * x2 * x3 + 2 * x3 * x3
                    - 8 * x1 - 3 * x2 - 3 * x3

        objfGrad x = let [x1, x2, x3] = toList x
                     in fromList [ 6 * x1 + 2 * x2 + x3 - 8
                                 , 2 * x1 + 5 * x2 + 2 * x3 - 3
                                 , x1 + 2 * x2 + 4 * x3 - 3 ]

        objfD x = (objf x, objfGrad x)

        stop = ObjectiveRelativeTolerance 1e-9 :| []

        c1f x = let [x1, _, x3] = toList x in x1 + x3 - 3
        c1fGrad _ = fromList [1, 0, 1]
        c1fD x = (c1f x, c1fGrad x)
        c1 = EqualityConstraint (Scalar c1fD) 1e-6

        c2f x = let [_, x2, x3] = toList x in x2 + x3
        c2fGrad _ = fromList [0, 1, 1]
        c2fD x = (c2f x, c2fGrad x)
        c2 = EqualityConstraint (Scalar c2fD) 1e-6

        algorithm = SLSQP objfD [] [] [c1, c2]
        problem = LocalProblem 3 stop algorithm

        x0 = fromList [0, 0, 0]

        solC = minimizeLocal problem x0

    print solC

    putStrLn "-- Done."


import Math.Combinat.Partitions (_partitions)
import Numeric.LinearAlgebra
import System.IO (putStrLn)
import Text.Printf (printf)

getX :: Matrix Double -> Matrix Double
getX = takeColumns 2

getY :: Matrix Double -> Vector Double
getY = head . toColumns . dropColumns 2

nonLinear :: Matrix Double -> Matrix Double
nonLinear = fromRows . map (fromList . nonLinearRow . toList) . toRows
  where
    nonLinearRow [x1, x2] = [1, x1, x2, x1^2, x2^2, x1 * x2, abs (x1 - x2), abs (x1 + x2)]

classificationError :: Vector Double -> Vector Double -> Double
classificationError v y = let sv = mapVector signum v
                              diffs = zipVectorWith (((fromIntegral . fromEnum).) . (/=)) sv y
                          in  foldVector (+) 0 diffs / fromIntegral (dim y)

regularizedRegression :: Matrix Double -> Vector Double -> Double -> Vector Double
regularizedRegression x y lambda = let xt = trans x
                                       xtx = multiply xt x
                                       n = cols x
                                       lambdaI = diag (constant lambda n)
                                       z = multiply (pinv (xtx + lambdaI)) xt
                                   in  z `mXv` y

experiment :: Matrix Double -> Vector Double -> Matrix Double -> Vector Double -> Double -> (Double, Double)
experiment x y x' y' lambda = let z = regularizedRegression x y lambda
                                  xz = x `mXv` z
                                  ein = classificationError xz y
                                  x'z = x' `mXv` z
                                  eout = classificationError x'z y'
                              in  (ein, eout)

main = do
         inputMatrix <- fromFile "in.dta" (35, 3)
         testMatrix <- fromFile "out.dta" (250, 3)
         let x = nonLinear (getX inputMatrix)
             y = getY inputMatrix
             x' = nonLinear (getX testMatrix)
             y' = getY testMatrix
         let run = experiment x y x' y'

         let (ein, eout) = run 0
         putStrLn $ printf "2)\tE_{in} = %.5f\n\tE_{out} = %.5f" ein eout

         let (ein, eout) = run (10**(-3))
         putStrLn $ printf "3)\tE_{in} = %.5f\n\tE_{out} = %.5f" ein eout

         let (ein, eout) = run (10**3)
         putStrLn $ printf "4)\tE_{in} = %.5f\n\tE_{out} = %.5f" ein eout

         let lambdas = [2, 1, 0, -1, -2] :: [Double]
             eouts = map (snd . run . (10**)) lambdas
             best = minimum (zip eouts lambdas)
         putStrLn $ printf "5)\t%d" (floor $ snd best :: Int)
         putStrLn $ printf "6)\t%f" (fst best)

         let layerings = filter (all (>= 2)) $ _partitions 36
             cost p = cost' $ 10:p
               where
                cost' [x] = x
                cost' (x:y:xs) = x * (y - 1) + cost' (y:xs)
             costs = map cost layerings
         putStrLn $ printf "9)\t%d" (minimum costs)
         putStrLn $ printf "10)\t%d" (maximum costs)


module FFT where

import Control.Applicative

import Data.Matrix as M
import Data.Complex as C

import Utils

-- 1-D Discrete Fourier Transform (DFT), the naive way.
dft :: (RealFloat a) => [Complex a] -> [Complex a]
dft xs =
  let n = length xs
      theta i j = 2 * pi * (fromIntegral i) * (fromIntegral j) / (fromIntegral n)
      w = M.matrix n n (\(i,j) -> C.mkPolar 1 $ theta (i-1) (j-1))
      xs' = M.fromList n 1 xs
  in M.toList $ vdot w xs'

-- Inverse transform for `dft`.
idft :: (RealFloat a) => [Complex a] -> [Complex a]
idft fs =
  let n = length fs
      theta i j = -2 * pi * (fromIntegral i) * (fromIntegral j) / (fromIntegral n)
      norm = fromIntegral n
      winv = M.matrix n n (\(i,j) -> C.mkPolar (1/norm) $ theta (i-1) (j-1))
      fs' = M.fromList n 1 fs
  in M.toList $ vdot winv fs'

-- 1-D DFT for real-valued vector. Unlike the numpy equivalent, returns all
-- frequency components including the negative frequency ones (which are simply
-- complex conjugates of the positive frequency components).
rdft :: (RealFloat a) => [a] -> [Complex a]
rdft xs = dft $ toComplex <$> xs
  where
    toComplex magnitude = C.mkPolar magnitude 0

-- Inverse transform for `rdft`.
irdft :: (RealFloat a) => [Complex a] -> [a]
irdft = map C.realPart . idft

-- numpy.fft.fft
-- 1-D Fast Fourier Transform (FFT).
fft :: (RealFloat a) => [Complex a] -> [Complex a]
fft xs
  | n == 0 = []
  | n == 1 = xs
  | even n = positiveFreqs ++ negativeFreqs
  | otherwise = dft xs
  where
    n = length xs
    positiveFreqs = zipWith3 (\evenX oddX w -> evenX + w * oddX) evenFreqs oddFreqs weights
    negativeFreqs = zipWith3 (\evenX oddX w -> evenX - w * oddX) evenFreqs oddFreqs weights
    evenFreqs = fft $ [xi | (i,xi) <- zip [0..] xs, even i]
    oddFreqs = fft $ [xi | (i,xi) <- zip [0..] xs, odd i]
    weights = [C.conjugate . C.mkPolar 1 $ theta k | k <- [0 .. (n `div` 2)-1]]
    theta k = 2 * pi * (fromIntegral k) / (fromIntegral n)

-- numpy.fft.ifft
-- Inverse transform for `fft`.
ifft :: (RealFloat a) => [Complex a] -> [Complex a]
ifft fs = normalize . ifft' $ fs
  where
    normalize xs = map (/ (fromIntegral (length xs))) xs
    ifft' fs
      | n == 0 = []
      | n == 1 = fs
      | even n = positiveFreqs ++ negativeFreqs
      | otherwise =  unnormalize . idft $ fs -- undo normalization done by idft do avoid double normalization
      where
        n = length fs
        positiveFreqs = zipWith3 (\evenX oddX w -> evenX + w * oddX) evenFreqs oddFreqs weights
        negativeFreqs = zipWith3 (\evenX oddX w -> evenX - w * oddX) evenFreqs oddFreqs weights
        evenFreqs = ifft' $ [xi | (i,xi) <- zip [0..] fs, even i]
        oddFreqs = ifft' $ [xi | (i,xi) <- zip [0..] fs, odd i]
        weights = [C.mkPolar 1 $ theta k | k <- [0 .. (n `div` 2)-1]]
        theta k = 2 * pi * (fromIntegral k) / (fromIntegral n)
        unnormalize = map (* (fromIntegral n))

-- numpy.fft.rfft
-- 1-D FFT for real-valued vector. Unlike the numpy equivalent, returns all
-- frequency components including the negative frequency ones (which are simply
-- complex conjugates of the positive frequency components).
rfft :: (RealFloat a) => [a] -> [Complex a]
rfft xs = fft $ toComplex <$> xs
  where
    toComplex magnitude = C.mkPolar magnitude 0

-- numpy.fft.irfft
-- Inverse transform for `rfft`.
irfft :: (RealFloat a) => [Complex a] -> [a]
irfft = map C.realPart . ifft

-- numpy.fft.fftfreq
-- Computes frequency bins.
-- n: Window length
-- d: Sample spacing (inverse of sampling rate)
fftfreq :: (Fractional a) => Int -> a -> [a]
fftfreq n d = map ((/ norm) . fromIntegral) $ freqs n
  where
    freqs n
      | n == 0 = []
      | otherwise = [0..n_2-1] ++ [i - n | i <- [n_2..n-1]]
    n_2 = if even n then n `div` 2 else (n + 1) `div` 2
    norm = (fromIntegral n) * d


module Assign_1_ExtraCredit where

import Data.Complex
-- see https://www.stackage.org/haddock/lts-8.24/base-4.9.1.0/Data-Complex.html

macid :: String
macid = "hutchm6"

{-
    - Assignment 1
    - Name: Mark Hutchison
    - Date: September 17th, 2019
 -}

{-
    Similar to the normal assignment, I will be using the 4 base equations that will be listed under this comment string. That being said, because the equations for Q R and Disc do not change, I will not be re showing the outputs for those above the functions.

    - cubicRealSolutions 1 (-6) 11 (-6) = should [1,2,3]
    - cubicRealSolutions 1 0 (-3) 0 = [0, sqrt 3, -sqrt 3]
    - cubicRealSolutions 1 (-3) 3 (-1) = should [1,1,1]
    - cubicRealSolutions 1 (-5) 8 (-4) = should [1,2,2]
-}
cubicQ :: Double -> Double -> Double -> Double
cubicQ a b c = ((3 * a * c) - (b ** 2)) / (9 * (a ** 2))

cubicR :: Double -> Double -> Double -> Double -> Double
cubicR a b c d = ((9 * a * b * c) - (27 * (a ** 2) * d) - (2 * (b ** 3))) / (54 * (a ** 3))

cubicDisc :: Double -> Double -> Double
cubicDisc q r = do
    if r == 0
        then q
        else ((q ** 3) + (r ** 2)) ** (1 / 3)

{-
    Here is the point where everything changes and we need to begin thinking in complex number systems.

    We need to be able to get the square root of a negative number, so the S and T function needed to change.
-}

cubicComplexS :: Double -> Double -> Complex Double
cubicComplexS q r = s where
    s = cubeRoot (r + sqrt (cubicDisc q r))

{-

-}

cubicComplexT :: Double -> Double -> Complex Double
cubicComplexT q r = t where
    t = cubeRoot (r - sqrt (cubicDisc q r))

cubicComplexSolutions :: Double -> Double -> Double -> Double -> [Complex Double]
cubicComplexSolutions a b c d = [x1, x2, x3] where
    q = cubicQ a b c
    r = cubicR a b c d
    s = cubicComplexS q r
    t = cubicComplexT q r
    x1 = (s + t - (b/(3*a)))
    x2 = ((-1) * ((s + t) / 2) - (b/(3*a)) + (((sqrt 3)/(2)) * (s - t)))
    x3 = ((-1) * ((s + t) / 2) - (b/(3*a)) - (((sqrt 3)/(2)) * (s - t)))

cubeRoot :: Double -> Double
cubeRoot n = do
    if n == 0
        then 0
        else
            if n > 0
                then n ** (1/3)
                else
                    if n < 0
                        then (-1) * ((-n) ** (1/3))
                        else n ** (1/3)


-- ch1 ex 1.25

import qualified Data.Vector as V

import Statistics.Sample.Histogram (histogram)
import Statistics.Sample (mean, varianceUnbiased, stdDev, range)

samples :: V.Vector Double
samples = V.fromList
  [  16, 224,  16,  80,  96, 536, 400,  80
  , 392, 576, 128,  56, 656, 224,  40,  32
  , 358, 384, 256, 246, 328, 464, 448, 716
  , 304,  16,  72,   8,  80,  72,  56, 608
  , 108, 194, 136, 224,  80,  16, 424, 264
  , 156, 216, 168, 184, 552,  72, 184, 240
  , 438, 120, 308,  32, 272, 152, 328, 480
  ,  60, 208, 340, 104,  72, 168,  40, 152
  , 360, 232,  40, 112, 112, 288, 168, 352
  ,  56,  72,  64,  40, 184, 264,  96, 224
  , 168, 168, 114, 280, 152, 208, 160, 176
  ]

hist :: (V.Vector Double, V.Vector Int)
hist = histogram 15 samples

main = do
  putStrLn $ "the range/4: " ++ show (range samples / 4)

  let av = mean samples
      sd = stdDev samples

  putStrLn $ "the standard deviation: " ++ show sd
  putStrLn $ "the mean value: " ++ show av

  let (bins, hs) = hist
  print hs

  let f k = V.length . V.filter (\x -> (av-k*sd)<x && x< (av+k*sd)) $ samples
  putStrLn $ "the sample size:    " ++ show (V.length samples)
  putStrLn $ "within one sigma:   " ++ show (f 1)
  putStrLn $ "within two sigma:   " ++ show (f 2)
  putStrLn $ "within three sigma: " ++ show (f 3)


module Matrix (
    tests_Matrix
    ) where

import Control.Monad( replicateM, zipWithM_ )
import Data.AEq
import Data.List( transpose )
import Debug.Trace
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck hiding ( vector )
import qualified Test.QuickCheck as QC

import Numeric.LinearAlgebra
import qualified Numeric.LinearAlgebra.Matrix as M
import qualified Numeric.LinearAlgebra.Vector as V

import Test.QuickCheck.LinearAlgebra( TestElem(..), Dim2(..), Index2(..),
    Assocs2(..), MatrixPair(..) )
import qualified Test.QuickCheck.LinearAlgebra as Test

import Typed

tests_Matrix = testGroup "Matrix"
    [ testPropertyI "dim . fromList" prop_dim_fromList
    , testPropertyI "at . fromList" prop_at_fromList
    , testPropertyI "fromCols" prop_fromCols
    , testPropertyI "fromRows" prop_fromRows
    , testPropertyI "constant" prop_constant
    , testPropertyI "indices" prop_indices
    , testPropertyI "elems" prop_elems
    , testPropertyI "assocs" prop_assocs
    , testPropertyI "update" prop_update
    , testPropertyI "accum" prop_accum
    , testPropertyI "map" prop_map
    , testPropertyI "zipWith" prop_zipWith
    , testPropertyI "col" prop_col
    , testPropertyI "cols" prop_cols
    , testPropertyD "row" prop_row
    , testPropertyD "rows" prop_rows
    , testPropertyI "diag" prop_diag
    , testPropertyI "slice" prop_slice
    , testPropertyI "splitRowsAt" prop_splitRowsAt
    , testPropertyI "splitColsAt" prop_splitColsAt
    , testPropertyI "viewVector" prop_viewVector
    , testPropertyDZ "shiftDiag" prop_shiftDiag prop_shiftDiag
    , testPropertyDZ "shiftDiagWithScale"
        prop_shiftDiagWithScale prop_shiftDiagWithScale
    , testPropertyDZ "add" prop_add prop_add
    , testPropertyDZ "sub" prop_sub prop_sub
    , testPropertyDZ "scale" prop_scale prop_scale
    , testPropertyDZ "scaleRows" prop_scaleRows prop_scaleRows
    , testPropertyDZ "scaleCols" prop_scaleCols prop_scaleCols
    , testPropertyDZ "negate" prop_negate prop_negate
    , testPropertyDZ "conjugate" prop_conjugate prop_conjugate
    , testPropertyDZ "trans" prop_trans prop_trans
    , testPropertyDZ "conjTrans" prop_conjTrans prop_conjTrans
    , testPropertyDZ "rank1Update" prop_rank1Update prop_rank1Update
    , testPropertyDZ "mulVector" prop_mulVector prop_mulVector
    , testPropertyDZ "mulVectorWithScale" prop_mulVectorWithScale prop_mulVectorWithScale
    , testPropertyDZ "addMulVectorWithScales" prop_addMulVectorWithScales prop_addMulVectorWithScales
    , testPropertyDZ "mulMatrix" prop_mulMatrix prop_mulMatrix
    , testPropertyDZ "mulMatrixWithScale" prop_mulMatrixWithScale prop_mulMatrixWithScale
    , testPropertyDZ "addMulMatrixWithScales" prop_addMulMatrixWithScales prop_addMulMatrixWithScales

    ]

------------------------- Matrix Construction ------------------------------

prop_dim_fromList t (Dim2 (m,n)) =
    forAll (QC.vector $ m*n) $ \es -> let
        a = typed t $ M.fromList (m,n) es
        in M.dim a == (m,n)

prop_at_fromList t (Dim2 (m,n)) =
    forAll (QC.vector $ m*n) $ \es -> let
        a = typed t $ M.fromList (m,n) es
        in and [ M.at a (i,j) === e
               | ((i,j),e) <- zip [ (i,j) | j <- [ 0..n-1 ], i <- [ 0..m-1 ] ]
                                  es
               ]

prop_fromCols t (Dim2 (m,n)) =
    forAll (replicateM n $ Test.vector m) $ \cs ->
        M.fromCols (m,n) cs === (typed t $ M.fromList (m,n) $
            concatMap V.elems cs)

prop_fromRows t (Dim2 (m,n)) =
    forAll (replicateM m $ Test.vector n) $ \rs ->
        M.fromRows (m,n) rs === (typed t $ M.fromList (m,n) $
            concat $ transpose $ map V.elems rs)

prop_constant t (Dim2 (m,n)) e =
    M.constant (m,n) e === M.fromList (m,n) (replicate (m*n) e)
  where
    _ = typed t [e]

-------------------------- Accessing Matrices ------------------------------

prop_indices t x =
    M.indices x === [ (i,j) | j <- [ 0..n-1 ], i <- [ 0..m-1 ] ]
  where
    (m,n) = M.dim x
    _ = immutableMatrix x
    _ = typed t x

prop_elems t x =
    M.elems x === [ M.at x i | i <- M.indices x ]
  where
    _ = typed t x

prop_assocs t x =
    M.assocs x === zip (M.indices x) (M.elems x)
  where
    _ = typed t x

------------------------- Incremental Updates ------------------------------

prop_update t (Assocs2 mn ies) =
    forAll (typed t `fmap` Test.matrix mn) $ \x -> let
        x' = M.update x ies
        is = M.indices x
        is1 = (fst . unzip) ies
        is0 = [ i | i <- is, i `notElem` is1 ]
        in and $
            [ M.at x' i `elem` [ e | (i',e) <- ies, i' == i ]
            | i <- is1
            ] ++
            [ M.at x' i === M.at x i
            | i <- is0
            ]

prop_accum t (Blind f) (Assocs2 mn ies) =
    forAll (typed t `fmap` Test.matrix mn) $ \x -> let
        x' = M.accum f x ies
        in x' === M.fromList mn [ foldl f e [ e' | (i',e') <- ies, i' == i]
                                | (i,e) <- M.assocs x ]
  where
      _ = typed t $ (snd . unzip) ies

-------------------------- Derived Matrices ------------------------------

prop_map t (Blind f) x =
    M.map f x === M.fromList (M.dim x) (map f $ M.elems x)
  where
    _ = typed t x
    _ = typed t $ M.map f x

prop_zipWith t (Blind f) (MatrixPair x y) =
    M.zipWith f x y === (M.fromList (M.dim x) $
                                zipWith f (M.elems x) (M.elems y))
  where
    _ = typed t x
    _ = typed t y
    _ = typed t $ M.zipWith f x y

------------------------------ Matrix Views --------------------------------

prop_col t (Index2 (m,n) (_,j)) =
    forAll (typed t `fmap` Test.matrix (m,n)) $ \a ->
        M.col a j === V.fromList m [ M.at a (i,j) | i <- [ 0..m-1 ] ]

prop_cols t a =
    M.cols a === [ M.col a j | j <- [ 0..n-1 ] ]
  where
    (_,n) = M.dim a
    _ = typed t $ immutableMatrix a

prop_row t (Index2 (m,n) (i,_)) =
    forAll (typed t `fmap` Test.matrix (m,n)) $ \a ->
        M.row a i === V.fromList n [ M.at a (i,j) | j <- [ 0..n-1 ] ]

prop_rows t a =
    M.rows a === [ M.row a i | i <- [ 0..m-1 ] ]
  where
    (m,_) = M.dim a
    _ = typed t $ immutableMatrix a

prop_diag t a =
    M.diag a === V.fromList mn [ M.at a (i,i) | i <- [ 0..mn-1 ] ]
  where
    (m,n) = M.dim a
    mn = min m n
    _ = typed t $ immutableMatrix a

prop_slice t a =
    forAll (choose (0,m)) $ \m' ->
    forAll (choose (0,n)) $ \n' ->
    forAll (choose (0,m-m')) $ \i ->
    forAll (choose (0,n-n')) $ \j ->
        M.slice (i,j) (m',n') a
            === M.fromCols (m',n') [ V.slice i m' (M.col a j')
                                      | j' <- [ j..j+n'-1 ] ]
  where
    (m,n) = M.dim a
    _ = typed t a

prop_splitRowsAt t a =
    forAll (choose (0,m)) $ \i ->
        M.splitRowsAt i a
            === ( M.slice (0,0) (i,n) a
                , M.slice (i,0) (m-i,n) a
                )
  where
    (m,n) = M.dim a
    _  = typed t $ immutableMatrix a

prop_splitColsAt t a =
    forAll (choose (0,n)) $ \j ->
        M.splitColsAt j a
            === ( M.slice (0,0) (m,j) a
                , M.slice (0,j) (m,n-j) a
                )
  where
    (m,n) = M.dim a
    _  = typed t $ immutableMatrix a

prop_viewVector t (Dim2 (m,n)) =
    forAll (Test.vector $ m*n) $ \x -> let _ = typed t x in
        M.elems (M.fromVector (m,n) x) === V.elems x

-------------------------- Num Matrix Operations --------------------------

prop_shiftDiag t a =
    forAll (Test.vector (min m n)) $ \d ->
        M.shiftDiag d a
            === M.accum (+) a [ ((i,i),e) | (i,e) <- V.assocs d ]
  where
    (m,n) = M.dim a
    _ = typed t a

prop_shiftDiagWithScale t k a =
    forAll (Test.vector (min m n)) $ \d ->
        M.shiftDiagWithScale k d a
            ~== M.accum (+) a [ ((i,i),k * e) | (i,e) <- V.assocs d ]
  where
    (m,n) = M.dim a
    _ = typed t a

prop_add t (MatrixPair x y) =
    x `M.add` y === M.zipWith (+) x y
  where
    _ = typed t x

prop_sub t (MatrixPair x y) =
    x `M.sub` y === M.zipWith (-) x y
  where
    _ = typed t x

prop_scale t k x =
    M.scale k x ~== M.map (k*) x
  where
    _ = typed t x

prop_scaleRows t a =
    forAll (Test.vector m) $ \s ->
        M.scaleRows s a
            ~== M.fromCols (m,n) [ V.mul s x | x <- M.cols a ]
  where
    (m,n) = M.dim a
    _ = typed t a

prop_scaleCols t a =
    forAll (Test.vector n) $ \s ->
        M.scaleCols s a
            ~== M.fromCols (m,n)
                    [ V.scale e x
                    | (e,x) <- zip (V.elems s) (M.cols a) ]
  where
    (m,n) = M.dim a
    _ = typed t a

prop_negate t x =
    M.negate x === M.map negate x
  where
    _ = typed t x

prop_conjugate t x =
    M.conjugate x === M.map conjugate x
  where
    _ = typed t x

-------------------------- Linear Algebra --------------------------

prop_trans t a =
    M.trans a
        ===
        M.update (M.zero (swap $ M.dim a)) [ (swap ij, e) | (ij,e) <- M.assocs a ]
  where
    swap (i,j) = (j,i)
    _ = typed t a

prop_conjTrans t a =
    M.conjTrans a === M.conjugate (M.trans a)
  where
    _ = typed t a

prop_rank1Update t alpha a =
    forAll (Test.vector m) $ \x ->
    forAll (Test.vector n) $ \y -> let y' = V.conjugate y in
        M.rank1Update alpha x y a
            ~==
            M.update (M.zero (m,n))
                     [ ((i,j), alpha * V.at x i * V.at y' j + e)
                     | ((i,j),e) <- M.assocs a
                     ]
  where
    (m,n)= M.dim a
    _ = typed t a

data MulMatrixAddVector e =
    MulMatrixAddVector Trans (Matrix e) (Vector e) (Vector e) deriving (Show)

instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixAddVector e) where
    arbitrary = do
        transa <- arbitrary
        a <- arbitrary
        let (ma,na) = M.dim a
            (m,n) = case transa of NoTrans -> (ma,na)
                                   _       -> (na,ma)
        x <- Test.vector n
        y <- Test.vector m
        return $ MulMatrixAddVector transa a x y

data MulMatrixVector e =
    MulMatrixVector Trans (Matrix e) (Vector e) deriving (Show)
instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixVector e) where
    arbitrary = do
        (MulMatrixAddVector transa a x _) <- arbitrary
        return $ MulMatrixVector transa a x

prop_mulVector t (MulMatrixVector transa a x) =
    M.mulVector transa a x
        ~==
        case transa of
            NoTrans   -> V.fromList (fst $ M.dim a)
                                    [ V.dot x (V.conjugate r)
                                    | r <- M.rows a ]

            Trans     -> V.fromList (snd $ M.dim a)
                                    [ V.dot x (V.conjugate c)
                                    | c <- M.cols a ]

            ConjTrans -> V.fromList (snd $ M.dim a)
                                    [ V.dot x c
                                    | c <- M.cols a ]
  where
    _ = typed t a

prop_mulVectorWithScale t alpha (MulMatrixVector transa a x) =
    M.mulVectorWithScale alpha transa a x
        ~==
        M.mulVector transa a (V.scale alpha x)
  where
    _ = typed t a

prop_addMulVectorWithScales t alpha beta (MulMatrixAddVector transa a x y) =
    M.addMulVectorWithScales alpha transa a x beta y
        ~==
        V.add (M.mulVectorWithScale alpha transa a x)
              (V.scale beta y)
  where
    _ = typed t a

data MulMatrixAddMatrix e =
    MulMatrixAddMatrix Trans (Matrix e) Trans (Matrix e) (Matrix e) deriving (Show)

instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixAddMatrix e) where
    arbitrary = do
        transa <- arbitrary
        transb <- arbitrary
        c <- arbitrary
        k <- fst `fmap` Test.dim2

        let (m,n) = M.dim c
            (ma,na) = case transa of NoTrans -> (m,k)
                                     _       -> (k,m)
            (mb,nb) = case transb of NoTrans -> (k,n)
                                     _       -> (n,k)
        a <- Test.matrix (ma,na)
        b <- Test.matrix (mb,nb)

        return $ MulMatrixAddMatrix transa a transb b c

data MulMatrixMatrix e =
    MulMatrixMatrix Trans (Matrix e) Trans (Matrix e) deriving (Show)
instance (Storable e, Arbitrary e) => Arbitrary (MulMatrixMatrix e) where
    arbitrary = do
        (MulMatrixAddMatrix transa a transb b _) <- arbitrary
        return $ MulMatrixMatrix transa a transb b

prop_mulMatrix t (MulMatrixMatrix transa a transb b) =
    M.mulMatrix transa a transb b
        ~==
        M.fromCols (m,n) [ M.mulVector transa a x | x <- M.cols b' ]
  where
    m = case transa of NoTrans -> (fst $ M.dim a)
                       _       -> (snd $ M.dim a)
    n = case transb of NoTrans -> (snd $ M.dim b)
                       _       -> (fst $ M.dim b)
    b' = case transb of NoTrans   -> b
                        Trans     -> M.trans b
                        ConjTrans -> M.conjTrans b
    _ = typed t a

prop_mulMatrixWithScale t alpha (MulMatrixMatrix transa a transb b) =
    M.mulMatrixWithScale alpha transa a transb b
        ~==
        M.scale alpha (M.mulMatrix transa a transb b)
  where
    _ = typed t a

prop_addMulMatrixWithScales t alpha beta (MulMatrixAddMatrix transa a transb b c) =
    M.addMulMatrixWithScales alpha transa a transb b beta c
        ~==
        M.add (M.scale alpha (M.mulMatrix transa a transb b))
              (M.scale beta c)
  where
    _ = typed t a

testAEq a b =
    if a ~== b then True
               else trace ("expected: " ++ show b ++ "\nactual: " ++ show a) False


module LinearRegression where

import Statistics.LinearRegression
import qualified Data.Vector.Unboxed as U
import Data.Decimal
import Graphics.EasyPlot

xs :: [Double]
xs = [25.47,67.80,20.65,22.50,30.40,55.30,22.74] ++
         [29.11,31.15,40.97,58.89,64.85,74.89,96.14] ++
         [65.37,80.23,95.80,92.71,98.16,89.77]

ys :: [Double]
ys = [390.50,632.70,449.36,501.81,621.72,684.62,685.53] ++
         [701.76,868.71,995.69,893.50,1240.48,1393.55] ++
         [1826.70,2145.32,2295.27,2522.79,2931.69] ++
         [2836.20,2456.30]

-- Values from a list
--
varIndep  = U.fromList xs
varDepend = U.fromList ys

-- computing theta0 and theta1 : Y = t0 + b1.X

(b0, b1) = linearRegression varIndep varDepend

b0n = realFracToDecimal 3 b0
b1n = realFracToDecimal 3 b1

points = zip xs ys

f x = b0 + b1*x
g x = ((*b0).sin.(/b1)) x

functionY = do
  plot X11 $ [
                    Function2D
                    [Title "Linear Regression", Color Red]
                    [Range 0 140] (g)
                    , Data2D
                    [Title "Data", Color Blue]
                    [] points
                    , Function2D
                    [Title "Linear Regression", Color Red]
                    [Range 0 140] (f)
                 ]


module Main where
import System.Environment (getArgs)
import Data.Complex
import Data.List.Split (chunksOf)
import Text.Read (readMaybe)
import Data.Maybe (isJust)

type Point = Complex Double
data MandelbrotPoint = MandelbrotPoint Int {-n-} Point {-z_n-} Point {-c-}

instance Show MandelbrotPoint where
  show (MandelbrotPoint n _ _)
    | n == 100  = " "
    | n > 10    = "#"
    | otherwise = [".',;\"oO%8@" !! (n - 1)]

data Mandelbrot = Mandelbrot [MandelbrotPoint] {-state-} Int {-width-}

instance Show Mandelbrot where
  show (Mandelbrot state width) =
    unlines $ chunksOf width $ concatMap show state

data Arguments = Arguments Point {-topleft-} Point {-bottomright-} Int {-width-} Int {-height-}

main :: IO ()
main = do
  args <- getArgs
  putStr $ show $ mandelbrot 100 $ initialise $ parseArguments args

usage :: IO ()
usage = do
  putStrLn "Usage: mandelbrot [TOPLEFT BOTTOMRIGHT WIDTH HEIGHT]"
  putStrLn "  TOPLEFT      Top-left corner of complex subplane"
  putStrLn "  BOTTOMRIGHT  Bottom-right corner of complex subplane"
  putStrLn "  WIDTH        Output width (characters)"
  putStrLn "  HEIGHT       Output height (characters)"

parseArguments :: [String] -> Arguments
parseArguments [topLeft, bottomRight, width, height] =
  if (all isJust planeCoords) && (all isJust imageCoords)
    -- TODO Sanity check values
    then Arguments (read topLeft) (read bottomRight) (read width) (read height)
    else error "Bad arguments" -- TODO: Print usage and exit 1
  where planeCoords = map readMaybe [topLeft, bottomRight] :: [Maybe Point]
        imageCoords = map readMaybe [width, height]        :: [Maybe Int]

-- Default values
parseArguments _ = Arguments ((-2) :+ 1) (1 :+ (-1)) 99 33

initialise :: Arguments -> Mandelbrot
initialise (Arguments topLeft bottomRight width height) =
  Mandelbrot (map (MandelbrotPoint 0 0) field) width
  where [w, h]    = map fromIntegral [width, height]
        diagonal  = bottomRight - topLeft
        scaleReal = realPart diagonal / (w - 1)
        scaleImag = imagPart diagonal / (h - 1)
        field     = [ ((x * scaleReal) :+ (y * scaleImag)) + topLeft
                    | y <- [0..(h - 1)], x <- [0..(w - 1)]]

mandelbrot :: Int -> Mandelbrot -> Mandelbrot
mandelbrot 0 state = state
mandelbrot x (Mandelbrot state width) =
  mandelbrot (x - 1) (Mandelbrot (map step state) width)
    where step point@(MandelbrotPoint n z_n c)
            | magnitude z_n > 2 = point
            | otherwise         = MandelbrotPoint (n + 1) ((z_n * z_n) + c) c


module Ch03.Activation where

import Prelude hiding (and, or)
import Numeric.LinearAlgebra hiding (step)
import Graphics.Gnuplot.Simple

-- Activation functions
step :: [R] -> [R]
step = map (\x -> if x > 0.0 then 1.0 else 0.0)

sigmoid :: [R] -> [R]
sigmoid = map (\x -> 1 / (1 + exp (-x)))

relu :: [R] -> [R]
relu = map $ max 0

-- Graphs
step_graph :: IO ()
step_graph = plotPath  [Title "step", YRange (-0.2, 1.2)] $ zip xs ys
  where
    xs = linearScale 1000 (-5.0, 5.0)
    ys = step xs

sigmoid_graph :: IO ()
sigmoid_graph = plotPath  [Title "sigmoid", YRange (-0.2, 1.2)] $ zip xs ys
  where
    xs = linearScale 1000 (-5.0, 5.0)
    ys = sigmoid xs

sigmoid_step_graph :: IO ()
sigmoid_step_graph = plotPathsStyle
                     [Title "sigmoid and step", YRange (-0.2, 1.2)]
                     [(style1, zip xs ys1), (style2, zip xs ys2)]
  where
    xs     = linearScale 1000 (-5.0, 5.0)
    ys1    = sigmoid xs
    ys2    = step xs
    style1 = PlotStyle Lines $ CustomStyle [(LineTitle "sigmoid")]
    style2 = PlotStyle Lines $ CustomStyle [(LineTitle "step")]

relu_graph :: IO ()
relu_graph = plotPath [Title "ReLU", YRange (-1.0, 5.5)] $ zip xs ys
  where
    xs = linearScale 1000 (-5.0, 5.0)
    ys = relu xs


-- ex 1.13 (1.2, 1.17)

import qualified Data.Vector as V

import Statistics.Sample.Histogram (histogram)
import Statistics.Sample as S (mean, stdDev, range)

import Statistics.Distribution
import Statistics.Distribution.Normal
import Statistics.Distribution.Binomial

-- Average wind speeds for 45 us cities:
samples :: V.Vector Double
samples = V.fromList
  [ 8.9,12.4, 8.6,11.3, 9.2, 8.8,35.1, 6.2, 7.0
  , 7.1,11.8,10.7, 7.6, 9.1, 9.2, 8.2, 9.0, 8.7
  , 9.1,10.9,10.3, 9.6, 7.8,11.5, 9.3, 7.9, 8.8
  , 8.8,12.7, 8.4, 7.8, 5.7,10.5,10.5, 9.6, 8.9
  ,10.2,10.3, 7.7,10.6, 8.3, 8.8, 9.5, 8.8, 9.4
  ]

-- 1.2 histogram
hist :: (V.Vector Double, V.Vector Int)
hist = histogram 12 samples

main :: IO ()
main = do
  let (lowerBs, hs) = hist
  putStrLn $ "The lower bounds: " ++ show lowerBs
  putStrLn $ "The histogram: " ++ show hs

  let av = S.mean samples
      sd = S.stdDev samples
  putStrLn $ "The average value is: " ++ show av ++ " and the standard deviation is: " ++ show sd

  let f k =
       V.length . V.filter (\x -> (av-k*sd)<x && x< (av+k*sd)) $ samples
  putStrLn $ "Our sample size is: " ++ show (V.length samples)
  putStrLn $ "Within one sigma:   " ++ show (f 1)
  putStrLn $ "Within two sigma:   " ++ show (f 2)
  putStrLn $ "Within three sigma: " ++ show (f 3)

  putStrLn $ "range/4 is:           " ++ show (S.range samples / 4)
  putStrLn $ "The average value is: " ++ show av


{- MathHmatrix.hs
 - Mapping of Linear algebra routines via the hMatrix library.
 - hMatrix uses GSL and a BLAS implementation such as ATLAS.
 -
 - Timothy A. Chagnon
 - CS 636 - Spring 2009
 -}
module MathHmatrix where

import Numeric.LinearAlgebra

deg2rad :: RealT -> RealT
deg2rad d = d * pi / 180

type RealT = Double
type Vec3f = Vector Double

vec3f :: Double -> Double -> Double -> Vector Double
vec3f x y z = (3 |>) [x,y,z]

zeroVec3f :: Vec3f
zeroVec3f = vec3f 0 0 0
svMul   :: Double -> Vec3f -> Vec3f
svMul = scale
dot     :: Vec3f -> Vec3f -> Double
dot  = Numeric.LinearAlgebra.dot
cross   :: Vec3f -> Vec3f -> Vec3f
cross v1 v2 =
    let [a, b, c] = toList v1 in
    let [d, e, f] = toList v2 in
    vec3f (b*f-c*e) (c*d-a*f) (a*e-b*d)

mag     :: Vec3f -> Double
mag v   = sqrt (magSq v)
magSq   :: Vec3f -> Double
magSq v = v `Numeric.LinearAlgebra.dot` v
norm    :: Vec3f -> Vec3f
norm v  = (1/(mag v)) `svMul` v

type Mat4f = Matrix Double
mat4f :: Vec4f -> Vec4f -> Vec4f -> Vec4f -> Mat4f
mat4f a b c d = fromRows [a,b,c,d]

type Vec4f = Vector Double
vec4f :: Double -> Double -> Double -> Double -> Vector Double
vec4f x y z w = (4 |>) [x,y,z,w]

mvMul     :: Mat4f -> Vec4f -> Vec4f
mvMul  = (<>)
mmMul     :: Mat4f -> Mat4f -> Mat4f
mmMul  = (<>)

id4f :: Mat4f
id4f = ident 4

point4f :: Vec3f -> Vec4f
point4f v = 4 |> ((toList v) ++ [1.0])

point3f :: Vec4f -> Vec3f
point3f v =
    let [x, y, z, w] = toList v in
    if w == 0
        then error "point3f divide by zero"
        else vec3f (x/w) (y/w) (z/w)

direction4f :: Vec3f -> Vec4f
direction4f v = 4 |> ((toList v) ++ [0.0])

direction3f :: Vec4f -> Vec3f
direction3f = subVector 0 3

vec3fElts :: Vec3f -> (RealT, RealT, RealT)
vec3fElts v =
    let [x,y,z] = toList v in
    (x,y,z)

type ColMat3f = Matrix Double
colMat3f :: Vec3f -> Vec3f -> Vec3f -> ColMat3f
colMat3f a b c = fromColumns [a,b,c]

detMat3f :: ColMat3f -> RealT
detMat3f = det


module Lib
  ( lab3
  ) where

import Data.Complex
import Data.List
import Generator
import Graphics.Gnuplot.Simple
import qualified Graphics.Gnuplot.Terminal.PNG as PNG

dft :: [Float] -> Int -> Complex Float
dft xs k =
  sum $ zipWith (\element index -> toComplex element * tc index) xs [0.0 ..]
  where
    tc n = toComplex (cos $ arg n) - toComplex (sin $ arg n) * imOne
    arg n = 2.0 * pi * fromIntegral k * n / fromIntegral (length xs)

fft :: [Float] -> Int -> Bool -> Complex Float
fft xs k lower
  | lower = evenPart + expPart * oddPart
  | otherwise = evenPart - expPart * oddPart
  where
    evenPart = dft (evens xs) k
    oddPart = dft (odds xs) k
    expPart = exp $ -2 * pi * fromIntegral k * imOne / fromIntegral (length xs)

evens :: [a] -> [a]
evens (x:xs) = x : odds xs
evens _ = []

odds :: [a] -> [a]
odds (_:xs) = evens xs
odds _ = []

toComplex :: Num a => a -> Complex a
toComplex x = x :+ 0

imOne :: Complex Float
imOne = 0.0 :+ 1.0

printTwoLists :: Show a => [a] -> [a] -> IO ()
printTwoLists xs ys =
  putStrLn . unlines . map (intercalate "      \t\t" . map show) . transpose $
  xs : [ys]

lab3 :: IO ()
lab3 = do
  let sHarmonics = 8
  let sAmplitude = 100
  let sFrequency = 1200
  let sPhase = 100
  let sTime = 60
  let signal =
        [ randomSignal sHarmonics t sAmplitude sFrequency sPhase
        | t <- [0 .. sTime - 1]
        ]
  let spectral_dft = [dft signal k | k <- [0 .. sTime - 1]]
  let spectral_fft =
        [fft signal k True | k <- [0 .. n1 - 1]] ++
        [fft signal k False | k <- [0 .. n2 - 1]]
        where
          n1 = (ceiling :: Float -> Int) $ fromIntegral (length signal) / 2
          n2 = (floor :: Float -> Int) $ fromIntegral (length signal) / 2
  putStrLn . unlines . map show $ signal
  printTwoLists spectral_dft spectral_fft
  plotLists
    [ Key Nothing
    , XLabel "Time"
    , YLabel "Value"
    , Title "Random signal"
    , terminal (PNG.cons "signal.png")
    ]
    [signal]
  plotLists
    [ Key Nothing
    , XLabel "Time"
    , YLabel "Value"
    , Title "DFT"
    , terminal (PNG.cons "dft.png")
    ]
    [map realPart spectral_dft, map imagPart spectral_dft]
  plotLists
    [ Key Nothing
    , XLabel "Time"
    , YLabel "Value"
    , Title "FFT"
    , terminal (PNG.cons "fft.png")
    ]
    [map realPart spectral_fft, map imagPart spectral_fft]


-- ch3 example 3.17

import Statistics.Distribution
import Statistics.Distribution.Hypergeometric

h :: HypergeometricDistribution
h = hypergeometric m l k
  where
    m =  4 -- r
    l = 20 -- N of population size
    k =  5 -- n of samplie size

p :: Int -> Double
p = probability h

main :: IO ()
main = do
  putStrLn $ "p2 + p3 + p3 = " ++ show (p 2 + p 3 + p 4)
  putStrLn $ "1 - p0 - p1 =  " ++ show (1 - p 0 - p 1)
  putStrLn $ "1 - P(X<=1) =  " ++ show (complCumulative h 1)

  putStrLn $ "Indeed p0 and p1 are: " ++ show (p 0) ++ " and " ++ show (p 1)
  putStrLn $ "The mean = " ++ show (mean h) ++ " variance = " ++ show (variance h)
          ++ " and stdDev = " ++ show (stdDev h)


module Statistics (
    tests_Statistics
    ) where

import Control.Monad( replicateM )
import Data.AEq
import Data.List( foldl' )
import Debug.Trace
import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck hiding ( vector )
import qualified Test.QuickCheck as QC

import Numeric.LinearAlgebra
import qualified Numeric.LinearAlgebra.Packed as P
import qualified Numeric.LinearAlgebra.Matrix as M
import qualified Numeric.LinearAlgebra.Vector as V

import Test.QuickCheck.LinearAlgebra( VectorList(..), WeightedVectorList(..) )
import qualified Test.QuickCheck.LinearAlgebra as Test

import Typed

testAEq actual expected =
    if actual ~== expected
        then True
        else trace ("expected: " ++ show expected ++ "\nactual: " ++ show actual)
                   False

tests_Statistics = testGroup "Statistics"
    [ testPropertyD "sum" prop_sum
    , testPropertyD "weightedSum" prop_weightedSum
    , testPropertyD "mean" prop_mean
    , testPropertyD "weightedMean" prop_weightedMean
    , testPropertyD "weightedMean (equal weights)" prop_weightedMean_eqw
    , testPropertyD "Matrix cov" prop_Matrix_cov
    , testPropertyD "Matrix covWithMean" prop_Matrix_covWithMean
    , testPropertyD "Matrix weightedCov (equal weights)" prop_Matrix_weightedCov_eqw
    , testPropertyD "Matrix weightedCov" prop_Matrix_weightedCov
    , testPropertyD "Matrix weightedCovWithMean" prop_Matrix_weightedCovWithMean
    , testPropertyD "Packed cov" prop_Packed_cov
    , testPropertyD "Packed covWithMean" prop_Packed_covWithMean
    , testPropertyD "Packed weightedCov (equal weights)" prop_Packed_weightedCov_eqw
    , testPropertyD "Packed weightedCov" prop_Packed_weightedCov
    , testPropertyD "Packed weightedCovWithMean" prop_Packed_weightedCovWithMean
    ]

prop_sum t (VectorList p xs) =
    V.sum p xs ~== foldl' V.add (V.constant p 0) xs
  where
    _ = typed t (head xs)

prop_weightedSum t (WeightedVectorList p wxs) =
    V.weightedSum p wxs
            ~== V.sum p (map (uncurry V.scale) wxs)
  where
    n = length wxs
    _ = typed t (snd $ head wxs)

prop_mean t (VectorList p xs) =
    V.mean p xs ~== V.scale (1/n) (V.sum p xs)
  where
    n = fromIntegral $ max (length xs) 1
    _ = typed t (head xs)

prop_weightedMean_eqw t (VectorList p xs) = let
    wxs = zip (repeat 1) xs
    in V.weightedMean p wxs ~== V.mean p xs
  where
    _ = typed t (head xs)

prop_weightedMean t (WeightedVectorList p wxs) = let
        w_sum = (sum . fst . unzip) wxs
        in V.weightedMean p wxs
            ~== if w_sum == 0 then V.constant p 0
                              else V.scale (1/w_sum) (V.weightedSum p wxs)
  where
    n = length wxs
    _ = typed t (snd $ head wxs)

prop_Matrix_cov t (VectorList p xs) =
    forAll (Test.vector p) $ \z ->
    forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let
        xbar = V.mean p xs
        ys = [ V.sub x xbar | x <- xs ]
        scale = case method of { UnbiasedCov -> 1/(n-1) ; MLCov -> 1/n }
        cov' = foldl' (flip $ \y -> M.rank1Update scale y y)
                      (M.constant (p,p) 0)
                      ys
        cov = M.cov p method xs

        in M.hermMulVector cov z ~== M.mulVector NoTrans cov' z
  where
    n = fromIntegral $ length xs
    _ = typed t $ head xs

prop_Matrix_covWithMean t (VectorList p xs) =
    forAll (Test.vector p) $ \z ->
    forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let
        xbar = V.mean p xs
        cov' = M.covWithMean xbar method xs
        cov = M.cov p method xs
        in M.hermMulVector cov z ~== M.hermMulVector cov' z
  where
    n = fromIntegral $ length xs
    _ = typed t $ head xs

prop_Matrix_weightedCov_eqw t (VectorList p xs) =
    forAll (Test.vector p) $ \z ->
    forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let
        wxs = zip (repeat 1) xs
        cov = M.weightedCov p method wxs
        cov' = M.cov p method xs
        in M.hermMulVector cov z ~== M.hermMulVector cov' z
  where
    n = fromIntegral $ length xs
    _ = typed t $ head xs

prop_Matrix_weightedCov t (WeightedVectorList p wxs) =
    forAll (Test.vector p) $ \z ->
    forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let
        (ws,xs) = unzip wxs

        w_sum = sum ws
        ws' = [ w / w_sum | w <- ws ]
        w2_sum = sum [ w*w | w <- ws' ]
        scale = case method of { UnbiasedCov -> 1/(1-w2_sum) ; MLCov -> 1 }

        xbar = V.weightedMean p wxs
        wys = [ (w, V.sub x xbar) | (w,x) <- zip ws' xs ]
        cov' = if w_sum == 0
                    then M.constant (p,p) 0
                    else foldl' (flip $ \(w,y) -> M.rank1Update (scale*w) y y)
                                (M.constant (p,p) 0)
                                wys

        cov = M.weightedCov p method wxs

        in M.hermMulVector cov z ~== M.mulVector NoTrans cov' z
  where
    n = fromIntegral $ length wxs
    _ = typed t $ snd $ head wxs

prop_Matrix_weightedCovWithMean t (WeightedVectorList p wxs) =
    forAll (Test.vector p) $ \z ->
    forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let
        xbar = V.weightedMean p wxs
        cov' = M.weightedCov p method wxs
        cov = M.weightedCovWithMean xbar method wxs
        in M.hermMulVector cov z ~== M.hermMulVector cov' z
  where
    n = fromIntegral $ length wxs
    _ = typed t $ snd $ head wxs

prop_Packed_cov t (VectorList p xs) =
    forAll (Test.vector p) $ \z ->
    forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let
        cov' = M.cov p method xs
        cov = P.cov p method xs
        in P.hermMulVector cov z ~== M.hermMulVector cov' z
  where
    n = fromIntegral $ length xs
    _ = typed t $ head xs

prop_Packed_covWithMean t (VectorList p xs) =
    forAll (Test.vector p) $ \z ->
    forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let
        xbar = V.mean p xs
        cov = P.covWithMean xbar method xs
        cov' = P.cov p method xs
        in P.hermMulVector cov z ~== P.hermMulVector cov' z
  where
    n = fromIntegral $ length xs
    _ = typed t $ head xs

prop_Packed_weightedCov_eqw t (VectorList p xs) =
    forAll (Test.vector p) $ \z ->
    forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let
        wxs = zip (repeat 1) xs
        cov = P.weightedCov p method wxs
        cov' = P.cov p method xs
        in P.hermMulVector cov z ~== P.hermMulVector cov' z
  where
    n = fromIntegral $ length xs
    _ = typed t $ head xs

prop_Packed_weightedCov t (WeightedVectorList p wxs) =
    forAll (Test.vector p) $ \z ->
    forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let
        cov' = M.weightedCov p method wxs
        cov = P.weightedCov p method wxs
        in P.hermMulVector cov z ~== M.hermMulVector cov' z
  where
    n = fromIntegral $ length wxs
    _ = typed t $ snd $ head wxs

prop_Packed_weightedCovWithMean t (WeightedVectorList p wxs) =
    forAll (Test.vector p) $ \z ->
    forAll (elements [ UnbiasedCov, MLCov ]) $ \method -> let
        xbar = V.weightedMean p wxs
        cov' = P.weightedCov p method wxs
        cov = P.weightedCovWithMean xbar method wxs
        in P.hermMulVector cov z ~== P.hermMulVector cov' z
  where
    n = fromIntegral $ length wxs
    _ = typed t $ snd $ head wxs


module PCA.PCA
       ( PCA (..)
       , covariance
       , eigenValues
       , eigenVectors
       , inputData
       , finalData
       , makePCA
       , restoredData
       , meanMatrix
       ) where

import Universum hiding (All, Vector, transpose)

import PCA.Types

import Control.Lens (makeLenses)
import Data.Array.Repa
import Data.Array.Repa.Repr.ForeignPtr
import Numeric.LinearAlgebra.Repa hiding (Matrix, Vector)

data PCA = PCA
  {   _inputData    :: Matrix D Double
    , _covariance   :: Covariance Double
    , _eigenVectors :: EigenVectors Double
    , _eigenValues  :: Vector F Double
    , _finalData    :: Matrix D Double
    , _restoredData :: Matrix D Double
    , _meanMatrix   :: Matrix D Double
  }

makeLenses ''PCA

makePCA
    :: Int
    -> Matrix D Double
    -> PCA
makePCA desiredDimensions input =
  let _inputData = input
         -- get dimension
      (Z :. yInp :. _) = extent input
      (meanVec, _covariance) = meanCovS input
      _meanMatrix = extend (Z :. yInp :. All) meanVec
      adjustInput'@(ADelayed (Z :. _ :. _) _) = input -^ _meanMatrix
      (_eigenValues, eigenVec) = eigSH _covariance
      eigenVecD@(ADelayed (Z :. y :. x) f) = transpose eigenVec
        -- leave only n desired eigenvectors
      eigenVectors' =
        if desiredDimensions >= y
        then eigenVecD
        else ADelayed (Z :. desiredDimensions :. x) f
        -- colunmns are eigenvectors
      _eigenVectors = transpose eigenVectors'
        -- data in new eigenvectors space
      finalData' = runIdentity $ eigenVectors' `mulP` transpose adjustInput'
      _finalData = transpose finalData'
        -- restore to the original space
      restoredDataWOMean = transpose $ pinvS eigenVectors' `mul` finalData'
        -- add mean
      _restoredData = restoredDataWOMean +^ _meanMatrix
  in PCA{..}


module Main where

import Numeric.LinearAlgebra

data Model = Model { w::Matrix R, beta::Vector R} deriving Show

-- sigmoid
sigmoid :: R -> R
sigmoid x = 1 / (1 + exp (-x))

elm :: Matrix R -> Vector R -> Int -> IO Model
elm x y n = do _w <- randn n $ cols x
               let hidden = cmap sigmoid $ _w <> (tr x)
                   _beta = tr (pinv hidden) #> y
               return Model { w = _w, beta = _beta}

classify :: Model -> Matrix R -> Vector R
classify m x =
  let _w = w m
      _beta = beta m
  in cmap signum $ tr (cmap sigmoid $ _w <> (tr x)) #> _beta

main :: IO ()
main = do
  model <- elm x y n
  print "class label"
  print y
  print $ "result: hidden_neuron = " ++ show n
  print $ classify model x
    where x = matrix 3 [0, 0, 1,
                        0, 1, 1,
                        1, 0, 1,
                        1, 1, 1]
          y = vector [-1, 1, 1, -1]
          n = 10


{-# LANGUAGE Arrows #-}

import Control.Arrow
import Data.Complex

-- The DFT forms the specification for the FFT.
dft :: RealFloat a => [Complex a] -> [Complex a]
dft xs = [ sum [ x * exp((0.0 :+ (-1.0)) * 2 * pi / lenXs * fromIntegral(k * n))
                 | (x, n) <- zip xs [0..]
               ]
           | k <- [0..(length xs - 1)]
         ]
    where lenXs = fromIntegral $ length xs

-- FFT implementation
-- Note my reversal of Ross' even/odd convention, below.
-- I did this, to remain consistent with the explanation, above, which came from a pre-existing work.
fft :: RealFloat b => Hom (Complex b) (Complex b)
fft = id :&: proc (e, o) -> do
                e' <- fft             -< e
                o' <- fft >>> twiddle -< o
                unriffle -< f (e', o')
    where f (x, y) = (x + y, x - y)

twiddle :: RealFloat b => Hom (Complex b) (Complex b)
twiddle = id :&: twiddle' 1

twiddle' :: RealFloat b => Int -> Hom (Pair (Complex b)) (Pair (Complex b))
twiddle' n = (id *** (* phi)) :&: ((twiddle' n') *** ((twiddle' n') >>> (arr ((* phi) `prod` (* phi)))))
    where phi = cis (-pi / (fromIntegral n))
          n'  = n + 1

-- Testing machinery
-- Conversion to list, for comparison to specification (i.e. - DFT)
btToList :: BalTree b -> [b]
btToList (Zero x)      = [x]
btToList (Succ (x, y)) = btToList x ++ (btToList y)

-- Build a tree of depth 'n', taking values from supplied list, sequentially.
buildTree :: Int -> [b] -> BalTree b
buildTree = invertTree . buildTree'

data BalTree' b = Zero' b
                | Succ' (Pair (BalTree' b))

buildTree' :: Int -> [b] -> BalTree' b
buildTree' _       []     = error "Exhausted input!"
buildTree' 0       (x:xs) = Zero' x
buildTree' n       xs     = Succ' ((buildTree' (n-1) (evens xs)), (buildTree' (n-1) (odds xs)))

invertTree :: BalTree' b -> BalTree b
invertTree Zero' x            = Zero x
invertTree Succ' (bt'1, bt'2) = Succ (joinTrees (invertTree bt'1, invertTree bt'2))

-- joinTrees :: Pair (BalTree b) -> BalTree (Pair b)
joinTrees :: Pair (BalTree b) -> BalTree b
joinTrees (Zero x,   Zero y)   = Succ (Zero (x, y))
joinTrees (Succ bt1, Succ bt2) = Succ (joinTrees (bt1, bt2))


module Y2017.M02.D24.Solution where

-- below imports from cabal package 'statistics'

import Statistics.Distribution
import Statistics.Distribution.Binomial

{--
AHA!

Whenever you think you have to invent something, stop, pause, and think, ...

SOMEBODY ELSE HAS ALREADY DONE IT! USE THE DARK SIDE OF THE FORCE AND TOGETHER
WE CAN RULE THE GALAXY AS FATHER AND SON!

See? All you need is love, a psychopathic father that murders young children
at the Jedi Academy, and 'midichlorians.' Lots of 'midichlorians.'

Where was I?

Ah, yes: 'already invented.'

So, we know from Rosalind.Traits that any descendant from an Aa Bb/Aa Bb
pairing will have a 25% probability of itself being Aa Bb (you can verify
this if you'd like), so the question arises, what is the probability of at
least n offspring at generation x (or Generation X, if you prefer) also being
Aa Bb.

This is the cumulative (or actually co-cumulative) binomial probability
distribution.

So.

Today's Haskell problem: with the help of the above imports, create a binomial
probability distribution at 25%, run a scenario where you are in generation
x, where the xth generation has x^2 offspring, and you are looking for at least
n of the offspring to have the desired characteristic (in the abstract case,
the what the characteristic is doesn't matter, we need what the probably outcome
of having it.
--}

type Trials = Int

aAbB :: Trials -> BinomialDistribution
aAbB = (`binomial` 0.25)

genx :: Int -> BinomialDistribution -> Double
genx n bin = sum (map (probability bin) [n .. bdTrials bin])

{--
What is the result for gen = 2, n = at least 1?

>>> genx 1 (aAbB 4)
0.68359375

Now solve for gen = 7, n = at least 35:

>>> genx 35 (aAbB (2 ^ 7))
0.3006022057910504

*WHEW* That was a lot easier than rewriting probability theory by hand!
--}


module Mandelbrot where

import Data.Complex
import Graphics.Gloss
import Graphics.Gloss.Data.Color
import Graphics.Gloss.Raster.Field
-- import qualified Graphics.Image.Interface as Hip
-- import qualified Graphics.Image as Hip
-- type Point = (Float, Float)

pointOfIndex :: Int -> Int -> Point
pointOfIndex w i = (x, y)
    where
        x = fromIntegral $ i `mod`  w
        y = fromIntegral $ i `quot` w

offset :: Point -> Point -> Point
offset (a, b) (c, d) = (a+c, b+d)

multiply :: Point -> Point -> Point
multiply (a, b) (c, d) = (a*c, b*d)

dasBrot :: RealFloat a => Complex a -> Complex a -> Complex a
dasBrot c z_n = z_n^2 + c

isBrot :: Int -> Point -> Bool
isBrot n (r, i) = aux 0 0 -- z_n `elem` (init set)
    where
        c   = r :+ i
        aux m z
            | magnitude successor > 16 = False
            | m > n                    = True
            | otherwise                = aux (m+1) successor
            where successor = dasBrot c z
        z_n = last set
        set = take (n+1)
              $ iterate (dasBrot c) 0

qualBrot :: Int -> Point -> Int
qualBrot n (r, i) = aux 0 0 -- z_n `elem` (init set)
    where
        c = r :+ i
        aux m z
            | willDiverge || m > n = m
            | otherwise             = aux (m+1) next
            where
                next        = dasBrot c z
                willDiverge = magnitude next > 16

renderSet :: Int -> Int -> Int -> Picture -> IO ()
renderSet w h n _ = display
    (InWindow
        "Mandelbrot set"
        (w, h)
        (10, 10)
    )
    white
    (pictures dots)
    where
        (sc_w, sc_h) = (1.3, 1.3)
        (f_w, f_h)   = (fromIntegral w, fromIntegral h)
        (t_w, t_h)   = multiply (-1.5, 0.0) (f_w, f_h)
        (s_w, s_h)   = (1/(f_w*sc_w), 1/(f_h*sc_h))
        (r_w, r_h)   = ((f_w)*s_w, f_h * s_h)
        pixels       = [(x + t_w*s_w, y + t_h*s_h)
                        | x <- [-r_w,(-r_w+s_w)..r_w]
                        , y <- [-r_h,(-r_h+s_h)..r_h]
                       ]
        dots         = map aux pixels
        aux p        = translate x y
                       $ color (makeColor 0 0 0 (1-shade))
                       $ rectangleSolid 1 1
                       where
                           s      = fromIntegral
                                    $ qualBrot n p
                           f_n    = fromIntegral n
                           (x, y) = offset (-t_w, -t_h)
                                    $ multiply (1/s_w, 1/s_h) p
                           shade  = if s == f_n
                                    then 0
                                    else s/f_n


module Nondet where
import Data.Complex
import Test.QuickCheck

type Nondet a = [a]

sqrts :: Floating a => a -> Nondet a
sqrts x = [y, negate y]
  where
    y = sqrt x

-- Exercise Four:  Apply the function on all input values and aggregate the results
bind :: (a -> Nondet b) -> (Nondet a -> Nondet b)
bind = undefined

-- Using # instead of * for composition to avoid ambiguities
(#) :: (b -> Nondet c) -> (a -> Nondet b) -> (a -> Nondet c)
g' # f' = bind g' . f'

-- Exercise Five: Provide minimal context for the given value
unit :: a -> Nondet a
unit = undefined

-- lift --- lifting functions
lift :: (a -> b) -> (a -> Nondet b)
lift f = unit . f

-- Solution to the quadratic equation a*x^2 + b * y + c = 0
-- delta = b^2 - 4*a*c
-- x = (-b +- sqrt delta) / (2*a)
solveQuadratic :: Floating a  => a -> a -> a -> Nondet a
solveQuadratic a b c = lift (/(2*a)) # lift (b+) # sqrts $ delta
  where
    delta = b*b - 4*a*c

-- Exercise Six:  Test that (for a given value x)
-- (a) f # unit = unit # f = f
-- (b) lift g # lift f = lift (g.f)
check_unit1, check_unit2 :: (Complex Float -> Nondet (Complex Float)) -> Complex Float -> Bool
check_unit1 f x = undefined
check_unit2 f x = undefined

test_unit1, test_unit2 :: IO ()
test_unit1 = quickCheck $ check_unit1 sqrts
test_unit2 = quickCheck $ check_unit2 sqrts

check_lift :: (Float -> Float) -> (Float -> Float) -> Float -> Bool
check_lift f g x = undefined

test_lift :: IO ()
test_lift = quickCheck $ check_lift (+2) (*3)

-- Exercise Ten(b): Rewrite the module to make Nondet instance of
-- the Monad typeclass
-- Note: You first need to make it an instance of Functor and Applicative

-- Exercise Twelve:  Write the solution to the quadratic equation in do notation


module NonlinearTransform
  ( solution8
  , solution9
  , solution10
  , createTransformedX2
  , createTransformedX
  , createTransformedXk
  ) where

import           LinearRegression
--------------------------------------------------------------
-- Solutions to homework 2 of "Learning from data" question 8-10
--------------------------------------------------------------
import           Numeric.LinearAlgebra.Data
import           Numeric.LinearAlgebra.HMatrix

-- | the target function
targetf :: (R, R) -> R
targetf (x1, x2) = signum (x1 ^ 2 + x2 ^ 2 - 0.6)

-- | returns the second value in a 3-tuple
sndOfTriple :: (a, b, c) -> b
sndOfTriple (_, b, _) = b

-- | returns the first value in a 3-tuple
fstOfTriple :: (a, b, c) -> a
fstOfTriple (a, _, _) = a

-- | Creates the transformed matrix X with feature vectors (1,x1,x2,x1*x2,x1^2,x2^2) from a list of data points
createTransformedX :: Int -> ([(R, R)] -> [R]) -> [(R, R)] -> Matrix R
createTransformedX numFeatures transformfunction listOfPoints =
  matrix numFeatures listOfNumbers
  where
    listOfNumbers = transformfunction listOfPoints

transformFunction1 =
  \listOfPoints ->
    concat [[1, a, b, a * b, a ^ 2, b ^ 2] | (a, b) <- listOfPoints]

transformFunction2 =
  \listOfPoints ->
    concat
      [ [1, a, b, a * b, a ^ 2, b ^ 2, abs (a - b), abs (a + b)]
      | (a, b) <- listOfPoints
      ]

transformFunctionk k =
  \listOfPoints ->
    concat
      [ take (k + 1) [1, a, b, a ^ 2, b ^ 2, a * b, abs (a - b), abs (a + b)]
      | (a, b) <- listOfPoints
      ]

createTransformedX1 listOfPoints =
  createTransformedX 6 transformFunction1 listOfPoints

createTransformedX2 listOfPoints =
  createTransformedX 8 transformFunction2 listOfPoints

createTransformedXk k listOfPoints =
  createTransformedX (k + 1) (transformFunctionk k) listOfPoints

-- | solution to Problem 8
solution8 :: IO R
solution8 = fmap sndOfTriple $ trainLinRegWNoise targetf 1000 0.1 createMatrixX

-- | solution to Problem 9
solution9 :: IO (Vector R)
solution9 =
  fmap fstOfTriple $ trainLinRegWNoise targetf 1000 0.1 createTransformedX1

-- | solution to Problem 10
solution10 :: IO R
solution10 = solution9 >>= testLinRegWNoise targetf 1000 0.1 createTransformedX1