{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK show-extensions #-}

-- | Module    :  Debug.SimpleExpr.Expr
-- Copyright   :  (C) 2023 Alexey Tochin
-- License     :  BSD3 (see the file LICENSE)
-- Maintainer  :  Alexey Tochin <Alexey.Tochin@gmail.com>
--
-- Simple expressions base types and manipulations.
module Debug.SimpleExpr.Expr
  ( -- * Expression manipulation
    number,
    variable,
    unaryFunc,
    binaryFunc,
    simplify,
    simplifyStep,

    -- * Base types
    SimpleExprF (NumberF, VariableF, BinaryFuncF, SymbolicFuncF),
    SimpleExpr,
    Expr,

    -- * Auxiliary functions
    ListOf,
    content,
    dependencies,
    showWithBrackets,
  )
where

import Control.Monad.Fix (fix)
import Data.Fix (Fix (Fix, unFix))
import Data.Functor.Classes (Eq1, liftEq)
import Data.List (intercalate, (++))
import NumHask (Additive, Distributive, Divisive, ExpField, Field, Multiplicative, Subtractive, TrigField, one, zero)
import qualified NumHask as NH
import Prelude
  ( Bool (False),
    Eq,
    Functor,
    Integer,
    Num,
    Show,
    String,
    fmap,
    seq,
    show,
    ($),
    (&&),
    (.),
    (<>),
    (==),
  )
import qualified Prelude as P

-- | Expression F-algebra functional.
data SimpleExprF a
  = NumberF Integer
  | VariableF String
  | BinaryFuncF String a a
  | SymbolicFuncF String [a]
  deriving (a -> SimpleExprF b -> SimpleExprF a
(a -> b) -> SimpleExprF a -> SimpleExprF b
(forall a b. (a -> b) -> SimpleExprF a -> SimpleExprF b)
-> (forall a b. a -> SimpleExprF b -> SimpleExprF a)
-> Functor SimpleExprF
forall a b. a -> SimpleExprF b -> SimpleExprF a
forall a b. (a -> b) -> SimpleExprF a -> SimpleExprF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SimpleExprF b -> SimpleExprF a
$c<$ :: forall a b. a -> SimpleExprF b -> SimpleExprF a
fmap :: (a -> b) -> SimpleExprF a -> SimpleExprF b
$cfmap :: forall a b. (a -> b) -> SimpleExprF a -> SimpleExprF b
Functor, SimpleExprF a -> SimpleExprF a -> Bool
(SimpleExprF a -> SimpleExprF a -> Bool)
-> (SimpleExprF a -> SimpleExprF a -> Bool) -> Eq (SimpleExprF a)
forall a. Eq a => SimpleExprF a -> SimpleExprF a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleExprF a -> SimpleExprF a -> Bool
$c/= :: forall a. Eq a => SimpleExprF a -> SimpleExprF a -> Bool
== :: SimpleExprF a -> SimpleExprF a -> Bool
$c== :: forall a. Eq a => SimpleExprF a -> SimpleExprF a -> Bool
Eq)

instance Eq1 SimpleExprF where
  liftEq :: (a -> b -> Bool) -> SimpleExprF a -> SimpleExprF b -> Bool
  liftEq :: (a -> b -> Bool) -> SimpleExprF a -> SimpleExprF b -> Bool
liftEq a -> b -> Bool
eq SimpleExprF a
e1 SimpleExprF b
e2 = case (SimpleExprF a
e1, SimpleExprF b
e2) of
    (NumberF Integer
n1, NumberF Integer
n2) -> Integer
n1 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
n2
    (VariableF String
v1, VariableF String
v2) -> String
v1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
v2
    (BinaryFuncF String
name1 a
x1 a
y1, BinaryFuncF String
name2 b
x2 b
y2) -> (String
name1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name2) Bool -> Bool -> Bool
&& a -> b -> Bool
eq a
x1 b
x2 Bool -> Bool -> Bool
&& a -> b -> Bool
eq a
y1 b
y2
    (SymbolicFuncF String
name1 [a]
args1, SymbolicFuncF String
name2 [b]
args2) -> (String
name1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name2) Bool -> Bool -> Bool
&& (a -> b -> Bool) -> [a] -> [b] -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
eq [a]
args1 [b]
args2
    (SimpleExprF a, SimpleExprF b)
_ -> Bool
False

instance NH.FromIntegral (SimpleExprF a) Integer where
  fromIntegral :: Integer -> SimpleExprF a
fromIntegral = Integer -> SimpleExprF a
forall a. Integer -> SimpleExprF a
NumberF

-- | Simple expression type, see
-- [tutorial](Debug.SimpleExpr.Tutorial.hs)
type SimpleExpr = Fix SimpleExprF

-- | Initializes a single integer number expression.
--
-- ==== __Examples of usage__
--
-- >>> a = number 42
-- >>> a
-- 42
-- >>> :t a
-- a :: SimpleExpr
number :: Integer -> SimpleExpr
number :: Integer -> SimpleExpr
number Integer
n = SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Integer -> SimpleExprF SimpleExpr
forall a. Integer -> SimpleExprF a
NumberF Integer
n)

