#!/usr/bin/env stack
-- stack --resolver lts-14.16 script
{-# LANGUAGE BangPatterns #-}

import Debug.Trace
-- import Control.Monad.State.Lazy

import System.Environment (getArgs)
import System.IO (readFile)
import Data.Map.Strict (Map, (!), insert, elems, fromList, toList, findWithDefault, size, empty, member, findMin, findMax, singleton)
import qualified Data.Map.Strict as M
--import qualified Data.Array as A
import Data.List (permutations)
import Data.List.Split (splitOn)
import Data.Complex (Complex((:+)), realPart, imagPart)

type Instructions = Map Integer Integer

run :: (Integer, Integer) -> Instructions -> [Integer] -> [Integer]
-- (instructionPointer, base), instructions, input, output
run (i, base) instructions inputs =
  -- trace ((show $ toList instructions) ++ ": (ip, base, instr, inputs) " ++ show (i, base, instr, inputs) ++ "\n") $
  case instr `mod` 100 of
    1 -> run (i+4, base) (insert (addr 3) (arg 1 + arg 2) instructions) inputs
    2 -> run (i+4, base) (insert (addr 3) (arg 1 * arg 2) instructions) inputs
    3 -> run (i+2, base) (insert (addr 1) (head inputs) instructions) $ tail inputs
    4 -> arg 1: run (i+2, base) instructions inputs
    5 -> run (if arg 1 == 0 then i+3 else arg 2, base) instructions inputs
    6 -> run (if arg 1 == 0 then arg 2 else i+3, base) instructions inputs
    7 -> run (i+4, base) (insert (addr 3) (if arg 1 < arg 2 then 1 else 0) instructions) inputs
    8 -> run (i+4, base) (insert (addr 3) (if arg 1 == arg 2 then 1 else 0) instructions) inputs
    9 -> run (i+2, base+arg 1) instructions inputs
    99 -> []
    _ -> error "unknown opcode"
  where instr = instructions!i
        ii x = findWithDefault 0 x instructions
        arg :: Integer -> Integer
        arg n = case (instr `mod` (100*10^n)) `div` (10*10^n) of
          0 -> ii $ ii $ i+n
          1 -> ii $ i+n
          2 -> ii ((ii $ i+n) + base)
          _ -> error "bad argument mode"
        addr n = case (instr `mod` (100*10^n)) `div` (10*10^n) of
          0 -> ii $ i+n
          1 -> error "address in mode 1"
          2 -> --trace "address in mode 2" $
            ii (i+n) + base
          _ -> error $ "address in unknown mode"

instance Ord a => Ord (Complex a) where
  compare a b | ar < br || ar == br && ai < bi = LT
              | ar > br || ar == br && ai > bi = GT
              | otherwise = EQ
    where (ar, ai) = toParts a
          (br, bi) = toParts b

toParts :: Complex a -> (a, a)
toParts c = (realPart c, imagPart c)

toIntParts :: RealFrac a => Complex a -> (Int, Int)
toIntParts c = (round $ realPart c, round $ imagPart c)

fromParts :: (a, a) -> Complex a
fromParts (a,b) = a :+ b

process :: (Complex Float, Complex Float, Map (Complex Float) Integer) -> [Integer] -> ([Integer], Complex Float, Complex Float, Map(Complex Float) Integer)
process (p, d, colors) [] =
  -- traceShow (size colors) $
  -- traceShow (showColors p d colors) $
  ([], p, d, colors)
process (p, d, colors) (c: t: futureOutputs) =
  -- traceShow ("xy", toIntParts p,"out", out,robot d, "paint", c,"turn", t) $
  -- trace (showColors p d colors) $
  merge out $ process (p', d', insert p c colors) futureOutputs
  where p' = p + d' -- next position
        d' = d * (0 :+ (1.0 - fromIntegral t * 2)) -- next direction
        out = findWithDefault 0 p' colors
        merge :: Integer -> ([Integer], Complex Float, Complex Float, Map(Complex Float) Integer) -> ([Integer], Complex Float, Complex Float, Map(Complex Float) Integer)
        merge x ~(xs, p, d, m) = (x:xs, p, d, m) -- need the irrefutable match operator ~, see https://stackoverflow.com/questions/59297557/when-can-i-rely-on-haskell-to-read-a-list-lazily/59298311#59298311

-- showProcess :: [Integer] -> (Complex Float, Complex Float, Map (Complex Float) Integer) -> (Complex Float, Complex Float, Map (Complex Float) Integer)
-- showProcess [] s = s
-- showProcess [c] s = trace ("leftover " ++ show c) $ s
-- showProcess (c: t: r) (p, d, m) = showProcess r (p', d', insert p c m)
--   where d' = d * (0 :+ (1.0 - fromIntegral t * 2 ))
--         p' = p + d'

showColors :: Complex Float -> Complex Float -> Map (Complex Float) Integer -> [Char]
showColors p d cs
  -- | null cs = []
  -- | otherwise
  = --traceShow ("showColors", p, robot d, "min", (x0,y0), "max", (x1,y1), "colors size", size cs) $
    unlines [line y | y <- reverse $ [y0 .. y1]]
  where line :: Int -> [Char]
        line y = [ (v (fromIntegral x :+ fromIntegral y) $ findWithDefault 3 (fromIntegral x :+ fromIntegral y) cs) | x <- [x0 .. x1]]
        pts = map fst $ toList cs
        xs = map (round . realPart) $ p: pts
        ys = map (round . imagPart) $ p: pts
        x0, y0, x1, y1 :: Int
        [x0, y0, x1, y1] = [minimum xs, minimum ys, maximum xs, maximum ys]
        v :: Complex Float -> Integer -> Char
        v p' c | p == p' = robot d
               | p' == (0.0 :+ 0.0) && c== 0 = 'o'
               | p' == (0.0 :+ 0.0) && c== 1 = 'O'
               | c == 1 = '#'
               | c == 0 = ' ' -- '.' -- change to space for clarity
               | otherwise = ' '

robot :: Complex Float -> Char
robot c | x == 0 && y == 1 = '^'
        | x == 1 && y == 0 = '>'
        | x == 0 && y == -1 = 'V'
        | x == -1 && y == 0 = '<'
        where (x,y) = toParts c

origin = 0 :+ 0
up = 0 :+ 1
startColors = singleton origin 0
startColors2 = singleton origin 1

main = do
  [instructionFile] <- getArgs
  instructionStrings <- readFile instructionFile
  let instructions = fromList . zip [0 ..] $ map read $ splitOn "," instructionStrings

  putStrLn "Part 1"
  let out = run (0,0) instructions $ (startColors!origin) : processOutput
      (processOutput, finalp, finald, colors) = process (origin,up, startColors) $ out
  putStrLn
    $ unlines
    $ ["done Part 1"
      , show $ ("tiles painted: ", size colors)
      , show $ ("finalp", finalp, "finald", robot finald)
      ]
  putStr $ showColors finalp finald colors

  putStrLn "Part 2"
  let out = run (0,0) instructions $ (startColors2!origin) : processOutput
      (processOutput, finalp, finald, colors) = process (origin,up, startColors2) $ out
  putStrLn
    $ unlines
    $ ["done Part 2"
      , show $ ("tiles painted: ", size colors)
      , show $ ("finalp", finalp, "finald", robot finald)
      ]
  putStr $ showColors finalp finald colors


{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module StatReport (statReport, showStatEntryValue) where

import Data.Fixed (showFixed)
import Data.Text (Text)
import Fmt

import QuoteData
import Statistics

instance Buildable Statistic where
  build Mean = "Mean"
  build Min = "Minimum"
  build Max = "Maximum"
  build Days = "Days between Min/Max"

showStatEntryValue :: StatEntry -> String
showStatEntryValue StatEntry {..} = showFixed (removeTrailing stat qfield) value
  where
    removeTrailing Days _ = True
    removeTrailing Min Volume = True
    removeTrailing Max Volume = True
    removeTrailing _ _ = False

instance Buildable StatEntry where
  build se@StatEntry {..} = ""+|stat|+": "+|showStatEntryValue se|+""

instance Buildable StatQFieldData where
  build (qf, stats) = nameF ("Statistics for " +||qf||+"") $ unlinesF stats

statReport :: StatInfo -> Text
statReport = fmt . unlinesF


module DistanceGeometry
  (
  -- * Steps of algorithm
    generateDistBoundsMatr
  , triangleSmooth
  , randomDistMatr
  , distMatrToMetricMatr
  , largestEigValVec
  , generateCoorFromEigValVec
  , coordMatrToDistMatr
  , updateCoord

  -- * Error Functions
  , distanceErrorFunction
  , chiralErrorFunction
  ) where

import           Control.Lens
import           Control.Monad.State
import           Data.List                   (foldl', zipWith3)
import           Numeric.LinearAlgebra
import           Numeric.LinearAlgebra.Data
import           Numeric.LinearAlgebra.Devel
import           System.Random
import           Types

-- * Steps of algorithm
-- | Generate of a distance bounds matrix
generateDistBoundsMatr :: Molecule -> [Bond] -> (Matrix Double, Matrix Double)
generateDistBoundsMatr molecule bonds =
  let n = views atoms length molecule
      upperDist _ _ = 100
      lowerDist i j = getAtom i molecule ^. avdwrad +
                      getAtom j molecule ^. avdwrad
      fixedDist i j = sqrt $ (xj - xi) ^ 2 + (yj - yi) ^ 2 + (zj - zi) ^ 2
        where
          (Point xi yi zi) = getAtom i molecule ^. acoordin
          (Point xj yj zj) = getAtom j molecule ^. acoordin
      upper = build (n, n) (\i' j' ->
        let (i, j) = (fromEnum i', fromEnum j')
        in if i == j
           then 0
           else if isBonded i j bonds
                then fixedDist i j
                else upperDist i j)
      lower = build (n, n) (\i' j' ->
        let (i, j) = (fromEnum i', fromEnum j')
        in if i == j
           then 0
           else if isBonded i j bonds
                then fixedDist i j
                else lowerDist i j)
   in (upper, lower)

-- | Triangle Inequality Bounds Smoothing
-- triangleSmooth :: Matrix Double -> Either String (Matrix Double)
triangleSmooth :: (Matrix Double, Matrix Double) -> (Matrix Double, Matrix Double)
triangleSmooth (upper, lower) =
  let n = rows upper
      kij = [ (k, i, j)
       | k <- [0 .. n - 1]
       , i <- [0 .. n - 2]
       , j <- [i + 1 .. n - 1]
       ]
      smoothing (u0, l0) (k, i, j) = do
        let (u1, l1) = if e1 > e2 + e3
                       then (changeMatrix u0 (i, j) (e2 + e3), l0)
                       else (u0, l0)
                       where
                        e1 = u0 `atIndex` (i, j)
                        e2 = u0 `atIndex` (i, k)
                        e3 = u0 `atIndex` (k, j)
        let (u2, l2) = if e1 < e2 - e3
                       then (u1, changeMatrix l1 (i, j) (e2 - e3))
                       else (u1, l1)
                       where
                        e1 = l1 `atIndex` (i, j)
                        e2 = l1 `atIndex` (i, k)
                        e3 = u1 `atIndex` (k, j)
        let (u3, l3) = if e1 < e2 - e3
                       then (u2, changeMatrix l2 (i, j) (e2 - e3))
                       else (u2, l2)
                       where
                        e1 = l2 `atIndex` (i, j)
                        e2 = l2 `atIndex` (j, k)
                        e3 = u2 `atIndex` (k, i)
        if l3 ! i ! j > u3 ! i ! j
        then error "Erroneous Bounds"
        else (u3, l3)
      (upper', lower') = foldl' smoothing (upper, lower) kij
      newUpper = build (n, n) (\i' j' ->
        let (i, j) = (fromEnum i', fromEnum j')
        in if i < j
           then upper' `atIndex` (i, j)
           else upper' `atIndex` (j, i))
      newLower = build (n, n) (\i' j' ->
        let (i, j) = (fromEnum i', fromEnum j')
        in if i < j
           then lower' `atIndex` (i, j)
           else lower' `atIndex` (j, i))
   in (newUpper, newLower)

-- | Generation of a distance matrix by random selection
-- of distances between the bounds.
randomDistMatr :: (Matrix Double, Matrix Double) -> IO (Matrix Double)
randomDistMatr (upper, lower) = do
  let n = rows upper
  distanceVector <- sequence [ r
   | i <- [0 .. n - 1]
   , j <- [0 .. n - 1]
   , let a = lower `atIndex` (i, j)
         b = upper `atIndex` (i, j)
         r = if j <= i
             then return 0
             else randomRIO (a, b)
             ]
  let distanceMatrix = matrix n distanceVector
  return $ distanceMatrix `add` tr' distanceMatrix

-- | Improving Random Sampling: Metrization
metrization :: Matrix Double -> Matrix Double
metrization matrix = undefined

-- | Improving Random Sampling: Partial Metrization
partialMetrization :: Matrix Double -> Matrix Double
partialMetrization matrix = undefined

-- | Conversion of the distance matrix to a metric matrix
distMatrToMetricMatr :: Matrix Double -> Matrix Double
distMatrToMetricMatr matr =
  let n = rows matr
      m = fromIntegral n
      uTriangleMatr = build (n, n) (\i' j' ->
        let (i, j) = (fromEnum i', fromEnum j')
        in if j <= i
           then 0
           else matr `atIndex` (i, j))
      d0 i = (1 / m) * sumElements ((matr ! i) ^ 2) -
             (1 / m ^ 2) * sumElements (uTriangleMatr ^ 2)
  in build (n, n) (\i' j' ->
    let (i, j) = (fromEnum i', fromEnum j')
        a = d0 i
        b = d0 j
        c = matr `atIndex` (i, j)
    in (a + b - c ^ 2) / 2)

-- | distanceToMetricMatrix is symmetric matrix => eigenvalues is real
-- Function return @k@ pairs of eigenvalues and eigenvectors (as columns)
-- in descending order
largestEigValVec :: Matrix Double -> (Vector Double, Matrix Double)
largestEigValVec matr =
  if (not . isSymmetric) matr
  then error "The matrix is not symmetric"
  else (subVector 0 k eigval, takeColumns k eigvec)
  where
    (eigval, eigvec) = (eigSH . trustSym) matr
    k = min 3 (size eigval)

-- | Generation of three-dimensional coordinates from
-- eigenvalues and eigenvectors.
generateCoorFromEigValVec ::
  (Vector Double, Matrix Double) -> Matrix Double
generateCoorFromEigValVec (val, vec) =
  vec Numeric.LinearAlgebra.<> (sqrt . diag) val

-- | Convert coordinate matrix to
-- distance matrix.
coordMatrToDistMatr :: Matrix Double -> Matrix Double
coordMatrToDistMatr matr =
  let n = rows matr
      dist i j = sqrt $ (xj - xi) ^ 2 + (yj - yi) ^ 2 + (zj - zi) ^ 2
        where
          [xi, yi, zi] = toList $ matr ! i
          [xj, yj, zj] = toList $ matr ! j
      dmatr = build (n, n) (\i' j' ->
       let (i, j) = (fromEnum i', fromEnum j')
       in if j <= i
          then 0
          else dist i j)
  in dmatr `add` tr' dmatr

-- | Update coordinates
updateCoord :: Matrix Double -> Molecule -> Molecule
updateCoord coord mol = set atoms newatoms mol
  where
    newatoms = zipWith updatec (toRows coord) (view atoms mol)
    updatec coord' =
      execState
        (do acoordin . x .= coord' ! 0
            acoordin . y .= coord' ! 1
            acoordin . z .= coord' ! 2)

-- * Error Functions
-- | Distance error function.
distanceErrorFunction ::
     Matrix Double -> Matrix Double -> Matrix Double -> [Bond] -> Double
distanceErrorFunction coord upper lower bonds =
  let n = rows coord
      dist = coordMatrToDistMatr coord
      [d2, u2, l2] = map (^2) [dist, upper, lower]
      ij' = [(i, j) | i <- [0 .. n - 2], j <- [i + 1 .. n - 1]]
      ij = filter (\(i,j) -> not $ isBonded i j bonds) ij'
      f1 (i, j) =
        (+) $ max 0 (d2 ! i ! j - u2 ! i ! j) ^ 2 +
        max 0 (l2 ! i ! j ^ 2 - d2 ! i ! j) ^ 2
      f2 (i, j) =
        (+) $ max 0 (d2 ! i ! j / u2 ! i ! j - 1) ^ 2 +
        max 0 (l2 ! i ! j / d2 ! i ! j - 1) ^ 2
      f3 (i, j) =
        (+) $ max 0 (d2 ! i ! j / u2 ! i ! j - 1) ^ 2 +
        max 0 (2 * l2 ! i ! j / (l2 ! i ! j + d2 ! i ! j) - 1) ^ 2
   in foldr f1 0 ij + foldr f2 0 ij + foldr f3 0 ij

-- | Chiral error function.
chiralErrorFunction ::
     Matrix Double -> Matrix Double -> Matrix Double -> [Bond] -> Double
chiralErrorFunction coord upper lower bonds =
  let n = rows coord
      dist = coordMatrToDistMatr coord
      ijkm' = [(i,j,k,m) | i <- [0..n-1], j <- [i+1..n-1],
                           k <- [j+1..n-1], m <- [k+1..n-1]]
      ijkm = filter (isTetrahedra dist) ijkm'
        where
          isTetrahedra d (i,j,k,m) = all (isTriangle d) [(i,j,k), (i,j,m), (i,k,m), (j,k,m)] && all (checkAngles d) [(i,j,k,m)]-- (j,k,m,i), (k,m,i,j), (m,i,j,k)]
            where isTriangle d (i,j,k) = and [a + b > c, b + c > a, c + a > b]
                   where a = d ! i ! j
                         b = d ! i ! k
                         c = d ! j ! k
                  checkAngles d (i,j,k,m) = and [b1 + b2 > b3, b1 + b3 > b2, b2 + b3 > b1]
                   where a1 = d ! i ! j; a2 = d ! i ! k
                         a3 = d ! i ! m; a4 = d ! j ! k
                         a5 = d ! j ! m; a6 = d ! k ! m
                         b1 = acos $ (a1^2 + a2^2 - a4^2) / (2*a1*a2)
                         b2 = acos $ (a1^2 + a3^2 - a5^2) / (2*a1*a3)
                         b3 = acos $ (a2^2 + a3^2 - a6^2) / (2*a2*a3)
      vol (i,j,k,m) = (xj - xi) `dot` ((xk - xi) `cross` (xm - xi))
        where [xi,xj,xk,xm] = map (coord !) [i,j,k,m]
      u (i,j,k,m) = (sum . map (atIndex upper)) [(i, j), (j, k), (k, m), (m, i)]
      l (i,j,k,m) = (sum . map (atIndex lower)) [(i, j), (j, k), (k, m), (m, i)]
      f x@(i,j,k,m) = (+) $ max 0 (vol x - u x) ^ 2 + max 0 (l x - vol x)
  in foldr f 0 ijkm

-- * Utils.
-- | Изменяет значение матрицы @m@ по индексам (@i@,@j@) на указанное @v@
changeMatrix :: Matrix Double -> (Int, Int) -> Double -> Matrix Double
changeMatrix m (i, j) v =
  runSTMatrix $ do
    m' <- thawMatrix m
    writeMatrix m' i j v
    return m'

-- | Check the symmetric matrix
isSymmetric :: Matrix Double -> Bool
isSymmetric matr =
  let r = rows matr
      c = cols matr
      s = [matr ! i ! j == matr ! j ! i | i <- [0 .. r - 1], j <- [i .. c - 1]]
  in r == c && and s

-- | Определяет, связаны ли атомы
isBonded :: Serial -> Serial -> [Bond] -> Bool
isBonded n m s = (n, m) `elem` bonds s || (m, n) `elem` bonds s
  where bonds = map (\x -> (view bfid x, view bsid x))

-- | Get atom from molecule
getAtom :: Serial -> Molecule -> Atom
getAtom i = views atoms (!! i)


{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE QuantifiedConstraints  #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE UndecidableInstances   #-}
module Q.Stochastic.Discretize
        where

import           Data.Functor
import           Numeric.LinearAlgebra
import           Q.Stochastic.Process
-- |Euler discretization of stochastic processes
newtype Euler = Euler { eDt :: Double }
        deriving stock (Show, Eq)

-- | Euler end-point discretization of stochastic processes
newtype EndEuler = EndEuler { eeDt :: Double }
        deriving stock (Show, Eq)

instance Discretize Euler Double where
  dDrift p Euler{..} s0 = pDrift p s0 <&> (* eDt)
  dDiff  p Euler{..} b  = (pDiff p b) <&> (* (sqrt eDt))
  dDt    _ Euler{..} _  = eDt

instance Discretize Euler (Vector Double) where
  dDrift p Euler{..} s0 = pDrift p s0 <&> (scale eDt)
  dDiff  p Euler{..} b = (pDiff p b) <&> (scale (sqrt eDt))
  dDt    _ Euler{..} _  = eDt

instance Discretize EndEuler Double where
  dDrift p EndEuler{..} s0@(t0, x0) = pDrift p (t0 + eeDt, x0) <&> (* eeDt)
  dDiff  p EndEuler{..}  s0@(t0, x0) =  pDiff  p (t0 + eeDt, x0) <&> (* (sqrt eeDt))
  dDt    _ e _   = eeDt e


{-# LANGUAGE BangPatterns    #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections   #-}

module Main where

import Data.List
import Data.Maybe
import Data.Ord
import Numeric.GSL.SimulatedAnnealing
import qualified Numeric.LinearAlgebra as H
import Text.Parsec hiding (parse)
import qualified Text.Parsec as Parsec

main :: IO ()
main = do
  !input <- parse <$> readFile "inputs/day-17.txt"

  putStrLn $ "Target: " <> show input

  putStrLn "\nPart 1:"
  -- print . hitsTarget input $! fancySolve input
  print $! bruteforce input

  putStrLn "\nPart 2:"
  print $! bruteforceBy length input

-- | The target area.
data Target = Target { left :: Int, right :: Int, bottom :: Int, top :: Int }
  deriving (Show)

-- | Find the velocity with the highest y-coordinate that passes through the
-- target.
--
-- This doesn't actually work
fancySolve :: Target -> (Int, Int)
fancySolve target =
  simanSolve 420 2 solverParams (20, 20)
    (solverPenalty target)
    (\(oldX, oldY) (newX, newY) -> fromIntegral $ abs (newX - oldX) + abs (newY - oldY))
    step
    (Just $ \velo -> show velo <> ": dist = " <> show (overshootDistance target velo))
  where
    solverParams = SimulatedAnnealingParams
      1000   -- Tries per step
      1000   -- Tries per temperature
      1      -- Maximum step size in random walk
      1.0    -- Boltzman constant for random walks
      2.0    -- Initial temperature
      1.69   -- Cooling rate
      0.0069 -- Final temperature

    step :: H.Vector Double -> Double -> (Int, Int) -> (Int, Int)
    step rands _ velo@(veloX, veloY) =
      ( veloX + round (((rands H.! 0) - 0.5) * overshootDistance target velo * 10)
      , veloY + round (((rands H.! 1) - 0.5) * overshootDistance target velo * 10)
      )

-- | Just exhaustively try all options to find starting velocity that results in
-- highest reached Y-coordinate.
bruteforce :: Target -> ((Int, Int), Int)
bruteforce = bruteforceBy (maximumBy (comparing snd))

bruteforceBy :: ([((Int, Int), Int)] -> a) -> Target -> a
bruteforceBy f target@Target{..}
  = f
  $ mapMaybe (\p -> (p,) <$> hitsTarget target p)
    [(x, y) | x <- [1 .. right], y <- [bottom .. abs bottom]]

-- | The penalty for the solver. This is negative the maximum Y-coordinate
-- unless the trajectory would not hit the target area, in which case it is the
-- distance to the center of the target area.
solverPenalty :: Target -> (Int, Int) -> Double
solverPenalty target initialVelo
  | Just maxYPos <- hitsTarget target initialVelo = fromIntegral (negate maxYPos)
  | otherwise                                     = (overshootDistance target initialVelo + 100) ** 2

-- | Whether the given velocity causes the target to be hit. Returns the highest
-- Y-position if it does.
hitsTarget :: Target -> (Int, Int) -> Maybe Int
hitsTarget Target{..} = go (0, 0)
  where
    go :: (Int, Int) -> (Int, Int) -> Maybe Int
    go (posX, posY) (veloX, veloY)
      | posX > right || posY < bottom = Nothing
      | otherwise =
          let newPos  = (posX + veloX, posY + veloY)
              newVelo = (veloX - signum veloX, veloY - 1)
           in if posX >= left && posX <= right && posY >= bottom && posY <= top
                then Just posY
                else max posY <$> go newPos newVelo

-- | The minimal distance the target's center is overshot by while following the
-- trajectory, bounded by double the target's bottom right corner.
overshootDistance :: Target -> (Int, Int) -> Double
overshootDistance Target{..} = lowestDistance (0, 0)
  where
    centerX = (left + right) `div` 2
    centerY = (top + bottom) `div` 2
    boundX = right * 2
    boundY = bottom * 2

    lowestDistance :: (Int, Int) -> (Int, Int) -> Double
    lowestDistance (posX, posY) (veloX, veloY) =
      let distance                  = sqrt $ fromIntegral (centerX - posX) ** 2
                                           + fromIntegral (centerY - posY) ** 2
          newPos@(newPosX, newPosY) = (posX + veloX, posY + veloY)
          newVelo                   = (veloX - signum veloX, veloY - 1)
       in if newPosX > boundX || newPosY < boundY
            then distance
            else min distance (lowestDistance newPos newVelo)

parse :: String -> Target
parse = fromRight' . Parsec.parse pTarget ""
  where
    fromRight' (Right x) = x
    fromRight' _         = error "This wasn't in our agreement!"

    pTarget :: Parsec String () Target
    pTarget = Target <$> (string "target area: x=" *> pInt)     <*> (string ".." *> pInt)
                     <*> (string ", y=" *> pInt <* string "..") <*> pInt

    pInt :: Parsec String () Int
    pInt = read <$> many (digit <|> char '-')


{-# OPTIONS_GHC -fsimpl-tick-factor=150 #-}
{-# LANGUAGE BangPatterns, RecordWildCards #-}

module Network.HTTP.LoadTest.Analysis
    (
    -- * Result analysis
      Analysis(..)
    , Basic(..)
    , analyseBasic
    , analyseFull
    ) where

import Criterion.Analysis (SampleAnalysis, analyseSample)
import Network.HTTP.LoadTest.Types (Analysis(..), Basic(..), Summary(..))
import Prelude hiding (catch)
import Statistics.Quantile (weightedAvg)
import qualified Data.Vector as V
import qualified Data.Vector.Generic as G
import qualified Statistics.Sample as S

analyseFull :: V.Vector Summary -> Double -> IO (Analysis SampleAnalysis)
analyseFull sumv elapsed = do
  let ci = 0.95
      resamples = 10 * 1000
  l <- analyseSample ci (G.convert . G.map summElapsed $ sumv) resamples
  return Analysis {
                 latency = l
               , latency99 = weightedAvg 99 100 . G.map summElapsed $ sumv
               , latency999 = weightedAvg 999 1000 . G.map summElapsed $ sumv
               , latValues = sumv
               , throughput = fromIntegral (G.length sumv) / elapsed
    }

analyseBasic :: V.Vector Summary -> Double -> Analysis Basic
analyseBasic sumv elapsed = Analysis {
                      latency = Basic {
                                  mean = S.mean . G.map summElapsed $ sumv
                                , stdDev = S.stdDev . G.map summElapsed $ sumv
                                }
                    , latency99 = weightedAvg 99 100 . G.map summElapsed $ sumv
                    , latency999 = weightedAvg 999 1000 . G.map summElapsed $ sumv
                    , latValues = sumv
                    , throughput = fromIntegral (G.length sumv) / elapsed
                    }


{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE FlexibleContexts #-}

module CPVO.Numeric (
  integrateAll,
  sumRow,
  getY0,
  delta,
  integrateToZero,
  integrateAtomicPDOS
  ) where

import Numeric.LinearAlgebra
import Data.List (findIndex,groupBy)
import Data.Maybe (fromJust)

integrateToZero :: Matrix Double -> Double
integrateToZero mP = integrateAll 0
  $ (++ ([toList $ getY0 $ takeColumns 2 mP]))
  $ takeWhile (\(a:_) -> a <= 0)
  $ toLists $ takeColumns 2 mP

integrateAll :: Double -> [[Double]] -> Double
integrateAll res [] = res
integrateAll res ([enA,nA]:b@[enB,nB]:as)
  | as == [] = integrateAll (res + (enB - enA)*(nA+nB)*0.5) []
  | otherwise = integrateAll (res + (enB - enA)*(nA+nB)*0.5) (b:as)
integrateAll _ _ = 99

sumRow :: Matrix Double -> Vector Double
sumRow a = a #> konst 1 (cols a)

getY0 :: Matrix Double -> Vector Double
getY0 dos = getY0' lowPos higNeg
  where
    rTDOS = toRows $ dos
    highestNeg = (+) (-1) $ fromJust $ findIndex (\a -> (atIndex a 0) >= 0) rTDOS
    lowestPos = highestNeg + 1
    higNeg = rTDOS !! highestNeg
    lowPos = rTDOS !! lowestPos

getY0' :: Vector Double -> Vector Double -> Vector Double
getY0' a b = a + (scale m v)
  where
    v = b - a
    m = ((*) (-1) $ a ! 0) / ((b ! 0) - (a ! 0))

delta :: Bool -> b -> b -> b
delta x y z = if x then y else z

integrateAtomicPDOS :: [(Matrix Double, (Int, (String, (Int, String))))]
                    -> [(Double, Double, (Int, (String, (Int, String))))]
integrateAtomicPDOS pdosAtomicPilihan =
          (\[us,ds] -> zipWith (\(iu,b) (idown,_) -> (iu,idown,b)) us ds )
          $ groupBy (\(_,(s,_)) (_,(s',_)) -> s == s') -- [[(spin,label,iup)]]
          $ map (\(mp,b) -> (integrateToZero mp,b)) $ pdosAtomicPilihan


-- Test of the computational correctness of my current FFT candidate.
--
-- Original author: David Banas <capn.freako@gmail.com>
-- Original date:   October 3, 2015
--
-- Copyright (c) 2015 David Banas; all rights reserved World wide.
--
-- I'm waiting for Conal to find time to look into my latest non-termination
-- failure through his compiler. While I do, I'm attempting, here, to verify
-- the computational correctness of my current FFT candidate.

{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}

module Main where

import Prelude hiding ({- id,(.), -}foldl,foldr,sum,product,zipWith,reverse,and,or,scanl,minimum,maximum)

import Control.Applicative
import Control.Arrow
import Control.Monad (forM_, unless)
import Data.Complex
import Data.Foldable (Foldable, sum, foldl')
import Data.Newtypes.PrettyDouble
import System.Exit (exitFailure)
import TypeUnary.Nat (IsNat, Nat(..), nat, N2, N3, N4, N5)  -- , N6)

-- import Test.QuickCheck (choose, vectorOf, elements, collect)
import Test.QuickCheck (choose, vectorOf)
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.All (quickCheckAll)

import Circat.Scan (lproducts, LScan)
import qualified Circat.Pair as P
import qualified Circat.RTree as RT
import Circat.RTree (bottomSplit)

type RTree = RT.Tree

-- FFT, as a class
-- (The LScan constraint comes from the use of 'lproducts', in 'addPhase'.)
class (LScan f) => FFT f a where
    fft  :: f a -> f a  -- Computes the FFT of a functor.

-- Note that this definition of the FFT instance for Pair assumes DIT.
-- How can we eliminate this assumption and make this more general?
instance (RealFloat a, Applicative f, Foldable f, Num (f (Complex a)), FFT f (Complex a)) => FFT P.Pair (f (Complex a)) where
    fft = P.inP (uncurry (+) &&& uncurry (-)) . P.secondP addPhase . fmap fft

instance (IsNat n, RealFloat a) => FFT (RTree n) (Complex a) where
    fft = fft' nat
        where   fft' :: (RealFloat a) => Nat n -> RTree n (Complex a) -> RTree n (Complex a)
                fft' Zero     = id
                fft' (Succ _) = inDIT fft
                    where   inDIT g  = RT.toB . g . bottomSplit

-- Adds the proper phase adjustments to a functor containing Complex RealFloats,
-- and instancing Num.
addPhase :: (Applicative f, Foldable f, LScan f, RealFloat a, Num (f (Complex a))) => f (Complex a) -> f (Complex a)
addPhase = liftA2 (*) id phasor
  where phasor f = fst $ lproducts (pure phaseDelta)
          where phaseDelta = cis ((-pi) / fromIntegral n)
                n          = flen f

-- Gives the "length" (i.e. - number of elements in) of a Foldable.
-- (Soon, to be provided by the Foldable class, as "length".)
flen :: (Foldable f) => f a -> Int
flen = foldl' (flip ((+) . const 1)) 0

-- Test config.
realData :: [[PrettyDouble]]
realData = [  [1.0,   0.0,   0.0,   0.0]  -- Delta
            , [1.0,   1.0,   1.0,   1.0]  -- Constant
            , [1.0,  -1.0,   1.0,  -1.0]  -- Nyquist
            , [1.0,   0.0,  -1.0,   0.0]  -- Fundamental
            , [0.0,   1.0,   0.0,  -1.0]  -- Fundamental w/ 90-deg. phase lag
           ]
complexData :: [[Complex PrettyDouble]]
complexData = map (map (:+ 0.0)) realData

myTree2 :: [a] -> RTree N2 a
myTree2 [w, x, y, z] = RT.tree2 w x y z
myTree2 _            = error "Something went horribly wrong!"

myTree3 :: [a] -> RTree N3 a
myTree3 [a, b, c, d, e, f, g, h] = RT.tree3 a b c d e f g h
myTree3 _            = error "Something went horribly wrong!"

myTree4 :: [a] -> RTree N4 a
myTree4 [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p] = RT.tree4 a b c d e f g h i j k l m n o p
myTree4 _            = error "Something went horribly wrong!"

myTree5 :: [a] -> RTree N5 a
myTree5 [a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p,
         a', b', c', d', e', f', g', h', i', j', k', l', m', n', o', p'] =
            RT.tree5 a b c d e f g h i j k l m n o p a' b' c' d' e' f' g' h' i' j' k' l' m' n' o' p'
myTree5 _            = error "Something went horribly wrong!"

-- myTree6 :: [a] -> RTree N6 a
-- myTree6 [a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1,
--          a2, b2, c2, d2, e2, f2, g2, h2, i2, j2, k2, l2, m2, n2, o2, p2,
--          a3, b3, c3, d3, e3, f3, g3, h3, i3, j3, k3, l3, m3, n3, o3, p3,
--          a4, b4, c4, d4, e4, f4, g4, h4, i4, j4, k4, l4, m4, n4, o4, p4] =
--             RT.tree6 a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1 n1 o1 p1
--                      a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2 o2 p2
--                      a3 b3 c3 d3 e3 f3 g3 h3 i3 j3 k3 l3 m3 n3 o3 p3
--                      a4 b4 c4 d4 e4 f4 g4 h4 i4 j4 k4 l4 m4 n4 o4 p4
-- myTree6 _            = error "Something went horribly wrong!"

-- Discrete Fourier Transform (DFT) (our "truth" reference)
-- O(n^2)
--
dft :: RealFloat a => [Complex a] -> [Complex a]
dft xs = [ sum [ x * exp((0.0 :+ (-1.0)) * 2 * pi / lenXs * fromIntegral(k * n))
                 | (x, n) <- Prelude.zip xs [0..]
               ]
           | k <- [0..(length xs - 1)]
         ]
    where lenXs = fromIntegral $ length xs

-- QuickCheck types & propositions
newtype FFTTestVal = FFTTestVal {
    getVal :: [Complex PrettyDouble]
} deriving (Show)
instance Arbitrary FFTTestVal where
    arbitrary = do
        xs <- vectorOf 32 $ choose (-1.0::Double, 1.0)
        let zs = map ((:+ 0) . PrettyDouble) xs
        return $ FFTTestVal zs

prop_fft_test_N2 :: FFTTestVal -> Bool
prop_fft_test_N2 testVal = fft (myTree2 zs) == RT.fromList (dft zs)
    where zs = take 4 $ getVal testVal

prop_fft_test_N3 :: FFTTestVal -> Bool
prop_fft_test_N3 testVal = fft (myTree3 zs) == RT.fromList (dft zs)
    where zs = take 8 $ getVal testVal

prop_fft_test_N4 :: FFTTestVal -> Bool
prop_fft_test_N4 testVal = fft (myTree4 zs) == RT.fromList (dft zs)
    where zs = take 16 $ getVal testVal

prop_fft_test_N5 :: FFTTestVal -> Bool
prop_fft_test_N5 testVal = fft (myTree5 zs) == RT.fromList (dft zs)
    where zs = take 32 $ getVal testVal

-- Test definitions & choice
basicTest :: IO ()
basicTest = forM_ complexData (\x -> do
                putStr "\nTesting input: "
                print x
                putStr "Expected output: "
                print $ dft x
                putStr "Actual output:   "
                print $ fft $ myTree2 x
                )

-- This weirdness is required, as of GHC 7.8.
return []

runTests :: IO Bool
runTests = $quickCheckAll
-- End weirdness.

advancedTest :: IO ()
advancedTest = do
    allPass <- runTests -- Run QuickCheck on all prop_ functions
    unless allPass exitFailure

main :: IO ()
-- main = basicTest
main = advancedTest


module Core(
    RenderSettings(..),
    module Scene.Base,
    module Scene.Object.Plane,
    module Scene.Material.Diffuse,
    module Scene.Object.SimpleSphere,
    module Math.Color,
    module Math.Ray,
    module Scene.Material.Skylike
    ) where

import Scene.Base(Trace, traceRay, Scene, Material)
--import Scene.Object.SimpleSphere(sphere)
import Scene.Object.Plane
import Scene.Object.SimpleSphere
import Scene.Material.Skylike
import Scene.Material.Diffuse
import Math.Color
import Math.Ray
import Numeric.LinearAlgebra
import Scene.Object.Plane
import GHC.Generics (Generic)
import Control.DeepSeq

data RenderSettings  = RenderSettings {
    background :: Color,
    width :: Int,
    height :: Int,
    topLeft :: Vec3,
    topRight :: Vec3,
    bottomRight :: Vec3,
    origin :: Vec3,
    path :: FilePath,
    antialiasing :: Int}


{-|
Module: MachineLearning.MultiSvmClassifier
Description: Multiclass Support Vector Machines Classifier.
Copyright: (c) Alexander Ignatyev, 2017-2018.
License: BSD-3
Stability: experimental
Portability: POSIX

Multicalss Support Vector Machines Classifier.
-}

module MachineLearning.MultiSvmClassifier
(
  module MachineLearning.Model
  , module MachineLearning.Classification.MultiClass
  , MultiSvmClassifier(..)
)

where

import Prelude hiding ((<>))
import qualified Numeric.LinearAlgebra as LA
import Numeric.LinearAlgebra((<>), (<.>), (|||))
import qualified Data.Vector.Storable as V

import qualified MachineLearning as ML
import MachineLearning.Types (R, Vector, Matrix)
import MachineLearning.Utils (sumByRows, reduceByRowsV)
import MachineLearning.Model
import MachineLearning.Classification.MultiClass

-- | Multiclass SVM Classifier, takes delta and number of futures. Delta = 1.0 is good for all cases.
data MultiSvmClassifier = MultiSvm R Int

instance Classifier MultiSvmClassifier where
  cscore (MultiSvm _ _) x theta = x <> (LA.tr theta)

  chypothesis m x theta = predictions
    where scores = cscore m x theta
          predictions = reduceByRowsV (fromIntegral . LA.maxIndex) scores

  ccost m@(MultiSvm d _) lambda x y theta =
    let nSamples = fromIntegral $ LA.rows x
        scores = cscore m x theta
        correct_scores = LA.remap (LA.asColumn $ V.fromList [0..(fromIntegral $ LA.rows x)-1]) (LA.toInt $ LA.asColumn y) scores
        margins = scores - (correct_scores - (LA.scalar d))
        margins' = margins * LA.step margins
        loss = LA.sumElements(margins') / nSamples - d
        reg = (ccostReg lambda theta) / nSamples
    in loss + reg

  cgradient m@(MultiSvm d _) lambda x y theta =
    let nSamples = fromIntegral $ LA.rows x
        ys = processOutput m y
        scores = cscore m x theta
        correct_scores = LA.remap (LA.asColumn $ V.fromList [0..(fromIntegral $ LA.rows x)-1]) (LA.toInt $ LA.asColumn y) scores
        margins = scores - (correct_scores - (LA.scalar d))
        margins' = (1-ys)*(LA.step margins)  -- step == cmap (\x -> if x>0 then 1 else 0)
        k = sumByRows margins'
        margins'' = margins' - (ys * k)
        dw = ((LA.tr margins'') <> x) / nSamples
        reg = (cgradientReg lambda theta) / nSamples
     in dw + reg

  cnumClasses (MultiSvm _ nLabels) = nLabels


module Main(main) where

import System.Environment (getArgs)
import Codec.Picture (generateImage, savePngImage, DynamicImage(ImageRGB8), PixelRGB8(PixelRGB8), pixelAt, colorMap, mixWith)
import Numeric.LinearAlgebra.Data ((|>))
import Raytracer.Camera (Camera(Camera), Point(Point), fire_ray, calculate_ray)
import Raytracer.Geometry (cube, square, dist, Collision(Collision), calc_ray)
import Raytracer.Light (Light(Light), computeLighting)
import Data.Monoid ((<>))
import Data.Maybe (isJust)

import Control.Parallel.Strategies (rdeepseq, parMap)
import Control.Concurrent (getNumCapabilities)

help = putStrLn
  "Ray traces an image from a simple scene\n\
  \Run: width height step cx cy cz dx dy dz\n\
  \Where c_ is camera position, d_ is camera direction\n\
  \width and height the size of the image, and step is how many pixels exist between width and height\n\
  \For example, w=200 h=200 step=1 will be a 200x200 image, 200x200x2 will be 100x100, but have the same frame"

test_camera wres hres = Camera 4 3 wres hres (Just 3)
test_cube = cube (PixelRGB8 255 0 255) (3 |> [2, 0, 0]) (3 |> [0, 2, 0]) (3 |> [0, 0, 2]) (3 |> [0, 0, 0])
test_floor = square (PixelRGB8 255 255 255) (3 |> [8,0,0]) (3 |> [0,0,8]) (3 |> [-2,0,-2])
test_mesh = test_cube <> test_floor

test_lights = [
  Light (3|> [-1, 3, 1]) 6 $ PixelRGB8 255 255 255,
  Light (3|> [1, 4, 1]) 5 $ PixelRGB8 0 0 255,
  Light (3|> [6, 0, 0]) 2 $ PixelRGB8 255 0 0,
  Light (3|> [6, 0, 2]) 2 $ PixelRGB8 0 255 0,
  Light (3|> [6, 0, 4]) 2 $ PixelRGB8 0 0 255
  ]

-- This mixes light colours additively
mixColours = foldr (mixWith add) (PixelRGB8 20 20 20)
  where
  add _ c1 c2 = if maxBound - c1 >= c2 then c1 + c2 else maxBound

-- This mixes a pigment with a light subtractively
reflectLight :: PixelRGB8 -> PixelRGB8 -> PixelRGB8
reflectLight surface light = mixWith subColour surface light
  where
  subColour _ cs cl = if cl >= (maxBound - cs) then cl - (maxBound - cs) else minBound

renderPixel camera x y = computePixel $ fire_ray test_mesh ray
  where
  ray = calculate_ray camera $ Point x y
  lights = computeLighting test_mesh test_lights
  computePixel Nothing = PixelRGB8 0 0 0
  computePixel (Just (Collision d c)) = reflectLight c $ mixColours $ lights $ calc_ray ray d

verticalFlip h func camera x y = func camera x (h - y)

parGenerateImage 1 func w h = generateImage func w h
parGenerateImage n func w h = generateImage combine w h
  where
  -- combine rotates through the parallel images putting lines together
  combine x y = pixelAt (images !! (y `mod` n)) x $ y `div` n
  images = parMap rdeepseq generate [0..n-1]
  generate offset = generateImage (\x y -> func x $ y*n + offset) w $ heightFor offset
  -- heightFor offset exists for when the height is not evenly divisible by n
  -- We need to add a couple rows to the earlier images to make up the difference
  heightFor offset = h `div` n + (if offset < h `mod` n then 1 else 0)

main = do
  args <- getArgs
  if length args /= 9 then
    help
  else do
    numCores <- getNumCapabilities
    let (width:height:step:cx:cy:cz:dx:dy:dz:[]) = args
    let w' = (read width) `div` (read step)
    let h' = (read height) `div` (read step)
    let camera = test_camera w' h' (3 |> [read cx, read cy, read cz]) (3 |> [read dx, read dy, read dz])
    let img = parGenerateImage numCores (verticalFlip h' renderPixel camera) w' h'
    savePngImage "test.png" $ ImageRGB8 img


{-# LANGUAGE OverloadedStrings #-}

module Simulation where

import DigitalAGC
import LutLogTests (sfToDouble, ufToDouble)

import Clash.Prelude (
  UFixed, Unsigned, Signed, SFixed(..), Vec(..), Nat, KnownDomain(..), HiddenClockResetEnable, SNat(..),
  createDomain, vInitBehavior, vName, vSystem, InitBehavior(..), Signal,
  simulate, System,
  shiftR,
  register,
  sf, bundle, df,
  riseEvery,
  fLitR, KnownNat
  )

import Prelude
import Data.Maybe (fromMaybe)
import Data.List (group)

import Lucid
import Lucid.Html5
import Graphics.Plotly hiding (sort)
import qualified Graphics.Plotly.Base as GPB
import Graphics.Plotly.Simple
import Graphics.Plotly.Lucid
import Lens.Micro
import System.Process
import Data.Array
import Data.Foldable

import qualified Data.Complex as DC
import Numeric.Transform.Fourier.FFT
import DSP.Basic (linspace)

import DataFlow.Extra
import Test.QuickCheck

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

--dec :: Int -> [a] -> [a]
--dec n [] = []
--dec n (x : xs) = x : dec n (drop (n-1) xs)

interp :: Int -> [a] -> [a]
interp n [] = []
interp n (x : xs) = replicate n x ++ interp n xs

chunks :: Int -> [a] -> [[a]]
chunks n [] = []
chunks n xs = take n xs : chunks n (drop n xs)

quantiseS :: forall i f . (KnownNat i, KnownNat f) => SNat i -> SNat f -> Double -> Double
quantiseS _ _ x = sfToDouble (fLitR x :: SFixed i f)

quantiseU :: forall i f . (KnownNat i, KnownNat f) => SNat i -> SNat f -> Double -> Double
quantiseU _ _ x = ufToDouble (fLitR x :: UFixed i f)

d0 = SNat :: SNat 0

iSig   = SNat :: SNat 26
iGain  = SNat :: SNat 10
fGain  = SNat :: SNat 10
iAlpha = SNat :: SNat 1
fAlpha = SNat :: SNat 6
iRef   = SNat :: SNat 3
fRef   = SNat :: SNat 12
iLog   = SNat :: SNat 4
fLog   = SNat :: SNat 22

simAgc :: Double -> Double -> Double -> [(Double, Double)] -> [(Double, Double,Double)]
simAgc window ref alpha iqs =
  let window' = 2**window
      powers blk = map (\(i,q)-> quantiseU iSig d0 . sqrt $ i^2 + q^2) blk
      smooth blk = quantiseU iSig d0 $ (/window') $ sum  blk
      alg state x = quantiseS iLog fLog (
                      (quantiseS iLog fLog state) -
                      ((quantiseS iLog fLog $ logBase 10 (smooth $ powers x)) - (quantiseU iRef fRef ref)) *
                      (quantiseU iAlpha fAlpha alpha))
      gains = scanl (\state x ->
                quantiseS iLog fLog $
                alg state (map (\(i,q)->(
                  quantiseS iSig d0 $ (i*) $ quantiseU iGain fGain $ 10**state,
                  quantiseS iSig d0 $ (q*) $ quantiseU iGain fGain $ 10**state)
                  ) x)
              ) 0
              (init $ chunks (round window') iqs)
  in zipWith (\(i,q) s -> let g = quantiseU iGain fGain $ 10**s
                          in (g, quantiseS iSig d0 $ i*g, quantiseS iSig d0 $ q*g))
     iqs (interp (round window') gains)

-- My floating point simulation shows us that we _should_ be ok with our
-- approach... make some tests to verify the log and exp DF behaviour.

createDomain vSystem{vName="SyncDefined", vInitBehavior=Defined}

simInput = let iqs = map (\(i,q)->(shiftR i 1, shiftR q 1)) $ sinInputComplex 1 0.01
           in  take 3000 iqs ++ map (\(i,q)->(shiftR i 4, shiftR q 4)) iqs

-- from 1.25 to 0.75... our ref is basically divided by 4, so this makes sense for a 100x range
-- we have 0.5 range with 6 frac bits => resolution of 1/64, so 32 sensible settings for our signal height.
-- This is all with alpha = 0.9375 and a window of 7
-- Window doesn't really affect this too much
-- Alpha seems to?

-- we have a 2.6 log word ( really 4.4)

-- a = 0.9375 and window = 128 ~ 1.5k         1.5k
-- a = 0.5                       3k           3.5k
-- a = 0.25                      4.5k         5k
-- a = 0.125                     7k           8k
-- a = 0.0625                                 10k

--   alpha             recovery samples   diff      log10  log diff
--        1; 5         2                  ----      0.3    --------
--      0.5; 7.3       5.3                3.3       0.72   0.42
--     0.25; 12        9                  3.7       0.95   0.23
--    0.125; 20        17                 8         1.23   0.27
--   0.0625; 33        31                 14        1.49   0.26

-- ref = 1.13 for 32k
-- for 1000, log 10
--sim = let ref = 1.05 :: UFixed 2 10
--          window = 7 :: Unsigned 5
--          alpha = 2.0 :: UFixed 1 6
--          fLog = Clash.d6
--          fGain = Clash.d6
--          out_gain = Clash.simulate @System (uncurry (digiAgcMult (pure window) (pure ref) (pure alpha)). unbundle) simInput
--      in map (zip [1..]) [
--                           map (fromIntegral . (\(_,x,_)->x)) out_gain
--                         , map (fromIntegral . (\(_,_,x)->x)) out_gain
--                         , map (ufToDouble   . (\(x,_,_)->x)) out_gain
--                         ]

{-
Just thinking about sensible wordlengths for RFSoC...

Our input is always 16 bits.

==========

This will likely be after decimation, used inside the user's RX digital logic so we can expect deal with sampling rates well below the 4 GSamples/s... say probably a max of 512 MHz.

How many window bits are needed for a period of 1 ms?

1e-3 * 512e6 = 18.9 ... let's just say 19

==========

Fullscale signal after log will be...

after ID; we need (nWindow + nSig) bits (35!!!)
after log10; we need (1+log2 35) bits (9) and fLog fractional bits, let's say 9.fLog
after sub with ref; we need 10.fLog
after mul with alpha we need (10+ia).(fLog+fa)

{ What should alpha's range be to allow a good selection of response times? }

After the antilog, our wordlength increases exponentially! We should be super
careful about growing our wordlengths in the log domain.

==========

nSig = 16
nWindow = 19
-}

-- Experimentally found recovery cycles for every tenth decimal step in alpha
-- alphas = [0.1,0.2,...1.9]
recoveryCycles :: [(Int, Int)]
recoveryCycles = [(1,56),(2,40),(3,31),(4,26),(5,22),(6,19),(7,17),(8,15),(9,14),(10,13),(11,12),(12,11),(13,10),(14,10),(15,9),(16,8),(17,8),(18,7),(19,7)]

getRecoveryCycles :: Double -> Int
getRecoveryCycles = fromMaybe (error "No entry found for that alpha") . flip lookup recoveryCycles. round . (*10)

newtype InGain = InGain Double deriving Show
newtype InStepTime = InStepTime Int deriving Show

instance Arbitrary InStepTime where
  arbitrary = fmap InStepTime $ choose (1000,10000)

instance Arbitrary InGain where
  arbitrary = fmap (InGain . recip . fromIntegral) $ choose (1::Int,63)

steppedInput :: InGain -> InGain -> InStepTime -> [(Signed 16,Signed 16)]
steppedInput (InGain g1) (InGain g2) (InStepTime n) =
  let a = map (\(i,q)->(multD i g1, multD q g1)) . take n $ sinInputComplex 1 0.01
      b = map (\(i,q)->(multD i g2, multD q g2))           $ sinInputComplex 1 0.01
  in a ++ b
  where
  multD s d = fromIntegral . round $ fromIntegral s * d

splitInto n [] = []
splitInto n xs = let (a,b) = splitAt n xs
                 in a : splitInto n b

isSteady :: Int -> Double -> Double -> [Double] -> Bool
isSteady n ref percent = (<=n) . maximum . map length . filter (\a->False == a!!0) . group . map (\x->abs (x-ref)/ref < (percent/100))

simDfLogErr ref alpha xs =
  simulate @System (\x ->
    bundle $ df (dfLogErr (pure ref) (pure alpha)) x (riseEvery (SNat :: SNat 3)) (pure True) )
  (cycle xs) :: [(SFixed 4 22, Bool, Bool)]

{--

1) Can I reproduce the variation in simulation? Maybe generating a repeating pattern with a non-integer multiple of the window size

2) Does this also appear in the floating point simulation, because that doesn't have the delays from cordic stuff.

If no to 1) maybe it's to do with my DataFlow implementation?

I'm seeing spikes for 32 cycles in the output. Why is this?! We should only be seeing 512 sample changes because of the window of 2^9

I've fixed it... Two things now:

  1) Are the log10 and pow10 df units *really* returning consistient values?

  2) We can add a feature to set the error state! We can use that in the python instead of feeding it extra samples. Is there anything else we should flush? Maybe just pad with 32ish samples. Wait. isn't that just the reset functionality that should already exist? I've just mapped the areset pin to axi reg 0, bit 1.

--}

simOutPower g1 g2 n =
  let ref = 4.0 :: UFixed 3 12
      alpha = 1.0 :: UFixed 1 6
      window = 9 :: Unsigned 5
      --inputSig = take (10000 + rec_time*(2^window)) $ steppedInput g1 g2 n
      inputSig = take (6000*5) $ steppedInput g1 g2 n
      rec_time = (2+) . getRecoveryCycles $ ufToDouble alpha
      --out_gain = take 15000 $ simAgc (fromIntegral window) (ufToDouble ref) (ufToDouble alpha) (map (\(i,q)->(fromIntegral i, fromIntegral q)) inputSig)
      --out_pow = map (\(_,i,q)-> sqrt $ (i)**2 + (q)**2) out_gain
      ip x =
               let ip = df (testBufferDF (SNat :: SNat 6000) `seqDF` throttleDF (SNat :: SNat 4) `seqDF` dfAgc (pure window) (pure ref) (pure alpha) (pure True))
                   oR = (riseEvery (SNat :: SNat 3))
                   (y, oV, iR) = ip x (pure True) oR
               in bundle (y, oV, oR) :: Signal System ((UFixed 10 15, (Signed 16, Signed 16)), Bool, Bool)
      --outs = drop 1 . take (10000 + rec_time*(2^window))
      outs = drop 1 . take 6000 . filter (\(_,v,r)->v&&r)
             $ simulate @System ip inputSig
      out_gain = map (\((g,(i,q)), v,r)->(g,i,q)) outs
      out_pow = map (\(_,i,q)-> sqrt $ (fromIntegral i)**2 + (fromIntegral q)**2) out_gain
      out_pow_block = map ((/(2^window)) . sum) $ splitInto (2^window) out_pow
      expected_pow = 10**(ufToDouble ref)
  in (inputSig, out_gain, out_pow, out_pow_block, rec_time, expected_pow)

prop_OutPower :: InGain -> InGain -> InStepTime -> Property
prop_OutPower g1 g2 (InStepTime n) =
  let (_, _, _, out_pow_block, rec_time, expected_pow) = simOutPower g1 g2 (InStepTime n)
  in property . isSteady rec_time expected_pow 1 $ drop (ceiling $ (fromIntegral n) / 2**7) out_pow_block

showTest g1 g2 n =
    renderToFile "/tmp/clash/sim.html" $ doctypehtml_ $ do
    head_ $ do meta_ [charset_ "utf-8"]
               plotlyCDN
               reloadCDN
               styleSheet
    body_ $ do
               toHtml $ plotly "time_iq_in" (traceTime simInputTrace)
                          & layout . title ?~ "Time domain I/Q Input"
               toHtml $ plotly "time_iq_out" (traceTime tData)
                          & layout . title ?~ "Time domain I/Q Output"
               toHtml $ plotly "constl_iq_out" (traceConstl tData)
                          & layout . title ?~ "Constellation I/Q"
                          & layout . width ?~ 600
                          & layout . height ?~ 600
               toHtml $ plotly "time_iq_ctrl" (traceTime ctrlData)
                          & layout . title ?~ "Time domain Control"
  where
  (simInput, sim, out_pow, _, _, _) = simOutPower g1 g2 n
  tData = map (zip [1..]) $ [map (\(_,x,_)->fromIntegral x) sim
                            ,map (\(_,_,x)->fromIntegral x) sim
                            ,map (\(x,_,_)->ufToDouble x)   sim
                            --[map (\(_,x,_)-> x) sim
                            --,map (\(_,_,x)-> x) sim
                            --,map (\(x,_,_)->x)   sim
                            ] :: [[(Double, Double)]]
  ctrlData = [tData !! 2, tData !! 2]
  simInputTrace = map (zip [(1::Double)..] . map (sfToDouble . sf (SNat :: SNat 0)))  [map fst simInput, map snd simInput]

corr :: [(Double, Double)] -> Double
corr = correlation . V.fromList

--prop_corrTest g1 g2 n =
--  let (_, outsig, _, _, recTime, _) = simOutPower g1 g2 n
--      insig = steppedInput (InGain 0.3125) (InGain 0.3125) (InStepTime 0)
--      inI  = map (fromIntegral . fst) insig
--      inQ  = map (fromIntegral . snd) insig
--      outI = map (fromIntegral . (\(_,i,_)->i)) outsig
--      outQ = map (fromIntegral . (\(_,_,q)->q)) outsig
--      correlation = corr $ zip (drop recTime inI) (drop recTime outI)
--  in property $ correlation > 0.9

bl10 n = fromIntegral . ceiling $ logBase 2 (logBase 10 (2**n))
be10 n = fromIntegral . ceiling $ logBase 2 (10 ** (2**n))

bitsCalc :: Double -> Double -> Double -> (Double, Double) -> Double
         -> (Double, (Double, Double), (Double, Double))
bitsCalc window sig fLog (iAlpha, fAlpha) fGain =
  let intgInternal = 2**window + sig
      iLog = bl10 sig
      iGain = be10 iLog - fGain
  in (intgInternal, (iLog,fLog), (iGain, fGain))

sinInput :: Double -> Double -> [Signed 16]
sinInput fs dt = map (fromInteger . round . ((2**15-1) * ) .  sin . (2*pi*fs * )) [0.0, dt..]

sinInputComplex :: Double -> Double -> [(Signed 16, Signed 16)]
sinInputComplex fs dt = zip sins coss
  where sins = map (fromInteger . round . ((2**15-1) * ) .  sin . (2*pi*fs * )) [0.0, dt..]
        coss = map (fromInteger . round . ((2**15-1) * ) .  cos . (2*pi*fs * )) [0.0, dt..]

reloadCDN :: Monad m => HtmlT m ()
reloadCDN = script_ [src_ "http://livejs.com/live.js"] $ toHtml (""::String)

styleSheet :: Monad m => HtmlT m ()
styleSheet = style_ [type_ "text/css" ] $
             toHtml (".svg-container {margin: 0 auto !important;}"::String)

traceTime a =  [trace "I" $ a !! 0
               ,trace "Q" $ a !! 1]
  where trace label points = linePlot points
                               & name ?~ label
                               & (GPB.line ?~ (defLine & lineshape ?~ Hv))

traceConstl points = [scatterPlot $ zip (map snd (points!!0)) (map snd (points!!1))]

startServer = callCommand "mkdir -p /tmp/clash; cd /tmp/clash/; python -m http.server > /dev/null 2>&1 &"

return []
runTests = $quickCheckAll

{- TODO

Include bin files in IP make script

Try find what resolution we need to increase in order to better recover very very low signals.

-}


{-# LANGUAGE ScopedTypeVariables, ConstraintKinds, GADTs #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-} -- See below
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_GHC -fno-warn-unused-binds   #-}

----------------------------------------------------------------------
-- |
-- Module      :  Generic.FFT
-- Copyright   :  (c) 2013 Tabula, Inc.
--
-- Maintainer  :  conal@tabula.com
-- Stability   :  experimental
--
-- FFT via functor composition. Apply to depth-typed perfect binary leaf trees.
----------------------------------------------------------------------
module Generic.FFT
  ( dft
  , idft
  , dct
  , HasFFT(..)
  ) where

import Prelude hiding (sum)

import Control.Applicative (Applicative(..), liftA2)
import Control.Arrow ((***))
import Data.Foldable (Foldable, sum)
import Data.Functor ((<$>))
import Data.Monoid (Monoid(..), Sum(..), (<>))
import Data.Traversable (Traversable(..), mapAccumL)

import Data.Complex (Complex(..), conjugate, realPart)
import Data.Tuple (swap)

import Data.UniformPair

import TypeUnary.Nat

import qualified Data.FTree.BottomUp as B
import qualified Data.FTree.TopDown as T

{--------------------------------------------------------------------
    Misc
--------------------------------------------------------------------}
type Unop a = a -> a

transpose :: (Traversable g, Applicative f) => g (f a) -> f (g a)
transpose = sequenceA

inTranspose ::
     (Traversable f, Traversable k, Applicative g, Applicative h)
  => (g (f a) -> k (h b))
  -> (f (g a) -> h (k b))
inTranspose = transpose --> transpose

infixr 1 -->

-- | Add pre- and post processing
(-->) :: (a' -> a) -> (b -> b') -> ((a -> b) -> (a' -> b'))
(f --> h) g = h . g . f

type R = Double
type C = Complex R

scanL :: (Traversable f, Monoid a) => (a, f a) -> (f a, a)
scanL (a0, as) = swap (mapAccumL h a0 as)
  where
    h a a' = (a <> a', a)

-- TODO: Replace scanL with my efficient parallel version.
-- Prefix (left) sums
sumsL :: (Traversable f, Num a) => (a, f a) -> (f a, a)
sumsL = (fmap getSum *** getSum) . scanL . (Sum *** fmap Sum)

-- Yield a structure counting from 0 to size-1, together with size
counts ::
     forall f a. (TA f, Num a)
  => (f a, a)
counts = sumsL (0, pure 1)

-- Cross product of structures
cross :: (Functor g, Functor f) => g a -> f b -> g (f (a, b))
as `cross` bs = fmap (\a -> fmap (a, ) bs) as

-- All products of numbers from each structure.
products :: (Functor g, Functor f, Num n) => g n -> f n -> g (f n)
products = (fmap . fmap . fmap . fmap) (uncurry (*)) cross

-- as `products` bs = (fmap.fmap) (uncurry (*)) (as `cross` bs)
-- as `products` bs = fmap (\ a -> fmap (\ b -> a*b) bs) as
-- Dot product of structures. Assumes a trie-like f, so that the Applicative
-- instance combines corresponding elements. Perhaps replace Applicative with a
-- more suitable constraint.
dot :: (Applicative f, Foldable f, Num a) => f a -> f a -> a
u `dot` v = sum (liftA2 (*) u v)

i2pi :: C
i2pi = 0 :+ 2 * pi

-- Principle nth root of unity with negated angle
uroot :: Int -> C
uroot n = exp (-i2pi / fromIntegral n)

{--------------------------------------------------------------------
    Unoptimized discrete Fourier transform (DFT)
--------------------------------------------------------------------}
-- Discrete Fourier transform:
-- $X_k = \sum_{n=0}^{N-1} x_n e^{-i 2\pi k \frac{n}{N}}$ for $k = 0,\ldots,N$.
dft :: TA f => Unop (f C)
dft xs = (xs `dot`) <$> rootses

idft ::
     forall f. TA f
  => Unop (f C)
idft = fmap ((/ fromIntegral n) . conjugate) . dft . fmap conjugate
  where
    n :: Int
    indices :: f Int
    (indices, n) = counts

-- Inefficinet; doesn't exploit symmetry, but a starting point for testing
dct :: TA f => Unop (f R)
dct = fmap realPart . dft . fmap (:+ 0)

-- Powers of 'uroot' needed in the DFT:
-- $e^{\frac{-i 2\pi k n}{N}}$ for $k,n = 0,\ldots,N$:
rootses ::
     forall f. TA f
  => f (f C)
rootses = rootCross tot indices indices
  where
    indices :: f Int
    (indices, tot) = counts

rootCross :: (Functor g, Functor f, Integral n) => Int -> g n -> f n -> g (f C)
rootCross tot = (fmap . fmap . fmap . fmap) (uroot tot ^) products

-- rootCross tot is js = (fmap.fmap) (uroot tot ^) (is `products` js)
{--------------------------------------------------------------------
    FFT
--------------------------------------------------------------------}
-- | FFT computation, parametrized by structure
class HasFFT f f' | f -> f' where
  fft :: f C -> f' C

-- Constraint shorthands
type TA f = (Traversable f, Applicative f)

type TAH f f' = (TA f, TA f', HasFFT f f')

-- Binary butterfly.
instance HasFFT Pair Pair where
  fft (a :# b) = a + b :# a - b

-- Decimation in time (DIT)
instance (TAH f f', IsNat n) => HasFFT (B.T f n) (T.T f' n) where
  fft (B.L a) = T.L a
  fft (B.B t) = T.B (fftC t)

-- Decimation in frequency (DIF)? I'm unsure.
instance (TAH f f', IsNat n) => HasFFT (T.T f n) (B.T f' n) where
  fft (T.L a) = B.L a
  fft (T.B t) = B.B (fftC t)

instance HasFFT [] [] where
  fft = dft

--     Variable s `f, f' occur more often than in the instance head
--       in the constraint: TAH f
--     (Use -XUndecidableInstances to permit this)
--     In the instance declaration for `HasFFT (T f n)'
--
-- This warning vanishes when we spell out TAH. Hm.
-- I'd prefer terser definitions like `fft = T.inT' T.l (T.B . fftC)`, but I
-- haven't found a type for `inT'` that GHC likes.
fftsT :: (Applicative f, Traversable g, HasFFT g g') => g (f C) -> f (g' C)
fftsT = fmap fft . transpose

-- FFT of composed functors
fftC :: (TAH f f', TAH g g') => g (f C) -> f' (g' C)
fftC = transpose . fftsT . twiddle . fftsT

{-

--   fftsT     :: g  (f  C) -> f  (g' C)
--   twiddle   :: f  (g' C) -> f  (g' C)
--   fftsT     :: f  (g' C) -> g' (f' C)
--   transpose :: g' (f' C) -> f' (g' C)

-}
-- Multiply by twiddle factors
twiddle ::
     forall f g. (TA f, TA g)
  => Unop (g (f C))
twiddle = (liftA2 . liftA2) (*) rootses'
  where
    rootses' = rootCross (gTot * fTot) gIndices fIndices
      where
        fIndices :: f Int
        (fIndices, fTot) = counts
        gIndices :: g Int
        (gIndices, gTot) = counts

{--------------------------------------------------------------------
    Experimental variation
--------------------------------------------------------------------}
-- This version is a better fit with
-- <https://en.wikipedia.org/wiki/Cooley%E2%80%93Tukey_FFT_algorithm#General_factorizations>
-- FFT of composed functors
fftC' :: (TAH f f', TAH g g') => g (f C) -> f' (g' C)
fftC' = fftsT' . transpose . twiddle . fftsT'
  where
    fftsT' :: (TA h, TAH k k') => k (h C) -> k' (h C)
    fftsT' = (inTranspose . fmap) fft

-- Hm. This definition differs from the previous one, since `twiddle` and
-- `transpose` got swapped. I doubt they're equivalent.
-- Types in the fftC' definition (right to left):
--
--   fftsT'    :: g  (f  C) -> g' (f  C)
--   twiddle   :: g' (f  C) -> g' (f  C)
--   transpose :: g' (f  C) -> f  (g' C)
--   fftsT'    :: f  (g' C) -> g' (g' C)
{--------------------------------------------------------------------
    Tests
--------------------------------------------------------------------}
-- {1, 0, 0, 0, ...} <=DFT=> {1, 1, 1, 1, ...}\
-- {1, -1, 1, -1, 1, -1, ...} <=DFT=> {0, 0, ... , N, 0, 0, ...} (where the 'N' occurs at the N/2 position in the output vector.
-- dft . idft ~= id
-- TODO :: show some example outputs and add a series of Quickcheck tests to
-- validate them.
-- TODO: make B / Pair showable

_p1 :: Pair C
_p1 = 1 :# 0

_t1 :: B.T Pair N3 C
_t1 = B.B (B.B (B.B (B.L (((1 :# 0) :# (0 :# 0)) :# ((0 :# 0) :# (0 :# 0))))))

_t2 :: B.T Pair N4 C
_t2 = pure 1

_t3 :: B.T Pair N3 C
_t3 = B.B (pure (1 :# -1))


{-# LANGUAGE ConstraintKinds #-}

module HashedExpression.Internal.Expression
  ( R,
    C,
    Covector,
    ET (..),
    Node (..),
    Internal,
    NodeID,
    ExpressionMap,
    Expression (..),
    Scalar,
    Dimension,
    ToShape (..),
    DimensionType,
    ElementType,
    NumType,
    VectorSpace,
    InnerProductSpace,
    PowerOp (..),
    PiecewiseOp (..),
    VectorSpaceOp (..),
    FTOp (..),
    ComplexRealOp (..),
    RotateOp (..),
    Shape,
    RotateAmount,
    Arg,
    Args,
    BranchArg,
    ConditionArg,
    InnerProductSpaceOp (..),
  )
where

import Data.Array
import qualified Data.Complex as DC
import Data.IntMap (IntMap)
import qualified Data.IntMap.Strict as IM
import Data.Proxy (Proxy (..))
import Data.Typeable (Typeable, typeRep)
import GHC.TypeLits (KnownNat, Nat, natVal)
import Prelude hiding ((^))

-- | Type representation of elements in the 1D, 2D, 3D, ... grid
data R
  deriving (NumType, ElementType, Typeable)

data C
  deriving (NumType, ElementType, Typeable)

data Covector
  deriving (ElementType, Typeable)

-- | Type representation of vector dimension
data Scalar
  deriving (Dimension, Typeable)

-- |
instance (KnownNat n) => Dimension n

instance (KnownNat m, KnownNat n) => Dimension '(m, n)

instance (KnownNat m, KnownNat n, KnownNat p) => Dimension '(m, n, p)

-- | Classes as constraints
class ElementType et

class ElementType et => NumType et

-------------------------------------------------------------------------------
class
  (Dimension d) =>
  ToShape d where
  toShape :: Proxy d -> Shape

instance ToShape Scalar where
  toShape _ = []

instance (KnownNat n) => ToShape n where
  toShape _ = [nat @n]

instance (KnownNat m, KnownNat n) => ToShape '(m, n) where
  toShape _ = [nat @m, nat @n]

instance (KnownNat m, KnownNat n, KnownNat p) => ToShape '(m, n, p) where
  toShape _ = [nat @m, nat @n, nat @p]

type DimensionType d = (Dimension d, ToShape d)

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

-- |
nat :: forall n. (KnownNat n) => Int
nat = fromIntegral $ natVal (Proxy :: Proxy n)

-------------------------------------------------------------------------------
class Dimension d

class VectorSpace d et s

class VectorSpace d s s => InnerProductSpace d s

instance (DimensionType d, ElementType et) => VectorSpace d et R

instance (DimensionType d) => VectorSpace d C C

instance VectorSpace d s s => InnerProductSpace d s

-- | Classes for operations so that both Expression and Pattern (in HashedPattern) can implement
class PowerOp a b | a -> b where
  (^) :: a -> b -> a

class VectorSpaceOp a b where
  scale :: a -> b -> b
  (*.) :: a -> b -> b
  (*.) = scale

class ComplexRealOp r c | r -> c, c -> r where
  (+:) :: r -> r -> c
  xRe :: c -> r
  xIm :: c -> r

class InnerProductSpaceOp a b c | a b -> c where
  (<.>) :: a -> b -> c

class RotateOp k a | a -> k where
  rotate :: k -> a -> a

class PiecewiseOp a b where
  piecewise :: [Double] -> a -> [b] -> b

class FTOp a b | a -> b where
  ft :: a -> b

infixl 6 +:

infixl 8 *., `scale`, <.>

infixl 8 ^

-- | Shape type:
-- []        --> scalar
-- [n]       --> 1D with size n
-- [n, m]    --> 2D with size n × m
-- [n, m, p] --> 3D with size n × m × p
type Shape = [Int]

-- | Args - list of indices of arguments in the ExpressionMap
type Args = [NodeID]

type Arg = NodeID

type ConditionArg = NodeID

type BranchArg = NodeID

-- | Rotation in each dimension.
-- | Property:  the length of this must match the dimension of the data
type RotateAmount = [Int]

-- | Data representation of element type
data ET
  = R
  | C
  | Covector
  deriving (Show, Eq, Ord)

-- | Internal
-- Shape: Shape of the expression
-- we can reconstruct the type of the Expression
type Internal = (Shape, Node)

-- | Hash map of all subexpressions
type ExpressionMap = IntMap Internal

-- | The index/key to look for the node on the hash table
type NodeID = Int

-- | Expression with 2 phantom types (dimension and num type)
data Expression d et
  = Expression
      { exRootID :: Int, -- the index this expression
        exMap :: ExpressionMap -- all subexpressions
      }
  deriving (Show, Eq, Ord, Typeable)

type role Expression nominal nominal -- So the users cannot use Data.Coerce.coerce to convert between expression types

-- | Node type
data Node
  = Var String
  | DVar String -- only contained in **Expression d Covector (1-form)**
  | Const Double -- only all elements the same
      -- MARK: Basics
  | Sum ET Args -- element-wise sum
  | Mul ET Args -- multiply --> have different meanings (scale in vector space, multiplication, ...)
  | Power Int Arg
  | Neg ET Arg
  | Scale ET Arg Arg
  | -- MARK: only apply to R
    Div Arg Arg -- TODO: Delete?
  | Sqrt Arg
  | Sin Arg
  | Cos Arg
  | Tan Arg
  | Exp Arg
  | Log Arg
  | Sinh Arg
  | Cosh Arg
  | Tanh Arg
  | Asin Arg
  | Acos Arg
  | Atan Arg
  | Asinh Arg
  | Acosh Arg
  | Atanh Arg
  | -- MARK: Complex related
    RealImag Arg Arg -- from real and imagine
  | RealPart Arg -- extract real part
  | ImagPart Arg -- extract imaginary part
      -- MARK: Inner product Space
  | InnerProd ET Arg Arg
  | -- MARK: Piecewise
    Piecewise [Double] ConditionArg [BranchArg]
  | Rotate RotateAmount Arg
  | -- MARK: Discrete Fourier Transform
    ReFT Arg
  | ImFT Arg
  | -- Need these inside because taking real of FT twice can be very fast
    TwiceReFT Arg
  | TwiceImFT Arg
  deriving (Show, Eq, Ord)


{-# LANGUAGE RecordWildCards #-}
module Fish ( Fish (..)
            , Loc
            , FishKind
            , Tolerance
            , FishData
            , move
            ) where
import Data.Complex
import qualified Data.Map.Strict as M

import Consts

type Loc = Complex Double
type FishKind = Int
type Tolerance = Double
type FishData = M.Map (Int,Int) Tolerance

data Fish = Fish {_kind :: FishKind, _loc :: Loc} deriving (Eq, Show)

distSquare :: Fish -> Fish -> Double
distSquare (Fish {_loc=l0}) (Fish {_loc=l1}) =
        sq (realPart l0 - realPart l1) + sq (imagPart l0 - imagPart l1)

sq :: Num a => a -> a
sq = (^ (2::Int))

tolerance :: FishData -> Fish -> Fish -> Double
tolerance d f0 f1 = d M.! (_kind f0, _kind f1)

tooClose :: FishData -> Fish -> Fish -> Bool
tooClose d f0 f1 = distSquare f0 f1 < tolerance d f0 f1

move :: FishData -> [Fish] -> [(Fish, Bool)]
move dat fs = map moveOne fs where
    -- TODO : consider better implementation
    force :: Fish -> Fish -> Loc
    force f0 f1 = let
        v = _loc f0 - _loc f1 in
            (dt:+0) * ((tolerance dat f0 f1 :+ 0) - abs v) * signum v
    moveOne :: Fish -> (Fish, Bool)
    moveOne f@(Fish {..}) = let
        neighbours = filter (/= f) . filter (tooClose dat f) $ fs
        mean = (/ ((fromIntegral . length) neighbours :+ 0))
        totalForce = mean . sum . map (force f) $ neighbours
        in
            (f {_loc = _loc + totalForce}, toEnum . signum $ length neighbours)


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TupleSections #-}

module MLP.Types (
   Pattern(..),
   input,
   output,
   DataSet(..),
   trainSet,
   testSet,
   Parameters(..),
   topology,
   learningRate,
   decayLearningRate,
   normalise,
   epochs,
   minErrorRate,
   trainFile,
   testFile,
   verbose,
   Topology(..),
   numInputs,
   hiddenLayers,
   numOutputs,
   topoFold,
   dataSet,
   params,
   State(..),
   network,
   curEpoch,
   curError,
   App(..),
   zipWithPat,
   MonadFileSystem(..)
)  where

import Control.Lens (makeLenses, (^..), (^.), ix, folding, Fold)
import Data.Aeson (FromJSON(..), withObject, withArray, (.:), (.:?), (.!=))
import Numeric.LinearAlgebra.Data (Vector, Matrix, loadMatrix)
import Numeric.LinearAlgebra.Static (R, L, zipWithVector)
import Data.Aeson.Lens (key, values, _Integral)
import Data.Aeson.TH (deriveToJSON, defaultOptions, Options(..))
import Control.Monad (guard)
import Data.Maybe (fromMaybe)
import Control.Monad.State.Lazy (StateT(..), runStateT)
import Control.Monad.Writer.Lazy (Writer(..), runWriter)
import qualified Data.Text as T
import Data.Functor.Identity (Identity)
import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
import qualified Data.ByteString.Lazy as B
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.State.Class (MonadState(..))
import GHC.TypeLits ( KnownNat, Nat )
import MLP.Network (Net(..), AllCon, Learn(..), MLP(..))
import Data.Singletons (SingI(..))
import Numeric.Natural ( Natural )
import qualified Data.Text.IO as TIO (putStrLn)

data Pattern (i :: Nat) (o :: Nat) = Pattern {
   _input :: R i,
   _output :: R o
} deriving Show

-- rank 2 function
apply :: (forall n. R n -> R n -> R n) -> Pattern i o -> Pattern i o -> Pattern i o
apply f (Pattern in1 out1) (Pattern in2 out2) = Pattern (f in1 in2) (f out1 out2)

zipWithPat :: (KnownNat i, KnownNat o) => (Double -> Double -> Double) -> Pattern i o -> Pattern i o -> Pattern i o
zipWithPat f (Pattern i1 o1) (Pattern i2 o2) =
   Pattern (zipWithVector f i1 i2) (zipWithVector f o1 o2)

instance Num (Pattern i o) where
   (-) p1 p2 = apply (-) p1 p2
   (+) p1 p2 = apply (+) p1 p2
   (*) p1 p2 = apply (*) p1 p2
   abs (Pattern inp out) = Pattern (abs inp) (abs out)
   signum (Pattern inp out) = Pattern (signum inp) (signum out)
   fromInteger num = Pattern (fromInteger num) (fromInteger num)

instance Fractional (Pattern i o) where
   (/) p1 p2 = apply (/) p1 p2
   recip (Pattern inp out) = Pattern (recip inp) (recip out)
   fromRational rat = Pattern (fromRational rat) (fromRational rat)

data DataSet i o = DataSet {
   _trainSet :: [Pattern i o],
   _testSet :: [Pattern i o]
} deriving Show

data Topology = Topology {
   _numInputs :: Natural,
   _hiddenLayers :: [Natural],
   _numOutputs :: Natural
} deriving Show

data Parameters = Parameters {
   _topology :: Topology,
   _learningRate :: Double,
   _decayLearningRate :: Bool,
   _epochs :: Natural,
   _minErrorRate :: Double,
   _normalise :: Bool,
   _trainFile :: FilePath,
   _testFile :: FilePath,
   _verbose :: Bool
} deriving Show

data State i hs o = State {
   _dataSet :: DataSet i o,
   _params :: Parameters,
   _network :: !(Net i hs o),
   _curEpoch :: Natural,
   _curError :: Double
}

makeLenses ''Pattern
makeLenses ''DataSet
makeLenses ''Topology

topoFold :: Fold Topology Natural
topoFold = folding $ \s -> (s ^. numInputs) : (s ^. hiddenLayers) ++ (s ^.. numOutputs)

makeLenses ''Parameters
makeLenses ''State

type Log = [T.Text]

newtype App (i :: Nat) (hs :: [Nat]) (o :: Nat) (a :: *) = App {
   -- | this is an unpacked StateT (StateT i hs o) (Writer Log) a
   runApp :: State i hs o -> ((a, State i hs o), Log)
}

instance Functor (App i hs o) where
   fmap f (App app) =
      App $ \s ->
         let ((!a,!s'),!l) = app s
            in ((f a,s'),l)

instance Applicative (App i hs o) where
   pure a = App $ \s -> ((a,s), mempty)

   (App fab) <*> (App fa) =
      App $ \s ->
         let ((!ab,!s'),!l) = fab s
             ((a, s''), l') = fa s'
            in ((ab a, s''), l <> l')

instance Monad (App i hs o) where
   return = pure

   (App ma) >>= amb =
      App $ \s ->
         let ((!a, !s'), !l) = ma s
             ((b, s''), l') = runApp (amb a) s'
            in ((b, s''), l <> l')

instance MonadWriter Log (App i hs o) where
   writer (!a, !l) = App $ \s -> ((a,s),l)
   tell !l = App $ \s -> (((),s),l)
   listen (App app) =
      App $ \s ->
         let ((!a,!s''),!l) = app s
            in (((a,l),s''),l)

   pass (App app) =
      App $ \s ->
         let (((!a,!f),!s'),!l) = app s
            in ((a,s'),l)

instance MonadState (State i hs o) (App i hs o) where
   get = App $ \s -> ((s,s),mempty)
   put s = App . const $ (((), s), mempty)
   state app = App ((,mempty).app)

class (Monad m, MonadFail m) => MonadFileSystem m where
   readFileM :: FilePath -> m B.ByteString
   readMatrixM :: FilePath -> m (Matrix Double)
   printText :: T.Text -> m ()

instance MonadFileSystem IO where
   readFileM fl = B.readFile fl
   readMatrixM = loadMatrix
   printText = TIO.putStrLn

$(deriveToJSON defaultOptions{fieldLabelModifier=drop 1} ''Topology)
$(deriveToJSON defaultOptions{fieldLabelModifier=drop 1} ''Parameters)

instance FromJSON Topology where
   parseJSON = withObject "Topology" (\o -> do
      inputs <- o .: "numInputs"
      guard (inputs > 0)

      outputs <- o .: "numOutputs"
      guard (outputs > 0)

      let hidden =  o ^.. ix "hiddenLayers".values._Integral

      return $ Topology inputs hidden outputs)

instance FromJSON Parameters where
   parseJSON = withObject "Parameters" (\o -> do
      _topology <- o .: "topology"
      _learningRate <- o .:? "learningRate" .!= 0.6
      _decayLearningRate <- o .:? "decayLearningRate" .!= False
      _normalise <- o .:? "normalise" .!= False
      _epochs <- o .:? "epochs" .!= 1000
      _minErrorRate <- o .: "minErrorRate"
      _trainFile <- o .: "trainFile"
      _testFile <- o .: "testFile"

      _verbose <- o .:? "verbose" .!= False

      return $ Parameters {..})


{-|
Module      : Data.Meta.Multiarm
Description : Matrix function for graphs
Copyright   : (c) Thodoris Papakonstantinou, 2019
License     : GPL-3
Maintainer  : mail@tpapak.com
Stability   : experimental
Portability : POSIX

-}

module Data.Meta.Matrices
  ( createBMatrix
  , createAMatrix
  , createCMatrix
  )
where

import           Control.Applicative
import           Data.List
import qualified Data.Map.Strict               as Map
import qualified Data.Set                      as Set
import           Data.Maybe
import           Data.Either
import           Data.Meta.Effects
import qualified Numeric.LinearAlgebra         as LA
import qualified Numeric.LinearAlgebra.Devel   as LAD
import qualified Data.Graph.AdjacencyList      as G
import qualified Data.Graph.AdjacencyList.BFS      as BFS

-- | create the edge vertex adjacency matrix given a graph
createBMatrix :: G.Graph -> LA.Matrix Double
createBMatrix g =
  let vs  = G.vertices g
      nvs = length vs
      es  = G.edges g
      nes = length es
      rowfromEdge e =
          let
            (u, v) = G.toTuple e
            r      = LA.fromList $ replicate nvs 0.0 :: LA.Vector Double
            r' =
              LAD.mapVectorWithIndex
                (\i _ ->
                  if i == u - 1 then 1.0 else if i == v - 1 then (-1.0) else 0.0
                )
                r :: LA.Vector Double
          in
            r'
      rows = map rowfromEdge es
      b    = LA.fromRows rows
  in  b

createAMatrix :: G.Graph -> LA.Matrix Double
createAMatrix g =
  let vs  = G.vertices g
      nvs = length vs
      es  = G.edges g
      nes = length es
      rowfromEdge e =
          let
            (u, v) = G.toTuple e
            r      = LA.fromList $ replicate (nvs - 1) 0.0 :: LA.Vector Double
            r' =
              LAD.mapVectorWithIndex
                (\i _ ->
                  if i == u - 2 then 1.0 else if i == v - 2 then (-1.0) else 0.0
                )
                r :: LA.Vector Double
           in r'
      rows = map rowfromEdge es
      a    = LA.fromRows rows
  in  a

-- | create the Vertex Edge adjacency matrix given a graph

-- | create the Vertex Edge adjacency matrix given a graph
createCMatrix :: G.Graph -> LA.Matrix Double
createCMatrix g =
  let vs  = G.vertices g
      nvs = length vs
      es  = G.edges g
      nes = length es
      rowfromVertex v =
        let r = map (\e ->
              let (u, v') = G.toTuple e
                  fillcell x | x==u = (-1.0)
                  fillcell x | x==v' = (1.0)
                  fillcell _ = (0.0)
               in  fillcell v
                  ) es
         in LA.fromList $ r :: LA.Vector Double
      rows = map rowfromVertex vs
      c    = LA.fromRows rows
  in  c

-- | create the Vertex Edge adjacency matrix given a graph
createXMatrix :: G.Graph -> LA.Matrix Double
createXMatrix g =
  let vs  = G.vertices g
      nvs = length vs
      es  = G.edges g
      nes = length es
      firstVertex = head vs
      bfsNet = BFS.bfs g firstVertex
      spanningtree = BFS.spanningTree bfsNet
      rowfromVertex v =
        let r = map (\e ->
              let (u, v') = G.toTuple e
                  fillcell x | x==u = (-1.0)
                  fillcell x | x==v' = (1.0)
                  fillcell _ = (0.0)
               in  fillcell v
                  ) es
         in LA.fromList $ r :: LA.Vector Double
      rows = map rowfromVertex vs
      c    = LA.fromRows rows
  in  c


module Eris.Predict.KNNbased where

import Data.HashMap.Strict as Map
import Data.Maybe (isNothing, isJust, fromJust)
import Control.Monad (guard)
import qualified Numeric.LinearAlgebra as NL

import Eris.Meta.DataStructure
import Eris.Compute.Similarity

-- | Example:
-- records2eCount :  get ecount
-- pairWiseSimilarity : get similarity Matrix
-- neighborOf : get neighbor of a entity  A
-- f1 : filter neighbors of A which related to entity of the other type .
-- c1 : retrive relation between two type of entity.
-- t : compute knnbased recommendataion.
t :: NeighborRank -> NeighborSimilarity-> Maybe Rank
t nr ns
    | length ns /= length nr = Nothing
    | otherwise = Just $ knnbased  ns nr
    where knnbased ns nr =  let
                              v1 = NL.vector $ fmap snd ns
                              v2 = NL.vector $ fmap snd nr
                            in  v1 NL.<.> v2 / NL.norm_1 v1

f1 :: PID -> ECount -> NeighborSimilarity -> NeighborSimilarity
f1 pid ecount nsim = do
    r@(eid,_) <- nsim
    guard $ validRecord ecount eid pid
    return r

c1 :: PID -> ECount -> NeighborSimilarity -> NeighborRank
c1 pid ecount nsim =do
                    (eid, _) <- nsim
                    let justRank = getRank ecount eid pid
                    guard $ isJust justRank
                    return (eid, fromJust justRank)

-- | Given an ID of a entity of certain type.
--  Based on the similairty matrix of this type of entity.
--  collect its neighbors and sort by Order.
--  return a list of tuple [(EID, Rank)] , rank value is necessary in case any further filter or verification process.
neighborOf :: Order -> CID -> SimilarityMatrix -> NeighborSimilarity
neighborOf ord cus matrix
  | isNothing (Map.lookup cus matrix) = []
  | otherwise = let
      rlist = Map.toList matrix
      neighborsRank = collectRank rlist cus
      in sortByRank neighborsRank ord
  where
        collectRank :: [(EID, Map.HashMap EID Rank)] -> EID -> NeighborSimilarity
        collectRank ((eid,edict) : exs) tid
            | eid == tid = Map.toList edict
            | otherwise = (eid,Map.lookupDefault 0 tid edict): collectRank exs tid
        sortByRank :: NeighborSimilarity -> Order -> NeighborSimilarity
        sortByRank nr o = let
            ascOrder = quickSortRank nr
            in if o == Desc
               then
                 reverse ascOrder
                else
                  ascOrder
        quickSortRank :: NeighborSimilarity -> NeighborSimilarity
        quickSortRank [] = []
        quickSortRank ((eid,erank):ers) =
            let smallRanks = quickSortRank [e | e <- ers , snd e <= erank]
                biggerRanks = quickSortRank [ e | e<- ers, snd e > erank]
            in smallRanks ++ [(eid,erank)] ++ biggerRanks

-- | Auxiliary Functions
validRecord :: ECount -> CID -> PID -> Bool
validRecord ec c p=
        let cContainsP = do
                          pdict <- Map.lookup c ec
                          Map.lookup p pdict
        in isJust cContainsP

getRank :: ECount -> CID -> PID -> Maybe Rank
getRank ec c p = do
    pdict <- Map.lookup c ec
    Map.lookup p pdict


-- This separation exists due to the GHC stage restriction of TH

{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS_GHC -ddump-splices #-}

module Deep.ExampleMain where

import Deep.Example

import Data.Complex
import Control.Monad

main :: IO ()
main = do
  print $(thExample1)
  print ($(thExample2) :: Int)
  print $(thExample3)
  print ($(thExample4) :: Int)
  print $(thExample5)
  print (thExample6 8)
  print (thExample6 7)
  print $(thExample7)
  print (thExample9 (IntPair 4 1))

  putStrLn "mandelbrot:"

  print (mandelbrot_nextZ (1 :+ 1, 0))

  print (mandelbrot_point ((-1) :+ 0))
  print (mandelbrot_point (1 :+ 0))
  print (mandelbrot_point (0 :+ 0))

  putStrLn mandelbrotTestAscii

  print (shouldFail (3 :+ 0))

  -- print thExample6
  -- print ($(thExample6) 3)

mandelbrotTestAscii :: String
mandelbrotTestAscii =
  unlines
    (map go [0..mandelbrot_height-1])
  where
    go y = map (go2 y) [0..mandelbrot_width-1]

    go2 y x =
      case mandelbrot_point (mandelbrot_toCoord x y) of
        Just _ -> ' '
        Nothing -> '*'

mandelbrot_toCoord :: Int -> Int -> Complex Double
mandelbrot_toCoord x0 y0 =
    (mandelbrot_xMin + x * mandelbrot_xIncr) :+ (mandelbrot_yMin + y * mandelbrot_yIncr)
  where
    x, y :: Double
    x = fromIntegral x0
    y = fromIntegral y0

mandelbrot_xIncr :: Double
mandelbrot_xIncr = (mandelbrot_xMax - mandelbrot_xMin) / (fromIntegral mandelbrot_width - 1)

mandelbrot_yIncr :: Double
mandelbrot_yIncr = (mandelbrot_yMax - mandelbrot_yMin) / (fromIntegral mandelbrot_height - 1)

mandelbrot_xMin :: Double
mandelbrot_xMin = -2.5

mandelbrot_xMax :: Double
mandelbrot_xMax = 1

mandelbrot_yMin :: Double
mandelbrot_yMin = -1.5

mandelbrot_yMax :: Double
mandelbrot_yMax = 1

mandelbrot_width :: Int
mandelbrot_width = 200

mandelbrot_height :: Int
mandelbrot_height = 40