module Parser
    (
      -- * Expression
      readExpr
    ) where

import Data.Array (listArray)
import Data.Char (digitToInt)
import Data.Complex (Complex(..))
import Data.Ratio ((%))
import Numeric (readFloat, readHex, readInt, readOct)

import Control.Monad.Except (throwError)
import Text.ParserCombinators.Parsec

import Type (LispError(..), LispVal(..), ThrowsError)

-- | Read an expression. Returns the parsed `LispVal`.
readExpr :: String -> ThrowsError LispVal
readExpr input =
    case parse parseExpr "lisp" input of
        Left err   -> throwError $ Parser err
        Right expr -> return expr

-- | Parses an expression. Returns the parsed `LispVal`.
parseExpr :: Parser LispVal
parseExpr = parseSymbol
    -- Expressions started with `#`
    <|> try parseNumber <|> try parseBoolean <|> try parseCharacter
    <|> parseVector
    -- Expressions started with `unquote` (,)
    <|> try parseUnquoteSplicing <|> parseUnquote
    <|> parseString <|> parseQuasiquote <|> parseQuoted <|> parseList

-- | Parses a boolean. Returns the parsed `Boolean`.
parseBoolean :: Parser LispVal
parseBoolean = do
    _ <- char '#'
    v <- char 't' <|> char 'f'

    return $
        case v of
            't' -> Boolean True
            _   -> Boolean False

-- | Parses an symbol. Returns the parsed `Symbol`.
parseSymbol :: Parser LispVal
parseSymbol = do
    first <- letter <|> extendedAlphabet
    rest  <- many $ letter <|> digit <|> extendedAlphabet
    return $ Symbol $ first:rest

-- | Parses a literal expression. Returns the parsed `List`.
parseQuoted :: Parser LispVal
parseQuoted = do
    _ <- char '\''
    x <- parseExpr
    return $ List [Symbol "quote", x]

-- | Parses a vector. Returns the parsed `Vector`.
parseVector :: Parser LispVal
parseVector = do
    _  <- string "#("
    xs <- sepBy parseExpr spaces1
    _  <- char ')'
    return $ Vector $ listArray (0, length xs - 1) xs

-- | Parses a quasiquote expression. Returns the parsed `List`.
parseQuasiquote :: Parser LispVal
parseQuasiquote = do
    _ <- char '`'
    x <- parseExpr
    return $ List [Symbol "quasiquote", x]

-- | Parses an unquote expression. Returns the parsed `List`.
parseUnquote :: Parser LispVal
parseUnquote = do
    _ <- char ','
    x <- parseExpr
    return $ List [Symbol "unquote", x]

-- | Parses an unquote-splicing expression. Returns the parsed `List`.
parseUnquoteSplicing :: Parser LispVal
parseUnquoteSplicing = do
    _ <- string ",@"
    x <- parseExpr
    return $ List [Symbol "unquote-splicing", x]

-- | Parses a list. Returns the parsed `List` or `DottedList`.
parseList :: Parser LispVal
parseList = do
    _  <- char '(' >> spaces
    xs <- parseExpr `sepEndBy` spaces1
    parseDottedListTail xs <|> parseListEnd xs

-- | Parses the end of a list. Returns the parsed `List`.
parseListEnd :: [LispVal] -> Parser LispVal
parseListEnd xs = do
    _  <- spaces >> char ')'
    return $ List xs

-- | Parses the tail of a dotted list. Returns the parsed `DottedList`.
parseDottedListTail :: [LispVal] -> Parser LispVal
parseDottedListTail xs = do
    _  <- char '.' >> spaces1
    t  <- parseExpr
    _  <- spaces >> char ')'
    return $ DottedList xs t

-- | Parses a numberical constant.
--
--   Returns the parsed `Integer`, `Rational`, `Real` or `Complex`.
parseNumber :: Parser LispVal
parseNumber =
    try parseReal <|> try parseRational <|> try parseComplex
    <|> try parseBin <|> try parseOct <|> try parseHex <|> parseDecimal

-- | Parses a floating point constant. Returns the parsed `Real`.
parseReal :: Parser LispVal
parseReal = do
    i <- many1 digit
    _ <- char '.'
    d <- many1 digit

    let n = concat [i, ".", d]
    return $
        case readFloat n of
            [(v, "")] -> Real v
            _         -> error $ "parseReal: no match for " ++ n

-- | Parses an rational number constant. Returns the parsed `Rational`.
--
--   For `a/b`, only integers are supported for `a` and `b` to ease
--   implementation.
parseRational :: Parser LispVal
parseRational = do
    n <- many1 digit
    _ <- char '/'
    d <- many1 digit
    return $ Rational $ read n % read d

-- | Parses an complex number constant. Returns the parsed `Complex`.
--
--   For `a+bi`, only integers are supported for `a` and `b` to ease
--   implementation.
parseComplex :: Parser LispVal
parseComplex = do
    n <- many1 digit
    _ <- char '+'
    d <- many1 digit
    _ <- char 'i'
    return $ Complex $ read n :+ read d

-- | Parses a decimal numberical constant. Returns the parsed `Integer`.
parseDecimal :: Parser LispVal
parseDecimal = do
    _ <- optional $ string "#d"
    Integer . read <$> many1 digit

-- | Parses an binary numberical constant. Returns the parsed `Integer`.
parseBin :: Parser LispVal
parseBin = do
    _ <- string "#b"
    n <- many1 $ oneOf "01"
    return $
        case readBin n of
            [(v, "")] -> Integer v
            _         -> error $ "parseBin: no match for " ++ n

-- | Parses an octal numberical constant. Returns the parsed `Integer`.
parseOct :: Parser LispVal
parseOct = do
    _ <- string "#o"
    n <- many1 octDigit
    return $
        case readOct n of
            [(v, "")] -> Integer v
            _         -> error $ "parseOct: no match for " ++ n

-- | Parses a hexadecimal numberics constant. Returns the parsed `Integer`.
parseHex :: Parser LispVal
parseHex = do
    _ <- string "#x"
    n <- many1 hexDigit
    return $
        case readHex n of
            [(v, "")] -> Integer v
            _         -> error $ "parseHex: no match for " ++ n