-- | Initializes a single symbolic variable expression.
--
-- ==== __Examples of usage__
--
-- >>> x = variable "x"
-- >>> x
-- x
-- >>> :t x
-- x :: SimpleExpr
variable :: String -> SimpleExpr
variable :: String -> SimpleExpr
variable String
name = SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (String -> SimpleExprF SimpleExpr
forall a. String -> SimpleExprF a
VariableF String
name)

-- | Returns the list of head dependencies of an expression.
--
-- ==== __Examples of usage__
--
-- >>> import Prelude (($), id)
-- >>> import NumHask ((+), (*))
--
-- >>> dependencies (variable "x" + (variable "y" * variable "z"))
-- [x,y·z]
dependencies :: SimpleExpr -> [SimpleExpr]
dependencies :: SimpleExpr -> [SimpleExpr]
dependencies (Fix SimpleExprF SimpleExpr
e) = case SimpleExprF SimpleExpr
e of
  NumberF Integer
_ -> []
  VariableF String
_ -> []
  BinaryFuncF String
_ SimpleExpr
leftArg SimpleExpr
rightArg -> [SimpleExpr
leftArg, SimpleExpr
rightArg]
  SymbolicFuncF String
_ [SimpleExpr]
args -> [SimpleExpr]
args

instance NH.FromIntegral (Fix SimpleExprF) Integer where
  fromIntegral :: Integer -> SimpleExpr
fromIntegral = SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SimpleExprF SimpleExpr -> SimpleExpr)
-> (Integer -> SimpleExprF SimpleExpr) -> Integer -> SimpleExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> SimpleExprF SimpleExpr
forall a. Integer -> SimpleExprF a
NumberF

-- | Entity that is representable as a list of in general other entities.
-- In particular, @X@ is a list of single @[X]@, see the example below.
--
-- ==== __Examples of usage__
--
-- >>> data Atom = Atom String deriving Show
-- >>> type Particle = ListOf Atom
--
-- >>> content (Atom "He") :: [Atom]
-- [Atom "He"]
--
-- >>> content (Atom "H", Atom "H") :: [Atom]
-- [Atom "H",Atom "H"]
--
-- >>> content [Atom "H", Atom "O", Atom "H"] :: [Atom]
-- [Atom "H",Atom "O",Atom "H"]
class ListOf inner outer where
  -- | Returns a list of entities the argument consists of.
  content :: outer -> [inner]

instance ListOf inner () where
  content :: () -> [inner]
content = [inner] -> () -> [inner]
forall a b. a -> b -> a
P.const []

instance ListOf inner inner where
  content :: inner -> [inner]
content inner
e = [inner
e]

instance (ListOf inner outer1, ListOf inner outer2) => ListOf inner (outer1, outer2) where
  content :: (outer1, outer2) -> [inner]
content (outer1
x1, outer2
x2) = outer1 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer1
x1 [inner] -> [inner] -> [inner]
forall a. [a] -> [a] -> [a]
++ outer2 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer2
x2

instance (ListOf inner outer1, ListOf inner outer2, ListOf inner outer3) => ListOf inner (outer1, outer2, outer3) where
  content :: (outer1, outer2, outer3) -> [inner]
content (outer1
x1, outer2
x2, outer3
x3) = outer1 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer1
x1 [inner] -> [inner] -> [inner]
forall a. [a] -> [a] -> [a]
++ outer2 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer2
x2 [inner] -> [inner] -> [inner]
forall a. [a] -> [a] -> [a]
++ outer3 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer3
x3

instance
  (ListOf inner outer1, ListOf inner outer2, ListOf inner outer3, ListOf inner outer4) =>
  ListOf inner (outer1, outer2, outer3, outer4)
  where
  content :: (outer1, outer2, outer3, outer4) -> [inner]
content (outer1
x1, outer2
x2, outer3
x3, outer4
x4) = outer1 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer1
x1 [inner] -> [inner] -> [inner]
forall a. [a] -> [a] -> [a]
++ outer2 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer2
x2 [inner] -> [inner] -> [inner]
forall a. [a] -> [a] -> [a]
++ outer3 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer3
x3 [inner] -> [inner] -> [inner]
forall a. [a] -> [a] -> [a]
++ outer4 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer4
x4

instance
  (ListOf inner outer1, ListOf inner outer2, ListOf inner outer3, ListOf inner outer4, ListOf inner outer5) =>
  ListOf inner (outer1, outer2, outer3, outer4, outer5)
  where
  content :: (outer1, outer2, outer3, outer4, outer5) -> [inner]
content (outer1
x1, outer2
x2, outer3
x3, outer4
x4, outer5
x5) = outer1 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer1
x1 [inner] -> [inner] -> [inner]
forall a. [a] -> [a] -> [a]
++ outer2 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer2
x2 [inner] -> [inner] -> [inner]
forall a. [a] -> [a] -> [a]
++ outer3 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer3
x3 [inner] -> [inner] -> [inner]
forall a. [a] -> [a] -> [a]
++ outer4 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer4
x4 [inner] -> [inner] -> [inner]
forall a. [a] -> [a] -> [a]
++ outer5 -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content outer5
x5

instance (ListOf inner outer) => ListOf inner [outer] where
  content :: [outer] -> [inner]
content = (outer -> [inner]
forall inner outer. ListOf inner outer => outer -> [inner]
content (outer -> [inner]) -> [outer] -> [inner]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
P.=<<)

-- | Expression typeclass.
-- It includes `SimpleExpr` as well as list and tuples of `SimpleExpr` etc.
type Expr = ListOf SimpleExpr

---- | Expression typeclass.
-- class Eq a => Expr a where
--  -- | Returns all simple expressions given expression consists of.
--  --
--  -- ==== __Examples of usage__
--  --
--  -- >>> import NumHask ((+), (*))
--  --
--  -- >>> x = variable "x"
--  -- >>> y = variable "y"
--  -- >>> z = variable "z"
--  --
--  -- >>> innerSimpleExprs [x, y + z]
--  -- [x,y+z]
--  --
--  -- >>> innerSimpleExprs (x * (y + z))
--  -- [x·(y+z)]
--  innerSimpleExprs :: a -> [SimpleExpr]
--
-- instance Expr () where
--  innerSimpleExprs = P.const []
--
-- instance Expr SimpleExpr where
--  innerSimpleExprs e = [e]
--
-- instance Expr (SimpleExpr, SimpleExpr) where
--  innerSimpleExprs (e0, e1) = [e0, e1]
--
-- instance Expr (SimpleExpr, SimpleExpr, SimpleExpr) where
--  innerSimpleExprs (e0, e1, e2) = [e0, e1, e2]
--
-- instance Expr [SimpleExpr] where
--  innerSimpleExprs = P.id

