text:
{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, DeriveGeneric #-}

module BayesStack.Models.Topic.SharedTaste
  ( -- * Primitives
    STData(..)
  , ItemSource(..)
  , Node(..), Item(..), Topic(..)
  , NodeItem, setupNodeItems
  , Friendship(..), otherFriend, isFriend, getFriends
    -- * Initialization
  , ModelInit
  , randomInitialize, smartInitialize
    -- * Model
  , STModel(..), ItemUnit
  , model, modelLikelihood
  , STModelState (..), getModelState
  , sortTopics
  , ItemVars(..)
    -- * Quantities of interest
  , friendInfluence
  , theta
  ) where

import Prelude hiding (mapM, sum, product)

import Data.EnumMap (EnumMap)
import qualified Data.EnumMap as EM

import Data.Sequence (Seq)
import qualified Data.Sequence as SQ

import Data.Set (Set)
import qualified Data.Set as S

import qualified Data.EnumSet as ES
import qualified Data.Vector as V

import Data.Traversable
import Data.Foldable
import Data.Monoid
import Data.Function (on)
import Data.List (sortBy)

import Control.Monad (liftM)
import Control.Monad.Trans.State
import Control.Monad.Trans.Class

import Data.Random
import Data.Random.Distribution.Bernoulli
import Data.Random.Sequence
import Data.Number.LogFloat hiding (realToFrac)

import BayesStack.Core
import BayesStack.Categorical
import BayesStack.DirMulti
import BayesStack.TupleEnum
import BayesStack.Models.Topic.Types

import Control.Monad (when)
import Control.Monad.IO.Class

import Statistics.Sample
import Data.Serialize (Serialize)
import GHC.Generics

data ItemSource = Shared | Own deriving (Show, Eq, Generic, Enum, Ord)
instance Serialize ItemSource

data STData = STData { stAlphaGammaShared, stAlphaGammaOwn :: Double
                     , stAlphaOmega :: Double
                     , stAlphaPsi :: Double
                     , stAlphaLambda :: Double
                     , stAlphaPhi :: Double
                     , stNodes :: Set Node
                     , stFriendships :: Set Friendship
                     , stItems :: Set Item
                     , stTopics :: Set Topic
                     , stNodeItems :: EnumMap NodeItem (Node, Item)
                     }
               deriving (Show, Eq, Generic)
instance Serialize STData

data ItemVars = ItemVars { ivS :: !ItemSource
                         , ivF :: !Node
                         , ivT :: !Topic
                         }
                deriving (Show, Eq, Generic)
instance Serialize ItemVars

data STModel = STModel { mData :: STData
                       , mGammas :: SharedEnumMap Node (Multinom ItemSource)
                       , mOmegas :: SharedEnumMap Node (Multinom Topic)
                       , mPsis :: SharedEnumMap Node (Multinom Node)
                       , mLambdas :: SharedEnumMap Friendship (Multinom Topic)
                       , mPhis :: SharedEnumMap Topic (Multinom Item)
                       , mVars :: SharedEnumMap NodeItem ItemVars
                       , mSortedTopics :: SharedEnumMap Item [Topic]
                       }

data STModelState = STModelState { msData :: STData
                                 , msGammas :: EnumMap Node (Multinom ItemSource)
                                 , msOmegas :: EnumMap Node (Multinom Topic)
                                 , msPsis :: EnumMap Node (Multinom Node)
                                 , msLambdas :: EnumMap Friendship (Multinom Topic)
                                 , msPhis :: EnumMap Topic (Multinom Item)
                                 , msVars :: EnumMap NodeItem ItemVars
                                 , msLogLikelihood :: Double
                                 } deriving (Show, Generic)
instance Serialize STModelState

type ModelInit = EnumMap NodeItem ItemVars

randomInitialize' :: STData -> ModelInit -> RVar ModelInit
randomInitialize' d init =
  let unset = EM.keysSet (stNodeItems d) `ES.difference` EM.keysSet init
      topics = S.toList $ stTopics d
      randomInit :: NodeItem -> RVar ModelInit
      randomInit ni = do t <- randomElement topics
                         let (n,_) = EM.findWithDefault (error "Can't find nodeItem") ni (stNodeItems d)
                             friends = getFriends (S.toList $ stFriendships d) n
                         f <- randomElement friends
                         s <- bernoulli $ stAlphaGammaShared d
                         let s' = case s of
                                        True  -> Shared
                                        False -> Own
                         return $ EM.singleton ni $ ItemVars s' f t
  in liftM ((init `mappend`) . mconcat) $ forM (ES.toList unset) randomInit

randomInitialize :: STData -> RVar ModelInit
randomInitialize = (flip randomInitialize') EM.empty

smartInitialize :: STData -> RVar ModelInit
smartInitialize d =
  let STData {stTopics=topics, stNodes=nodes, stItems=items, stNodeItems=nodeItems} = d
      STData {stFriendships=friendships, stNodeItems=nis} = d
      nisInv :: EnumMap (Node,Item) [NodeItem]
      nisInv = EM.fromListWith (++) $ map (\(ni,(n,i))->((n,i),[ni])) $ EM.toList nis

      sharedTopics :: Friendship -> StateT (EnumMap Item Topic, EnumMap Friendship (Set Topic)) RVar ModelInit
      sharedTopics fs@(Friendship (a,b)) =
        let findItems n = S.fromList $ map snd $ filter (\(n',i)->n==n') $ toList nodeItems
            sharedItems = toList $ S.intersection (findItems a) (findItems b)
        in liftM mconcat $ forM sharedItems $ \x -> do
             (itemTopics,_) <- get
             t <- if x `EM.member` itemTopics
                    then return $ EM.findWithDefault (error "Item has no topic") x itemTopics
                    else do (_, friendshipTopics) <- get
                            --let possTopics = EM.findWithDefault topics fs friendshipTopics
                            let possTopics = topics -- FIXME
                            t <- lift $ randomElement $ S.toList possTopics
                            modify $ \(a,b)->(EM.insert x t a, b)
                            return t
             modify $ \(a,b)->(a, EM.insertWith S.union fs (S.singleton t) b)
             return $ EM.fromList $ do ax <- EM.findWithDefault (error "ouch") (a,x) nisInv
                                       return (ax, ItemVars Shared b t)
                                 ++ do bx <- EM.findWithDefault (error "ouch") (b,x) nisInv
                                       return (bx, ItemVars Shared a t)
  in do a <- evalStateT (mapM sharedTopics $ S.toList friendships) (EM.empty, EM.empty)
        randomInitialize' d $ mconcat a

data ItemUnit = ItemUnit { iuModel :: STModel
                         , iuNodeItem :: NodeItem
                         , iuFriends :: Set Node
                         , iuN :: Node
                         , iuVars :: Shared ItemVars
                         , iuX :: Item
                         , iuGamma :: Shared (Multinom ItemSource)
                         , iuOmega :: Shared (Multinom Topic)
                         , iuLambdas :: SharedEnumMap Friendship (Multinom Topic)
                         , iuPhis :: SharedEnumMap Topic (Multinom Item)
                         , iuState :: Shared GibbsUpdateState
                         }

model :: STData -> ModelInit -> ModelMonad (Seq ItemUnit, STModel)
model d init =
  do let STData {stTopics=topics, stNodes=nodes, stItems=items, stNodeItems=nis} = d
         STData {stFriendships=friendships} = d
         friends :: EnumMap Node (Set Node)
         friends = foldMap (\n->EM.singleton n $ S.fromList $ getFriends (S.toList friendships) n) nodes
     gammas <- newSharedEnumMap (S.toList nodes) $ \n ->
       --return $ dirMulti [ (Shared, stAlphaGammaShared d)
       --                  , (Own, stAlphaGammaOwn d) ]
       return $ multinom [ (Shared, stAlphaGammaShared d)
                         , (Own, stAlphaGammaOwn d) ]
     omegas <- newSharedEnumMap (S.toList nodes) $ \n ->
       return $ symDirMulti (stAlphaOmega d) (S.toList topics)
     psis <- newSharedEnumMap (S.toList nodes) $ \n ->
       return $ symDirMulti (stAlphaPsi d) (S.toList nodes)
     lambdas <- newSharedEnumMap (S.toList friendships) $ \n ->
       return $ symDirMulti (stAlphaLambda d) (S.toList topics)
     phis <- newSharedEnumMap (S.toList topics) $ \t ->
       return $ symDirMulti (stAlphaPhi d) (S.toList items)

     ivs <- newSharedEnumMap (EM.keys nis) $ \ni ->
       return $ EM.findWithDefault (error "Incomplete initialization") ni init

     sortedTopics <- newSharedEnumMap (S.toList items) $ \x -> return $ S.toList topics

     let model = STModel { mData = d
                         , mGammas = gammas
                         , mOmegas = omegas
                         , mPsis = psis
                         , mLambdas = lambdas
                         , mPhis = phis
                         , mVars = ivs
                         , mSortedTopics = sortedTopics
                         }

     itemUnits <- forM (EM.toList ivs) $ \(ni,iv) ->
       do state <- newGibbsUpdateState
          let (n,x) = nis EM.! ni
          let unit = ItemUnit { iuModel = model
                              , iuNodeItem = ni
                              , iuFriends = friends EM.! n
                              , iuN = n
                              , iuVars = iv
                              , iuX = x
                              , iuGamma = gammas EM.! n
                              , iuOmega = omegas EM.! n
                              , iuLambdas = EM.filterWithKey (\k _->isFriend n k) lambdas
                              , iuPhis = phis
                              , iuState = state
                              }
          getShared iv >>= guSet unit
          return unit
     return (SQ.fromList itemUnits, model)

sortTopics :: STModel -> ModelMonad ()
sortTopics model =
  forM_ (EM.toList $ mSortedTopics model) $ \(x,topics)->do
    d <- getShared topics
    weights <- forM d $ \t->do phi <- getShared $ mPhis model EM.! t
                               return $ sampleProb phi x -- FIXME
    setShared topics $ map snd $ sortBy (flip (compare `on` fst)) $ zip weights d

modelLikelihood :: STModelState -> Probability
modelLikelihood model =
  product $ map likelihood (EM.elems $ msGammas model)
         ++ map likelihood (EM.elems $ msPhis model)
         ++ map likelihood (EM.elems $ msLambdas model)
         ++ map likelihood (EM.elems $ msOmegas model)
         ++ map likelihood (EM.elems $ msPsis model)

instance GibbsUpdateUnit ItemUnit where
  type GUValue ItemUnit = ItemVars
  guProb unit (ItemVars s f t) =
    do gamma <- getShared $ iuGamma unit
       omega <- getShared $ iuOmega unit
       psi <- getShared $ mPsis (iuModel unit) EM.! iuN unit
       phi <- getShared $ iuPhis unit EM.! t
       lambda <- getShared $ iuLambdas unit EM.! Friendship (iuN unit, f)
       case s of
            Shared -> return $ sampleProb gamma s
                             * sampleProb psi f
                             * sampleProb lambda t
                             * sampleProb phi (iuX unit)
            Own -> return $ sampleProb gamma s
                          * sampleProb omega t
                          * sampleProb phi (iuX unit)

  guDomain unit = return $ (do t <- S.toList $ stTopics $ mData $ iuModel unit
                               f <- S.toList $ iuFriends unit
                               return $ ItemVars Shared f t)
                        ++ (do t <- S.toList $ stTopics $ mData $ iuModel unit
                               let f = head $ S.toList $ iuFriends unit
                               return $ ItemVars Own f t)

  guUnset unit =
    do ItemVars s f t <- getShared $ iuVars unit
       let x = iuX unit
           u = iuN unit
           m = iuModel unit
           gamma = iuGamma unit
           omega = iuOmega unit
           lambda = iuLambdas unit EM.! Friendship (iuN unit, f)
           phi = iuPhis unit EM.! t
       gamma `updateShared` decMultinom s
       case s of
            Shared -> do (mPsis m EM.! u) `updateShared` decMultinom f
                         (mPsis m EM.! f) `updateShared` decMultinom u
                         lambda `updateShared` decMultinom t
            Own -> omega `updateShared` decMultinom t
       phi `updateShared` decMultinom x
       return $ ItemVars s f t

  guSet unit iv@(ItemVars s f t) =
    do iuVars unit `setShared` iv
       let x = iuX unit
           u = iuN unit
           m = iuModel unit
           gamma = iuGamma unit
           omega = iuOmega unit
           lambda = iuLambdas unit EM.! Friendship (iuN unit, f)
           phi = iuPhis unit EM.! t
       gamma `updateShared` incMultinom s
       case s of
            Shared -> do (mPsis m EM.! u) `updateShared` incMultinom f
                         (mPsis m EM.! f) `updateShared` incMultinom u
                         lambda `updateShared` incMultinom t
            Own -> omega `updateShared` incMultinom t
       phi `updateShared` incMultinom x

  guState = iuState

getModelState :: STModel -> ModelMonad STModelState
getModelState model =
  do gammas <- getSharedEnumMap $ mGammas model
     omegas <- getSharedEnumMap $ mOmegas model
     psis <- getSharedEnumMap $ mPsis model
     lambdas <- getSharedEnumMap $ mLambdas model
     phis <- getSharedEnumMap $ mPhis model
     vars <- getSharedEnumMap $ mVars model
     let state = STModelState { msData = mData model
                              , msGammas = gammas
                              , msOmegas = omegas
                              , msPsis = psis
                              , msLambdas = lambdas
                              , msPhis = phis
                              , msVars = vars
                              , msLogLikelihood = logFromLogFloat $ modelLikelihood state
                              }
     return state

-- | The analogue of theta in LDA
theta :: STModelState -> Node -> Topic -> Double
theta state u t =
  sampleProb gamma Own * sampleProb omega t
  + sampleProb gamma Shared
  * sum (map (\f->let lambda = msLambdas state EM.! Friendship (u,f)
                  in sampleProb psi f * sampleProb lambda t
             )
         $ getFriends (S.toList $ stFriendships $ msData state) u
        )
  where psi = msPsis state EM.! u
        gamma = msGammas state EM.! u
        omega = msOmegas state EM.! u

friendInfluence :: STModelState -> Node -> Node -> Double
friendInfluence state u f =
  let lambda = msLambdas state EM.! Friendship(u,f)
      vars = map snd
             $ filter (\(ni,iv)->let (u',x) = stNodeItems (msData state) EM.! ni in u==u')
             $ EM.assocs $ msVars state
      tProbF = map (realToFrac . sampleProb lambda . ivT) vars
  in case tProbF of
       [] -> error "friendInfluence: vars is null"
       otherwise -> geometricMean $ V.fromList tProbF

max_stars_repo_name: laura-dietz/bayes-stack

max_issues_repo_name: laura-dietz/bayes-stack

max_forks_repo_name: laura-dietz/bayes-stack


text:
module Game.Physics.Types ( Position
                          , Velocity
                          , Force
                          , PhysicsObject(..)
                          ) where

import Prelewd

import Control.DeepSeq
import Numeric.LinearAlgebra hiding ((<>))

import Text.Show

type Position     = Vector Double
type Velocity     = Vector Double
type Force        = Vector Double

-- | Represents a simulatable object's current state. Pass a Data.Vector to of
--   these to the integrator to step the simulation.
data PhysicsObject = PObject { pos      :: Position
                             , vel      :: Velocity
                             , invMass  :: Double -- ^ 1/mass
                             -- | Given a function which retrieves a physics
                             --   object from its index in the vector and the
                             --   Δt from the start of the frame, return the
                             --   net force acting on the object.
                             --
                             --   The retrieved physics objects will have
                             --   updated positions and velocities.
                             , netForce :: (Int -> PhysicsObject)
                                        -> Double
                                        -> Force
                             }

instance Show PhysicsObject where
    show (PObject p v im _) = "pos = " <> show p
                            <> " | vel = " <> show v
                            <> " | invMass = " <> show im

instance NFData PhysicsObject

ext: hs

max_stars_repo_name: bfops/Chess

max_issues_repo_name: bfops/Chess

max_forks_repo_name: bfops/Chess


text:
-- |
-- Module      :  HashedExpression.Interp
-- Copyright   :  (c) OCA 2020
-- License     :  MIT (see the LICENSE file)
-- Maintainer  :  anandc@mcmaster.ca
-- Stability   :  provisional
-- Portability :  unportable
--
-- Evaluate expressions. Mainly useful for testings.
module HashedExpression.Interp where

import Data.Array
import Data.Complex hiding (conjugate)
import qualified Data.List as List
import qualified Data.Map as Map
import HashedExpression.Internal.Base hiding ((**))
import HashedExpression.Internal.Node
import HashedExpression.Utils
import HashedExpression.Value

data InterpValue
  = VR Double
  | VC (Complex Double)
  | V1DR (Array Int Double)
  | V1DC (Array Int (Complex Double))
  | V2DR (Array (Int, Int) Double)
  | V2DC (Array (Int, Int) (Complex Double))
  | V3DR (Array (Int, Int, Int) Double)
  | V3DC (Array (Int, Int, Int) (Complex Double))
  deriving (Show, Eq)

eval :: IsExpression e => ValMap -> e -> InterpValue
eval valMap e =
  let (mp, nID) = asRawExpr e
      (shape, et, op) = retrieveNode nID mp
      eval' :: NodeID -> InterpValue
      eval' x = eval valMap (mp, x)
      -------------------------------------------------------------------------------
      -- Partial helper functions
      constructR :: [Double] -> InterpValue
      constructR vs = case (shape, vs) of
        ([], [v]) -> VR v
        ([size], _) -> V1DR $ listArray (0, size - 1) vs
        ([size1, size2], _) -> V2DR $ listArray ((0, 0), (size1 - 1, size2 - 1)) vs
        ([size1, size2, size3], _) -> V3DR $ listArray ((0, 0, 0), (size1 - 1, size2 - 1, size3 - 1)) vs
      extractR :: InterpValue -> [Double]
      extractR val = case val of
        VR v -> [v]
        V1DR arr -> elems arr
        V2DR arr -> elems arr
        V3DR arr -> elems arr
      constructC :: [Complex Double] -> InterpValue
      constructC vs = case (shape, vs) of
        ([], [v]) -> VC v
        ([size], _) -> V1DC $ listArray (0, size - 1) vs
        ([size1, size2], _) -> V2DC $ listArray ((0, 0), (size1 - 1, size2 - 1)) vs
        ([size1, size2, size3], _) -> V3DC $ listArray ((0, 0, 0), (size1 - 1, size2 - 1, size3 - 1)) vs
      extractC :: InterpValue -> [Complex Double]
      extractC val = case val of
        VC v -> [v]
        V1DC arr -> elems arr
        V2DC arr -> elems arr
        V3DC arr -> elems arr
      unaryR op arg = arg |> eval' |> extractR |> map op |> constructR
      unaryC op arg = arg |> eval' |> extractC |> map op |> constructC
      binaryR op arg1 arg2 = zipWith op (extractR $ eval' arg1) (extractR $ eval' arg2) |> constructR
      binaryC op arg1 arg2 = zipWith op (extractC $ eval' arg1) (extractC $ eval' arg2) |> constructC
   in case op of
        Var name -> case (shape, Map.lookup name valMap) of
          ([], Just (VScalar val)) -> VR val
          ([_], Just (V1D arr)) -> V1DR arr
          ([_, _], Just (V2D arr)) -> V2DR arr
          ([_, _, _], Just (V3D arr)) -> V3DR arr
        Param name -> case (shape, Map.lookup name valMap) of
          ([], Just (VScalar val)) -> VR val
          ([_], Just (V1D arr)) -> V1DR arr
          ([_, _], Just (V2D arr)) -> V2DR arr
          ([_, _, _], Just (V3D arr)) -> V3DR arr
        Const v -> constructR $ replicate (product shape) v
        Sum args
          | et == R -> args |> map eval' |> map extractR |> foldl1 (zipWith (+)) |> constructR
          | et == C -> args |> map eval' |> map extractC |> foldl1 (zipWith (+)) |> constructC
        Mul args
          | et == R -> args |> map eval' |> map extractR |> foldl1 (zipWith (*)) |> constructR
          | et == C -> args |> map eval' |> map extractC |> foldl1 (zipWith (*)) |> constructC
        Power x arg
          | et == R -> unaryR (** fromIntegral x) arg
          | et == C -> unaryC (** fromIntegral x) arg
        Neg arg
          | et == R -> unaryR negate arg
          | et == C -> unaryC negate arg
        Scale arg1 arg2 -> case (retrieveElementType arg1 mp, retrieveElementType arg2 mp) of
          (R, R) ->
            let VR v = eval' arg1
             in unaryR (v *) arg2
          (R, C) ->
            let VR v = eval' arg1
             in unaryC ((v :+ 0) *) arg2
          (C, C) ->
            let VC v = eval' arg1
             in unaryC (v *) arg2
        Div arg1 arg2
          | et == R -> binaryR (/) arg1 arg2
          | et == C -> binaryC (/) arg1 arg2
        -------------------------------------------------------------------------------
        Sqrt arg -> unaryR sqrt arg
        Sin arg -> unaryR sin arg
        Cos arg -> unaryR cos arg
        Tan arg -> unaryR tan arg
        Exp arg -> unaryR exp arg
        Log arg -> unaryR log arg
        Sinh arg -> unaryR sinh arg
        Cosh arg -> unaryR cosh arg
        Tanh arg -> unaryR tanh arg
        Asin arg -> unaryR asin arg
        Acos arg -> unaryR acos arg
        Atan arg -> unaryR atan arg
        Asinh arg -> unaryR asinh arg
        Acosh arg -> unaryR acosh arg
        Atanh arg -> unaryR atanh arg
        -------------------------------------------------------------------------------
        RealImag arg1 arg2 ->
          let re = extractR (eval' arg1)
              im = extractR (eval' arg2)
           in constructC $ zipWith (:+) re im
        RealPart arg -> extractC (eval' arg) |> map realPart |> constructR
        ImagPart arg -> extractC (eval' arg) |> map imagPart |> constructR
        Conjugate arg -> unaryC conjugate arg
        -------------------------------------------------------------------------------
        InnerProd arg1 arg2
          | et == R ->
            let x = extractR (eval' arg1)
                y = extractR (eval' arg2)
             in VR $ sum $ zipWith (*) x y
          | et == C ->
            let x = extractC (eval' arg1)
                y = extractC (eval' arg2)
             in VC $ sum $ zipWith (*) x (map conjugate y)
        Piecewise marks conditionArg branchArgs
          | et == R ->
            let condition = extractR (eval' conditionArg)
                branches = map (extractR . eval') branchArgs
             in constructR $ zipWith (chooseBranch marks) condition (List.transpose branches)
          | et == C ->
            let condition = extractR (eval' conditionArg)
                branches = map (extractC . eval') branchArgs
             in constructC $ zipWith (chooseBranch marks) condition (List.transpose branches)
        Rotate rotateAmount arg
          | et == R -> case (rotateAmount, shape) of
            ([amount], [size]) ->
              let V1DR arr = eval' arg
               in V1DR $ rotate1D size amount arr
            ([amount1, amount2], [size1, size2]) ->
              let V2DR arr = eval' arg
               in V2DR $ rotate2D (size1, size2) (amount1, amount2) arr
            ([amount1, amount2, amount3], [size1, size2, size3]) ->
              let V3DR arr = eval' arg
               in V3DR $ rotate3D (size1, size2, size3) (amount1, amount2, amount3) arr
          | et == C -> case (rotateAmount, shape) of
            ([amount], [size]) ->
              let V1DC arr = eval' arg
               in V1DC $ rotate1D size amount arr
            ([amount1, amount2], [size1, size2]) ->
              let V2DC arr = eval' arg
               in V2DC $ rotate2D (size1, size2) (amount1, amount2) arr
            ([amount1, amount2, amount3], [size1, size2, size3]) ->
              let V3DC arr = eval' arg
               in V3DC $ rotate3D (size1, size2, size3) (amount1, amount2, amount3) arr
        FT arg -> case shape of
          [] -> eval' arg
          [size] ->
            let V1DC arr = eval' arg
             in V1DC $ fourierTransform1D FT_FORWARD size arr
          [size1, size2] ->
            let V2DC arr = eval' arg
             in V2DC $ fourierTransform2D FT_FORWARD (size1, size2) arr
          [size1, size2, size3] ->
            let V3DC arr = eval' arg
             in V3DC $ fourierTransform3D FT_FORWARD (size1, size2, size3) arr
        IFT arg -> case shape of
          [] -> eval' arg
          [size] ->
            let V1DC arr = eval' arg
             in V1DC $ fourierTransform1D FT_BACKWARD size arr
          [size1, size2] ->
            let V2DC arr = eval' arg
             in V2DC $ fourierTransform2D FT_BACKWARD (size1, size2) arr
          [size1, size2, size3] ->
            let V3DC arr = eval' arg
             in V3DC $ fourierTransform3D FT_BACKWARD (size1, size2, size3) arr
        Project dss arg -> case shape of
          [] -> case (retrieveShape arg mp, dss) of
            ([size], [At i]) -> case eval' arg of
              V1DR base -> VR $ base ! i
              V1DC base -> VC $ base ! i
            ([size1, size2], [At i, At j]) -> case eval' arg of
              V2DR base -> VR $ base ! (i, j)
              V2DC base -> VC $ base ! (i, j)
            ([size1, size2, size3], [At i, At j, At k]) -> case eval' arg of
              V3DR base -> VR $ base ! (i, j, k)
              V3DC base -> VC $ base ! (i, j, k)
          [size] -> case (retrieveShape arg mp, dss) of
            ([bSize], [ds]) -> case eval' arg of
              V1DR base -> V1DR $ listArray (0, size - 1) [base ! i | i <- mkIndices ds bSize]
              V1DC base -> V1DC $ listArray (0, size - 1) [base ! i | i <- mkIndices ds bSize]
            ([bSize1, bSize2], [ds1, ds2]) -> case eval' arg of
              V2DR base ->
                V1DR $
                  listArray (0, size - 1) $
                    [base ! (i, j) | i <- mkIndices ds1 bSize1, j <- mkIndices ds2 bSize2]
              V2DC base ->
                V1DC $
                  listArray (0, size - 1) $
                    [base ! (i, j) | i <- mkIndices ds1 bSize1, j <- mkIndices ds2 bSize2]
            ([bSize1, bSize2, bSize3], [ds1, ds2, ds3]) -> case eval' arg of
              V3DR base ->
                V1DR $
                  listArray (0, size - 1) $
                    [base ! (i, j, k) | i <- mkIndices ds1 bSize1, j <- mkIndices ds2 bSize2, k <- mkIndices ds3 bSize3]
              V3DC base ->
                V1DC $
                  listArray (0, size - 1) $
                    [base ! (i, j, k) | i <- mkIndices ds1 bSize1, j <- mkIndices ds2 bSize2, k <- mkIndices ds3 bSize3]
          [size1, size2] -> case (retrieveShape arg mp, dss) of
            ([bSize1, bSize2], [ds1, ds2]) -> case eval' arg of
              V2DR base ->
                V2DR $
                  listArray
                    ((0, 0), (size1 - 1, size2 - 1))
                    [base ! (i, j) | i <- mkIndices ds1 bSize1, j <- mkIndices ds2 bSize2]
              V2DC base ->
                V2DC $
                  listArray
                    ((0, 0), (size1 - 1, size2 - 1))
                    [base ! (i, j) | i <- mkIndices ds1 bSize1, j <- mkIndices ds2 bSize2]
            ([bSize1, bSize2, bSize3], [ds1, ds2, ds3]) -> case eval' arg of
              V3DR base ->
                V2DR $
                  listArray
                    ((0, 0), (size1 - 1, size2 - 1))
                    [base ! (i, j, k) | i <- mkIndices ds1 bSize1, j <- mkIndices ds2 bSize2, k <- mkIndices ds3 bSize3]
              V3DC base ->
                V2DC $
                  listArray
                    ((0, 0), (size1 - 1, size2 - 1))
                    [base ! (i, j, k) | i <- mkIndices ds1 bSize1, j <- mkIndices ds2 bSize2, k <- mkIndices ds3 bSize3]
          [size1, size2, size3] -> case (retrieveShape arg mp, dss) of
            ([bSize1, bSize2, bSize3], [ds1, ds2, ds3]) -> case eval' arg of
              V3DR base ->
                V3DR $
                  listArray
                    ((0, 0, 0), (size1 - 1, size2 - 1, size3 - 1))
                    [base ! (i, j, k) | i <- mkIndices ds1 bSize1, j <- mkIndices ds2 bSize2, k <- mkIndices ds3 bSize3]
              V3DC base ->
                V3DC $
                  listArray
                    ((0, 0, 0), (size1 - 1, size2 - 1, size3 - 1))
                    [base ! (i, j, k) | i <- mkIndices ds1 bSize1, j <- mkIndices ds2 bSize2, k <- mkIndices ds3 bSize3]
        Inject dss subArg baseArg
          | et == R ->
            let injectingElements = extractR $ eval' subArg
             in case (eval' baseArg, dss, shape) of
                  (V1DR base, [ds], [size]) ->
                    let indices = mkIndices ds size
                     in V1DR $ base // zip indices injectingElements
                  (V2DR base, [ds1, ds2], [size1, size2]) ->
                    let indices = [(i, j) | i <- mkIndices ds1 size1, j <- mkIndices ds2 size2]
                     in V2DR $ base // zip indices injectingElements
                  (V3DR base, [ds1, ds2, ds3], [size1, size2, size3]) ->
                    let indices = [(i, j, k) | i <- mkIndices ds1 size1, j <- mkIndices ds2 size2, k <- mkIndices ds3 size3]
                     in V3DR $ base // zip indices injectingElements
          | et == C ->
            let injectingElements = extractC $ eval' subArg
             in case (eval' baseArg, dss, shape) of
                  (V1DC base, [ds], [size]) ->
                    let indices = mkIndices ds size
                     in V1DC $ base // zip indices injectingElements
                  (V2DC base, [ds1, ds2], [size1, size2]) ->
                    let indices = [(i, j) | i <- mkIndices ds1 size1, j <- mkIndices ds2 size2]
                     in V2DC $ base // zip indices injectingElements
                  (V3DC base, [ds1, ds2, ds3], [size1, size2, size3]) ->
                    let indices = [(i, j, k) | i <- mkIndices ds1 size1, j <- mkIndices ds2 size2, k <- mkIndices ds3 size3]
                     in V3DC $ base // zip indices injectingElements
        MatMul arg1 arg2
          | et == R ->
            case (shape, retrieveShape arg1 mp, retrieveShape arg2 mp) of
              ([_m], [m, _n], [n]) ->
                let V2DR x = eval' arg1
                    V1DR y = eval' arg2
                 in V1DR $
                      listArray
                        (0, m - 1)
                        [ sum [(x ! (i, j)) * (y ! j) | j <- [0 .. n - 1]]
                          | i <- [0 .. m - 1]
                        ]
              ([_m, _p], [m, _n], [n, p]) ->
                let V2DR x = eval' arg1
                    V2DR y = eval' arg2
                 in V2DR $
                      listArray
                        ((0, 0), (m - 1, p - 1))
                        [ sum [(x ! (i, k)) * (y ! (k, j)) | k <- [0 .. n - 1]]
                          | i <- [0 .. m - 1],
                            j <- [0 .. p - 1]
                        ]
          | et == C ->
            case (shape, retrieveShape arg1 mp, retrieveShape arg2 mp) of
              ([_m], [m, _n], [n]) ->
                let V2DC x = eval' arg1
                    V1DC y = eval' arg2
                 in V1DC $
                      listArray
                        (0, m - 1)
                        [ sum [(x ! (i, j)) * (y ! j) | j <- [0 .. n - 1]]
                          | i <- [0 .. m - 1]
                        ]
              ([_m, _p], [m, _n], [n, p]) ->
                let V2DC x = eval' arg1
                    V2DC y = eval' arg2
                 in V2DC $
                      listArray
                        ((0, 0), (m - 1, p - 1))
                        [ sum [(x ! (i, k)) * (y ! (k, j)) | k <- [0 .. n - 1]]
                          | i <- [0 .. m - 1],
                            j <- [0 .. p - 1]
                        ]
        Transpose arg
          | et == R ->
            case (retrieveShape arg mp, shape) of
              -- ([m], [1, _m]) ->
              --   let V1DR x = eval' arg
              --    in V2DR $ listArray ((0, 0), (1, m - 1)) $ elems x
              ([m, n], [_n, _m]) ->
                let V2DR x = eval' arg
                 in V2DR $ listArray ((0, 0), (n - 1, m - 1)) [x ! (j, i) | i <- [0 .. n - 1], j <- [0 .. m - 1]]
          | et == C ->
            case (retrieveShape arg mp, shape) of
              -- ([m], [1, _m]) ->
              --   let V1DC x = eval' arg
              --    in V2DC $ listArray ((0, 0), (1, m - 1)) $ elems x
              ([m, n], [_n, _m]) ->
                let V2DC x = eval' arg
                 in V2DC $ listArray ((0, 0), (n - 1, m - 1)) [x ! (j, i) | i <- [0 .. n - 1], j <- [0 .. m - 1]]
        Coerce _ arg
          | et == R -> constructR . extractR $ eval' arg
          | et == C -> constructC . extractC $ eval' arg
        node -> error $ show node

zipWithA :: Ix x => (a -> b -> c) -> Array x a -> Array x b -> Array x c
zipWithA f xs ys = listArray (bounds xs) $ zipWith f (elems xs) (elems ys)

-- | Choose branch base on condition value.
-- In Decision tree, there are 2 possible outcomes, Head and Tail.
-- The decision of being Head or Tail is made based on the the condition value.
chooseBranch :: [Double] -> Double -> [a] -> a
chooseBranch marks val branches
  | val < head marks = head branches
  | otherwise =
    snd . last . filter ((val >=) . fst) $ zip marks (tail branches)

-- NOTE: `mod` in Haskell with negative number, e.g, (-5) `mod` 3 = 1

-- | One dimension rotation.
--   The elemnts falling off of the length of the 1D array will appear at the beginning of the array
rotate1D ::
  -- | Size of the input array
  Int ->
  -- | amount of rotation
  Int ->
  -- | Input array
  Array Int a ->
  -- | Rotated array
  Array Int a
rotate1D size amount arr =
  listArray
    (0, size - 1)
    [arr ! ((i - amount) `mod` size) | i <- [0 .. size - 1]]

-- | Two dimension rotation.
--   The elements falling off of the length of the 2D array will appear at the beginning of the each row or column of the array
rotate2D ::
  -- | Size of the 2d input array
  (Int, Int) ->
  -- | amount of rotation for 2d array
  (Int, Int) ->
  -- | Input 2d array
  Array (Int, Int) a ->
  -- | Rotated 2d array
  Array (Int, Int) a
rotate2D (size1, size2) (amount1, amount2) arr =
  listArray
    ((0, 0), (size1 - 1, size2 - 1))
    [ arr ! ((i - amount1) `mod` size1, (j - amount2) `mod` size2)
      | i <- [0 .. size1 - 1],
        j <- [0 .. size2 - 1]
    ]

-- | Three dimension rotation
rotate3D ::
  -- | Size of 3d input array
  (Int, Int, Int) ->
  -- | Amount of Rotation for 3d array
  (Int, Int, Int) ->
  -- | Input 3d array
  Array (Int, Int, Int) a ->
  -- | Rotated 3d array
  Array (Int, Int, Int) a
rotate3D (size1, size2, size3) (amount1, amount2, amount3) arr =
  listArray
    ((0, 0, 0), (size1 - 1, size2 - 1, size3 - 1))
    [ arr
        ! ( (i - amount1) `mod` size1,
            (j - amount2) `mod` size2,
            (k - amount3) `mod` size3
          )
      | i <- [0 .. size1 - 1],
        j <- [0 .. size2 - 1],
        k <- [0 .. size3 - 1]
    ]

data FTMode = FT_FORWARD | FT_BACKWARD deriving (Eq, Ord)

-- | Fourier Transform in 1D.
--  Frequency is just in one dimension.
--  Consider a real-valued function, S(x),
--  that is integrable on an interval of P, which will be the period of the Fourier series.
--  number of cycles is n.
--  length of cycle is P/n, and frequency is n/P.
--  so for input i the frequency is (2*pi*i*n)/P
fourierTransform1D ::
  FTMode -> Int -> Array Int (Complex Double) -> Array Int (Complex Double)
fourierTransform1D mode size arr =
  listArray (0, size - 1) [computeX i | i <- [0 .. size - 1]]
  where
    s = if mode == FT_BACKWARD then fromIntegral size else 1
    computeX i = (sum $ zipWithA (*) arr (fourierBasis i)) / s
    fourierBasis i =
      let frequency n = (2 * pi * fromIntegral (i * n) / fromIntegral size) * (if mode == FT_BACKWARD then -1 else 1)
       in listArray
            (0, size - 1)
            [ cos (frequency n) :+ (- sin (frequency n))
              | n <- [0 .. size - 1]
            ]

-- | Fourier Transform in 2D
--  the frequency should be calculated in 2D
--  Consider a real-valued function, S(x),
--  that is integrable on an interval of P, which will be the period of the Fourier series.
--  numbber of cycles is n.
--  length of cycle is P/n, and frequency is n/P.
--  so for input i the frequency is (2*pi*i*n)/P
--  the frequency should be calculated in both dimensions for i and j
fourierTransform2D ::
  FTMode ->
  (Int, Int) ->
  Array (Int, Int) (Complex Double) ->
  Array (Int, Int) (Complex Double)
fourierTransform2D mode (size1, size2) arr =
  listArray
    ((0, 0), (size1 - 1, size2 - 1))
    [computeX i j | i <- [0 .. size1 - 1], j <- [0 .. size2 - 1]]
  where
    s = if mode == FT_BACKWARD then fromIntegral (size1 * size2) else 1
    computeX i j = (sum $ zipWithA (*) arr (fourierBasis i j)) / s
    fourierBasis i j =
      let frequency m n =
            ( 2 * pi * fromIntegral (i * m) / fromIntegral size1
                + 2 * pi * fromIntegral (j * n) / fromIntegral size2
            )
              * (if mode == FT_BACKWARD then -1 else 1)
       in listArray
            ((0, 0), (size1 - 1, size2 - 1))
            [ cos (frequency m n) :+ (- sin (frequency m n))
              | m <- [0 .. size1 - 1],
                n <- [0 .. size2 - 1]
            ]

-- | Fourier Transform in 3D
--   the frequency should be calculated in 3D
--   Consider a real-valued function, S(x),
--   that is integrable on an interval of P, which will be the period of the Fourier series.
--   numbber of cycles is n.
--   length of cycle is P/n, and frequency is n/P.
--   so for input i the frequency is (2*pi*i*n)/P
--   the frequency should be calculated for all dimensions, i , j , k
fourierTransform3D ::
  FTMode ->
  (Int, Int, Int) ->
  Array (Int, Int, Int) (Complex Double) ->
  Array (Int, Int, Int) (Complex Double)
fourierTransform3D mode (size1, size2, size3) arr =
  listArray
    ((0, 0, 0), (size1 - 1, size2 - 1, size3 - 1))
    [ computeX i j k
      | i <- [0 .. size1 - 1],
        j <- [0 .. size2 - 1],
        k <- [0 .. size3 - 1]
    ]
  where
    s = if mode == FT_BACKWARD then fromIntegral (size1 * size2) else 1
    computeX i j k = (sum $ zipWithA (*) arr (fourierBasis i j k)) / s
    fourierBasis i j k =
      let frequency m n p =
            ( 2 * pi * fromIntegral (i * m) / fromIntegral size1
                + 2 * pi * fromIntegral (j * n) / fromIntegral size2
                + 2 * pi * fromIntegral (k * p) / fromIntegral size3
            )
              * (if mode == FT_BACKWARD then -1 else 1)
       in listArray
            ((0, 0, 0), (size1 - 1, size2 - 1, size3 - 1))
            [ cos (frequency m n p) :+ (- sin (frequency m n p))
              | m <- [0 .. size1 - 1],
                n <- [0 .. size2 - 1],
                p <- [0 .. size3 - 1]
            ]

max_stars_repo_name: McMasterU/HashedExpression

max_issues_repo_name: McMasterU/HashedExpression

max_forks_repo_name: McMasterU/HashedExpression


text:
--{-# LANGUAGE BangPatterns #-}
module NeuralNetworks where
import Util
import Data.List
import System.Random
import Numeric.LinearAlgebra
import Numeric.LinearAlgebra.Util
import Numeric.GSL.Minimization
import Control.Parallel (par,pseq)
import Debug.Trace
import System.IO
import System.Directory

readThetaList :: [Int] -> IO [Matrix Double]
readThetaList layers = do
                          let readThetaListInternal fname = do
                                                              contents <- readFile fname
                                                              let thetas = contents `seq` read contents :: [Matrix Double]
                                                              return thetas
                          let generateThetaList = do
                                                    rgen <- getStdGen
                                                    return $ randomInitializeAllWeights rgen layers
                          let fileName = show layers
                          fexist <- doesFileExist fileName
                          if fexist
                          then
                            readThetaListInternal fileName
                          else
                            generateThetaList

writeThetaList :: [Int] -> [Matrix Double] -> IO ()
writeThetaList layers thetas = do
                                let filename = show layers
                                let contents = show thetas
                                writeFile filename contents

{- RANDINITIALIZEWEIGHTS Randomly initialize the weights of a layer with L_in
   incoming connections and L_out outgoing connections
   W = RANDINITIALIZEWEIGHTS(L_in, L_out) randomly initializes the weights
   of a layer with L_in incoming connections and L_out outgoing
   connections.
   Note that W should be set to a matrix of size(L_out, 1 + L_in) as
   the first row of W handles the "bias" terms -}
randomInitializeWeights :: RandomGen g => g -> Int -> Int -> Matrix Double
randomInitializeWeights gen l_in l_out = randommatrix * 2 * epsilon_init - epsilon_init
     where
      randomlist = randoms gen :: [Double]
      epsilon_init = 0.12
      randommatrix = (l_out><(1+l_in)) randomlist

randomInitializeAllWeights :: RandomGen g => g -> [Int] -> [Matrix Double]
randomInitializeAllWeights gen (outputs:[]) = []
randomInitializeAllWeights gen (inputs:outputs:rest) = (randomInitializeWeights gen inputs outputs):(randomInitializeAllWeights gen (outputs:rest))

{- Implements the neural network cost function for a neural network which performs
   classification.
   [J, grad] = NNCOSTFUNCTON(nn_params, hidden_layer_size, num_labels, ...
   X, y, lambda) computes the cost and gradient of the neural network. The
   parameters for the neural network are "unrolled" into the vector
   nn_params and need to be converted back into the weight matrices.
   The returned parameter grad should be a "unrolled" vector of the
   partial derivatives of the neural network.

   NOTE: cost does not work on NNs with no hidden layers.  TODO fix this if
   I ever need it.

   -}
costFunction :: Vector Double -> [Int] -> Matrix Double -> Matrix Double -> Double -> (Double, Vector Double)
costFunction thetaVector layers x targetYsMatrix lambda = (j_reg, gradientVector)
    where
      m = fromIntegral $ rows targetYsMatrix
      thetaList = reshapeVector layers thetaVector
      (inputMatrices, activationMatrices, output_layer) = forwardPropagate x thetaList
      --j = trace (show $ -((1/m) * sumElements (targetYsMatrix * (log output_layer) + (1 - targetYsMatrix)  * (log (1 - output_layer))))) (-((1/m) * ( sumElements (targetYsMatrix * (log output_layer) + (1 - targetYsMatrix) * (log (1 - output_layer))))))
      --j = trace (show $ ((targetYsMatrix * (log output_layer) + (1 - targetYsMatrix) * (log (1 - output_layer))))) (-((1/m) * ( sumElements (targetYsMatrix * (log output_layer) + (1 - targetYsMatrix) * (log (1 - output_layer))))))
      j = -((1/m) * ( sumElements (targetYsMatrix * (log output_layer) + (1 - targetYsMatrix) * (log (1 - output_layer)))))
      j_reg = j + (lambda/(2*m)) * ( sum ( map (\ theta -> sumElements ((dropColumns 1 theta) ^ 2)) thetaList ))
      deltaList = backPropagate thetaList inputMatrices activationMatrices output_layer targetYsMatrix
      gradientVector = createGradientVector thetaList deltaList
        where
          -- create list of gradient matrices and then flatten them into a single vector
          createGradientVector :: [Matrix Double] -> [Matrix Double] -> Vector Double
          createGradientVector tlist dlist = flattenConcat $ iterate tlist dlist
            where
              iterate [] []         = []
              iterate (t:ts) (d:ds) = grad:(iterate ts ds)
                where
                  -- liminate j = 0 column from theta for purposes of regularization
                  tmpTheta = padLeft (dropColumns 1 t) 0
                  -- regularized gradients
                  grad =  (1/(scalar m)) * d + (scalar (lambda/m)) * tmpTheta

-- |Performs forward propagation on a neural network, returning the resulting output layer
forwardPropagate :: Matrix Double -> [Matrix Double] -> ([Matrix Double],[Matrix Double],Matrix Double)
--forwardPropagate inputMatrix _ | trace ("Forward propagate input matrix dimensions " ++ (show (rows inputMatrix)) ++ "x" ++ (show (cols inputMatrix)) ) False = undefined
forwardPropagate inputMatrix thetaList = (inputMatrices, activationMatrices, output_layer)
  where
    resultList' = doForwardProp inputMatrix thetaList
    --add x to the start of the input list, for both input and activation... testing
    resultList = (inputMatrix,inputMatrix):resultList'
    (inputMatrices, activationMatrices) = unzip resultList
    output_layer = last activationMatrices
    doForwardProp input []         = []
    doForwardProp input (t:thetas) = (initial_value,activation):(doForwardProp activation thetas)
      where
        input_with_bias = addBias input
        initial_value = input_with_bias <> (ctrans t)
        activation = sigmoid initial_value

-- |Performs backpropagation on a neural network, returning the resulting Delta matrices
backPropagate :: [Matrix Double] -> [Matrix Double] -> [Matrix Double] -> Matrix Double -> Matrix Double -> [Matrix Double]
backPropagate thetaList inputMatrices activationMatrices output_layer targetYs = output_deltas `par` doBackProp 0 deltaList
  where
    deltaList = makeZeroDeltaList thetaList
    m = rows targetYs
    -- reverse the lists we'll be iterating through, since we're going backwards from the output layer
    revInputs = reverse inputMatrices
    revActivations = reverse activationMatrices
    revThetaList = reverse thetaList
    output_deltas = (head revActivations) - targetYs
    --for each example in training set:
    doBackProp index ds | index >= m = ds
                        | otherwise  = doBackProp (index +1) updatedDs
      where
        -- reverse the lists we'll be iterating through, since we're going backwards from the output layer
        revDs = reverse ds
        --do output layer separately:
        output_delta = ctrans $ extractRows [index] output_deltas
        --do the rest of the layers:
        updatedDs = reverse $ backPropagateOneExample revThetaList output_delta (tail revInputs) (tail revActivations) revDs
        backPropagateOneExample _ _ _ _ [] = []
        backPropagateOneExample (thetaI:thetas) previous_delta (inputI:inputs) (activationI:activations) (deltaI:deltas) = current_delta `pseq` updatedDelta:(backPropagateOneExample thetas current_delta inputs activations deltas)
          where
            current_delta_with_bias = (ctrans thetaI) <> previous_delta * (sigmoidGradient (ctrans (addBias (extractRows [index] inputI))))
            current_delta = updatedDelta `par` dropRows 1 current_delta_with_bias
            -- capital Delta accumulation
            updatedDelta = deltaI + previous_delta <> addBias (extractRows [index] activationI)

-- |Makes a list of 0-filled Delta matrices from a list of theta matrices
makeZeroDeltaList :: [Matrix Double] -> [Matrix Double]
makeZeroDeltaList [] = []
makeZeroDeltaList (m:ms) = (zeros (rows m) (cols m)):(makeZeroDeltaList ms)

-- |Reshapes a vector into a list of weight matrices for a network of the given number and size of layers
reshapeVector :: [Int] -> Vector Double -> [Matrix Double]
reshapeVector layers vector = iterate layers (toList vector)
  where
    iterate _ [] = []
    iterate [] _ = []
    iterate (x:[]) _ = []
    iterate (l_in:l_out:xs) vlist = m:(iterate (l_out:xs) (drop msize vlist))
      where
        msize = l_out * (l_in + 1)
        m = reshape (l_in + 1) (fromList (take msize vlist))

-- |The prediction function
predict :: [Matrix Double] -> Matrix Double -> [Double] -> Matrix Double
predict [] input targetMapping = selectTarget
  where
    maxIndex xs = snd $ maximum $ zip xs targetMapping
    selectTarget = asColumn $ fromList $ map maxIndex $ toLists input
predict (theta:thetas) input targetMapping = predict thetas layer targetMapping
  where
    layer = sigmoid $ (addBias input) <> (ctrans theta)

{-
Minimization methods:
ConjugateFR
ConjugatePR
VectorBFGS
VectorBFGS2
SteepestDescent
-}

minimizeVDGeneric method x targetYsMatrix layers num_iters lambda precision initial_thetas = minimizeVD method precision num_iters first_step tol traceCostFunc gradientFunc (flattenConcat initial_thetas)
    where
      first_step = precision * 100
      tol = 0.1 -- see http://www.gnu.org/software/gsl/manual/html_node/Multimin-Algorithms-with-Derivatives.html
      costFunc thetaVect = fst $ costGradFunction thetaVect
      gradientFunc thetaVect = snd $ costGradFunction thetaVect
      costGradFunction t = (costFunction t layers x targetYsMatrix lambda)
      traceGradientFunc thetaVect = traceShow ((sumElements grad)) grad
        where grad = snd $ costGradFunction thetaVect
      traceCostFunc thetaVect = traceShow cost cost
        where cost = fst $ costGradFunction thetaVect
      --memoizedCostGradFunction = unsafeMemoize costGradFunction

-- Generate learning curves
learningCurvesNeuralNetwork::
  RandomGen g =>   MinimizeMethodD ->
                   Matrix Double ->
                   Matrix Double ->
                   Matrix Double ->
                   Matrix Double ->
                   [Int] ->
                   Double ->
                   Int ->
                   Double ->
                   g ->
                   Int ->
                   [(Double,Double,Int)]
learningCurvesNeuralNetwork method x y xval yval layers lambda iter precision gen step_size = learningCurves trainFunc costFunc x y xval yval step_size
  where
    initial_thetas = randomInitializeAllWeights gen layers
    trainFunc tx ty = asColumn $ fst $ minimizeVDGeneric method tx ty layers iter lambda precision initial_thetas
    costFunc tx ty tt = fst $ costFunction (flatten tt) layers tx ty  0

max_stars_repo_name: thade/haskellml

max_issues_repo_name: thade/haskellml

max_forks_repo_name: thade/haskellml


text:
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Marvin.API.Algorithms.KMeans (
  KMeans (..)

  , CentroidModel
  , distancesFromNearestCentroids
  , centroids
) where

import Control.Monad.Reader

import Data.Foldable
import Data.Array.IArray
import Data.Ord
import Control.Arrow
import Control.Monad.Except

import Marvin.API.Table.DataType
import Marvin.API.Fallible
import Marvin.API.Meta.Model
import Marvin.API.Table.DataType
import Marvin.API.Fallible
import Marvin.API.Table.Internal

import Data.Vector.Unboxed (Vector)
import qualified Data.Vector.Unboxed as UVec
import qualified Data.Vector as Vec

import qualified Numeric.LinearAlgebra as LA

-- * Parameters

-- | Parameters.
data KMeans = KMeans {
  k :: Int -- ^ Number of clusters (centroids).
  , numberOfIterations :: Int -- ^ Number of iterations.
}

-- | Default parameters.
defaultKMeans = KMeans {
  k = 5
  , numberOfIterations = 10
}

-- * Model

-- | Resulting model.
data CentroidModel = CentroidModel {
  centroids_ :: Array Label Centroid
  , dimension :: Int
} deriving Show

-- | Retrieves a list of the centroids.
centroids :: CentroidModel -> [[Double]]
centroids model = fmap LA.toList $ fmap snd $ assocs $ centroids_ model

-- | Retrieves the distances from the nearest centroids for some points
distancesFromNearestCentroids :: CentroidModel -> NumericTable -> Fallible NumericColumn
distancesFromNearestCentroids model tab = do
  if dimension model /= numberOfColumns tab
    then throwError $ RowLengthMismatch $ "While trying the calculate nearest distances " ++
      "with CentroidModel."
    else return ()
  let ps = tableToRows tab
  let distances = fmap (distanceFromNearest model) ps
  fromList $ Vec.toList $ distances

-- | Type aliases.
type Point = LA.Vector Double
type Centroid = LA.Vector Double
type Label = Int

-- | Distance from nearest centroid.
distanceFromNearest :: CentroidModel -> Point -> Double
distanceFromNearest model p = minimum $ fmap (dist p) cs
  where
    cs = fmap snd $ assocs $ centroids_ model

instance Estimator KMeans NumericTable where
  type ResultingModel KMeans NumericTable = CentroidModel
  fit = fit'

fit' :: KMeans -> NumericTable -> Fallible CentroidModel
fit' kMeans table = do
  ensurePositive
    (InvalidAlgorithmParameter "KMeans" "numberOfIterations must be positive") numIter
  ensurePositive
    (InvalidAlgorithmParameter "KMeans" "number of centroids (k) must be positive") numCentroids
  ensureNonEmptyTable "While fitting KMeans." table
  return $ CentroidModel {
    centroids_ = centroidArray
    , dimension = numberOfColumns table
  }
  where
    centroidArray = fitKMeans params numIter
    numIter = numberOfIterations kMeans
    numCentroids = k kMeans
    pts = tableToRows table
    params = KMeansParams {
      numOfCents = numCentroids
      , points = Vec.toList pts
    }

instance Predictor CentroidModel where
  type Testing CentroidModel = NumericTable
  type Prediction CentroidModel = NaturalColumn
  predict model numericTable = if numberOfColumns numericTable /= dimension model
      then throwError $ RowLengthMismatch "When predicting with a CentroidModel."
      else fromList $ Vec.toList labels
    where
      pts = tableToRows numericTable
      labels = fmap (nearestLabel (centroids_ model)) pts

tableToRows =
  Vec.map (LA.fromList . UVec.toList) . transposeVectorVectorU . Vec.map values . columnsVec

data InitStrategy = TakeFirstK
data KMeansParams = KMeansParams {
  points :: [Point]
  , numOfCents :: Int
}

dimensions :: KMeansParams -> Int
dimensions params = LA.size $ head $ points params

initCents :: Reader KMeansParams (Array Label Centroid)
initCents = do
  ps <- asks points
  k <- asks numOfCents
  return $ listArray (1,k) (take k (ps))

dist :: LA.Vector Double -> LA.Vector Double -> Double
dist xs ys = LA.norm_2 $ xs - ys

nearestLabels :: Array Label Centroid -> Reader KMeansParams [(Label, Point)]
nearestLabels cs = do
  ps <- asks points
  return $
    fmap (\p -> (nearestLabel cs p, p)) ps

nearestLabel :: Array Label Centroid -> Point -> Label
nearestLabel cs p = fst $ minimumBy (comparing (dist p . snd)) (assocs cs)

mean :: [Vector Double] -> Vector Double
mean xs = UVec.map (\x -> x / n) $ sumVecs xs
  where
    n = fromIntegral (length xs)
    sumVecs = foldr1 addVecs
    addVecs x y = UVec.zipWith (+) x y

accumArrWithLabs :: Ix i => Array i (Point, Int) -> [(i, Point)] -> Array i (Point, Int)
accumArrWithLabs = accum meanAccum

meanAccum :: (Point, Int) -> Point -> (Point, Int)
meanAccum (sum, cnt) p = (sum + p, cnt + 1)

nextCentroids :: Array Label Centroid -> Reader KMeansParams (Array Label Centroid)
nextCentroids cs = do
  ps <- asks points
  k <- asks numOfCents
  n <- asks dimensions
  let initArr = listArray (1,k) (repeat (n LA.|> [0,0..], 0))
  labeledPoints <- nearestLabels cs
  let means = accum meanAccum initArr labeledPoints
  return $ amap (\(sum, cnt) -> LA.scale (1 / fromIntegral cnt) sum) means

fitKMeans :: KMeansParams -> Int
  -> Array Label Centroid
fitKMeans params numIter = runReader readerIter params
  where
    readerIter = do
      init <- initCents
      runIterationM numIter nextCentroids init

runIterationM :: Monad m => Int -> (a -> m a) -> a -> m a
runIterationM n f init = iterate (>>= f) (return init) !! n

max_stars_repo_name: gaborhermann/marvin

max_issues_repo_name: gaborhermann/marvin

max_forks_repo_name: gaborhermann/marvin


text:
module Main where

import           Criterion
import           Criterion.Main.Options
import           Criterion.Types
import           Data.Complex
import           Data.Vector
import qualified Numeric.FFT            as FFT

tstvec :: Int -> Vector (Complex Double)
tstvec sz = generate sz (\i -> let ii = fromIntegral i
                               in sin (2*pi*ii/1024) + sin (2*pi*ii/511))

main :: IO ()
main = do
  p <- FFT.plan 256
  benchmarkWith (defaultConfig { resamples = 1000 })
    (nf (FFT.fftWith p) (tstvec 256))

max_stars_repo_name: ian-ross/arb-fft

max_issues_repo_name: ian-ross/arb-fft

max_forks_repo_name: ian-ross/arb-fft


text:
module Solver (coefficients, approxU, getLMatrix, getBMatrix, domainStart, domainEnd) where

import Data.Maybe (fromJust)
import Math.GaussianQuadratureIntegration (nIntegrate256)
import Numeric.LinearAlgebra (flatten, fromLists, linearSolve, luSolve, toList, toLists, (><))

approxU :: Int -> Double -> Double
approxU n x =
  sum . zipWith (\i c_i -> c_i * basisF i x) [0 ..] . coefficients $ n
  where
    basisF = basisFWithDomain n

coefficients :: Int -> [Double]
coefficients n = 0 : (toList . flatten $ fromJust (linearSolve b_matrix l_vector))
  where
    b_matrix = fromLists $ getBMatrix n
    l_vector = (n >< 1) $ getLMatrix n

getLMatrix :: Int -> [Double]
getLMatrix n =
  [l_ej j | j <- [1 .. n]]
  where
    -- L(v) = - int[0, 2] v*sindx
    -- L(e_j) = - int[0, 2] e_j*sindx
    -- u(0) => e_j = 0, so we skip it
    l_ej j = - integrate domainStart domainEnd (j > 0) (\x -> basisF j x * sin x)
    basisF = basisFWithDomain n

getBMatrix :: Int -> [[Double]]
getBMatrix n =
  [[b_ei_ej i j | j <- [1 .. n]] | i <- [1 .. n]]
  where
    -- B(u,v) = u(2)v(2) + int[0, 2] (-u'v' + uv) dx
    -- B(e_i, e_j) = e_i(2)*e_j(2) + int[0, 2] (- e_i'*e_j' + e_i*e_j) dx
    b_ei_ej i j = u2v2 i j + ʃsub_u'v'_add_uvdx i j
    u2v2 i j = basisF i domainEnd * basisF j domainEnd
    -- we only need to integrate splines with non-zero intersection
    ʃsub_u'v'_add_uvdx i j = integrate lowerBound upperBound (near i j) (\x -> - basisF' i x * basisF' j x + basisF i x * basisF j x)
      where
        -- finding intersection of tent functions
        lowerBound = dx * max (bigger_idx - 1) domainStart
        upperBound = dx * min (smaller_idx + 1) (fromIntegral n)
        dx = domainEnd / fromIntegral n
        smaller_idx = min (fromIntegral i) (fromIntegral j)
        bigger_idx = max (fromIntegral i) (fromIntegral j)
    near i j = abs (i - j) <= 1
    basisF = basisFWithDomain n
    basisF' = basisF'WithDomain n

integrate :: (Fractional a, Ord a) => a -> a -> Bool -> (a -> a) -> a
integrate start end nonZeroCond f
  | nonZeroCond = nIntegrate256 f start end
  | otherwise = 0

-- tent function used for generating vector space
-- https://en.wikipedia.org/wiki/Triangular_function
basisFWithDomain :: Int -> Int -> Double -> Double
basisFWithDomain n i x
  | x < left || right < x = 0
  | x <= center = (x - left) * hInverse
  | otherwise = (right - x) * hInverse
  where
    left = center - h
    right = center + h
    center = domainEnd * fromIntegral i / fromIntegral n
    h = domainEnd / fromIntegral n
    hInverse = fromIntegral n / domainEnd

-- derivative of tent function
basisF'WithDomain :: Int -> Int -> Double -> Double
basisF'WithDomain n i x
  | x < left || right < x = 0
  | x <= center = hInverse
  | otherwise = - hInverse
  where
    left = center - h
    right = center + h
    center = domainEnd * fromIntegral i / fromIntegral n
    h = domainEnd / fromIntegral n
    hInverse = fromIntegral n / domainEnd

domainEnd :: Double
domainEnd = 2

domainStart :: Double
domainStart = 0


text:
{-# LANGUAGE NoImplicitPrelude #-}
module BaseCompat (
  module X
) where

import Intro as X

import Control.Applicative as X
import Control.Arrow as X hiding (first, second)
import Control.Category as X
import Control.Concurrent as X
import Control.Exception as X
import Control.Exception.Base as X
import Control.Monad as X hiding (fail)
import Control.Monad.Fix as X
import Control.Monad.IO.Class as X
import Control.Monad.ST as X
import Control.Monad.ST.Unsafe as X
import Control.Monad.Zip as X
import Data.Bifunctor as X
import Data.Bits as X
import Data.Bool as X
import Data.Char as X
import Data.Coerce as X
import Data.Complex as X
import Data.Data as X
import Data.Dynamic as X
import Data.Either as X
import Data.Eq as X
import Data.Fixed as X
import Data.Foldable as X
import Data.Function as X hiding ((.), id)
import Data.Functor as X
import Data.Functor.Classes as X
import Data.Functor.Compose as X
import Data.Functor.Identity as X
import Data.IORef as X
import Data.Int as X
import Data.Ix as X
import Data.List as X hiding (scanl1, scanr1, map, cycle, head, init, last, tail)
import Data.Maybe as X
import Data.Monoid as X hiding (First(..), Last(..), (<>))
import Data.Ord as X
import Data.Proxy as X
import Data.Ratio as X
import Data.STRef as X
import Data.Semigroup as X
import Data.String as X
import Data.Traversable as X
import Data.Tuple as X
import Data.Type.Bool as X
import Data.Type.Coercion as X
import Data.Type.Equality as X hiding (trans, sym)
import Data.Unique as X
import Data.Version as X
import Data.Void as X
import Data.Word as X
import Numeric as X
import Numeric.Natural as X
import Prelude as X hiding ((.), id, map, putChar, putStrLn, putStr, getContents, getLine, print, getChar, appendFile, readFile, writeFile, fail, show, undefined, scanl1, scanr1, cycle, head, init, last, tail)
import System.CPUTime as X
import System.Console.GetOpt as X hiding (Option)
import System.Environment as X
import System.Exit as X
import System.IO as X hiding (putChar, putStrLn, putStr, getContents, getLine, print, getChar, appendFile, readFile, writeFile)
import System.IO.Error as X
import System.IO.Unsafe as X
import System.Info as X
import System.Mem as X
import System.Mem.StableName as X
import System.Mem.Weak as X
import System.Timeout as X
import Text.ParserCombinators.ReadP as X hiding (get, (+++), optional, (<++), look, pfail, many, choice, option)
import Text.ParserCombinators.ReadPrec as X hiding (get, (+++), lift)
import Text.Printf as X
import Text.Read as X hiding (readMaybe, get, lift, EOF, (+++))
import Text.Show as X hiding (show)
import Unsafe.Coerce as X
import Control.Monad.Fail as X hiding (fail)
import Data.Kind as X

max_stars_repo_name: minad/intro

max_issues_repo_name: minad/intro

max_forks_repo_name: minad/intro


text:
{-# LANGUAGE FlexibleInstances #-}

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

import System.Environment (getArgs)
import System.IO (readFile)
import Data.Map.Strict (Map, (!), insert, elems, fromList, toList, findWithDefault, size, empty, member, findMin, findMax, singleton, filter)
import qualified Data.Map.Strict as M
import Data.Set (Set)
import qualified Data.Set as S
--import qualified Data.Array as A
import Data.List (find, intercalate, intersperse, permutations, inits, tails, isPrefixOf)
import Data.List.Split (splitOn, chunksOf)
-- import Data.Complex (Complex((:+)), realPart, imagPart) -- define my own complex

import UI.NCurses
import Data.Char (chr, ord)
-- import Data.Complex (Complex((:+)))
import Data.Maybe (fromJust)
type Instructions = Map Integer Integer

data ComputerState = Ready | Running | Blocked | Done
  deriving (Show, Eq)

data Computer = Computer {
  state :: ComputerState,
  memory :: Map Integer Integer,
  iptr :: Integer, -- instruction pointer
  base :: Integer, -- base offset
  input :: [Integer],
  output :: [Integer]}

computer0 = Computer { state = Ready, memory = empty, iptr = 0, base = 0, input = [], output = [] }

run :: Computer -> Computer -- (Integer, Integer) -> Instructions -> [Integer] -> [Integer]
run c
  | state c == Ready = run $ c {state = Running}
  | state c == Done = c
  | state c == Blocked = if input c == [] then c else run $ c {state = Running}
  | otherwise = -- running
    --traceShow (iptr c, base c, memory c) $
    case instr `mod` 100 of
      1 -> -- add
        run $ c {iptr = i+4, memory = insert (addr 3) (arg 1 + arg 2) instructions}
      2 -> -- multiply
        run $ c {iptr = i+4, memory = insert (addr 3) (arg 1 * arg 2) instructions}
      3 -> -- read input
        if (null $ input c)
        then c {state = Blocked}
        else run $ c {iptr = i+2, memory = insert (addr 1) (head $ input c) instructions, input = tail $ input c}
      4 -> -- output
        --traceShow (arg 1) $
        run $ c {iptr = i+2, output = output c ++ [arg 1]}
      5 -> -- jump-if-true
        run $ c {iptr = if arg 1 == 0 then i+3 else arg 2}
      6 -> -- jump-if-false
        run $ c {iptr = if arg 1 == 0 then arg 2 else i+3}
      7 -> -- less than
        run $ c {iptr = i+4, memory = insert (addr 3) (if arg 1 < arg 2 then 1 else 0) instructions}
      8 -> -- equals
        run $ c {iptr = i+4, memory = insert (addr 3) (if arg 1 == arg 2 then 1 else 0) instructions}
      9 -> -- set relative base
        run $ c {iptr = i+2, base = base c + arg 1}
      99 -> -- halt
        run $ c {state = Done}
      _ -> error "unknown opcode"
  where instructions = memory c
        i = iptr c
        instr = instructions!i
        ii x = findWithDefault 0 x instructions
        arg :: Integer -> Integer
        arg n = case (instr `mod` (100*10^n)) `div` (10*10^n) of
          0 -> ii $ ii $ i+n
          1 -> ii $ i+n
          2 -> ii ((ii $ i+n) + base c)
          _ -> error "bad argument mode"
        addr n = case (instr `mod` (100*10^n)) `div` (10*10^n) of
          0 -> ii $ i+n
          1 -> error "address in mode 1"
          2 -> --trace "address in mode 2" $
            ii (i+n) + base c
          _ -> error $ "address in unknown mode"

instance (Show a) => Show (Complex a) where
  show (C x y) = "C " ++ show x ++ " " ++ show y

instance (Eq a) => Eq (Complex a) where
  (C a ai) == (C b bi) = a == b && ai == bi

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

-- Note that we are using a plane where imaginary (y-axis) numbers
-- increase downward. I think this means that right and left are
-- reversed.

data Complex a = C a a

-- instance Num (Complex Int) where
--   abs c = error "Can't take abs of Complex Int"

instance Num a => Num (Complex a) where
  (C x y) + (C u v) = C (x+u) (y+v)
  (C x y) * (C u v) = C (x*u-y*v) (x*v+y*u)
  fromInteger n = C (fromInteger n) 0
  abs (C x y) = C (abs x) y -- sqrt $ x*x + y*y
  signum (C x y) = C (signum x) 0
  negate (C x y) = C (negate x) (negate y)

type Point = Complex Int
type Direction = Complex Int
type Scaffold = Set Point
data Move = R | L | F Int | Err
  deriving (Show, Eq)

show' :: [Move] -> String
show' ms = intercalate "," $ map showMove ms
  where showMove R = "R"
        showMove L = "L"
        showMove (F n) = show n
        showMove Err = error "showing err"

charToDirection '>' = C 1 0
charToDirection '<' = C (-1) 0
charToDirection '^' = C 0 (-1)
charToDirection 'v' = C 0 1
charToDirection c = error $ "bad direction" ++ [c]

fromJust' :: String -> Maybe a -> a
fromJust' s Nothing = error s
fromJust' s (Just x) = x

path :: Scaffold -> (Point, Direction) -> [Move]
path scaffold (pt, dir)
  | S.size scaffold < 2 = []
  -- | otherwise = (traceShowId $ rotation ++ [F steps]) ++ path scaffold' (pt', dir')
  | otherwise = rotation ++ [F steps] ++ path scaffold' (pt', dir')
  where left :: Complex Int
        left = C 0 (-1)
        dir' = fromJust' "dir'" $ find (\d -> (pt + d) `S.member` scaffold) [left^i | i <- [1 .. 4]]
        directions = [(left, [L]), (left^2, [L,L]), (left^3, [R]), (left^4, [Err])]
        rotation = snd $ fromJust' ("rotation: "++ show (dir', directions))  $
          find (\(d, m) -> dir * d == dir') directions
        (pt', steps, scaffold') = walk (pt, 0, scaffold)
        walk (p, n, s) | not $ (p+dir') `S.member` s = (p, n, s)
                       | (p+dir'*left) `S.member` s = walk (p+dir', n+1, s) -- intersection, don't delete
                       | otherwise = walk (p+dir', n+1, S.delete p s)

testIntersection scaffold pt = all (`S.member` scaffold) [ pt + d | d <- [l, l*l, l*l*l, l*l*l*l]]
  where l = C 0 1

data Function = A | B | C' deriving (Show)

substitute :: [Move] -> [Function]
-- substitute (L: F n: ms) = A: (substitute $ F (n-8): ms)
-- substitute (F n: ms) = B n: substitute ms
-- substitute (R: F n: ms) = C': (substitute $ F (n-8): ms)
-- substitute [] = []
-- substitute ms = error $ "substitute: can't do " ++ show ms
substitute (L: F 12: L: F 12: R: F 12: ms) = A: substitute ms
substitute (L: F 8: L: F 8: R: F 12: L: F 8: L: F 8: ms) = B: substitute ms
substitute (L: F 10: R: F 8: R: F 12: ms) = C': substitute ms
substitute [] = []
substitute ms = error $ "substitute: can't do " ++ show ms

findIndex :: (Show a) => (a->Bool) -> [a] -> Maybe Int
findIndex p lst | null lst = Nothing
                | p $ head lst = return 0
                | otherwise = (findIndex p $ tail lst) >>= return . fromIntegral . (+ 1)
  -- where test predicate [] = Nothing
  --       test predicate (x:xs) = if predicate x then 0 else 1 + test predicate xs

findIndexes :: (Show a) => [(a->Bool)] -> [a] -> [Int]
findIndexes ps lst | null ps = []
                   | otherwise = case findIndex (head ps) lst of
                                   Nothing -> []
                                   Just x -> x: (map (+ x) $ findIndexes (tail ps) $ drop x lst)
main = do
  -- [instructionFile] <- getArgs
  instructionStrings <- readFile "19.input.txt" -- instructionFile
  let instructions = fromList . zip [0 ..] $ map read $ splitOn "," instructionStrings

  putStrLn "Part 1"
  let outputToChar 0 = ' '
      outputToChar 1 = '#'
      outputToChar _ = error "bad output"
  let outputs = [ [head $ output computer1 | i <- [0 .. 49]
                                           , let computer1 = run $ computer0{memory = instructions, input=[i,j]}
                                           ] | j <- [0 .. 49]]
  let view = unlines $ map (map outputToChar) $ outputs
  putStrLn view
  putStrLn $ show $ sum $ map sum outputs

  putStrLn "Part 2"
  putStrLn $ unlines $ map show $ zip [0 .. ] $ map (findIndex (== 1)) outputs
  putStrLn $ unlines $ map show $ zip [0 .. ] $ map (findIndexes [(== 0),(== 1),(== 0)]) outputs

  let getValueAtPoint i j = -- traceShow (i,j) $ traceShowId $
        head $ output $ run computer0{memory = instructions, input=map fromIntegral [i,j]}

  -- let lineValue y startx stopx = (stopx' - startx', startx', stopx')
  --       where startx' = startx - 1 + (fromJust $  getIndex (== 1) [getValueAtPoint x y | x <- [(startx-1) ..]])
  --             stopx' = stopx - 1 + (fromJust $ getIndex (== 0) [getValueAtPoint x y | x <- [(stopx-1) ..]])

  let search f x y
      -- x y are the top right coordinates of the box (xy increasing right and  down).
        | x < 100 = traceShow "move right" $
          search f 100 y
        | x > 10000 || y > 10000 = error "searched too far"
        | f (x-99) (y+99) == 0 = traceShow (x,y, "move diagonally") $
          search f (x+1) (y+1)
        | f (x+1) y == 1 = traceShow (x,y, "move right") $
          search f (x+1) y
        | f x y == 0 = traceShow (x,y, "move down") $
          search f x (y+1)
        | otherwise = (x,y)

  let (x,y) = search (getValueAtPoint) 0 0
  let topright@(x',y') = (x-99, y)
  print $ (topright, x'*10000 + y')

  -- let getTransition valueGetter isTransition start
  --       | isTransition $ valueGetter start = Nothing -- started too late
  --       | otherwise = findIndex isTransition [valueGetter i | i <- [start .. ]] >>= return . (+ start)

  -- let test j = do
  --       let i = traceShow ("Starting search on line", j, "column") $ traceShowId $ abs $ j-150
  --       stopx <- traceShow ("At line", j, "transitioning from 1 to 0 at column") $ traceShowId $
  --         getTransition (`getValueAtPoint` j) (== 0) i
  --       let startx_searchStart = stopx - 200
  --       startx <- traceShow ("At line", j+99, "transitioning from 0 to 1 at column ") $ traceShowId $
  --         getTransition (`getValueAtPoint` (j+100)) (== 1) startx_searchStart
  --       let getLine y = [getValueAtPoint x y | x <- [0 .. 1000]]
  --       return $ (stopx - startx, map (findIndexes [(== 1), (== 0)]) [getLine j, getLine (j+99)])

  -- interact (unlines . map (show . test . read) . lines)


text:
{-# LANGUAGE PartialTypeSignatures, ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans -funbox-strict-fields #-}
-- | Provides @'Matrix'@ and @'MMatrix'@ instances for
--  @'LA.Matrix'@ type of @hmatrix@ package.
module Algebra.Matrix.HMatrix (STMatrix) where
import           Algebra.Matrix.Generic
import           Algebra.Matrix.Generic.Mutable (MMatrix (..))
import           Algebra.Prelude.Core
import           Control.Monad                  (forM_)
import           Control.Monad.Primitive
import qualified Data.Coerce                    as DC
import qualified Data.Vector.Storable           as SV
import qualified Numeric.LinearAlgebra          as LA
import qualified Numeric.LinearAlgebra.Devel    as LA

type instance Mutable LA.Matrix = STMatrix
type instance Row LA.Matrix = LA.Vector
type instance Column LA.Matrix = LA.Vector
type instance Row STMatrix = LA.Vector
type instance Column STMatrix = LA.Vector

-- | Wrapper type for @hmatrix@'s @'LA.STMatrix'@.
data STMatrix s a = STMat { stmRows :: !Int
                          , stmCols :: !Int
                          , unwrapSTM :: LA.STMatrix s a
                          }

instance (Num a, LA.Container LA.Matrix a) => Matrix LA.Matrix (WrapNum a) where
  basicRowCount = LA.rows
  basicColumnCount = LA.cols
  unsafeFromRows rs = DC.coerce $ LA.fromRows (DC.coerce rs :: [LA.Vector a])
  unsafeFromColumns cs = DC.coerce $ LA.fromColumns (DC.coerce cs :: [LA.Vector a])
  basicUnsafeIndexM m i j =
    return $ WrapNum $ (DC.coerce m :: LA.Matrix a) `LA.atIndex` (i, j)
  unsafeFreeze = stToPrim . LA.unsafeFreezeMatrix . unwrapSTM
  unsafeThaw m = stToPrim $ STMat (LA.rows m) (LA.cols m) <$> LA.unsafeThawMatrix m
  basicUnsafeGetRowM m i = return $ DC.coerce $ getRowLA  i (DC.coerce m :: LA.Matrix a)
  basicUnsafeGetColumnM m i =
    return $ DC.coerce $ head $ LA.toColumns (DC.coerce m LA.¿ [i] :: LA.Matrix a)
  unsafeGenerate w h f =
    DC.coerce $
    LA.fromRows [ SV.generate w $ \j -> unwrapNum $ f i j
                | i <- [0..h - 1]
                ]

instance (Integral a, LA.Container LA.Matrix a) => Matrix LA.Matrix (WrapIntegral a) where
  basicRowCount = LA.rows
  basicColumnCount = LA.cols
  unsafeFromRows rs = DC.coerce $ LA.fromRows (DC.coerce rs :: [LA.Vector a])
  unsafeFromColumns cs = DC.coerce $ LA.fromColumns (DC.coerce cs :: [LA.Vector a])
  basicUnsafeIndexM m i j =
    return $ WrapIntegral $ (DC.coerce m :: LA.Matrix a) `LA.atIndex` (i, j)
  unsafeFreeze = stToPrim . LA.unsafeFreezeMatrix . unwrapSTM
  unsafeThaw m = stToPrim $ STMat (LA.rows m) (LA.cols m) <$> LA.unsafeThawMatrix m
  basicUnsafeGetRowM m i = return $ DC.coerce $ getRowLA  i (DC.coerce m :: LA.Matrix a)
  basicUnsafeGetColumnM m i =
    return $ DC.coerce $ head $ LA.toColumns (DC.coerce m LA.¿ [i] :: LA.Matrix a)
  unsafeGenerate w h f =
    DC.coerce $
    LA.fromRows [ SV.generate w $ \j -> unwrapIntegral $ f i j
                | i <- [0..h - 1]
                ]

instance (Fractional a, LA.Container LA.Matrix a) => Matrix LA.Matrix (WrapFractional a) where
  basicRowCount = LA.rows
  basicColumnCount = LA.cols
  unsafeFromRows rs = DC.coerce $ LA.fromRows (DC.coerce rs :: [LA.Vector a])
  unsafeFromColumns cs = DC.coerce $ LA.fromColumns (DC.coerce cs :: [LA.Vector a])
  basicUnsafeIndexM m i j =
    return $ WrapFractional $ (DC.coerce m :: LA.Matrix a) `LA.atIndex` (i, j)
  unsafeFreeze = stToPrim . LA.unsafeFreezeMatrix . unwrapSTM
  unsafeThaw m = stToPrim $ STMat (LA.rows m) (LA.cols m) <$> LA.unsafeThawMatrix m
  basicUnsafeGetRowM m i = return $ DC.coerce $ getRowLA  i (DC.coerce m :: LA.Matrix a)
  basicUnsafeGetColumnM m i =
    return $ DC.coerce $ head $ LA.toColumns (DC.coerce m LA.¿ [i] :: LA.Matrix a)
  unsafeGenerate w h f =
    DC.coerce $
    LA.fromRows [ SV.generate w $ \j -> unwrapFractional $ f i j
                | i <- [0..h - 1]
                ]

getRowLA :: LA.Element t => Int -> LA.Matrix t -> LA.Vector t
getRowLA i m = head $ LA.toRows $ m LA.? [i]
getColLA :: LA.Element t => Int -> LA.Matrix t -> LA.Vector t
getColLA i m = head $ LA.toColumns $ m LA.¿ [i]

unwrapSTMNum :: STMatrix s (WrapNum a) -> LA.STMatrix s a
unwrapSTMNum = DC.coerce . unwrapSTM
{-# INLINE unwrapSTMNum #-}

castSTMatrixNum :: LA.STMatrix s (WrapNum a) -> LA.STMatrix s a
castSTMatrixNum = DC.coerce
{-# INLINE castSTMatrixNum #-}

instance (Num a, LA.Container LA.Matrix a) => MMatrix STMatrix (WrapNum a) where
  basicUnsafeNew n m = stToPrim $ STMat n m <$> LA.newMatrix 0 n m
  basicInitialise _ = return ()
  basicRowCount = stmRows
  basicColumnCount = stmCols
  unsafeGetRow i m =
    stToPrim $ DC.coerce . getRowLA i <$> LA.unsafeFreezeMatrix (unwrapSTMNum m)
  unsafeGetColumn i m = stToPrim $ DC.coerce . getColLA i <$> LA.unsafeFreezeMatrix (unwrapSTMNum m)
  unsafeFill n m a = stToPrim $ STMat n m <$> LA.newMatrix a n m
  unsafeFromRow r = stToPrim $ STMat 1 (SV.length r) <$> LA.unsafeThawMatrix (LA.asRow r)
  unsafeFromRows rs = stToPrim $ do
    let m = LA.fromRows (DC.coerce rs :: [LA.Vector a])
    STMat (LA.rows m) (LA.cols m) . DC.coerce <$> LA.unsafeThawMatrix m
  unsafeFromColumn c = stToPrim $ STMat (SV.length c) 1 <$> LA.unsafeThawMatrix (LA.asColumn c)
  unsafeFromColumns rs = stToPrim $ do
    let m = LA.fromColumns (DC.coerce rs :: [LA.Vector a])
    STMat (LA.rows m) (LA.cols m) . DC.coerce <$> LA.unsafeThawMatrix m
  unsafeCopy (STMat r c m)  (STMat _ _ m') = stToPrim $ do
    m0 <- LA.unsafeFreezeMatrix m'
    LA.setMatrix (DC.coerce m :: LA.STMatrix w a) r c (DC.coerce m0 :: LA.Matrix a)
  unsafeRead (STMat _ _ m) i j = stToPrim $ LA.readMatrix m i j
  unsafeWrite (STMat _ _ m) i j x = stToPrim $ LA.writeMatrix m i j x
  basicSet (STMat r c m) x = stToPrim $ LA.modifyMatrix m r c $ const x
  basicUnsafeSwapRows (STMat _ _ m) i j =
    stToPrim $ LA.rowOper (LA.SWAP i j LA.AllCols) $ castSTMatrixNum m
  unsafeScaleRow (STMat _ _ m) i c =
    stToPrim $ LA.rowOper (LA.SCAL (unwrapNum c) (LA.Row i) LA.AllCols) $ castSTMatrixNum m
  basicUnsafeIMapRowM (STMat _ c m) i f = forM_ [0..c-1] $ \j ->
    stToPrim . LA.writeMatrix m i j =<< f j =<< stToPrim (LA.readMatrix m i j)
  toRows (STMat _ _ m) =
    stToPrim $ DC.coerce . LA.toRows <$> LA.unsafeFreezeMatrix (castSTMatrixNum m)
  toColumns (STMat _ _ m) =
    stToPrim $ DC.coerce . LA.toColumns <$> LA.unsafeFreezeMatrix (castSTMatrixNum m)

unwrapSTMFractional :: STMatrix s (WrapFractional a) -> LA.STMatrix s a
unwrapSTMFractional = DC.coerce . unwrapSTM
{-# INLINE unwrapSTMFractional #-}

castSTMatrixFractional :: LA.STMatrix s (WrapFractional a) -> LA.STMatrix s a
castSTMatrixFractional = DC.coerce
{-# INLINE castSTMatrixFractional #-}

instance (Fractional a, LA.Container LA.Matrix a) => MMatrix STMatrix (WrapFractional a) where
  basicUnsafeNew n m = stToPrim $ STMat n m <$> LA.newMatrix 0 n m
  basicInitialise _ = return ()
  basicRowCount = stmRows
  basicColumnCount = stmCols
  unsafeGetRow i m =
    stToPrim $ DC.coerce . getRowLA i <$> LA.unsafeFreezeMatrix (unwrapSTMFractional m)
  unsafeGetColumn i m = stToPrim $ DC.coerce . getColLA i <$> LA.unsafeFreezeMatrix (unwrapSTMFractional m)
  unsafeFill n m a = stToPrim $ STMat n m <$> LA.newMatrix a n m
  unsafeFromRow r = stToPrim $ STMat 1 (SV.length r) <$> LA.unsafeThawMatrix (LA.asRow r)
  unsafeFromRows rs = stToPrim $ do
    let m = LA.fromRows (DC.coerce rs :: [LA.Vector a])
    STMat (LA.rows m) (LA.cols m) . DC.coerce <$> LA.unsafeThawMatrix m
  unsafeFromColumn c = stToPrim $ STMat (SV.length c) 1 <$> LA.unsafeThawMatrix (LA.asColumn c)
  unsafeFromColumns rs = stToPrim $ do
    let m = LA.fromColumns (DC.coerce rs :: [LA.Vector a])
    STMat (LA.rows m) (LA.cols m) . DC.coerce <$> LA.unsafeThawMatrix m
  unsafeCopy (STMat r c m)  (STMat _ _ m') = stToPrim $ do
    m0 <- LA.unsafeFreezeMatrix m'
    LA.setMatrix (DC.coerce m :: LA.STMatrix w a) r c (DC.coerce m0 :: LA.Matrix a)
  unsafeRead (STMat _ _ m) i j = stToPrim $ LA.readMatrix m i j
  unsafeWrite (STMat _ _ m) i j x = stToPrim $ LA.writeMatrix m i j x
  basicSet (STMat r c m) x = stToPrim $ LA.modifyMatrix m r c $ const x
  basicUnsafeSwapRows (STMat _ _ m) i j =
    stToPrim $ LA.rowOper (LA.SWAP i j LA.AllCols) $ castSTMatrixFractional m
  unsafeScaleRow (STMat _ _ m) i c =
    stToPrim $ LA.rowOper (LA.SCAL (unwrapFractional c) (LA.Row i) LA.AllCols) $ castSTMatrixFractional m
  basicUnsafeIMapRowM (STMat _ c m) i f = forM_ [0..c-1] $ \j ->
    stToPrim . LA.writeMatrix m i j =<< f j =<< stToPrim (LA.readMatrix m i j)
  toRows (STMat _ _ m) =
    stToPrim $ DC.coerce . LA.toRows <$> LA.unsafeFreezeMatrix (castSTMatrixFractional m)
  toColumns (STMat _ _ m) =
    stToPrim $ DC.coerce . LA.toColumns <$> LA.unsafeFreezeMatrix (castSTMatrixFractional m)

unwrapSTMIntegral :: STMatrix s (WrapIntegral a) -> LA.STMatrix s a
unwrapSTMIntegral = DC.coerce . unwrapSTM
{-# INLINE unwrapSTMIntegral #-}

castSTMatrixIntegral :: LA.STMatrix s (WrapIntegral a) -> LA.STMatrix s a
castSTMatrixIntegral = DC.coerce
{-# INLINE castSTMatrixIntegral #-}

instance (Integral a, LA.Container LA.Matrix a) => MMatrix STMatrix (WrapIntegral a) where
  basicUnsafeNew n m = stToPrim $ STMat n m <$> LA.newMatrix 0 n m
  basicInitialise _ = return ()
  basicRowCount = stmRows
  basicColumnCount = stmCols
  unsafeGetRow i m =
    stToPrim $ DC.coerce . getRowLA i <$> LA.unsafeFreezeMatrix (unwrapSTMIntegral m)
  unsafeGetColumn i m = stToPrim $ DC.coerce . getColLA i <$> LA.unsafeFreezeMatrix (unwrapSTMIntegral m)
  unsafeFill n m a = stToPrim $ STMat n m <$> LA.newMatrix a n m
  unsafeFromRow r = stToPrim $ STMat 1 (SV.length r) <$> LA.unsafeThawMatrix (LA.asRow r)
  unsafeFromRows rs = stToPrim $ do
    let m = LA.fromRows (DC.coerce rs :: [LA.Vector a])
    STMat (LA.rows m) (LA.cols m) . DC.coerce <$> LA.unsafeThawMatrix m
  unsafeFromColumn c = stToPrim $ STMat (SV.length c) 1 <$> LA.unsafeThawMatrix (LA.asColumn c)
  unsafeFromColumns rs = stToPrim $ do
    let m = LA.fromColumns (DC.coerce rs :: [LA.Vector a])
    STMat (LA.rows m) (LA.cols m) . DC.coerce <$> LA.unsafeThawMatrix m
  unsafeCopy (STMat r c m)  (STMat _ _ m') = stToPrim $ do
    m0 <- LA.unsafeFreezeMatrix m'
    LA.setMatrix (DC.coerce m :: LA.STMatrix w a) r c (DC.coerce m0 :: LA.Matrix a)
  unsafeRead (STMat _ _ m) i j = stToPrim $ LA.readMatrix m i j
  unsafeWrite (STMat _ _ m) i j x = stToPrim $ LA.writeMatrix m i j x
  basicSet (STMat r c m) x = stToPrim $ LA.modifyMatrix m r c $ const x
  basicUnsafeSwapRows (STMat _ _ m) i j =
    stToPrim $ LA.rowOper (LA.SWAP i j LA.AllCols) $ castSTMatrixIntegral m
  unsafeScaleRow (STMat _ _ m) i c =
    stToPrim $ LA.rowOper (LA.SCAL (unwrapIntegral c) (LA.Row i) LA.AllCols) $ castSTMatrixIntegral m
  basicUnsafeIMapRowM (STMat _ c m) i f = forM_ [0..c-1] $ \j ->
    stToPrim . LA.writeMatrix m i j =<< f j =<< stToPrim (LA.readMatrix m i j)
  toRows (STMat _ _ m) =
    stToPrim $ DC.coerce . LA.toRows <$> LA.unsafeFreezeMatrix (castSTMatrixIntegral m)
  toColumns (STMat _ _ m) =
    stToPrim $ DC.coerce . LA.toColumns <$> LA.unsafeFreezeMatrix (castSTMatrixIntegral m)

instance {-# OVERLAPPING #-} (LA.Container LA.Matrix a, Show a) => Show (LA.Matrix (WrapNum a)) where
  showsPrec d = showsPrec d . (DC.coerce :: LA.Matrix (WrapNum a) -> LA.Matrix a)

instance {-# OVERLAPPING #-} (LA.Container LA.Matrix a, Show a) => Show (LA.Matrix (WrapIntegral a)) where
  showsPrec d = showsPrec d . (DC.coerce :: LA.Matrix (WrapIntegral a) -> LA.Matrix a)

instance {-# OVERLAPPING #-} (LA.Container LA.Matrix a, Show a) => Show (LA.Matrix (WrapFractional a)) where
  showsPrec d = showsPrec d . (DC.coerce :: LA.Matrix (WrapFractional a) -> LA.Matrix a)

max_stars_repo_name: hangingman/computational-algebra

max_issues_repo_name: hangingman/computational-algebra

max_forks_repo_name: hangingman/computational-algebra


text:
-- |
-- Module      : Data.Express.Express
-- Copyright   : (c) 2019-2021 Rudy Matela
-- License     : 3-Clause BSD  (see the file LICENSE)
-- Maintainer  : Rudy Matela <rudy@matela.com.br>
--
-- Defines the 'Express' type class.
{-# LANGUAGE CPP #-}
module Data.Express.Express
  ( Express (..)
  , (-:)
  , (->:)
  , (->>:)
  , (->>>:)
  , (->>>>:)
  , (->>>>>:)
  , (->>>>>>:)
  , (->>>>>>>:)
  , (->>>>>>>>:)
  , (->>>>>>>>>:)
  , (->>>>>>>>>>:)
  , (->>>>>>>>>>>:)
  , (->>>>>>>>>>>>:)
  )
where

import Data.Express.Core
import Data.Typeable

-- for instances
import Data.Int
import Data.Word
import Data.Ratio
import Data.Char
import Data.Complex

-- |
-- 'Express' typeclass instances provide an 'expr' function
-- that allows values to be deeply encoded as applications of 'Expr's.
--
-- > expr False  =  val False
-- > expr (Just True)  =  value "Just" (Just :: Bool -> Maybe Bool) :$ val True
--
-- The function 'expr' can be contrasted with the function 'val':
--
-- * 'val' always encodes values as atomic 'Value' 'Expr's --
--   shallow encoding.
-- * 'expr' ideally encodes expressions as applications (':$')
--   between 'Value' 'Expr's --
--   deep encoding.
--
-- Depending on the situation, one or the other may be desirable.
--
-- Instances can be automatically derived using the TH function
-- 'Data.Express.Express.Derive.deriveExpress'.
--
-- The following example shows a datatype and its instance:
--
-- > data Stack a = Stack a (Stack a) | Empty
--
-- > instance Express a => Express (Stack a) where
-- >   expr s@(Stack x y) = value "Stack" (Stack ->>: s) :$ expr x :$ expr y
-- >   expr s@Empty       = value "Empty" (Empty   -: s)
--
-- To declare 'expr' it may be useful to use auxiliary type binding operators:
-- '-:', '->:', '->>:', '->>>:', '->>>>:', '->>>>>:', ...
--
-- For types with atomic values, just declare @ expr = val @
class (Show a, Typeable a) => Express a where
  expr :: a -> Expr

instance Express ()        where  expr  =  val
instance Express Bool      where  expr  =  val
instance Express Int       where  expr  =  val
instance Express Integer   where  expr  =  val
instance Express Char      where  expr  =  val
instance Express Ordering  where  expr  =  val

instance Express a => Express (Maybe a) where
  expr mx@Nothing   =  value "Nothing" (Nothing -: mx)
  expr mx@(Just x)  =  value "Just"    (Just   ->: mx) :$ expr x

instance (Express a, Express b) => Express (Either a b) where
  expr lx@(Left x)   =  value "Left"  (Left  ->: lx) :$ expr x
  expr ry@(Right y)  =  value "Right" (Right ->: ry) :$ expr y

instance (Express a, Express b) => Express (a,b) where
  expr (x,y)  =  value "," ((,) ->>: (x,y))
              :$ expr x :$ expr y

instance (Express a, Express b, Express c) => Express (a,b,c) where
  expr (x,y,z)  =  value ",," ((,,) ->>>: (x,y,z))
                :$ expr x :$ expr y :$ expr z

instance (Express a, Express b, Express c, Express d) => Express (a,b,c,d) where
  expr (x,y,z,w)  =  value ",,," ((,,,) ->>>>: (x,y,z,w))
                  :$ expr x :$ expr y :$ expr z :$ expr w

instance Express a => Express [a] where
  expr xs  =  case xs of
              [] -> val xs
              (y:ys) -> value ":" ((:) ->>: xs) :$ expr y :$ expr ys

-- instances of further types and arities --

instance (Integral a, Express a) => Express (Ratio a) where
  expr q  =  value "%" ((%) ->>: q) :$ expr (numerator q) :$ expr (denominator q)
-- the "Integral a" restriction above is required for compilation on GHC <= 7.10

instance (RealFloat a, Express a) => Express (Complex a) where
  expr (x :+ y)  =  value ":+" ((:+) ->>: (x :+ y)) :$ expr x :$ expr y

instance (Express a, Express b, Express c, Express d, Express e)
      => Express (a,b,c,d,e) where
  expr (x,y,z,w,v)  =  value ",,,," ((,,,,) ->>>>>: (x,y,z,w,v))
                    :$ expr x :$ expr y :$ expr z :$ expr w :$ expr v

instance (Express a, Express b, Express c, Express d, Express e, Express f)
      => Express (a,b,c,d,e,f) where
  expr (x,y,z,w,v,u)  =  value ",,,,," ((,,,,,) ->>>>>>: (x,y,z,w,v,u))
                    :$ expr x :$ expr y :$ expr z :$ expr w :$ expr v :$ expr u

instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g )
      => Express (a,b,c,d,e,f,g) where
  expr (x,y,z,w,v,u,t)  =  value ",,,,,," ((,,,,,,) ->>>>>>>: (x,y,z,w,v,u,t))
                        :$ expr x :$ expr y :$ expr z :$ expr w
                        :$ expr v :$ expr u :$ expr t

#if __GLASGOW_HASKELL__ < 710
-- No 8-tuples for you:
-- On GHC 7.8, 8-tuples are not Typeable instances.
-- We could add a standalone deriving clause,
-- but that may cause trouble
-- if some other library does the same (orphan instance).
-- User should declare Express 8-tuples manually
-- when using GHC <= 7.8.
#else
instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g, Express h )
      => Express (a,b,c,d,e,f,g,h) where
  expr (x,y,z,w,v,u,t,s)  =
    value ",,,,,,," ((,,,,,,,) ->>>>>>>>: (x,y,z,w,v,u,t,s))
      :$ expr x :$ expr y :$ expr z :$ expr w
      :$ expr v :$ expr u :$ expr t :$ expr s

instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g, Express h, Express i )
      => Express (a,b,c,d,e,f,g,h,i) where
  expr (x,y,z,w,v,u,t,s,r)  =
    value ",,,,,,,," ((,,,,,,,,) ->>>>>>>>>: (x,y,z,w,v,u,t,s,r))
      :$ expr x :$ expr y :$ expr z :$ expr w
      :$ expr v :$ expr u :$ expr t :$ expr s
      :$ expr r

instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g, Express h, Express i, Express j )
      => Express (a,b,c,d,e,f,g,h,i,j) where
  expr (x,y,z,w,v,u,t,s,r,q)  =
    value ",,,,,,,,," ((,,,,,,,,,) ->>>>>>>>>>: (x,y,z,w,v,u,t,s,r,q))
      :$ expr x :$ expr y :$ expr z :$ expr w
      :$ expr v :$ expr u :$ expr t :$ expr s
      :$ expr r :$ expr q

instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g, Express h, Express i, Express j, Express k )
      => Express (a,b,c,d,e,f,g,h,i,j,k) where
  expr (x,y,z,w,v,u,t,s,r,q,p)  =
    value ",,,,,,,,,," ((,,,,,,,,,,) ->>>>>>>>>>>: (x,y,z,w,v,u,t,s,r,q,p))
      :$ expr x :$ expr y :$ expr z :$ expr w
      :$ expr v :$ expr u :$ expr t :$ expr s
      :$ expr r :$ expr q :$ expr p

instance ( Express a, Express b, Express c, Express d, Express e, Express f
         , Express g, Express h, Express i, Express j, Express k, Express l )
      => Express (a,b,c,d,e,f,g,h,i,j,k,l) where
  expr (x,y,z,w,v,u,t,s,r,q,p,o)  =
    value ",,,,,,,,,,," ((,,,,,,,,,,,) ->>>>>>>>>>>>: (x,y,z,w,v,u,t,s,r,q,p,o))
      :$ expr x :$ expr y :$ expr z :$ expr w
      :$ expr v :$ expr u :$ expr t :$ expr s
      :$ expr r :$ expr q :$ expr p :$ expr o
#endif

instance Express Double   where  expr  =  val
instance Express Float    where  expr  =  val
instance Express Int8     where  expr  =  val
instance Express Int16    where  expr  =  val
instance Express Int32    where  expr  =  val
instance Express Int64    where  expr  =  val
instance Express Word     where  expr  =  val
instance Express Word8    where  expr  =  val
instance Express Word16   where  expr  =  val
instance Express Word32   where  expr  =  val
instance Express Word64   where  expr  =  val
#if __GLASGOW_HASKELL__ < 710
-- No GeneralCategory for you:
-- On GHC 7.8, GeneralCategory is not a Typeable instance.
-- We could add a standalone deriving clause,
-- but that may cause trouble
-- if some other library does the same (orphan instance).
-- Users should declare their own Express GeneralCategory instance
-- when using GHC <= 7.8.
#else
instance Express GeneralCategory  where  expr  =  val
#endif

-- type binding utilities --

-- | Type restricted version of 'const'
-- that forces its first argument
-- to have the same type as the second.
--
-- >  value -: (undefined :: Ty)  =  value :: Ty
(-:) :: a -> a -> a
(-:) = asTypeOf -- const
infixl 1 -:

-- | Type restricted version of 'const'
-- that forces the result of its first argument
-- to have the same type as the second.
--
-- >  f ->: (undefined :: Ty)  =  f :: a -> Ty
(->:) :: (a -> b) -> b -> (a -> b)
(->:) = const
infixl 1 ->:

-- | Type restricted version of 'const'
-- that forces the result of the result of its first argument
-- to have the same type as the second.
--
-- > f ->>: (undefined :: Ty)  =  f :: a -> b -> Ty
(->>:) :: (a -> b -> c) -> c -> (a -> b -> c)
(->>:) = const
infixl 1 ->>:

-- | Type restricted version of 'const'
-- that forces the result of the result of the result of its first argument
-- to have the same type as the second.
(->>>:) :: (a -> b -> c -> d) -> d -> (a -> b -> c -> d)
(->>>:) = const
infixl 1 ->>>:

-- | Forces the result type of a 4-argument function.
(->>>>:) :: (a -> b -> c -> d -> e) -> e -> (a -> b -> c -> d -> e)
(->>>>:) = const
infixl 1 ->>>>:

-- | Forces the result type of a 5-argument function.
(->>>>>:) :: (a -> b -> c -> d -> e -> f) -> f -> (a -> b -> c -> d -> e -> f)
(->>>>>:) = const
infixl 1 ->>>>>:

-- | Forces the result type of a 6-argument function.
(->>>>>>:) :: (a->b->c->d->e->f->g) -> g -> (a->b->c->d->e->f->g)
(->>>>>>:) = const
infixl 1 ->>>>>>:

-- | Forces the result type of a 7-argument function.
(->>>>>>>:) :: (a->b->c->d->e->f->g->h) -> h -> (a->b->c->d->e->f->g->h)
(->>>>>>>:) = const
infixl 1 ->>>>>>>:

-- | Forces the result type of a 8-argument function.
(->>>>>>>>:) :: (a->b->c->d->e->f->g->h->i) -> i -> (a->b->c->d->e->f->g->h->i)
(->>>>>>>>:) = const
infixl 1 ->>>>>>>>:

-- | Forces the result type of a 9-argument function.
(->>>>>>>>>:) :: (a->b->c->d->e->f->g->h->i->j) -> j
              -> (a->b->c->d->e->f->g->h->i->j)
(->>>>>>>>>:) = const
infixl 1 ->>>>>>>>>:

-- | Forces the result type of a 10-argument function.
(->>>>>>>>>>:) :: (a->b->c->d->e->f->g->h->i->j->k) -> k
               -> (a->b->c->d->e->f->g->h->i->j->k)
(->>>>>>>>>>:) = const
infixl 1 ->>>>>>>>>>:

-- | Forces the result type of a 11-argument function.
(->>>>>>>>>>>:) :: (a->b->c->d->e->f->g->h->i->j->k->l) -> l
                -> (a->b->c->d->e->f->g->h->i->j->k->l)
(->>>>>>>>>>>:) = const
infixl 1 ->>>>>>>>>>>:

-- | Forces the result type of a 12-argument function.
(->>>>>>>>>>>>:) :: (a->b->c->d->e->f->g->h->i->j->k->l->m) -> m
                 -> (a->b->c->d->e->f->g->h->i->j->k->l->m)
(->>>>>>>>>>>>:) = const
infixl 1 ->>>>>>>>>>>>:

max_stars_repo_name: rudymatela/express

max_issues_repo_name: rudymatela/express

max_forks_repo_name: rudymatela/express