Last active
May 21, 2024 06:25
-
-
Save evanrelf/8ea4dedb8033cb1cd2148d1b540e626e to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment