{-# LANGUAGE TemplateHaskell #-}
module Algorithms.Geometry.SoS.Expr where

import           Control.Lens
import qualified Data.List as List

--------------------------------------------------------------------------------

data Expr v r = Constant r
              | Negate (Expr v r)
              | Sum  [Expr v r]
              | Prod [Expr v r]
              | Var v
              deriving (Int -> Expr v r -> ShowS
[Expr v r] -> ShowS
Expr v r -> String
(Int -> Expr v r -> ShowS)
-> (Expr v r -> String) -> ([Expr v r] -> ShowS) -> Show (Expr v r)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall v r. (Show r, Show v) => Int -> Expr v r -> ShowS
forall v r. (Show r, Show v) => [Expr v r] -> ShowS
forall v r. (Show r, Show v) => Expr v r -> String
showList :: [Expr v r] -> ShowS
$cshowList :: forall v r. (Show r, Show v) => [Expr v r] -> ShowS
show :: Expr v r -> String
$cshow :: forall v r. (Show r, Show v) => Expr v r -> String
showsPrec :: Int -> Expr v r -> ShowS
$cshowsPrec :: forall v r. (Show r, Show v) => Int -> Expr v r -> ShowS
Show,Expr v r -> Expr v r -> Bool
(Expr v r -> Expr v r -> Bool)
-> (Expr v r -> Expr v r -> Bool) -> Eq (Expr v r)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall v r. (Eq r, Eq v) => Expr v r -> Expr v r -> Bool
/= :: Expr v r -> Expr v r -> Bool
$c/= :: forall v r. (Eq r, Eq v) => Expr v r -> Expr v r -> Bool
== :: Expr v r -> Expr v r -> Bool
$c== :: forall v r. (Eq r, Eq v) => Expr v r -> Expr v r -> Bool
Eq)
makePrisms ''Expr


foldExpr :: (r -> b) -> (b -> b) -> ([b] -> b) -> ([b] -> b) -> (v -> b) -> Expr v r -> b
foldExpr :: (r -> b)
-> (b -> b)
-> ([b] -> b)
-> ([b] -> b)
-> (v -> b)
-> Expr v r
-> b
foldExpr r -> b
con' b -> b
neg' [b] -> b
sum' [b] -> b
prod' v -> b
var' = Expr v r -> b
go
  where
    go :: Expr v r -> b
go = \case
      Constant r
c -> r -> b
con' r
c
      Negate Expr v r
e   -> b -> b
neg'  (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ Expr v r -> b
go Expr v r
e
      Sum [Expr v r]
es     -> [b] -> b
sum'  ([b] -> b) -> [b] -> b
forall a b. (a -> b) -> a -> b
$ (Expr v r -> b) -> [Expr v r] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map Expr v r -> b
go [Expr v r]
es
      Prod [Expr v r]
es    -> [b] -> b
prod' ([b] -> b) -> [b] -> b
forall a b. (a -> b) -> a -> b
$ (Expr v r -> b) -> [Expr v r] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map Expr v r -> b
go [Expr v r]
es
      Var v
v      -> v -> b
var' v
v

-- | Test if the expression has any variables.
hasVariables :: Expr v r -> Bool
hasVariables :: Expr v r -> Bool
hasVariables = (r -> Bool)
-> (Bool -> Bool)
-> ([Bool] -> Bool)
-> ([Bool] -> Bool)
-> (v -> Bool)
-> Expr v r
-> Bool
forall r b v.
(r -> b)
-> (b -> b)
-> ([b] -> b)
-> ([b] -> b)
-> (v -> b)
-> Expr v r
-> b
foldExpr (Bool -> r -> Bool
forall a b. a -> b -> a
const Bool
False)
                        Bool -> Bool
forall a. a -> a
id
                        [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
                        [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
                        (Bool -> v -> Bool
forall a b. a -> b -> a
const Bool
True)

instance (Num r) => Num (Expr i r) where
  fromInteger :: Integer -> Expr i r
fromInteger = r -> Expr i r
forall v r. r -> Expr v r
Constant (r -> Expr i r) -> (Integer -> r) -> Integer -> Expr i r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> r
forall a. Num a => Integer -> a
fromInteger
  abs :: Expr i r -> Expr i r
abs Expr i r
_ = String -> Expr i r
forall a. HasCallStack => String -> a
error String
"'abs' not defined for Algorithms.Geometry.SoS.Expr.Expr"
  signum :: Expr i r -> Expr i r
signum Expr i r
_ = String -> Expr i r
forall a. HasCallStack => String -> a
error String
"'signum' not defined for Algorithms.Geometry.SoS.Expr.Expr"
  negate :: Expr i r -> Expr i r
negate      = \case
    Negate Expr i r
e -> Expr i r
e
    Expr i r
e        -> Expr i r -> Expr i r
forall v r. Expr v r -> Expr v r
Negate Expr i r
e

  (Sum [Expr i r]
es) + :: Expr i r -> Expr i r -> Expr i r
+ (Sum [Expr i r]
es') = [Expr i r] -> Expr i r
forall v r. [Expr v r] -> Expr v r
Sum ([Expr i r] -> Expr i r) -> [Expr i r] -> Expr i r
forall a b. (a -> b) -> a -> b
$ [Expr i r]
es [Expr i r] -> [Expr i r] -> [Expr i r]
forall a. Semigroup a => a -> a -> a
<> [Expr i r]
es'
  (Sum [Expr i r]
es) + Expr i r
e         = [Expr i r] -> Expr i r
forall v r. [Expr v r] -> Expr v r
Sum (Expr i r
eExpr i r -> [Expr i r] -> [Expr i r]
forall a. a -> [a] -> [a]
:[Expr i r]
es)
  Expr i r
e        + (Sum [Expr i r]
es)  = [Expr i r] -> Expr i r
forall v r. [Expr v r] -> Expr v r
Sum (Expr i r
eExpr i r -> [Expr i r] -> [Expr i r]
forall a. a -> [a] -> [a]
:[Expr i r]
es)
  Expr i r
e        + Expr i r
e'        = [Expr i r] -> Expr i r
forall v r. [Expr v r] -> Expr v r
Sum [Expr i r
e,Expr i r
e']

  (Prod [Expr i r]
es) * :: Expr i r -> Expr i r -> Expr i r
* (Prod [Expr i r]
es') = [Expr i r] -> Expr i r
forall v r. [Expr v r] -> Expr v r
Prod ([Expr i r] -> Expr i r) -> [Expr i r] -> Expr i r
forall a b. (a -> b) -> a -> b
$ [Expr i r]
es [Expr i r] -> [Expr i r] -> [Expr i r]
forall a. Semigroup a => a -> a -> a
<> [Expr i r]
es'
  (Prod [Expr i r]
es) * Expr i r
e          = [Expr i r] -> Expr i r
forall v r. [Expr v r] -> Expr v r
Prod (Expr i r
eExpr i r -> [Expr i r] -> [Expr i r]
forall a. a -> [a] -> [a]
:[Expr i r]
es)
  Expr i r
e         * (Prod [Expr i r]
es)   = [Expr i r] -> Expr i r
forall v r. [Expr v r] -> Expr v r
Prod (Expr i r
eExpr i r -> [Expr i r] -> [Expr i r]
forall a. a -> [a] -> [a]
:[Expr i r]
es)
  Expr i r
e         * Expr i r
e'          = [Expr i r] -> Expr i r
forall v r. [Expr v r] -> Expr v r
Prod [Expr i r
e,Expr i r
e']


simplify :: (Num r, Eq r) => Expr v r -> Expr v r
simplify :: Expr v r -> Expr v r
simplify = \case
  Prod [Expr v r]
es  -> case (Expr v r -> Bool) -> [Expr v r] -> [Expr v r]
forall a. (a -> Bool) -> [a] -> [a]
filter (APrism (Expr v r) (Expr v r) () () -> Expr v r -> Bool
forall s t a b. APrism s t a b -> s -> Bool
isn't (APrism (Expr v r) (Expr v r) () () -> Expr v r -> Bool)
-> APrism (Expr v r) (Expr v r) () () -> Expr v r -> Bool
forall a b. (a -> b) -> a -> b
$ Market () () r (Identity r)
-> Market () () (Expr v r) (Identity (Expr v r))
forall v r. Prism' (Expr v r) r
_Constant(Market () () r (Identity r)
 -> Market () () (Expr v r) (Identity (Expr v r)))
-> (Market () () () (Identity ()) -> Market () () r (Identity r))
-> APrism (Expr v r) (Expr v r) () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.r -> Prism' r ()
forall a. Eq a => a -> Prism' a ()
only r
1) [Expr v r]
es of
                []  -> r -> Expr v r
forall v r. r -> Expr v r
Constant r
1
                [Expr v r]
es' -> [Expr v r] -> Expr v r
forall v r. [Expr v r] -> Expr v r
Prod ([Expr v r] -> Expr v r) -> [Expr v r] -> Expr v r
forall a b. (a -> b) -> a -> b
$ (Expr v r -> Expr v r) -> [Expr v r] -> [Expr v r]
forall a b. (a -> b) -> [a] -> [b]
map Expr v r -> Expr v r
forall r v. (Num r, Eq r) => Expr v r -> Expr v r
simplify [Expr v r]
es'
  Sum  [Expr v r]
es  -> case (Expr v r -> Bool) -> [Expr v r] -> [Expr v r]
forall a. (a -> Bool) -> [a] -> [a]
filter (APrism (Expr v r) (Expr v r) () () -> Expr v r -> Bool
forall s t a b. APrism s t a b -> s -> Bool
isn't (APrism (Expr v r) (Expr v r) () () -> Expr v r -> Bool)
-> APrism (Expr v r) (Expr v r) () () -> Expr v r -> Bool
forall a b. (a -> b) -> a -> b
$ Market () () r (Identity r)
-> Market () () (Expr v r) (Identity (Expr v r))
forall v r. Prism' (Expr v r) r
_Constant(Market () () r (Identity r)
 -> Market () () (Expr v r) (Identity (Expr v r)))
-> (Market () () () (Identity ()) -> Market () () r (Identity r))
-> APrism (Expr v r) (Expr v r) () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.r -> Prism' r ()
forall a. Eq a => a -> Prism' a ()
only r
0) [Expr v r]
es of
                []  -> r -> Expr v r
forall v r. r -> Expr v r
Constant r
0
                [Expr v r]
es' -> [Expr v r] -> Expr v r
forall v r. [Expr v r] -> Expr v r
Sum ([Expr v r] -> Expr v r) -> [Expr v r] -> Expr v r
forall a b. (a -> b) -> a -> b
$ (Expr v r -> Expr v r) -> [Expr v r] -> [Expr v r]
forall a b. (a -> b) -> [a] -> [b]
map Expr v r -> Expr v r
forall r v. (Num r, Eq r) => Expr v r -> Expr v r
simplify [Expr v r]
es'
  Negate Expr v r
e -> Expr v r -> Expr v r
forall v r. Expr v r -> Expr v r
Negate (Expr v r -> Expr v r) -> Expr v r -> Expr v r
forall a b. (a -> b) -> a -> b
$ Expr v r -> Expr v r
forall r v. (Num r, Eq r) => Expr v r -> Expr v r
simplify Expr v r
e
  Expr v r
e        -> Expr v r
e

prettyP :: (Show r, Show v) => Expr v r -> String
prettyP :: Expr v r -> String
prettyP = \case
  Constant r
c  -> r -> String
forall a. Show a => a -> String
show r
c
  Negate Expr v r
e    -> String
"(-1)*(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Expr v r -> String
forall r v. (Show r, Show v) => Expr v r -> String
prettyP Expr v r
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")"
  Prod [Expr v r]
es     -> [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
"("
                            , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
")*(" (Expr v r -> String
forall r v. (Show r, Show v) => Expr v r -> String
prettyP (Expr v r -> String) -> [Expr v r] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expr v r]
es)
                            , String
")"
                            ]
  Sum [Expr v r]
es     -> [String] -> String
forall a. Monoid a => [a] -> a
mconcat [ String
"("
                        , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
") + (" (Expr v r -> String
forall r v. (Show r, Show v) => Expr v r -> String
prettyP (Expr v r -> String) -> [Expr v r] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Expr v r]
es)
                        , String
")"
                        ]
  Var v
v -> v -> String
forall a. Show a => a -> String
show v
v