-- | Parses a character constant. Returns the parsed `Character`.
--
--   Only `#\space` is supported instead of `#\` to ease implementation.
parseCharacter :: Parser LispVal
parseCharacter = do
    _ <- string "#\\"
    s <- string "space" <|> string "newline" <|> count 1 (noneOf " ")
    return $
        case s of
            "space"   -> Character ' '
            "newline" -> Character '\n'
            [c]       -> Character c
            _         -> error $ "parseCharacter: no match for " ++ s

-- | Parses a string constant. Returns the parsed `String`.
parseString :: Parser LispVal
parseString = do
    _ <- char '"'
    x <- many $ noneOf "\\\"" <|> parseQuotedCharacter
    _ <- char '"'
    return $ String x

-- | Parses a quoted character (\\, \", \n, \r, \t).
--
--   Returns the parsed character.
parseQuotedCharacter :: Parser Char
parseQuotedCharacter = do
    _  <- char '\\'
    qc <- oneOf "\\\"nrt"
    return $
        case qc of
            'n' -> '\n'
            'r' -> '\r'
            't' -> '\t'
            _   -> qc

-- | Skips one or more white space characters.
spaces1 :: Parser ()
spaces1 = skipMany1 space

-- | Parses an extended alphabetic character (!$%&*+-/:<=>?@^_~).
--
--   Dot (.) was removed to ease implementation of dotted list.
--
--   Returns the parsed character.
extendedAlphabet :: Parser Char
extendedAlphabet = oneOf "!$%&*+-/:<=>?@^_~"

-- | Read an unsigned number in binary notation.
readBin :: (Eq a, Num a) => ReadS a
readBin = readInt 2 (`elem` "01") digitToInt


{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# Language TypeOperators, TypeApplications, ScopedTypeVariables #-}

module ConCat.Circ where

import Prelude hiding ((.), id, curry, uncurry, const)
import ConCat.Circuit ( CircuitM, (:>)
  , Bus(..),Comp(..),Input,Output, Ty(..), busTy, Source(..), Template(..)
  , GenBuses(..), GS, genBusesRep', tyRep
  -- , delayCRep, unDelayName
  , namedC, constC -- , constS
  , genUnflattenB'
  , SourceToBuses(..), CompS(..), simpleComp
  , mkGraph
  , Attr
  , graphDot, writeDot, displayDot,Name,Report,Graph
  -- , simpleComp
  , tagged
  , systemSuccess
  -- For AbsTy
  , BusesM, abstB,abstC,reprC,Buses(..)
  , OkCAR
  -- , Ty(..)
  )
import GHC.Generics (unComp1, (:.:)(..), Generic)

import ConCat.Misc
import qualified ConCat.RunCircuit as RC
import ConCat.Rep
import ConCat.Category

import ConCat.AltCat ()
import ConCat.Rebox () -- necessary for reboxing rules to fire
import ConCat.Orphans ()
import ConCat.Free.VectorSpace
import ConCat.Free.Affine
import ConCat.Free.LinearRow
import ConCat.Additive

import Data.Vector.Sized (Vector)
import Data.Constraint
import Data.Complex
import Data.Key

-- This is what a morphism looks like in LCirc
data RLC a = Res a
  | Cap a
  | Ind a
  deriving (Eq, Show, Functor, Generic)

instance (HasRep a) => HasRep (RLC a) where
  type Rep (RLC a) = (Maybe a, Maybe a, Maybe a)
  abst (Just r, Nothing, Nothing) = Res r
  abst (Nothing, Just c, Nothing) = Cap c
  abst (Nothing, Nothing, Just i) = Ind i
  repr (Res r) = (Just r, Nothing, Nothing)
  repr (Cap c) = (Nothing, Just c, Nothing)
  repr (Ind i) = (Nothing, Nothing, Just i)

instance (HasV R a) => HasV R (Maybe a) where
  type V R (Maybe a) = Maybe :.: V R a
  toV = Comp1 . fmap toV
  unV = fmap unV . unComp1

instance (HasV R a) => HasV R (Complex a)

instance (HasRep a, HasV R a) => HasV R (RLC a)

instance (GenBuses a) => GenBuses (RLC a) where
  genBuses' = genBusesRep'
  ty = tyRep @(RLC a)
  unflattenB' = genUnflattenB'

newtype VI a = VI (a, a) deriving (Eq, Ord, Generic)

instance HasRep a => HasRep (VI a) where
  type Rep (VI a) = (a, a)
  repr (VI (v, i)) = (v, i)
  abst = VI

instance (GenBuses a) => GenBuses (VI a) where
  genBuses' = genBusesRep'
  ty = tyRep @(VI a)
  unflattenB' = genUnflattenB'

instance (HasRep a, HasV R a) => HasV R (VI a)

--elem :: VI' :> RLC
--elem = namedC "elem"

type VI' = VI R

type LC a = (VI a, RLC a)

-- laplace transform all the tings

--class Circ i b where
--  codup :: (Num b) => (LC b :* LC b) -> (LC b) -> (LC b)
--  dup :: (Num b) => (LC b) -> ((LC b) :* (LC b))
--  unit :: (Num b) => () -> (LC b)
--  counit :: (Num b) => (LC b) -> ()

blackbox :: Fractional a => (VI a) -> (RLC a) -> (VI a)
blackbox (VI (v,i)) (Res r) = VI (v + r*i, i)
blackbox (VI (v,i)) (Cap c) = VI (v + (i / c), i)
blackbox (VI (v, i)) (Ind l) = VI (v + (l * i), i)

--bb :: (Fractional b) => Circ a -> VI b
--bb (Codup (lc1, lc2) lc3) = (uncurry blackbox $ lc1)

--blackbox :: (RLC :> RLC) -> Affine R R R
--blackbox = undefined

newtype Blackbox a = Blackbox (L R a R) deriving (Generic)

instance (HasRep a) => HasRep (Blackbox a) where
  type Rep (Blackbox a) = a
  abst = undefined $ Blackbox
  repr (Blackbox a) = undefined $ a

instance (GenBuses a) => GenBuses (Blackbox a) where
  genBuses' = genBusesRep'
  ty = tyRep @(Blackbox a)
  unflattenB' = genUnflattenB'

instance OkFunctor (:>) (Blackbox) where
  okFunctor = Entail (Sub Dict)


module Language.Scheme.Types where

import Data.Complex

data LispVal = Atom String
             | List [LispVal]
             | DottedList [LispVal] LispVal
             | String String
             | Bool Bool
             | Character Char
             | Number Number

data Number = Integer Integer
            | Real Double
            | Rational Rational
            | Complex (Complex Double)

instance Show Number where
    show = showNumber

instance Show LispVal where
    show = showVal

showNumber :: Number -> String
showNumber (Integer contents) = show contents
showNumber (Real contents) = show contents
showNumber (Rational contents) = show contents
showNumber (Complex contents) = show contents

showVal :: LispVal -> String
showVal (String contents) = "\"" ++ contents ++ "\""
showVal (Atom name) = name
showVal (Character name) = [name]
showVal (Number contents) = show contents
showVal (Bool True) = "#t"
showVal (Bool False) = "#f"
showVal (List contents) = "(" ++ unwordsList contents ++ ")"
showVal (DottedList head' tail') = "(" ++ unwordsList head' ++ " . " ++ showVal tail' ++ ")"

unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal


{-# LANGUAGE ForeignFunctionInterface #-}
{-|
Module      : Grenade.Layers.Internal.Shrink
Description : Functions to shrink a matrix
Maintainer  : Theo Charalambous
License     : BSD2
Stability   : experimental
-}
module Grenade.Layers.Internal.Shrink (
    shrink_2d,
    shrink_2d_rgba
  ) where

import qualified Data.Vector.Storable        as S

import           Foreign                     (mallocForeignPtrArray, withForeignPtr)
import           Foreign.Ptr                 (Ptr)
import           Numeric.LinearAlgebra       (Matrix, flatten)
import qualified Numeric.LinearAlgebra.Devel as U
import           System.IO.Unsafe            (unsafePerformIO)

import           Data.Word

import           Grenade.Types

shrink_2d :: Int            -- ^ input rows
          -> Int            -- ^ input cols
          -> Int            -- ^ target rows
          -> Int            -- ^ target cols
          -> Matrix RealNum -- ^ input matrix
          -> Matrix RealNum -- ^ shrinked matrix
shrink_2d rows cols rows' cols' m
 = let outMatSize      = rows' * cols'
       vec             = flatten m
   in unsafePerformIO $ do
     --print vec
     outPtr           <- mallocForeignPtrArray outMatSize
     let (inPtr, _, _) = S.unsafeToForeignPtr vec

     withForeignPtr inPtr $ \inPtr' ->
        withForeignPtr outPtr $ \outPtr' ->
          shrink_2d_cpu inPtr' rows cols rows' cols' outPtr'

     let matVec = S.unsafeFromForeignPtr0 outPtr outMatSize
     return (U.matrixFromVector U.RowMajor rows' cols' matVec)
--{-# INLINE shrink_2d #-}

shrink_2d_rgba :: Int            -- ^ input rows
               -> Int            -- ^ input cols
               -> Int            -- ^ target rows
               -> Int            -- ^ target cols
               -> S.Vector Word8 -- ^ vector of word8s in the form rgba, like from a HTML canvas
               -> Matrix RealNum -- shrinked matrix
shrink_2d_rgba rows cols rows' cols' vec
  = let outMatSize = rows' * cols'
    in unsafePerformIO $ do
      outPtr           <- mallocForeignPtrArray outMatSize
      let (inPtr, _, _) = S.unsafeToForeignPtr vec

      -- print vec

      withForeignPtr inPtr $ \inPtr' ->
        withForeignPtr outPtr $ \outPtr' ->
          shrink_2d_rgba_cpu inPtr' rows cols rows' cols' outPtr'

      let matVec = S.unsafeFromForeignPtr0 outPtr outMatSize
      return (U.matrixFromVector U.RowMajor rows' cols' matVec)
--{-# INLINE shrink_2d_rgba #-}

foreign import ccall unsafe
    shrink_2d_cpu :: Ptr RealNum -> Int -> Int -> Int -> Int -> Ptr RealNum -> IO ()

foreign import ccall unsafe
    shrink_2d_rgba_cpu :: Ptr Word8 -> Int -> Int -> Int -> Int -> Ptr RealNum -> IO ()


{-# LANGUAGE MagicHash, CPP, UnboxedTuples, BangPatterns, FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Packed.Internal.Vector
-- Copyright   :  (c) Alberto Ruiz 2007
-- License     :  GPL-style
--
-- Maintainer  :  Alberto Ruiz <aruiz@um.es>
-- Stability   :  provisional
-- Portability :  portable (uses FFI)
--
-- Vector implementation
--
-----------------------------------------------------------------------------

module Data.Packed.Internal.Vector (
    Vector, dim,
    fromList, toList, (|>),
    join, (@>), safe, at, at', subVector, takesV,
    mapVector, mapVectorWithIndex, zipVectorWith, unzipVectorWith,
    mapVectorM, mapVectorM_, mapVectorWithIndexM, mapVectorWithIndexM_,
    foldVector, foldVectorG, foldLoop, foldVectorWithIndex,
    createVector, vec,
    asComplex, asReal, float2DoubleV, double2FloatV,
    stepF, stepD, condF, condD,
    conjugateQ, conjugateC,
    fwriteVector, freadVector, fprintfVector, fscanfVector,
    cloneVector,
    unsafeToForeignPtr,
    unsafeFromForeignPtr,
    unsafeWith
) where

import Data.Packed.Internal.Common
import Data.Packed.Internal.Signatures
import Foreign.Marshal.Alloc(free)
import Foreign.Marshal.Array(peekArray, pokeArray, copyArray, advancePtr)
import Foreign.ForeignPtr(ForeignPtr, castForeignPtr)
import Foreign.Ptr(Ptr)
import Foreign.Storable(Storable, peekElemOff, pokeElemOff, sizeOf)
import Foreign.C.String
import Foreign.C.Types
import Data.Complex
import Control.Monad(when)
import System.IO.Unsafe(unsafePerformIO)

#if __GLASGOW_HASKELL__ >= 605
import GHC.ForeignPtr           (mallocPlainForeignPtrBytes)
#else
import Foreign.ForeignPtr       (mallocForeignPtrBytes)
#endif

import GHC.Base
#if __GLASGOW_HASKELL__ < 612
import GHC.IOBase hiding (liftIO)
#endif

import qualified Data.Vector.Storable as Vector
import Data.Vector.Storable(Vector,
                            unsafeToForeignPtr,
                            unsafeFromForeignPtr,
                            unsafeWith)

-- | Number of elements
dim :: (Storable t) => Vector t -> Int
dim = Vector.length

-- C-Haskell vector adapter
-- vec :: Adapt (CInt -> Ptr t -> r) (Vector t) r
vec :: (Storable t) => Vector t -> (((CInt -> Ptr t -> t1) -> t1) -> IO b) -> IO b
vec x f = unsafeWith x $ \p -> do
    let v g = do
        g (fi $ dim x) p
    f v
{-# INLINE vec #-}

-- allocates memory for a new vector
createVector :: Storable a => Int -> IO (Vector a)
createVector n = do
    when (n <= 0) $ error ("trying to createVector of dim "++show n)
    fp <- doMalloc undefined
    return $ unsafeFromForeignPtr fp 0 n
  where
    --
    -- Use the much cheaper Haskell heap allocated storage
    -- for foreign pointer space we control
    --
    doMalloc :: Storable b => b -> IO (ForeignPtr b)
    doMalloc dummy = do
#if __GLASGOW_HASKELL__ >= 605
        mallocPlainForeignPtrBytes (n * sizeOf dummy)
#else
        mallocForeignPtrBytes      (n * sizeOf dummy)
#endif

{- | creates a Vector from a list:

@> fromList [2,3,5,7]
4 |> [2.0,3.0,5.0,7.0]@

-}
fromList :: Storable a => [a] -> Vector a
fromList l = unsafePerformIO $ do
    v <- createVector (length l)
    unsafeWith v $ \ p -> pokeArray p l
    return v

safeRead v = inlinePerformIO . unsafeWith v
{-# INLINE safeRead #-}

inlinePerformIO :: IO a -> a
inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
{-# INLINE inlinePerformIO #-}

{- | extracts the Vector elements to a list

@> toList (linspace 5 (1,10))
[1.0,3.25,5.5,7.75,10.0]@

-}
toList :: Storable a => Vector a -> [a]
toList v = safeRead v $ peekArray (dim v)

{- | An alternative to 'fromList' with explicit dimension. The input
     list is explicitly truncated if it is too long, so it may safely
     be used, for instance, with infinite lists.

     This is the format used in the instances for Show (Vector a).
-}
(|>) :: (Storable a) => Int -> [a] -> Vector a
infixl 9 |>
n |> l = if length l' == n
            then fromList l'
            else error "list too short for |>"
  where l' = take n l

-- | access to Vector elements without range checking
at' :: Storable a => Vector a -> Int -> a
at' v n = safeRead v $ flip peekElemOff n
{-# INLINE at' #-}

--
-- turn off bounds checking with -funsafe at configure time.
-- ghc will optimise away the salways true case at compile time.
--
#if defined(UNSAFE)
safe :: Bool
safe = False
#else
safe = True
#endif

-- | access to Vector elements with range checking.
at :: Storable a => Vector a -> Int -> a
at v n
    | safe      = if n >= 0 && n < dim v
                    then at' v n
                    else error "vector index out of range"
    | otherwise = at' v n
{-# INLINE at #-}

{- | takes a number of consecutive elements from a Vector

@> subVector 2 3 (fromList [1..10])
3 |> [3.0,4.0,5.0]@

-}
subVector :: Storable t => Int       -- ^ index of the starting element
                        -> Int       -- ^ number of elements to extract
                        -> Vector t  -- ^ source
                        -> Vector t  -- ^ result
subVector = Vector.slice

{- | Reads a vector position:

@> fromList [0..9] \@\> 7
7.0@

-}
(@>) :: Storable t => Vector t -> Int -> t
infixl 9 @>
(@>) = at

{- | creates a new Vector by joining a list of Vectors

@> join [fromList [1..5], constant 1 3]
8 |> [1.0,2.0,3.0,4.0,5.0,1.0,1.0,1.0]@

-}
join :: Storable t => [Vector t] -> Vector t
join [] = error "joining zero vectors"
join [v] = v
join as = unsafePerformIO $ do
    let tot = sum (map dim as)
    r <- createVector tot
    unsafeWith r $ \ptr ->
        joiner as tot ptr
    return r
  where joiner [] _ _ = return ()
        joiner (v:cs) _ p = do
            let n = dim v
            unsafeWith v $ \pb -> copyArray p pb n
            joiner cs 0 (advancePtr p n)

{- | Extract consecutive subvectors of the given sizes.

@> takesV [3,4] (linspace 10 (1,10))
[3 |> [1.0,2.0,3.0],4 |> [4.0,5.0,6.0,7.0]]@

-}
takesV :: Storable t => [Int] -> Vector t -> [Vector t]
takesV ms w | sum ms > dim w = error $ "takesV " ++ show ms ++ " on dim = " ++ (show $ dim w)
            | otherwise = go ms w
    where go [] _ = []
          go (n:ns) v = subVector 0 n v
                      : go ns (subVector n (dim v - n) v)

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

-- | transforms a complex vector into a real vector with alternating real and imaginary parts
asReal :: (RealFloat a, Storable a) => Vector (Complex a) -> Vector a
asReal v = unsafeFromForeignPtr (castForeignPtr fp) (2*i) (2*n)
    where (fp,i,n) = unsafeToForeignPtr v

-- | transforms a real vector into a complex vector with alternating real and imaginary parts
asComplex :: (RealFloat a, Storable a) => Vector a -> Vector (Complex a)
asComplex v = unsafeFromForeignPtr (castForeignPtr fp) (i `div` 2) (n `div` 2)
    where (fp,i,n) = unsafeToForeignPtr v

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

float2DoubleV :: Vector Float -> Vector Double
float2DoubleV v = unsafePerformIO $ do
    r <- createVector (dim v)
    app2 c_float2double vec v vec r "float2double"
    return r

double2FloatV :: Vector Double -> Vector Float
double2FloatV v = unsafePerformIO $ do
    r <- createVector (dim v)
    app2 c_double2float vec v vec r "double2float2"
    return r

foreign import ccall unsafe "float2double" c_float2double:: TFV
foreign import ccall unsafe "double2float" c_double2float:: TVF

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

stepF :: Vector Float -> Vector Float
stepF v = unsafePerformIO $ do
    r <- createVector (dim v)
    app2 c_stepF vec v vec r "stepF"
    return r

stepD :: Vector Double -> Vector Double
stepD v = unsafePerformIO $ do
    r <- createVector (dim v)
    app2 c_stepD vec v vec r "stepD"
    return r

foreign import ccall unsafe "stepF" c_stepF :: TFF
foreign import ccall unsafe "stepD" c_stepD :: TVV

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

condF :: Vector Float -> Vector Float -> Vector Float -> Vector Float -> Vector Float -> Vector Float
condF x y l e g = unsafePerformIO $ do
    r <- createVector (dim x)
    app6 c_condF vec x vec y vec l vec e vec g vec r "condF"
    return r

condD :: Vector Double -> Vector Double -> Vector Double -> Vector Double -> Vector Double -> Vector Double
condD x y l e g = unsafePerformIO $ do
    r <- createVector (dim x)
    app6 c_condD vec x vec y vec l vec e vec g vec r "condD"
    return r

foreign import ccall unsafe "condF" c_condF :: CInt -> PF -> CInt -> PF -> CInt -> PF -> TFFF
foreign import ccall unsafe "condD" c_condD :: CInt -> PD -> CInt -> PD -> CInt -> PD -> TVVV

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

conjugateAux fun x = unsafePerformIO $ do
    v <- createVector (dim x)
    app2 fun vec x vec v "conjugateAux"
    return v

conjugateQ :: Vector (Complex Float) -> Vector (Complex Float)
conjugateQ = conjugateAux c_conjugateQ
foreign import ccall unsafe "conjugateQ" c_conjugateQ :: TQVQV

conjugateC :: Vector (Complex Double) -> Vector (Complex Double)
conjugateC = conjugateAux c_conjugateC
foreign import ccall unsafe "conjugateC" c_conjugateC :: TCVCV

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

cloneVector :: Storable t => Vector t -> IO (Vector t)
cloneVector v = do
        let n = dim v
        r <- createVector n
        let f _ s _ d =  copyArray d s n >> return 0
        app2 f vec v vec r "cloneVector"
        return r

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

-- | map on Vectors
mapVector :: (Storable a, Storable b) => (a-> b) -> Vector a -> Vector b
mapVector f v = unsafePerformIO $ do
    w <- createVector (dim v)
    unsafeWith v $ \p ->
        unsafeWith w $ \q -> do
            let go (-1) = return ()
                go !k = do x <- peekElemOff p k
                           pokeElemOff      q k (f x)
                           go (k-1)
            go (dim v -1)
    return w
{-# INLINE mapVector #-}

-- | zipWith for Vectors
zipVectorWith :: (Storable a, Storable b, Storable c) => (a-> b -> c) -> Vector a -> Vector b -> Vector c
zipVectorWith f u v = unsafePerformIO $ do
    let n = min (dim u) (dim v)
    w <- createVector n
    unsafeWith u $ \pu ->
        unsafeWith v $ \pv ->
            unsafeWith w $ \pw -> do
                let go (-1) = return ()
                    go !k = do x <- peekElemOff pu k
                               y <- peekElemOff pv k
                               pokeElemOff      pw k (f x y)
                               go (k-1)
                go (n -1)
    return w
{-# INLINE zipVectorWith #-}

-- | unzipWith for Vectors
unzipVectorWith :: (Storable (a,b), Storable c, Storable d)
                   => ((a,b) -> (c,d)) -> Vector (a,b) -> (Vector c,Vector d)
unzipVectorWith f u = unsafePerformIO $ do
      let n = dim u
      v <- createVector n
      w <- createVector n
      unsafeWith u $ \pu ->
          unsafeWith v $ \pv ->
              unsafeWith w $ \pw -> do
                  let go (-1) = return ()
                      go !k   = do z <- peekElemOff pu k
                                   let (x,y) = f z
                                   pokeElemOff      pv k x
                                   pokeElemOff      pw k y
                                   go (k-1)
                  go (n-1)
      return (v,w)
{-# INLINE unzipVectorWith #-}

foldVector :: Storable a => (a -> b -> b) -> b -> Vector a -> b
foldVector f x v = unsafePerformIO $
    unsafeWith v $ \p -> do
        let go (-1) s = return s
            go !k !s = do y <- peekElemOff p k
                          go (k-1::Int) (f y s)
        go (dim v -1) x
{-# INLINE foldVector #-}

-- the zero-indexed index is passed to the folding function
foldVectorWithIndex :: Storable a => (Int -> a -> b -> b) -> b -> Vector a -> b
foldVectorWithIndex f x v = unsafePerformIO $
    unsafeWith v $ \p -> do
        let go (-1) s = return s
            go !k !s = do y <- peekElemOff p k
                          go (k-1::Int) (f k y s)
        go (dim v -1) x
{-# INLINE foldVectorWithIndex #-}

foldLoop f s0 d = go (d - 1) s0
     where
       go 0 s = f (0::Int) s
       go !j !s = go (j - 1) (f j s)

foldVectorG f s0 v = foldLoop g s0 (dim v)
    where g !k !s = f k (at' v) s
          {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479)
{-# INLINE foldVectorG #-}

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

-- | monadic map over Vectors
--    the monad @m@ must be strict
mapVectorM :: (Storable a, Storable b, Monad m) => (a -> m b) -> Vector a -> m (Vector b)
mapVectorM f v = do
    w <- return $! unsafePerformIO $! createVector (dim v)
    mapVectorM' w 0 (dim v -1)
    return w
    where mapVectorM' w' !k !t
              | k == t               = do
                                       x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                       y <- f x
                                       return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y
              | otherwise            = do
                                       x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                       y <- f x
                                       _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y
                                       mapVectorM' w' (k+1) t
{-# INLINE mapVectorM #-}

-- | monadic map over Vectors
mapVectorM_ :: (Storable a, Monad m) => (a -> m ()) -> Vector a -> m ()
mapVectorM_ f v = do
    mapVectorM' 0 (dim v -1)
    where mapVectorM' !k !t
              | k == t            = do
                                    x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                    f x
              | otherwise         = do
                                    x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                    _ <- f x
                                    mapVectorM' (k+1) t
{-# INLINE mapVectorM_ #-}

-- | monadic map over Vectors with the zero-indexed index passed to the mapping function
--    the monad @m@ must be strict
mapVectorWithIndexM :: (Storable a, Storable b, Monad m) => (Int -> a -> m b) -> Vector a -> m (Vector b)
mapVectorWithIndexM f v = do
    w <- return $! unsafePerformIO $! createVector (dim v)
    mapVectorM' w 0 (dim v -1)
    return w
    where mapVectorM' w' !k !t
              | k == t               = do
                                       x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                       y <- f k x
                                       return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y
              | otherwise            = do
                                       x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                       y <- f k x
                                       _ <- return $! inlinePerformIO $! unsafeWith w' $! \q -> pokeElemOff q k y
                                       mapVectorM' w' (k+1) t
{-# INLINE mapVectorWithIndexM #-}

-- | monadic map over Vectors with the zero-indexed index passed to the mapping function
mapVectorWithIndexM_ :: (Storable a, Monad m) => (Int -> a -> m ()) -> Vector a -> m ()
mapVectorWithIndexM_ f v = do
    mapVectorM' 0 (dim v -1)
    where mapVectorM' !k !t
              | k == t            = do
                                    x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                    f k x
              | otherwise         = do
                                    x <- return $! inlinePerformIO $! unsafeWith v $! \p -> peekElemOff p k
                                    _ <- f k x
                                    mapVectorM' (k+1) t
{-# INLINE mapVectorWithIndexM_ #-}

mapVectorWithIndex :: (Storable a, Storable b) => (Int -> a -> b) -> Vector a -> Vector b
--mapVectorWithIndex g = head . mapVectorWithIndexM (\a b -> [g a b])
mapVectorWithIndex f v = unsafePerformIO $ do
    w <- createVector (dim v)
    unsafeWith v $ \p ->
        unsafeWith w $ \q -> do
            let go (-1) = return ()
                go !k = do x <- peekElemOff p k
                           pokeElemOff      q k (f k x)
                           go (k-1)
            go (dim v -1)
    return w
{-# INLINE mapVectorWithIndex #-}

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

-- | Loads a vector from an ASCII file (the number of elements must be known in advance).
fscanfVector :: FilePath -> Int -> IO (Vector Double)
fscanfVector filename n = do
    charname <- newCString filename
    res <- createVector n
    app1 (gsl_vector_fscanf charname) vec res "gsl_vector_fscanf"
    free charname
    return res

foreign import ccall unsafe "vector_fscanf" gsl_vector_fscanf:: Ptr CChar -> TV

-- | Saves the elements of a vector, with a given format (%f, %e, %g), to an ASCII file.
fprintfVector :: FilePath -> String -> Vector Double -> IO ()
fprintfVector filename fmt v = do
    charname <- newCString filename
    charfmt <- newCString fmt
    app1 (gsl_vector_fprintf charname charfmt) vec v "gsl_vector_fprintf"
    free charname
    free charfmt

foreign import ccall unsafe "vector_fprintf" gsl_vector_fprintf :: Ptr CChar -> Ptr CChar -> TV

-- | Loads a vector from a binary file (the number of elements must be known in advance).
freadVector :: FilePath -> Int -> IO (Vector Double)
freadVector filename n = do
    charname <- newCString filename
    res <- createVector n
    app1 (gsl_vector_fread charname) vec res "gsl_vector_fread"
    free charname
    return res

foreign import ccall unsafe "vector_fread" gsl_vector_fread:: Ptr CChar -> TV

-- | Saves the elements of a vector to a binary file.
fwriteVector :: FilePath -> Vector Double -> IO ()
fwriteVector filename v = do
    charname <- newCString filename
    app1 (gsl_vector_fwrite charname) vec v "gsl_vector_fwrite"
    free charname

foreign import ccall unsafe "vector_fwrite" gsl_vector_fwrite :: Ptr CChar -> TV


module Math.HiddenMarkovModel.CSV where

import qualified Numeric.LinearAlgebra.Algorithms as Algo
import qualified Data.Packed.Matrix as Matrix
import qualified Data.Packed.Vector as Vector
import Data.Packed.Matrix (Matrix)
import Data.Packed.Vector (Vector)

import qualified Text.CSV.Lazy.String as CSV
import Text.Read.HT (maybeRead)
import Text.Printf (printf)

import qualified Control.Monad.Exception.Synchronous as ME
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import Control.Monad.Exception.Synchronous (Exceptional)
import Control.Monad (liftM2, replicateM, unless)

import qualified Data.List.HT as ListHT

cellsFromVector ::
   (Show a, Algo.Field a) =>
   Vector a -> [String]
cellsFromVector = map show . Vector.toList

cellsFromMatrix ::
   (Show a, Matrix.Element a) =>
   Matrix.Matrix a -> [[String]]
cellsFromMatrix = map (map show) . Matrix.toLists

padTable :: a -> [[a]] -> [[a]]
padTable x xs =
   let width = maximum (map length xs)
   in  map (ListHT.padRight x width) xs

type CSVParser = MS.StateT CSV.CSVResult (Exceptional String)

assert :: Bool -> String -> CSVParser ()
assert cond msg =
   unless cond $ MT.lift $ ME.throw msg

retrieveShortRow :: CSV.CSVError -> Maybe CSV.CSVRow
retrieveShortRow err =
   case err of
      CSV.IncorrectRow {CSV.csvFields = row} -> Just row
      _ -> Nothing

fixShortRow ::
   Either [CSV.CSVError] CSV.CSVRow -> Either [CSV.CSVError] CSV.CSVRow
fixShortRow erow =
   case erow of
      Left errs ->
         case ListHT.partitionMaybe retrieveShortRow errs of
            ([row], []) -> Right row
            _ -> Left errs
      _ -> erow

maybeGetRow :: CSVParser (Maybe CSV.CSVRow)
maybeGetRow = do
   csv0 <- MS.get
   case csv0 of
      [] -> return Nothing
      item : csv1 -> do
         MS.put csv1
         case item of
            Right row -> return (Just row)
            Left errors ->
               MT.lift $ ME.throw $ unlines $ map CSV.ppCSVError errors

getRow :: CSVParser CSV.CSVRow
getRow =
   MT.lift . ME.fromMaybe "unexpected end of file" =<< maybeGetRow

checkEmptyRow :: CSV.CSVRow -> Exceptional String ()
checkEmptyRow row =
   case filter (not . null . CSV.csvFieldContent) row of
      [] -> return ()
      cell:_ -> ME.throw $ printf "%d: expected empty row" (CSV.csvRowNum cell)

skipEmptyRow :: CSVParser ()
skipEmptyRow  =  MT.lift . checkEmptyRow =<< getRow

manySepUntilEnd :: CSVParser a -> CSVParser [a]
manySepUntilEnd p =
   let go = liftM2 (:) p $ do
          mrow <- maybeGetRow
          case mrow of
             Nothing -> return []
             Just row -> do
                MT.lift $ checkEmptyRow row
                go
   in  go

manyRowsUntilEnd :: (CSV.CSVRow -> CSVParser a) -> CSVParser [a]
manyRowsUntilEnd p =
   let go = do
          mrow <- maybeGetRow
          case mrow of
             Nothing -> return []
             Just row -> liftM2 (:) (p row) go
   in  go

parseVectorCells ::
   (Read a, Algo.Field a) =>
   CSVParser (Vector a)
parseVectorCells =
   parseVectorFields =<< getRow

parseVectorFields ::
   (Read a, Algo.Field a) =>
   CSV.CSVRow -> CSVParser (Vector a)
parseVectorFields =
   MT.lift . fmap Vector.fromList . mapM parseNumberCell .
   ListHT.dropWhileRev (null . CSV.csvFieldContent)

parseNonEmptyVectorCells ::
   (Read a, Algo.Field a) =>
   CSVParser (Vector a)
parseNonEmptyVectorCells = do
   v <- parseVectorCells
   assert (Vector.dim v > 0) "no data for vector"
   return v

cellContent :: CSV.CSVField -> Exceptional String String
cellContent field =
   case field of
      CSV.CSVFieldError {} -> ME.throw $ CSV.ppCSVField field
      CSV.CSVField { CSV.csvFieldContent = str } -> return str

parseNumberCell :: (Read a) => CSV.CSVField -> Exceptional String a
parseNumberCell field = do
   str <- cellContent field
   ME.fromMaybe (printf "field content \"%s\" is not a number" str) $
      maybeRead str

parseSquareMatrixCells ::
   (Read a, Algo.Field a) =>
   Int -> CSVParser (Matrix a)
parseSquareMatrixCells n = do
   rows <- replicateM n parseVectorCells
   assert (not $ null rows) "no rows"
   assert (all ((n==) . Vector.dim) rows) "inconsistent matrix dimensions"
   return $ Matrix.fromRows rows

parseStringList ::
   CSV.CSVRow -> CSVParser [String]
parseStringList =
   MT.lift . mapM cellContent .
   ListHT.dropWhileRev (null . CSV.csvFieldContent)


-- |
-- Module      : Test.LeanCheck.Function.ShowFunction
-- Copyright   : (c) 2015-2018 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- This module is part of LeanCheck,
-- a simple enumerative property-based testing library.
--
-- This module exports the 'ShowFunction' typeclass,
-- its instances and related functions.
--
-- Using this module, it is possible to implement
-- a 'Show' instance for functions:
--
-- > import Test.LeanCheck.ShowFunction
-- > instance (Show a, Listable a, ShowFunction b) => Show (a->b) where
-- >   show = showFunction 8
--
-- This shows functions as a case pattern with up to 8 cases.
--
-- It will only work for functions whose ultimate return value is an instance
-- of 'ShowFunction'.  This module provides instances for most standard data
-- types ('Int', 'Bool', 'Maybe', ...).  Please see the 'ShowFunction'
-- typeclass documentation for how to declare istances for user-defined data
-- types.
--
-- The modules
-- "Test.LeanCheck.Function"
-- and
-- "Test.LeanCheck.Function.Show"
-- exports an instance like the one above.
{-# LANGUAGE CPP #-}
module Test.LeanCheck.Function.ShowFunction
  (
  -- * Showing functions
    showFunction
  , showFunctionLine

  -- * Support for user-defined algebraic datatypes on return values
  , ShowFunction (..)
  , bindtiersShow

  -- * Listing functional bindings
  , Binding
  , bindings

  -- * Pipeline for explaining, describing and clarifying bindings
  , explainedBindings
  , describedBindings
  , clarifiedBindings

  -- * Re-exports
  , Listable
  )
where

import Test.LeanCheck.Core
import Test.LeanCheck.Error (errorToNothing)
import Test.LeanCheck.Utils.Types
import Test.LeanCheck.Stats (classifyOn)
import Data.List (intercalate, sortBy)
import Data.Maybe
import Data.Function (on)
import Data.Word
import Data.Int
import Data.Ratio
import Data.Complex
import Data.Char (GeneralCategory)
import System.Exit (ExitCode)
import System.IO (IOMode, BufferMode, SeekMode)
import Foreign.C

-- | A functional binding in a showable format.
--   Argument values are represented as a list of strings.
--   The result value is represented by 'Just' a 'String' when defined
--   or by 'Nothing' when 'undefined'.
type Binding = ([String], Maybe String)

-- | 'ShowFunction' values are those for which
--   we can return a list of functional bindings.
--
-- Instances for 'show'able algebraic datatypes are defined using
-- 'bindtiersShow':
--
-- > instance ShowFunction Ty where bindtiers = bindtiersShow
class ShowFunction a where
  bindtiers :: a -> [[Binding]]

-- | Given a 'ShowFunction' value, return a list of 'Binding's.
--   If the domain of the given argument function is infinite,
--   the resulting list is infinite.
--
-- Some examples follow.  These are used as running examples in the definition
-- of 'explainedBindings', 'describedBindings' and 'clarifiedBindings'.
--
-- * Defined return values are represented as 'Just' 'String's:
--
--     > > bindings True
--     > [([],Just "True")]
--
-- * Undefined return values are represented as @Nothing@:
--
--     > > bindings undefined
--     > [([],Nothing)]
--
-- * Infinite domains result in an infinite bindings list:
--
--     > > bindings (id::Int->Int)
--     > [ (["0"], Just "0")
--     > , (["1"], Just "1")
--     > , (["-1"], Just "-1")
--     > , ...
--     > ]
--
-- * Finite domains result in a finite bindings list:
--
--     > > bindings (&&)
--     > [ (["False","False"], Just "False")
--     > , (["False","True"], Just "False")
--     > , (["True","False"], Just "False")
--     > , (["True","True"], Just "True")
--     > ]
--
--     > > bindings (||)
--     > [ (["False","False"], Just "False")
--     > , (["False","True"], Just "True")
--     > , (["True","False"], Just "True")
--     > , (["True","True"], Just "True")
--     > ]
--
-- * Even very simple functions are represented by an infinite list of bindings:
--
--     > > bindings (== 0)
--     > [ (["0"], Just "True")
--     > , (["1"], Just "False")
--     > , (["-1"], Just "False")
--     > , ...
--     > ]
--
--     > > bindings (== 1)
--     > [ (["0"], Just "False")
--     > , (["1"], Just "True")
--     > , (["-1"], Just "False")
--     > , ...
--     > ]
--
-- * Ignored arguments are still listed:
--
--     > > bindings ((\_ y -> y == 1) :: Int -> Int -> Bool)
--     > [ (["0","0"], Just "False")
--     > , (["0","1"], Just "True")
--     > , (["1","0"], Just "False")
--     > , ...
--     > ]
--
-- * Again, undefined values are represented as 'Nothing'.
--   Here, the 'head' of an empty list is undefined:
--
--     > > bindings (head :: [Int] -> Int)
--     > [ (["[]"], Nothing)
--     > , (["[0]"], Just "0")
--     > , (["[0,0]"], Just "0")
--     > , (["[1]"], Just "1")
--     > , ...
--     > ]
bindings :: ShowFunction a => a -> [Binding]
bindings = concat . bindtiers

-- | A drop-in implementation of 'bindtiers' for 'show'able types.
--
-- Define instances for 'show'able algebraic datatypes as:
--
-- > instance ShowFunction Ty where bindtiers = bindtiersShow
bindtiersShow :: Show a => a -> [[Binding]]
bindtiersShow x = [[([],errorToNothing $ show x)]]

instance ShowFunction ()       where bindtiers = bindtiersShow
instance ShowFunction Bool     where bindtiers = bindtiersShow
instance ShowFunction Int      where bindtiers = bindtiersShow
instance ShowFunction Word     where bindtiers = bindtiersShow
instance ShowFunction Integer  where bindtiers = bindtiersShow
instance ShowFunction Char     where bindtiers = bindtiersShow
instance ShowFunction Float    where bindtiers = bindtiersShow
instance ShowFunction Double   where bindtiers = bindtiersShow
instance ShowFunction Ordering where bindtiers = bindtiersShow
instance Show a => ShowFunction [a]       where bindtiers = bindtiersShow
instance Show a => ShowFunction (Maybe a) where bindtiers = bindtiersShow
instance (Show a, Show b) => ShowFunction (Either a b) where bindtiers = bindtiersShow
instance (Show a, Show b) => ShowFunction (a,b) where bindtiers = bindtiersShow

-- instance for functional value type --
instance (Show a, Listable a, ShowFunction b) => ShowFunction (a->b) where
  bindtiers f = concatMapT bindtiersFor tiers
    where bindtiersFor x = mapFst (show x:) `mapT` bindtiers (f x)
          mapFst f (x,y) = (f x, y)

paren :: String -> String
paren s = "(" ++ s ++ ")"

showTuple :: [String] -> String
showTuple [x]  =  x
showTuple xs | all (== "_") xs  =  "_"
             | otherwise        =  paren $ intercalate "," xs

showBindings :: [Binding] -> [String]
showBindings bs = [ showTuple as ++ " -> " ++ r | (as, Just r) <- bs ]

showNBindings :: Bool -> Int -> [Binding] -> [String]
showNBindings infinite n bs' = take n bs ++ ["..." | infinite || length bs > n]
  where
  bs = showBindings bs'

isValue :: ShowFunction a => a -> Bool
isValue f = case bindings f of
              [([],_)] -> True
              _        -> False

showValueOf :: ShowFunction a => a -> String
showValueOf x = case snd . head . bindings $ x of
                  Nothing -> "undefined"
                  Just x' -> x'

-- | Given the number of patterns to show, shows a 'ShowFunction' value.
--
-- > > putStrLn $ showFunction undefined True
-- > True
-- >
-- > > putStrLn $ showFunction 3 (id::Int->Int)
-- > \x -> case x of
-- >       0 -> 0
-- >       1 -> 1
-- >       -1 -> -1
-- >       ...
-- >
-- > > putStrLn $ showFunction 4 (&&)
-- > \x y -> case (x,y) of
-- >         (True,True) -> True
-- >         _ -> False
-- >
--
-- In the examples above, "@...@" should be interpreted literally.
--
-- This can be used as an implementation of 'show' for functions:
--
-- > instance (Show a, Listable a, ShowFunction b) => Show (a->b) where
-- >   show = showFunction 8
--
-- See 'showFunctionLine' for an alternative without line breaks.
showFunction :: ShowFunction a => Int -> a -> String
showFunction n = showFunctionL False (n*n+1) n

-- | Same as 'showFunction', but has no line breaks.
--
-- > > putStrLn $ showFunctionLine 3 (id::Int->Int)
-- > \x -> case x of 0 -> 0; 1 -> 1; -1 -> -1; ...
-- > > putStrLn $ showFunctionLine 3 (&&)
-- > \x y -> case (x,y) of (True,True) -> True; _ -> False
--
-- This can be used as an implementation of 'show' for functions:
--
-- > instance (Show a, Listable a, ShowFunction b) => Show (a->b) where
-- >   show = showFunction 8
showFunctionLine :: ShowFunction a => Int -> a -> String
showFunctionLine n = showFunctionL True (n*n+1) n

-- | isUndefined checks if a function is totally undefined
--   for the given maximum number of values
isUndefined :: ShowFunction a => Int -> a -> Bool
isUndefined m = all (isNothing . snd) . take m . bindings

-- | checks if a function is constant
--   for the given maximum number of values
isConstant :: ShowFunction a => Int -> a -> Bool
isConstant m f = case take m $ bindings f of
                 []          -> False -- uninhabited type?
                 ((_,r'):bs) -> all (\(_,r) -> r == r') bs

-- | shows a constant function
showConstant :: ShowFunction a => Int -> a -> String
showConstant m f = "\\" ++ unwords vs ++ " -> " ++ fromMaybe "undefined" r
  where
  (as,r) = head $ bindings f
  vs = replicate (length as) "_"

-- The first boolean parameter tells if we are showing
-- the function on a single line
showFunctionL :: ShowFunction a => Bool -> Int -> Int -> a -> String
showFunctionL singleLine m n f | isValue f = showValueOf f
showFunctionL singleLine m n f | isConstant m f = showConstant m f
--showFunctionL singleLine m n f | canName m f = showName m f
showFunctionL singleLine m n f | otherwise = lambdaPat ++ caseExp
  where
    lambdaPat = "\\" ++ unwords vs ++ " -> "
    casePat = "case " ++ showTuple (filter (/= "_") vs) ++ " of"
    (vs, bindings) = clarifiedBindings m n f
    bs = showNBindings (length bindings >= m) n bindings
    sep | singleLine = " "
        | otherwise = "\n"
    cases | singleLine = intercalate "; " bs
          | otherwise  = unlines
                       $ (replicate (length lambdaPat) ' ' ++) `map` bs
    caseExp = if isUndefined m f
                then "undefined"
                else casePat ++ sep ++ cases

-- instances for further tuple arities --
instance (Show a, Show b, Show c)
      => ShowFunction (a,b,c) where bindtiers = bindtiersShow
instance (Show a, Show b, Show c, Show d)
      => ShowFunction (a,b,c,d) where bindtiers = bindtiersShow
instance (Show a, Show b, Show c, Show d, Show e)
      => ShowFunction (a,b,c,d,e) where bindtiers = bindtiersShow
instance (Show a, Show b, Show c, Show d, Show e, Show f)
      => ShowFunction (a,b,c,d,e,f) where bindtiers = bindtiersShow
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g)
      => ShowFunction (a,b,c,d,e,f,g) where bindtiers = bindtiersShow
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h)
      => ShowFunction (a,b,c,d,e,f,g,h) where bindtiers = bindtiersShow
instance ( Show a, Show b, Show c, Show d
         , Show e, Show f, Show g, Show h
         , Show i )
      => ShowFunction (a,b,c,d,e,f,g,h,i) where bindtiers = bindtiersShow
instance ( Show a, Show b, Show c, Show d
         , Show e, Show f, Show g, Show h
         , Show i, Show j )
      => ShowFunction (a,b,c,d,e,f,g,h,i,j) where bindtiers = bindtiersShow
instance ( Show a, Show b, Show c, Show d
         , Show e, Show f, Show g, Show h
         , Show i, Show j, Show k )
      => ShowFunction (a,b,c,d,e,f,g,h,i,j,k) where bindtiers = bindtiersShow
instance ( Show a, Show b, Show c, Show d
         , Show e, Show f, Show g, Show h
         , Show i, Show j, Show k, Show l )
      => ShowFunction (a,b,c,d,e,f,g,h,i,j,k,l) where bindtiers = bindtiersShow

-- Data.Ratio
instance (Integral a, Show a) => ShowFunction (Ratio a) where bindtiers = bindtiersShow

-- Data.Complex
instance (RealFloat a, Show a) => ShowFunction (Complex a) where bindtiers = bindtiersShow

-- instance for types from Data.Int and Data.Word
instance ShowFunction Int8  where bindtiers = bindtiersShow
instance ShowFunction Int16 where bindtiers = bindtiersShow
instance ShowFunction Int32 where bindtiers = bindtiersShow
instance ShowFunction Int64 where bindtiers = bindtiersShow
instance ShowFunction Word8  where bindtiers = bindtiersShow
instance ShowFunction Word16 where bindtiers = bindtiersShow
instance ShowFunction Word32 where bindtiers = bindtiersShow
instance ShowFunction Word64 where bindtiers = bindtiersShow

-- instance for types from Test.LeanCheck.Utils.Types
instance ShowFunction Nat   where bindtiers = bindtiersShow
instance ShowFunction Nat1  where bindtiers = bindtiersShow
instance ShowFunction Nat2  where bindtiers = bindtiersShow
instance ShowFunction Nat3  where bindtiers = bindtiersShow
instance ShowFunction Nat4  where bindtiers = bindtiersShow
instance ShowFunction Nat5  where bindtiers = bindtiersShow
instance ShowFunction Nat6  where bindtiers = bindtiersShow
instance ShowFunction Nat7  where bindtiers = bindtiersShow
instance ShowFunction Int1  where bindtiers = bindtiersShow
instance ShowFunction Int2  where bindtiers = bindtiersShow
instance ShowFunction Int3  where bindtiers = bindtiersShow
instance ShowFunction Int4  where bindtiers = bindtiersShow
instance ShowFunction Word1 where bindtiers = bindtiersShow
instance ShowFunction Word2 where bindtiers = bindtiersShow
instance ShowFunction Word3 where bindtiers = bindtiersShow
instance ShowFunction Word4 where bindtiers = bindtiersShow

instance ShowFunction Natural where bindtiers = bindtiersShow

instance ShowFunction Letter    where bindtiers = bindtiersShow
instance ShowFunction AlphaNum  where bindtiers = bindtiersShow
instance ShowFunction Digit     where bindtiers = bindtiersShow
instance ShowFunction Alpha     where bindtiers = bindtiersShow
instance ShowFunction Upper     where bindtiers = bindtiersShow
instance ShowFunction Lower     where bindtiers = bindtiersShow
instance ShowFunction Space     where bindtiers = bindtiersShow

instance ShowFunction Spaces    where bindtiers = bindtiersShow
instance ShowFunction Lowers    where bindtiers = bindtiersShow
instance ShowFunction Uppers    where bindtiers = bindtiersShow
instance ShowFunction Alphas    where bindtiers = bindtiersShow
instance ShowFunction Digits    where bindtiers = bindtiersShow
instance ShowFunction AlphaNums where bindtiers = bindtiersShow
instance ShowFunction Letters   where bindtiers = bindtiersShow

instance Show a => ShowFunction (X a) where bindtiers = bindtiersShow
instance Show a => ShowFunction (Xs a) where bindtiers = bindtiersShow
instance Show a => ShowFunction (Set a) where bindtiers = bindtiersShow
instance Show a => ShowFunction (Bag a) where bindtiers = bindtiersShow
instance Show a => ShowFunction (NoDup a) where bindtiers = bindtiersShow
instance (Show a, Show b) => ShowFunction (Map a b) where bindtiers = bindtiersShow

-- misc instances
instance ShowFunction ExitCode   where bindtiers = bindtiersShow
instance ShowFunction SeekMode   where bindtiers = bindtiersShow
instance ShowFunction IOMode     where bindtiers = bindtiersShow
instance ShowFunction BufferMode where bindtiers = bindtiersShow
instance ShowFunction GeneralCategory where bindtiers = bindtiersShow

-- instances for Foreign.C types
instance ShowFunction CChar      where bindtiers = bindtiersShow
instance ShowFunction CSChar     where bindtiers = bindtiersShow
instance ShowFunction CUChar     where bindtiers = bindtiersShow
instance ShowFunction CShort     where bindtiers = bindtiersShow
instance ShowFunction CUShort    where bindtiers = bindtiersShow
instance ShowFunction CInt       where bindtiers = bindtiersShow
instance ShowFunction CUInt      where bindtiers = bindtiersShow
instance ShowFunction CLong      where bindtiers = bindtiersShow
instance ShowFunction CULong     where bindtiers = bindtiersShow
instance ShowFunction CPtrdiff   where bindtiers = bindtiersShow
instance ShowFunction CSize      where bindtiers = bindtiersShow
instance ShowFunction CWchar     where bindtiers = bindtiersShow
instance ShowFunction CSigAtomic where bindtiers = bindtiersShow
instance ShowFunction CLLong     where bindtiers = bindtiersShow
instance ShowFunction CULLong    where bindtiers = bindtiersShow
instance ShowFunction CIntPtr    where bindtiers = bindtiersShow
instance ShowFunction CUIntPtr   where bindtiers = bindtiersShow
instance ShowFunction CIntMax    where bindtiers = bindtiersShow
instance ShowFunction CUIntMax   where bindtiers = bindtiersShow
instance ShowFunction CClock     where bindtiers = bindtiersShow
instance ShowFunction CTime      where bindtiers = bindtiersShow
instance ShowFunction CFloat     where bindtiers = bindtiersShow
instance ShowFunction CDouble    where bindtiers = bindtiersShow
#if __GLASGOW_HASKELL__ >= 802
instance ShowFunction CBool      where bindtiers = bindtiersShow
#endif
#if __GLASGOW_HASKELL__
instance ShowFunction CUSeconds  where bindtiers = bindtiersShow
instance ShowFunction CSUSeconds where bindtiers = bindtiersShow
#endif

-- | Returns a set of variables and a set of bindings
--   describing how a function works.
--
-- Some argument values are generalized to "@_@" when possible.
-- If one of the function arguments is not used altogether, it is ommited in
-- the set of bindings and appears as "_" in the variables list.
--
-- This is the /last/ function in the clarification pipeline.
--
-- It takes two integer arguments:
--
-- 1. @m@: the maximum number of cases considered for computing the description;
-- 2. @n@: the maximum number of cases in the actual description.
--
-- As a general rule of thumb, set @m=n*n+1@.
--
-- Some examples follow:
--
-- * When all arguments are used, the result is the same as 'describedBindings':
--
--     > > clarifiedBindings 100 10 (==1)
--     > ( ["x"], [ (["1"],Just "True"),
--     >          , (["_"],Just "False") ] )
--
-- * When some arguments are unused, they are omitted in the list of bindings and
--   appear as @"_"@ in the list of variables.
--
--     > > clarifiedBindings 100 10 (\_ y -> y == 1)
--     > ( ["_", "y"], [ (["1"],Just "True")
--     >               , (["_"],Just "False") ] )
clarifiedBindings :: ShowFunction a => Int -> Int -> a -> ([String],[Binding])
clarifiedBindings m n = clarifyBindings . describedBindings m n

clarifyBindings :: [Binding] -> ([String],[Binding])
clarifyBindings bs  =  (varnamesByUsage used, map (mapFst $ select used) bs)
  where
  mapFst f (x,y) = (f x, y)
  used = usedArgs bs

varnamesByUsage :: [Bool] -> [String]
varnamesByUsage = zipWith used varnames
  where
  used s False = "_"
  used s True  = s
  varnames = ["x","y","z","w"] ++ map (++"'") varnames

usedArgs :: [Binding] -> [Bool]
usedArgs = foldr1 (zipWith (||))
         . map (map (/= "_") . fst)

-- | Returns a set of bindings describing how a function works.
-- Some argument values are generalized to "@_@" when possible.
-- It takes two integer arguments:
--
-- 1. @m@: the maximum number of cases considered for computing description;
-- 2. @n@: the maximum number of cases in the actual description.
--
-- As a general rule of thumb, set @m=n*n+1@.
--
-- This is the /second/ function in the clarification pipeline.
--
-- This function processes the result of 'explainedBindings'
-- to sometimes return shorter descriptions.
-- It chooses the shortest of the following (in order):
--
-- * regular unexplained-undescribed 'bindings';
-- * regular 'explainedBindings';
-- * 'explainedBindings' with least occurring cases generalized first;
--
-- Here are some examples:
--
-- * Sometimes the result is the same as 'explainedBindings':
--
--     > > describedBindings 100 10 (||)
--     > [ (["False","False"],Just "False")
--     > , (["_","_"],Just "True") ]
--
--     > > describedBindings 100 10 (==0)
--     > [ (["0"],Just "True")
--     > , (["_"],Just "False") ]
--
-- * but sometimes it is shorter because we consider generalizing least
--   occurring cases first:
--
--     > > describedBindings 100 10 (&&)
--     > [ ( ["True","True"],Just "True")
--     > , ( ["_","_"],Just "False") ]
--
--     > > describedBindings 100 10 (==1)
--     > [ (["1"],Just "True"),
--     > , (["_"],Just "False") ]
--
--     > > describedBindings 100 10 (\_ y -> y == 1)
--     > [ (["_","1"],Just "True")
--     > , (["_","_"],Just "False") ]
describedBindings :: ShowFunction a => Int -> Int -> a -> [Binding]
describedBindings m n f
  | length bs1 <= n  =  bs1
  | otherwise        =  bs0
  where
  bs0  =  take m $ bindings f
  bs1  =  describeBindings bs0

describeBindings :: [Binding] -> [Binding]
describeBindings bs = head $ sortOn length $
  [ bs
  , explainBindings bs
  , explainBindings . concat . sortOn length $ classifyOn snd bs
  ]

-- | Returns a set of bindings explaining how a function works.
--   Some argument values are generalized to "@_@" when possible.
--   It takes as argument the maximum number of cases
--   considered for computing the explanation.
--
-- A measure of success in this generalization process is if this function
-- returns less values than the asked maximum number of cases.
--
-- This is the /first/ function in the clarification pipeline.
--
-- * In some cases, 'bindings' cannot be "explained"
--   an almost unchanged result of 'bindings' is returned
--   with the last binding having variables replaced by "@_@":
--
--     > > explainedBindings 4 (id::Int->Int)
--     > [ (["0"],Just "0")
--     > , (["1"],Just "1")
--     > , (["-1"],Just "-1")
--     > , (["_"],Just "2") ]
--
-- * When possible, some cases are generalized using @_@:
--
--     > > explainedBindings 10 (||)
--     > [ (["False","False"],Just "False")
--     > , (["_","_"],Just "True") ]
--
--     but the resulting "explanation" might not be the shortest possible
--     (cf. 'describedBindings'):
--
--     > > explainedBindings 10 (&&)
--     > [ ( ["False","_"],Just "False")
--     > , (["_","False"],Just "False")
--     > , (["_","_"],Just "True") ]
--
-- * Generalization works for infinite domains (heuristically):
--
--     > > explainedBindings 10 (==0)
--     > [ (["0"],Just "True")
--     > , (["_"],Just "False") ]
--
-- * Generalization for each item is processed in the order they are generated by 'bindings'
--   hence explanations are not always the shortest possible (cf. 'describedBindings').
--   In the following examples, the first case is redundant.
--
--     > > explainedBindings 10 (==1)
--     > [ (["0"],Just "False")
--     > , (["1"],Just "True"),
--     > , (["_"],Just "False") ]
--
--     > > explainedBindings 10 (\_ y -> y == 1)
--     > [ (["_","0"],Just "False")
--     > , (["_","1"],Just "True")
--     > , (["_","_"],Just "False") ]
explainedBindings :: ShowFunction a => Int -> a -> [Binding]
explainedBindings m = explainBindings . take m . bindings

explainBindings :: [Binding] -> [Binding]
explainBindings = explain []
  where
  explain :: [Binding] -> [Binding] -> [Binding]
  explain bs' []           =  reverse bs'
  explain bs' ((as,r):bs)  =  explain (bs''++bs') [b | b <- bs, none (b <~~) bs'']
    where
    bs'' = discardLater (<~~)
         [ (gas,r) | gas <- generalizations as
                   , and [r' == r | (as',r') <- bs, as' <~ gas] ]

generalizations :: [String] -> [[String]]
generalizations []     = [[]]
generalizations (v:vs) = map ("_":) gvs ++ map (v:) gvs
  where
  gvs = generalizations vs

-- | Should be read as "is generalized by":
--
-- > > ["1","2","3"] <~ ["_","_","_"]
-- > True
-- > > ["_","_","_"] <~ ["1","2","3"]
-- > False
-- > > ["1","3"] <~ ["_","3"]
-- > True
-- > > ["_","3"] <~ ["_","4"]
-- > False
(<~) :: [String] -> [String] -> Bool
[]     <~ []       =  True
(v:vs) <~ ("_":ws) =  vs <~ ws
(v:vs) <~ (w:ws)   =  v == w && vs <~ ws
_      <~ _        =  False

-- | Should be read as "is generalized by".
(<~~) :: Binding -> Binding -> Bool
(as,r) <~~ (as',r') = as <~ as' && r == r'

-- general auxiliary functions

discard :: (a -> Bool) -> [a] -> [a]
discard p = filter (not . p)

discardLater :: (a -> a -> Bool) -> [a] -> [a]
discardLater (?>) = dl
  where
  dl []     = []
  dl (x:xs) = x : discard (?> x) (dl xs)

none :: (a -> Bool) -> [a] -> Bool
none p = not . any p

-- sortOn is only available on GHC > 7.8
sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f = sortBy (compare `on` f)

select :: [Bool] -> [a] -> [a]
select [] _ = []
select _ [] = []
select (p:ps) (x:xs) = if p then x : xs' else xs' where xs' = select ps xs


{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE TypeFamilies              #-}

import           Control.Applicative
import           Control.Monad
import           Graphics.Image               hiding (map, on)
import           Numeric.LinearAlgebra.Static (L, fromList, (===))
import           Options.Applicative

import           Grenade
import           Grenade.Utils.PascalVoc

data TinyYoloV2Options = TinyYoloV2Options FilePath  -- onnx file
                                           FilePath  -- image path

pTinyYoloV2 :: Parser TinyYoloV2Options
pTinyYoloV2 = TinyYoloV2Options <$> argument str (metavar "onnx") <*> argument str (metavar "image")

loadTinyYoloImage :: FilePath -> IO (Maybe (S ('D3 416 416 3)))
loadTinyYoloImage path = do
  img <- readImageRGB VU path
  displayImage img
  return $ do
    guard $ dims img == (416, 416)
    let [reds, greens, blues] = map (fromList . map (\(PixelX y) -> doubleToRealNum y) . concat . toLists)
                              $ toImagesX img :: [L 416 416]
    return $ S3D $ reds === greens === blues

main :: IO ()
main = do
    TinyYoloV2Options netPath imgPath <- execParser (info (pTinyYoloV2 <**> helper) idm)
    res  <- loadTinyYoloV2 netPath
    imgM <- loadTinyYoloImage imgPath

    case (res, imgM) of
      (Right net, Just img) -> do
        putStrLn "Succesfully loaded image and network"
        print $ processOutput (runNet net img) 0.3 0.5

      (Left err, _) -> print err
      _             -> print "Error loading image"


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

module Main where

import Wyas.Parser
import Wyas.Evaluator
import Wyas.Types
import Wyas.Error

import Test.Tasty
import Test.Tasty.HUnit

import Data.Ratio ((%))
import Data.Complex (Complex((:+)))
import Data.Vector (fromList)

testTypeParsing = testGroup "type parsing tests"
  [ testCase "parse decimal point number"
        $ (extractValue . readExpr) "3"
        @?= Number 3

  , testCase "parse floating point number"
        $ (extractValue . readExpr) "42.0"
        @?= Float 42.0

  , testCase "parse rational number"
        $ (extractValue . readExpr) "3/4"
        @?= (Ratio $ 3 % 4)

  , testCase "parse complex number (decimal)"
        $ (extractValue . readExpr) "3+1i"
        @?= (Complex $ 3.0 :+ 1.0)

  , testCase "parse complex number (floating)"
        $ (extractValue . readExpr) "3.0+1.0i"
        @?= (Complex $ 3.0 :+ 1.0)

  , testCase "parse number (binary prefix)"
        $ (extractValue . readExpr) "#b1000"
        @?= Number 8

  , testCase "parse number (hex prefix)"
        $ (extractValue . readExpr) "#xFF"
        @?= Number 255

  , testCase "parse number (oct prefix)"
        $ (extractValue . readExpr) "#o7"
        @?= Number 7

  , testCase "parse char"
        $ (extractValue . readExpr) "#\\a"
        @?= Character 'a'

  , testCase "parse space char"
        $ (extractValue . readExpr) "#\\ "
        @?= Character ' '

  , testCase "parse special newline char"
        $ (extractValue . readExpr) "#\\newline"
        @?= Character '\n'

  , testCase "parse special space char"
        $ (extractValue . readExpr) "#\\space"
        @?= Character ' '

  , testCase "parse string"
        $ (extractValue . readExpr) "\"test 123\""
        @?= String "test 123"

  , testCase "parse escaped quote in string"
        $ (extractValue . readExpr) "\"\\\"\""
        @?= String "\""

  , testCase "parse quote in string"
        $ (extractValue . readExpr) "\"test \\\"123\\\" test\""
        @?= String "test \"123\" test"

  , testCase "parse backslash in string"
        $ (extractValue . readExpr) "\"te\\\\st\""
        @?= String "te\\st"

  , testCase "parse newline in string"
        $ (extractValue . readExpr) "\"te\nst\""
        @?= String "te\nst"

  , testCase "parse atom"
        $ (extractValue . readExpr) "test_func123"
        @?= Atom "test_func123"

  , testCase "parse bool (true)"
        $ (extractValue . readExpr) "#t"
        @?= Bool True

  , testCase "parse bool (false)"
        $ (extractValue . readExpr) "#f"
        @?= Bool False
  ]

testListParsing = testGroup "list parsing tests"
  [ testCase "parse simple list"
        $ (extractValue . readExpr) "(a b)"
        @?= List [Atom "a", Atom "b"]

  , testCase "parse nested list"
        $ (extractValue . readExpr) "(a (b) c)"
        @?= List [Atom "a",
                  List [Atom "b"],
                  Atom "c"]

  , testCase "parse dotted list"
        $ (extractValue . readExpr) "(a (b . c) d)"
        @?= List [Atom "a",
                  DottedList [(Atom "b")] (Atom "c"),
                  Atom "d"]

  , testCase "parse quoted dotted"
        $ (extractValue . readExpr) "(a '(b (c . d)) e)"
        @?= List [Atom "a",
                  List [Atom "quote",
                        List [Atom "b",
                              DottedList [(Atom "c")] (Atom "d")]],
                  Atom "e"]

  , testCase "parse quasiquoted list"
        $ (extractValue . readExpr) "`(a (b c))"
        @?= List [Atom "quasiquote",
                  List [Atom "a",
                        List [Atom "b", Atom "c"]]]

  , testCase "parse quasiquoted list (unquote)"
        $ (extractValue . readExpr) "`(a ,(b c) d)"
        @?= List [Atom "quasiquote",
                  List [Atom "a",
                        List [Atom "unquote",
                              List [Atom "b",
                                    Atom "c"]],
                        Atom "d"]]
  , testCase "parse vector"
        $ (extractValue . readExpr) "#(1 a 3)"
        @?= Vector (fromList [Number 1, Atom "a", Number 3])
  ]