instance {-# OVERLAPPING #-} Show SimpleExpr where
  show :: SimpleExpr -> String
show (Fix SimpleExprF SimpleExpr
e) = case SimpleExprF SimpleExpr
e of
    NumberF Integer
n -> Integer -> String
forall a. Show a => a -> String
show Integer
n
    VariableF String
name -> String
name
    BinaryFuncF String
name SimpleExpr
leftArg SimpleExpr
rightArg -> SimpleExpr -> String
showWithBrackets SimpleExpr
leftArg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SimpleExpr -> String
showWithBrackets SimpleExpr
rightArg
    SymbolicFuncF String
name [SimpleExpr]
args -> String
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((SimpleExpr -> String) -> [SimpleExpr] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SimpleExpr -> String
forall a. Show a => a -> String
show [SimpleExpr]
args) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"

-- | Shows expression adding brackets if it is needed for a context.
showWithBrackets :: SimpleExpr -> String
showWithBrackets :: SimpleExpr -> String
showWithBrackets SimpleExpr
e = case SimpleExpr
e of
  n :: SimpleExpr
n@(Fix NumberF {}) -> SimpleExpr -> String
forall a. Show a => a -> String
show SimpleExpr
n
  c :: SimpleExpr
c@(Fix VariableF {}) -> SimpleExpr -> String
forall a. Show a => a -> String
show SimpleExpr
c
  bf :: SimpleExpr
bf@(Fix BinaryFuncF {}) -> String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SimpleExpr -> String
forall a. Show a => a -> String
show SimpleExpr
bf String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  sf :: SimpleExpr
sf@(Fix SymbolicFuncF {}) -> SimpleExpr -> String
forall a. Show a => a -> String
show SimpleExpr
sf

-- | Inituialize unarry function
--
-- ==== __Examples of usage__
--
-- >>> x = variable "x"
-- >>> f = unaryFunc "f"
-- >>> f x
-- f(x)
-- >>> :t x
-- x :: SimpleExpr
-- >>> :t f
-- f :: SimpleExpr -> SimpleExpr
unaryFunc :: String -> SimpleExpr -> SimpleExpr
unaryFunc :: String -> SimpleExpr -> SimpleExpr
unaryFunc String
name SimpleExpr
x = SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (String -> [SimpleExpr] -> SimpleExprF SimpleExpr
forall a. String -> [a] -> SimpleExprF a
SymbolicFuncF String
name [SimpleExpr
x])

-- | Inituialize unarry function
--
-- ==== __Examples of usage__
--
-- >>> x = variable "x"
-- >>> y = variable "y"
-- >>> (-*-) = binaryFunc "-*-"
-- >>> x -*- y
-- x-*-y
-- >>> :t x
-- x :: SimpleExpr
-- >>> :t (-*-)
-- (-*-) :: SimpleExpr -> SimpleExpr -> SimpleExpr
-- >>> :t x-*-y
-- x-*-y :: SimpleExpr
binaryFunc :: String -> SimpleExpr -> SimpleExpr -> SimpleExpr
binaryFunc :: String -> SimpleExpr -> SimpleExpr -> SimpleExpr
binaryFunc String
name SimpleExpr
x SimpleExpr
y = SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (String -> SimpleExpr -> SimpleExpr -> SimpleExprF SimpleExpr
forall a. String -> a -> a -> SimpleExprF a
BinaryFuncF String
name SimpleExpr
x SimpleExpr
y)

instance Additive SimpleExpr where
  zero :: SimpleExpr
zero = Integer -> SimpleExpr
number Integer
0
  + :: SimpleExpr -> SimpleExpr -> SimpleExpr
(+) = String -> SimpleExpr -> SimpleExpr -> SimpleExpr
binaryFunc String
"+"

instance Subtractive SimpleExpr where
  negate :: SimpleExpr -> SimpleExpr
negate = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"-"
  (-) = String -> SimpleExpr -> SimpleExpr -> SimpleExpr
binaryFunc String
"-"

instance Multiplicative SimpleExpr where
  one :: SimpleExpr
one = Integer -> SimpleExpr
number Integer
1
  * :: SimpleExpr -> SimpleExpr -> SimpleExpr
(*) = String -> SimpleExpr -> SimpleExpr -> SimpleExpr
binaryFunc String
"·"

instance Distributive SimpleExpr

instance Divisive SimpleExpr where
  / :: SimpleExpr -> SimpleExpr -> SimpleExpr
(/) = String -> SimpleExpr -> SimpleExpr -> SimpleExpr
binaryFunc String
"/"

instance Field SimpleExpr

instance ExpField SimpleExpr where
  exp :: SimpleExpr -> SimpleExpr
exp = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"exp"
  log :: SimpleExpr -> SimpleExpr
log = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"log"
  ** :: SimpleExpr -> SimpleExpr -> SimpleExpr
(**) = String -> SimpleExpr -> SimpleExpr -> SimpleExpr
binaryFunc String
"^"
  sqrt :: SimpleExpr -> SimpleExpr
sqrt = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"sqrt"

instance TrigField SimpleExpr where
  pi :: SimpleExpr
pi = String -> SimpleExpr
variable String
"π"
  sin :: SimpleExpr -> SimpleExpr
sin = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"sin"
  cos :: SimpleExpr -> SimpleExpr
cos = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"cos"
  tan :: SimpleExpr -> SimpleExpr
tan = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"tg"
  asin :: SimpleExpr -> SimpleExpr
asin = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"arcsin"
  acos :: SimpleExpr -> SimpleExpr
acos = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"arccos"
  atan :: SimpleExpr -> SimpleExpr
atan = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"arctan"
  sinh :: SimpleExpr -> SimpleExpr
sinh = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"sh"
  cosh :: SimpleExpr -> SimpleExpr
cosh = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"ch"
  tanh :: SimpleExpr -> SimpleExpr
tanh = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"th"
  atan2 :: SimpleExpr -> SimpleExpr -> SimpleExpr
atan2 SimpleExpr
a SimpleExpr
b = SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (SimpleExprF SimpleExpr -> SimpleExpr)
-> SimpleExprF SimpleExpr -> SimpleExpr
forall a b. (a -> b) -> a -> b
$ String -> [SimpleExpr] -> SimpleExprF SimpleExpr
forall a. String -> [a] -> SimpleExprF a
SymbolicFuncF String
"atan2" [SimpleExpr
a, SimpleExpr
b]
  asinh :: SimpleExpr -> SimpleExpr
asinh = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"arcsh"
  acosh :: SimpleExpr -> SimpleExpr
acosh = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"arcch"
  atanh :: SimpleExpr -> SimpleExpr
atanh = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"arcth"

instance Num SimpleExpr where
  + :: SimpleExpr -> SimpleExpr -> SimpleExpr
(+) = SimpleExpr -> SimpleExpr -> SimpleExpr
forall a. Additive a => a -> a -> a
(NH.+)
  (-) = SimpleExpr -> SimpleExpr -> SimpleExpr
forall a. Subtractive a => a -> a -> a
(NH.-)
  * :: SimpleExpr -> SimpleExpr -> SimpleExpr
(*) = SimpleExpr -> SimpleExpr -> SimpleExpr
forall a. Multiplicative a => a -> a -> a
(NH.*)
  negate :: SimpleExpr -> SimpleExpr
negate = SimpleExpr -> SimpleExpr
forall a. Subtractive a => a -> a
NH.negate
  abs :: SimpleExpr -> SimpleExpr
abs = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"abs"
  signum :: SimpleExpr -> SimpleExpr
signum = String -> SimpleExpr -> SimpleExpr
unaryFunc String
"sign"
  fromInteger :: Integer -> SimpleExpr
fromInteger = Integer -> SimpleExpr
number

-- | Applies a function recursivelly until it has no effect.
-- Strict.
-- Unsafe due to possible inifinite recursion.
--
-- ==== __Examples of usage__
--
-- >>> import Prelude (Integer, div)
-- >>> iterateUntilEqual (`div` 2) (1000 :: Integer)
-- 0
iterateUntilEqual :: Eq x => (x -> x) -> x -> x
iterateUntilEqual :: (x -> x) -> x -> x
iterateUntilEqual x -> x
f x
x =
  let fx :: x
fx = x -> x
f x
x
   in if x
fx x -> x -> Bool
forall a. Eq a => a -> a -> Bool
== x
x
        then x
x
        else x -> x -> x
seq x
fx ((x -> x) -> x -> x
forall x. Eq x => (x -> x) -> x -> x
iterateUntilEqual x -> x
f x
fx)

-- | Minimalistic simplification step.
--
-- ==== __Examples of usage__
--
-- >>> import Prelude (($), id)
-- >>> import NumHask ((+), (*), (**))
--
-- >>> simplifyStep id (0 + (0 + (0 + 10)))
-- 0+(0+10)
--
-- >>> simplifyStep id (1 * (0 + (10 ** 1)))
-- 0+(10^1)
simplifyStep :: (SimpleExpr -> SimpleExpr) -> SimpleExpr -> SimpleExpr
simplifyStep :: (SimpleExpr -> SimpleExpr) -> SimpleExpr -> SimpleExpr
simplifyStep SimpleExpr -> SimpleExpr
f SimpleExpr
e = case SimpleExpr
e of
  n :: SimpleExpr
n@(Fix (NumberF Integer
_)) -> SimpleExpr
n
  c :: SimpleExpr
c@(Fix (VariableF String
_)) -> SimpleExpr
c
  Fix (BinaryFuncF String
name SimpleExpr
leftArg SimpleExpr
rightArg) -> case String
name of
    String
"+" -> case (SimpleExpr -> SimpleExprF SimpleExpr
forall (f :: * -> *). Fix f -> f (Fix f)
unFix SimpleExpr
leftArg, SimpleExpr -> SimpleExprF SimpleExpr
forall (f :: * -> *). Fix f -> f (Fix f)
unFix SimpleExpr
rightArg) of
      (NumberF Integer
0, SimpleExprF SimpleExpr
_) -> SimpleExpr -> SimpleExpr
f SimpleExpr
rightArg
      (SimpleExprF SimpleExpr
_, NumberF Integer
0) -> SimpleExpr -> SimpleExpr
f SimpleExpr
leftArg
      (NumberF Integer
n, NumberF Integer
m) -> SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Integer -> SimpleExprF SimpleExpr
forall a. Integer -> SimpleExprF a
NumberF (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
P.+ Integer
m))
      (SimpleExprF SimpleExpr, SimpleExprF SimpleExpr)
