module Graphics.Web.Processing.Core.Primal (
Preamble (..), Setup (..), Draw (..)
, MouseClicked (..), MouseReleased (..)
, KeyPressed (..)
, Recursive (..)
, Proc_Bool (..), fromBool
, true, false
, pnot, (#||), (#&&)
, Proc_Int (..), fromInt
, pfloor, pround
, Proc_Float (..), fromFloat
, intToFloat
, noisef
, Proc_Image
, Proc_Char , fromChar
, Proc_Text, fromStText
, (+.+)
, Proc_Show (..)
, Proc_Key (..)
, Proc_KeyCode (..)
, ProcType (..)
, isVarInArg, isVarInAssign
, assignVarName
, Proc_Eq (..)
, Proc_Ord (..)
, Reducible (..)
, Var, varName, varFromText
, ArrayVar, arrayVarName, arrayVarFromText
, arraySize
, arrayVarToVar
, ProcCode (..), ProcArg (..), ProcAssign (..)
, ProcList (..)
, emptyCode
, (>>.)
, ProcScript (..)
, emptyScript
) where
import Prelude hiding (foldr)
import Data.Text (Text,lines,pack)
import Data.Text.Lazy (toStrict)
import qualified Data.Sequence as Seq
import Data.Monoid
import Data.String
import Data.Foldable (foldMap,foldr)
import Control.Applicative
import Text.PrettyPrint.Mainland
import Test.QuickCheck (Arbitrary (..), Gen, oneof, sized, resize, vectorOf)
import Test.QuickCheck.Instances()
import GHC.Generics
import Graphics.Web.Processing.Core.TH
class PArbitrary a where
parbitrary :: Gen a
default parbitrary :: (Generic a, GArbitrary (Rep a)) => Gen a
parbitrary = to <$> garbitrary
class GArbitrary f where
garbitrary :: Gen (f a)
instance GArbitrary U1 where
garbitrary = pure U1
instance (GArbitrary a, GArbitrary b) => GArbitrary (a :*: b) where
garbitrary = sized $
\n -> resize (n+1) $ (:*:) <$> garbitrary <*> garbitrary
sizeLimit :: Int
sizeLimit = 15
instance (GArbitrary a, GArbitrary b) => GArbitrary (a :+: b) where
garbitrary = sized $
\n -> if n > sizeLimit
then L1 <$> garbitrary
else oneof [L1 <$> garbitrary, R1 <$> garbitrary]
instance GArbitrary a => GArbitrary (M1 i c a) where
garbitrary = M1 <$> garbitrary
instance PArbitrary a => GArbitrary (K1 i a) where
garbitrary = K1 <$> parbitrary
instance Arbitrary a => PArbitrary (Maybe a) where
parbitrary = arbitrary
instance Arbitrary a => PArbitrary (Seq.Seq a) where
parbitrary = arbitrary
instance PArbitrary Int where
parbitrary = arbitrary
instance PArbitrary Float where
parbitrary = arbitrary
instance PArbitrary Text where
parbitrary = pack <$> vectorOf 4 parbitrary
instance PArbitrary Char where
parbitrary = oneof $ fmap pure [ 'a' .. 'z' ]
instance Arbitrary a => PArbitrary [a] where
parbitrary = arbitrary
data Preamble = Preamble
data Setup = Setup
data Draw = Draw
data MouseClicked = MouseClicked
data MouseReleased = MouseReleased
data KeyPressed = KeyPressed
pfunction :: Text -> [Doc] -> Doc
pfunction n as = fromText n <> parens (commasep as)
class Extended from to | to -> from where
extend :: from -> to
patmatch :: to -> Maybe from
extendf :: (Extended from to, Extended from' to')
=> (from -> from') -> (to -> to') -> (to -> to')
extendf f g x =
case patmatch x of
Nothing -> g x
Just a -> extend $ f a
extendop :: (Extended from to
,Extended from' to'
,Extended from'' to'')
=> (from -> from' -> from'')
-> (to -> to' -> to'')
-> (to -> to' -> to'')
extendop f g x y =
case (patmatch x, patmatch y) of
(Just a, Just b) -> extend $ f a b
_ -> g x y
class Recursive a where
recursor :: (a -> a) -> a -> a
data Proc_Bool =
Proc_True
| Proc_False
| Proc_Neg Proc_Bool
| Proc_Or Proc_Bool Proc_Bool
| Proc_And Proc_Bool Proc_Bool
| Bool_Var Text
| Bool_Eq Proc_Bool Proc_Bool
| Bool_NEq Proc_Bool Proc_Bool
| Int_Eq Proc_Int Proc_Int
| Int_NEq Proc_Int Proc_Int
| Int_LE Proc_Int Proc_Int
| Int_L Proc_Int Proc_Int
| Int_GE Proc_Int Proc_Int
| Int_G Proc_Int Proc_Int
| Float_Eq Proc_Float Proc_Float
| Float_NEq Proc_Float Proc_Float
| Float_LE Proc_Float Proc_Float
| Float_L Proc_Float Proc_Float
| Float_GE Proc_Float Proc_Float
| Float_G Proc_Float Proc_Float
| Char_Eq Proc_Char Proc_Char
| Char_NEq Proc_Char Proc_Char
| Text_Eq Proc_Text Proc_Text
| Key_Eq Proc_Key Proc_Key
| KeyCode_Eq Proc_KeyCode Proc_KeyCode
| Bool_Cond Proc_Bool Proc_Bool Proc_Bool
deriving (Eq,Ord,Generic)
instance PArbitrary Proc_Bool
instance Arbitrary Proc_Bool where
arbitrary = parbitrary
instance Extended Bool Proc_Bool where
extend True = Proc_True
extend False = Proc_False
patmatch Proc_True = Just True
patmatch Proc_False = Just False
patmatch _ = Nothing
docEq :: Doc
docEq = fromText "=="
docNEq :: Doc
docNEq = fromText "!="
docLE :: Doc
docLE = fromText "<="
docL :: Doc
docL = fromText "<"
docGE :: Doc
docGE = fromText ">="
docG :: Doc
docG = fromText ">"
docCond :: Doc -> Doc -> Doc -> Doc
docCond _if _then _else = _if <+> fromText "?" <+> _then <+> fromText ":" <+> _else
indentLevel :: Int
indentLevel = 3
instance Pretty Proc_Bool where
ppr Proc_True = fromText "true"
ppr Proc_False = fromText "false"
ppr (Proc_Neg b) = fromText "!" <> ppr b
ppr (Proc_Or b1 b2) = parens $ ppr b1 <+> fromText "||" <+> ppr b2
ppr (Proc_And b1 b2) = parens $ ppr b1 <+> fromText "&&" <+> ppr b2
ppr (Bool_Var t) = fromText t
ppr (Bool_Eq x y) = parens $ ppr x <+> docEq <+> ppr y
ppr (Bool_NEq x y) = parens $ ppr x <+> docNEq <+> ppr y
ppr (Int_Eq x y) = parens $ ppr x <+> docEq <+> ppr y
ppr (Int_NEq x y) = parens $ ppr x <+> docNEq <+> ppr y
ppr (Int_LE x y) = parens $ ppr x <+> docLE <+> ppr y
ppr (Int_L x y) = parens $ ppr x <+> docL <+> ppr y
ppr (Int_GE x y) = parens $ ppr x <+> docGE <+> ppr y
ppr (Int_G x y) = parens $ ppr x <+> docG <+> ppr y
ppr (Float_Eq x y) = parens $ ppr x <+> docEq <+> ppr y
ppr (Float_NEq x y) = parens $ ppr x <+> docNEq <+> ppr y
ppr (Float_LE x y) = parens $ ppr x <+> docLE <+> ppr y
ppr (Float_L x y) = parens $ ppr x <+> docL <+> ppr y
ppr (Float_GE x y) = parens $ ppr x <+> docGE <+> ppr y
ppr (Float_G x y) = parens $ ppr x <+> docG <+> ppr y
ppr (Char_Eq x y) = parens $ ppr x <+> docEq <+> ppr y
ppr (Char_NEq x y) = parens $ ppr x <+> docNEq <+> ppr y
ppr (Text_Eq x y) = ppr x <> fromText "." <> pfunction "equals" [ppr y]
ppr (Key_Eq x y) = parens $ ppr x <+> docEq <+> ppr y
ppr (KeyCode_Eq x y) = parens $ ppr x <+> docEq <+> ppr y
ppr (Bool_Cond b x y) = parens $ docCond (ppr b) (ppr x) (ppr y)
true :: Proc_Bool
true = Proc_True
false :: Proc_Bool
false = Proc_False
pnot :: Proc_Bool -> Proc_Bool
pnot = extendf not Proc_Neg
infixr 2 #||
(#||) :: Proc_Bool -> Proc_Bool -> Proc_Bool
(#||) = extendop (||) Proc_Or
infixr 3 #&&
(#&&) :: Proc_Bool -> Proc_Bool -> Proc_Bool
(#&&) = extendop (&&) Proc_And
fromBool :: Bool -> Proc_Bool
fromBool = extend
data Proc_Int =
Proc_Int Int
| Int_Sum Proc_Int Proc_Int
| Int_Substract Proc_Int Proc_Int
| Int_Divide Proc_Int Proc_Int
| Int_Mult Proc_Int Proc_Int
| Int_Mod Proc_Int Proc_Int
| Int_Var Text
| Int_Abs Proc_Int
| Int_Floor Proc_Float
| Int_Round Proc_Float
| Int_Cond Proc_Bool Proc_Int Proc_Int
deriving (Eq,Ord,Generic)
instance PArbitrary Proc_Int
instance Arbitrary Proc_Int where
arbitrary = parbitrary
instance Extended Int Proc_Int where
extend = Proc_Int
patmatch (Proc_Int a) = Just a
patmatch _ = Nothing
instance Pretty Proc_Int where
ppr (Proc_Int i) = ppr i
ppr (Int_Sum n m) = parens $ ppr n <> fromText "+" <> ppr m
ppr (Int_Substract n m) = parens $ ppr n <> fromText "-" <> ppr m
ppr (Int_Divide n m) = parens $ ppr n <> fromText "/" <> ppr m
ppr (Int_Mult n m) = parens $ ppr n <> fromText "*" <> ppr m
ppr (Int_Mod n m) = parens $ ppr n <> fromText "%" <> ppr m
ppr (Int_Var t) = fromText t
ppr (Int_Abs n) = pfunction "abs" [ppr n]
ppr (Int_Floor x) = pfunction "floor" [ppr x]
ppr (Int_Round x) = pfunction "round" [ppr x]
ppr (Int_Cond b x y) = parens $ docCond (ppr b) (ppr x) (ppr y)
fromInt :: Int -> Proc_Int
fromInt = extend
pfloor :: Proc_Float -> Proc_Int
pfloor = extendf floor Int_Floor
pround :: Proc_Float -> Proc_Int
pround = extendf round Int_Round
instance Enum Proc_Int where
toEnum = fromInt
fromEnum n = case patmatch n of
Nothing -> error "Proc_Int: fromEnum applied to a variable."
Just i -> i
succ n = n + 1
pred n = n 1
instance Num Proc_Int where
fromInteger = fromInt . fromInteger
(+) = extendop (+) Int_Sum
() = extendop () Int_Substract
(*) = extendop (*) Int_Mult
abs = extendf abs Int_Abs
signum = error "Proc_Int: signum method is undefined."
instance Real Proc_Int where
toRational n = case patmatch n of
Nothing -> error "Proc_Int: toRational applied to a variable."
Just i -> toRational i
instance Integral Proc_Int where
div = extendop div Int_Divide
mod = extendop mod Int_Mod
quotRem n d = (div n d, mod n d)
divMod = quotRem
toInteger n = case patmatch n of
Nothing -> error "Proc_Int: toInteger applied to a variable."
Just i -> toInteger i
data Proc_Float =
Proc_Float Float
| Float_Sum Proc_Float Proc_Float
| Float_Substract Proc_Float Proc_Float
| Float_Divide Proc_Float Proc_Float
| Float_Mult Proc_Float Proc_Float
| Float_Mod Proc_Float Proc_Float
| Float_Neg Proc_Float
| Float_Var Text
| Float_Abs Proc_Float
| Float_Exp Proc_Float
| Float_Sqrt Proc_Float
| Float_Log Proc_Float
| Float_Sine Proc_Float
| Float_Cosine Proc_Float
| Float_Arcsine Proc_Float
| Float_Arccosine Proc_Float
| Float_Arctangent Proc_Float
| Float_Floor Proc_Float
| Float_Round Proc_Float
| Float_Noise Proc_Float Proc_Float
| Float_Random Proc_Float Proc_Float
| Float_Cond Proc_Bool Proc_Float Proc_Float
deriving (Eq,Ord,Generic)
instance PArbitrary Proc_Float
instance Arbitrary Proc_Float where
arbitrary = parbitrary
instance Extended Float Proc_Float where
extend = Proc_Float
patmatch (Proc_Float x) = Just x
patmatch _ = Nothing
instance Pretty Proc_Float where
ppr (Proc_Float f) = ppr f
ppr (Float_Sum x y) = parens $ ppr x <> fromText "+" <> ppr y
ppr (Float_Substract x y) = parens $ ppr x <> fromText "-" <> ppr y
ppr (Float_Divide x y) = parens $ ppr x <> fromText "/" <> ppr y
ppr (Float_Mult x y) = parens $ ppr x <> fromText "*" <> ppr y
ppr (Float_Neg x) = fromText "-" <> ppr x
ppr (Float_Mod x y) = parens $ ppr x <> fromText "%" <> ppr y
ppr (Float_Var t) = fromText t
ppr (Float_Abs x) = pfunction "abs" [ppr x]
ppr (Float_Exp x) = pfunction "exp" [ppr x]
ppr (Float_Sqrt x) = pfunction "sqrt" [ppr x]
ppr (Float_Log x) = pfunction "log" [ppr x]
ppr (Float_Sine x) = pfunction "sin" [ppr x]
ppr (Float_Cosine x) = pfunction "cos" [ppr x]
ppr (Float_Arcsine x) = pfunction "asin" [ppr x]
ppr (Float_Arccosine x) = pfunction "acos" [ppr x]
ppr (Float_Arctangent x) = pfunction "atan" [ppr x]
ppr (Float_Floor x) = pfunction "floor" [ppr x]
ppr (Float_Round x) = pfunction "round" [ppr x]
ppr (Float_Noise x y) = pfunction "noise" [ppr x,ppr y]
ppr (Float_Cond b x y) = parens $ docCond (ppr b) (ppr x) (ppr y)
ppr (Float_Random x y) = pfunction "random" [ppr x,ppr y]
fromFloat :: Float -> Proc_Float
fromFloat = extend
noisef :: Proc_Float -> Proc_Float -> Proc_Float
noisef = Float_Noise
intToFloat :: Proc_Int -> Proc_Float
intToFloat (Proc_Int i) = Proc_Float $ fromIntegral i
intToFloat (Int_Sum n m) = Float_Sum (intToFloat n) (intToFloat m)
intToFloat (Int_Substract n m) = Float_Substract (intToFloat n) (intToFloat m)
intToFloat (Int_Divide n m) = Float_Divide (intToFloat n) (intToFloat m)
intToFloat (Int_Mult n m) = Float_Mult (intToFloat n) (intToFloat m)
intToFloat (Int_Mod n m) = Float_Mod (intToFloat n) (intToFloat m)
intToFloat (Int_Var t) = Float_Var t
intToFloat (Int_Abs n) = Float_Abs $ intToFloat n
intToFloat (Int_Floor x) = Float_Floor x
intToFloat (Int_Round x) = Float_Round x
intToFloat (Int_Cond b x y) = Float_Cond b (intToFloat x) (intToFloat y)
instance Num Proc_Float where
fromInteger = fromFloat . fromInteger
(+) = extendop (+) Float_Sum
() = extendop () Float_Substract
(*) = extendop (*) Float_Mult
abs = extendf abs Float_Abs
negate = extendf negate Float_Neg
signum = error "Proc_Float: signum method is undefined."
instance Fractional Proc_Float where
(/) = extendop (/) Float_Divide
fromRational = fromFloat . fromRational
instance Floating Proc_Float where
pi = extend pi
exp = extendf exp Float_Exp
sqrt = extendf sqrt Float_Sqrt
log = extendf log Float_Log
sin = extendf sin Float_Sine
cos = extendf cos Float_Cosine
asin = extendf asin Float_Arcsine
acos = extendf acos Float_Arccosine
atan = extendf atan Float_Arctangent
sinh = error "Proc_Float: sinh method is undefined."
cosh = error "Proc_Float: cosh method is undefined."
asinh = error "Proc_Float: asinh method is undefined."
acosh = error "Proc_Float: acosh method is undefined."
atanh = error "Proc_Float: atanh method is undefined."
data Proc_Image =
Image_Var Text
| Image_Cond Proc_Bool Proc_Image Proc_Image
deriving (Eq,Generic)
instance PArbitrary Proc_Image
instance Arbitrary Proc_Image where
arbitrary = parbitrary
instance Pretty Proc_Image where
ppr (Image_Var t) = fromText t
ppr (Image_Cond b x y) = parens $ docCond (ppr b) (ppr x) (ppr y)
data Proc_Char =
Proc_Char Char
| Char_Var Text
| Char_Cond Proc_Bool Proc_Char Proc_Char
deriving (Eq,Ord,Generic)
instance PArbitrary Proc_Char
instance Arbitrary Proc_Char where
arbitrary = parbitrary
instance Extended Char Proc_Char where
extend = Proc_Char
patmatch (Proc_Char c) = Just c
patmatch _ = Nothing
fromChar :: Char -> Proc_Char
fromChar = extend
instance Pretty Proc_Char where
ppr (Proc_Char c) = enclose squote squote (char c)
ppr (Char_Var n) = fromText n
ppr (Char_Cond b x y) = parens $ docCond (ppr b) (ppr x) (ppr y)
data Proc_Text =
Proc_Text Text
| Text_Var Text
| Show_Bool Proc_Bool
| Show_Char Proc_Char
| Show_Float Proc_Float
| Show_Int Proc_Int
| Text_Append Proc_Text Proc_Text
| Text_Cond Proc_Bool Proc_Text Proc_Text
deriving (Eq,Ord,Generic)
infixr 5 +.+
(+.+) :: Proc_Text -> Proc_Text -> Proc_Text
(+.+) = Text_Append
instance PArbitrary Proc_Text
instance Arbitrary Proc_Text
instance Extended Text Proc_Text where
extend = Proc_Text
patmatch (Proc_Text t) = Just t
patmatch _ = Nothing
instance Pretty Proc_Text where
ppr (Proc_Text t) = enclose dquote dquote (fromText t)
ppr (Text_Var n) = fromText n
ppr (Show_Bool x) = pfunction "str" [ppr x]
ppr (Show_Char x) = pfunction "str" [ppr x]
ppr (Show_Float x) = pfunction "str" [ppr x]
ppr (Show_Int x) = pfunction "str" [ppr x]
ppr (Text_Append x y) = ppr x <+> fromText "+" <+> ppr y
ppr (Text_Cond b x y) = parens $ docCond (ppr b) (ppr x) (ppr y)
fromStText :: Text -> Proc_Text
fromStText = extend
instance IsString Proc_Text where
fromString = fromStText . fromString
class Proc_Show a where
pshow :: a -> Proc_Text
instance Proc_Show Proc_Bool where
pshow = Show_Bool
instance Proc_Show Proc_Char where
pshow = Show_Char
instance Proc_Show Proc_Float where
pshow = Show_Float
instance Proc_Show Proc_Int where
pshow = Show_Int
data Proc_Key =
Key_Var
| Key_CODED
| Key_Char Char
deriving (Eq,Ord,Generic)
instance PArbitrary Proc_Key
instance Pretty Proc_Key where
ppr Key_Var = fromText "key"
ppr Key_CODED = fromText "CODED"
ppr (Key_Char c) = ppr $ fromChar c
data Proc_KeyCode =
KeyCode_Var
| KeyCode_UP
| KeyCode_DOWN
| KeyCode_LEFT
| KeyCode_RIGHT
| KeyCode_ALT
| KeyCode_CONTROL
| KeyCode_SHIFT
| KeyCode_BACKSPACE
| KeyCode_TAB
| KeyCode_ENTER
| KeyCode_RETURN
| KeyCode_ESC
| KeyCode_DELETE
deriving (Eq,Ord,Generic)
instance PArbitrary Proc_KeyCode
instance Pretty Proc_KeyCode where
ppr KeyCode_Var = fromText "keyCode"
ppr KeyCode_UP = fromText "UP"
ppr KeyCode_DOWN = fromText "DOWN"
ppr KeyCode_LEFT = fromText "LEFT"
ppr KeyCode_RIGHT = fromText "RIGHT"
ppr KeyCode_ALT = fromText "ALT"
ppr KeyCode_CONTROL = fromText "CONTROL"
ppr KeyCode_SHIFT = fromText "SHIFT"
ppr KeyCode_BACKSPACE = fromText "BACKSPACE"
ppr KeyCode_TAB = fromText "TAB"
ppr KeyCode_ENTER = fromText "ENTER"
ppr KeyCode_RETURN = fromText "RETURN"
ppr KeyCode_ESC = fromText "ESC"
ppr KeyCode_DELETE = fromText "DELETE"
$(procTypeMechs)
instance PArbitrary ProcArg
instance Arbitrary ProcArg where
arbitrary = parbitrary
instance PArbitrary ProcAssign
instance PArbitrary ProcList
data ProcCode c =
Command Text [ProcArg]
| CreateVar ProcAssign
| CreateArrayVar Text ProcList
| Assignment ProcAssign
| Conditional Proc_Bool
(ProcCode c)
(ProcCode c)
| Comment Text
| Sequence (Seq.Seq (ProcCode c))
deriving (Generic,Eq)
instance PArbitrary (ProcCode c)
instance Arbitrary (ProcCode c) where
arbitrary = parbitrary
instance Pretty (ProcCode c) where
ppr (Command n as) = pfunction n (fmap ppr as) <+> fromText ";"
ppr (CreateVar a) = ptype a <+> ppr a <+> fromText ";"
ppr (CreateArrayVar n xs) = ltype xs <+> fromText n <+> fromText "="
<+> ppr xs <+> fromText ";"
ppr (Assignment a) = ppr a <+> fromText ";"
ppr (Conditional b e1 e2) =
let c1 = indent indentLevel $ ppr e1
c2 = indent indentLevel $ ppr e2
in pfunction "if" [ppr b]
<+> enclose lbrace rbrace (line <> c1)
<+> if e2 == mempty then mempty
else fromText "else" <+> enclose lbrace rbrace (line <> c2)
ppr (Comment t) = stack $ fmap (fromText . ("// " <>)) $ Data.Text.lines t
ppr (Sequence sq) =
if Seq.null sq then Text.PrettyPrint.Mainland.empty
else foldMap ((<> line) . ppr) sq
(>>.) :: ProcCode c -> ProcCode c -> ProcCode c
(Sequence xs) >>. (Sequence ys) = Sequence $ xs Seq.>< ys
(Sequence xs) >>. p = if Seq.null xs
then p
else Sequence $ xs Seq.|> p
p >>. (Sequence xs) = if Seq.null xs
then p
else Sequence $ p Seq.<| xs
p >>. q = Sequence $ Seq.fromList [p,q]
emptyCode :: ProcCode a
emptyCode = Sequence $ Seq.empty
instance Monoid (ProcCode a) where
mempty = emptyCode
mappend = (>>.)
data Var a = Var {
varName :: Text }
varFromText :: Text -> Var a
varFromText = Var
data ArrayVar a =
ArrayVar {
arraySize :: Int
, innerVar :: Var a }
arrayVarName :: ArrayVar a -> Text
arrayVarName = varName . innerVar
arrayVarFromText :: Int -> Text -> ArrayVar a
arrayVarFromText n t = ArrayVar n (Var t)
arrayVarToVar :: ArrayVar a -> Proc_Int -> Var a
arrayVarToVar v n = varFromText $ arrayVarName v <> "[" <> f n <> "]"
where
f = toStrict . prettyLazyText 80 . ppr
class ProcType a where
proc_assign :: Text -> a -> ProcAssign
proc_list :: [a] -> ProcList
proc_arg :: a -> ProcArg
proc_read :: Var a -> a
proc_cond :: Proc_Bool -> a -> a -> a
checkForVar :: Text -> a -> Bool
$(deriveProcTypeInsts)
infix 4 #==, #/=
class Proc_Eq a where
(#==) :: a -> a -> Proc_Bool
(#/=) :: a -> a -> Proc_Bool
x #== y = pnot $ x #/= y
x #/= y = pnot $ x #== y
instance Proc_Eq Proc_Bool where
(#==) = Bool_Eq
(#/=) = Bool_NEq
instance Proc_Eq Proc_Int where
(#==) = Int_Eq
(#/=) = Int_NEq
instance Proc_Eq Proc_Float where
(#==) = Float_Eq
(#/=) = Float_NEq
instance Proc_Eq Proc_Char where
(#==) = Char_Eq
(#/=) = Char_NEq
instance Proc_Eq Proc_Text where
(#==) = Text_Eq
instance Proc_Eq Proc_Key where
(#==) = Key_Eq
instance Proc_Eq Proc_KeyCode where
(#==) = KeyCode_Eq
infix 4 #<=, #<, #>=, #>
class Proc_Ord a where
(#<=) :: a -> a -> Proc_Bool
(#<) :: a -> a -> Proc_Bool
(#>=) :: a -> a -> Proc_Bool
(#>) :: a -> a -> Proc_Bool
instance Proc_Ord Proc_Int where
(#<=) = Int_LE
(#<) = Int_L
(#>=) = Int_GE
(#>) = Int_G
instance Proc_Ord Proc_Float where
(#<=) = Float_LE
(#<) = Float_L
(#>=) = Float_GE
(#>) = Float_G
$(deriveRecursive ''Proc_Bool)
$(deriveRecursive ''Proc_Int)
$(deriveRecursive ''Proc_Float)
class Eq a => Reducible a where
reduce :: a -> a
iteratedReduce :: Reducible a => a -> a
iteratedReduce = fst . firstWith (uncurry (==)) . pairing . iterate reduce
where
pairing (x:y:xs) = (x,y) : pairing (y:xs)
pairing _ = []
firstWith f (x:xs) = if f x then x else firstWith f xs
firstWith _ _ = error "Error in iterated reduction. Report this as a bug."
instance Reducible Proc_Float where
reduce f@(Float_Sum (Float_Mult x y) (Float_Mult x' y'))
| x == x' = reduce $ x * (y + y')
| y == y' = reduce $ y * (x + x')
| otherwise = recursor reduce f
reduce (Float_Sum x (Float_Neg y)) = reduce $ Float_Substract x y
reduce (Float_Sum (Float_Neg x) y) = reduce $ Float_Substract y x
reduce (Float_Sum x y)
| x == y = 2 * reduce x
| x == 0 = reduce y
| y == 0 = reduce x
| otherwise = reduce x + reduce y
reduce (Float_Substract x (Float_Neg y)) = reduce $ Float_Sum x y
reduce (Float_Substract x y)
| x == y = 0
| x == 0 = reduce $ negate y
| y == 0 = reduce x
| otherwise = reduce x reduce y
reduce (Float_Mult x y)
| x == y = reduce x ** 2
| x == 1 = reduce y
| y == 1 = reduce x
| otherwise = reduce x * reduce y
reduce (Float_Divide (Float_Mult (Proc_Float x) y) (Proc_Float z)) =
reduce $ (y*) $ Proc_Float $ x / z
reduce (Float_Divide (Float_Mult x (Proc_Float y)) (Proc_Float z)) =
reduce $ (x*) $ Proc_Float $ y / z
reduce x = recursor reduce x
instance Reducible ProcArg where
reduce (FloatArg x) = FloatArg $ iteratedReduce x
reduce x = x
instance Reducible (ProcCode c) where
reduce (Sequence sq) = Sequence $ fmap reduce $ foldr (
\x xs ->
case Seq.viewl xs of
y Seq.:< ys -> case reduceProcPair x y of
Nothing -> x Seq.<| xs
Just z -> z Seq.<| ys
Seq.EmptyL -> Seq.singleton x
) Seq.empty sq
reduce (Command n xs) = Command n $ fmap reduce xs
reduce x = x
reduceProcPair :: ProcCode c -> ProcCode c -> Maybe (ProcCode c)
reduceProcPair (Command "translate" [FloatArg 0,FloatArg 0]) x = Just x
reduceProcPair x (Command "translate" [FloatArg 0,FloatArg 0]) = Just x
reduceProcPair (Command "translate" [FloatArg x,FloatArg y])
(Command "translate" [FloatArg x',FloatArg y'])
= Just $ Command "translate" [ FloatArg $ x+x'
, FloatArg $ y+y']
reduceProcPair (Command "rotate" [FloatArg 0]) x = Just x
reduceProcPair x (Command "rotate" [FloatArg 0]) = Just x
reduceProcPair (Command "rotate" [FloatArg x])
(Command "rotate" [FloatArg x'])
= Just $ Command "rotate" [FloatArg $ x+x']
reduceProcPair _ _ = Nothing
data ProcScript = ProcScript
{ proc_preamble :: ProcCode Preamble
, proc_setup :: ProcCode Setup
, proc_draw :: Maybe (ProcCode Draw)
, proc_mouseClicked :: Maybe (ProcCode MouseClicked)
, proc_mouseReleased :: Maybe (ProcCode MouseReleased)
, proc_keyPressed :: Maybe (ProcCode KeyPressed)
} deriving (Eq,Generic)
instance PArbitrary ProcScript
instance Arbitrary ProcScript where
arbitrary = parbitrary
emptyScript :: ProcScript
emptyScript = ProcScript {
proc_preamble = emptyCode
, proc_setup = emptyCode
, proc_draw = Nothing
, proc_mouseClicked = Nothing
, proc_mouseReleased = Nothing
, proc_keyPressed = Nothing
}
pvoid :: Pretty a => Text -> Maybe a -> Doc
pvoid _ Nothing = Text.PrettyPrint.Mainland.empty
pvoid n (Just c) = fromText "void" <+> fromText n <> fromText "()" <+> enclose lbrace rbrace inside
where
inside = line <> indent indentLevel (ppr c) <> line
instance Pretty ProcScript where
ppr ps = stack [
ppr $ proc_preamble ps
, pvoid "setup" $ Just $ proc_setup ps
, pvoid "draw" $ proc_draw ps
, pvoid "mouseClicked" $ proc_mouseClicked ps
, pvoid "mouseReleased" $ proc_mouseReleased ps
, pvoid "keyPressed" $ proc_keyPressed ps
]