testEvaluation = testGroup "evaluation tests"
  [ testCase "simple addition"
        $ extractValue (readExpr "(+ 2 2)" >>= eval)
        @?= Number 4
  , testCase "negative number"
        $ extractValue (readExpr "(+ 2 (-4 1))" >>= eval)
        @?= Number 2
  , testCase "nested calls"
        $ extractValue (readExpr "(+ 2 (- 4 1))" >>= eval)
        @?= Number 5
  , testCase "chained calls"
        $ extractValue (readExpr "(- (+ 4 6 3) 3 5 2)" >>= eval)
        @?= Number 3
  , testCase "check symbol?"
        $ extractValue (readExpr "(symbol? test)" >>= eval)
        @?= Bool True
  , testCase "check number?"
        $ extractValue (readExpr "(number? 3)" >>= eval)
        @?= Bool True
  , testCase "check string?"
        $ extractValue (readExpr "(string? \"test\")" >>= eval)
        @?= Bool True
  , testCase "symbol to string"
        $ extractValue (readExpr "(symbol->string test)" >>= eval)
        @?= String "test"
  ]

testBinop = testGroup "evaluate binops"
  [ testCase "less than (numbers)"
        $ extractValue (readExpr "(< 2 3)" >>= eval)
        @?= Bool True
  , testCase "greater than (numbers)"
        $ extractValue (readExpr "(> 2 3)" >>= eval)
        @?= Bool False
  , testCase "greater or equal than (numbers)"
        $ extractValue (readExpr "(>= 3 3)" >>= eval)
        @?= Bool True
  , testCase "string equality"
        $ extractValue (readExpr "(string=? \"test\" \"test\")" >>= eval)
        @?= Bool True
  , testCase "less than (strings)"
        $ extractValue (readExpr "(string<? \"abc\" \"bba\")" >>= eval)
        @?= Bool True
  , testCase "equal on lists"
        $ extractValue (readExpr "(equal? \'(1 \"2\") \'(1 2))" >>= eval)
        @?= Bool True
  ]