_ -> SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (String -> SimpleExpr -> SimpleExpr -> SimpleExprF SimpleExpr
forall a. String -> a -> a -> SimpleExprF a
BinaryFuncF String
"+" (SimpleExpr -> SimpleExpr
f SimpleExpr
leftArg) (SimpleExpr -> SimpleExpr
f SimpleExpr
rightArg))
    String
"-" -> case (SimpleExpr -> SimpleExprF SimpleExpr
forall (f :: * -> *). Fix f -> f (Fix f)
unFix SimpleExpr
leftArg, SimpleExpr -> SimpleExprF SimpleExpr
forall (f :: * -> *). Fix f -> f (Fix f)
unFix SimpleExpr
rightArg) of
      (NumberF Integer
0, SimpleExprF SimpleExpr
_) -> (SimpleExpr -> SimpleExpr) -> SimpleExpr -> SimpleExpr
forall a. Subtractive a => a -> a
NH.negate SimpleExpr -> SimpleExpr
f SimpleExpr
rightArg
      (SimpleExprF SimpleExpr
_, NumberF Integer
0) -> SimpleExpr -> SimpleExpr
f SimpleExpr
leftArg
      (NumberF Integer
n, NumberF Integer
m) -> SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Integer -> SimpleExprF SimpleExpr
forall a. Integer -> SimpleExprF a
NumberF (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
P.- Integer
m))
      (SimpleExprF SimpleExpr, SimpleExprF SimpleExpr)
