fold-frozen-arithmetic.hs

#!/usr/bin/env runghc

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NegativeLiterals #-}

{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}

data Value1
  = Value1_Constant Double
  | Value1_Add Value1 Value1
  | Value1_Subtract Value1 Value1
  | Value1_Multiply Value1 Value1
  | Value1_Divide Value1 Value1
  | Value1_Reciprocal Value1
  | Value1_Negate Value1
  | Value1_Absolute Value1
  | Value1_Sign Value1

instance Show Value1 where
  show = \case
    Value1_Constant x -> show x
    Value1_Add x y -> "(" <> show x <> " + " <> show y <> ")"
    Value1_Subtract x y -> "(" <> show x <> " - " <> show y <> ")"
    Value1_Multiply x y -> "(" <> show x <> " * " <> show y <> ")"
    Value1_Divide x y -> "(" <> show x <> " / " <> show y <> ")"
    Value1_Reciprocal x -> "(1 / " <> show x <> ")"
    Value1_Negate x -> "-" <> show x
    Value1_Absolute x -> "|" <> show x <> "|"
    Value1_Sign x -> show (signum (eval1 x))

instance Num Value1 where
  x + y = Value1_Add x y
  x - y = Value1_Subtract x y
  x * y = Value1_Multiply x y
  negate x = Value1_Negate x
  abs x = Value1_Absolute x
  signum x = Value1_Sign x
  fromInteger x = Value1_Constant (fromInteger x)

instance Fractional Value1 where
  x / y = Value1_Divide x y
  recip x = Value1_Reciprocal x
  fromRational x = Value1_Constant (fromRational x)

eval1 :: Value1 -> Double
eval1 = \case
  Value1_Constant x -> x
  Value1_Add x y -> eval1 x + eval1 y
  Value1_Subtract x y -> eval1 x - eval1 y
  Value1_Multiply x y -> eval1 x * eval1 y
  Value1_Divide x y -> eval1 x / eval1 y
  Value1_Reciprocal x -> 1 / eval1 x
  Value1_Negate x -> negate (eval1 x)
  Value1_Absolute x -> abs (eval1 x)
  Value1_Sign x -> signum (eval1 x)

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

newtype Fix f = Fix{ unFix :: f (Fix f) }

foldFix :: Functor f => (f a -> a) -> Fix f -> a
foldFix f = go where go = f . fmap go . unFix

unfoldFix :: Functor f => (a -> f a) -> a -> Fix f
unfoldFix f = go where go = Fix . fmap go . f

data Value2F r
  = Value2_Constant Double
  | Value2_Add r r
  | Value2_Subtract r r
  | Value2_Multiply r r
  | Value2_Divide r r
  | Value2_Reciprocal r
  | Value2_Negate r
  | Value2_Absolute r
  | Value2_Sign r
  deriving stock (Functor)

type Value2 = Fix Value2F

instance Show Value2 where
  show = foldFix \case
    Value2_Constant x -> show x
    Value2_Add x y -> "(" <> x <> " + " <> y <> ")"
    Value2_Subtract x y -> "(" <> x <> " - " <> y <> ")"
    Value2_Multiply x y -> "(" <> x <> " * " <> y <> ")"
    Value2_Divide x y -> "(" <> x <> " / " <> y <> ")"
    Value2_Reciprocal x -> "(1 / " <> x <> ")"
    Value2_Negate x -> "-" <> x
    Value2_Absolute x -> "|" <> x <> "|"
    Value2_Sign _x -> error ":("

instance Num Value2 where
  x + y = Fix (Value2_Add x y)
  x - y = Fix (Value2_Subtract x y)
  x * y = Fix (Value2_Multiply x y)
  negate x = Fix (Value2_Negate x)
  abs x = Fix (Value2_Absolute x)
  signum x = Fix (Value2_Sign x)
  fromInteger x = Fix (Value2_Constant (fromInteger x))

instance Fractional Value2 where
  x / y = Fix (Value2_Divide x y)
  recip x = Fix (Value2_Reciprocal x)
  fromRational x = Fix (Value2_Constant (fromRational x))

eval2 :: Value2 -> Double
eval2 = foldFix \case
  Value2_Constant x -> x
  Value2_Add x y -> x + y
  Value2_Subtract x y -> x - y
  Value2_Multiply x y -> x * y
  Value2_Divide x y -> x / y
  Value2_Reciprocal x -> 1 / x
  Value2_Negate x -> negate x
  Value2_Absolute x -> abs x
  Value2_Sign x -> signum x

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

to2 :: Value1 -> Value2
to2 = unfoldFix \case
  Value1_Constant x -> Value2_Constant x
  Value1_Add x y -> Value2_Add x y
  Value1_Subtract x y -> Value2_Subtract x y
  Value1_Multiply x y -> Value2_Multiply x y
  Value1_Divide x y -> Value2_Divide x y
  Value1_Reciprocal x -> Value2_Reciprocal x
  Value1_Negate x -> Value2_Negate x
  Value1_Absolute x -> Value2_Absolute x
  Value1_Sign x -> Value2_Sign x

to1 :: Value2 -> Value1
to1 = foldFix \case
  Value2_Constant x -> Value1_Constant x
  Value2_Add x y -> Value1_Add x y
  Value2_Subtract x y -> Value1_Subtract x y
  Value2_Multiply x y -> Value1_Multiply x y
  Value2_Divide x y -> Value1_Divide x y
  Value2_Reciprocal x -> Value1_Reciprocal x
  Value2_Negate x -> Value1_Negate x
  Value2_Absolute x -> Value1_Absolute x
  Value2_Sign x -> Value1_Sign x

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

-- $> main
main :: IO ()
main = do
  putStrLn "value1 (normal)"

  print $ id @Value1 $ 1 + negate (abs (42 + 69 * -108)) + 2

  putStrLn do
    let expr = (1 + 2 + 3 + 4) / (5 - 3) + recip 1
     in show expr <> " = " <> show (eval1 expr)

  putStrLn "value2 (recursion schemes)"

  print $ id @Value2 $ 1 + negate (abs (42 + 69 * -108)) + 2

  putStrLn do
    let expr = (1 + 2 + 3 + 4) / (5 - 3) + recip 1
     in show expr <> " = " <> show (eval2 expr)