tests :: TestTree
tests = testGroup "Parser Tests" [ testTypeParsing
                                 , testListParsing
                                 , testEvaluation
                                 , testBinop
                                 ]

main = defaultMain tests


{-# LANGUAGE NamedFieldPuns #-}

module Word2Vec ( trainWith
                , mostSimilar
                , groupOf
                ) where

import Vocabulary
import Huffman
import Train
import Persistence

import Prelude hiding (lookup)
import Numeric.LinearAlgebra.Data (Matrix, Vector, loadMatrix, saveMatrix, cmap, size)
import qualified Numeric.LinearAlgebra.HMatrix as M
import qualified Numeric.LinearAlgebra.Devel as DV
import qualified Data.HashMap.Strict as HM
import qualified Data.IntMap.Strict as IM
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Foldable (fold)
import Control.Arrow (first)
import System.Random (getStdGen)
import System.IO

i2hFile = "i2h.txt"
i2wFile = "i2w.txt"
w2iFile = "w2i.txt"

-- | Train input-hidden weight matrix with sentences from a file.
trainWith :: FilePath -> Int -> IO ()
trainWith path num = do
  sentences <- take num <$> readGiganticLine path

  randGen <- getStdGen
  let (vocabulary, i2w, vocSize) = buildModel sentences
      huffman = encodeTree $ buildTree $ map snd $ HM.toList vocabulary
      vectorSize = 100
      matrices = buildMatrices randGen vocSize vectorSize
      config = Configuration {vocabulary, huffman, learningRate=0.025, vectorSize}
      (i2h, h2o) = train config matrices sentences

  saveMatrix i2hFile "%g" i2h
  saveI2W i2wFile i2w
  saveW2I w2iFile vocabulary

mostSimilar :: [String] -> IO ()
mostSimilar [] = putStrLn "Specify words."
mostSimilar words = do
  i2h <- normalizeMatrix <$> loadMatrix i2hFile
  i2w <- loadI2W i2wFile
  w2i <- loadW2I w2iFile
  mapM_ print $ take 5 $ findMostSimilar i2w w2i i2h words

findMostSimilar :: IM.IntMap String
                -> HM.HashMap String Int
                -> Matrix Double
                -> [String]
                -> [(String, Double)]
findMostSimilar i2w w2i i2h words = filter ((`notElem` nakedWords) . fst) similarWords
  where weightedWords = map weightedWord words
        nakedWords = map fst weightedWords
        similarities = M.toList $ M.app i2h (wordsMean w2i i2h weightedWords)
        indexSimilarities = sortBy (flip $ comparing snd) $ zip [0..] similarities
        similarWords = map (first (i2w IM.!)) indexSimilarities

-- | Normalized mean vector for multiple words.
wordsMean :: HM.HashMap String Int -> Matrix Double -> [(String, Double)] -> Vector Double
wordsMean w2i i2h words = meanVector vecs
  where vecs = map (\(s, w) -> M.scale w $ wordVector w2i i2h s) words

-- | Weigh a word according to its prefix.
weightedWord :: String -> (String, Double)
weightedWord word = case word of
  '+':rest -> (rest, 1)
  '-':rest -> (rest, -1)
  word     -> (word, 1)

-- | Return a vector for a word.
wordVector :: HM.HashMap String Int -> Matrix Double -> String -> Vector Double
wordVector w2i i2h = (i2h M.!) . (w2i HM.!)

-- | Normalized mean vector.
meanVector :: [Vector Double] -> Vector Double
meanVector vecs = M.scale (1 / magnitude' mean) mean
  where mean = sum vecs / fromIntegral (length vecs)

-- | Divide matrix values by each row vector's magnitude.
normalizeMatrix :: Matrix Double -> Matrix Double
normalizeMatrix mat = DV.runSTMatrix $ do
  m <- DV.thawMatrix mat
  mapM_ (uncurry $ modifyRow m) $ zip [0..] magnitudes
  return m
    where magnitudes = map magnitude' $ M.toRows mat
          colSize = M.cols mat
          modifyRow mm i mag = mapM_ (flip (DV.modifyMatrix mm i) (/ mag)) [0 .. colSize - 1]

-- | Calculate magnitude of a 'Vector'.
magnitude :: Vector Double -> Double
magnitude = sqrt . M.sumElements . (** 2)

-- | Calculate magnitude of a 'Vector'. Return 1 if magnitude is 0 not to
-- divide by 0.
magnitude' :: Vector Double -> Double
magnitude' v = if mag == 0 then 1 else mag
  where mag = magnitude v

-- | Read sentences from a normalized file.
readSentences :: FilePath -> IO [Sentence]
readSentences path = do
  contents <- readFile path
  return $ map words $ lines contents

-- | Read a gigantic line and split it into sentences by each 1000 words.
readGiganticLine :: FilePath -> IO [Sentence]
readGiganticLine path = do
  contents <- readFile path
  return $ groupOf 100 $ words contents

groupOf :: Int -> [a] -> [[a]]
groupOf _ [] = []
groupOf n xs = (\(f, s) -> f : groupOf n s) $ splitAt n xs

saveI2W :: FilePath -> Index2Word -> IO ()
saveI2W = saveIntMap (\(i, w) -> show i ++ " " ++ w)

saveW2I :: FilePath -> Vocabulary -> IO ()
saveW2I = saveHashMap (\(w, (i, _)) -> w ++ " " ++ show i)

loadI2W :: FilePath -> IO Index2Word
loadI2W = loadIntMap (\(i:w:_) -> (read i, w))

loadW2I :: FilePath -> IO (HM.HashMap String Int)
loadW2I = loadHashMap (\(w:i:_) -> (w, read i))


{-# language QuasiQuotes #-}
{- |
Module       : Main
Description  : Main entry point into FractalStream
-}
module Main where

import qualified Data.Color as FSColor
import UI.WX.Viewer
import Control.Concurrent
import Control.Monad.State
import Data.Planar
import Data.Complex
import Text.RawString.QQ

import Language.Code.Simulator
import Language.Type
import Language.Environment
import Language.Effect
import Language.Code.Parser
import Language.Value.Parser
import Data.Proxy

import Actor.Settings
import Actor.Tool
import Actor.Viewer
import Event
import Language.Effect.Draw
import Language.Effect.Render
import Language.Effect.Provide
import Language.Code
import Backend.LLVM

main :: IO ()
main = do
    tid <- myThreadId
    bound <- isCurrentThreadBound
    capInfo <- threadCapability tid
    putStrLn ("Hello from main, on thread " ++ show tid ++ " "
              ++ show capInfo ++ " " ++ show bound)
    wxMain
    putStrLn "main is done"

wxMain :: IO ()
wxMain = do
    tid <- myThreadId
    bound <- isCurrentThreadBound
    capInfo <- threadCapability tid
    putStrLn ("Hello from wxMain, on thread " ++ show tid ++ " " ++ show capInfo ++ " " ++ show bound)
    let env = declare @"maxIters" IntegerType
            $ declare @"maxRadius" RealType
            $ declare @"x" RealType
            $ declare @"y" RealType
            $ endOfDecls
    withCompiledCode env mandelProgram0 $ \kernel -> do
      let action bs ss dz z out = runJX kernel out (fromIntegral bs) (fromIntegral ss) dz 100 10 z
      wxView viewport action mainViewer
  where
    viewport = flippedRectangle (-2.5, 2) (1.5, -2)

flag :: String
flag = [r|
if x < -0.65 then
  dark green
else if x > 0.65 then
  orange
else
  white|]

grid :: String
grid = [r|
init z : C to x + i y
init fz : C to sin z
init dfz : C to cos z
init size : R to 0.01 * |dfz|
if |sin (pi re(fz))| < size or |sin (pi im(fz))| < size then
  light blue
else
  white|]

mandelProgram0 :: String
mandelProgram0 = [r|
init C : C to x + i y
init z : C to 0
init k : Z to 0
loop
  set z to z z + C
  set k to k + 1
  |z| < maxRadius and k < maxIters
if k = maxIters then
  black
else
  init c1 : Color to if im(z) > 0 then blue else yellow
  init c2 : Color to if im(z) > 0 then green else orange
  init s : R to k + 1 - (log (log (|z|^2) / 2)) / log 2
  set s to cos (s pi / 10)
  set s to s s
  blend (s, c1, c2)|]

juliaProgram0 :: String
juliaProgram0 = [r|
init C : C to -0.12256 + 0.74486i
init z : C to x + i y
init k : Z to 0
init r2 : R to maxRadius * maxRadius
loop
  set z to z z + C
  set k to k + 1
  re(z) re(z) + im(z) im(z) < r2 and k < maxIters
if k = maxIters then
  black
else
  init c1 : Color to if im(z) > 0 then blue else yellow
  init c2 : Color to if im(z) > 0 then green else orange
  init s : R to k + 1 - (log (log (|z|^2) / 2)) / log 2
  set s to cos (s pi / 10)
  set s to s s
  blend (s, c1, c2)
|]

mandelProgram :: String
mandelProgram = [r|
init C : C to -0.11 + 0.75i
init z : C to x + i y
init k : Z to 0
init r2 : R to maxRadius * maxRadius
loop
  set z to z z + C
  set k to k + 1
  |z|^2 < r2 and k < maxIters
if k >= maxIters then
  black
else
  init s : R to k + 1 - (log ((log (|z|^2)) / 2)) / log 2
  set s to mod(s, 10) / 10
  init c1 : Color to blue
  init c2 : Color to white
  if im z > 0 then
    set c1 to yellow
    set c2 to red
  else
    pass
  if s < 0.5 then
    blend(2s, c1, c2)
  else
    blend(2s - 1, c2, c1)|]

mandelProgram' :: String
mandelProgram' = [r|
init curImage : bitmap <- render in x y plane (viewWidth,viewHeight) (-2,2) (1 / 128, 1 / 128)
  init C : C to -0.11 + 0.75i
  set complex z to x + i y
  set integer k to 0
  set real r2 to maxRadius * maxRadius
  loop
    set z to z z + C
    set k to k + 1
    re z re z + im z im z < r2 and k < maxIters
  if k >= maxIters then
    black
  else
    set s : R to k + 1 - (log ((log (|z|^2)) / 2)) / log 2
    set s to mod(s, 10) / 10
    set c1 : Color to blue
    set c2 : Color to white
    if im z > 0 then
      set c1 to yellow
      set c2 to red
    else
      pass
    if s < 0.5 then
      blend(2s, c1, c2)
    else
      blend(2s - 1, c2, c1)|]

mandelProgram'' :: String
mandelProgram'' = [r|
curImage : Image
curImage ⟵ render in x y plane (viewWidth,viewHeight) (-2,2) (1 / 128, 1 / 128)
  C : Complex
  C = -0.11 + 0.75i
  z : Complex
  z = x + i y

  repeat maxIters times with counter k
      z = z² + C
  while |z| < maxRadius

  if k = maxIters then
    black
  else
    s : Real
    s = if use_smoothing then k + 1 - log (log |z|² / 2) / log 2 else k
    s = mod (s, speed) / speed
    c₁ = blue  : Color
    c₂ = white : Color
    if im z > 0 then
        c₁ = yellow
        c₂ = red
    if s < 0.5 then
      blend(2s, c₁, c₂)
    else
      blend(2s - 1, c₂, c₁)|]

traceProgram :: String
traceProgram = [r|
init C : C to -0.11 + 0.75i
init z : C to posX + posY i
init z0 : C to 0
init k : Z to 0
erase
use white for line
loop
    set z0 to z
    set z to z z + C
    draw point at z0
    draw line from z0 to z
    set k to k + 1
    k < 100|]

traceProgram' :: String
traceProgram' = [r|
C : ℂ
C = -0.11 + 0.75i

z : ℂ
z = x + i y

z₀ : ℂ
z₀ = 0

erase
use white for line
repeat 100 times
    z₀ = z
    z  = z² + C
    draw point at z₀
    draw line from z₀ to z
|]

traceTool :: Tool '[Draw]
traceTool = Tool{..}
  where
    toolName = "Trace"
    toolHelp = "Click on a point to draw its trace"

    toolSettings = Settings{..}
    settingsList  = Bind (Proxy @"steps") IntegerType
                    (Setting Proxy (Scalar IntegerType 100)
                      (Just ("Trace steps",
                              [ InputValidator
                                "Trace steps must be non-negative"
                                validator ])))
                    $ EmptyContext
    settingsEnv = declare @"steps" IntegerType endOfDecls
    settingsTitle = "Trace settings"
    onChanged     = Nothing

    onClick = Just ( Fix
                   $ Effect Proxy Proxy VoidType
                   $ Provide posEnv settingsEnv VoidType trace)
    onMouseDown = Nothing
    onMouseUp = Nothing
    onMotion = Nothing
    onDrag = Nothing
    buttons = []
    env  = declare @"posX" RealType
         $ declare @"posY" RealType
         $ settingsEnv
    trace = case parseCode (EP (ParseEff noParser $ ParseEff drawEffectParser NoEffs)) env VoidType traceProgram of
      Right p -> p
      Left e  -> error (show e)

    validator = case parseValue settingsEnv BooleanType "steps > 0" of
      Right p -> p
      Left e -> error (show e)

mainViewer :: Viewer
mainViewer = Viewer{..}
  where
    onTimer = Nothing
    viewerTools = [traceTool]
    viewerSettings = Settings{..}
    settingsList = Bind (Proxy @"maxRadius") RealType
                     (Setting Proxy (Scalar RealType 10)
                       (Just ("Max. radius", [])))
                 $ Bind (Proxy @"maxIters") IntegerType
                     (Setting Proxy (Scalar IntegerType 100)
                       (Just ("Max. iterations", [])))
                 $ EmptyContext
    settingsEnv = contextToEnv settingsList

    settingsTitle = "FractalStream demo viewer settings"
    onChanged = Nothing
    onResize  = Nothing
    onRefresh = Just ( Fix
                     $ Effect Proxy Proxy VoidType
                     $ Provide EmptyEnvProxy settingsEnv VoidType mandelCode)
    viewToModel = case parseValue envV2M (PairType RealType RealType) v2m of
      Right c -> c
      Left e -> error (show e)
    modelToView = case parseValue envM2V (PairType RealType RealType) m2v of
      Right c -> c
      Left e -> error (show e)

    envV2M = declare @"viewX" RealType
           $ declare @"viewY" RealType
           $ env

    envM2V = declare @"modelX" RealType
           $ declare @"modelY" RealType
           $ env

    env = declare @"maxRadius" RealType
        $ declare @"maxIters"  IntegerType
        $ endOfDecls

    v2m = "((viewX - 256) / 128, (viewY - 256) / 128)"
    m2v = "(128 modelX + 256, 128 modelY + 256)"

    mandelCode = case parseCode (EP (ParseEff noParser $ ParseEff renderEffectParser NoEffs)) settingsEnv VoidType mandelProgram' of
      Right c -> c
      Left e  -> error (show e)

mandel' :: Int -> Double -> Complex Double -> FSColor.Color
mandel' maxIters maxRadius (x :+ y) =
  let ctx = Bind (Proxy @"x") RealType x
          $ Bind (Proxy @"y") RealType y
          $ Bind (Proxy @"maxRadius") RealType maxRadius
          $ Bind (Proxy @"maxIters") IntegerType (fromIntegral maxIters)
          $ EmptyContext
  in evalState (simulate NoHandler prog) (ctx, ())
 where
   prog = case parseCode (EP NoEffs) env ColorType mandelProgram of
     Right p -> p
     Left _  -> case parseCode (EP NoEffs) env ColorType "dark red" of
       Right p -> p
       Left e  -> error (show e) -- should be unreachable
   env = declare @"x" RealType
       $ declare @"y" RealType
       $ declare @"maxRadius" RealType
       $ declare @"maxIters" IntegerType
       $ endOfDecls