_ ->
        if SimpleExpr
fX SimpleExpr -> SimpleExpr -> Bool
forall a. Eq a => a -> a -> Bool
== SimpleExpr
fY
          then SimpleExpr
forall a. Additive a => a
zero
          else SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (String -> SimpleExpr -> SimpleExpr -> SimpleExprF SimpleExpr
forall a. String -> a -> a -> SimpleExprF a
BinaryFuncF String
"-" SimpleExpr
fX SimpleExpr
fY)
        where
          fX :: SimpleExpr
fX = SimpleExpr -> SimpleExpr
f SimpleExpr
leftArg
          fY :: SimpleExpr
fY = SimpleExpr -> SimpleExpr
f SimpleExpr
rightArg
    String
"·" -> case (SimpleExpr -> SimpleExprF SimpleExpr
forall (f :: * -> *). Fix f -> f (Fix f)
unFix SimpleExpr
leftArg, SimpleExpr -> SimpleExprF SimpleExpr
forall (f :: * -> *). Fix f -> f (Fix f)
unFix SimpleExpr
rightArg) of
      (NumberF Integer
0, SimpleExprF SimpleExpr
_) -> SimpleExpr
forall a. Additive a => a
zero
      (SimpleExprF SimpleExpr
_, NumberF Integer
0) -> SimpleExpr
forall a. Additive a => a
zero
      (NumberF Integer
1, SimpleExprF SimpleExpr
_) -> SimpleExpr -> SimpleExpr
f SimpleExpr
rightArg
      (SimpleExprF SimpleExpr
_, NumberF Integer
1) -> SimpleExpr -> SimpleExpr
f SimpleExpr
leftArg
      (NumberF Integer
n, NumberF Integer
m) -> SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Integer -> SimpleExprF SimpleExpr
forall a. Integer -> SimpleExprF a
NumberF (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
P.* Integer
m))
      (SimpleExprF SimpleExpr, SimpleExprF SimpleExpr)
