srtree (empty) → 0.1.0.0
raw patch · 10 files changed
+1146/−0 lines, 10 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl, random, srtree, vector
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +34/−0
- Setup.hs +2/−0
- src/Data/SRTree.hs +57/−0
- src/Data/SRTree/Internal.hs +547/−0
- src/Data/SRTree/Print.hs +210/−0
- src/Data/SRTree/Random.hs +182/−0
- srtree.cabal +62/−0
- test/Spec.hs +17/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Changelog for srtree++## 0.1.0.0++- Initial version
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,34 @@+# srtree: A symbolic regression expression tree structure.++`srtree` is a Haskell library with a data structure and supporting functions to manipulate expression trees for symbolic regression.++The tree-like structure is parameterized by the type of the variables indexing and the return value when evaluating the tree. The most common is to index the variables with `Int` starting at $0$ and to return a `Double`. The Functor instance changes the type of the stored/returned values.++The tree supports leaf nodes containing a variable, a free parameter, or a constant value; internal nodes that represents binary operators such as the four basic math operations, logarithm with custom base, and the power of two expressions; and unary functions specified by `Function` data type.++This library also defines the `OptInt` class with the operator `^.` that represents the integral power. This is needed to automatically simplify some constructs of the tree and also when using interval arithmetic, that requires a special case of integral power.++The `SRTree` structure has instances for `Num, Fractional, Floating` which allows to create an expression as a valid Haskell expression such as:++```haskell+x = Var 0+y = Var 1+expr = x * 2 + sin(y * pi + x) :: SRTree Int Double+```++There is also a `Bifunctor` instance that allows to change the type of both parameters, and an `Applicative, Foldable, Traversable` instances. To traverse by the index type, there is a function called `traverseIx`.++## Other features:++- simplification algorithm (`simplify`)+- derivative w.r.t. a variable (`deriveBy`)+- evaluation (`evalTree`)+- relabel free parameters sequentially (`relabelParams`)+- relabel variables couting their occurrence (`relabelOccurrences`, used with interval arithmetic)++## TODO:++- derivative w.r.t. free parameters+- support more advanced functions+- support conditional branching (`IF-THEN-ELSE`)+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Data/SRTree.hs view
@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.SRTree +-- Copyright : (c) Fabricio Olivetti 2021 - 2021+-- License : BSD3+-- Maintainer : fabricio.olivetti@gmail.com+-- Stability : experimental+-- Portability : FlexibleInstances, DeriveFunctor, ScopedTypeVariables, ConstraintKinds+--+-- Expression tree for Symbolic Regression+--+-----------------------------------------------------------------------------+module Data.SRTree + ( SRTree(..)+ , Function(..)+ , OptIntPow(..)+ , traverseIx+ , arity+ , getChildren+ , countNodes+ , countVarNodes+ , countOccurrences+ , deriveBy+ , simplify+ , derivative+ , evalFun+ , inverseFunc+ , evalTree+ , evalTreeMap+ , evalTreeWithMap+ , evalTreeWithVector+ , relabelOccurrences+ , relabelParams+ )+ where+ +import Data.SRTree.Internal ( SRTree(..)+ , Function(..)+ , OptIntPow(..)+ , traverseIx+ , arity+ , getChildren+ , countNodes+ , countVarNodes+ , countOccurrences+ , deriveBy+ , simplify+ , derivative+ , evalFun+ , inverseFunc+ , evalTree+ , evalTreeMap+ , evalTreeWithMap+ , evalTreeWithVector+ , relabelOccurrences+ , relabelParams+ )
+ src/Data/SRTree/Internal.hs view
@@ -0,0 +1,547 @@+{-# language FlexibleInstances, DeriveFunctor #-}+{-# language ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.SRTree.Internal +-- Copyright : (c) Fabricio Olivetti 2021 - 2021+-- License : BSD3+-- Maintainer : fabricio.olivetti@gmail.com+-- Stability : experimental+-- Portability : FlexibleInstances, DeriveFunctor, ScopedTypeVariables+--+-- Expression tree for Symbolic Regression+--+-----------------------------------------------------------------------------++module Data.SRTree.Internal + ( SRTree(..)+ , Function(..)+ , OptIntPow(..)+ , traverseIx+ , arity+ , getChildren+ , countNodes+ , countVarNodes+ , countOccurrences+ , deriveBy+ , simplify+ , derivative+ , evalFun+ , inverseFunc+ , evalTree+ , evalTreeMap+ , evalTreeWithMap+ , evalTreeWithVector+ , relabelOccurrences+ , relabelParams+ )+ where++import Data.Bifunctor++import Data.Map.Strict (Map(..), (!), (!?), insert, fromList)+import qualified Data.Map.Strict as M+import qualified Data.Vector as V+import Control.Monad.State+import Control.Monad.Reader+import Control.Applicative hiding (Const)++-- | Tree structure to be used with Symbolic Regression algorithms.+-- This structure is parametrized by the indexing type to retrieve the values+-- of a variable and the type of the output value.+data SRTree ix val = + Empty + | Var ix+ | Const val+ | Param ix+ | Fun Function (SRTree ix val)+ | Pow (SRTree ix val) Int+ | SRTree ix val `Add` SRTree ix val+ | SRTree ix val `Sub` SRTree ix val+ | SRTree ix val `Mul` SRTree ix val+ | SRTree ix val `Div` SRTree ix val+ | SRTree ix val `Power` SRTree ix val+ | SRTree ix val `LogBase` SRTree ix val+ deriving (Show, Eq, Ord, Functor)++-- | Functions that can be applied to a subtree.+data Function = + Id + | Abs+ | Sin + | Cos + | Tan + | Sinh+ | Cosh+ | Tanh + | ASin + | ACos + | ATan+ | ASinh+ | ACosh + | ATanh + | Sqrt + | Cbrt + | Square + | Log + | Exp + deriving (Show, Read, Eq, Ord, Enum)++-- | A class for optimized `(^^)` operators for specific types.+-- This was created because the integer power operator for+-- interval arithmetic must be aware of the dependency problem,+-- thus the default `(^)` doesn't work.+class OptIntPow a where+ (^.) :: a -> Int -> a+ infix 8 ^.+ +instance OptIntPow Double where+ (^.) = (^^)+ {-# INLINE (^.) #-}+instance OptIntPow Float where+ (^.) = (^^)+ {-# INLINE (^.) #-}+ + +instance (Eq ix, Eq val, Num val, OptIntPow val) => OptIntPow (SRTree ix val) where+ t ^. 0 = 1+ t ^. 1 = t+ (Const c) ^. k = Const $ c ^. k + t ^. k = Pow t k+ {-# INLINE (^.) #-}+ +instance (Eq ix, Eq val, Num val) => Num (SRTree ix val) where+ 0 + r = r+ l + 0 = l+ (Const c1) + (Const c2) = Const $ c1 + c2+ l + r = Add l r+ {-# INLINE (+) #-}++ 0 - r = (-1) * r+ l - 0 = l+ (Const c1) - (Const c2) = Const $ c1 - c2+ l - r = Sub l r+ {-# INLINE (-) #-}++ 0 * r = 0+ l * 0 = 0+ 1 * r = r+ l * 1 = l + (Const c1) * (Const c2) = Const $ c1 * c2+ l * r = Mul l r+ {-# INLINE (*) #-}+ + abs = Fun Abs+ {-# INLINE abs #-}+ + negate (Const x) = Const (negate x)+ negate t = Const (-1) * t+ {-# INLINE negate #-}+ + signum t = case t of+ Const x -> Const $ signum x+ _ -> Const 0+ fromInteger x = Const (fromInteger x)+ {-# INLINE fromInteger #-}++instance (Eq ix, Eq val, Fractional val) => Fractional (SRTree ix val) where+ 0 / r = 0+ l / 1 = l+ (Const c1) / (Const c2) = Const $ c1/c2+ l / r = Div l r+ {-# INLINE (/) #-}+ + fromRational = Const . fromRational+ {-# INLINE fromRational #-}+ +instance (Eq ix, Eq val, Floating val) => Floating (SRTree ix val) where + pi = Const pi+ {-# INLINE pi #-}+ exp = evalToConst . Fun Exp+ {-# INLINE exp #-}+ log = evalToConst . Fun Log+ {-# INLINE log #-}+ sqrt = evalToConst . Fun Sqrt+ {-# INLINE sqrt #-}+ sin = evalToConst . Fun Sin+ {-# INLINE sin #-}+ cos = evalToConst . Fun Cos+ {-# INLINE cos #-}+ tan = evalToConst . Fun Tan+ {-# INLINE tan #-}+ asin = evalToConst . Fun ASin+ {-# INLINE asin #-}+ acos = evalToConst . Fun ACos+ {-# INLINE acos #-}+ atan = evalToConst . Fun ATan+ {-# INLINE atan #-}+ sinh = evalToConst . Fun Sinh+ {-# INLINE sinh #-}+ cosh = evalToConst . Fun Cosh+ {-# INLINE cosh #-}+ tanh = evalToConst . Fun Tanh+ {-# INLINE tanh #-}+ asinh = evalToConst . Fun ASinh+ {-# INLINE asinh #-}+ acosh = evalToConst . Fun ACosh+ {-# INLINE acosh #-}+ atanh = evalToConst . Fun ATanh+ {-# INLINE atanh #-}++ 0 ** r = 0+ 1 ** r = 1+ l ** 0 = 1+ l ** 1 = l+ l ** r = evalToConst $ Power l r+ {-# INLINE (**) #-}++ logBase 1 r = 0+ logBase l r = evalToConst $ LogBase l r+ {-# INLINE logBase #-}++instance Bifunctor SRTree where+ first f Empty = Empty+ first f (Var ix) = Var $ f ix+ first f (Param ix) = Param $ f ix+ first f (Fun g t) = Fun g $ first f t+ first f (Pow t k) = Pow (first f t) k+ first f (Add l r) = Add (first f l) (first f r)+ first f (Sub l r) = Sub (first f l) (first f r)+ first f (Mul l r) = Mul (first f l) (first f r)+ first f (Div l r) = Div (first f l) (first f r)+ first f (Power l r) = Power (first f l) (first f r)+ first f (LogBase l r) = LogBase (first f l) (first f r)+ {-# INLINE first #-}+ + second = fmap+ {-# INLINE second #-}++instance Applicative (SRTree ix) where+ pure = Const++ Empty <*> t = Empty+ Var ix <*> t = Var ix+ Param ix <*> t = Param ix+ Const f <*> t = fmap f t+ Fun g tf <*> t = Fun g $ tf <*> t+ Pow tf k <*> t = Pow (tf <*> t) k+ Add lf rf <*> t = Add (lf <*> t) (rf <*> t)+ Sub lf rf <*> t = Sub (lf <*> t) (rf <*> t)+ Mul lf rf <*> t = Mul (lf <*> t) (rf <*> t)+ Div lf rf <*> t = Div (lf <*> t) (rf <*> t)+ Power lf rf <*> t = Power (lf <*> t) (rf <*> t)+ LogBase lf rf <*> t = LogBase (lf <*> t) (rf <*> t)+ +instance Foldable (SRTree ix) where+ foldMap f Empty = mempty+ foldMap f (Var ix) = mempty+ foldMap f (Param ix) = mempty+ foldMap f (Const c) = f c+ foldMap f t = mconcat $ map (foldMap f) $ getChildren t++instance Traversable (SRTree ix) where+ traverse mf Empty = pure Empty+ traverse mf (Var ix) = pure $ Var ix+ traverse mf (Param ix) = pure $ Param ix+ traverse mf (Const c) = Const <$> mf c+ traverse mf (Fun g t) = Fun g <$> traverse mf t+ traverse mf (Pow t k) = (`Pow` k) <$> traverse mf t+ traverse mf (Add l r) = Add <$> traverse mf l <*> traverse mf r+ traverse mf (Sub l r) = Sub <$> traverse mf l <*> traverse mf r+ traverse mf (Mul l r) = Mul <$> traverse mf l <*> traverse mf r+ traverse mf (Div l r) = Div <$> traverse mf l <*> traverse mf r+ traverse mf (Power l r) = Power <$> traverse mf l <*> traverse mf r+ traverse mf (LogBase l r) = LogBase <$> traverse mf l <*> traverse mf r++-- | Same as `traverse` but for the first type parameter.+traverseIx :: Applicative f => (ixa -> f ixb) -> SRTree ixa val -> f (SRTree ixb val)+traverseIx mf Empty = pure Empty+traverseIx mf (Var ix) = Var <$> mf ix+traverseIx mf (Param ix) = Param <$> mf ix+traverseIx mf (Const c) = pure $ Const c+traverseIx mf (Fun g t) = Fun g <$> traverseIx mf t+traverseIx mf (Pow t k) = (`Pow` k) <$> traverseIx mf t+traverseIx mf (Add l r) = Add <$> traverseIx mf l <*> traverseIx mf r+traverseIx mf (Sub l r) = Sub <$> traverseIx mf l <*> traverseIx mf r+traverseIx mf (Mul l r) = Mul <$> traverseIx mf l <*> traverseIx mf r+traverseIx mf (Div l r) = Div <$> traverseIx mf l <*> traverseIx mf r+traverseIx mf (Power l r) = Power <$> traverseIx mf l <*> traverseIx mf r+traverseIx mf (LogBase l r) = LogBase <$> traverseIx mf l <*> traverseIx mf r+{-# INLINE traverseIx #-}++-- | Arity of the current node+arity :: SRTree ix val -> Int+arity Empty = 0+arity (Var _) = 0+arity (Param _) = 0+arity (Const _) = 0+arity (Fun _ _) = 1+arity (Pow _ _) = 1+arity _ = 2+{-# INLINE arity #-}++-- | Get the children of a node. Returns an empty list in case of a leaf node.+getChildren :: SRTree ix val -> [SRTree ix val]+getChildren Empty = []+getChildren (Var _) = []+getChildren (Param _) = []+getChildren (Const _) = []+getChildren (Fun _ t) = [t]+getChildren (Pow t _) = [t]+getChildren (Add l r) = [l, r]+getChildren (Sub l r) = [l, r]+getChildren (Mul l r) = [l, r]+getChildren (Div l r) = [l, r]+getChildren (Power l r) = [l, r]+getChildren (LogBase l r) = [l, r]+{-# INLINE getChildren #-}++-- Support function to simplify operations applied to const subtrees.+evalToConst :: Floating val => SRTree ix val -> SRTree ix val +evalToConst (Fun g (Const c)) = Const $ evalFun g c+evalToConst (Power (Const c1) (Const c2)) = Const $ c1**c2+evalToConst (LogBase (Const c1) (Const c2)) = Const $ logBase c1 c2+evalToConst t = t+{-# INLINE evalToConst #-}++-- Support function to sum the types of nodes specified by `f`.+sumCounts :: (SRTree ix val -> Int) -> Int -> SRTree ix val -> Int+sumCounts f val = foldr (\c v -> f c + v) val . getChildren+{-# INLINE sumCounts #-}++-- | Count the number of nodes in a tree.+countNodes :: SRTree ix val -> Int+countNodes Empty = 0+countNodes t = sumCounts countNodes 1 t+{-# INLINE countNodes #-}++-- | Count the number of `Var` nodes+countVarNodes :: SRTree ix val -> Int+countVarNodes (Var _) = 1+countVarNodes t = sumCounts countVarNodes 0 t+{-# INLINE countVarNodes #-}++-- | Count the occurrences of variable indexed as `ix`+countOccurrences :: Eq ix => SRTree ix val -> ix -> Int+countOccurrences (Var ix) iy = if ix==iy then 1 else 0+countOccurrences t iy = sumCounts (`countOccurrences` iy) 0 t+{-# INLINE countOccurrences #-}++-- | Creates an `SRTree` representing the partial derivative of the input by the variable indexed by `ix`.+deriveBy :: (Eq ix, Eq val, Floating val, OptIntPow val) => ix -> SRTree ix val -> SRTree ix val+deriveBy _ Empty = Empty+deriveBy dx (Var ix)+ | dx == ix = 1+ | otherwise = 0+deriveBy dx (Param ix) = 0+deriveBy dx (Const val) = 0+deriveBy dx (Fun g t) =+ case deriveBy dx t of+ 0 -> 0+ 1 -> derivative g t+ t' -> derivative g t * t'+deriveBy dx (Pow t 0) = 0 +deriveBy dx (Pow t 1) = deriveBy dx t+deriveBy dx (Pow t k) = + case deriveBy dx t of+ 0 -> 0+ Const val -> Const (val * fromIntegral k) * (t ^. (k-1))+ t' -> fromIntegral k * (t ^. (k-1)) * t'+deriveBy dx (Add l r) = deriveBy dx l + deriveBy dx r+deriveBy dx (Sub l r) = deriveBy dx l - deriveBy dx r+deriveBy dx (Mul l r) = deriveBy dx l * r + l * deriveBy dx r+deriveBy dx (Div l r) = (deriveBy dx l * r - l * deriveBy dx r) / r ^. 2+deriveBy dx (Power l r) = l ** (r-1) * (r * deriveBy dx l + l * log l * deriveBy dx r)+deriveBy dx (LogBase l r) = deriveBy dx (log l / log r)+{-# INLINE deriveBy #-}++-- | Simplifies the `SRTree`.+simplify :: (Eq ix, Eq val, Floating val, OptIntPow val) => SRTree ix val -> SRTree ix val+simplify (Fun g t) = evalToConst . Fun g $ simplify t+simplify (Pow t 0) = 1 +simplify (Pow t 1) = simplify t+simplify (Pow t k) =+ case simplify t of+ Const c -> Const $ c ^. k+ t' -> Pow t' k+ +simplify (Add l r)+ | l' == r' = 2 * l' + | otherwise = l' + r' + where + l' = simplify l + r' = simplify r+simplify (Sub l r)+ | l' == r' = 0+ | otherwise = l' - r' + where + l' = simplify l + r' = simplify r+simplify (Mul l r)+ | l' == r' = Pow l' 2+ | otherwise = l' * r' + where + l' = simplify l + r' = simplify r+simplify (Div l r)+ | l' == r' = 1+ | otherwise = l' / r' + where + l' = simplify l + r' = simplify r++simplify (Power l r) = simplify l ** simplify r+simplify (LogBase l r) = logBase (simplify l) (simplify r)+simplify t = t+{-# INLINE simplify #-}++-- | Derivative of a Function+derivative :: (Eq ix, Eq val, Floating val) => Function -> SRTree ix val -> SRTree ix val+derivative Id = const 1+derivative Abs = \x -> x / abs x+derivative Sin = cos+derivative Cos = negate.sin+derivative Tan = recip . (**2.0) . cos+derivative Sinh = cosh+derivative Cosh = sinh+derivative Tanh = (1-) . (**2.0) . tanh+derivative ASin = recip . sqrt . (1-) . (^2)+derivative ACos = negate . recip . sqrt . (1-) . (^2)+derivative ATan = recip . (1+) . (^2)+derivative ASinh = recip . sqrt . (1+) . (^2)+derivative ACosh = \x -> 1 / (sqrt (x-1) * sqrt (x+1))+derivative ATanh = recip . (1-) . (^2)+derivative Sqrt = recip . (2*) . sqrt+derivative Cbrt = recip . (3*) . cbrt . (^2)+derivative Square = (2*)+derivative Exp = exp+derivative Log = recip+{-# INLINE derivative #-}++-- | Evaluates a function.+evalFun :: Floating val => Function -> val -> val+evalFun Id = id+evalFun Abs = abs+evalFun Sin = sin+evalFun Cos = cos+evalFun Tan = tan+evalFun Sinh = sinh+evalFun Cosh = cosh+evalFun Tanh = tanh+evalFun ASin = asin+evalFun ACos = acos+evalFun ATan = atan+evalFun ASinh = asinh+evalFun ACosh = acosh+evalFun ATanh = atanh+evalFun Sqrt = sqrt+evalFun Cbrt = cbrt+evalFun Square = (^2)+evalFun Exp = exp+evalFun Log = log+{-# INLINE evalFun #-}++cbrt :: Floating val => val -> val+cbrt x = signum x * abs x ** (1/3)+{-# INLINE cbrt #-}++-- | Returns the inverse of a function. This is a partial function.+inverseFunc :: Function -> Function+inverseFunc Id = Id+inverseFunc Sin = ASin+inverseFunc Cos = ACos+inverseFunc Tan = ATan+inverseFunc Tanh = ATanh+inverseFunc ASin = Sin+inverseFunc ACos = Cos+inverseFunc ATan = Tan+inverseFunc ATanh = Tanh+inverseFunc Sqrt = Square+inverseFunc Square = Sqrt+inverseFunc Log = Exp+inverseFunc Exp = Log+inverseFunc x = error $ show x ++ " has no support for inverse function"+{-# INLINE inverseFunc #-}++-- | Evaluates a tree with the variables stored in a `Reader` monad.+evalTree :: (Floating val, OptIntPow val) => SRTree ix val -> Reader (ix -> Maybe val) (Maybe val)+evalTree Empty = pure Nothing+evalTree (Const c) = pure $ Just c+evalTree (Var ix) = askAbout ix+evalTree (Param ix) = pure $ Just 1.0 -- TODO: askAbout paramIx+evalTree (Fun f t) = evalFun f <$$> evalTree t+evalTree (Pow t k) = (^. k) <$$> evalTree t+evalTree (Add l r) = (+) <$*> evalTree l <*> evalTree r+evalTree (Sub l r) = (-) <$*> evalTree l <*> evalTree r+evalTree (Mul l r) = (*) <$*> evalTree l <*> evalTree r+evalTree (Div l r) = (/) <$*> evalTree l <*> evalTree r+evalTree (Power l r) = (**) <$*> evalTree l <*> evalTree r+evalTree (LogBase l r) = logBase <$*> evalTree l <*> evalTree r++-- | Evaluates a tree with the variables stored in a `Reader` monad while mapping the constant +-- values to a different type.+evalTreeMap :: (Floating v1, OptIntPow v1, Floating v2, OptIntPow v2) => (v1 -> v2) -> SRTree ix v1 -> Reader (ix -> Maybe v2) (Maybe v2)+evalTreeMap f Empty = pure Nothing+evalTreeMap f (Const c) = pure $ Just $ f c+evalTreeMap f (Var ix) = askAbout ix+evalTreeMap f (Param ix) = pure $ Just $ f 1.0 -- TODO: askAbout paramIx+evalTreeMap f (Fun g t) = evalFun g <$$> evalTreeMap f t+evalTreeMap f (Pow t k) = (^. k) <$$> evalTreeMap f t+evalTreeMap f (Add l r) = (+) <$*> evalTreeMap f l <*> evalTreeMap f r+evalTreeMap f (Sub l r) = (-) <$*> evalTreeMap f l <*> evalTreeMap f r+evalTreeMap f (Mul l r) = (*) <$*> evalTreeMap f l <*> evalTreeMap f r+evalTreeMap f (Div l r) = (/) <$*> evalTreeMap f l <*> evalTreeMap f r+evalTreeMap f (Power l r) = (**) <$*> evalTreeMap f l <*> evalTreeMap f r+evalTreeMap f (LogBase l r) = logBase <$*> evalTreeMap f l <*> evalTreeMap f r++-- lift functions inside nested applicatives.+(<$$>) :: (Applicative f, Applicative g) => (a -> b) -> f (g a) -> f (g b)+(<$$>) = fmap . fmap+{-# INLINE (<$$>) #-}+(<$*>) :: (Applicative f, Applicative g) => (a -> b -> c) -> f (g a) -> f (g b -> g c)+op <$*> m = liftA2 op <$> m+{-# INLINE (<$*>) #-}++-- applies the argument `x` in the function carried by the `Reader` monad.+askAbout :: x -> Reader (x -> a) a+askAbout x = asks ($ x)+{-# INLINE askAbout #-}++-- | Example of using `evalTree` with a Map.+evalTreeWithMap :: (Ord ix, Floating val, OptIntPow val) => SRTree ix val -> Map ix val -> Maybe val+evalTreeWithMap t m = runReader (evalTree t) (m !?)+{-# INLINE evalTreeWithMap #-}++-- | Example of using `evalTree` with a Vector.+evalTreeWithVector :: (Floating val, OptIntPow val) => SRTree Int val -> V.Vector val -> Maybe val+evalTreeWithVector t v = runReader (evalTree t) (v V.!?)+{-# INLINE evalTreeWithVector #-}++-- | Relabel occurences of a var into a tuple (ix, Int).+relabelOccurrences :: forall ix val . Ord ix => SRTree ix val -> SRTree (ix, Int) val+relabelOccurrences t = traverseIx updVar t `evalState` M.empty + where+ updVar :: ix -> State (Map ix Int) (ix, Int)+ updVar ix = do+ s <- get+ case s !? ix of+ Nothing -> do put $ insert ix 0 s+ pure (ix, 0)+ Just c -> do put $ insert ix (c+1) s+ pure (ix, c+1)++-- | Relabel the parameters sequentially starting from 0+relabelParams :: Num ix => SRTree ix val -> SRTree ix val+relabelParams t = (toState t) `evalState` 0+ where+ toState :: Num ix => SRTree ix val -> State ix (SRTree ix val)+ toState (Param x) = do n <- get; put (n+1); pure (Param n)+ toState (Add l r) = do l' <- toState l; r' <- toState r; pure (Add l' r')+ toState (Sub l r) = do l' <- toState l; r' <- toState r; pure (Sub l' r')+ toState (Mul l r) = do l' <- toState l; r' <- toState r; pure (Mul l' r')+ toState (Div l r) = do l' <- toState l; r' <- toState r; pure (Div l' r')+ toState (Power l r) = do l' <- toState l; r' <- toState r; pure (Power l' r')+ toState (LogBase l r) = do l' <- toState l; r' <- toState r; pure (LogBase l' r')+ toState (Fun f n) = do n' <- toState n; pure (Fun f n')+ toState (Pow n i) = do n' <- toState n; pure (Pow n' i)+ toState n = pure n
+ src/Data/SRTree/Print.hs view
@@ -0,0 +1,210 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.SRTree.Print +-- Copyright : (c) Fabricio Olivetti 2021 - 2021+-- License : BSD3+-- Maintainer : fabricio.olivetti@gmail.com+-- Stability : experimental+-- Portability : +--+-- Conversion functions to display the expression trees in different formats.+--+-----------------------------------------------------------------------------+module Data.SRTree.Print + ( DisplayNodes(..)+ , showExpr+ , showTree+ , printExpr+ , showDefault+ , showTikz+ , showPython+ , showLatex+ )+ where++import Control.Monad.Reader ( asks, runReader, Reader )+import Data.Char ( toLower )++import Data.SRTree.Internal++-- | Data structure containing the needed definitions to print a SRTree.+data DisplayNodes ix val = D+ { _displayVar :: ix -> String+ , _displayPar :: ix -> String+ , _displayVal :: val -> String+ , _displayFun :: Function -> String+ , _displayPow :: String+ , _displayFloatPow :: String+ }++-- Auxiliary function to print a tree as an infix expression+asExpr :: (Show ix, Show val) => SRTree ix val -> Reader (DisplayNodes ix val) String+asExpr Empty = pure ""+asExpr (Var ix) = do+ display <- asks _displayVar+ pure $ display ix+asExpr (Param ix) = do+ display <- asks _displayPar+ pure $ display ix+asExpr (Const val) = do+ display <- asks _displayVal+ pure $ display val +asExpr (Fun f t) = do+ display <- asks _displayFun+ st <- asExpr t+ pure $ mconcat [display f, "(", st, ")"]+asExpr (Pow t ix) = do+ st <- asExpr t+ pow <- asks _displayPow+ pure $ mconcat ["(", st, ")", pow, "(", show ix, ")"]+asExpr (Add l r) = do+ sl <- asExpr l+ sr <- asExpr r+ pure $ mconcat ["(", sl, ") + (", sr, ")"]+asExpr (Sub l r) = do+ sl <- asExpr l+ sr <- asExpr r+ pure $ mconcat ["(", sl, ") - (", sr, ")"]+asExpr (Mul l r) = do+ sl <- asExpr l+ sr <- asExpr r+ pure $ mconcat ["(", sl, ") * (", sr, ")"]+asExpr (Div l r) = do+ sl <- asExpr l+ sr <- asExpr r+ pure $ mconcat ["(", sl, ") / (", sr, ")"]+asExpr (Power l r) = do+ sl <- asExpr l+ sr <- asExpr r+ pow <- asks _displayFloatPow+ pure $ mconcat ["(", sl, ")", pow, "(", sr, ")"]+asExpr (LogBase l r) = do+ sl <- asExpr l+ sr <- asExpr r+ pure $ mconcat ["log(", sl, ",", sr, ")"]++-- Auxiliary function to print a tree as a tree-like structure+asTree :: (Show ix, Show val) => SRTree ix val -> Reader (DisplayNodes ix val) String+asTree Empty = pure ""+asTree (Var ix) = do+ display <- asks _displayVar+ pure $ mconcat ["[", display ix, "]\n"]+asTree (Param ix) = do+ display <- asks _displayPar+ pure $ mconcat ["[", display ix, "]\n"]+asTree (Const val) = do+ display <- asks _displayVal+ pure $ mconcat ["[", display val, "]\n"]+asTree (Fun f t) = do+ display <- asks _displayFun+ st <- asTree t+ pure $ mconcat ["[", display f, "\n", st, "]\n"]+asTree (Pow t ix) = do+ st <- asTree t+ pow <- asks _displayPow+ pure $ mconcat ["[", pow, "\n", st, "[", show ix, "]\n]"] +asTree (Add l r) = do+ sl <- asTree l+ sr <- asTree r+ pure $ mconcat ["[+\n", sl, sr, "]\n"]+asTree (Sub l r) = do+ sl <- asTree l+ sr <- asTree r+ pure $ mconcat ["[-\n", sl, sr, "]\n"]+asTree (Mul l r) = do+ sl <- asTree l+ sr <- asTree r+ pure $ mconcat ["[×\n", sl, sr, "]\n"]+asTree (Div l r) = do+ sl <- asTree l+ sr <- asTree r+ pure $ mconcat ["[÷\n", sl, sr, "]\n"]+asTree (Power l r) = do+ sl <- asTree l+ sr <- asTree r+ pow <- asks _displayFloatPow+ pure $ mconcat ["[", pow, "\n", sl, sr, "]\n"]+asTree (LogBase l r) = do+ sl <- asTree l+ sr <- asTree r+ pure $ mconcat ["[log\n", sl, sr, "]\n"]++-- | Converts a tree to a `String` using the specifications given by `DisplayNodes`+showExpr, showTree :: (Show ix, Show val) => SRTree ix val -> DisplayNodes ix val -> String+showExpr t = runReader (asExpr t)+{-# INLINE showExpr #-}+showTree t = runReader (asTree t)+{-# INLINE showTree #-}++-- | Prints a tree as an expression using the specifications given by `DisplayNodes`+printExpr :: (Show ix, Show val) => SRTree ix val -> DisplayNodes ix val -> IO ()+printExpr t = putStrLn . showExpr t++-- | Displays a tree as an expression+showDefault t = showExpr t d+ where+ d = D (\ix -> mconcat ["x", show ix])+ (\ix -> mconcat ["t", show ix])+ show+ show+ "^"+ "**"++-- | Displays a tree in Tikz format+showTikz :: (Show ix, Show val, RealFrac val) => SRTree ix val -> String +showTikz t = showTree t d+ where+ d = D (\ix -> mconcat ["$x_{", show ix, "}$"])+ (\ix -> mconcat ["$\\theta_{", show ix, "}$"])+ (\val -> mconcat ["$", show $ (/100) $ fromIntegral $ round $ val*100, "$"])+ show+ "\\^{}"+ "**"++-- | Displays a tree as a numpy compatible expression.+showPython t = showExpr t d+ where+ d = D (\ix -> mconcat ["x[:,", show ix, "]"])+ (\ix -> mconcat ["t[", show ix, "]"])+ show+ pyFun+ "**"+ "**"+ + pyFun Id = ""+ pyFun Abs = "np.abs"+ pyFun Sin = "np.sin"+ pyFun Cos = "np.cos"+ pyFun Tan = "np.tan"+ pyFun Sinh = "np.sinh"+ pyFun Cosh = "np.cosh"+ pyFun Tanh = "np.tanh"+ pyFun ASin = "np.asin"+ pyFun ACos = "np.acos"+ pyFun ATan = "np.atan"+ pyFun ASinh = "np.asinh"+ pyFun ACosh = "np.acosh"+ pyFun ATanh = "np.atanh"+ pyFun Sqrt = "np.sqrt"+ pyFun Square = "np.square"+ pyFun Log = "np.log"+ pyFun Exp = "np.exp"++-- | Displays a tree as a sympy compatible expression.+showLatex :: (Show ix, Show val) => SRTree ix val -> String+showLatex Empty = ""+showLatex (Var ix) = mconcat ["x_{", show ix, "}"]+showLatex (Param ix) = mconcat ["\\theta_{", show ix, "}"]+showLatex (Const val) = show val+showLatex (Fun Abs t) = mconcat ["\\left |", showLatex t, "\\right |"]+showLatex (Fun f t) = mconcat [showLatexFun f, "\\left(", showLatex t, "\\right)"]+showLatex (Pow t ix) = mconcat ["\\left(", showLatex t, "\\right)^{", show ix, "}"]+showLatex (Add l r) = mconcat ["\\left(", showLatex l, "\\right) + \\left(", showLatex r, "\\right)"]+showLatex (Sub l r) = mconcat ["\\left(", showLatex l, "\\right) - \\left(", showLatex r, "\\right)"]+showLatex (Mul l r) = mconcat ["\\left(", showLatex l, "\\right) \\left(", showLatex r, "\\right)"]+showLatex (Div l r) = mconcat ["\\frac{", showLatex l, "}{", showLatex r, "}"]+showLatex (Power l r) = mconcat ["\\left(", showLatex l, "\\right)^{", showLatex r, "}"]+showLatex (LogBase l r) = mconcat ["\\log_{", showLatex r, "}{", showLatex l, "}"]++showLatexFun :: Function -> String+showLatexFun f = mconcat ["\\operatorname{", map toLower $ show f, "}"]
+ src/Data/SRTree/Random.hs view
@@ -0,0 +1,182 @@+{-# language ConstraintKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.SRTree.Random +-- Copyright : (c) Fabricio Olivetti 2021 - 2021+-- License : BSD3+-- Maintainer : fabricio.olivetti@gmail.com+-- Stability : experimental+-- Portability : ConstraintKinds+--+-- Functions to generate random trees and nodes.+--+-----------------------------------------------------------------------------+module Data.SRTree.Random + ( HasVars+ , HasVals+ , HasFuns+ , HasEverything+ , FullParams(..)+ , RndTree+ , randomVar+ , randomConst+ , randomPow+ , randomFunction+ , randomNode+ , randomNonTerminal+ , randomTree+ , randomTreeBalanced+ )+ where++import System.Random +import Control.Monad.State +import Control.Monad.Reader +import Data.Maybe (fromJust)++import Data.SRTree.Internal++-- * Class definition of properties that a certain parameter type has.+--+-- HasVars: does `p` provides a list of the variable indices?+-- HasVals: does `p` provides a range of values for the constants?+-- HasExps: does `p` provides a range for the integral exponentes?+-- HasFuns: does `p` provides a list of allowed functions?+class HasVars p where+ _vars :: p ix val -> [ix]+class HasVals p where+ _range :: p ix val -> (val, val)+class HasExps p where+ _exponents :: p ix val -> (Int, Int)+class HasFuns p where+ _funs :: p ix val -> [Function]++-- | Constraint synonym for all properties.+type HasEverything p = (HasVars p, HasVals p, HasExps p, HasFuns p)++-- | A structure with every property+data FullParams ix val = P [ix] (val, val) (Int, Int) [Function]++instance HasVars FullParams where+ _vars (P ixs _ _ _) = ixs+instance HasVals FullParams where+ _range (P _ r _ _) = r+instance HasExps FullParams where+ _exponents (P _ _ e _) = e+instance HasFuns FullParams where+ _funs (P _ _ _ fs) = fs++-- auxiliary function to sample between False and True+toss :: StateT StdGen IO Bool+toss = state random+{-# INLINE toss #-}++-- returns a random element of a list+randomFrom :: [a] -> StateT StdGen IO a+randomFrom funs = do n <- randomRange (0, length funs - 1)+ pure $ funs !! n+{-# INLINE randomFrom #-}++-- returns a random element within a range+randomRange :: (Ord val, Random val) => (val, val) -> StateT StdGen IO val+randomRange rng = state (randomR rng)+{-# INLINE randomRange #-}++-- Replace the child of a unary tree.+replaceChild :: SRTree ix val -> SRTree ix val -> Maybe (SRTree ix val)+replaceChild (Fun g _) t = Just $ Fun g t+replaceChild (Pow _ k) t = Just $ Pow t k+replaceChild _ _ = Nothing +{-# INLINE replaceChild #-}++-- Replace the children of a binary tree.+replaceChildren :: SRTree ix val -> SRTree ix val -> SRTree ix val -> Maybe (SRTree ix val)+replaceChildren (Add _ _) l r = Just $ Add l r+replaceChildren (Sub _ _) l r = Just $ Sub l r+replaceChildren (Mul _ _) l r = Just $ Mul l r+replaceChildren (Div _ _) l r = Just $ Div l r+replaceChildren (Power _ _) l r = Just $ Power l r+replaceChildren (LogBase _ _) l r = Just $ LogBase l r+replaceChildren _ _ _ = Nothing+{-# INLINE replaceChildren #-}++-- | RndTree is a Monad Transformer to generate random trees of type `SRTree ix val` +-- given the parameters `p ix val` using the random number generator `StdGen`.+type RndTree p ix val = ReaderT (p ix val) (StateT StdGen IO) (SRTree ix val)++-- | Returns a random variable, the parameter `p` must have the `HasVars` property+randomVar :: HasVars p => RndTree p ix val+randomVar = do vars <- asks _vars+ lift $ Var <$> randomFrom vars++-- | Returns a random constant, the parameter `p` must have the `HasConst` property+randomConst :: (Ord val, Random val, HasVals p) => RndTree p ix val+randomConst = do rng <- asks _range+ lift $ Const <$> randomRange rng++-- | Returns a random integer power node, the parameter `p` must have the `HasExps` property+randomPow :: (Ord val, Random val, HasExps p) => RndTree p ix val+randomPow = do rng <- asks _exponents+ lift $ Pow Empty <$> randomRange rng++-- | Returns a random function, the parameter `p` must have the `HasFuns` property+randomFunction :: HasFuns p => RndTree p ix val+randomFunction = do funs <- asks _funs+ lift $ (`Fun` Empty) <$> randomFrom funs++-- | Returns a random node, the parameter `p` must have every property.+randomNode :: (Ord val, Random val, HasEverything p) => RndTree p ix val+randomNode = do+ choice <- lift $ randomRange (0, 9 :: Int)+ case choice of+ 0 -> randomVar+ 1 -> randomConst+ 2 -> randomFunction+ 3 -> randomPow+ 4 -> pure $ Add Empty Empty+ 5 -> pure $ Sub Empty Empty+ 6 -> pure $ Mul Empty Empty+ 7 -> pure $ Div Empty Empty+ 8 -> pure $ Power Empty Empty+ 9 -> pure $ LogBase Empty Empty++-- | Returns a random non-terminal node, the parameter `p` must have every property.+randomNonTerminal :: (Ord val, Random val, HasEverything p) => RndTree p ix val+randomNonTerminal = do+ choice <- lift $ randomRange (0, 7 :: Int)+ case choice of+ 0 -> randomFunction+ 1 -> randomPow+ 2 -> pure $ Add Empty Empty+ 3 -> pure $ Sub Empty Empty+ 4 -> pure $ Mul Empty Empty+ 5 -> pure $ Div Empty Empty+ 6 -> pure $ Power Empty Empty+ 7 -> pure $ LogBase Empty Empty+ +-- | Returns a random tree with a limited budget, the parameter `p` must have every property.+randomTree :: (Ord val, Random val, HasEverything p) => Int -> RndTree p ix val+randomTree 0 = do+ coin <- lift toss+ if coin+ then randomVar+ else randomConst+randomTree budget = do + node <- randomNode+ fromJust <$> case arity node of+ 0 -> pure $ Just node+ 1 -> replaceChild node <$> randomTree (budget - 1)+ 2 -> replaceChildren node <$> randomTree (budget `div` 2) <*> randomTree (budget `div` 2)+ +-- | Returns a random tree with a approximately a number `n` of nodes, the parameter `p` must have every property.+randomTreeBalanced :: (Ord val, Random val, HasEverything p) => Int -> RndTree p ix val+randomTreeBalanced n | n <= 1 = do+ coin <- lift toss+ if coin+ then randomVar+ else randomConst+randomTreeBalanced n = do + node <- randomNonTerminal+ fromJust <$> case arity node of+ 1 -> replaceChild node <$> randomTreeBalanced (n - 1)+ 2 -> replaceChildren node <$> randomTreeBalanced (n `div` 2) <*> randomTreeBalanced (n `div` 2)
+ srtree.cabal view
@@ -0,0 +1,62 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.1.+--+-- see: https://github.com/sol/hpack++name: srtree+version: 0.1.0.0+synopsis: A general framework to work with Symbolic Regression expression trees.+description: Please see the README on GitHub at <https://github.com/folivetti/srtree#readme>+category: Math, Data, Data Structures+homepage: https://github.com/folivetti/srtree#readme+bug-reports: https://github.com/folivetti/srtree/issues+author: Fabricio Olivetti de França+maintainer: fabricio.olivetti@gmail.com+copyright: 2023 Fabricio Olivetti de França+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/folivetti/srtree++library+ exposed-modules:+ Data.SRTree+ Data.SRTree.Internal+ Data.SRTree.Print+ Data.SRTree.Random+ other-modules:+ Paths_srtree+ hs-source-dirs:+ src+ ghc-options: -O2+ build-depends:+ base ==4.15.*+ , containers ==0.6.*+ , mtl ==2.2.*+ , random ==1.2.*+ , vector ==0.12.*+ default-language: Haskell2010++test-suite srtree-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_srtree+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base ==4.15.*+ , containers ==0.6.*+ , mtl ==2.2.*+ , random ==1.2.*+ , srtree+ , vector ==0.12.*+ default-language: Haskell2010
+ test/Spec.hs view
@@ -0,0 +1,17 @@+import Data.SRTree+import Data.SRTree.Random+import Data.SRTree.Print++import System.Random+import Control.Monad.State+import Control.Monad.Reader++runThing g n = flip evalStateT g . runReaderT (randomTree n)++main :: IO ()+main = do+ g <- getStdGen+ t <- runThing g 10 $ P [0,1] (-1.0, 1.0) (-3, 3) [Id, Sin]+ print (t :: SRTree Int Double)+ putStrLn $ showDefault t+ putStrLn $ showTikz t