{-# LANGUAGE RankNTypes,
             ScopedTypeVariables,
             ViewPatterns,
             TypeFamilies,
             TypeOperators,
             RankNTypes,
             MultiWayIf,
             DataKinds,
             LambdaCase,
             ConstraintKinds,
             FlexibleContexts #-}

module Networks where

import Optimierung
import Tuple
import Numeric.LinearAlgebra.Static.Backprop
import Numeric.Backprop
import GHC.TypeNats
import qualified Numeric.LinearAlgebra.Static as H
import qualified Control.Foldl as L
import qualified Data.Vector.Storable as V

type KN i o = (KnownNat i, KnownNat o)
type Fehler a b = forall z. Reifies z W => BVar z a -> BVar z a -> BVar z b
type Res p a b c = forall z. Reifies z W => BVar z (a :& b) -> BVar z p -> BVar z c

type Modell p a b =
       forall z. Reifies z W
    => BVar z p
    -> BVar z a
    -> BVar z b

withScalarActivation :: (Reifies z W, KnownNat i)
                     => (BVar z Double -> BVar z Double)
                     -> BVar z (R i :& Double)
                     -> BVar z (R i)
                     -> BVar z Double
withScalarActivation f (w :&& b) v = f $ w <.> v + b

withActivation :: (Reifies z W, KN i o)
               => (BVar z (R o) -> BVar z (R o))
               -> BVar z (L o i :& R o)
               -> BVar z (R i)
               -> BVar z (R o)
withActivation f (w :&& b) v = f $ w #> v + b

logistic :: Floating a => a -> a
logistic x = 1 / (1 + exp (-x))

linear :: KnownNat i => Modell (R i :& Double) (R i) Double
linear = withScalarActivation id

linear2 :: KnownNat i => Modell (R i :& Double) (R i) Double
linear2 (w :&& b) x = w <.> x + b

sigmoid :: KN i o => Modell (L o i :& R o) (R i) (R o)
sigmoid = withActivation logistic

--todo: dvmap isn't actually made differentiable, manually make Op
leakyReLU :: KN i o => Modell (L o i :& R o) (R i) (R o)
leakyReLU = withActivation $ dvmap $ \x -> if (x < 0) then 0.01*x
                                                      else x

sigmoidNoBias :: KN i o => Modell (L o i) (R i) (R o)
sigmoidNoBias w v = logistic $ w #> v

sigmoid' :: KnownNat i => Modell (R i :& Double) (R i) Double
sigmoid' = withScalarActivation logistic

se :: Fehler Double Double
se x a = (x - a)^2

se' :: (KnownNat n, 1 <= n) => Fehler (R n) Double
se' a e = (d <.> d) / 2
    where d = e - a

crossentropy' :: (KnownNat n, 1 <= n) => Fehler (R n) Double
crossentropy' a y = vsum . nanToNum . negate $ entropy y a + entropy (1-y) (1-a)
    where entropy x y = x * log y

crossentropyUnsafe' :: (KnownNat n, 1 <= n) => Fehler (R n) Double
crossentropyUnsafe' a y = vsum . negate $ entropy y a + entropy (1-y) (1-a)
    where entropy x y = x * log y

crossentropy :: (KnownNat n, 1 <= n) => R n -> R n -> Double
crossentropy a y = (H.konst 1) H.<.> (entropy (-y) a - entropy (1-y) (1-a))
    where entropy x y = x * log y

logisticSample :: KN i o => (L o i :& R o) -> Int -> R i -> R o
logisticSample (w :& b) s v = H.zipWithVector (\x p -> if x < p then 1 else 0) r probs
    where probs = logistic $ w H.#> v + b
          r     = H.randomVector s H.Uniform

nonModelLogistic :: KN i o => (L o i :& R o) -> R i -> R o
nonModelLogistic (w :& b) v = logistic $ w H.#> v + b

vsum :: (Reifies z W, KnownNat n) => BVar z (R n) -> BVar z Double
vsum x = (konst 1) <.> x

rbmcd1 :: KN d h => Int -> (L d h :& R d :& R h) -> R d -> (L d h :& R d :& R h)
rbmcd1 s (w :& b :& c) v1 = (H.outer v1 h1 - H.outer v2 h2) :& (v1 - v2) :& (h1 - h2)
    where h1 = (logisticSample (H.tr w :& c) s v1)
          v2 = (nonModelLogistic (w :& b) h1)
          h2 = (nonModelLogistic (H.tr w :& c) v2)

gradientStep :: (Backprop p, Backprop b, Backprop c)
             => Modell p a b  -- ^ Modell zum Trainieren
             -> Fehler b c    -- ^ Fehlerfunktion
             -> p             -- ^ Parameter am Anfang des Schrittes
             -> (a, b)        -- ^ (Eingabedatum, erwartete Antwort)
             -> p             -- ^ Gradient des Parameters
gradientStep mod err param (vec, trg) = gradBP (\p -> err (mod p (auto vec)) (auto trg)) param

makeFoldAll :: Optimierung d p
         => d p
         -> (p -> a -> p)
         -> p
         -> L.Fold a p
makeFoldAll d f p0 = L.Fold (\x a -> regel d x (f (aus x) a)) (start p0) aus

uberwachtesFold :: (Optimierung d p, Backprop p, Backprop b, Backprop c)
                => d p
                -> Modell p a b
                -> Fehler b c
                -> p
                -> L.Fold (a, b) p
uberwachtesFold op mod err p0 = makeFoldAll op (gradientStep mod err) p0

isVecNaN :: KnownNat n => R n -> Bool
isVecNaN = V.foldl (\acc x -> acc || isNaN x) False . H.extract

nanToNum :: (KnownNat n, Reifies z W) => BVar z (R n) -> BVar z (R n)
nanToNum = vmap bvToNum

bvToNum :: Reifies z W => BVar z Double -> BVar z Double
bvToNum = liftOp1 . op1 $ \x -> ((if
                            | isNaN x      -> 0.0
                            | isInfinite x -> if x < 0 then -1.7976931348623157e+308
                                                       else  1.7976931348623157e+308
                            | otherwise    -> x), id)

supervised :: (Backprop a, Backprop p, Backprop b, Backprop c)
           => Fehler b c
           -> Modell p a b
           -> Res p a b c
supervised err mod (a :&& y) ps = err (mod ps a) y

class Optimizable m where
    type Params m
    type In     m
    gradient :: m -> Params m -> In m -> Params m

makeFoldOptimizable :: (Optimizable m, Optimierung d (Params m))
                    => m
                    -> d (Params m)
                    -> Params m
                    -> L.Fold (In m) (Params m)
makeFoldOptimizable m d p0 = L.Fold (\x a -> regel d x (step (aus x) a)) (start p0) aus
    where step = gradient m

(<~) :: (Backprop p, Backprop q)
     => Modell  p       b c
     -> Modell      q  a b
     -> Modell (p :& q) a c
(f <~ g) (p :&& q) = f p . g q

infixr 8 <~


{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (c) Edward Kmett 2010-2015
-- License     :  BSD3
-- Maintainer  :  ekmett@gmail.com
-- Stability   :  experimental
-- Portability :  GHC only
--
-----------------------------------------------------------------------------

module Numeric.AD.Mode
  (
  -- * AD modes
    Mode(..)
  ) where

import Numeric.Natural
import Data.Complex
import Data.Int
import Data.Ratio
import Data.Word

infixr 7 *^
infixl 7 ^*
infixr 7 ^/

class (Num t, Num (Scalar t)) => Mode t where
  type Scalar t
  -- | allowed to return False for items with a zero derivative, but we'll give more NaNs than strictly necessary
  isKnownConstant :: t -> Bool
  isKnownConstant _ = False

  -- | allowed to return False for zero, but we give more NaN's than strictly necessary then
  isKnownZero :: t -> Bool
  isKnownZero _ = False

  -- | Embed a constant
  auto  :: Scalar t -> t

  -- | Scalar-vector multiplication
  (*^) :: Scalar t -> t -> t
  a *^ b = auto a * b

  -- | Vector-scalar multiplication
  (^*) :: t -> Scalar t -> t
  a ^* b = a * auto b

  -- | Scalar division
  (^/) :: Fractional (Scalar t) => t -> Scalar t -> t
  a ^/ b = a ^* recip b

  -- |
  -- @'zero' = 'lift' 0@
  zero :: t
  zero = auto 0

instance Mode Double where
  type Scalar Double = Double
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Float where
  type Scalar Float = Float
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Int where
  type Scalar Int = Int
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Integer where
  type Scalar Integer = Integer
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Int8 where
  type Scalar Int8 = Int8
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Int16 where
  type Scalar Int16 = Int16
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Int32 where
  type Scalar Int32 = Int32
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Int64 where
  type Scalar Int64 = Int64
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Natural where
  type Scalar Natural = Natural
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Word where
  type Scalar Word = Word
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Word8 where
  type Scalar Word8 = Word8
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Word16 where
  type Scalar Word16 = Word16
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Word32 where
  type Scalar Word32 = Word32
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Mode Word64 where
  type Scalar Word64 = Word64
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance RealFloat a => Mode (Complex a) where
  type Scalar (Complex a) = Complex a
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)

instance Integral a => Mode (Ratio a) where
  type Scalar (Ratio a) = Ratio a
  isKnownConstant _ = True
  isKnownZero x = 0 == x
  auto = id
  (^/) = (/)


{-# LANGUAGE CPP #-}
module Main (main) where

import Prelude hiding (sum)

#if !MIN_VERSION_base(4, 8, 0)
import Control.Applicative ((<$>))
#endif
import Control.Monad (when)
import Data.Foldable (sum)
import Data.Maybe (fromJust)

import System.Environment (getArgs, getProgName)
import System.Random (getStdGen, randoms)

import Text.Printf (printf)

import qualified Data.Vector.Generic as V

import qualified Criterion as C
import qualified Criterion.Types as C
import qualified Statistics.Resampling.Bootstrap as S

import qualified Data.ReedSolomon as RS

runBench :: RS.Encoder -> RS.Matrix -> IO Double
runBench encoder shards = do
    let bench = C.nf (fromJust . RS.encode RS.defaultBackend encoder) shards

    r <- C.benchmark' bench

    let mean = S.estPoint $ C.anMean $ C.reportAnalysis r
        iters = 1.0 / mean
        dataSize = sum $ V.map V.length shards
        throughput = iters * fromIntegral dataSize

    return throughput

main :: IO ()
main = do
    args <- getArgs
    when (length args /= 3) $ do
        progName <- getProgName
        error $ "Usage: " ++ progName ++ " dataShards parityShards dataSize"

    let [dataShards, parityShards, dataSize] = fmap read args

    instructionSet <- RS.simdInstructions
    printf "Using CPU instructions: %s\n" (maybe "None" show instructionSet)

    putStrLn "generating encoder..."
    encoder <- RS.new dataShards parityShards

    putStrLn "generating data..."
    vs <- RS.split encoder =<< V.fromListN dataSize . randoms <$> getStdGen

    throughput <- runBench encoder vs

    printf "Configuration: dataShards %d, parityShards %d, dataSize %d, shardSize %d\n"
        dataShards parityShards dataSize (V.length $ V.head vs)
    printf "Mean throughput: %.2f MB/s\n" (throughput / (1024 * 1024))


{-# LANGUAGE GADTs, OverloadedStrings, DeriveFunctor #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Matrix.MatrixMarket.Internal
-- Copyright   :  (c) Marco Zocca 2017
-- License     :  BSD2 (see the file LICENSE)
--
-- Maintainer  :  zocca marco gmail
-- Stability   :  experimental
-- Portability :  portable
--
-- Attoparsec parser and serializer for the NIST MatrixMarket format. The parser logic originally appeared in `accelerate-examples` and it is reused here (courtesy of T.McDonell and the `accelerate` developers) with some amendments.
--
-- In this version:
-- * Numbers are represented with Scientific notation instead of floating point
-- * Parsing rules are a bit relaxed to accommodate various whitespace corner cases
--
-----------------------------------------------------------------------------
module Data.Matrix.MatrixMarket.Internal
       (readMatrix, readMatrix', readArray,
        writeMatrix, writeMatrix', writeArray,
        Matrix(..), Array(..),
        Format (Coordinate, Array), Structure (General, Symmetric, Hermitian, Skew),
        nnz, dim, numDat,
        dimArr, numDatArr,
        ImportError) where

import Control.Applicative                      hiding ( many )

import Data.Int
import qualified Data.Char as C
import Data.Complex
import qualified Data.Scientific as S
import Data.Attoparsec.ByteString.Char8 hiding (I)
-- import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Attoparsec.Lazy           as L
import qualified Data.ByteString.Lazy           as L

import Control.Monad.Catch
import Control.Exception.Common

-- | Specifies either sparse or dense storage.  In sparse (\"coordinate\")
-- storage, elements are given in (i,j,x) triplets for matrices (or (i,x) for
-- vectors).  Indices are 1-based, so that A(1,1) is the first element of a
-- matrix, and x(1) is the first element of a vector.
--
-- In dense (\"array\") storage, elements are given in column-major order.
--
-- In both cases, each element is given on a separate line.
--
data Format = Coordinate | Array
    deriving (Eq, Show)

-- | Specifies the element type.  Pattern matrices do not have any elements,
-- only indices, and only make sense for coordinate matrices and vectors.
--
data Field  = R | C | I | P
    deriving (Eq, Show)

-- | Specifies any special structure in the matrix.  For symmetric and hermitian
-- matrices, only the lower-triangular part of the matrix is given. For skew
-- matrices, only the entries below the diagonal are stored.
--
data Structure = General | Symmetric | Hermitian | Skew
    deriving (Eq, Show)

-- | Sparse matrix in coordinate form (row, column, entry)
-- NB: indices are 1-based i.e. A(1,1) is the top-left entry of matrix A
data Matrix a = RMatrix (Int, Int) Int Structure [(Int, Int, a)]
              | CMatrix (Int, Int) Int Structure [(Int, Int, Complex a)]
              | PatternMatrix (Int,Int) Int  Structure [(Int32,Int32)]
              | IntMatrix (Int,Int) Int Structure [(Int32,Int32,Int)]
              deriving (Eq, Show)

-- | Array, i.e. a DENSE matrix (also used to represent vectors as n-by-1 matrices)
data Array a = RArray (Int, Int) Structure [a]
             | CArray (Int, Int) Structure [Complex a]
             deriving (Eq, Show)

--------------------------------------------------------------------------------
-- Attoparsec combinators
--------------------------------------------------------------------------------

comment :: Parser ()
comment = char '%' *> skipWhile (not . eol) *> endOfLine
  where
    eol w = w `elem` ("\n\r" :: String)

floating :: Parser S.Scientific
floating = skipSpace' *> scientific

integral :: Integral a => Parser a
integral = skipSpace' *> decimal

format :: Parser Format
format =  string "coordinate" *> pure Coordinate
      <|> string "array"      *> pure Array
      <?> "matrix format"

field :: Parser Field
field =  string "real"    *> pure R
     <|> string "complex" *> pure C
     <|> string "integer" *> pure I
     <|> string "pattern" *> pure P
     <?> "matrix field"

structure :: Parser Structure
structure =  string "general"        *> pure General
         <|> string "symmetric"      *> pure Symmetric
         <|> string "hermitian"      *> pure Hermitian
         <|> string "skew-symmetric" *> pure Skew
         <?> "matrix structure"

header :: Parser (Format,Field,Structure)
header =  string "%%MatrixMarket matrix"
       >> (,,) <$> (skipSpace' *> format)
               <*> (skipSpace' *> field)
               <*> (skipSpace' *> structure)
               <*  endOfLine
               <?> "MatrixMarket header"

extentMatrix :: Parser (Int,Int,Int)
extentMatrix = do
  [m,n,l] <- skipSpace' *> count 3 integral <* endOfLine
  return (m,n,l)

extentArray :: Parser (Int,Int)
extentArray = do
  [m,n] <- skipSpace' *> count 2 integral <* endOfLine
  return (m,n)

line3 :: Integral i => Parser a -> Parser (i,i,a)
line3 f = (,,) <$> integral
               <*> integral
               <*> f
               <*  (endOfLine <|> L.endOfInput)

skipSpace' :: Parser String
skipSpace' = many' space

--------------------------------------------------------------------------------
-- Load and parse
--------------------------------------------------------------------------------

matrix :: Parser (Matrix S.Scientific)
matrix = do
  (f, t, s) <- header
  (m, n, l) <- skipMany comment *> extentMatrix
  if f /= Coordinate
    then fail "matrix is not in Coordinate format"
    else
    case t of
     R -> RMatrix (m,n) l s <$> many1 (line3 floating)
     C -> CMatrix (m,n) l s <$> many1 (line3 ((:+) <$> floating <*> floating))
     I -> IntMatrix     (m,n) l s <$> many1 (line3 integral)
     P -> PatternMatrix (m,n) l s <$> many1 ((,) <$> integral <*> integral)

array :: Parser (Array S.Scientific)
array = do
  (f, t, s) <- header
  (m, n) <- skipMany comment *> extentArray
  if f /= Array
    then fail "array is not in Array format"
    else
     case t of
       R -> RArray (m,n) s <$> many1 floating
       C -> CArray (m,n) s <$> many1 ((:+) <$> floating <*> floating)
       _ -> fail "integer and pattern cases not relevant for the dense case"

-- | Load a matrix (sparse, i.e. in Coordinate format) from file
readMatrix :: FilePath -> IO (Matrix S.Scientific)
readMatrix file = L.readFile file >>= readMatrix'

-- | Load a matrix (sparse, i.e. in Coordinate format) from a bytestring.
readMatrix' :: L.ByteString -> IO (Matrix S.Scientific)
readMatrix' chunks =
  case L.parse matrix chunks of
    L.Fail _ _ msg      -> throwM (FileParseError "readMatrix" msg)
    L.Done _ mtx        -> return mtx

-- | Load a dense matrix (i.e. a matrix or vector in Array format) from file
readArray :: FilePath -> IO (Array S.Scientific)
readArray file = do
  chunks <- L.readFile file
  case L.parse array chunks of
    L.Fail _ _ msg      -> throwM (FileParseError "readArray" msg)
    L.Done _ mtx        -> return mtx

--------------------------------------------------------------------------------
-- Write to file
--------------------------------------------------------------------------------

showFormat :: Format -> String
showFormat = map C.toLower <$> show

showField :: Field -> String
showField f = case f of R -> "real"
                        C -> "complex"
                        I -> "integer"
                        P -> "pattern"

showStruct :: Structure -> String
showStruct = map C.toLower <$> show

-- %%MatrixMarket matrix coordinate real general

headerStr :: Format -> Field -> Structure -> L.ByteString
headerStr f t s =
    B.pack $ unwords ["%%MatrixMarket matrix",
                      showFormat f, showField t, showStruct s]

nl :: L.ByteString
nl = toLBS "\n"

showLines :: (a -> String) -> [a] -> L.ByteString
showLines showf d = L.concat (L.pack . withNewline . showf <$> d) where
  withNewline x = toEnum . C.ord <$> x ++ "\n"

-- | Serialize a sparse matrix in Coordinate format
writeMatrix :: Show b => FilePath -> Matrix b -> IO ()
writeMatrix file = L.writeFile file . writeMatrix'

-- | Serialize a sparse matrix in Coordinate format as a bytestring
writeMatrix' :: Show b => Matrix b -> L.ByteString
writeMatrix' mat =
  case mat of (RMatrix d nz s dat) ->
                matrixByteString d nz R s dat
              (CMatrix d nz s dat) ->
                matrixByteString d nz C s dat
              (IntMatrix d nz s dat) ->
                matrixByteString d nz I s dat
              _ -> error "writeMatrix : PatternMatrix not implemented yet"
     where
       matrixByteString di nz t s d =
         L.concat [headerStr Coordinate t s,
                   nl,
                   headerSzMatrix di nz,
                   nl,
                   showLines sf3 d]
         where
         sf3 (i,j,x) = unwords [show i, show j, show x]
         headerSzMatrix (m,n) numz = B.pack $ unwords [show m, show n, show numz]

-- | Serialize a dense matrix in Array format
writeArray :: Show a => FilePath -> Array a -> IO ()
writeArray file arr =
  case arr of (RArray d s dat) -> L.writeFile file (arrayByteString d R s dat)
              (CArray d s dat) -> L.writeFile file (arrayByteString d C s dat)
    where
      arrayByteString di t s d =
        L.concat [headerStr Array t s,
            nl,
            headerSzArray di,
            nl,
            showLines show d] where
        headerSzArray (m,n) = B.pack $ unwords [show m, show n]

-- | helpers

-- | Number of matrix nonzeros
nnz :: Matrix t -> Int
nnz m = case m of (RMatrix _ nz _ _) -> nz
                  (CMatrix _ nz _ _) -> nz
                  (PatternMatrix _ nz _ _) -> nz
                  (IntMatrix _ nz _ _) -> nz

-- | Matrix size : number of rows, number of columns
dim :: Matrix t -> (Int, Int)
dim m = case m of (RMatrix d _ _ _) -> d
                  (CMatrix d _ _ _) -> d
                  (PatternMatrix d _ _ _) -> d
                  (IntMatrix d _ _ _) -> d

-- | Length of data vector internal to the Matrix; this is _not_ necessarily the actual number of matrix entries because symmetric entries are not stored
numDat :: Matrix t -> Int
numDat m = case m of (RMatrix _ _ _ d) -> length d
                     (CMatrix _ _ _ d) -> length d
                     (PatternMatrix _ _ _ d) -> length d
                     (IntMatrix _ _ _ d) -> length d

-- | Array size : number of rows, number of columns
dimArr :: Array t -> (Int, Int)
dimArr a = case a of (RArray d _ _) -> d
                     (CArray d _ _) -> d

-- | Length of data vector internal to the Array; this is _not_ necessarily the actual number of matrix entries because symmetric entries are not stored
numDatArr :: Array a -> Int
numDatArr a = case a of (RArray _ _ ll) -> length ll
                        (CArray _ _ ll) -> length ll

-- | String -> ByteString
-- NB: do not abuse
-- toBS :: String -> BS.ByteString
-- toBS x = BS.pack $ (toEnum . C.ord) <$> x

-- | String -> lazy ByteString
-- NB: do not abuse
toLBS :: String -> L.ByteString
toLBS x = L.pack $ (toEnum . C.ord) <$> x

-- t1 = toBS "%%MatrixMarket matrix coordinate real general\n5  5  8\n1     1   1.000e+00\n2     2   1.050e+01\n3     3   1.500e-02\n1     4   6.000e+00\n4     2   2.505e+02\n4     4  -2.800e+02\n4     5   3.332e+01\n5     5   1.200e+01\n"

-- t2 = toBS "%%MatrixMarket matrix coordinate real general\n5  5  8\n1     1   1.000e+00\n"


{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE TypeApplications #-}

module Main ( main ) where

import           Criterion.Main
import           Data.List.NonEmpty (NonEmpty(..))
import           Data.Massiv.Array as A hiding (zipWith)
import qualified Data.Vector as V
import qualified Data.Vector.Unboxed as U
import           Geography.MapAlgebra
import           GHC.TypeLits
import           Graphics.ColorSpace
import qualified Numeric.LinearAlgebra as LA
import           Prelude hiding (zipWith)

---

main :: IO ()
main = do
  img   <- fileY "data/gray512.tif"
  imgF  <- fileY "data/gray512.tif"
  rgba  <- fileRGB "data/512x512.tif"
  a512  <- fileRGB "data/512x512.tif"
  -- a1024 <- fileRGB "data/1024x1024.tif"
  -- a2048 <- fileRGB "data/2048x2048.tif"
  -- a4096 <- fileRGB "data/4096x4096.tif"
  -- let aHuge :: Raster S u 46500 46500 Word8
  --     aHuge = fromFunction S Par (\(r :. c) -> fromIntegral $ r * c)
  defaultMain
    [
      creation
    , io
    , colouring img
    , massivOps img
    , localOps rgba a512 img
    , hmatrix
    , conversions img
    , focalOps img imgF
    , compositeOps a512 -- a1024 a2048 a4096
    , histograms img
    ]

creation :: Benchmark
creation = bgroup "Raster Creation"
           [ bench "constant 256x256"     $ nf (_array . constantB) 5
           , bench "constant 512x512"     $ nf (_array . constantB') 5
           , bench "fromFunction 256x256" $ nf (_array . functionB) (\(r :. c) -> r * c)
           , bench "fromFunction 512x512" $ nf (_array . functionB') (\(r :. c) -> r * c)
           , bench "fromVector Unboxed Int - 256x256" $ nf (_array . vectorB) uv
           , bench "fromVector Boxed Int - 256x256"   $ nf (_array . vectorB') bv ]
  where uv = U.fromList ([1..65536] :: [Int])
        bv = V.fromList ([1..65536] :: [Int])

io :: Benchmark
io = bgroup "IO"
     [ bench "fromRGBA 512x512" $ nfIO (_array . _red <$> fileRGB @Word8 @512 @512 "data/512x512.tif")
     , bench "fromRGBA (Word8 -> Double) 512x512" $ nfIO (_array . _red <$> fileRGB @Double @512 @512 "data/512x512.tif")
     , bench "fromGray Multiband 512x512"  $ nfIO (_array <$> fileY @Word8 @512 @512 "data/512x512.tif")
     , bench "fromGray Singleband 512x512" $ nfIO (_array <$> gray "data/gray512.tif") ]

colouring :: Raster S p 512 512 Word8 -> Benchmark
colouring img = bgroup "Colouring"
                [ bench "classify 512x512"  $ nf (_array . strict S . classify invisible cr . lazy) img
                , bench "grayscale 512x512" $ nf (_array . strict S . grayscale . lazy) img ]
  where cr = greenRed [25, 50, 75, 100, 125, 150, 175, 200, 225, 255]

massivOps :: Raster S p 512 512 Word8 -> Benchmark
massivOps img = bgroup "Massiv Operations"
                [ bench "strict S . lazy" $ nf (_array . strict S . lazy) img
                , bench "strict U . lazy" $ nf (_array . strict U . lazy) img
                , bench "strict P . lazy" $ nf (_array . strict P . lazy) img ]

localOps :: RGBARaster p 512 512 Word8 -> RGBARaster p 512 512 Double -> Raster S p 512 512 Word8 -> Benchmark
localOps (RGBARaster r g b _) (RGBARaster rF gF bF _) img = bgroup "Local Operations"
  [ bench "fmap (+ 17) . lazy" $ nf (_array . strict S . fmap (+ 17) . lazy) img
  , bench "zipWith (+)"    $ nf (_array . strict S . zipWith (+) r) g
  , bench "zipWith (/)"    $ nf (_array . strict S . zipWith (/) rF) gF
  , bench "(+)"            $ nf (_array . strict S . (+ lazy r)) (lazy g)
  , bench "(/)"            $ nf (_array . strict S . (/ lazy rF)) (lazy gF)
  -- , bench "(.+)"           $ nf (\g' -> computeAs S $ _array r .+ g') (_array g)
  -- , bench "(./)"           $ nf (\g' -> computeAs S $ _array rF ./ g') (_array gF)
  , bench "lmax"           $ nf (_array . strict S . lmax img) img
  , bench "lmin"           $ nf (_array . strict S . lmin img) img
  , bench "lmean (Word8)"  $ nf (_array . strict S . lmean @Word8 @Double) rs
  , bench "lmean (Double)" $ nf (_array . strict S . lmean @Double @Double) rsF
  , bench "lvariety"       $ nf (_array . strict S . lvariety) rs
  , bench "lmajority"      $ nf (_array . strict S . lmajority) rs
  , bench "lminority"      $ nf (_array . strict S . lminority) rs
  , bench "lvariance (Word8)"  $ nf (fmap (_array . strict S) . lvariance) rs
  , bench "lvariance (Double)" $ nf (fmap (_array . strict S) . lvariance) rsF ]
  where rs  = lazy r :| [lazy g, lazy b]
        rsF = lazy rF :| [lazy gF, lazy bF]

hmatrix :: Benchmark
hmatrix = bgroup "HMatrix"
          [ bench "linearSolveLS" $ nf (LA.linearSolveLS zing) (LA.col [8,8,8,8,8,8,8,8,8])
          , bench "manual - MxM"  $ nf (leftPseudo <>) (LA.col [8,8,8,8,8,8,8,8,8])
          , bench "manual - MxV"  $ nf (leftPseudo LA.#>) (LA.vector [8,8,8,8,8,8,8,8,8]) ]

conversions :: Raster S p 512 512 Word8 -> Benchmark
conversions img = bgroup "Numeric Conversion"
                  [ bench "Double -> Double via id"         $ nf id tau
                  , bench "Double -> Double via realToFrac" $ nf (realToFrac @Double @Double) tau
                  , bench "Word -> Double via realToFrac"   $ nf (realToFrac @Word8 @Double) 5
                  , bench "realToFrac on Raster"            $ nf (_array . strict S . fmap (realToFrac @Word8 @Double) . lazy) img ]

focalOps :: Raster S p 512 512 Word8 -> Raster S p 512 512 Double -> Benchmark
focalOps img imgF = bgroup "Focal Operations"
               [ bgroup "fsum"
                 [ bench "512"    $ nf (_array . strict S . fsum) img
                 -- , bench "46500"  $ nf (_array . strict S . fsum) huge
                 -- , bench "maybing" $ nf (_array . strict B . fmap Just . lazy) img
                 -- , bench "nodata" $ nf (_array . strict S . nodatafsum) img
                 ]
               , bgroup "fmean"
                 [ bench "Word8"  $ nf (_array . strict S . fmean @Word8 @Double) img
                 , bench "Double" $ nf (_array . strict S . fmean @Double @Double) imgF
                 ]
               , bench "fmax"        $ nf (_array . strict S . fmax) img
               , bench "fmin"        $ nf (_array . strict S . fmin) img
               , bench "fmajority"   $ nf (_array . strict S . fmajority) img
               , bench "fminority"   $ nf (_array . strict S . fminority) img
               , bench "fvariety"    $ nf (_array . strict S . fvariety) img
               , bench "fpercentage" $ nf (_array . strict S . fpercentage) img
               , bench "fpercentile" $ nf (_array . strict S . fpercentile) img
               , bench "flinkage"    $ nf (_array . strict S . flinkage) img
               , bench "flength"     $ nf (_array . strict S . flength . flinkage) img
               , bench "fpartition"  $ nf (_array . strict B . fpartition) img
               , bench "fshape"      $ nf (_array . strict B . fshape) img
               , bench "ffrontage"   $ nf (_array . strict S . ffrontage . fshape) img
               , bench "farea"       $ nf (_array . strict S . farea . fshape) img
               , bgroup "fvolume"
                 [ bench "Word8 -> Double" $ nf (_array . strict S . fvolume . strict S . fmap (realToFrac @Word8 @Double) . lazy) img
                 , bench "Double" $ nf (_array . strict S . fvolume) imgF
                 ]
               , bgroup "fgradient"
                 [ bench "Word8"  $ nf (_array . strict S . fgradient . strict S . fmap wtod . lazy) img
                 , bench "Double" $ nf (_array . strict S . fgradient) imgF
                 ]
               , bgroup "faspect"
                 [ bench "Unsafe (Word8)"  $ nf (_array . strict S . faspect' . strict S . fmap wtod . lazy) img
                 , bench "Unsafe (Double)" $ nf (_array .strict S . faspect') imgF
                 , bench "Safe (Word8)"    $ nf (_array . strict B . faspect . strict S . fmap wtod . lazy) img
                 , bench "Safe (Double)"   $ nf (_array . strict B . faspect) imgF
                 ]
               , bgroup "fdownstream"
                 [ bench "Word8"  $ nf (_array . strict S . fdownstream . strict S . fmap wtod . lazy) img
                 , bench "Double" $ nf (_array. strict S . fdownstream) imgF
                 ]
               , bgroup "fupstream"
                 [ bench "Word8"  $ nf (_array . strict S . fupstream . strict S . fdownstream . strict S . fmap wtod . lazy) img
                 , bench "Double" $ nf (_array . strict S . fupstream . strict S . fdownstream) imgF
                 ]
               ]

wtod :: Word8 -> Double
wtod = realToFrac

compositeOps :: RGBARaster p 512 512 Double
  -- -> RGBARaster p 1024 1024 Double
  -- -> RGBARaster p 2048 2048 Double
  -- -> RGBARaster p 4096 4096 Double
  -> Benchmark
compositeOps i@(RGBARaster r g _ _) =
  bgroup "Composite Operations"
  [ bench "NDVI" $ nf (_array . strict S . ndvi (lazy g)) (lazy r)
  , bench "EVI (512)"    $ nf (_array . strict S . evi) i
  -- , bench "EVI (1024)"   $ nf (_array . strict S . evi) a1024
  -- , bench "EVI (2048)"   $ nf (_array . strict S . evi) a2048
  -- , bench "EVI (4096)"   $ nf (_array . strict S . evi) a4096
  , bench "EVI + Colour" $ nf (_array . strict S . classify invisible cr . evi) i
  , bench "EVI + Colour + PNG (D)" $ nf (png . classify invisible cr . evi) i
  , bench "EVI + Colour + PNG (S)" $ nf (png . strict S . classify invisible cr . evi) i ]
  where cr = greenRed $ fmap (10 ^) ([1..10] :: [Int])

fromRight :: Either a b -> b
fromRight (Right b) = b
fromRight _         = error "Was Left"

constantB :: Int -> Raster S p 256 256 Int
constantB = constant S Par

constantB' :: Int -> Raster S p 512 512 Int
constantB' = constant S Par

functionB :: (Ix2 -> Int) -> Raster S p 256 256 Int
functionB = fromFunction S Par

functionB' :: (Ix2 -> Int) -> Raster S p 512 512 Int
functionB' = fromFunction S Par

vectorB :: U.Vector Int -> Raster U p 256 256 Int
vectorB = fromRight . fromVector Par

vectorB' :: V.Vector Int -> Raster B p 256 256 Int
vectorB' = fromRight . fromVector Par

-- doubles :: Raster U p 512 512 Double
-- doubles = fromRight . fromVector Par $ U.fromList ([1..262144] :: [Double])

zing :: LA.Matrix Double
zing = LA.matrix 3 [ -0.5, -0.5, 1
                   , -0.5, 0, 1
                   , -0.5, 0.5, 1
                   , 0, -0.5, 1
                   , 0, 0, 1
                   , 0, 0.5, 1
                   , 0.5, -0.5, 1
                   , 0.5, 0, 1
                   , 0.5, 0.5, 1 ]

gray :: FilePath -> IO (Raster S p 512 512 Word8)
gray fp = do
  i <- fromGray fp
  case i of
    Left err  -> error err
    Right img -> pure img

fileY :: (Elevator a, KnownNat r, KnownNat c) => FilePath -> IO (Raster S p r c a)
fileY fp = do
  i <- fromGray fp
  case i of
    Left err  -> error err
    Right img -> pure img
{-# INLINE fileY #-}

fileRGB :: (Elevator a, KnownNat r, KnownNat c) => FilePath -> IO (RGBARaster p r c a)
fileRGB fp = do
  i <- fromRGBA fp
  case i of
    Left err  -> error err
    Right img -> pure img
{-# INLINE fileRGB #-}

-- | See: https://en.wikipedia.org/wiki/Normalized_difference_vegetation_index
ndvi :: (KnownNat r, KnownNat c) => Raster D p r c Double -> Raster D p r c Double -> Raster D p r c Double
ndvi nir red = (nir - red) / (nir + red)
{-# INLINE ndvi #-}

-- | See: https://en.wikipedia.org/wiki/Enhanced_vegetation_index
evi :: (Fractional a, Storable a, KnownNat r, KnownNat c) => RGBARaster p r c a -> Raster D p r c a
evi (RGBARaster r g b _) = 2.5 * (numer / denom)
  where nir   = lazy g  -- fudging it.
        numer = nir - lazy r
        denom = nir + (6 * lazy r) - (7.5 * lazy b) + 1
{-# INLINE evi #-}

-- nodatafsum :: Raster S p 1753 1760 Double -> Raster DW p 1753 1760 Double
-- nodatafsum = fmap (maybe 0 ((/9) . getSum)) . fmonoid . strict B . fmap check . lazy
--   where check 0 = Nothing
--         check n = Just $ Sum n
-- {-# INLINE nodatafsum #-}

histograms :: Raster S p 512 512 Word8 -> Benchmark
histograms r = bgroup "Histogram Algorithms"
  [ bench "Storable Super Mutable" $ nf (_histogram . histogram) r
  ]


import Numeric.LinearAlgebra
import Graph
import Adjacency

main :: IO ()
main = do
  putStr . dispf 0 . edges'' . toAdjacency $ completeGraph [1..1000]


{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Eigen.SparseMatrix (
    -- * SparseMatrix type
    SparseMatrix(..),
    SparseMatrixXf,
    SparseMatrixXd,
    SparseMatrixXcf,
    SparseMatrixXcd,
    -- * Matrix internal data
    values,
    innerIndices,
    outerStarts,
    innerNNZs,
    -- * Accessing matrix data
    cols,
    rows,
    coeff,
    (!),
    -- * Matrix conversions
    fromList,
    toList,
    fromVector,
    toVector,
    fromDenseList,
    toDenseList,
    fromMatrix,
    toMatrix,
    -- * Matrix properties
    norm,
    squaredNorm,
    blueNorm,
    block,
    nonZeros,
    innerSize,
    outerSize,
    -- * Basic matrix algebra
    add,
    sub,
    mul,
    -- * Matrix transformations
    pruned,
    scale,
    transpose,
    adjoint,
    -- * Matrix representation
    compress,
    uncompress,
    compressed,
    -- * Matrix serialization
    encode,
    decode,
    -- * Mutable matricies
    thaw,
    freeze,
    unsafeThaw,
    unsafeFreeze,
) where

import qualified Prelude as P
import Prelude hiding (map)
import qualified Data.List as L
import Data.Complex
import Data.Binary hiding (encode, decode)
import qualified Data.Binary as B
import Foreign.C.Types
import Foreign.C.String
import Foreign.Storable
import Foreign.Ptr
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Control.Monad
#if __GLASGOW_HASKELL__ >= 710
#else
import Control.Applicative
#endif
import qualified Data.Eigen.Matrix as M
import qualified Data.Eigen.Matrix.Mutable as MM
import qualified Data.Eigen.SparseMatrix.Mutable as SMM
import qualified Foreign.Concurrent as FC
import qualified Data.Eigen.Internal as I
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Storable.Mutable as VSM
import qualified Data.ByteString.Lazy as BSL

{-| A versatible sparse matrix representation.

SparseMatrix is the main sparse matrix representation of Eigen's sparse module.
It offers high performance and low memory usage.
It implements a more versatile variant of the widely-used Compressed Column (or Row) Storage scheme.

It consists of four compact arrays:

* `values`: stores the coefficient values of the non-zeros.
* `innerIndices`: stores the row (resp. column) indices of the non-zeros.
* `outerStarts`: stores for each column (resp. row) the index of the first non-zero in the previous two arrays.
* `innerNNZs`: stores the number of non-zeros of each column (resp. row). The word inner refers to an inner vector that is a column for a column-major matrix, or a row for a row-major matrix. The word outer refers to the other direction.

This storage scheme is better explained on an example. The following matrix

@
0   3   0   0   0
22  0   0   0   17
7   5   0   1   0
0   0   0   0   0
0   0   14  0   8
@

and one of its possible sparse, __column major__ representation:

@
values:         22  7   _   3   5   14  _   _   1   _   17  8
innerIndices:   1   2   _   0   2   4   _   _   2   _   1   4
outerStarts:    0   3   5   8   10  12
innerNNZs:      2   2   1   1   2
@

Currently the elements of a given inner vector are guaranteed to be always sorted by increasing inner indices.
The "\_" indicates available free space to quickly insert new elements. Assuming no reallocation is needed,
the insertion of a random element is therefore in @O(nnz_j)@ where @nnz_j@ is the number of nonzeros of the
respective inner vector. On the other hand, inserting elements with increasing inner indices in a given inner
vector is much more efficient since this only requires to increase the respective `innerNNZs` entry that is a @O(1)@ operation.

The case where no empty space is available is a special case, and is refered as the compressed mode.
It corresponds to the widely used Compressed Column (or Row) Storage schemes (CCS or CRS).
Any `SparseMatrix` can be turned to this form by calling the `compress` function.
In this case, one can remark that the `innerNNZs` array is redundant with `outerStarts` because we the equality:
@InnerNNZs[j] = OuterStarts[j+1]-OuterStarts[j]@. Therefore, in practice a call to `compress` frees this buffer.

The results of Eigen's operations always produces compressed sparse matrices.
On the other hand, the insertion of a new element into a `SparseMatrix` converts this later to the uncompressed mode.

For more infomration please see Eigen <http://eigen.tuxfamily.org/dox/classEigen_1_1SparseMatrix.html documentation page>.
-}

data SparseMatrix a b where
    SparseMatrix :: I.Elem a b => !(ForeignPtr (I.CSparseMatrix a b)) -> SparseMatrix a b

-- | Alias for single precision sparse matrix
type SparseMatrixXf = SparseMatrix Float CFloat
-- | Alias for double precision sparse matrix
type SparseMatrixXd = SparseMatrix Double CDouble
-- | Alias for single previsiom sparse matrix of complex numbers
type SparseMatrixXcf = SparseMatrix (Complex Float) (I.CComplex CFloat)
-- | Alias for double prevision sparse matrix of complex numbers
type SparseMatrixXcd = SparseMatrix (Complex Double) (I.CComplex CDouble)

-- | Pretty prints the sparse matrix
instance (I.Elem a b, Show a) => Show (SparseMatrix a b) where
    show m = concat [
        "SparseMatrix ", show (rows m), "x", show (cols m),
        "\n", L.intercalate "\n" $ P.map (L.intercalate "\t" . P.map show) $ toDenseList m, "\n"]

-- | Basic sparse matrix math exposed through Num instance: @(*)@, @(+)@, @(-)@, `fromInteger`, `signum`, `abs`, `negate`
instance I.Elem a b => Num (SparseMatrix a b) where
    (*) = mul
    (+) = add
    (-) = sub
    fromInteger x = fromList 1 1 [(0,0,fromInteger x)]
    signum = _map signum
    abs = _map abs
    negate = _map negate

instance I.Elem a b => Binary (SparseMatrix a b) where
    put m = do
        put $ I.magicCode (undefined :: b)
        put $ rows m
        put $ cols m
        put $ toVector m

    get = do
        get >>= (`when` fail "wrong matrix type") . (/= I.magicCode (undefined :: b))
        fromVector <$> get <*> get <*> get

-- | Encode the sparse matrix as a lazy byte string
encode :: I.Elem a b => SparseMatrix a b -> BSL.ByteString
encode = B.encode

-- | Decode sparse matrix from the lazy byte string
decode :: I.Elem a b => BSL.ByteString -> SparseMatrix a b
decode = B.decode

-- | Stores the coefficient values of the non-zeros.
values :: I.Elem a b => SparseMatrix a b -> VS.Vector b
values = _getvec I.sparse_values

-- | Stores the row (resp. column) indices of the non-zeros.
innerIndices :: I.Elem a b => SparseMatrix a b -> VS.Vector CInt
innerIndices = _getvec I.sparse_innerIndices

-- | Stores for each column (resp. row) the index of the first non-zero in the previous two arrays.
outerStarts :: I.Elem a b => SparseMatrix a b -> VS.Vector CInt
outerStarts = _getvec I.sparse_outerStarts

-- | Stores the number of non-zeros of each column (resp. row).
-- The word inner refers to an inner vector that is a column for a column-major matrix, or a row for a row-major matrix.
-- The word outer refers to the other direction
innerNNZs :: I.Elem a b => SparseMatrix a b -> Maybe (VS.Vector CInt)
innerNNZs m
    | compressed m = Nothing
    | otherwise = Just $ _getvec I.sparse_innerNNZs m

-- | Number of rows for the sparse matrix
rows :: I.Elem a b => SparseMatrix a b -> Int
rows = _unop I.sparse_rows (return . I.cast)

-- | Number of columns for the sparse matrix
cols :: I.Elem a b => SparseMatrix a b -> Int
cols = _unop I.sparse_cols (return . I.cast)

-- | Matrix coefficient at given row and col
coeff :: I.Elem a b => Int -> Int -> SparseMatrix a b -> a
coeff row col (SparseMatrix fp) = I.performIO $ withForeignPtr fp $ \p -> alloca $ \pq -> do
    I.call $ I.sparse_coeff p (I.cast row) (I.cast col) pq
    I.cast <$> peek pq

-- | Matrix coefficient at given row and col
(!) :: I.Elem a b => SparseMatrix a b -> (Int, Int) -> a
(!) m (row, col) = coeff row col m

{-| For vectors, the l2 norm, and for matrices the Frobenius norm.
    In both cases, it consists in the square root of the sum of the square of all the matrix entries.
    For vectors, this is also equals to the square root of the dot product of this with itself.
-}
norm :: I.Elem a b => SparseMatrix a b -> a
norm = _unop I.sparse_norm (return . I.cast)

-- | For vectors, the squared l2 norm, and for matrices the Frobenius norm. In both cases, it consists in the sum of the square of all the matrix entries. For vectors, this is also equals to the dot product of this with itself.
squaredNorm :: I.Elem a b => SparseMatrix a b -> a
squaredNorm = _unop I.sparse_squaredNorm (return . I.cast)

-- | The l2 norm of the matrix using the Blue's algorithm. A Portable Fortran Program to Find the Euclidean Norm of a Vector, ACM TOMS, Vol 4, Issue 1, 1978.
blueNorm :: I.Elem a b => SparseMatrix a b -> a
blueNorm = _unop I.sparse_blueNorm (return . I.cast)

-- | Extract rectangular block from sparse matrix defined by startRow startCol blockRows blockCols
block :: I.Elem a b => Int -> Int -> Int -> Int -> SparseMatrix a b -> SparseMatrix a b
block row col rows cols = _unop (\p pq -> I.sparse_block p (I.cast row) (I.cast col) (I.cast rows) (I.cast cols) pq) _mk

-- | Number of non-zeros elements in the sparse matrix
nonZeros :: I.Elem a b => SparseMatrix a b -> Int
nonZeros = _unop I.sparse_nonZeros (return . I.cast)

-- | The matrix in the compressed format
compress :: I.Elem a b => SparseMatrix a b -> SparseMatrix a b
compress = _unop I.sparse_makeCompressed _mk

-- | The matrix in the uncompressed mode
uncompress :: I.Elem a b => SparseMatrix a b -> SparseMatrix a b
uncompress = _unop I.sparse_uncompress _mk

-- | Is this in compressed form?
compressed :: I.Elem a b => SparseMatrix a b -> Bool
compressed = _unop I.sparse_isCompressed (return . (/=0))

-- | Minor dimension with respect to the storage order
innerSize :: I.Elem a b => SparseMatrix a b -> Int
innerSize = _unop I.sparse_innerSize (return . I.cast)

-- | Major dimension with respect to the storage order
outerSize :: I.Elem a b => SparseMatrix a b -> Int
outerSize = _unop I.sparse_outerSize (return . I.cast)

-- | Suppresses all nonzeros which are much smaller than reference under the tolerence @epsilon@
pruned :: I.Elem a b => a -> SparseMatrix a b -> SparseMatrix a b
pruned r = _unop (\p pq -> alloca $ \pr -> poke pr (I.cast r) >> I.sparse_prunedRef p pr pq) _mk

-- | Multiply matrix on a given scalar
scale :: I.Elem a b => a -> SparseMatrix a b -> SparseMatrix a b
scale x = _unop (\p pq -> alloca $ \px -> poke px (I.cast x) >> I.sparse_scale p px pq) _mk

-- | Transpose of the sparse matrix
transpose :: I.Elem a b => SparseMatrix a b -> SparseMatrix a b
transpose = _unop I.sparse_transpose _mk

-- | Adjoint of the sparse matrix
adjoint :: I.Elem a b => SparseMatrix a b -> SparseMatrix a b
adjoint = _unop I.sparse_adjoint _mk

-- | Adding two sparse matrices by adding the corresponding entries together. You can use @(+)@ function as well.
add :: I.Elem a b => SparseMatrix a b -> SparseMatrix a b -> SparseMatrix a b
add = _binop I.sparse_add _mk

-- | Subtracting two sparse matrices by subtracting the corresponding entries together. You can use @(-)@ function as well.
sub :: I.Elem a b => SparseMatrix a b -> SparseMatrix a b -> SparseMatrix a b
sub = _binop I.sparse_sub _mk

-- | Matrix multiplication. You can use @(*)@ function as well.
mul :: I.Elem a b => SparseMatrix a b -> SparseMatrix a b -> SparseMatrix a b
mul = _binop I.sparse_mul _mk

-- | Construct sparse matrix of given size from the list of triplets (row, col, val)
fromList :: I.Elem a b => Int -> Int -> [(Int, Int, a)] -> SparseMatrix a b
fromList rows cols = fromVector rows cols . VS.fromList . P.map I.cast

-- | Construct sparse matrix of given size from the storable vector of triplets (row, col, val)
fromVector :: I.Elem a b => Int -> Int -> VS.Vector (I.CTriplet b) -> SparseMatrix a b
fromVector rows cols tris = I.performIO $ VS.unsafeWith tris $ \p -> alloca $ \pq -> do
    I.call $ I.sparse_fromList (I.cast rows) (I.cast cols) p (I.cast $ VS.length tris) pq
    peek pq >>= _mk

-- | Convert sparse matrix to the list of triplets (row, col, val). Compressed elements will not be included
toList :: I.Elem a b => SparseMatrix a b -> [(Int, Int, a)]
toList = P.map I.cast . VS.toList . toVector

-- | Convert sparse matrix to the storable vector of triplets (row, col, val). Compressed elements will not be included
toVector :: I.Elem a b => SparseMatrix a b -> VS.Vector (I.CTriplet b)
toVector m@(SparseMatrix fp) = I.performIO $ do
    let size = nonZeros m
    tris <- VSM.new size
    withForeignPtr fp $ \p ->
        VSM.unsafeWith tris $ \q ->
            I.call $ I.sparse_toList p q (I.cast size)
    VS.unsafeFreeze tris

-- | Construct sparse matrix of two-dimensional list of values. Matrix dimensions will be detected automatically. Zero values will be compressed.
fromDenseList :: (I.Elem a b, Eq a) => [[a]] -> SparseMatrix a b
fromDenseList list = fromList rows cols $ do
    (row, vals) <- zip [0..] list
    (col, val) <- zip [0..] vals
    guard $ val /= 0
    return (row, col, val)
    where
        rows = length list
        cols = L.foldl' max 0 $ P.map length list

-- | Convert sparse matrix to (rows X cols) dense list of values
toDenseList :: I.Elem a b => SparseMatrix a b -> [[a]]
toDenseList m = [[coeff row col m | col <- [0 .. cols m - 1]] | row <- [0 .. rows m - 1]]

-- | Construct sparse matrix from dense matrix. Zero elements will be compressed
fromMatrix :: I.Elem a b => M.Matrix a b -> SparseMatrix a b
fromMatrix m1 = I.performIO $ alloca $ \pm0 ->
    M.unsafeWith m1 $ \vals rows cols -> do
        I.call $ I.sparse_fromMatrix vals rows cols pm0
        peek pm0 >>= _mk

-- | Construct dense matrix from sparse matrix
toMatrix :: I.Elem a b => SparseMatrix a b -> M.Matrix a b
toMatrix m1@(SparseMatrix fp) = I.performIO $ do
    m0 <- MM.new (rows m1) (cols m1)
    MM.unsafeWith m0 $ \vals rows cols ->
        withForeignPtr fp $ \pm1 ->
            I.call $ I.sparse_toMatrix pm1 vals rows cols
    M.unsafeFreeze m0

-- | Yield an immutable copy of the mutable matrix
freeze :: I.Elem a b => SMM.IOSparseMatrix a b -> IO (SparseMatrix a b)
freeze (SMM.IOSparseMatrix fp) = SparseMatrix <$> _clone fp

-- | Yield a mutable copy of the immutable matrix
thaw :: I.Elem a b => SparseMatrix a b -> IO (SMM.IOSparseMatrix a b)
thaw (SparseMatrix fp) = SMM.IOSparseMatrix <$> _clone fp

-- | Unsafe convert a mutable matrix to an immutable one without copying. The mutable matrix may not be used after this operation.
unsafeFreeze :: I.Elem a b => SMM.IOSparseMatrix a b -> IO (SparseMatrix a b)
unsafeFreeze (SMM.IOSparseMatrix fp) = return $! SparseMatrix fp

-- | Unsafely convert an immutable matrix to a mutable one without copying. The immutable matrix may not be used after this operation.
unsafeThaw :: I.Elem a b => SparseMatrix a b -> IO (SMM.IOSparseMatrix a b)
unsafeThaw (SparseMatrix fp) = return $! SMM.IOSparseMatrix fp

_unop :: Storable c => (I.CSparseMatrixPtr a b -> Ptr c -> IO CString) -> (c -> IO d) -> SparseMatrix a b -> d
_unop f g (SparseMatrix fp) = I.performIO $
    withForeignPtr fp $ \p ->
        alloca $ \pq -> do
            I.call (f p pq)
            peek pq >>= g

_binop :: Storable c => (I.CSparseMatrixPtr a b -> I.CSparseMatrixPtr a b -> Ptr c -> IO CString) -> (c -> IO d) -> SparseMatrix a b -> SparseMatrix a b -> d
_binop f g (SparseMatrix fp1) (SparseMatrix fp2) = I.performIO $
    withForeignPtr fp1 $ \p1 ->
        withForeignPtr fp2 $ \p2 ->
            alloca $ \pq -> do
                I.call (f p1 p2 pq)
                peek pq >>= g

_getvec :: (I.Elem a b, Storable c) => (Ptr (I.CSparseMatrix a b) -> Ptr CInt -> Ptr (Ptr c) -> IO CString) -> SparseMatrix a b -> VS.Vector c
_getvec f (SparseMatrix fm) = I.performIO $
    withForeignPtr fm $ \m ->
    alloca $ \ps ->
    alloca $ \pq -> do
        I.call $ f m ps pq
        s <- fromIntegral <$> peek ps
        q <- peek pq
        fr <- FC.newForeignPtr q $ touchForeignPtr fm
        return $! VS.unsafeFromForeignPtr0 fr s

_clone :: I.Elem a b => ForeignPtr (I.CSparseMatrix a b) -> IO (ForeignPtr (I.CSparseMatrix a b))
_clone fp = withForeignPtr fp $ \p -> alloca $ \pq -> do
    I.call $ I.sparse_clone p pq
    q <- peek pq
    FC.newForeignPtr q $ I.call $ I.sparse_free q

_map :: I.Elem a b => (a -> a) -> SparseMatrix a b -> SparseMatrix a b
_map f m = fromVector (rows m) (cols m) . VS.map g . toVector $ m where
    g (I.CTriplet r c v) = I.CTriplet r c $ I.cast $ f $ I.cast v

_mk :: I.Elem a b => Ptr (I.CSparseMatrix a b) -> IO (SparseMatrix a b)
_mk p = SparseMatrix <$> FC.newForeignPtr p (I.call $ I.sparse_free p)


{-# LANGUAGE FlexibleContexts #-}

module Main (main) where

import Control.Monad.IO.Class (liftIO)
import Data.Complex (Complex)
import Data.Foldable (toList)
import Text.PrettyPrint.Mainland
import Text.PrettyPrint.Mainland.Class

import Spiral
import Spiral.Backend.C
import Spiral.Config
import Spiral.Driver
import Spiral.Exp
import Spiral.OpCount
import Spiral.Program
import Spiral.RootOfUnity
import Spiral.SPL
import Spiral.SPL.Run
import Spiral.Util.Uniq

main :: IO ()
main = defaultMain $ \args -> do
    useComplexType <- asksConfig $ testDynFlag UseComplex
    n <- case args of
           [s] -> return (read s)
           _   -> return 4
    let f = formula n
    pprint f
    if useComplexType
      then toProgram "f" f >>= go
      else toProgram "f" (Re f) >>= go
  where
    go :: (Typed a, Num (Exp a)) => Program a -> Spiral ()
    go prog = do
      pprint prog
      ops <- countProgramOps prog
      resetUnique
      defs <- evalCg $ cgProgram prog
      outp <- asksConfig output
      case outp of
        Nothing -> return ()
        Just{}  -> writeOutput (toList defs)
      liftIO $ putDocLn $
          text "Multiplications:" <+> ppr (mulOps ops) </>
          text "      Additions:" <+> ppr (addOps ops) </>
          text "          Total:" <+> ppr (allOps ops)

-- The SPL formula for which we generate code and count operations.
formula :: Int -> SPL (Exp (Complex Double))
formula _ =
    Pi (L 8 4) ×
    (I 2 ⊗ (Pi (L 4 2) × (I 2 ⊗ F 2 w2) × diag [1.0, 1.0, 1.0, w4] × (F 2 w2 ⊗ I 2))) ×
    diag [1.0, 1.0, 1.0, 1.0, 1.0, w8, w4, w8^(3 :: Int)] ×
    (F 2 w2 ⊗ I 4)
  where
    w2, w4, w8 :: Exp (Complex Double)
    w2 = omega 2
    w4 = omega 4
    w8 = omega 8


{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if __GLASGOW_HASKELL__ >= 800
  {-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif
-- |
-- Module      : Graphics.Image.Interface.Elevator
-- Copyright   : (c) Alexey Kuleshevich 2017
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Image.Interface.Elevator (
  Elevator(..)
  , clamp01
  ) where

import qualified Data.Complex        as C
import           Data.Int
import           Data.Typeable
import           Data.Vector.Unboxed (Unbox)
import           Data.Word
import           GHC.Float

-- | A class with a set of convenient functions that allow for changing precision of
-- channels within pixels, while scaling the values to keep them in an appropriate range.
--
-- >>> let rgb = PixelRGB 0.0 0.5 1.0 :: Pixel RGB Double
-- >>> toWord8 <$> rgb
-- <RGB:(0|128|255)>
-- >>> toWord16 <$> rgb
-- <RGB:(0|32768|65535)>
--
class (Eq e, Num e, Typeable e, Unbox e) => Elevator e where

  -- | Values are scaled to @[0, 255]@ range.
  toWord8 :: e -> Word8

  -- | Values are scaled to @[0, 65535]@ range.
  toWord16 :: e -> Word16

  -- | Values are scaled to @[0, 4294967295]@ range.
  toWord32 :: e -> Word32

  -- | Values are scaled to @[0, 18446744073709551615]@ range.
  toWord64 :: e -> Word64

  -- | Values are scaled to @[0.0, 1.0]@ range.
  toFloat :: e -> Float

  -- | Values are scaled to @[0.0, 1.0]@ range.
  toDouble :: e -> Double

  -- | Values are scaled from @[0.0, 1.0]@ range.
  fromDouble :: Double -> e

-- | Lower the precision
dropDown :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b
dropDown !e = fromIntegral $ fromIntegral e `div` ((maxBound :: a) `div`
                                                   fromIntegral (maxBound :: b))
{-# INLINE dropDown #-}

-- | Increase the precision
raiseUp :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b
raiseUp !e = fromIntegral e * ((maxBound :: b) `div` fromIntegral (maxBound :: a))
{-# INLINE raiseUp #-}

-- | Convert to fractional with value less than or equal to 1.
squashTo1 :: forall a b. (Fractional b, Integral a, Bounded a) => a -> b
squashTo1 !e = fromIntegral e / fromIntegral (maxBound :: a)
{-# INLINE squashTo1 #-}

-- | Convert to integral streaching it's value up to a maximum value.
stretch :: forall a b. (RealFrac a, Floating a, Integral b, Bounded b) => a -> b
stretch !e = round (fromIntegral (maxBound :: b) * clamp01 e)
{-# INLINE stretch #-}

-- | Clamp a value to @[0, 1]@ range.
clamp01 :: (Ord a, Floating a) => a -> a
clamp01 !x = min (max 0 x) 1
{-# INLINE clamp01 #-}

-- | Values between @[0, 255]]@
instance Elevator Word8 where
  toWord8 = id
  {-# INLINE toWord8 #-}
  toWord16 = raiseUp
  {-# INLINE toWord16 #-}
  toWord32 = raiseUp
  {-# INLINE toWord32 #-}
  toWord64 = raiseUp
  {-# INLINE toWord64 #-}
  toFloat = squashTo1
  {-# INLINE toFloat #-}
  toDouble = squashTo1
  {-# INLINE toDouble #-}
  fromDouble = toWord8
  {-# INLINE fromDouble #-}

-- | Values between @[0, 65535]]@
instance Elevator Word16 where
  toWord8 = dropDown
  {-# INLINE toWord8 #-}
  toWord16 = id
  {-# INLINE toWord16 #-}
  toWord32 = raiseUp
  {-# INLINE toWord32 #-}
  toWord64 = raiseUp
  {-# INLINE toWord64 #-}
  toFloat = squashTo1
  {-# INLINE toFloat #-}
  toDouble = squashTo1
  {-# INLINE toDouble #-}
  fromDouble = toWord16
  {-# INLINE fromDouble #-}

-- | Values between @[0, 4294967295]@
instance Elevator Word32 where
  toWord8 = dropDown
  {-# INLINE toWord8 #-}
  toWord16 = dropDown
  {-# INLINE toWord16 #-}
  toWord32 = id
  {-# INLINE toWord32 #-}
  toWord64 = raiseUp
  {-# INLINE toWord64 #-}
  toFloat = squashTo1
  {-# INLINE toFloat #-}
  toDouble = squashTo1
  {-# INLINE toDouble #-}
  fromDouble = toWord32
  {-# INLINE fromDouble #-}

-- | Values between @[0, 18446744073709551615]@
instance Elevator Word64 where
  toWord8 = dropDown
  {-# INLINE toWord8 #-}
  toWord16 = dropDown
  {-# INLINE toWord16 #-}
  toWord32 = dropDown
  {-# INLINE toWord32 #-}
  toWord64 = id
  {-# INLINE toWord64 #-}
  toFloat = squashTo1
  {-# INLINE toFloat #-}
  toDouble = squashTo1
  {-# INLINE toDouble #-}
  fromDouble = toWord64
  {-# INLINE fromDouble #-}

-- | Values between @[0, 18446744073709551615]@ on 64bit
instance Elevator Word where
  toWord8 = dropDown
  {-# INLINE toWord8 #-}
  toWord16 = dropDown
  {-# INLINE toWord16 #-}
  toWord32 = dropDown
  {-# INLINE toWord32 #-}
  toWord64 = fromIntegral
  {-# INLINE toWord64 #-}
  toFloat = squashTo1
  {-# INLINE toFloat #-}
  toDouble = squashTo1
  {-# INLINE toDouble #-}
  fromDouble = stretch . clamp01
  {-# INLINE fromDouble #-}

-- | Values between @[0, 127]@
instance Elevator Int8 where
  toWord8 = fromIntegral . (max 0)
  {-# INLINE toWord8 #-}
  toWord16 = raiseUp . (max 0)
  {-# INLINE toWord16 #-}
  toWord32 = raiseUp . (max 0)
  {-# INLINE toWord32 #-}
  toWord64 = raiseUp . (max 0)
  {-# INLINE toWord64 #-}
  toFloat = squashTo1 . (max 0)
  {-# INLINE toFloat #-}
  toDouble = squashTo1 . (max 0)
  {-# INLINE toDouble #-}
  fromDouble = stretch . clamp01
  {-# INLINE fromDouble #-}

-- | Values between @[0, 32767]@
instance Elevator Int16 where
  toWord8 = dropDown . (max 0)
  {-# INLINE toWord8 #-}
  toWord16 = fromIntegral . (max 0)
  {-# INLINE toWord16 #-}
  toWord32 = raiseUp . (max 0)
  {-# INLINE toWord32 #-}
  toWord64 = raiseUp . (max 0)
  {-# INLINE toWord64 #-}
  toFloat = squashTo1 . (max 0)
  {-# INLINE toFloat #-}
  toDouble = squashTo1 . (max 0)
  {-# INLINE toDouble #-}
  fromDouble = stretch . clamp01
  {-# INLINE fromDouble #-}

-- | Values between @[0, 2147483647]@
instance Elevator Int32 where
  toWord8 = dropDown . (max 0)
  {-# INLINE toWord8 #-}
  toWord16 = dropDown . (max 0)
  {-# INLINE toWord16 #-}
  toWord32 = fromIntegral . (max 0)
  {-# INLINE toWord32 #-}
  toWord64 = raiseUp . (max 0)
  {-# INLINE toWord64 #-}
  toFloat = squashTo1 . (max 0)
  {-# INLINE toFloat #-}
  toDouble = squashTo1 . (max 0)
  {-# INLINE toDouble #-}
  fromDouble = stretch . clamp01
  {-# INLINE fromDouble #-}

-- | Values between @[0, 9223372036854775807]@
instance Elevator Int64 where
  toWord8 = dropDown . (max 0)
  {-# INLINE toWord8 #-}
  toWord16 = dropDown . (max 0)
  {-# INLINE toWord16 #-}
  toWord32 = dropDown . (max 0)
  {-# INLINE toWord32 #-}
  toWord64 = fromIntegral . (max 0)
  {-# INLINE toWord64 #-}
  toFloat = squashTo1 . (max 0)
  {-# INLINE toFloat #-}
  toDouble = squashTo1 . (max 0)
  {-# INLINE toDouble #-}
  fromDouble = stretch . clamp01
  {-# INLINE fromDouble #-}

-- | Values between @[0, 9223372036854775807]@ on 64bit
instance Elevator Int where
  toWord8 = dropDown . (max 0)
  {-# INLINE toWord8 #-}
  toWord16 = dropDown . (max 0)
  {-# INLINE toWord16 #-}
  toWord32 = dropDown . (max 0)
  {-# INLINE toWord32 #-}
  toWord64 = fromIntegral . (max 0)
  {-# INLINE toWord64 #-}
  toFloat = squashTo1 . (max 0)
  {-# INLINE toFloat #-}
  toDouble = squashTo1 . (max 0)
  {-# INLINE toDouble #-}
  fromDouble = stretch . clamp01
  {-# INLINE fromDouble #-}

-- | Values between @[0.0, 1.0]@
instance Elevator Float where
  toWord8 = stretch . clamp01
  {-# INLINE toWord8 #-}
  toWord16 = stretch . clamp01
  {-# INLINE toWord16 #-}
  toWord32 = stretch . clamp01
  {-# INLINE toWord32 #-}
  toWord64 = stretch . clamp01
  {-# INLINE toWord64 #-}
  toFloat = id
  {-# INLINE toFloat #-}
  toDouble = float2Double
  {-# INLINE toDouble #-}
  fromDouble = toFloat
  {-# INLINE fromDouble #-}

-- | Values between @[0.0, 1.0]@
instance Elevator Double where
  toWord8 = stretch . clamp01
  {-# INLINE toWord8 #-}
  toWord16 = stretch . clamp01
  {-# INLINE toWord16 #-}
  toWord32 = stretch . clamp01
  {-# INLINE toWord32 #-}
  toWord64 = stretch . clamp01
  {-# INLINE toWord64 #-}
  toFloat = double2Float
  {-# INLINE toFloat #-}
  toDouble = id
  {-# INLINE toDouble #-}
  fromDouble = id
  {-# INLINE fromDouble #-}

-- | Discards imaginary part and changes precision of real part.
instance (Num e, Elevator e, RealFloat e) => Elevator (C.Complex e) where
  toWord8 = toWord8 . C.realPart
  {-# INLINE toWord8 #-}
  toWord16 = toWord16 . C.realPart
  {-# INLINE toWord16 #-}
  toWord32 = toWord32 . C.realPart
  {-# INLINE toWord32 #-}
  toWord64 = toWord64 . C.realPart
  {-# INLINE toWord64 #-}
  toFloat = toFloat . C.realPart
  {-# INLINE toFloat #-}
  toDouble = toDouble . C.realPart
  {-# INLINE toDouble #-}
  fromDouble = (C.:+ 0) . fromDouble
  {-# INLINE fromDouble #-}


{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE KindSignatures         #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeOperators          #-}

module Numeric.Optimization.TwoPhase.Tableau.Build
    ( IsBuilder
    , mkTable
    ) where

import           Prelude hiding                             ((++))

import qualified Data.List as List
import           Data.Maybe                                 (fromJust)
import qualified Data.Vector.Sized as Vec
import           Data.Vector.Storable.Sized                 (Vector, (++))
import qualified Data.Vector.Storable.Sized as SVec
import           GHC.TypeLits
import           Numeric.LinearAlgebra.Static               (L)
import qualified Numeric.LinearAlgebra.Static as LS
import qualified Numeric.LinearAlgebra.Static.Vector as LS

import           Numeric.Optimization.Problem
import           Numeric.Optimization.TwoPhase.Types

type IsBuilder v s a c =
    ( KnownNat v
    , KnownNat s
    , KnownNat a
    , KnownNat c
    )

data Builder (v :: Nat) (s :: Nat) (a :: Nat) (c :: Nat) = Builder
    { slackSupply       :: [Vector s Double]
    , artificialSupply  :: [Vector a Double]
    , rowsBuilt         :: [Vector (Cols 'PhaseI v s a) Double]
    , adjustmentsBuilt  :: [Vector (Cols 'PhaseI v s a) Double]
    }

mkBuilder :: (IsBuilder v s a c) => Builder v s a c
mkBuilder = Builder slackI artificialI [] []
  where
    slackI      = reverse . fmap LS.rVec . LS.toRows $ LS.eye
    artificialI = reverse . fmap LS.rVec . LS.toRows $ LS.eye

buildPhaseI
    :: forall v s a c.
        (IsBuilder v s a c)
    => Builder v s a c
    -> Builder v s a c
buildPhaseI acc = acc
    { rowsBuilt = row : rowsBuilt acc }
  where
    row = SVec.snoc (os ++ xs ++ ss ++ as) 0
    os  = SVec.fromTuple (1, 0)
    xs  = SVec.replicate @v 0
    ss  = SVec.replicate @s 0
    as  = SVec.replicate @a (-1)

buildPhaseII
    :: forall v s a c.
        (IsBuilder v s a c)
    => Builder v s a c
    -> Coeffs v
    -> Builder v s a c
buildPhaseII acc xs' = acc
    { rowsBuilt = row : rowsBuilt acc }
  where
    row = SVec.snoc (os ++ xs ++ ss ++ as) 0
    os  = SVec.fromTuple (0, 1)
    xs  = SVec.map negate xs'
    ss  = SVec.replicate @s 0
    as  = SVec.replicate @a 0

buildObjective :: (IsBuilder v s a c)
    => Builder v s a c -> Coeffs v -> Builder v s a c
buildObjective acc = buildPhaseI . buildPhaseII acc

buildLEQ
    :: forall v s a c.
        (IsBuilder v s a c)
    => Builder v s a c
    -> Coeffs v
    -> Double
    -> Builder v s a c
buildLEQ acc xs rhs = acc
    { slackSupply   = tail (slackSupply acc)
    , rowsBuilt     = row : rowsBuilt acc
    }
  where
    row = SVec.snoc (os ++ xs ++ ss ++ as) rhs
    os  = SVec.fromTuple (0, 0)
    ss  = head (slackSupply acc)
    as  = SVec.replicate @a 0

buildGEQ
    :: forall v s a c.
        (IsBuilder v s a c)
    => Builder v s a c
    -> Coeffs v
    -> Double
    -> Builder v s a c
buildGEQ acc xs' rhs' = acc
    { slackSupply       = tail (slackSupply acc)
    , artificialSupply  = tail (artificialSupply acc)
    , rowsBuilt         = row : rowsBuilt acc
    }
  where
    row = SVec.snoc (os ++ xs ++ ss ++ as) rhs
    os  = SVec.fromTuple (0, 0)
    xs  = SVec.map negate xs'
    ss  = head (slackSupply acc)
    as  = head (artificialSupply acc)
    rhs = negate rhs'

buildEQU
    :: forall v s a c.
        (IsBuilder v s a c)
    => Builder v s a c
    -> Coeffs v
    -> Double
    -> Builder v s a c
buildEQU acc xs rhs = acc
    { artificialSupply  = tail (artificialSupply acc)
    , rowsBuilt         = row : rowsBuilt acc
    , adjustmentsBuilt  = row : adjustmentsBuilt acc
    }
  where
    row = SVec.snoc (os ++ xs ++ ss ++ as) rhs
    os  = SVec.fromTuple (0, 0)
    ss  = SVec.replicate @s 0
    as  = head (artificialSupply acc)

buildConstraint :: (IsBuilder v s a c)
    => Builder v s a c -> Constraint v x y -> Builder v s a c
buildConstraint acc (xs :< y) = buildLEQ acc xs y
buildConstraint acc (xs :> y) = buildGEQ acc xs y
buildConstraint acc (xs := y) = buildEQU acc xs y

toMatrix :: forall v s a c. (IsBuilder v s a c)
    => Builder v s a c -> L (Rows 'PhaseI c) (Cols 'PhaseI v s a)
toMatrix acc =
    LS.rowsL . fromJust . Vec.fromList $ fmap LS.vecR adjusted
  where
    rows    = rowsBuilt acc
    adjusts = adjustmentsBuilt acc

    adjusted = case adjusts of
        [] -> rows
        xs ->
            let oldObjP1  = head rows
                newObjP1  = List.foldl1' (SVec.zipWith (+)) (oldObjP1 : xs)
            in  newObjP1 : tail rows

mkTable :: forall d v s a c. (IsBuilder v s a c)
    => Problem d v s a c -> L (Rows 'PhaseI c) (Cols 'PhaseI v s a)
mkTable = toMatrix . go mkBuilder
  where
    go :: Builder v s a c -> Problem d v x y z -> Builder v s a c
    go acc (Maximize xs)    = buildObjective acc xs
    go acc (Minimize xs)    = buildObjective acc xs
    go acc (SuchThat p c)   = go (buildConstraint acc c) p


{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeOperators       #-}

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Test.Grenade.Layers.Internal.Transpose where

import           Grenade.Layers.Internal.Transpose

import           Numeric.LinearAlgebra                  hiding (konst,
                                                         uniformSample, (===))

import           Hedgehog

prop_transpose4d_behaves_as_reference_swap_three_axis = withTests 1 $ property $ do
  let input           = (12 >< 4) [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47 ]
      perms           = vector [2, 0, 1, 3]
      dims            = [2, 2, 3, 4]
      expected_output = (12 >< 4) [ 0, 1, 2, 3, 12, 13, 14, 15, 24, 25, 26, 27, 36, 37, 38, 39, 4, 5, 6, 7, 16, 17, 18, 19, 28, 29, 30, 31, 40, 41, 42, 43, 8, 9, 10, 11, 20, 21, 22, 23, 32, 33, 34, 35, 44, 45, 46, 47 ]

      output = transpose4d dims perms input

  output === expected_output

prop_same_pad_pool_behaves_correctly_at_edges_three_channels = withTests 1 $ property $ do
  let input           = (12 >< 4) [ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47 ]
      perms           = vector [3, 2, 1, 0]
      dims            = [2, 2, 3, 4]
      expected_output = (24 >< 2) [ 0, 24, 12, 36, 4, 28, 16, 40, 8, 32, 20, 44, 1, 25, 13, 37, 5, 29, 17, 41, 9, 33, 21, 45, 2, 26, 14, 38, 6, 30, 18, 42, 10, 34, 22, 46, 3, 27, 15, 39, 7, 31, 19, 43, 11, 35, 23, 47 ]

      output = transpose4d dims perms input

  output === expected_output

tests :: IO Bool
tests = checkParallel $$(discover)


module LispTypes where

import Data.Ratio
import Data.Complex
import Data.Array
import Data.IORef

import Numeric
import Text.ParserCombinators.Parsec.Error
import Control.Monad.Except
import System.IO

-- Env is a stateful variable (IORef) that holds a map of strings -> IORef LispVal
type Env = IORef[(String, IORef LispVal)]

-- |Lisp Atom data type
data LispVal = Atom String -- Simple Types
    | Number Integer
    | Float Double
    | String String
    | Character Char
    | Bool Bool
    | Ratio Rational -- Composite types
    | Complex (Complex Double)
    | List [LispVal]
    | DottedList [LispVal] LispVal
    | Vector (Array Int LispVal)
    -- Stores a primitive function
    | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
    -- Generalized function type
    | Func {
        params :: [String], -- Parameters name
        vararg :: Maybe String, -- name of a variable-length argument list
        body :: [LispVal], -- list of expressions
        closure :: Env -- the environment where the function was created
        }
    | IOFunc ([LispVal] -> IOThrowsError LispVal) -- A dirty function that performs IO
    | Port Handle -- Represents input and output devices

-- Defining Equality methods for LispVal
instance Eq LispVal where
    (==) (Number x)         (Number y)  = x == y
    (==) (Float x)          (Float y)   = x == y
    (==) (String x)         (String y)  = x == y
    (==) (Bool x)           (Bool y)    = x == y
    (==) (Ratio x)          (Ratio y)   = x == y
    (==) (Complex x)        (Complex y) = x == y
    (==) (DottedList xs x)  (DottedList ys y) =
        (List $ xs ++ [x]) == (List $ ys ++ [y])
    (==) l1@(List x) l2@(List y) =
        (length x == length y) && all (uncurry (==)) (zip x y)

instance Ord LispVal where
    compare (Number x)      (Number y)  = compare x y
    compare (Float x)       (Float y)   = compare x y
    compare (String x)      (String y)  = compare x y
    compare (Bool x)        (Bool y)    = compare x y
    compare (Ratio x)       (Ratio y)   = compare x y
    -- There is no compare instance for complex numbers since it violates trichotomy
    -- https://math.stackexchange.com/questions/257184/defining-the-complex-numbers/257208#257208
    compare (Complex x)     (Complex y) = error "Complex numbers do not satisfy the axiom of trichotomy"

    -- |Helper function to show a Double in full precision
showFullPrecision :: Double -> String
showFullPrecision x = showFFloat Nothing x ""

-- |Print the content of a LispVal
-- Pattern matching is used to destructure
-- The algebraic data type selecting a clause
-- Based on constructors
showVal :: LispVal -> String
-- Simple Types
showVal (Atom name) = name
showVal (String s) = "\"" ++ s ++ "\""
showVal (Number n) = show n
showVal (Float f) = showFullPrecision f
showVal (Character '\n') = ""
showVal (Character c) = "#\\" ++ [c]
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"

-- Composite types
showVal (Ratio r) =
    (show . numerator) r ++ "/" ++ (show . denominator) r
showVal (Complex c) = (showFullPrecision. realPart) c
    ++ (if imagPart c >= 0 then "+" else "")
    ++ (showFullPrecision . imagPart) c ++ "i"
showVal (List l) = "(" ++ unwordsList l ++ ")"
showVal (DottedList hd tl) = "(" ++ unwordsList hd ++ " . " ++ showVal tl ++ ")"
showVal v@(Vector x) = "#(" ++ unwordsVector v ++ ")"

-- Show for functions and ports
showVal (PrimitiveFunc _) = "<primitive>"
showVal Func { params = args, vararg = varargs, body = body, closure = env} =
    "(lambda (" ++ unwords args ++
    (case varargs of
        Nothing -> ""
        Just arg -> " . " ++ arg) ++ ") ...)"
showVal (IOFunc _) = "<IO primitive>"
showVal (Port _) = "<IO port>"
-- |Helper function mapping showVal over a Lisp List
-- |Basically unwords for LispVal

{-
 unwordsList is defined in point-free style
 no argument is specified and it is written only in
 terms of function composition and partial application:
 map is partially applied to showVal (creates a fun that
 takes a list of LispVals and returns a list of their
 string representation). Then, it is composed to
 Haskell's unwords which merges strings in a list
 into a single string separated by spaces.

 This is an important example of currying
-}
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal

unwordsVector :: LispVal -> String
unwordsVector (Vector y) = unwords . map showVal $ elems y

-- |Defining the show method for LispVal
-- See https://www.haskell.org/tutorial/classes.html
-- for details on typeclasses
instance Show LispVal where show = showVal

-- ERRORS

{-
    Some interpreted languages like PHP silently assign
    default values like #f or 0 as a result when errors occur
    This approach means that errors pass silently throughout the
    programs until they can become problematic and need long
    debugging sessions to get rid of the bug completely.

    Here, errors are signaled as soon as they happen and
    immediately break out of execution
-}

data LispError = NumArgs Integer [LispVal]
    | DivideByZero
    | TypeMismatch String LispVal
    | Parser ParseError
    | BadSpecialForm String LispVal
    | NotFunction String String
    | UnboundVar String String
    | Default String

-- Make LispError an instance of Show
showError :: LispError -> String
showError (Default msg) = show msg
showError DivideByZero = show "Division by zero!"
showError (TypeMismatch expected found) = "Invalid type: expected "
    ++ expected ++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr
showError (BadSpecialForm msg form) = msg ++ ": " ++ show form
showError (NotFunction msg func) = msg ++ ": " ++ show func
showError (UnboundVar msg varname) = msg ++ ": " ++ varname
showError (NumArgs expected found) = "Expected " ++ show expected
    ++ " args: found values " ++ unwordsList found

instance Show LispError where show = showError

-- |Type to represent functions that may throw a LispError or return a value.

-- Either is only partially applied (curried) to LispError so that ThrowsError
-- can be used with any data type
-- Either is a monad and the "extra information" carried by it is whether or not
-- An error has occured. This is why haskell does not need a separate
-- Control-flow construct to handle exceptions.
-- Either also provides throwError and catchError
type ThrowsError = Either LispError

-- Needs an Error Monad to handle errors like unbound variables
-- ErrorT is a monad transformer that layers error handling on top of IO
-- May contain IO actions and throws a LispError
-- Curried type constructor that still accepts an argument: return type of the function
type IOThrowsError = ExceptT LispError IO

-- |Convert errors to their string representation and return it
-- trapError action
-- The result of calling trapError is an Either action which will
-- always have valid (Right) data.
trapError action = catchError action (return . show)

-- |Extract a value from a ThrowsError type returned by trapError
-- extractValue (Right val) = val
-- extractValue is purposedly left undefined for Left values
extractValue :: ThrowsError a -> a
extractValue (Right val) = val


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, filter)
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)

import UI.NCurses

type Instructions = Map Integer Integer

run :: (Integer, Integer) -> Instructions -> [Integer] -> [Integer]
-- (instructionPointer, base), instructions, input, output
run (i, base) instructions inputs =
  -- traceShow (i, base, instructions) $
  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 -> -- traceShow (arg 1) $
      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

type Game = Map (Integer, Integer) Integer
updateGame :: Game -> [Integer] -> Game
updateGame g [] = g
updateGame g (x:y:t:r) = updateGame (insert (x,y) t g) r
updateGame g _ = error "bad input"

display :: [Integer] -> IO ()
display drawCommands = runCurses $ do
    setEcho False
    w <- defaultWindow
    updateWindow w $ do
        draw drawCommands
    render
    waitFor w (\ev -> ev == EventCharacter 'q' || ev == EventCharacter 'Q')
      where draw [] = do
              moveCursor 0 10
              drawString "Done"
            draw (x:y:t:r) =
              if (x,y) == (-1, 0)
              then do
                moveCursor 0 0
                drawString $ show t
                draw r
              else do
                moveCursor (y+1) x
                drawString (case t of
                              0 -> " "
                              1 -> "W"
                              2 -> "B"
                              3 -> "_"
                              4 -> "*")
                draw r

waitFor :: Window -> (Event -> Bool) -> Curses ()
waitFor w p = loop where
    loop = do
        ev <- getEvent w Nothing
        case ev of
            Nothing -> loop
            Just ev' -> if p ev' then return () else loop

play :: [Integer] -> IO ([Integer])
play drawInstructions = runCurses $ do
  setEcho False
  w <- defaultWindow
  loop w drawInstructions
    where loop :: Window -> [Integer] -> Curses([Integer])
          loop w [] = do
            updateWindow w $ do
              moveCursor 0 10
              drawString "Press q to quit"
            render
            let qloop = do
                  ev <- getEvent w Nothing
                  case ev of
                    Nothing -> qloop
                    Just (EventCharacter 'q') -> return []
                    Just (EventCharacter 'Q') -> return []
                    _ -> qloop
            qloop
          loop w (x:y:t:r) = do
            updateWindow w $ do
              if (x,y) == (-1, 0)
                then do
                moveCursor 0 0
                drawString $ show t
                else do
                moveCursor (y+1) x
                drawString (case t of
                              0 -> " "
                              1 -> "W"
                              2 -> "B"
                              3 -> "_"
                              4 -> "*"
                              _ -> error ("Unknown input " ++ show t)
                           )
            render
            moveEvent <- getEvent w (Just 1)
            let joystick = case moveEvent of
                             Just (EventSpecialKey KeyLeftArrow) -> -1
                             Just (EventSpecialKey KeyRightArrow) -> 1
                             Nothing -> 0
                             Just (EventCharacter 'j') -> -1
                             Just (EventCharacter 'J') -> -1
                             Just (EventCharacter 'k') -> 1
                             Just (EventCharacter 'K') -> 1
                             _ -> 0
            updateWindow w $ do
              moveCursor 0 10
              drawString $ case joystick of
                -1 -> "move left"
                0 -> "no move"
                1 -> "move right"
            render
            -- laterJoysticks <- loop r
            -- return (joystick: laterJoysticks)
            joystick `merge` loop w r
          loop w badQ = error $ "loop: bad q: " ++ show badQ
          merge:: Integer -> Curses([Integer]) -> Curses([Integer])
          merge j ~js' = do
            js <- js'
            return (j:js)

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

  putStrLn "Part 1"
  let moves = run (0,0) instructions []
  putStrLn $ show moves
  let game = updateGame empty moves
  putStrLn $ show ("blocks", size (M.filter (== 2) game))

  -- putStrLn "Part 1b"
  -- display drawCommands
  -- putStrLn "Part 2"
  -- let instructions2 = insert 0 2 instructions -- play for free by setting memory address 0 to 2
  -- let moves = moves >>= (play . run (0,0) instructions2)
  -- -- moves <- play $ run (0,0) instructions2 $ repeat 0
  -- moves' <- moves
  -- putStrLn $ show $ length moves'

  -- let moves = moves >>= (play . run (0,0) instructions2)
  -- moves' <- moves
  -- putStrLn $ show moves'
  -- moves' <- play $ run (0,0) instructions2 []
  -- putStrLn $ show ("moves", moves')
  -- let moves = run (0,0) instructions2 $ repeat 0
  -- putStrLn $ show ("moves", moves)
  -- display moves

  -- 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 BangPatterns          #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE RoleAnnotations       #-}
{-# LANGUAGE DuplicateRecordFields #-}

{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

--TODO figure out what export
module ObjRSimplex (
  VSimplex
  , ObjRF(..)
  , ObjRVtxOf
  , ObjRVtx(..)
  , FObjRVtx(..)
  , ObjRSimplex(..)
  , SortedObjRSimplex(..)
  , CmpObjRVtx
  , makeFObjRVtx
  , cmpObjRVtx
  , RVtxObjCmp
  , getRVtxObjCmp
  ) where

import Data.Ord (comparing)
--import Data.Function (on)
--import Data.Bool (bool)
--import Data.Maybe (fromMaybe)
--import qualified Data.Foldable as FLD
import Data.Coerce

import qualified Data.Finite as F

import qualified Data.Vector.Sized as VS

import Numeric.LinearAlgebra.Static

import GHC.TypeNats

import qualified GDP

import Data.Vector.GDP.Sorted

--TODO need another file that has SortedSimplex stuff
--must create sorted simplex with compartor that is derived from objective
--TODO problem, compartor is completely determined by ObjF in this specific case

--note this has all the axioms of Objective Simplex / Vertex, others should derive from this
--rename GDP, rename to RnObjectiveSimplex

type VSimplex v n = VS.Vector (n + 1) (v n)

type ObjRF n = R n -> ℝ

newtype ObjRVtxOf fObjName name = ObjVtxOf GDP.Defn
type role ObjRVtxOf nominal nominal

data ObjRVtx n = ObjRVtx { getX :: !(R n)
                         , getFx :: ℝ
                         }
                         deriving Show

newtype FObjRVtx fObjName n =
  FObjRVtx { getObjRVtx :: ObjRVtx n GDP.? ObjRVtxOf fObjName }

newtype ObjRSimplex fObjName n =
  ObjRSimplex { vtxs :: VSimplex (FObjRVtx fObjName) n }

newtype SortedObjRSimplex fObjName n =
  SortedObjRSimplex { vtxs :: VSimplex (FObjRVtx fObjName) n GDP.? SortedBy (RVtxObjCmp fObjName) }

type CmpObjRVtx fObjName n = Comparison (FObjRVtx fObjName n)

makeFObjRVtx :: (ObjRF n GDP.~~ fObjName) -> R n -> FObjRVtx fObjName n
makeFObjRVtx (GDP.The f) x = FObjRVtx $ GDP.assert ObjRVtx { getX = x, getFx = f x }

--TODO rewrite using GDP stripping proof function
--TODO note objective will be in environment, make new copy of nelderMead
cmpObjRVtx :: CmpObjRVtx fObjName n
cmpObjRVtx (FObjRVtx (GDP.The vtx1)) (FObjRVtx (GDP.The vtx2)) =
  comparing getFx vtx1 vtx2

newtype RVtxObjCmp fObjName = RVtxObjCmp GDP.Defn
type role RVtxObjCmp nominal

getRVtxObjCmp :: (ObjRF n GDP.~~ fObjName)
  -> (CmpObjRVtx fObjName n GDP.~~ RVtxObjCmp fObjName)
getRVtxObjCmp f = GDP.defn cmpObjRVtx

newtype VtxsOfObjRSimplex vName = VtxsOfObjRSimplex GDP.Defn
type role VtxsOfObjRSimplex nominal

getObjRSimplexNamedVtxs :: forall fObjName smplxName n.
  ObjRSimplex fObjName n GDP.~~ smplxName
  -> (VSimplex (FObjRVtx fObjName) n GDP.~~ VtxsOfObjRSimplex smplxName)
getObjRSimplexNamedVtxs (GDP.The s) = GDP.defn $ vtxs (s :: ObjRSimplex fObjName n)


{-# LANGUAGE BangPatterns #-}

module School.FileIO.BinConversion
( binConversion
, decodeList
) where

import Data.ByteString (ByteString, drop, length, take, unpack)
import Numeric.LinearAlgebra (I, R)
import Prelude hiding (drop, length, take)
import School.Types.Decoding (binToInt)
import School.Types.Encoding (Put, putInt, putDouble, runPut)
import School.Types.DataType (DataType(..))
import School.Types.Error (Error)

type Converter = ByteString
              -> Either Error ByteString

floatMsg :: Error
floatMsg = "Illegal conversion from floating point to integral"

precMsg :: Error
precMsg = "Illegal conversion from higher to lower "
       ++ "precision variables"

convertWords :: (Num a)
             => (Int -> a)
             -> (a -> Put)
             -> Converter
convertWords fromInt put = Right
                         . runPut
                         . mapM_ (put . fromInt . fromEnum)
                         . unpack

decodeList :: Int
           -> (a -> b)
           -> (ByteString -> Either Error a)
           -> (ByteString -> Either Error [b])
decodeList s convert decode bytes = reverse <$>
  go s bytes [] where
    go n b acc = if length b < n
                   then return acc
                   else do
                     e <- decode . take n $ b
                     let e' = convert e
                     go n (drop n b) (e':acc)

binConversion :: DataType
              -> DataType
              -> Converter
binConversion INT08B INT32B =
  convertWords (fromIntegral :: Int -> I) putInt
binConversion INT08B DBL64B =
  convertWords (fromIntegral :: Int -> R) putDouble
binConversion INT32B INT08B = const $ Left precMsg
binConversion INT32B DBL64B = \bytes -> do
  !doubles <- decodeList 4 fromIntegral binToInt bytes
  return . runPut $ mapM_ putDouble doubles
binConversion DBL64B INT08B = const $ Left floatMsg
binConversion DBL64B INT32B = const $ Left floatMsg
binConversion _ _ = Right


{-# LANGUAGE DataKinds, FlexibleContexts, TemplateHaskell #-}
module Main where
import qualified Data.Vector.Unboxed as V
import Diagrams.Backend.Rasterific
import Diagrams (dims2D, width, height)
import Frames
import Graphics.Rendering.Chart.Backend.Diagrams (defaultEnv, runBackendR)
import Graphics.Rendering.Chart.Easy
import qualified Pipes as P
import qualified Pipes.Prelude as P
import Statistics.Sample.KernelDensity (kde)

-- Data from http://wwwn.cdc.gov/nchs/nhanes/2005-2006/TRIGLY_D.htm
tableTypes "Trigly" "data/trigly_d.csv"

-- Load the data. Invalid records use zeros as a placeholder.
triglyData :: MonadSafe m => P.Producer Trigly m ()
triglyData = readTable "data/trigly_d.csv" P.>-> P.filter ((> 0) . view lBDLDL)

-- Adapted from a Chart example
fillBetween :: String -> [(a, (b, b))] -> EC l (PlotFillBetween a b)
fillBetween title vs = liftEC $ do
  plot_fillbetween_title .= title
  color <- dissolve 0.5 `fmap` takeColor
  plot_fillbetween_style .= solidFillStyle color
  plot_fillbetween_values .= vs

-- | Plot a semi-transparent KDE with a thick black outline.
mkPlot :: String -> [Int] -> EC (Layout Double Double) ()
mkPlot title xs = do plot (fillBetween title pts)
                     plot . liftEC $ do
                       zoom plot_lines_style $ do
                         line_color .= opaque black
                         line_width *= 2
                       plot_lines_values .= [map (_2 %~ snd) pts]
  where pts = V.toList . uncurry (V.zipWith (\x y -> (x, (0, y)))) . kde 128
            $ V.fromList (map fromIntegral xs)

-- | Plot LDL cholesterol and Triglyceride levels.
mkPlots :: [Record [LBXTR, LBDLDL]] -> EC (Layout Double Double) ()
mkPlots xs = do layout_title .= "Distributions"
                layout_x_axis . laxis_title .= "mg/dL"
                layout_all_font_styles . font_size *= 2
                mkPlot "LDL" ldls
                mkPlot "Triglycerides" tris
  where ldls = map (view lBDLDL) xs
        tris = map (view lBXTR) xs

main :: IO ()
main = do env <- defaultEnv bitmapAlignmentFns 640 480
          let chart2diagram = fst . runBackendR env . toRenderable . execEC
          ldlData <- runSafeT . P.toListM $ triglyData P.>-> P.map rcast
          let d = chart2diagram $ mkPlots ldlData
              sz = dims2D (width d) (height d)
          renderRasterific "plot.png" sz d


-- (C) Copyright Chris Banks 2011-2012

-- This file is part of The Continuous Pi-calculus Workbench (CPiWB).

--     CPiWB is free software: you can redistribute it and/or modify
--     it under the terms of the GNU General Public License as published by
--     the Free Software Foundation, either version 3 of the License, or
--     (at your option) any later version.

--     CPiWB is distributed in the hope that it will be useful,
--     but WITHOUT ANY WARRANTY; without even the implied warranty of
--     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--     GNU General Public License for more details.

--     You should have received a copy of the GNU General Public License
--     along with CPiWB.  If not, see <http://www.gnu.org/licenses/>.

{-# OPTIONS_GHC -w #-}

module CPi.Matlab
    (solveODEoctave,
     matlabScript
    ) where

import BioCalcLib.Lib
import CPi.Lib
import CPi.Semantics
import CPi.ODE

import qualified Data.List as L
import qualified Control.Exception as X
import qualified Data.Map as Map
import Data.Map (Map)
--import Data.Maybe

--import qualified Numeric.LinearAlgebra as LA

import System.IO.Unsafe
import qualified System.Process as OS

-------------------------------
-- MATLAB script output:
-------------------------------

matlabODE :: Env -> Process -> P' -> (Int,(Double,Double)) -> String
matlabODE env p dpdt (n,(t0,tn))
    = "init = [" ++ (L.concat (L.intersperse ";" (map show (initials env p p')))) ++ "];\n" ++
      "t = linspace(" ++ show t0 ++ "," ++ show tn ++ "," ++ show n ++ ");\n" ++
      "function xdot = f(x,t) \n\n" ++
      (L.concat (L.intersperse ";\n"
                 ((map (\(k,v) ->
                        (maybe "XXX" id (Map.lookup k (svxd)) ++ " = " ++
                         matlabExpr env (svx) v)))
                  (Map.toList p')))) ++ ";\nendfunction;\n\n" ++
      "function jac = jj(x,t)\n\n" ++
      matlabJac env p' ++ ";\nendfunction;\n\n" ++
      "x = lsode({@f,@jj}, init, t);\n" ++
      "save (\"-ascii\", \"-\", \"x\");"
          where
            xdots = ["xdot("++ show i ++")" | i<-[1..]]
            svxd = speciesVars env xdots p'
            xs = ["x("++ show i ++")" | i<-[1..]]
            svx = speciesVars env xs p'
            p' = simpP' env dpdt

matlabExpr :: Env -> Map Species String -> Expr -> String
matlabExpr env vs (Var x)
    = maybe (ex x) id (Map.lookup x vs)
      where
        ex x = X.throw $ CpiException
               ("Bug: failed var lookup in CPi.ODE.matlabExpr: " ++ show x)
matlabExpr env vs (Plus x y) = matlabExpr env vs x ++ " .+ " ++ matlabExpr env vs y
matlabExpr env vs (Times (Plus x y) (Plus x' y'))
    = "(" ++ matlabExpr env vs (Plus x y) ++ ").*(" ++ matlabExpr env vs (Plus x' y') ++ ")"
matlabExpr env vs (Times (Plus x y) z)
    = "(" ++ matlabExpr env vs (Plus x y) ++ ").*" ++ matlabExpr env vs z
matlabExpr env vs (Times x (Plus y z))
    = matlabExpr env vs x ++ ".*(" ++ matlabExpr env vs (Plus y z) ++ ")"
matlabExpr env vs (Times x y) = matlabExpr env vs x ++ ".*" ++ matlabExpr env vs y
matlabExpr env vs (Num k) = show k

matlabJac :: Env -> P' -> String
matlabJac env p' = L.concat $ L.intersperse ";\n" $
                   map (\(a,b) -> a ++ " = " ++ b) $
                   zip rhss $
                   map (matlabExpr env (speciesVars env xs p')) $
                   map (simp env) $
                   map diff' $ cp (unzip (Map.toList (sp')))
    where
      cp (x,y) = [(a,b)|b<-y,a<-x]
      diff' (x,e) = diff x e
      xs = ["x("++ show i ++")" | i<-[1..]]
      sp' = simpP' env p'
      len = Map.size p'
      rhss = ["jac("++ show x ++ "," ++ show y ++ ")" | x<-[1..len], y<-[1..len]]

---------------------------------------
-- Using Octave to execute the scripts
---------------------------------------

callOctave env p mts p' ts = let
    script = matlabODE env (wholeProc env p mts) p' ts
  in do
    putStrLn $ "Octave Script: \n" ++ script
    OS.readProcess
      "octave" ["-q", "--eval", script] []

-- | Solver which calculates the symbolic Jacobian, writes MATLAB code, and executes it with GNU Octave. (General purpose, deals with stiff systems, uses LSODE.)
solveODEoctave :: Solver
solveODEoctave env p mts p' ts@(n,(t0,tn))
    = let raw = unsafePerformIO (callOctave env p mts p' ts)
      in (n><(Map.size p')) $ map s2d $ words raw

-- Return the MATLAB script for ODEs
matlabScript :: Env
             -> Process
             -> MTS
             -> P'
             -> (Int, (Double, Double))
             -> String
matlabScript env p mts p' ts = matlabODE env (wholeProc env p mts) p' ts


import Test.QuickCheck
import Execution
import InputOutput
import Types
import Data.List.Split
import System.Random
import System.Random.Shuffle
import Numeric.LinearAlgebra.HMatrix
import Numeric.LinearAlgebra.Data
import Training
import Execution

-- Exemplo de como usar:
--
-- $ ghci Tests.hs
--  > import Test.QuickCheck
--  > quickCheck prop_reverseReverse

prop_reverseReverse :: [Int] -> Bool
prop_reverseReverse xs = reverse (reverse xs) == xs


module Rebase.Data.Complex
(
  module Data.Complex
)
where

import Data.Complex