_ -> SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (String -> SimpleExpr -> SimpleExpr -> SimpleExprF SimpleExpr
forall a. String -> a -> a -> SimpleExprF a
BinaryFuncF String
"·" (SimpleExpr -> SimpleExpr
f SimpleExpr
leftArg) (SimpleExpr -> SimpleExpr
f SimpleExpr
rightArg))
    String
"^" -> case (SimpleExpr -> SimpleExprF SimpleExpr
forall (f :: * -> *). Fix f -> f (Fix f)
unFix SimpleExpr
leftArg, SimpleExpr -> SimpleExprF SimpleExpr
forall (f :: * -> *). Fix f -> f (Fix f)
unFix SimpleExpr
rightArg) of
      (NumberF Integer
n, NumberF Integer
m) -> SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Integer -> SimpleExprF SimpleExpr
forall a. Integer -> SimpleExprF a
NumberF (Integer
n Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
P.^ Integer
m))
      (NumberF Integer
0, SimpleExprF SimpleExpr
_) -> SimpleExpr
forall a. Additive a => a
zero
      (SimpleExprF SimpleExpr
_, NumberF Integer
0) -> SimpleExpr
forall a. Multiplicative a => a
one
      (NumberF Integer
1, SimpleExprF SimpleExpr
_) -> SimpleExpr
forall a. Multiplicative a => a
one
      (SimpleExprF SimpleExpr
_, NumberF Integer
1) -> SimpleExpr -> SimpleExpr
f SimpleExpr
leftArg
      (SimpleExprF SimpleExpr, SimpleExprF SimpleExpr)
_ -> SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (String -> SimpleExpr -> SimpleExpr -> SimpleExprF SimpleExpr
forall a. String -> a -> a -> SimpleExprF a
BinaryFuncF String
"^" (SimpleExpr -> SimpleExpr
f SimpleExpr
leftArg) (SimpleExpr -> SimpleExpr
f SimpleExpr
rightArg))
    String
_ -> SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (String -> SimpleExpr -> SimpleExpr -> SimpleExprF SimpleExpr
forall a. String -> a -> a -> SimpleExprF a
BinaryFuncF String
name (SimpleExpr -> SimpleExpr
f SimpleExpr
leftArg) (SimpleExpr -> SimpleExpr
f SimpleExpr
rightArg))
  Fix (SymbolicFuncF String
name [SimpleExpr]
args) -> SimpleExprF SimpleExpr -> SimpleExpr
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (String -> [SimpleExpr] -> SimpleExprF SimpleExpr
forall a. String -> [a] -> SimpleExprF a
SymbolicFuncF String
name ((SimpleExpr -> SimpleExpr) -> [SimpleExpr] -> [SimpleExpr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SimpleExpr -> SimpleExpr
f [SimpleExpr]
args))

-- | Simplify expression using some primitive rules like '0 * x -> 0' specified in 'simplifyStep' implementation.
--
-- ==== __Examples of usage__
--
-- >>> import Prelude (($))
-- >>> import Debug.SimpleExpr (variable, simplify)
-- >>> import NumHask ((+), (-), (*))
--
-- >>> x = variable "x"
-- >>> simplify $ (x + 0) * 1 - x * (3 - 2)
-- 0
simplify :: SimpleExpr -> SimpleExpr
simplify :: SimpleExpr -> SimpleExpr
simplify = ((SimpleExpr -> SimpleExpr) -> SimpleExpr -> SimpleExpr)
-> SimpleExpr -> SimpleExpr
forall a. (a -> a) -> a
fix (((SimpleExpr -> SimpleExpr) -> SimpleExpr -> SimpleExpr)
 -> SimpleExpr -> SimpleExpr)
-> ((SimpleExpr -> SimpleExpr) -> SimpleExpr -> SimpleExpr)
-> SimpleExpr
-> SimpleExpr
forall a b. (a -> b) -> a -> b
$ (SimpleExpr -> SimpleExpr) -> SimpleExpr -> SimpleExpr
forall x. Eq x => (x -> x) -> x -> x
iterateUntilEqual ((SimpleExpr -> SimpleExpr) -> SimpleExpr -> SimpleExpr)
-> ((SimpleExpr -> SimpleExpr) -> SimpleExpr -> SimpleExpr)
-> (SimpleExpr -> SimpleExpr)
-> SimpleExpr
-> SimpleExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SimpleExpr -> SimpleExpr) -> SimpleExpr -> SimpleExpr
simplifyStep -- simplify = iterateUntilEqual (simplifyStep simplify)