Skip to content

Instantly share code, notes, and snippets.

@Garciat
Created November 6, 2018 17:31
Show Gist options
  • Save Garciat/b0f060ddf8c5fcd6e4933a739fe57db9 to your computer and use it in GitHub Desktop.
Save Garciat/b0f060ddf8c5fcd6e4933a739fe57db9 to your computer and use it in GitHub Desktop.
module StackExpr where
data Instr
= Const Integer
| Add
| Sub
| Mul
| Neg
| Abs
| Sig
deriving (Show)
newtype Program = P [Instr] deriving (Show)
instance Num Program where
fromInteger i = P [Const i]
P a + P b = P (b ++ a ++ [Add])
P a - P b = P (b ++ a ++ [Sub])
P a * P b = P (b ++ a ++ [Mul])
negate (P a) = P (a ++ [Neg])
abs (P a) = P (a ++ [Abs])
signum (P a) = P (a ++ [Sig])
eval :: Program -> Integer
eval (P xs) = go [] xs
where
go (x:_) [] = x
go xs (Const i:ys) = go (i:xs) ys
go (a:b:xs) (Add:ys) = go ((a+b):xs) ys
go (a:b:xs) (Mul:ys) = go ((a*b):xs) ys
go (a:b:xs) (Sub:ys) = go ((a-b):xs) ys
go (a:xs) (Neg:ys) = go ((negate a):xs) ys
go (a:xs) (Abs:ys) = go ((abs a):xs) ys
go (a:xs) (Sig:ys) = go ((signum a):xs) ys
module StackExpr where
data BinOp
= Add
| Mul
| Sub
deriving (Show)
data UnaOp
= Neg
| Abs
| Sig
deriving (Show)
data Instr
= Const Integer
| BinOp BinOp
| UnaOp UnaOp
deriving (Show)
binop :: BinOp -> Integer -> Integer -> Integer
binop Add = (+)
binop Mul = (*)
binop Sub = (-)
unaop :: UnaOp -> Integer -> Integer
unaop Neg = negate
unaop Abs = abs
unaop Sig = signum
newtype Program = P [Instr] deriving (Show)
formatBin :: BinOp -> Program -> Program -> Program
formatBin op (P a) (P b) = P (b ++ a ++ [BinOp op])
formatUna :: UnaOp -> Program -> Program
formatUna op (P a) = P (a ++ [UnaOp op])
instance Num Program where
fromInteger i = P [Const i]
(+) = formatBin Add
(-) = formatBin Sub
(*) = formatBin Mul
negate = formatUna Neg
abs = formatUna Abs
signum = formatUna Sig
eval :: Program -> Integer
eval (P xs) = go [] xs
where
go (x:_) [] = x
go xs (Const i:ys) = go (i:xs) ys
go (a:b:xs) (BinOp x:ys) = go ((binop x a b):xs) ys
go (a:xs) (UnaOp x:ys) = go ((unaop x a):xs) ys
{-# Language ConstraintKinds #-}
{-# Language GADTs #-}
module StackExpr where
data BinOp
= Add
| Mul
| Sub
deriving (Show)
data UnaOp
= Neg
| Abs
| Sig
deriving (Show)
data Instr
= Const Integer
| BinOp BinOp
| UnaOp UnaOp
deriving (Show)
newtype Program = P [Instr] deriving (Show)
formatBin :: BinOp -> Program -> Program -> Program
formatBin op (P a) (P b) = P (b ++ a ++ [BinOp op])
formatUna :: UnaOp -> Program -> Program
formatUna op (P a) = P (a ++ [UnaOp op])
instance Num Program where
fromInteger i = P [Const i]
(+) = formatBin Add
(-) = formatBin Sub
(*) = formatBin Mul
negate = formatUna Neg
abs = formatUna Abs
signum = formatUna Sig
---
{-
class Num a where
(+) :: a -> a -> a
(-) :: a -> a -> a
(*) :: a -> a -> a
negate :: a -> a
abs :: a -> a
signum :: a -> a
fromInteger :: Integer -> a
-}
data DNum where
NumAdd :: DNum -> DNum -> DNum
NumSub :: DNum -> DNum -> DNum
NumMul :: DNum -> DNum -> DNum
NumNeg :: DNum -> DNum
NumAbs :: DNum -> DNum
NumSig :: DNum -> DNum
NumInt :: Integer -> DNum
deriving Show
instance Num DNum where
(+) = NumAdd
(-) = NumSub
(*) = NumMul
negate = NumNeg
abs = NumAbs
signum = NumSig
fromInteger = NumInt
asNum :: Num a => DNum -> a
asNum = go
where
go (NumAdd a b) = go a + go b
go (NumSub a b) = go a - go b
go (NumMul a b) = go a * go b
go (NumNeg a) = negate (go a)
go (NumAbs a) = abs (go a)
go (NumSig a) = signum (go a)
go (NumInt i) = fromInteger i
class ToDNum a where
toDNum :: a -> DNum
instance ToDNum DNum where
toDNum = id
instance ToDNum Program where
toDNum (P xs) = go [] xs
where
go [x] [] = x
go xs (Const i:ys) = go (NumInt i:xs) ys
go (a:b:xs) (BinOp op:ys) = go (bin op a b:xs) ys
go (a:xs) (UnaOp op:ys) = go (una op a:xs) ys
bin Add = NumAdd
bin Sub = NumSub
bin Mul = NumMul
una Neg = NumNeg
una Abs = NumAbs
una Sig = NumSig
eval :: Program -> Integer
eval = asNum . toDNum
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment