66 lines
1.9 KiB
Haskell
66 lines
1.9 KiB
Haskell
-- Adapted from https://github.com/leanprover/lean4/blob/IFL19/tests/bench/const_fold.hs
|
|
|
|
import System.Environment
|
|
|
|
data Expr = Var Integer
|
|
| Val Integer
|
|
| Add Expr Expr
|
|
| Mul Expr Expr
|
|
|
|
mk_expr :: Integer -> Integer -> Expr
|
|
mk_expr 0 v = if v == 0 then Var 1 else Val v
|
|
mk_expr n v = Add (mk_expr (n-1) (v+1)) (mk_expr (n-1) (max (v-1) 0))
|
|
|
|
append_add :: Expr -> Expr -> Expr
|
|
append_add (Add e₁ e₂) e₃ = Add e₁ (append_add e₂ e₃)
|
|
append_add e₁ e₂ = Add e₁ e₂
|
|
|
|
append_mul :: Expr -> Expr -> Expr
|
|
append_mul (Mul e₁ e₂) e₃ = Mul e₁ (append_mul e₂ e₃)
|
|
append_mul e₁ e₂ = Mul e₁ e₂
|
|
|
|
reassoc :: Expr -> Expr
|
|
reassoc (Add e₁ e₂) =
|
|
let e₁' = reassoc e₁ in
|
|
let e₂' = reassoc e₂ in
|
|
append_add e₁' e₂'
|
|
reassoc (Mul e₁ e₂) =
|
|
let e₁' = reassoc e₁ in
|
|
let e₂' = reassoc e₂ in
|
|
append_mul e₁' e₂'
|
|
reassoc e = e
|
|
|
|
const_folding :: Expr -> Expr
|
|
const_folding (Add e₁ e₂) =
|
|
let e₁' = const_folding e₁ in
|
|
let e₂' = const_folding e₂ in
|
|
(case (e₁', e₂') of
|
|
(Val a, Val b ) -> Val (a+b)
|
|
(Val a, Add e (Val b)) -> Add (Val (a+b)) e
|
|
(Val a, Add (Val b) e) -> Add (Val (a+b)) e
|
|
(_, _ ) -> Add e₁' e₂')
|
|
const_folding (Mul e₁ e₂) =
|
|
let e₁' = const_folding e₁ in
|
|
let e₂' = const_folding e₂ in
|
|
(case (e₁', e₂') of
|
|
(Val a, Val b ) -> Val (a*b)
|
|
(Val a, Mul e (Val b)) -> Mul (Val (a*b)) e
|
|
(Val a, Mul (Val b) e) -> Mul (Val (a*b)) e
|
|
(_, _ ) -> Mul e₁' e₂')
|
|
const_folding e = e
|
|
|
|
eval :: Expr -> Integer
|
|
eval (Var _) = 0
|
|
eval (Val v) = v
|
|
eval (Add l r) = eval l + eval r
|
|
eval (Mul l r) = eval l * eval r
|
|
|
|
main :: IO ()
|
|
main = do
|
|
[arg] <- getArgs
|
|
let n = read arg
|
|
let e = (mk_expr n 1)
|
|
let v₁ = eval e
|
|
let v₂ = eval (const_folding (reassoc e))
|
|
putStrLn (show v₁ ++ " " ++ show v₂)
|