packages feed

HLearn-algebra 0.1.2.1 → 1.0.0

raw patch · 16 files changed

+691/−516 lines, 16 filesdep +hashabledep +randomdep +vectordep −semigroups

Dependencies added: hashable, random, vector, vector-heterogenous

Dependencies removed: semigroups

Files

HLearn-algebra.cabal view
@@ -1,9 +1,9 @@ Name:                HLearn-algebra-Version:             0.1.2.1+Version:             1.0.0 Synopsis:            Algebraic foundation for homomorphic learning Description:         This module contains the algebraic basis for the HLearn library.  It is separated out in it's own library because it contains routines that may be useful to others.  In particular, it contains methods for automatically converting algorithms into online/parallel versions, and its structure is slightly more modular (although much less complete) than other algebra packages. Category:            Data Mining, Machine Learning-License:             GPL+License:             BSD3 --License-file:        LICENSE Author:              Mike izbicki Maintainer:          mike@izbicki.me@@ -16,20 +16,28 @@     Build-Depends:               base                >= 3 && < 5,         ConstraintKinds     >= 0.0.1,+        vector-heterogenous >= 0.1.0,         -        semigroups          >= 0.8,+        random              >= 1.0.1,         parallel            >= 3.2,         deepseq             >= 1.3,-        containers          >= 0.5+        containers          >= 0.5,+        vector              >= 0.10,+        hashable            >= 1.2+             hs-source-dirs:     src     ghc-options:        -rtsopts -auto-all -caf-all -O2      Exposed-modules:         HLearn.Algebra         HLearn.Algebra.Functions-        HLearn.Algebra.Models+        HLearn.Algebra.HVector+        HLearn.Algebra.Models.HomTrainer         HLearn.Algebra.Models.Lame-        HLearn.Algebra.Morphism+        --HLearn.Algebra.Morphism         HLearn.Algebra.Structures.Groups+        HLearn.Algebra.Structures.MetricSpace         HLearn.Algebra.Structures.Modules-        HLearn.Algebra.Structures.Free.RegSG2Group         HLearn.Algebra.Structures.Triangles+        HLearn.Algebra.Structures.Free.Bagging+        HLearn.Algebra.Structures.Free.FreeHomTrainer+        HLearn.Algebra.Structures.Free.FreeModule
src/HLearn/Algebra.hs view
@@ -2,21 +2,29 @@  module HLearn.Algebra     ( module HLearn.Algebra.Functions-    , module HLearn.Algebra.Models+    , module HLearn.Algebra.HVector+    , module HLearn.Algebra.Models.HomTrainer     , module HLearn.Algebra.Models.Lame-    , module HLearn.Algebra.Morphism+--     , module HLearn.Algebra.Morphism     , module HLearn.Algebra.Structures.Groups+    , module HLearn.Algebra.Structures.MetricSpace     , module HLearn.Algebra.Structures.Modules-    , module HLearn.Algebra.Structures.Free.RegSG2Group     , module HLearn.Algebra.Structures.Triangles+    , module HLearn.Algebra.Structures.Free.Bagging+    , module HLearn.Algebra.Structures.Free.FreeHomTrainer+    , module HLearn.Algebra.Structures.Free.FreeModule     )     where            import HLearn.Algebra.Functions-import HLearn.Algebra.Models+import HLearn.Algebra.HVector+import HLearn.Algebra.Models.HomTrainer import HLearn.Algebra.Models.Lame-import HLearn.Algebra.Morphism+-- import HLearn.Algebra.Morphism import HLearn.Algebra.Structures.Groups+import HLearn.Algebra.Structures.MetricSpace import HLearn.Algebra.Structures.Modules-import HLearn.Algebra.Structures.Free.RegSG2Group import HLearn.Algebra.Structures.Triangles+import HLearn.Algebra.Structures.Free.Bagging+import HLearn.Algebra.Structures.Free.FreeHomTrainer+import HLearn.Algebra.Structures.Free.FreeModule
src/HLearn/Algebra/Functions.hs view
@@ -1,21 +1,26 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} --- | This module contains \"low-level higher order functions\" for manipulating algebraic homomorphisms.  You probably want to use the 'HomTrainer' type-class rather than using these functions directly.+-- | This module contains \"low-level higher order functions\" for manipulating algebraic homomorphisms.  You probably want to use the "HomTrainer" type-class rather than using these functions directly.  module HLearn.Algebra.Functions     ( -    -- * Parallelism-    parallel-    -- * Manipulating homomorphisms+    -- * Almost dependently typed function+    Function (..)+    +    -- * Higher order functions+    -- ** Parallelism+    , parallel+    -- ** Manipulating homomorphisms     , online, offline-    , batch, unbatch+    , batch, batchCK, unbatch     , semigroup-    -- * Helper functions+    -- ** Helper functions     , reduce     )     where@@ -25,7 +30,7 @@ import Control.Concurrent import Control.Parallel.Strategies -- import Data.Traversable--- import qualified Data.Foldable as F+import qualified Data.Foldable as F import GHC.Exts (Constraint) import Prelude hiding (filter) import System.IO.Unsafe@@ -33,11 +38,18 @@ import HLearn.Algebra.Structures.Groups  -------------------------------------------------------------------------------+-- type classes++-- | Every data type that implements this class has a corresponding function.  We can use this data type as type level parameters to other data types.  This gives us some of the benefit of dependently typed functions.+class Function f domain range | f domain -> range where+    function :: f -> domain -> range++------------------------------------------------------------------------------- -- higher order functions  -- | Parallelizes any batch trainer to run over multiple processors on a single machine.  The function automatically detects the number of available processors and parallelizes the function accordingly.  This requires the use of unsafePerformIO, however, the result should still be safe. parallel :: -    ( Semigroup model+    ( Monoid model     , NFData model     , CK.Partitionable container     , CK.PartitionableConstraint container datapoint@@ -52,7 +64,7 @@  -- | Converts a batch trainer into an online trainer.  The input function should be a semigroup homomorphism. online :: -    ( Semigroup model+    ( Monoid model     ) => (datapoint -> model) -- ^ singleton trainer       -> (model -> datapoint -> model) -- ^ online trainer online train = \model datapoint -> model <> (train datapoint)@@ -67,6 +79,14 @@ -- | Converts a singleton trainer into a batch trainer, which is also a semigroup homomorphism. batch ::     ( Monoid model+    , Functor container+    , F.Foldable container+    ) => (datapoint -> model) -- ^ singleton trainer+      -> (container datapoint -> model) -- ^ batch trainer+batch train = \dps -> F.foldl mappend mempty $ fmap train dps++batchCK ::+    ( Monoid model     , CK.Functor container     , CK.FunctorConstraint container model     , CK.FunctorConstraint container datapoint@@ -74,7 +94,7 @@     , CK.FoldableConstraint container model     ) => (datapoint -> model) -- ^ singleton trainer       -> (container datapoint -> model) -- ^ batch trainer-batch train = \dps -> CK.foldl' mappend mempty $ CK.fmap train dps+batchCK train = \dps -> CK.foldl' mappend mempty $ CK.fmap train dps  -- | Inverse of 'unbatch'.  Converts a semigroup homomorphism into a singleton trainer. unbatch :: @@ -94,19 +114,25 @@  -- | Like fold, but (i) only for use on the semigroup operation (\<\>) and (ii) uses the fan-in reduction strategy which is more efficient when the semigroup operation takes nonconstant time depending on the size of the data structures being reduced. reduce :: -    ( Semigroup sg+    ( Monoid sg+    , F.Foldable container+    ) => container sg -> sg+reduce = reduceL . F.toList++reduceCK :: +    ( Monoid sg     , CK.Foldable container     , CK.FoldableConstraint container sg     , CK.FoldableConstraint container [sg]     ) => container sg -> sg-reduce = reduceL . CK.toList+reduceCK = reduceL . CK.toList -reduceL :: (Semigroup sg) => [sg] -> sg+reduceL :: (Monoid sg) => [sg] -> sg reduceL []  = error "reduce: cannot reduce empty list" reduceL [x] = x reduceL xs  = reduceL $ itr xs     where-        itr :: (Semigroup sg) => [sg] -> [sg]+        itr :: (Monoid sg) => [sg] -> [sg]         itr []            = []         itr [x]           = [x]         itr (x1:x2:xs)    = (x1<>x2):(itr xs)
+ src/HLearn/Algebra/HVector.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverlappingInstances #-}++-- | Algebraic instances for the HVector type.  These form the data points used for much of the library.+module HLearn.Algebra.HVector+    ( module Data.Vector.Heterogenous+    , L2+    )+    where++import Data.Vector.Heterogenous++import HLearn.Algebra.Models.HomTrainer+import HLearn.Algebra.Structures.Groups+import HLearn.Algebra.Structures.MetricSpace+import HLearn.Algebra.Structures.Modules+import HLearn.Algebra.Structures.Triangles++-------------------------------------------------------------------------------+-- Algebra++instance Abelian (HList '[])+instance (Abelian x, Abelian (HList xs)) => Abelian (HList (x ': xs))+instance (Abelian (HList xs), ValidHVector box xs) => Abelian (HVector box xs)++---------------------------------------++instance Group (HList '[]) where+    inverse HNil = HNil++instance (Group x, Group (HList xs)) => Group (HList (x ': xs)) where+    inverse (x:::xs) = inverse x:::inverse xs++instance (Group (HList xs), ValidHVector box xs) => Group (HVector box xs) where+    inverse hv = vec (undefined::a->box) $ inverse $ toHList hv++---------------------------------------++instance (HasRing x) => HasRing (HList (x ': xs)) where+    type Ring (HList (x ': xs)) = Ring x+    +instance (Module x, Module (HList xs), Ring (HList xs) ~ Ring x) => Module (HList (x ': xs)) where+    r .* (x:::xs) = (r.*x):::(r.*xs)+    +instance (HasRing x) => HasRing (HList (x ': '[])) where+    type Ring (HList (x ': '[])) = Ring x+    +instance (Module x) => Module (HList (x ': '[])) where+    r .* (x:::HNil) = (r.*x):::HNil++---------------------------------------++newtype L2 xs = L2 xs++instance (Num r) => Abelian (L2 [r])+instance (Num r) => Monoid (L2 [r]) where+    mempty = L2 $ repeat 0+    mappend (L2 xs) (L2 ys) = L2 $ zipWith (+) xs ys+    +instance (Num r) => Group (L2 [r]) where+    inverse (L2 xs) = L2 $ map (*(-1)) xs+   +instance (Num r) => HasRing (L2 [r]) where+    type Ring (L2 [r]) = r++instance (Num r) => Module (L2 [r]) where+--     type Ring (L2 [r]) = r+    r .* (L2 xs) = L2 $ map (r*) xs++instance (Floating r) => MetricSpace (L2 [r]) where+    distance (L2 xs) (L2 ys) = sqrt . sum . map (^2) $ zipWith (-) xs ys++-- instance (Num a) => HasRing a where+--     type Ring a = a+-- +-- instance Monoid Double where+--     mempty = 0+--     mappend = (+)+--     +-- instance Group Double where+--     inverse = negate+-- +-- instance Abelian Double+-- +-- instance Module Double where+--     (.*) = (*)++-- instance (LeftOperator r x, LeftOperator r (HList xs)) => LeftOperator r (HList (x ': xs)) where+--     r .* (x:::xs) = (r.*x):::(r.*xs)+-- +-- instance (LeftOperator r (HList xs), ValidHVector box xs) => LeftOperator r (HVector box xs) where+--     r .* hv = vec (undefined::a->box) $ r .* toHList hv+-- +-- instance (Num r) => LeftModule r (HList '[])+-- instance (LeftModule r x, LeftModule r (HList xs)) => LeftModule r (HList (x ': xs))+-- instance (LeftModule r (HList xs), ValidHVector box xs) => LeftModule r (HVector box xs)+-- +-- instance RightOperator r (HList '[]) where+--     HNil *. r = HNil+--     +-- instance (RightOperator r x, RightOperator r (HList xs)) => RightOperator r (HList (x ': xs)) where+--     (x:::xs) *. r = (x*.r):::(xs*.r)+-- +-- instance (RightOperator r (HList xs), ValidHVector box xs) => RightOperator r (HVector box xs) where+--     hv*.r = vec (undefined::a->box) $ toHList hv *. r+-- +-- instance (Num r) => RightModule r (HList '[])+-- instance (RightModule r x, RightModule r (HList xs)) => RightModule r (HList (x ': xs))+-- instance (RightModule r (HList xs), ValidHVector box xs) => RightModule r (HVector box xs)++-------------------------------------------------------------------------------+-- Training++instance HomTrainer (HList '[]) where+    type Datapoint (HList '[]) = (HList '[])+    train1dp HNil = HNil++instance +    ( HomTrainer model+    , HomTrainer (HList modelL)+    , Datapoint (HList modelL) ~ HList datapointL+    ) => HomTrainer (HList (model ': modelL))+    where+        type Datapoint (HList (model ': modelL)) = (HList ((Datapoint model) ': (UnHList (Datapoint (HList modelL)))))+        train1dp (dp:::dpL) = train1dp dp ::: train1dp dpL+
− src/HLearn/Algebra/Models.hs 
@@ -1,159 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-}---- | The 'HomTrainer' class forms the base of the HLearn library.  It represents homomorphisms from a free monoid/group to any other structure.  This captures our intuitive notion of how data mining and machine learning algorithms should behave, but in a way that allows for the easy creation of parallel and online algorithms.------ Unfortunately, we must slightly complicate the matter by also introducing the 'Model' class.  Many learning algorithms take some sort of parameters, and we need the model class to define what those parameters should look like.  --module HLearn.Algebra.Models-    ( -    -- * Parameters-    Model (..)-    , DefaultModel (..)-    -    -- * HomTrainer-    , HomTrainer (..)-    , DefaultHomTrainer (..)-    -    -- * Convenience functions-    , sub1dp-    , subBatch-    -    -- * Type synonyms---     , Labeled---     , Weighted---     , Label (..)-    )-    where-          -import qualified Control.ConstraintKinds as CK-          -import HLearn.Algebra.Functions-import HLearn.Algebra.Structures.Groups-import HLearn.Algebra.Structures.Modules---- import Control.DeepSeq--- import Data.Hashable--- import Data.Binary------------------------------------------------------------------------------------ Model---- | Every model has at least one data type that that fully describes its parameters.  Many models do not actually *need* any parameters, in which case they will simply use an empty data type for modelparams.-class Model modelparams model | modelparams -> model, model -> modelparams where-    getparams :: model -> modelparams-    --- | For those algorithms that do not require parameters (or that have reasonable default parameters), this class lets us use a more convenient calling notation.-class (Model modelparams model) => DefaultModel modelparams model | model -> modelparams where-    defparams :: modelparams---- | A minimal complete definition of the class is the singleton trainer 'train1dp\''-class -    ( Semigroup model-    , Monoid model-    , Model modelparams model-    ) => HomTrainer modelparams datapoint model | model -> modelparams datapoint-        where--    -- | The singleton trainer-    {-# INLINE train1dp' #-}-    train1dp' :: modelparams -> datapoint -> model-    train1dp' modelparams = unbatch (train' modelparams)-    -    -- | The batch trainer-    {-# INLINE train' #-}-    train' ::     -        ( CK.Functor container-        , CK.FunctorConstraint container model-        , CK.FunctorConstraint container datapoint-        , CK.Foldable container-        , CK.FoldableConstraint container model-        ) => modelparams -> container datapoint -> model-    train' modelparams = batch (train1dp' modelparams)--    -- | The online trainer-    {-# INLINE add1dp #-}-    add1dp :: model -> datapoint -> model-    add1dp model = online (train1dp' (getparams model :: modelparams)) model-    -    -- | The batch online trainer; will be more efficient than simply calling 'add1dp' for each element being added-    {-# INLINE addBatch #-}-    addBatch ::-        ( CK.Functor container-        , CK.FunctorConstraint container model-        , CK.FunctorConstraint container datapoint-        , CK.Foldable container-        , CK.FoldableConstraint container model-        ) =>  model -> container datapoint -> model-    addBatch model = online (train' (getparams model :: modelparams)) model-    --sub1dp :: -    ( RegularSemigroup model-    , HomTrainer modelparams datapoint model-    , DefaultModel modelparams model-    ) => model -> datapoint -> model-sub1dp model dp = model <> (inverse $ train1dp dp)---- model -. dp = sub1dp model dp--- model -. xs = subBatch model xs--subBatch :: -    ( CK.Functor container-    , CK.FunctorConstraint container model-    , CK.FunctorConstraint container datapoint-    , CK.Foldable container-    , CK.FoldableConstraint container model-    , RegularSemigroup model-    , HomTrainer modelparams datapoint model-    , DefaultModel modelparams model-    ) => model -> container datapoint -> model-subBatch model xs = model <> (inverse $ train xs)---- instance ---     ( HomTrainer modelparams datapoint model---     , LeftOperator r model---     ) => HomTrainer modelparams (r,datapoint) model where---         train1dp' modelparams (r,dp) = r .* (train1dp' modelparams dp)---- instance ---     ( HomTrainer modelparams datapoint model---     , RightOperator r model---     ) => HomTrainer modelparams (datapoint,r) model where---         train1dp' modelparams (dp,r) = (train1dp' modelparams dp) *. r----- | Provides parameterless functions for those training algorithms that do not require parameters-class -    ( DefaultModel modelparams model-    , HomTrainer modelparams datapoint model-    ) => DefaultHomTrainer modelparams datapoint model | model -> modelparams-        where-              -    -- | A singleton trainer that doesn't require parameters (uses 'defparams')-    {-# INLINE train1dp #-}-    train1dp :: datapoint -> model-    train1dp = train1dp' (defparams :: modelparams)-    -    -- | A batch trainer that doesn't require parameters (uses 'defparams')-    {-# INLINE train #-}-    train :: -        ( CK.Functor container-        , CK.FunctorConstraint container model-        , CK.FunctorConstraint container datapoint-        , CK.Foldable container-        , CK.FoldableConstraint container model-        ) => container datapoint -> model-    train = train' (defparams :: modelparams)-    -instance -    ( DefaultModel modelparams model-    , HomTrainer modelparams datapoint model-    ) => DefaultHomTrainer modelparams datapoint model-    -
+ src/HLearn/Algebra/Models/HomTrainer.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}++-- | Every model in the HLearn library is an instance of the 'HomTrainer' type class.  This ensures that the batch trainer is a monoid homomorphism.  This is a restrictive condition that not all learning models satisfy; however, it is useful for two reasons.  First, this property lets us easily derive three important functions for machine learning algorithms: online trainers, parallel trainers, and fast cross-validation algorithms.  Second, many popular algorithms (or variants on them) satisfy the condition and are implemented in the library.+--+-- For a full theoretical description of the 'HomTrainer' class, see the paper: <INSERT HERE>+--+-- Unfortunately, the class hierarchy here is slightly more complicated.  In the paper, we assume that all parameters for a model can be included in the model's type.  Currently, however, this is not possible in Haskell, so every model must also have a data type that describes it's parameters.  This is the purpose of the 'ModelParams' class.  Most models have either no parameters, or reasonable defaults, and so their parameters are instances of the 'DefaultParams' class.++module HLearn.Algebra.Models.HomTrainer+    (     +    -- * HomTrainer+    HomTrainer (..)+    , WeightedHomTrainer (..)+    , NumDP(..)+    +    )+    where+          +import qualified Control.ConstraintKinds as CK+import Data.Foldable+          +import HLearn.Algebra.Functions+import HLearn.Algebra.Structures.Groups+import HLearn.Algebra.Structures.Modules++-------------------------------------------------------------------------------+-- NumDP++-- | numdp returns the number of data points that the model has been trained on+class (HasRing model) => NumDP model where+    numdp :: model -> Ring model++-------------------------------------------------------------------------------+-- HomTrainer++-- | A minimal complete definition of the class is the singleton trainer 'train1dp\''+class (Monoid model) => HomTrainer model where+    +    type Datapoint model++    -- | The singleton trainer+    {-# INLINE train1dp #-}+    train1dp :: Datapoint model -> model+    train1dp = unbatch train+    +    -- | The batch trainer+    {-# INLINE train #-}+    train ::     +        ( Functor container+        , Foldable container+        ) => container (Datapoint model) -> model+    train = batch train1dp++    -- | The online trainer+    {-# INLINE add1dp #-}+    add1dp :: model -> Datapoint model -> model+    add1dp model = online train1dp model+    +    -- | The batch online trainer; will be more efficient than simply calling 'add1dp' for each element being added+    addBatch ::+        ( Functor container+        , Foldable container+        ) =>  model -> container (Datapoint model) -> model+    addBatch model = online train model++    -- | CK methods take advantage of the ContraintKinds extension to allow containers that require constraints.  In particular, they allow the use of Unboxed Vectors, which can improve performance.+    {-# INLINE trainCK #-}+    trainCK ::     +        ( CK.Functor container+        , CK.FunctorConstraint container model+        , CK.FunctorConstraint container (Datapoint model)+        , CK.Foldable container+        , CK.FoldableConstraint container model+        , CK.FoldableConstraint container (Datapoint model)+        ) => container (Datapoint model) -> model+    trainCK = batchCK train1dp++    {-# INLINE addBatchCK #-}+    addBatchCK ::+        ( CK.Functor container+        , CK.FunctorConstraint container model+        , CK.FunctorConstraint container (Datapoint model)+        , CK.Foldable container+        , CK.FoldableConstraint container model+        , CK.FoldableConstraint container (Datapoint model)+        ) =>  model -> container (Datapoint model) -> model+    addBatchCK model = online trainCK model+    ++-------------------------------------------------------------------------------+-- WeightedHomTrainer++class (Module model, HomTrainer model) => +    WeightedHomTrainer model +        where+        +    train1dpW :: (Ring model,Datapoint model) -> model+    train1dpW (r,dp) = r .* train1dp dp+    +    trainW :: (Foldable container, Functor container) => +        container (Ring model,Datapoint model) -> model+    trainW = batch train1dpW++    add1dpW :: model -> (Ring model,Datapoint model) -> model+    add1dpW = online $ unbatch $ offline addBatchW+    +    addBatchW :: (Foldable container, Functor container) => +        model -> container (Ring model,Datapoint model) -> model+    addBatchW = online trainW+    +instance (Module model, HomTrainer model) => WeightedHomTrainer model+    +-------------------------------------------------------------------------------+-- Counter instance for testing++data Counter sampletype = Counter {c::sampletype}+    deriving (Read,Show,Eq,Ord)++instance (Num sampletype) => Monoid (Counter sampletype) where+    mempty = Counter 0+    c1 `mappend` c2 = Counter $ c c1+c c2++instance (Num sampletype) => HomTrainer (Counter sampletype) where+    type Datapoint (Counter sampletype) = sampletype+    train1dp dp = Counter 1
src/HLearn/Algebra/Models/Lame.hs view
@@ -5,36 +5,47 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-} --- | Lame trainers are trainers that are crippled---They are not instances of Semigroup/Monoid, and training their models is not a homomorphism.  This means we can't do any of the cool manipulations automatically that we can do with the HomTrainer class.+{-# LANGUAGE OverlappingInstances #-} +-- | Lame trainers are trainers that are crippled---They are not Monoids, and training their models is not a homomorphism.  This means we can't do any of the cool manipulations automatically that we can do with the HomTrainer class.  These classes are provided mostly for development and testing purposes.  It is not recommended that you use any of their instances.+ module HLearn.Algebra.Models.Lame     (      -- * Classes     LameTrainer (..)     , LameTrainerOnline (..)-    , Sizable (..)     )     where           -import qualified Control.ConstraintKinds as CK-import HLearn.Algebra.Models+import HLearn.Algebra.Models.HomTrainer -class Sizable t where-    size :: t a -> Int+-- | Provides a non-homomorphic batch trainer+class LameTrainer model where+    type LameDatapoint model :: *+    type LameContainer model :: * -> *     -instance Sizable [] where-    size = length-          -class (Model modelparams model) => LameTrainer modelparams datapoint model where-    lame_train :: -        ( CK.Functor container-        , CK.FunctorConstraint container model-        , CK.FunctorConstraint container datapoint-        , CK.Foldable container-        , CK.FoldableConstraint container model-        , Sizable container-        ) => modelparams -> container datapoint -> model+    lame_train :: (LameContainer model) (LameDatapoint model) -> model++instance +    ( HomTrainer model+    ) => LameTrainer model +        where+    type LameDatapoint model = Datapoint model+    type LameContainer model = []     -class (Model modelparams model) => LameTrainerOnline modelparams datapoint model where-    lame_add1dp :: model -> datapoint -> model+    lame_train dataset = train dataset++-- | Provides a non-homomorphic online trainer+class LameTrainerOnline model where+    type LameDatapointOnline model :: *+    lame_add1dp :: model -> LameDatapointOnline model -> model+    +--     lame_addBatch :: model -> [datapoint] -> model+--     lame_addBatch = add1dp2addBatch lame_add1dp+--         +-- add1dp2addBatch :: (model -> dp -> model) -> (model -> [dp] -> model)+-- add1dp2addBatch add1dp = \model xs -> case xs of+--     []   -> model+--     x:xs -> (add1dp2addBatch add1dp) (add1dp model x) xs
− src/HLearn/Algebra/Morphism.hs 
@@ -1,139 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE DatatypeContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE UndecidableInstances #-}---- | A \"morphism\" is a general term for a function that converts one data structure into another.  The HLearn library uses this module to allow arbitrary morphisms to be declared, chained together, and assigned properties like surjectivity and homomorphic.------ NOTE: This module is still under heavy development and will probably change drastically!--module HLearn.Algebra.Morphism-    ( -    -- * Morphisms-    Morphism (..)-    , DefaultMorphism (..)-    -    -- * Morphism properties-    , Surjective (..)-    , Injective (..)-    , Homomorphism (..)-    -    -- * Chaining morphisms-    , MorphismComposition (..)-    )-    where--import qualified Control.ConstraintKinds as CK-import HLearn.Algebra.Models-import HLearn.Algebra.Structures.Groups---- | A Morphism converts from a domain to a codomain using the given parameters.  We perform the actual conversion using the @$>@ operator.--class Morphism domain params codomain | params -> codomain where-    morph' :: domain -> params -> codomain-    morph' = ($>)--    ($>) :: domain -> params -> codomain-    ($>) = morph'-        -    (<.>) :: params -> domain -> codomain-    (<.>) = flip morph'----- | This data structure allow us to chain arbitrary morphisms together to generate a new morphism.-data -    ( Morphism domain params1 interdomain-    , Morphism interdomain params2 codomain-    ) => MorphismComposition domain params1 interdomain params2 codomain = (:.) params2 params1--instance -    ( Morphism domain params1 interdomain-    , Morphism interdomain params2 codomain-    ) => Morphism domain (MorphismComposition domain params1 interdomain params2 codomain) codomain-    where-        morph' x (params2 :. params1) = morph' (morph' x params1) params2----- | If there is a reasonable default parameter (or no parameters at all) for performing the morphism, this class provides a shortcut syntax.-class (Morphism domain params codomain) => DefaultMorphism domain params codomain | domain codomain -> params  where-    defMorphParams :: domain -> codomain -> params-    -    morph :: domain -> codomain-    morph domain = (morph' :: domain -> params -> codomain) domain (defMorphParams (undefined :: domain) (undefined :: codomain))------------------------------------------------------------------------------------- data HLearn params domain codomain = HLearn params--- instance Category (MorphismComposition' params1 interdomain params2) where---     id a = a---     (.) = ------------------------------------------------------------------------------------ Properties--class (Morphism domain params codomain) => Surjective domain params codomain-instance -    ( Surjective domain params1 interdomain-    , Surjective interdomain params2 codomain-    ) => Surjective domain (MorphismComposition domain params1 interdomain params2 codomain) codomain-    -class (Morphism domain params codomain) => Injective domain params codomain-instance -    ( Injective domain params1 interdomain-    , Injective interdomain params2 codomain-    ) => Injective domain (MorphismComposition domain params1 interdomain params2 codomain) codomain-    -class (Morphism domain params codomain) => Homomorphism domain params codomain-instance -    ( Homomorphism domain params1 interdomain-    , Homomorphism interdomain params2 codomain-    ) => Homomorphism domain (MorphismComposition domain params1 interdomain params2 codomain) codomain------------------------------------------------------------------------------------ Training---- instance ---     ( HomTrainer modelparams datapoint model---     , CK.Foldable container---     , CK.FoldableConstraint container model---     , CK.Functor container---     , CK.FunctorConstraint container datapoint---     , CK.FunctorConstraint container model---     ) => Morphism (container datapoint) modelparams model---     where---         morph' input params = train' params input---     --- instance ---     ( Model params1 interdomain---     , Model params2 codomain---     ) => Model (MorphismComposition domain params1 interdomain params2 codomain) codomain---     where---         getparams model = undefined---- instance ---     ( DefaultModel params1 interdomain---     , DefaultModel params2 codomain---     ) => DefaultModel (MorphismComposition domain params1 interdomain params2 codomain) codomain---     where---         defparams = undefined-{--instance -    ( CK.FunctorConstraint container model-    , CK.FunctorConstraint container datapoint-    , CK.FoldableConstraint container model-    , CK.Foldable container-    , CK.Functor container-    , Model (MorphismComposition (container datapoint) params1 interdomain params2 codomain) codomain-    , HomTrainer params1 datapoint interdomain-    , Morphism (container datapoint) params1 interdomain-    , Morphism interdomain params2 codomain-    , Monoid codomain-    , Semigroup codomain-    , Model (MorphismComposition domain params1 interdomain params2 codomain) codomain-    ) => HomTrainer (MorphismComposition (container datapoint) params1 interdomain params2 codomain) datapoint codomain-    where-         train1dp' (params2 :. params1) dp = params2 <.> (train1dp' params1 dp)-}
+ src/HLearn/Algebra/Structures/Free/Bagging.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DataKinds #-}++module HLearn.Algebra.Structures.Free.Bagging+    ( Bagging+    , Bagging'+    )+    where++import Data.Hashable+import qualified Data.Vector as V+import GHC.TypeLits+import System.Random++import HLearn.Algebra.Models.HomTrainer+import HLearn.Algebra.Structures.Groups+import HLearn.Algebra.Structures.Modules++-------------------------------------------------------------------------------+-- data types++newtype Bagging' (n::Nat) (seed::Nat) model = Bagging'+    { modelL :: V.Vector model+    }+    deriving (Read,Show,Eq,Ord)++type Bagging n model = Bagging' n 0 model++-------------------------------------------------------------------------------+-- Algebra++instance (Abelian model, SingI n) => Abelian (Bagging' n seed model) where+instance (Monoid model, SingI n) => Monoid (Bagging' n seed model) where+    mempty = Bagging' $ V.replicate (fromIntegral $ fromSing $ (sing :: Sing n)) mempty+    (Bagging' v1) `mappend` (Bagging' v2) = Bagging' $ V.zipWith (<>) v1 v2++instance (Group model, SingI n) => Group (Bagging' n seed model) where+    inverse (Bagging' v) = Bagging' $ fmap inverse v++instance (HasRing model) => HasRing (Bagging' n seed model) where+    type Ring (Bagging' n seed model) = Ring model++instance (Module model, SingI n) => Module (Bagging' n seed model) where+    r .* (Bagging' v) = Bagging' $ fmap (r.*) v++-------------------------------------------------------------------------------+-- Training++instance +    ( HomTrainer model+    , SingI n+    , SingI seed+    , Hashable (Datapoint model)+    ) => HomTrainer (Bagging' n seed model) +        where+    +    type Datapoint (Bagging' n seed model) = Datapoint model+    +    train1dp dp = Bagging' $ V.replicate n mempty V.// [(offset `mod` n,train1dp dp)]+        where+            n = fromIntegral $ fromSing (sing :: Sing n)+            seed = fromIntegral $ fromSing (sing :: Sing seed)+            (offset,g) = random $ mkStdGen $ hash dp + seed
+ src/HLearn/Algebra/Structures/Free/FreeHomTrainer.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE EmptyDataDecls #-}++{-# LANGUAGE OverlappingInstances #-}++module HLearn.Algebra.Structures.Free.FreeHomTrainer+    ( FreeHomTrainer (..)+    , NoFlatten+    , AbelianGroup+    , FreeHomTrainer'+    )+    where++import Control.Applicative+import qualified Data.Map as Map++import HLearn.Algebra.Models.HomTrainer+import HLearn.Algebra.Models.Lame+import HLearn.Algebra.Structures.Groups+import HLearn.Algebra.Structures.Modules+import HLearn.Algebra.Structures.Free.FreeModule++-------------------------------------------------------------------------------+-- data types++newtype FreeHomTrainer' container model = FreeHomTrainer'+    { modelL :: container model+    }+    deriving (Read,Show,Eq,Ord,Monoid,Group,Abelian)++type family FreeHomTrainer (model:: *) (algebra::a) (merge::b) :: x+type instance FreeHomTrainer model Monoid        NoFlatten = FreeHomTrainer' FreeMonoid model+type instance FreeHomTrainer model Group         NoFlatten = FreeHomTrainer' FreeGroup model+type instance FreeHomTrainer model AbelianGroup  NoFlatten = FreeHomTrainer' (FreeModule Int) model+type instance FreeHomTrainer model (Module ring) NoFlatten = FreeHomTrainer' (FreeModule ring) model+type instance FreeHomTrainer model Module        NoFlatten = FreeHomTrainer' (FreeModule (Ring model)) model++data NoFlatten++newtype FreeMonoid a = FreeMonoid [a]+newtype FreeGroup a = FreeGroup [a]+data AbelianGroup ++-------------------------------------------------------------------------------+-- Algebra++instance (HasRing (container model)) => HasRing (FreeHomTrainer' container model) where+    type Ring (FreeHomTrainer' container model) = Ring (container model)+    +deriving instance (Module (container model)) => Module (FreeHomTrainer' container model)++-------------------------------------------------------------------------------+-- Training++instance +    ( Num ring+    , Ord model+    , LameTrainer model+    , Applicative container+    , Monoid (container model)+    ) => HomTrainer (FreeHomTrainer' container model) +        where+    +    type Datapoint (FreeHomTrainer' container model) = (LameContainer model) (LameDatapoint model)+    +    train1dp dp = FreeHomTrainer'+        { modelL = pure $ lame_train dp+        }+        +instance +    (Num ring, Ord model, LameTrainer model) => HomTrainer (FreeHomTrainer' (FreeModule ring) model) where+    +    type Datapoint (FreeHomTrainer' (FreeModule ring) model) = (LameContainer model) (LameDatapoint model)+    +    train1dp dp = FreeHomTrainer'+        { modelL = FreeModule $ Map.singleton (lame_train dp) 1+        }
+ src/HLearn/Algebra/Structures/Free/FreeModule.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module HLearn.Algebra.Structures.Free.FreeModule+    ( FreeModule (..)+    , list2module+    )+    where++import Control.Applicative+import qualified Control.ConstraintKinds as CK+import Data.List+import qualified Data.Map as Map+import HLearn.Algebra.Structures.Groups+import HLearn.Algebra.Structures.Modules++-------------------------------------------------------------------------------+-- FreeModuleule++newtype FreeModule r a = FreeModule { getMap :: Map.Map a r }+    deriving (Read,Show,Eq, Ord)++-- instance CK.Functor (FreeModule r) where+--     type FunctorConstraint (FreeModule r) a = (Num r, Ord a)+--     fmap f (FreeModule m) = FreeModule $ Map.mapKeysWith (+) f m+-- +-- instance CK.Foldable (FreeModule r) where+--     type FoldableConstraint (FreeModule r) a = (Num r, Ord a{-, Operator r a-})+-- --     foldr f b (FreeModule m) = Map.foldrWithKey (\a r b -> f (r .* a) b) b m+--     foldr f b (FreeModule m) = foldr (\(a,r) b -> f (r .* a) b) b $ Map.toList m+--     foldl f b (FreeModule m) = foldl (\b (a,r) -> f b (r .* a)) b $ Map.toList m+--     foldl' f b (FreeModule m) = foldl' (\b (a,r) -> f b (r .* a)) b $ Map.toList m+--     +--     foldr1 f (FreeModule m) = foldr1 f $ map (\(a,r) -> r.*a) $ Map.toList m+--     foldl1 f (FreeModule m) = foldl1 f $ map (\(a,r) -> r.*a) $ Map.toList m++instance (Num r, Ord a) => Abelian (FreeModule r a)+instance (Num r, Ord a) => Monoid (FreeModule r a) where+    mempty = FreeModule mempty+    (FreeModule m1) `mappend` (FreeModule m2) = FreeModule $ Map.unionWith (+) m1 m2+    +instance (Num r, Ord a) => Group (FreeModule r a) where+    inverse (FreeModule m) = FreeModule $ Map.map negate m++instance (Num r) => HasRing (FreeModule r a) where+    type Ring (FreeModule r a) = r++instance (Num r, Ord a) => Module (FreeModule r a) where+    r .* (FreeModule m) = FreeModule $ Map.map (r*) m++list2module :: (Num r, Ord r, Ord a) => [a] -> FreeModule r a+list2module xs = FreeModule $ Map.fromList $ go 0 (head sorted) [] sorted+    where+        sorted = sort xs+        +        go n x retL [] = (x,n):retL+        go n x retL xs = if (head xs) == x+            then go (n+1) x retL (tail xs)+            else go 1 (head xs) ((x,n):retL) (tail xs)+
− src/HLearn/Algebra/Structures/Free/RegSG2Group.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DatatypeContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}---- | These algebraic structures have sacrificed generality in favor of being easily used with the standard Haskell Prelude.  The fact that monoids are not guaranteed to be semigroups makes this difficult.--module HLearn.Algebra.Structures.Free.RegSG2Group-    where--import HLearn.Algebra.Structures.Groups-import HLearn.Algebra.Structures.Modules-import Control.DeepSeq---- | Convert any regular semigroup into a group (and thus also a monoid) by adding a unique identity element-data RegSG2Group sg = SGNothing | SGJust sg-    deriving (Show,Read,Ord,Eq)--instance (RegularSemigroup sg) => Semigroup (RegSG2Group sg) where-    SGNothing <> m = m-    m <> SGNothing = m-    (SGJust sg1) <> (SGJust sg2) = SGJust $ sg1<>sg2--instance (RegularSemigroup sg) => RegularSemigroup (RegSG2Group sg) where-    inverse SGNothing = SGNothing-    inverse (SGJust x) = SGJust $ inverse x--instance (RegularSemigroup sg) => Monoid (RegSG2Group sg) where-    mempty = SGNothing-    mappend = (<>)-    -instance (RegularSemigroup sg) => Group (RegSG2Group sg)--instance (RegularSemigroup sg, NFData sg) => NFData (RegSG2Group sg) where-    rnf SGNothing = ()-    rnf (SGJust sg) = rnf sg-    -instance (LeftOperator r sg, RegularSemigroup sg) => LeftOperator r (RegSG2Group sg) where-    r .* (SGNothing) = SGNothing-    r .* (SGJust sg) = SGJust $ r .*  sg-    -instance (RightOperator r sg, RegularSemigroup sg) => RightOperator r (RegSG2Group sg) where-    (SGNothing) *. r = SGNothing-    (SGJust sg) *. r = SGJust $ sg *. r
src/HLearn/Algebra/Structures/Groups.hs view
@@ -2,23 +2,25 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DatatypeContexts #-}  -- | These algebraic structures have sacrificed generality in favor of being easily used with the standard Haskell Prelude.  The fact that monoids are not guaranteed to be semigroups makes this difficult.  module HLearn.Algebra.Structures.Groups     ( -    -- * Type classes-    RegularSemigroup (..)-    , Group(..)+    -- * Algebra+    Group(..)     , Abelian (..) -    , module Data.Semigroup+    -- * Non-algebraic+    , FreeInverse(..)+    , Invertible(..)+    +    , module Data.Monoid     )     where  import Control.DeepSeq-import Data.Semigroup+import Data.Monoid import GHC.Exts (Constraint)  -------------------------------------------------------------------------------@@ -26,18 +28,43 @@ -- class (c a) => Abelian (a :: *) (c :: * -> Constraint) where --     op :: a -> a -> a -class (Semigroup sg) => Abelian sg+class (Monoid m) => Abelian m  ------------------------------------------------------------------------------- -- Inverses --- | Semigroups that also have an inverse.  See <https://en.wikipedia.org/wiki/Regular_semigroup>-class (Semigroup g) => RegularSemigroup g where+-- | Groups are monoids that also have an inverse.  See <https://en.wikipedia.org/wiki/Regular_semigroup>+class (Monoid g) => Group g where     inverse :: g -> g --- -- | Semigroups where a unique inverse exists for each element.  See <https://en.wikipedia.org/wiki/Inverse_semigroup>--- class (RegularSemigroup g) => InverseSemigroup g+-------------------------------------------------------------------------------+-- Invertible --- | Regular semigroups that also have an identity; alternatively, monoids where every element has a unique inverse.  See <https://en.wikipedia.org/wiki/Group_(mathematics)>-class (RegularSemigroup g, Monoid g) => Group g-instance (RegularSemigroup g, Monoid g) => Group g+data FreeInverse a = FreeInverse !a +                   | Negate !a+    deriving (Read,Show,Eq)++instance (Ord a) => Ord (FreeInverse a) where+    compare (FreeInverse x) (FreeInverse y) = compare x y+    compare (Negate x) (Negate y) = compare x y+    compare (FreeInverse x) (Negate y) = case compare x y of+                                      LT -> LT+                                      GT -> GT+                                      EQ -> LT+    compare (Negate x) (FreeInverse y) = case compare x y of+                                      LT -> LT+                                      GT -> GT+                                      EQ -> GT++class Invertible a where+    mkinverse :: a -> a+    isInverse :: a -> a -> Bool+    +instance (Eq a) => Invertible (FreeInverse a) where+    mkinverse (FreeInverse x) = Negate x+    mkinverse (Negate x) = FreeInverse x+    +    isInverse (FreeInverse x) (FreeInverse y) = False+    isInverse (Negate x) (Negate y) = False+    isInverse (FreeInverse x) (Negate y) = x==y+    isInverse (Negate x) (FreeInverse y) = x==y
+ src/HLearn/Algebra/Structures/MetricSpace.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Metric spaces are mathematical structures that have a notion of distance between objects.  See wikipedia for more information: <https://en.wikipedia.org/wiki/Metric_space>+module HLearn.Algebra.Structures.MetricSpace+    where+          +import Data.List+import Data.Monoid+import HLearn.Algebra.Structures.Modules+                    +-------------------------------------------------------------------------------+-- MetricSpaces++-- | We assume that the MetricSpace on s is compatible with the ordering on s+class (HasRing s) => MetricSpace s where+    distance :: s -> s -> Ring s+    +-------------------------------------------------------------------------------+-- Norms++class (Module m, MetricSpace m) => Norm m where+    {-# INLINE magnitude #-}+    magnitude :: m -> Ring m+    magnitude m = distance m mempty+          +instance (Module m, MetricSpace m) => Norm m where+
src/HLearn/Algebra/Structures/Modules.hs view
@@ -1,136 +1,45 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DatatypeContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}  -- | Modules are a generalization of vector spaces  module HLearn.Algebra.Structures.Modules     where -import qualified Control.ConstraintKinds as CK import Data.List-import qualified Data.Map as Map import HLearn.Algebra.Structures.Groups  ---------------------------------------------------------------------------------- Operators--class (LeftOperator r m, RightOperator r m) => Operator r m-instance (LeftOperator r m, RightOperator r m) => Operator r m--class LeftOperator r m | m -> r where-    infixl 7 .*-    (.*) :: r -> m -> m--class RightOperator r m | m -> r where-    infixl 7 *.-    (*.) :: m -> r -> m--instance RightOperator Integer Integer where (*.) = (*)-instance LeftOperator Integer Integer where (.*) = (*)--instance RightOperator Int Int where (*.) = (*)-instance LeftOperator Int Int where (.*) = (*)--instance RightOperator Float Float where (*.) = (*)-instance LeftOperator Float Float where (.*) = (*)--instance RightOperator Double Double where (*.) = (*)-instance LeftOperator Double Double where (.*) = (*)--instance (RightOperator a b) => RightOperator a [b] where bs *. a = fmap (*.a) bs-instance (LeftOperator a b) => LeftOperator a [b] where a .* bs = fmap (a.*) bs------------------------------------------------------------------------------------ FreeOp---- | Bug: Technically, the free operator should just require that r be a semigroup and use (<>) to chain the r's together.  But this would make things awkward because the number types aren't instances of semigroup.  Constraining r to be of type Num reduces our generality but makes FreeOp easier to work with in most practical use cases.---- newtype (Num r) => FreeOp r a = FreeOp [(r,a)]---     deriving (Read,Show)--- --- instance (Num r) => Functor (FreeOp r) where---     fmap f (FreeOp xs) = FreeOp $ map (\(r,a) -> (r,f a)) xs--- --- instance (Num r) => LeftOperator r (FreeOp r m) where---     r <| (FreeOp xs) = FreeOp $ map (\(r2,m) -> (r*r2,m)) xs---     --- instance (Num r) => RightOperator r (FreeOp r m) where---     m |> r = r <| m---     --- list2freeop :: (Num r) => [a] -> FreeOp r a--- list2freeop = FreeOp . map (\x -> (1,x))----------------------------------------------------------------------------------- -- Modules --- | Bug: The module classes have the constraint that r be of type Num.  Technically, this should be a Ring.  But creating a Ring class would be awkward because it would conflict with the Num class and require importing a different Prelude.--class (LeftModule r g, RightModule r g) => Module r g-instance (LeftModule r g, RightModule r g) => Module r g--class (LeftOperator r g, Num r, Group g, Abelian g) => LeftModule r g-instance (LeftOperator r g, Num r, Group g, Abelian g) => LeftModule r g--class (RightOperator r g, Num r, Group g, Abelian g) => RightModule r g-instance (RightOperator r g, Num r, Group g, Abelian g) => RightModule r g------------------------------------------------------------------------------------ FreeModule--data FreeModParams = FreeModParams--newtype (Num r, Ord a) => FreeMod r a = FreeMod (Map.Map a r)-    deriving (Read,Show,Eq)--instance CK.Functor (FreeMod r) where-    type FunctorConstraint (FreeMod r) a = (Num r, Ord a)-    fmap f (FreeMod m) = FreeMod $ Map.mapKeysWith (+) f m--instance CK.Foldable (FreeMod r) where-    type FoldableConstraint (FreeMod r) a = (Num r, Ord a, Operator r a)---     foldr f b (FreeMod m) = Map.foldrWithKey (\a r b -> f (r .* a) b) b m-    foldr f b (FreeMod m) = foldr (\(a,r) b -> f (r .* a) b) b $ Map.toList m-    foldl f b (FreeMod m) = foldl (\b (a,r) -> f b (r .* a)) b $ Map.toList m-    foldl' f b (FreeMod m) = foldl' (\b (a,r) -> f b (r .* a)) b $ Map.toList m-    -    foldr1 f (FreeMod m) = foldr1 f $ map (\(a,r) -> r.*a) $ Map.toList m-    foldl1 f (FreeMod m) = foldl1 f $ map (\(a,r) -> r.*a) $ Map.toList m--instance (Num r, Ord a) => Abelian (FreeMod r a)-instance (Num r, Ord a) => Semigroup (FreeMod r a) where-    (FreeMod m1) <> (FreeMod m2) = FreeMod $ Map.unionWith (+) m1 m2+class (Num (Ring m)) => HasRing m where+    type Ring m -instance (Num r, Ord a) => Monoid (FreeMod r a) where-    mempty = FreeMod mempty-    mappend = (<>)+-- | Bug: The module classes have the constraint that r be of type Num.  Technically, this should be a Ring.  But creating a Ring class would be awkward because it would conflict with the Num class and require importing a different Prelude.+class (HasRing m, Abelian m, Group m) => Module m where    +    infix 7 .*+    (.*) :: (Ring m) -> m -> m     -instance (Num r, Ord a) => RegularSemigroup (FreeMod r a) where-    inverse (FreeMod m) = FreeMod $ Map.map negate m+    {-# INLINE (*.) #-}+    infix 7 *.+    (*.) :: m -> (Ring m) -> m+    m *. r = r .* m -instance (Num r, Ord a) => LeftModule r (FreeMod r a)-instance (Num r, Ord a) => LeftOperator r (FreeMod r a) where-    r .* (FreeMod m) = FreeMod $ Map.map (r*) m-    -instance (Num r, Ord a) => RightModule r (FreeMod r a)-instance (Num r, Ord a) => RightOperator r (FreeMod r a) where-    a *. r = r .* a+-------------------------------------------------------------------------------+-- Vector Spaces -list2module :: (Num r, Ord r, Ord a) => [a] -> FreeMod r a-list2module xs = FreeMod $ Map.fromList $ go 0 (head sorted) [] sorted-    where-        sorted = sort xs-        -        go n x retL [] = (x,n):retL-        go n x retL xs = if (head xs) == x-            then go (n+1) x retL (tail xs)-            else go 1 (head xs) ((x,n):retL) (tail xs)+class (Module m, Fractional (Ring m)) => VectorSpace m where+    infix 7 /.+    {-# INLINE (/.) #-}+    (/.) :: m -> (Ring m) -> m+    m /. r = m *. (1/r) +instance (Module m, Fractional (Ring m)) => VectorSpace m
src/HLearn/Algebra/Structures/Triangles.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +-- | Provides a generic interface to structures that offer both a left and right cons.  It's based on the Data.Sequence interface. module HLearn.Algebra.Structures.Triangles     ( Triangle (..) --     , module Data.Sequence@@ -10,6 +11,7 @@ import qualified Data.Sequence as S import Data.Sequence hiding ((<|),(|>)) +-- | Methods for left and right cons on a data type class Triangle f a where     (<|) :: a -> f -> f     (|>) :: f -> a -> f