text:
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeOperators #-}

module Language.Grappa.Interp.TypedExpr where

import Data.Proxy
import Data.Functor.Const
import GHC.Generics

import qualified Numeric.SpecFunctions as Gamma
import qualified Language.Haskell.TH as TH

import Language.Grappa.Interp
import Language.Grappa.GrappaInternals
import Language.Haskell.TH.GrappaUtil
import Language.Grappa.Interp.FunRepr

----------------------------------------------------------------------
-- * Typed TH Expressions
----------------------------------------------------------------------

-- | Typed Template Haskell literals
data TypedLit a where
  TypedIntLit :: Num a => Integer -> TypedLit a
  TypedRatLit :: Fractional a => Rational -> TypedLit a

data TypedExpr a where
  TypedVar :: THName a -> TypedExpr a
  -- ^ A Haskell definition or variable lifted into the expression language
  TypedLit :: TypedLit a -> TypedExpr a
  -- ^ Literal expressions
  TypedApp :: TypedExpr (a -> b) -> TypedExpr a -> TypedExpr b
  -- ^ Function application
  TypedLam :: (THName a -> TypedExpr b) -> TypedExpr (a -> b)
  -- ^ Function abstraction
  TypedIfThenElse :: TypedExpr Bool -> TypedExpr a -> TypedExpr a -> TypedExpr a
  -- ^ If-then-else expression
  TypedFix :: (THName a -> TypedExpr a) -> TypedExpr a
  -- ^ Fixed-point expression

  TypedTuple :: TupleF ts TypedExpr (GTuple ts) -> TypedExpr (GTuple ts)
  -- ^ Tuple expression
  TypedMatchTuple :: IsTypeList ts => TypedExpr (GTuple ts) ->
                     (TupleF ts THName (GTuple ts) -> TypedExpr a) ->
                     TypedExpr a
  -- ^ Tuple pattern-matching expression

  TypedCtor :: THADT adt => adt TypedExpr (ADT adt) -> TypedExpr (ADT adt)
  -- ^ Constructor application expression
  TypedMatchCtor :: THADT adt => TypedExpr (ADT adt) ->
                    (adt Proxy (ADT adt)) ->
                    (adt THName (ADT adt) -> TypedExpr a) ->
                    TypedExpr a -> TypedExpr a
  -- ^ ADT match expression against a specific constructor, given as an element
  -- of its ADT, that will either call the continuation if the expression
  -- matches the constructor or will call the alternative expression otherwise
  -- which acts like the body of a wildcard pattern

-- FIXME: give TypedMatchCtor a list of possible cases, so that a wildcard that
-- is itself a match over the same expression can be folded in

----------------------------------------------------------------------
-- * Compiling Typed Expressions to TH
----------------------------------------------------------------------

class GTHCompilable f where
  gthCompile :: f a -> TH.Q TH.Exp

instance GTHCompilable U1 where
  gthCompile U1 = [| U1 |]

instance (GTHCompilable a, GTHCompilable b) => GTHCompilable (a :*: b) where
  gthCompile (a :*: b) = [| $(gthCompile a) :*: $(gthCompile b) |]

instance (GTHCompilable a, GTHCompilable b) => GTHCompilable (a :+: b) where
  gthCompile (L1 a) = [| L1 $(gthCompile a) |]
  gthCompile (R1 b) = [| R1 $(gthCompile b) |]

instance GTHCompilable a => GTHCompilable (M1 i c a) where
  gthCompile (M1 a) = [| M1 $(gthCompile a) |]

instance THCompilable a => GTHCompilable (K1 i a) where
  gthCompile (K1 a) = [| M1 $(thCompile a) |]

-- | A general typeclass for compiling things via TH
class THCompilable a where
  thCompile :: a -> TH.Q TH.Exp

  default thCompile :: (Generic a, GTHCompilable (Rep a)) => a -> TH.Q TH.Exp
  thCompile a = [| to $(gthCompile (from a)) |]

instance THCompilable a => THCompilable [a] where
  thCompile l = TH.ListE <$> mapM thCompile l

instance THCompilable (TypedExpr a) where
  thCompile (TypedVar nm) = TH.varE $ getTHName nm
  thCompile (TypedLit (TypedIntLit i)) = TH.litE (TH.IntegerL i)
  thCompile (TypedLit (TypedRatLit r)) = TH.litE (TH.RationalL r)
  thCompile (TypedApp f arg) = TH.appE (thCompile f) (thCompile arg)
  thCompile (TypedLam f) =
    do x <- TH.newName "x"
       TH.lamE [TH.varP x] (thCompile (f $ THName x))
  thCompile (TypedIfThenElse c t f) =
    TH.condE (thCompile c) (thCompile t) (thCompile f)
  thCompile (TypedFix f) =
    do x <- TH.newName "fix_var"
       TH.letE [TH.valD (TH.varP x) (TH.normalB $ thCompile $ f $ THName x) []]
         (TH.varE x)
  thCompile (TypedTuple tup) =
    adtToTHExp <$> traverseADT (fmap Const . thCompile) tup
  thCompile (TypedMatchTuple e k) =
    do ctx <- traverseADT (const $ newTHName "tup_arg") typeListProxy
       TH.caseE (thCompile e)
         [TH.match (return $ adtToTHPattern ctx)
          (TH.normalB $ thCompile $ k ctx) []]
  thCompile (TypedCtor adt) =
    adtToTHExp <$> traverseADT (fmap Const . thCompile) adt
  thCompile (TypedMatchCtor e ctor k_succ k_fail) =
    do ns_adt <- traverseADT (const (newTHName "case_arg")) ctor
       TH.caseE (thCompile e)
         [TH.match (return $ adtToTHPattern ns_adt)
          (TH.normalB $ thCompile $ k_succ $ ns_adt) []
         ,
          TH.match TH.wildP (TH.normalB $ thCompile k_fail) []]

instance THCompilable (GExpr TypedExprRepr a) where
  thCompile = thCompile . unGExpr

----------------------------------------------------------------------
-- * Compiling Functions Over Typed Expressions to TH
----------------------------------------------------------------------

-- | A context is a tuple of names, one for each type in @ctx@
type TypedCtx ctx = TupleF ctx THName (GTuple ctx)

-- | Build a tuple of fresh TH names with the given string prefix
buildTypedCtx :: IsTypeList ctx => String -> TH.Q (TypedCtx ctx)
buildTypedCtx str = traverseADT (const $ newTHName str) typeListProxy

-- | Get a list of the TH names in a 'TypedCtx'
ctxNames :: TypedCtx ctx -> [TH.Name]
ctxNames = ctorArgsADT getTHName

-- | An expression in a context is a function from contexts to expressions
type TypedCtxExpr ctx a = TypedCtx ctx -> TypedExpr a

instance IsTypeList ctx => THCompilable (TypedCtxExpr ctx a) where
  thCompile expr_f =
    do ctx <- buildTypedCtx "fun_arg"
       body_th <- thCompile $ expr_f ctx
       return $ foldr (\n -> TH.LamE [TH.VarP n]) body_th (ctxNames ctx)

-- | The representation that uses an expression-in-context
type TypedCtxExprRepr ctx = FunRepr (TypedCtx ctx) TypedExprRepr

instance IsTypeList ctx => THCompilable (GExpr (TypedCtxExprRepr ctx) a) where
  thCompile = thCompile . unGExpr

----------------------------------------------------------------------
-- * The Typed Expression Representation
----------------------------------------------------------------------

data TypedExprRepr :: *

instance ValidExprRepr TypedExprRepr where
  type GExprRepr TypedExprRepr a = TypedExpr a
  interp__'bottom = error "TypedExprRepr: unexpected bottom!"
  interp__'injTuple tup = GExpr $ TypedTuple $ mapADT unGExpr tup
  interp__'projTuple (GExpr e) k =
    GExpr $ TypedMatchTuple e (unGExpr . k . mapADT (GExpr . TypedVar))
  interp__'app (GExpr f) (GExpr x) =
    GExpr (TypedApp f x)
  interp__'lam f = GExpr $ TypedLam (unGExpr . f . GExpr . TypedVar)
  interp__'fix f = GExpr $ TypedFix (unGExpr . f . GExpr . TypedVar)

instance THADT adt => Interp__ADT__Expr TypedExprRepr adt where
  interp__'injADT adt = GExpr $ TypedCtor $ mapADT unGExpr adt
  interp__'projADT (GExpr _e) _k =
    error "FIXME HERE: no support for projADT in TypedExprRepr!"
  interp__'projMatchADT (GExpr e) ctor _ k_succ k_fail =
    GExpr $ TypedMatchCtor e ctor
    (unGExpr . k_succ . mapADT (GExpr . TypedVar)) $
    unGExpr k_fail

-- | Helper for lifting definitions to 'TypedExpr'
typedVar :: TH.Name -> GExpr TypedExprRepr a
typedVar = GExpr . TypedVar . THName

----------------------------------------------------------------------
-- * Interpreting the Operations in 'TypedExprRepr'
----------------------------------------------------------------------

--
-- Boolean and comparison operations
--

instance Interp__'ifThenElse TypedExprRepr where
  interp__'ifThenElse (GExpr c) (GExpr t) (GExpr f) =
    GExpr $ TypedIfThenElse c t f

instance Interp__not TypedExprRepr where
  interp__not = typedVar 'not

instance Interp__'amp'amp TypedExprRepr where
  interp__'amp'amp = typedVar '(&&)

instance Interp__'bar'bar TypedExprRepr where
  interp__'bar'bar = typedVar '(||)

instance Ord a => Interp__'eq'eq TypedExprRepr a where
  interp__'eq'eq = typedVar '(==)

instance Ord a => Interp__'lt TypedExprRepr a where
  interp__'lt = typedVar '(<)

instance Ord a => Interp__'gt TypedExprRepr a where
  interp__'gt = typedVar '(>)

instance Ord a => Interp__'lt'eq TypedExprRepr a where
  interp__'lt'eq = typedVar '(<=)

instance Ord a => Interp__'gt'eq TypedExprRepr a where
  interp__'gt'eq = typedVar '(>=)

instance Ord a => Interp__min TypedExprRepr a where
  interp__min = typedVar 'min

instance Ord a => Interp__max TypedExprRepr a where
  interp__max = typedVar 'max

instance Num a => Interp__'plus TypedExprRepr a where
  interp__'plus = typedVar '(+)

instance Num a => Interp__'minus TypedExprRepr a where
  interp__'minus = typedVar '(-)

instance Num a => Interp__'times TypedExprRepr a where
  interp__'times = typedVar '(*)

instance Num a => Interp__negate TypedExprRepr a where
  interp__negate = typedVar 'negate

instance Num a => Interp__abs TypedExprRepr a where
  interp__abs = typedVar 'abs

instance Num a => Interp__signum TypedExprRepr a where
  interp__signum = typedVar 'signum

instance Num a => Interp__fromInteger TypedExprRepr a where
  interp__fromInteger = typedVar 'fromInteger

instance Num a => Interp__'integer TypedExprRepr a where
  interp__'integer i = GExpr $ TypedLit $ TypedIntLit i

instance Fractional a => Interp__'rational TypedExprRepr a where
  interp__'rational r = GExpr $ TypedLit $ TypedRatLit r

instance Fractional a => Interp__'div TypedExprRepr a where
  interp__'div = typedVar '(/)

instance Fractional a => Interp__recip TypedExprRepr a where
  interp__recip = typedVar 'recip

instance Fractional a => Interp__fromRational TypedExprRepr a where
  interp__fromRational = typedVar 'fromRational

instance Floating a => Interp__pi TypedExprRepr a where
  interp__pi = typedVar 'pi

instance Floating a => Interp__exp TypedExprRepr a where
  interp__exp = typedVar 'exp

instance Floating a => Interp__log TypedExprRepr a where
  interp__log = typedVar 'log

instance Floating a => Interp__sqrt TypedExprRepr a where
  interp__sqrt = typedVar 'sqrt

instance Floating a => Interp__'times'times TypedExprRepr a where
  interp__'times'times = typedVar '(**)

instance Floating a => Interp__logBase TypedExprRepr a where
  interp__logBase = typedVar 'logBase

instance Floating a => Interp__sin TypedExprRepr a where
  interp__sin = typedVar 'sin

instance Floating a => Interp__cos TypedExprRepr a where
  interp__cos = typedVar 'cos

instance Floating a => Interp__tan TypedExprRepr a where
  interp__tan = typedVar 'tan

instance Floating a => Interp__asin TypedExprRepr a where
  interp__asin = typedVar 'asin

instance Floating a => Interp__acos TypedExprRepr a where
  interp__acos = typedVar 'acos

instance Floating a => Interp__atan TypedExprRepr a where
  interp__atan = typedVar 'atan

instance Floating a => Interp__sinh TypedExprRepr a where
  interp__sinh = typedVar 'sinh

instance Floating a => Interp__cosh TypedExprRepr a where
  interp__cosh = typedVar 'cosh

instance Floating a => Interp__tanh TypedExprRepr a where
  interp__tanh = typedVar 'tanh

instance Floating a => Interp__asinh TypedExprRepr a where
  interp__asinh = typedVar 'asinh

instance Floating a => Interp__acosh TypedExprRepr a where
  interp__acosh = typedVar 'acosh

instance Floating a => Interp__atanh TypedExprRepr a where
  interp__atanh = typedVar 'atanh

--
-- Probability operations
--

instance Interp__realToProb TypedExprRepr where
  interp__realToProb = typedVar 'realToProb

instance Interp__logRealToProb TypedExprRepr where
  interp__logRealToProb = typedVar 'logRealToProb

instance Interp__probToReal TypedExprRepr where
  interp__probToReal = typedVar 'probToReal

instance Interp__probToLogReal TypedExprRepr where
  interp__probToLogReal = typedVar 'probToLogReal

instance Interp__gammaProb TypedExprRepr where
  interp__gammaProb = typedVar 'gammaProb

instance Interp__digamma TypedExprRepr where
  interp__digamma = typedVar 'Gamma.digamma

--
-- Misc operations
--

instance Interp__gerror TypedExprRepr a where
  interp__gerror = typedVar 'gerror

max_stars_repo_name: kquick/grappa

max_issues_repo_name: kquick/grappa

max_forks_repo_name: kquick/grappa


text:
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, OverloadedLists #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeApplications #-}

{-# LANGUAGE DeriveGeneric #-}

{-# LANGUAGE GADTs #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE OverloadedLists #-}

module Test where

import Control.Applicative
import Control.Monad
import Control.Monad.Fix
import Control.Lens hiding (index, inside)
import Data.Data
import Data.Distributive
import Data.Foldable as Foldable
--import Data.Profunctor.Rep (Representable(..))
import Data.Proxy
import Data.Reflection as R
import Data.Tagged
import Data.Traversable (sequenceA)
import Data.Vector as V
import GHC.TypeLits
import GHC.Generics (Generic)
import GHC.Generics (Generic1)

import Unsafe.Coerce
{-
import Prelude hiding ((*), (+), (-), negate, subtract,zipWith)
import qualified Prelude
import qualified Data.Semiring as R
-}

import qualified Control.Lens.Internal.Context as I

import Linear.Vector
-- import Linear.Covector
-- import Linear.Metric
-- import Linear.Conjugate

import Linear.V

import Data.Foldable as Foldable

import Data.Coerce (coerce)
--import Data.Data.Lens
import Data.Functor.Rep --(Representable(..))

-- TensorLike t = (Traversable t, Additive t, Dim t, Dims t, Representable t, Foldable t, Finite t)
-- also Elt a, Basis t

{-
-- a recursive typeclass for index flattening?
https://github.com/chessai/eigen/blob/89bb642f7fa0dbde0579b72c796b8706a3cf0c5b/src/Eigen/Internal.hsc#L81
class Cast (a :: Type) where
  type family C a = (result :: Type) | result -> a
  toC   :: a -> C a
  fromC :: C a -> a

instance Cast t => Cast (Dim n t) where fromC $! VS.unsafeIndex vals $! n * (fromC t + row

-}

-- TODO: add more base types. maybe replace TF OneOf with either of these approaches:
-- https://github.com/GU-CLASP/TypedFlow/blob/master/TypedFlow/Types.hs#L330-L443
-- http://hackage.haskell.org/package/hmatrix-0.19.0.0/docs/Numeric-LinearAlgebra.html#t:RealOf
-- | Class representing base elements of a tensor.
class (a ~ Float) => Elt a where

instance Elt Float

-- inductive typeclass for V a (V b (V c .... ))
instance Elt a => Dims a where reflectDims _ = []
-- this would make no sense:
--instance Elt a => Dim a where reflectDim _ = 0

class Dims s where reflectDims :: proxy s -> [Int]

-- TODO: remove overlapping: https://mzabani.github.io/posts/2018-08-13.html
instance {-# Overlapping #-} (Dim (V n v), Dims v) => Dims (V n v) where
  reflectDims _ = reflectDim (Proxy :: Proxy (V n v)) : reflectDims (Proxy :: Proxy v)

instance {-# Overlapping #-} (Dim (T n v), Dims v) => Dims (T n v) where
  reflectDims _ = reflectDim (Proxy :: Proxy (T n v)) : reflectDims (Proxy :: Proxy v)

instance {-# Overlapping #-} (Dim (F n v), Dims v) => Dims (F n v) where
  reflectDims _ = reflectDim (Proxy :: Proxy (F n v)) : reflectDims (Proxy :: Proxy v)

dims :: forall a. (Dims a) => a -> [Int]
dims _ = reflectDims (Proxy :: Proxy a)

-- TODO: figure out biplate or use recursion schemes?
--instance (KnownNat n, Data a) => Plated (V n a) where plate = biplate

-- TODO: update linear version or fork.
vLens :: Int -> Lens' (V n a) a
vLens i = \f (V v) -> (\a -> V (v V.// [(i, a)])) <$> f (v V.! i)

instance ( 1 <= n) => Field1  (V n a) (V n a) a a where _1  = vLens  0
instance ( 2 <= n) => Field2  (V n a) (V n a) a a where _2  = vLens  1
instance ( 3 <= n) => Field3  (V n a) (V n a) a a where _3  = vLens  2
instance ( 4 <= n) => Field4  (V n a) (V n a) a a where _4  = vLens  3
instance ( 5 <= n) => Field5  (V n a) (V n a) a a where _5  = vLens  4
instance ( 6 <= n) => Field6  (V n a) (V n a) a a where _6  = vLens  5
instance ( 7 <= n) => Field7  (V n a) (V n a) a a where _7  = vLens  6
instance ( 8 <= n) => Field8  (V n a) (V n a) a a where _8  = vLens  7
instance ( 9 <= n) => Field9  (V n a) (V n a) a a where _9  = vLens  8

-- | nested functions:
-- TODO: change to other rep?
{-
HS.build ::
  (KnownNat n, KnownNat m) =>
  (HS.ℝ -> HS.ℝ -> HS.ℝ) -> HS.L m n

withDims
  :: forall n m a. (Elem a, KnownNat n, KnownNat m)
  => (Int -> Int -> VS.Vector (C a)) -> Matrix n m a
withDims f =
  let !r = natToInt @n
      !c = natToInt @m
  in Matrix $ Vec $ f r c

-- TODO: is this rep better for constructing tensors?
--newtype F' n t = F' { unF' :: Tagged n Int -> t } deriving (Functor,Applicative,Generic,Generic1)
type F' n t = Tagged n Int -> Vector e
type F2' a b t = (KnownNat a, KnownNat b) => F' a (F' b t)
type F3' a b c t = (KnownNat a, KnownNat b, KnownNat c) => F' a (F' b (F' c t))

instance Num t => Num (Tagged n Int -> t) where
  (+) = liftA2 (+)
  (-) = liftA2 (-)
  (*) = liftA2 (*)

-}

newtype F (n :: Nat) t = F { unF :: Int -> t } deriving (Functor,Applicative,Generic,Generic1)

instance Additive (F n)
instance Dim n => Dim (F n t) where reflectDim _ = reflectDim (Proxy :: Proxy n)

instance Num a => Num (V.Vector a) where
  as + bs = V.zipWith (+) as bs
  {-# INLINE (+) #-}
  as - bs = V.zipWith (-) as bs
  {-# INLINE (-) #-}
  as * bs = V.zipWith (*) as bs
  {-# INLINE (*) #-}
  negate = fmap negate
  {-# INLINE negate #-}
  abs = fmap abs
  {-# INLINE abs #-}
  signum = fmap signum
  {-# INLINE signum #-}
  fromInteger = pure . fromInteger
  {-# INLINE fromInteger #-}

instance Num a => Num (F n a) where
  F as + F bs = F $ liftA2 (+) as bs
  {-# INLINE (+) #-}
  F as - F bs = F $ liftA2 (-) as bs
  {-# INLINE (-) #-}
  F as * F bs = F $ liftA2 (*) as bs
  {-# INLINE (*) #-}
  negate = fmap negate
  {-# INLINE negate #-}
  abs = fmap abs
  {-# INLINE abs #-}
  signum = fmap signum
  {-# INLINE signum #-}
  fromInteger = pure . fromInteger
  {-# INLINE fromInteger #-}

type F2 a b t = F a (F b t)
type F3 a b c t = F a (F b (F c t))

f26 :: F2 2 6 Float
f26 = pure 1

f265 :: F3 2 6 5 Float
f265 = pure 1

-- | nested 'Tagged's:
newtype T (n :: Nat) t = T { unT :: Tagged n t } deriving (Eq,Ord,Show,Functor,Applicative,Foldable,Traversable,Generic,Generic1)

instance Dim n => Additive (T n)
instance Dim n => Dim (T n t) where reflectDim _ = reflectDim (Proxy :: Proxy n)

instance Dim n => Additive (Tagged n)

instance Num a => Num (T n a) where
  (+) = liftA2 (+)
  (-) = liftA2 (-)
  (*) = liftA2 (*)
  negate = fmap negate
  {-# INLINE negate #-}
  abs = fmap abs
  {-# INLINE abs #-}
  signum = fmap signum
  {-# INLINE signum #-}
  fromInteger = pure . fromInteger
  {-# INLINE fromInteger #-}

type T2 a b t = T a (T b t)
type T3 a b c t = T a (T b (T c t))

-- TODO: sequence works but distribute doesn't for some reason
-- λ: t26 * (sequenceA $ t26 + t26)
-- Tagged (Tagged 2.0)

t26 :: T2 2 6 Float
t26 = pure 1

-- test: dims t265 == [2,6,5]
t265 :: T3 2 6 5 Float
t265 = pure 1

-- | nested 'Vector's:

type V2 a b t = (KnownNat a, KnownNat b) => V a (V b t)
type V3 a b c t = (KnownNat a, KnownNat b, KnownNat c) => V a (V b (V c t))

{-
 -
 -
Representable f =>

instance {-# Overlapping #-} (Representable v, KnownNat n) => Representable (V n v) where
  reflectDims _ = reflectDim (Proxy :: Proxy (V n v)) : reflectDims (Proxy :: Proxy v)

type Rep ?  = Idxs ds -> a

instance (Representable f, Representable g) => Representable (Compose f g) where
  type Rep (Compose f g) = (Rep f, Rep g)
  index (Compose fg) (i,j) = index (index fg i) j
  tabulate = Compose . tabulate . fmap tabulate . curry

-}
-- TODO why isn't the applicative working?
b265 :: V3 2 6 5 Bool
b265 = pure . pure . pure $ False

v5 :: V 5 Float
v5 = return 1

v52 :: V2 5 2 Float
v52 = pure 1

v25 :: V2 2 5 Float
v25 = pure 1

v265 :: V3 2 6 5 Float
v265 = pure 1

v615 :: V3 6 1 5 Float
v615 = pure 1

v22 :: V 2 (V 2 Int)
v22 = pure 1

v222 :: V 2 (V 2 (V 2 Int))
v222 = pure 5

v312 :: V 3 (V 1 (V 2 Int))
v312 = pure 2

v4312 :: V 4 (V 3 (V 1 (V 2 Int)))
v4312 = pure 2

-- test: dims v4321 == [4,3,2,1]
v4321 :: V 4 (V 3 (V 2 (V 1 Int)))
v4321 = pure 2

v3512 :: V 3 (V 5 (V 1 (V 2 Int)))
v3512 = pure 2

{-
v232 :: V 2 (V 3 (V 2 Int))
v232 = unsafeCoerce
  [[[13, 14],
    [15, 16],
    [17, 18]],
   [[19, 20],
    [21, 22],
    [23, 24]]]

v223 :: V 2 (V 2 (V 3 Int))
v223 = unsafeCoerce
  [[[ 1,  2,  3],
    [ 4,  5,  6]],
   [[ 7,  8,  9],
    [10, 11, 12]]]
-}

----Tensile.Operators API
--

class Finite v where
  type Size v :: Nat -- this should allow kind k, for Reifies k Int
  toV :: v a -> V (Size v) a
  default toV :: Foldable v => v a -> V (Size v) a
  toV = V . V.fromList . Foldable.toList
  fromV :: V (Size v) a -> v a

instance Finite (V (n :: Nat)) where
  type Size (V n) = n
  toV = id
  fromV = id

-- TODO: remove
add :: (Additive f, Num a) => f a -> f a -> f a
add = (^+^)

sub :: (Additive f, Num a) => f a -> f a -> f a
sub = (^-^)

-- test: dim (scalar 1.7 :: V 1 Float) == 1
scalar :: (Additive f, Finite f, Elt a) => a -> f a
scalar a = fromV (V $ pure a)

-- (Tensor f, Ring a)
(.+.) :: (Additive f, Num a) => f a -> f a -> f a
(.+.) = add

(.-.) :: (Additive f, Num a) => f a -> f a -> f a
(.-.) = sub

-- | Right scalar product
(.*) :: (Functor f, Num a) => f a -> a -> f a
f .* a = fmap (* a) f

-- | Left scalar product
(*.) :: (Functor f, Num a) => a -> f a -> f a
a *. f = fmap (* a) f

-- | Right vector product
(.*!) :: (Functor m, Foldable r, Additive r, Num a) => m (r a) -> r a -> m a
m .*! v = fmap (\r -> Foldable.sum $ liftI2 (*) r v) m

-- (!*) :: (Metric r, Additive f, Num a) => r a -> r (f a) -> f a
-- f !* g = dot f <$> distribute g
--
-- | Left vector product
(!*.) :: (Foldable t, Additive f, Additive t, Num a) => t a -> t (f a) -> f a
f !*. g = sumV $ liftI2 (*.) f g

-- | Matrix product.
(.*.) :: (Functor m, Foldable t, Additive t, Additive n, Num a) => m (t a) -> t (n a) -> m (n a)
f .*. g = fmap (\f' -> Foldable.foldl' add zero $ liftI2 (*.) f' g) f

{-
infixl 6 :+:, :-:
infixl 7 :+:,.*:,:+.,*:,:+

sumV :: (Foldable f, Additive v, Num a) => f (v a) -> v a
sumV = Foldable.foldl' add zero

dot :: (Foldable f, Num a) => f a -> f a -> a
dot x y = Foldable.sum $ liftI2 R.(*) x y

-- | Product of a matrix of weights with a batched vector .
weight
  :: (Functor m, Foldable t, Additive t, Applicative t, Additive n, Num a, Traversable n)
  => n (t a) -> m (t a) -> m (n a)
weight m v = v .*. (sequenceA m) -- use distribute here instead?

--transpose :: (Distributive g, Functor f) => f (g a) -> g (f a)
--transpose = distribute

-}

-- | A generalization of 'Control.Lens.inside' that works over any corepresentable 'Functor'.
-- Useful for performing operations along different axes. See https://medium.com/@aerinykim/tensorflow-101-what-does-it-mean-to-reduce-axis-9f39e5c6dea2
-- for a tutorial on tensor axes.

-- λ: :t v4312 ^. (_1)
-- v4312 ^. (_1) :: V 3 (V 1 (V 2 Int))
-- λ: :t v4312 ^. (_1 . _1)
-- v4312 ^. (_1 . _1) :: V 1 (V 2 Int)
-- λ: :t v4312 ^. (_1 . _1 . _1)
-- v4312 ^. (_1 . _1 . _1) :: V 2 Int
-- λ: :t v4312 ^. (_1 . _1 . _1 ._1)
-- v4312 ^. (_1 . _1 . _1 ._1) :: Int
--
-- λ: :t v4312 ^. inside (_1 )
-- v4312 ^. inside (_1 ) :: V 4 (V 1 (V 2 Int))
-- λ: :t v4312 ^. inside (_1 . _1)
-- v4312 ^. inside (_1 . _1) :: V 4 (V 2 Int)
-- λ: :t v4312 ^. inside (_1 . _1 . _1)
-- v4312 ^. inside (_1 . _1 . _1) :: V 4 Int
--
-- λ: :t v4312 ^. (inside _1)
-- v4312 ^. (inside _1) :: V 4 (V 1 (V 2 Int))
-- λ: :t v4312 ^. (inside . inside $ _1)
-- v4312 ^. (inside . inside $ _1) :: V 4 (V 3 (V 2 Int))
-- λ: :t v4312 ^. (inside . inside . inside $ _1)
-- v4312 ^. (inside . inside . inside $ _1) :: V 4 (V 3 (V 1 Int))

inside
  :: Functor f
  => Representable g
  => LensLike (Context a b) s t a b
  -> (g a -> f (g b)) -> g s -> f (g t)
inside l = \afb s -> sbt s <$> afb (sa s)
  where
    sa = liftR $ \s -> I.ipos (accessors l s)

    sbt = liftR2 $ \s b -> I.ipeek b (accessors l s)

    -- Isomorphic to s -> (a, (b -> t))
    accessors l = l (Context id)

    liftR = fmapRep

-- TODO: push (V 1) constructor down n levels to add an extra dimension at axis (@n@) of size 1.
--
-- expandDim :: forall n s e. (KnownLen s, KnownPeano n) => Tensor s t -> Tensor (Take n s ++ (1 ': Drop n s)) t
-- expandDim (T x) = (T (funcall "tf.expand_dims" [x, named "axis" (integer (listLen @s - peanoInt @n))]))

--reduceSum0 :: ∀ s' n e. KnownLen s' => Tensor (n ': s') t -> Tensor s' t
reduceSum :: (Foldable f, Additive v, Num a) => f (v a) -> v a
reduceSum = sumV

-- dot prod along arbitrary axis
--
-- λ: :t v265 `dot` v265
-- v265 `dot` v265 :: V 6 (V 5 Float)
--
-- λ: :t liftI2 dot v265 v265
-- liftI2 dot v265 v265 :: V 2 (V 5 Float)
--
-- | For two tensors of the same dimension, the Hadamard product is a tensor of the same dimension as the operands, with elements given by pointwise multiplication.

--hadamard :: (Num a, Additive f) => f a -> f a -> f a
--hadamard = liftI2 (Prelude.(*))

{-
-- https://en.wikipedia.org/wiki/Kronecker_product
If A is an m × n matrix and B is a p × q matrix, then the Kronecker product A ⊗ B is the mp × nq block matrix formed by multiplying every scalar value in m by the matrix m.

Transposition and conjugate transposition are distributive over the Kronecker product:

transpose (m ⊗ n) == (transpose m) ⊗ (transpose n)
adjoint (m ⊗ n) == (adjoint m) ⊗ (adjoint n)

TODO: replace w/ version w/ fewer restrictions on a.
need to recurse to leaves and then build up matrices. zylomorph?
-}
kronecker :: (Functor f, Functor g, Num a) => f a -> g a -> f (g a)
kronecker = outer

-- $setup
-- >>> import Data.Complex
-- >>> import Data.IntMap
-- >>> import Debug.SimpleReflect.Vars
-- >>> import Linear.V

-- need Linear.Conjugate for this
-- | Hermitian conjugate or conjugate transpose
--
-- >>> adjoint (V2 (V2 (1 :+ 2) (3 :+ 4)) (V2 (5 :+ 6) (7 :+ 8)))
-- V2 (V2 (1.0 :+ (-2.0)) (5.0 :+ (-6.0))) (V2 (3.0 :+ (-4.0)) (7.0 :+ (-8.0)))
-- adjoint :: (Functor m, Distributive n, Conjugate a) => m (n a) -> n (m a)
-- adjoint = collect (fmap conjugate)
-- {-# INLINE adjoint #-}

ext: hs

max_stars_repo_name: cmk/tensile

max_issues_repo_name: cmk/tensile

max_forks_repo_name: cmk/tensile


text:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TupleSections     #-}

module Topical.Text.Tokenizer.TextTiling
    ( SmoothingParams(..)

    , textTilingTokenizer
    , suppressSmallBlocks
    , smooth

    , windows
    , partition
    , triples
    , frequencies
    , blockComparison
    , vocabularyIntroduction

    , Sequence(..)
    , seqNo
    , seqSpan
    , seqItems
    , seqFreqs

    , SeqScore
    ) where

import           Control.Arrow
import           Control.Error
import           Control.Lens
-- import           Data.Foldable       hiding (concat)
import           Data.Hashable
import qualified Data.HashMap.Strict as M
import qualified Data.HashSet        as S
import qualified Data.List           as L
import qualified Data.List.Split     as Split
import           Data.Monoid
import           Data.Ord
import qualified Data.Text           as T
import           Data.Traversable
-- import qualified Data.Vector         as V
-- import           Statistics.Sample

-- import           Topical.Text.Types

type Frequency         = Int
-- type TokenSeqFrequency = (SeqNumber, Frequency)

-- | "The morpholocially-analyzed token is stored in a table along with
-- a record of the token-windowSeq number it occurred in, and the number of
-- times it appeared in the token-sequence."
-- type TokenTable a      = M.HashMap a [TokenSeqFrequency]

type SeqNumber = Int

-- | A record is also kept of the locations of the paragraph breaks within
-- the text. Stop words contribute to the computation of the size of the
-- token windowSeq, but not to the computation of the similarity between
-- blocks of text.
type SeqSpan = (Int, Int)

type FrequencyTable a = M.HashMap a Frequency

data Sequence a b = Sequence
                  { _seqNo    :: !SeqNumber
                  , _seqSpan  :: !SeqSpan
                  , _seqItems :: ![a]
                  , _seqFreqs :: !(FrequencyTable b)
                  } deriving (Eq)
makeLenses ''Sequence

instance Show (Sequence T.Text b) where
    show Sequence{..} =
        mconcat [ "Sequence #"
                , show _seqNo
                , ": "
                , T.unpack (T.unwords _seqItems)
                ]

type TokenSequence a = Sequence a a
type BlockSequence a = Sequence (TokenSequence a) a

type SeqScore a b = (TokenSequence a, b)

data SmoothingParams  = Smoothing Int    -- ^ Number of rounds of smoothing
                                  Int    -- ^ Smoothing window size

type ScoringFunction a =
    TokenSeqSize -> BlockSize -> [TokenSequence a] -> [SeqScore a Double]
type CountFunction a b = (Hashable b, Eq b) => [a] -> FrequencyTable b

type TokenSeqSize = Int
type BlockSize    = Int

-- | The basic processing flow:
-- boundary identification . lexical score determination . tokenization
textTilingTokenizer :: (Hashable a, Eq a, Show a)
                    => TokenSeqSize
                    -- ^ The token windowSeq size parameter (/w/). 20 is often
                    -- a good default value.
                    -> BlockSize
                    -- ^ The number of token sequences to group together.
                    -- This is the average paragraph length (in token
                    -- sequences) (/blocksize/). 6 often works well.
                    -> ScoringFunction a
                    -- ^ This either uses block comparison to look at
                    -- shared vocabulary or vocabulary introduction to base
                    -- it on the number of new words are found in the
                    -- second window. Either way, larger output values
                    -- should indicate a more likely change of topic.
                    -> SmoothingParams
                    -> [a]
                    -- ^ The input sequence. If this is text, this should
                    -- be tokenized, case-folded, and stop-words filtered
                    -- out. Also, affixes and irregular forms normalized
                    -- should be removed so that it's only the
                    -- morphological base.
                    -> [BlockSequence a]
textTilingTokenizer w k scoring (Smoothing sWin sIters) =
      cutOffs
    . smooth sWin sIters
    . snd
    . mapAccumConcat boundary (0, 0, [])
    . scoring w k
    . partitionSeq w frequencies

cutOffs :: [SeqScore a (Double, Double)] -> [BlockSequence a]
cutOffs = undefined

-- The first Double is the raw score. The second is the depth score
-- actually used to make the boundary determination.
-- type SeqNode a = SeqScore a (Double, Double)

-- | This takes a list of @SeqScore a (Double, Double)@, sorted by
-- likelihood of beginning a new section, and returns a tree of descending
-- likelihoods, but in sequence order.
-- hangTree :: Show a => [SeqNode a] -> Tree (SeqNode a)
-- hangTree = unfoldTree hang
--     where
--         hang :: Show a
--                 => [SeqNode a]
--                     -> (SeqNode a, (Maybe [SeqNode a], Maybe [SeqNode a]))
--         hang = undefined
--              . maximumBy (comparing (snd . snd . fst))
--              . snd
--              . L.mapAccumL packageNode []
--              . filter (not . L.null)
--              . L.tails
--
--         packageNode :: Show a
--                        => [SeqNode a]
--                            -> [SeqNode a]
--                            -> ([SeqNode a], (SeqNode a, [[SeqNode a]]))
--         packageNode ls (s:rs) = (s:ls, (s, [reverse ls, rs]))
--         packageNode ls []     = (ls,   (undefined, []))
--         -- It should never reach here, so I'll just plant a bomb.
--         -- KA-BOOM!

smooth :: Int -> Int -> [SeqScore a (Double, Double)]
       -> [SeqScore a (Double, Double)]
smooth _      0     sss = sss
smooth window iters sss =
    smooth window (pred iters) $ moveAvgBy window (_2 . _2) sss

moveAvgBy :: Int       -- ^ The number of items to offset from each side
                       -- of the center. For instance, for a window of 3,
                       -- use a value of 1.
          -> Lens' a Double -> [a] -> [a]
moveAvgBy n l xs = zipWith (set l) (moveavg n $ map (^. l) xs) xs

moveavg :: Int         -- ^ The number of items to offset from each side
                       -- of the center. For instance, for a window of 3,
                       -- use a value of 1.
        -> [Double] -> [Double]
moveavg n = go []
    where
        go _    []     = []
        go pref (x:xs) = avg (x : take n pref ++ take n xs) : go (x:pref) xs

avg :: [Double] -> Double
avg = uncurry (/) . L.foldl' accum (0, 0)
    where
        accum p x = ((+ x) *** succ) p

suppressSmallBlocks :: Int
                    -> [SeqScore a (Double, Double)]
                    -> [SeqScore a (Double, Double)]
suppressSmallBlocks minP = sortNo . removeTiny minP . sortScore
    where
        removeTiny :: Int
                   -> [SeqScore a0 (Double, Double)]
                   -> [SeqScore a0 (Double, Double)]
        removeTiny _ []     = []
        removeTiny w (x:xs) =
            x : sortScore (map (modifyClose w $ x ^. _1 . seqNo) xs)
        closeTo :: Int -> Int -> SeqScore a1 (Double, Double) -> Bool
        closeTo w seq1No seq2 = abs (seq1No - (seq2 ^. _1 . seqNo)) <= w
        modifyClose :: Int
                    -> Int
                    -> SeqScore a2 (Double, Double)
                    -> SeqScore a2 (Double, Double)
        modifyClose w seq1No seq2 = if closeTo w seq1No seq2
                                        then seq2 & _2 . _2 .~ 0
                                        else seq2

sortScore :: [SeqScore a (Double, Double)] -> [SeqScore a (Double, Double)]
sortScore = L.sortBy (comparing (Down . snd . snd))

sortNo :: [SeqScore a b] -> [SeqScore a b]
sortNo = L.sortBy (comparing (_seqNo . fst))

type BoundaryId a = (Double, Double, [Double -> SeqScore a (Double, Double)])

boundary :: BoundaryId a
         -> SeqScore a Double
         -> (BoundaryId a, [SeqScore a (Double, Double)])
boundary (leftS, lastS, pending) (ts, s)
    | lastS <= s = ((leftS', s, nextf:pending), [])
    | otherwise  = ((s, s, []), reverse (map ($ lastS) (nextf:pending)))
    where
        leftS'  = max leftS s
        nextf r = (ts, (s, (leftS' - s) + (r - s)))

-- | This converts a two-item list into a tuple pair.
toPair :: [a] -> Maybe (a, a)
toPair [a, b] = Just (a, b)
toPair _      = Nothing

-- toTriples :: [a] -> Maybe (a, a, a)
-- toTriples [a, b, c] = Just (a, b, c)
-- toTriples _         = Nothing

mapAccumConcat :: (a -> b -> (a, [c])) -> a -> [b] -> (a, [c])
mapAccumConcat f s = fmap concat . mapAccumL f s

-- TODO: I think this should be a comonad, but right now I just want to get
-- it written.
-- mapAccumContext :: (s -> [x] -> x -> [x] -> (s, [a])) -> s -> [x] -> (s, [a])
-- mapAccumContext f state = go state []
--     where
--         go s _  []     = (s, [])
--         go s ls (x:xs) = let (s',  as)  = f s ls x xs
--                              (s'', ass) = go s' (x:ls) xs
--                          in  (s'', as ++ ass)

-- | The block comparison scoring function. This looks at words in common
-- between two windows.
-- TODO: I think we're loosing `bsize` token sequences off the front.
blockComparison :: (Hashable a, Eq a) => ScoringFunction a
blockComparison _ _ []      = []
blockComparison _ bsize tss =
      uncurry appHead
    . (floatHead &&& comparePairs)
    $ windowSeq bsize mergeFrequencies tss
    where
        floatHead seqs = (,0.0) <$> seqs ^? i0 . seqItems . i0
        comparePairs   = map (uncurry blockCompare) . mapMaybe toPair . windows 2
        appHead mh xs  = maybe xs (:xs) mh
        i0             = traversed . index 0

blockCompare :: (Hashable a, Eq a)
             => BlockSequence a -> BlockSequence a -> SeqScore a Double
blockCompare (Sequence _ _ _ b1) (Sequence _ _ (ts:_) b2) =
    (ts,) . final . foldMap step $ terms b1 `S.union` terms b2
    where
        topf w1 w2     = w1 * w2
        bottoml w1 _w2 = w1 * w1
        bottomr _w1 w2 = w2 * w2
        getFreqs t     = (M.lookupDefault 0 t b1, M.lookupDefault 0 t b2)
        step           = (   Sum . uncurry topf
                         &&& Sum . uncurry bottoml
                         &&& Sum . uncurry bottomr
                         ) . getFreqs
        final (Sum t, (Sum bl, Sum br)) =
            fromIntegral t / sqrt (fromIntegral $ bl * br)
blockCompare _ _ = undefined

-- | This returns the terms in a frequency table.
terms :: (Hashable a, Eq a) => FrequencyTable a -> S.HashSet a
terms = S.fromList . M.keys

-- | The vocabulary introduction scoring function. This looks at how many
-- words are introduced in the second window.
-- TODO: What happens to the first item from the first pair in `collapse`?
-- TODO: Are we looking a token sequence off the front?
vocabularyIntroduction :: (Hashable a, Eq a) => ScoringFunction a
vocabularyIntroduction tsSize _ = snd
                                . mapAccumL accum S.empty
                                . map (uncurry collapse)
                                . mapMaybe toPair
                                . windows 2
                                . map (id &&& (terms . _seqFreqs))
    where
        blockSize :: Double
        blockSize = fromIntegral tsSize * 2.0
        collapse (_, t1) (ts, t2) = (ts, t1 `S.union` t2)
        accum s (ts, block) =
            let unseen = S.size $ block `S.difference` s
                s'     = s `S.union` block
            in  (s', (ts, fromIntegral unseen / blockSize))

-- | This extends @windows@ to create @Sequence@ instances.
windowSeq :: (Eq b, Hashable b)
          => Int -> CountFunction a b -> [a] -> [Sequence a b]
windowSeq k = toSeq (windows k)

-- | This extends @partition@ to create @Sequence@ data.
partitionSeq :: (Eq b, Hashable b)
             => Int -> CountFunction a b -> [a] -> [Sequence a b]
partitionSeq k = toSeq (partition k)

toSeq :: (Eq b, Hashable b)
      => ([(Int, a)] -> [[(Int, a)]])
      -> CountFunction a b -> [a] -> [Sequence a b]
toSeq breaker counter =
    mapMaybe (uncurry toSeq') . zip [0..] . breaker . zip [0..]
    where
        toSeq' n spanned =
            let items = map snd spanned
            in  Sequence n <$> getSpan spanned
                           <*> pure items
                           <*> pure (counter items)
        getSpan []          = Nothing
        getSpan [(s, _)]    = Just (s, s)
        getSpan ((s, _):xs) = (s,) . fst <$> lastZ xs

-- | This takes an input windowSeq and divides it into overlapping
-- subsequences of a given size.
--
-- >>> windows 2 [1, 2, 3, 4, 5]
-- [[1, 2], [2, 3], [3, 4], [4, 5], [5]]
windows :: Int      -- ^ The size of the sliding window.
        -> [a]      -- ^ The input sequence.
        -> [[a]]    -- ^ The output windowSeq of windows.
windows k = filter (not . L.null) . map (take k) . L.tails

-- | This implementation is taken from Data.List.Split.Lens, before it was
-- removed.
chunking :: Int -- ^@n@
         -> Getting (Endo [a]) s a -> Fold s [a]
chunking s l f = coerce . traverse f . Split.chunksOf s . toListOf l
{-# INLINE chunking #-}

-- | This takes an input windowSeq and divides it into non-overlapping
-- partitions of a given size.
--
-- >> partition 2 [1, 2, 3, 4, 5]
-- [[1, 2], [3, 4], [5]]
partition :: Int    -- ^ The size of the non-overlapping partitions.
          -> [a]    -- ^ The input windowSeq to partition.
          -> [[a]]  -- ^ The non-overlapping partitions.
partition k xs = xs ^.. chunking k each

-- | This takes an input windowSeq and divides it into overlapping chains of
-- three.
--
-- >>> triples [1, 2, 3, 4, 5]
-- [(1, 2, 3), (2, 3, 4), (3, 4, 5)]
triples :: [a] -> [(a, a, a)]
triples = mapMaybe triples' . L.tails
    where
        triples' (a:b:c:_) = Just (a, b, c)
        triples' _         = Nothing

frequencies :: CountFunction a a
frequencies xs = M.fromListWith (+) . zip xs $ L.repeat 1

mergeFrequencies :: CountFunction (Sequence a b) b
mergeFrequencies = foldMap _seqFreqs

-- cosSimilarity :: (Hashable a, Eq a)
--               => FrequencyTable a -> FrequencyTable a -> Double
-- cosSimilarity b1 b2 =
--     finish . foldMap step $ terms b1 `S.union` terms b2
--     where step k = let w1 = M.lookupDefault 0 k b1
--                        w2 = M.lookupDefault 0 k b2
--                     in (Sum (w1 * w2), Sum (w1 * w1), Sum (w2 * w2))
--           finish (Sum a, Sum b, Sum c) =
--               fromIntegral a / sqrt (fromIntegral b * fromIntegral c)

-- | This calculates all boundaries as being places where the depth score
-- is greater than the function below (mean minus half the standard
-- deviation).
--
-- If I need better performance, I can use
-- http://en.wikipedia.org/wiki/Algorithms_for_calculating_variance#Online_algorithm

-- boundaries :: [Double] -- ^ The cutoff scores between each paragraph block.
--            -> [Int]    -- ^ A list of the paragraph indexes that are boundaries.
-- boundaries depths = undefined $ mean depths' - (fastStdDev depths' / 2.0)
--     where depths' = V.fromList depths

-- Stuff from Main for this:
-- main :: IO ()
-- main = do
--     (stopfile:files) <- getArgs
--
--     stoplist <- S.fromList . tokenize <$> TIO.readFile stopfile
--
--     forM_ files $ \filename -> do
--         putStrLn filename
--
--         tokens <-  filter (not . (`S.member` stoplist)) . tokenize
--                <$> TIO.readFile filename
--         putStrLn $ "Token count = " ++ show (length tokens)
--
--         let tiles = map _seqItems
--                   $ textTilingTokenizer 20 6 blockComparison (Smoothing 1 2) tokens
--         putStrLn $ "Tile count  = " ++ show (length tiles)
--
--         forM_ tiles $ TIO.putStr
--                     . (<> "\n\n")
--                     . T.intercalate "\n\n"
--                     . map ((<> ".") . T.intercalate " " . _seqItems)
--
-- {-
--  -         chart tiles
--  -
--  -         forM_ tiles $ \(Sequence{..}, (raw, score)) ->
--  -             putStrLn $ L.intercalate "," [ show _seqNo
--  -                                          , show (fst _seqSpan)
--  -                                          , show (snd _seqSpan)
--  -                                          , show raw
--  -                                          , show score
--  -                                          , unwords (map T.unpack _seqItems)
--  -                                          ]
--  -}
--
-- chart :: [SeqScore T.Text (Double, Double)] -> IO ()
-- chart seqs = toFile def "tiles.png" $ do
--     layout_title .= "TextTiling scores"
--     -- layout_y_axis . laxis_override .= axisGridHide
--     -- plot $ line "raw"   [map (fst . _seqSpan *** fst) seqs]
--     plot $ line "score" [map (fst . _seqSpan *** snd) seqs]
--
-- {-
--  - toParagraphs :: Int
--  -              -> Tree (SeqScore T.Text (Double, Double))
--  -              -> [[SeqScore T.Text (Double, Double)]]
--  - toParagraphs 0 tree = [L.sortBy (comparing (_seqNo . fst)) $ flatten tree]
--  - toParagraphs n (Node root forest) = [sortp pre, root : sortp post]
--  -     where
--  -         rootNo      = root ^. _1 . seqNo
--  -         (pre, post) = L.break ((< rootNo) . _seqNo . fst . head . head)
--  -                     $ map (toParagraphs (n - 1)) forest
--  -         sortp       = L.sortBy (comparing (_seqNo . fst . _))
--  -}
--
-- showp :: [SeqScore T.Text (Double, Double)] -> String
-- showp = L.intercalate ". " . map (unwords . map T.unpack . _seqItems . fst)
--
-- tshow :: Show a => a -> T.Text
-- tshow = T.pack . show
--
-- word :: Parser T.Text
-- word = T.pack <$> many1 (satisfy isAlphaNum)
--
-- tokenize :: T.Text -> [T.Text]
-- tokenize = map T.toLower . parserTokenizer word

max_stars_repo_name: erochest/topical

max_issues_repo_name: erochest/topical

max_forks_repo_name: erochest/topical


text:
module Rnd (Distr, Rnd, minMax95, minMax99, meanMinMax95, meanMinMax99,
  (|*|), (|+|), runRnd, simulate, mkN95, distrN, distrAsymN, distrConst,
  simulateN, simulateMmm, MeanMinMax(..), scanM, withConfidence, mkMeanMinMax, showD,
  mmmProbability95AtLeast, meanMinMax95N, mmm) where

import Statistics.Distribution.Normal
import Statistics.Distribution
import Data.Random.Normal
import Control.Monad.State
import System.Random
import qualified Data.List as List
import Numeric

type Rnd = State StdGen
type Distr = Rnd Double

distrConst :: Double -> Distr
distrConst = return

distrN :: Double -> Double -> Distr
distrN m std = (+) m . (*) std <$> state normal

distrAsymN :: Double -> Double -> Double -> Distr
distrAsymN m lowStd highStd = (+) m . mulStd <$> state normal
  where
    mulStd :: Double -> Double
    mulStd v
      | v <= 0 = v*lowStd
      | otherwise = v*highStd

data MeanMinMax = MeanMinMax {
  mmmMean :: Double,
  mmmMin :: Double,
  mmmMax :: Double
}

mmm :: Double -> Double -> Double -> MeanMinMax
mmm = MeanMinMax

instance Show MeanMinMax where
    show (MeanMinMax m pMin pMax) = showD 2 m ++ " (" ++ showD 2 pMin ++ " .. " ++ showD 2 pMax ++ ")"

instance Num MeanMinMax where
  (MeanMinMax a c e) + (MeanMinMax b d f) = MeanMinMax (a + b) (c + d) (e + f)
  (MeanMinMax a c e) - (MeanMinMax b d f) = MeanMinMax (a - b) (c - d) (e - f)
  (MeanMinMax a c e) * (MeanMinMax b d f) = MeanMinMax (a * b) (c * d) (e * f)
  negate (MeanMinMax a b c) = MeanMinMax (-a) (-b) (-c)
  abs (MeanMinMax a b c) = MeanMinMax (abs a) (abs b) (abs c)
  signum (MeanMinMax a b c) = MeanMinMax (signum a) (signum b) (signum c)
  fromInteger x =
    let d = fromIntegral x
    in MeanMinMax d d d

instance Fractional MeanMinMax where
  (MeanMinMax a c e) / (MeanMinMax b d f) = MeanMinMax (a / b) (c / d) (e / f)
  fromRational x =
    let d = fromRational x
    in MeanMinMax d d d

mmmProbability95AtLeast :: MeanMinMax -> Double -> Double
mmmProbability95AtLeast (MeanMinMax m a z) x
  | x == m = 0.5
  | x < m = complCumulative (normalDistr m ((m - a)/2)) x
  | otherwise = complCumulative (normalDistr m ((z - m)/2)) x

(|*|) :: MeanMinMax -> Double -> MeanMinMax
(MeanMinMax m pMin pMax) |*| v = MeanMinMax (m*v) (pMin*v) (pMax*v)

(|+|) :: MeanMinMax -> Double -> MeanMinMax
(MeanMinMax m pMin pMax) |+| v = MeanMinMax (m+v) (pMin+v) (pMax+v)

minMax95 :: Double -> Double -> Distr
minMax95 pMin pMax = distrN m std where
  m = (pMax + pMin)/2
  std = (pMax - pMin)/4

minMax99 :: Double -> Double -> Distr
minMax99 pMin pMax = distrN m std where
  m = (pMax + pMin)/2
  std = (pMax - pMin)/6

meanMinMax95N :: MeanMinMax -> Distr
meanMinMax95N (MeanMinMax m pMin pMax) = distrAsymN m lowStd highStd
  where
    lowStd = (m - pMin)/2
    highStd = (pMax - m)/2

meanMinMax95 :: Double -> Double -> Double -> Distr
meanMinMax95 m pMin pMax = meanMinMax95N $ MeanMinMax m pMin pMax

meanMinMax99N :: MeanMinMax -> Distr
meanMinMax99N (MeanMinMax m pMin pMax) = distrN mean1 std where
  mean1 = (pMax + 4*m + pMin)/6
  std = (pMax - pMin)/6

meanMinMax99 :: Double -> Double -> Double -> Distr
meanMinMax99 m pMin pMax = meanMinMax99N $ MeanMinMax m pMin pMax

mkN95 :: [Double] -> Distr
mkN95 [] = distrN 0 1
mkN95 xs = meanMinMax95N $ mkMeanMinMax $ withConfidence 0.997 xs

withConfidence :: Double -> [Double] -> [Double]
withConfidence confidence xs = if d == 0 then xs else take (len - 2*d) $ drop d $ List.sort xs
  where
    len = length xs
    d = floor $ (1 - confidence)/2 * fromIntegral len

mkMeanMinMax :: [Double] -> MeanMinMax
mkMeanMinMax xs = MeanMinMax (sum xs / fromIntegral (length xs) ) (minimum xs) (maximum xs)

simulate :: Int -> Rnd a -> [a]
simulate 0 _ = []
simulate times r = runRnd times r : simulate (times - 1) r

simulateN :: Int -> Rnd Double -> Distr
simulateN times r = mkN95 $ simulate times r

simulateMmm :: Int -> Double -> Rnd Double -> MeanMinMax
simulateMmm times confidence r = mkMeanMinMax $ withConfidence confidence $ simulate times r

runRnd :: Int -> Rnd a -> a
runRnd seed r = evalState r (mkStdGen seed)

scanM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m [a]
scanM _ q [] = return [q]
scanM f q (x:xs) =
  do
    q2 <- f q x
    qs <- scanM f q2 xs
    return (q:qs)

showD :: RealFloat a => Int -> a -> String
showD numOfDecimals floatNum = showFFloat (Just numOfDecimals) floatNum ""

max_stars_repo_name: antonzherdev/shares-value

max_issues_repo_name: antonzherdev/shares-value

max_forks_repo_name: antonzherdev/shares-value


text:
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import Data.Complex
import Data.Monoid
import Control.Arrow ((***))
import Control.Monad.State
import Control.Monad.Identity
import System.Random
import Lucid.Svg

import Data.List (foldl')

-- |Defines the finite trace of a coalgebra up to n iterations
traceN :: (Monad m) => Int -> (x -> m [x]) -> x -> m [x]
traceN 0 c seed = return []
traceN 1 c seed = c seed
traceN n c seed = concat <$> (traceN (n-1) c seed >>= mapM c)

data NDFPP = F | T Bool | Push | Pop | X
  deriving (Eq , Show)

-- |Stochastic seaweed L-system
--
-- > F=FF
-- > X=F-[[X]+X]+F[+FX]-X
--    ,F+[[X]-X]-F[-FX]+X
--
stochweed :: (RandomGen g) => NDFPP -> State g [NDFPP]
stochweed F = return [F , F]
stochweed X = run <$> state random
  where
    run b = [F , T (not b) , Push , Push , X , Pop , T b , X , Pop
            ,T b , F , Push , T b , F , X , Pop , T (not b) , X]
stochweed x = return [x]

type Seed = Int

stochweedDet :: Seed -> Int -> [NDFPP]
stochweedDet seed n = evalState (traceN n stochweed X) (mkStdGen seed)

rot :: Float -> Complex Float -> Complex Float
rot angle = (* cis angle)

{-
render :: Float -> [NDFPP] -> State [Complex Float] (Svg ())
render angle = foldl' (\r x -> r >>= go x) (return $ return ())
  where
    go :: NDFPP -> Svg () -> State [Complex Float] (Svg ())
    go F = path_ [ d_ (mA
-}

mvTo   c = mA (realPart c) (imagPart c)
lineTo c = lA (realPart c) (imagPart c)

-- state is current dir and current pos
renderS :: Float -> [NDFPP] -> StateT [(Complex Float , Complex Float)] Svg ()
renderS angle []     = return ()
renderS angle (i:is) = render1 i >> renderS angle is
  where
    render1 :: NDFPP -> StateT [(Complex Float , Complex Float)] Svg ()
    render1 i = do
      (dir , p):ps <- get
      case i of
        T True  -> put ((rot   angle  dir , p):ps)
        T False -> put ((rot (-angle) dir , p):ps)
        Push -> put ((dir , p):(dir , p):ps)
        Pop  -> put ps
        _ -> let p' = dir + p
              in put ((dir, p'):ps)
              >> lift (path_ [ d_ (mvTo p <> lineTo p' <> z) , stroke_ "black" ])

svg :: Svg () -> Svg ()
svg content = do
  doctype_
  with (svg11_ content) [version_ "1.1", width_ "300" , height_ "200"]

main :: IO ()
main = let tree = stochweedDet 123513 3
        in print $ svg $ evalStateT (renderS 22.5 tree) [(0 :+ 10 , mkPolar 0 0)]

max_stars_repo_name: VictorCMiraldo/hs-victor-lsys-cover

max_issues_repo_name: VictorCMiraldo/hs-victor-lsys-cover

max_forks_repo_name: VictorCMiraldo/hs-victor-lsys-cover


text:
-- |
-- Copyright: 2013 (C) Amgen, Inc
--

{-# Language ConstraintKinds #-}
{-# Language DefaultSignatures #-}
{-# Language DataKinds #-}
{-# Language FlexibleContexts #-}
{-# Language FlexibleInstances #-}
{-# Language FunctionalDependencies #-}
{-# Language GADTs #-}
{-# Language LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# Language TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# Language ViewPatterns #-}

-- required to not warn about IsVector usage.
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module Language.R.Literal
  ( -- * Literals conversion
    Literal(..)
  , toPairList
  , fromPairList
    -- * Derived helpers
  , fromSomeSEXP
  , mkSEXP
  , dynSEXP
  , mkSEXPVector
  , mkSEXPVectorIO
  , mkProtectedSEXPVector
  , mkProtectedSEXPVectorIO
    -- * Internal
  , funToSEXP
  ) where

import           Control.Memory.Region
import           Control.Monad.R.Class
import qualified Data.Vector.SEXP as SVector
import qualified Data.Vector.SEXP.Mutable as SMVector
import qualified Foreign.R as R
import qualified Foreign.R.Internal as R (somesexp)
import           Foreign.R.Type ( IsVector, SSEXPTYPE )
import           Foreign.R ( SEXP, SomeSEXP(..) )
import           Internal.Error
import           {-# SOURCE #-} Language.R.Internal (r1)
import           Language.R.Globals (nilValue)
import           Language.R.HExp
import           Language.R.Instance
import           Language.R.Internal.FunWrappers
import           Language.R.Internal.FunWrappers.TH

import Data.Singletons ( Sing, SingI, fromSing, sing )

import Control.DeepSeq ( NFData )
import Control.Monad ( void, zipWithM_ )
import Data.Int (Int32)
import qualified Data.ByteString.Unsafe as B
import Data.Complex (Complex)
import Data.Text (Text)
import qualified Data.Text.Encoding as T
import Foreign          ( FunPtr, castPtr )
import Foreign.C.String ( withCString )
import Foreign.Storable ( Storable, pokeElemOff )
import qualified GHC.Foreign as GHC
import GHC.IO.Encoding.UTF8
import System.IO.Unsafe ( unsafePerformIO )

-- | Values that can be converted to 'SEXP'.
class SingI ty => Literal a ty | a -> ty where
    -- | Internal function for converting a literal to a 'SEXP' value. You
    -- probably want to be using 'mkSEXP' instead.
    mkSEXPIO :: a -> IO (SEXP V ty)
    fromSEXP :: SEXP s ty -> a

    default mkSEXPIO :: (IsVector ty, Literal [a] ty) => a -> IO (SEXP V ty)
    mkSEXPIO x = mkSEXPIO [x]

    default fromSEXP :: (IsVector ty, Literal [a] ty) => SEXP s ty -> a
    fromSEXP (fromSEXP -> [x]) = x
    fromSEXP _ = failure "fromSEXP" "Not a singleton vector."

-- |  Create a SEXP value and protect it in current region
mkSEXP :: (Literal a b, MonadR m) => a -> m (SEXP (Region m) b)
mkSEXP x = acquire =<< io (mkSEXPIO x)

-- | Like 'fromSEXP', but with no static type satefy. Performs a dynamic
-- (i.e. at runtime) check instead.
fromSomeSEXP :: forall s a form. (Literal a form) => R.SomeSEXP s -> a
fromSomeSEXP = fromSEXP . R.cast (sing :: Sing form)

-- | Like 'fromSomeSEXP', but behaves like the @as.*@ family of functions
-- in R, by performing a best effort conversion to the target form (e.g. rounds
-- reals to integers, etc) for atomic types.
dynSEXP :: forall a s ty. (Literal a ty) => SomeSEXP s -> a
dynSEXP (SomeSEXP sx) =
    fromSomeSEXP $ unsafePerformIO $ case fromSing (sing :: SSEXPTYPE ty) of
      R.Char -> r1 "as.character" sx
      R.Int -> r1 "as.integer" sx
      R.Real -> r1 "as.double" sx
      R.Complex -> r1 "as.complex" sx
      R.Logical -> r1 "as.logical" sx
      R.Raw -> r1 "as.raw" sx
      _ -> return $ SomeSEXP $ R.release sx

{-# NOINLINE mkSEXPVector #-}
mkSEXPVector :: (Storable (SVector.ElemRep s a), IsVector a)
             => SSEXPTYPE a
             -> [IO (SVector.ElemRep s a)]
             -> SEXP s a
mkSEXPVector ty allocators = unsafePerformIO $ mkSEXPVectorIO ty allocators

mkSEXPVectorIO :: (Storable (SVector.ElemRep s a), IsVector a)
               => SSEXPTYPE a
               -> [IO (SVector.ElemRep s a)]
               -> IO (SEXP s a)
mkSEXPVectorIO ty allocators =
    R.withProtected (R.allocVector ty $ length allocators) $ \vec -> do
      let ptr = castPtr $ R.unsafeSEXPToVectorPtr vec
      zipWithM_ (\i -> (>>= pokeElemOff ptr i)) [0..] allocators
      return vec

{-# NOINLINE mkProtectedSEXPVector #-}
mkProtectedSEXPVector :: IsVector b
                      => SSEXPTYPE b
                      -> [SEXP s a]
                      -> SEXP s b
mkProtectedSEXPVector ty xs = unsafePerformIO $ mkProtectedSEXPVectorIO ty xs

mkProtectedSEXPVectorIO :: IsVector b
                        => SSEXPTYPE b
                        -> [SEXP s a]
                        -> IO (SEXP s b)
mkProtectedSEXPVectorIO ty xs = do
    mapM_ (void . R.protect) xs
    z <- R.withProtected (R.allocVector ty $ length xs) $ \vec -> do
           let ptr = castPtr $ R.unsafeSEXPToVectorPtr vec
           zipWithM_ (pokeElemOff ptr) [0..] xs
           return vec
    R.unprotect (length xs)
    return z

instance Literal [R.Logical] 'R.Logical where
    mkSEXPIO = mkSEXPVectorIO sing . map return
    fromSEXP (hexp -> Logical v) = SVector.toList v
    fromSEXP _ =
        failure "fromSEXP" "Logical expected where some other expression appeared."

instance Literal [Int32] 'R.Int where
    mkSEXPIO = mkSEXPVectorIO sing . map return
    fromSEXP (hexp -> Int v) = SVector.toList v
    fromSEXP _ =
        failure "fromSEXP" "Int expected where some other expression appeared."

instance Literal [Double] 'R.Real where
    mkSEXPIO = mkSEXPVectorIO sing . map return
    fromSEXP (hexp -> Real v) = SVector.toList v
    fromSEXP _ =
        failure "fromSEXP" "Numeric expected where some other expression appeared."

instance Literal [Complex Double] 'R.Complex where
    mkSEXPIO = mkSEXPVectorIO sing . map return
    fromSEXP (hexp -> Complex v) = SVector.toList v
    fromSEXP _ =
        failure "fromSEXP" "Complex expected where some other expression appeared."

instance Literal [String] 'R.String where
    mkSEXPIO =
        mkSEXPVectorIO sing .
        map (\str -> GHC.withCString utf8 str (R.mkCharCE R.CE_UTF8))
    fromSEXP (hexp -> String v) =
        map (\(hexp -> Char xs) -> SVector.toString xs) (SVector.toList v)
    fromSEXP _ =
        failure "fromSEXP" "String expected where some other expression appeared."

instance Literal Text 'R.String where
    mkSEXPIO s =
        mkSEXPVectorIO sing
          [ B.unsafeUseAsCStringLen (T.encodeUtf8 s) $
              uncurry (R.mkCharLenCE R.CE_UTF8) ]
    fromSEXP (hexp -> String v) =
      case SVector.toList v of
        [hexp -> Char x] -> SVector.unsafeWithByteString x $ \p -> do
           pure $ T.decodeUtf8 p
        _ -> failure "fromSEXP" "Not a singleton vector"
    fromSEXP _ =
      failure "fromSEXP" "String expected where some other expression appeared."

-- | Create a pairlist from an association list. Result is either a pairlist or
-- @nilValue@ if the input is the null list. These are two distinct forms. Hence
-- why the type of this function is not more precise.
toPairList :: MonadR m => [(String, SomeSEXP (Region m))] -> m (SomeSEXP (Region m))
toPairList [] = return $ SomeSEXP (R.release nilValue)
toPairList ((k, SomeSEXP v):kvs) = do
    -- No need to protect the tag because it's in the symbol table, so won't be
    -- garbage collected.
    tag <- io $ withCString k R.install
    toPairList kvs >>= \case
      SomeSEXP cdr@(hexp -> Nil) ->
        fmap SomeSEXP $ unhexp $ List v cdr (R.unsafeRelease tag)
      SomeSEXP cdr@(hexp -> List _ _ _) ->
        fmap SomeSEXP $ unhexp $ List v cdr (R.unsafeRelease tag)
      _ -> impossible "toPairList"

-- | Create an association list from a pairlist. R Pairlists are nil-terminated
-- chains of nested cons cells, as in LISP.
fromPairList :: SomeSEXP s -> [(String, SomeSEXP s)]
fromPairList (SomeSEXP (hexp -> Nil)) = []
fromPairList (SomeSEXP (hexp -> List car cdr (hexp -> Symbol (hexp -> Char name) _ _))) =
    (SVector.toString name, SomeSEXP car) : fromPairList (SomeSEXP cdr)
fromPairList (SomeSEXP (hexp -> List _ _ _)) =
    failure "fromPairList" "Association listed expected but tag not set."
fromPairList _ =
    failure "fromPairList" "Pairlist expected where some other expression appeared."

-- Use the default definitions included in the class declaration.
instance Literal R.Logical 'R.Logical
instance Literal Int32 'R.Int
instance Literal Double 'R.Real
instance Literal (Complex Double) 'R.Complex

instance Literal String 'R.String where
    mkSEXPIO x = mkSEXPIO [x]
    fromSEXP x@(hexp -> String {})
      | [h] <- fromSEXP x = h
      | otherwise = failure "fromSEXP" "Not a singleton vector."
    fromSEXP _ =
        failure "fromSEXP" "String expected where some other expression appeared."

instance SVector.SVECTOR ty a => Literal (SVector.Vector ty a) ty where
    mkSEXPIO = return . SVector.toSEXP
    fromSEXP = SVector.fromSEXP . R.cast (sing :: SSEXPTYPE ty)
             . SomeSEXP

instance SVector.VECTOR V ty a => Literal (SMVector.MVector V ty a) ty where
    mkSEXPIO = unsafeRunRegion . SMVector.toSEXP
    fromSEXP = SMVector.fromSEXP . R.cast (sing :: SSEXPTYPE ty)
             . SomeSEXP . R.release

instance SingI a => Literal (SEXP s a) a where
    mkSEXPIO = fmap R.unsafeRelease . return
    fromSEXP = R.cast (sing :: SSEXPTYPE a) . SomeSEXP . R.unsafeRelease

instance Literal (SomeSEXP s) 'R.Any where
    -- The ANYSXP type in R plays the same role as SomeSEXP in H. It is a dummy
    -- type tag, that is never seen in any object. It serves only as a stand-in
    -- when the real type is not known.
    mkSEXPIO (SomeSEXP s) = return . R.unsafeRelease $ R.unsafeCoerce s
    fromSEXP = SomeSEXP . R.unsafeRelease

instance (NFData a, Literal a b) => Literal (R s a) 'R.ExtPtr where
    mkSEXPIO = funToSEXP wrap0
    fromSEXP = unimplemented "Literal (R s a) fromSEXP"

instance (NFData b, Literal a a0, Literal b b0) => Literal (a -> R s b) 'R.ExtPtr where
    mkSEXPIO = funToSEXP wrap1
    fromSEXP = unimplemented "Literal (a -> R s b) fromSEXP"

instance (NFData c, Literal a a0, Literal b b0, Literal c c0)
         => Literal (a -> b -> R s c) 'R.ExtPtr where
    mkSEXPIO   = funToSEXP wrap2
    fromSEXP = unimplemented "Literal (a -> b -> IO c) fromSEXP"

-- | A class for functions that can be converted to functions on SEXPs.
class HFunWrap a b | a -> b where
    hFunWrap :: a -> b

instance (NFData a, Literal a la) => HFunWrap (R s a) (IO R.SEXP0) where
    hFunWrap a = fmap R.unsexp $ (mkSEXPIO $!) =<< unsafeRunRegion a

instance (Literal a la, HFunWrap b wb)
         => HFunWrap (a -> b) (R.SEXP0 -> wb) where
    hFunWrap f a = hFunWrap $ f $! fromSEXP (R.cast sing (R.somesexp a) :: SEXP s la)

foreign import ccall "missing_r.h funPtrToSEXP" funPtrToSEXP
    :: FunPtr a -> IO (SEXP s 'R.ExtPtr)

funToSEXP :: HFunWrap a b => (b -> IO (FunPtr b)) -> a -> IO (SEXP s 'R.ExtPtr)
funToSEXP w x = funPtrToSEXP =<< w (hFunWrap x)

$(thWrapperLiterals 3 12)

max_stars_repo_name: reactormonk/HaskellR

max_issues_repo_name: reactormonk/HaskellR

max_forks_repo_name: reactormonk/HaskellR


text:
import Graphics.Rendering.Chart.Easy
import Graphics.Rendering.Chart.Backend.Diagrams(toFile)

import ActivationFunction
import Numeric.LinearAlgebra.Data(vector, toList)

main = toFile def "activation_function.svg" $ do
    layout_title .= "activation function"
    let input = vector [(-5),(-4.9)..5]
    plot (line "step" [stepSignals input])
    plot (line "sigmoid" [sigmoidSignals input])
    plot (line "relu" [reluSignals input])

stepSignals xs = zipWith (,) (toList xs) (toList $ step' xs)

sigmoidSignals xs = zipWith (,) (toList xs) (toList $ sigmoid xs)

reluSignals xs = zipWith (,) (toList xs) (toList $ relu xs)