processing 1.1.0.0 → 1.2.0.0
raw patch · 14 files changed
+2011/−479 lines, 14 filesdep +QuickCheckdep +quickcheck-instancesdep +template-haskelldep ~directorydep ~filepath
Dependencies added: QuickCheck, quickcheck-instances, template-haskell
Dependency ranges changed: directory, filepath
Files
- Graphics/Web/Processing/Core/Interface.hs +10/−1
- Graphics/Web/Processing/Core/Monad.hs +64/−12
- Graphics/Web/Processing/Core/Primal.hs +516/−191
- Graphics/Web/Processing/Core/TH.hs +452/−0
- Graphics/Web/Processing/Core/Types.hs +9/−2
- Graphics/Web/Processing/Core/Var.hs +5/−2
- Graphics/Web/Processing/Mid.hs +23/−12
- Graphics/Web/Processing/Mid/CustomVar.hs +132/−47
- Graphics/Web/Processing/Optimize.hs +218/−165
- Graphics/Web/Processing/Simple.hs +7/−7
- examples/pacman.hs +487/−0
- examples/pacman.map +31/−0
- license +30/−30
- processing.cabal +27/−10
Graphics/Web/Processing/Core/Interface.hs view
@@ -53,7 +53,7 @@ -- * Others , frameCount , getFrameRate- , writeComment+ , comment -- * Processing monads , ProcMonad ) where@@ -73,6 +73,7 @@ import Graphics.Web.Processing.Core.Var -- import Control.Arrow (first)+import Data.Text (Text) ---- PREDEFINED VALUES @@ -385,3 +386,11 @@ -- The default rate is 60 frames per second. setFrameRate :: ProcMonad m => Proc_Int -> m Setup () setFrameRate r = commandM "frameRate" [proc_arg r]++---- COMMENTS++-- | Include a comment in the current position of the code.+-- You normally don't need to read the processing.js code output,+-- but this function can be useful to analyse or debug it.+comment :: ProcMonad m => Text -> m c ()+comment = writeComment
Graphics/Web/Processing/Core/Monad.hs view
@@ -5,6 +5,8 @@ , runProcM, execProcM , runProcMWith , ProcMonad (..)+ , readArrayVar+ , writeArrayVar , newVarNumber , getVarNumber , setVarNumber@@ -31,6 +33,19 @@ -- to generate the corresponding Processing code under the 'ProcCode' type. newtype ProcM c a = ProcM { unProcM :: StateT Int (Writer (ProcCode c)) a } +{- ProcM monad definition++On the inside, ProcM is a monad which stores both a counter and some+processing code. The purpose of the counter is to give each variable+an unique name. Using an inner writer monad, using 'tell', we append+processing code. Each time we append the creation of a new var, we+generate the name of that variable depending on the state of the+counter. For example, if the counter is in 2, the variable will be+named "v_2" (see 'intVarNumber'). The context of the ProcCode stored+in the inner writer monad is propagated to the ProcM monad. ++-}+ -- | Generate Processing code using the 'ProcM' monad. -- The code output is reduced. runProcM :: ProcM c a -> (a,ProcCode c)@@ -60,7 +75,7 @@ return = pure (ProcM w) >>= f = ProcM $ w >>= unProcM . f --- | Adds @1@ to the variable counter and returns the result.+-- | Add @1@ to the variable counter and returns the result. newVarNumber :: ProcM c Int newVarNumber = ProcM $ modify (+1) >> get @@ -78,15 +93,17 @@ -- Processing Monad class -- | Types in this instance form a monad when they are applied--- to a context @c@. Then, they are used to write Processing+-- to a context @c@. They are used to write Processing -- code. class ProcMonad m where -- | Internal function to process commands in the target monad. commandM :: Text -> [ProcArg] -> m c () -- | Internal function to process asignments in the target monad.- assignM :: ProcAsign -> m c ()+ assignM :: ProcAssign -> m c () -- | Internal function to process variable creations in the target monad.- createVarM :: ProcAsign -> m c ()+ createVarM :: ProcAssign -> m c ()+ -- | Internal function to process array varaible creations in the target monad.+ createArrayVarM :: Text -> ProcList -> m c () -- | Write a comment in the code. writeComment :: Text -> m c () -- | Conditional execution.@@ -98,6 +115,8 @@ liftProc :: ProcM c a -> m c a -- | Create a new variable with a starting value. newVar :: ProcType a => a -> m Preamble (Var a)+ -- | Create a new array variable with a starting list of values.+ newArrayVar :: ProcType a => [a] -> m Preamble (ArrayVar a) -- | Read a variable. readVar :: ProcType a => Var a -> m c a -- | Write a new value to a variable.@@ -106,7 +125,7 @@ -- | When using this instance, please, be aware of the -- behavior of 'readVar'. ----- /It does not matter when read the variable/.+-- /It does not matter when the variable is read/. -- The result will /always/ hold the last value asigned to the variable. -- For example, this code --@@ -117,21 +136,54 @@ -- -- will draw a point at (10,20). instance ProcMonad ProcM where- commandM n as = ProcM $ lift $ tell $ command n as- assignM = ProcM . lift . tell . assignment- createVarM = ProcM . lift . tell . createVar- writeComment = ProcM . lift . tell . comment+ -- commandM, assignM, createVarM, createArrayVarM and writeComment+ -- send, using 'tell', to the inner writer monad.+ commandM n as = ProcM $ lift $ tell $ Command n as+ assignM = ProcM . lift . tell . Assignment+ createVarM = ProcM . lift . tell . CreateVar+ createArrayVarM n xs = ProcM $ lift $ tell $ CreateArrayVar n xs+ writeComment = ProcM . lift . tell . Comment+ -- Conditionals are a bit trickier. We need to make sure that+ -- the variable number traverses the conditional and keeps any+ -- modifications performed inside the conditional. iff b (ProcM e1) (ProcM e2) = ProcM $ do i0 <- get let (i1,c1) = runWriter $ execStateT e1 i0 (i2,c2) = runWriter $ execStateT e2 i1 put i2- lift $ tell $ conditional b c1 c2+ lift $ tell $ Conditional b c1 c2+ -- The method liftProc is useful for other mondas, like EventM+ -- or ScriptM that are built in top of ProcM. liftProc = id+ -- Create a new variable, automatically asigning a name depending+ -- on the current variable number. newVar x = do n <- newVarNumber let v = intVarName n- createVarM (proc_asign v x)+ createVarM (proc_assign v x) return $ varFromText v+ newArrayVar xs = do+ n <- newVarNumber+ let v = intVarName n+ createArrayVarM v $ proc_list xs+ return $ arrayVarFromText (length xs) v readVar = return . proc_read- writeVar v x = assignM $ proc_asign (varName v) x+ writeVar v x = assignM $ proc_assign (varName v) x++-- | Read a component of an array variable.+readArrayVar :: (ProcMonad m, Monad (m c), ProcType a) => ArrayVar a -> Proc_Int -> m c a+readArrayVar v n =+ case n of+ Proc_Int i -> let s = arraySize v+ in if (i < 0) || (i >= s)+ then fail $ "readArrayVar: index out of bounds.\nArray size: "+ ++ show s+ ++ ".\nIndex given: "+ ++ show i+ ++ ".\nRemember that indices start from 0."+ else readVar $ arrayVarToVar v n+ _ -> readVar $ arrayVarToVar v n++-- | Write a component of an array variable.+writeArrayVar :: (ProcMonad m, ProcType a) => ArrayVar a -> Proc_Int -> a -> m c ()+writeArrayVar v n x = writeVar (arrayVarToVar v n) x
Graphics/Web/Processing/Core/Primal.hs view
@@ -1,8 +1,13 @@ -{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, FunctionalDependencies,+ DeriveGeneric, TypeOperators, DefaultSignatures, FlexibleContexts,+ TemplateHaskell+ #-} --- | Internal module. Mostly for type definitions--- and class instances.+{- | Internal core module.+The purpose of this module is to define the most basic types+and write the necessary instances for them.+-} module Graphics.Web.Processing.Core.Primal ( -- * Types -- ** Singleton types@@ -11,17 +16,18 @@ Preamble (..), Setup (..), Draw (..) , MouseClicked (..), MouseReleased (..) , KeyPressed (..)+ -- ** Recursive types+ , Recursive (..) -- ** @Proc_*@ types -- *** Boolean , Proc_Bool (..), fromBool , true, false , pnot, (#||), (#&&) -- *** Int- , Proc_Int, fromInt+ , Proc_Int (..), fromInt , pfloor, pround -- *** Float , Proc_Float (..), fromFloat- , recFloat , intToFloat , noisef -- *** Image@@ -30,11 +36,15 @@ , Proc_Char , fromChar -- *** Text , Proc_Text, fromStText+ , (+.+)+ , Proc_Show (..) -- *** Keys , Proc_Key (..) , Proc_KeyCode (..) -- ** Type class of proc types , ProcType (..)+ , isVarInArg, isVarInAssign+ , assignVarName -- ** Conditionals , Proc_Eq (..) , Proc_Ord (..)@@ -42,36 +52,138 @@ , Reducible (..) -- ** Variables , Var, varName, varFromText+ , ArrayVar, arrayVarName, arrayVarFromText+ , arraySize+ , arrayVarToVar -- ** Script- , ProcCode (..), ProcArg (..), ProcAsign (..)+ , ProcCode (..), ProcArg (..), ProcAssign (..)+ , ProcList (..) , emptyCode- , command , assignment, createVar, comment- , conditional , (>>.) , ProcScript (..) , emptyScript ) where -{- Notes on this module--This module needs some work to be refactored, probably-in different submodules. Currently, it's getting too long-and is potentially going to grow even more. Also, it has-code for unrelated tasks: types, code reduction, variables,-events, etc. I think 'Reducible' deserves a module by itself.---}- import Prelude hiding (foldr)-import Data.Text (Text,lines)+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 (liftA2)+import Control.Applicative -- Pretty import Text.PrettyPrint.Mainland+-- QuickCheck+import Test.QuickCheck (Arbitrary (..), Gen, oneof, sized, resize, vectorOf)+import Test.QuickCheck.Instances()+-- Meta-programming+import GHC.Generics+import Graphics.Web.Processing.Core.TH +------------------------------------------------+-- QUICK CHECK DERIVING++{-++Some of the types defined in this module have a big+amount of data constructors. Creating Arbitrary instances+for each of them manually is a tedious and unnecessary work.++In order to be able to derive automatically instance for+the arbitrary typeclass, we create a new class, PArbitrary+(from Processing Arbitrary). Having access to the class+definition, we can provide a default instance based in our+generic deriving. Once an instance to PArbitrary is done,+the Arbitrary instance is trivial:++instance Arbitrary a where+ arbitrary = parbitrary++Given the number of data constructors, and being most of them+recursive, if we create totally random values, the chances of+creating (insanely) huge values is very high. To avoid it, we+set a maximum number of random steps (see 'sizeLimit'). When+this number is reached, we "travel" to the left-most constructor,+which by definition will be finite (something like Proc_Float Float).++-}++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++------------------------------------------------+-- DEFAULT INSTANCES++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++------------------------------------------------++{-+Processing.js code is divided in different sections.+Each section handles a different event. Naturally,+there are commands that may be called inside of a+particular context, but not within another. Most of+these commands are runnable in different kind of+events. Writing variables should be possible from+any event. To handle this situation, we annotate+the AST with a /context/. This context indicates+which event that portion of code belongs to. For+example, @ProcCode Draw@ indicates that the code+belongs to the draw loop. Now we can restrict+functions to work only under certain contexts.+For example, variables should be created only once.+Since events may be called several times, we restrict+the type of any function that creates variables,+annotating the type with 'Preamble'.+-}+ -- | The /preamble/ is the code that is executed -- at the beginning of the script. data Preamble = Preamble@@ -99,26 +211,91 @@ -- TYPES +{-++Some Proc_* types can be seen as extensions+of some Haskell types. For example Proc_Float+may contain a Float under the Proc_Float data+constructor. However, it has more data constructors+and, therefore, it may contain other different+values. The Extended class is created for+these types. It provides two methods that, once+defined, permit to extend functions and operators+from the type that has been extended to the extension.+For example, we can extend the sin function, which+is defined for Float values, to value of the type+Proc_Float.++The two methods required are extend and patmatch+(pattern match). The method extend should inject+a value from the extended type to the extension.+The method patmatch would do the opposite. However,+not every element in the extension belongs to the+extended type. We return Nothing in those cases.++Extended functions and operators behave the same+way as the originals for values in the extended+type. A supplied default function/operator+indicates what to do in the rest of cases.++-}+ class Extended from to | to -> from where extend :: from -> to patmatch :: to -> Maybe from -extendf :: Extended from to- => (from -> from) -> (to -> to) -> (to -> to)+-- | Function extension.+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- => (from -> from -> from)- -> (to -> to -> to)- -> (to -> to -> to)+-- | Operator extension.+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 of recursive types.++The 'recursor' function applies the+given function to every subexpression+of the same type. For example, this would+be the recursor over lists:++recursor f [] = []+recursor f (x:xs) = x : f xs++Instances of Recursive can be derived+using $(deriveRecursive ''Type).+-}+class Recursive a where+ recursor :: (a -> a) -> a -> a++{- Proc_* types++Proc_* types are AST's for different kind+of expressions. For example, a value of type+Proc_Bool store an AST of a boolean expression.+The "Proc_" prefix indicates that the type+of the expression matches a type in Processing.++Proc_* types have a specialized version of+'extend'. This way, the Extended class can be+kept hidden to the user. If this is or not a+good idea is something to be discussed.+Note that the class use Functional Dependencies.++-}+ -- | Boolean values. data Proc_Bool = Proc_True@@ -157,8 +334,13 @@ | KeyCode_Eq Proc_KeyCode Proc_KeyCode -- Conditional | Bool_Cond Proc_Bool Proc_Bool Proc_Bool- deriving (Eq,Ord)+ 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@@ -186,9 +368,16 @@ docG :: Doc docG = fromText ">" +-- | Processing.js syntax for conditionals.+--+-- > <bool> ? <a> : <a>+-- docCond :: Doc -> Doc -> Doc -> Doc docCond _if _then _else = _if <+> fromText "?" <+> _then <+> fromText ":" <+> _else +-- | This constant indicates how many spaces+-- are added in each indentation. Events+-- and conditionals add indentation. indentLevel :: Int indentLevel = 3 @@ -219,6 +408,7 @@ 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+ -- Conditional ppr (Bool_Cond b x y) = parens $ docCond (ppr b) (ppr x) (ppr y) -- | Value of 'True'.@@ -266,8 +456,13 @@ | Int_Round Proc_Float -- Conditional | Int_Cond Proc_Bool Proc_Int Proc_Int- deriving Eq+ 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@@ -292,18 +487,11 @@ -- | Calculate the 'floor' of a 'Proc_Float'. pfloor :: Proc_Float -> Proc_Int-pfloor (Proc_Float x) = Proc_Int $ floor x-pfloor x = Int_Floor x+pfloor = extendf floor Int_Floor -- | Round a number to the closest integer. pround :: Proc_Float -> Proc_Int-pround (Proc_Float x) = Proc_Int $ round x-pround x = Int_Round x--instance Ord Proc_Int where- n <= m = case liftA2 (<=) (patmatch n) (patmatch m) of- Nothing -> error "Proc_Int: (<=) applied to a variable."- Just b -> b+pround = extendf round Int_Round instance Enum Proc_Int where toEnum = fromInt@@ -330,7 +518,8 @@ instance Integral Proc_Int where div = extendop div Int_Divide mod = extendop mod Int_Mod- divMod n d = (div n d, mod n d)+ 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@@ -346,6 +535,7 @@ | Float_Divide Proc_Float Proc_Float | Float_Mult Proc_Float Proc_Float | Float_Mod Proc_Float Proc_Float+ | Float_Neg Proc_Float -- Variables | Float_Var Text -- Functions@@ -365,43 +555,25 @@ | Float_Random Proc_Float Proc_Float -- Conditional | Float_Cond Proc_Bool Proc_Float Proc_Float- deriving (Eq,Ord)+ 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 --- | /Float recursion/. Applies a function to the subexpressions--- of a 'Proc_Float'.-recFloat :: (Proc_Float -> Proc_Float) -> Proc_Float -> Proc_Float-recFloat f (Float_Sum x y) = Float_Sum (f x) (f y)-recFloat f (Float_Substract x y) = Float_Substract (f x) (f y)-recFloat f (Float_Divide x y) = Float_Divide (f x) (f y)-recFloat f (Float_Mult x y) = Float_Mult (f x) (f y)-recFloat f (Float_Mod x y) = Float_Mod (f x) (f y)-recFloat f (Float_Abs x) = Float_Abs $ f x-recFloat f (Float_Exp x) = Float_Exp $ f x-recFloat f (Float_Sqrt x) = Float_Sqrt $ f x-recFloat f (Float_Log x) = Float_Log $ f x-recFloat f (Float_Sine x) = Float_Sine $ f x-recFloat f (Float_Cosine x) = Float_Cosine $ f x-recFloat f (Float_Arcsine x) = Float_Arcsine $ f x-recFloat f (Float_Arccosine x) = Float_Arccosine $ f x-recFloat f (Float_Arctangent x) = Float_Arctangent $ f x-recFloat f (Float_Floor x) = Float_Floor $ f x-recFloat f (Float_Round x) = Float_Round $ f x-recFloat f (Float_Noise x y) = Float_Noise (f x) (f y)-recFloat f (Float_Cond b x y) = Float_Cond b (f x) (f y)-recFloat f (Float_Random x y) = Float_Random (f x) (f y)-recFloat _ x = x- 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]@@ -414,7 +586,7 @@ 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 "found" [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]@@ -448,6 +620,7 @@ (-) = 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@@ -455,7 +628,8 @@ fromRational = fromFloat . fromRational -- | WARNING: 'sinh', 'cosh', 'asinh', 'acosh' and 'atanh'--- methods are undefined.+-- methods are undefined. They are not present in+-- processing.js. instance Floating Proc_Float where pi = extend pi exp = extendf exp Float_Exp@@ -477,8 +651,13 @@ data Proc_Image = Image_Var Text | Image_Cond Proc_Bool Proc_Image Proc_Image- deriving Eq+ 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)@@ -488,8 +667,13 @@ Proc_Char Char | Char_Var Text | Char_Cond Proc_Bool Proc_Char Proc_Char- deriving (Eq,Ord)+ 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@@ -505,13 +689,35 @@ ppr (Char_Cond b x y) = parens $ docCond (ppr b) (ppr x) (ppr y) -- | Type of textual values.+--+-- It is recommended to enable the @OverloadedStrings@ extension.+-- Note that 'Proc_Text' is an instance of the 'IsString' class. data Proc_Text = Proc_Text Text | Text_Var Text+ -- Proc_Show+ -- See <http://processingjs.org/reference/str_> for avaiable+ -- types.+ | Show_Bool Proc_Bool+ | Show_Char Proc_Char+ | Show_Float Proc_Float+ | Show_Int Proc_Int+ -- String appending+ | Text_Append Proc_Text Proc_Text -- Conditional | Text_Cond Proc_Bool Proc_Text Proc_Text- deriving (Eq,Ord)+ deriving (Eq,Ord,Generic)+ +infixr 5 +.+ +-- | Append two text strings.+(+.+) :: 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@@ -522,6 +728,15 @@ -- escape characters. 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]+ -- No parenthesis are included since appending is the+ -- only operation over text.+ ppr (Text_Append x y) = ppr x <+> fromText "+" <+> ppr y+ -- ppr (Text_Cond b x y) = parens $ docCond (ppr b) (ppr x) (ppr y) -- | Cast a strict 'Text' value.@@ -531,13 +746,32 @@ instance IsString Proc_Text where fromString = fromStText . fromString +-- | Similar to the 'Show' class, but for @Proc_*@ types.+class Proc_Show a where+ -- | Render a value as a 'Proc_Text'.+ 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+ -- | Type of keyboard keys. data Proc_Key = Key_Var | Key_CODED | Key_Char Char- deriving (Eq,Ord)+ deriving (Eq,Ord,Generic) +instance PArbitrary Proc_Key+ instance Pretty Proc_Key where ppr Key_Var = fromText "key" ppr Key_CODED = fromText "CODED"@@ -559,8 +793,10 @@ | KeyCode_RETURN | KeyCode_ESC | KeyCode_DELETE- deriving (Eq,Ord)+ deriving (Eq,Ord,Generic) +instance PArbitrary Proc_KeyCode+ instance Pretty Proc_KeyCode where ppr KeyCode_Var = fromText "keyCode" ppr KeyCode_UP = fromText "UP"@@ -577,71 +813,139 @@ ppr KeyCode_ESC = fromText "ESC" ppr KeyCode_DELETE = fromText "DELETE" ++-- END OF PROC_* TYPES+----------------------------------------------+----------------------------------------------++{- Proc_* type mechanics++Three types are automatically generated for the+Proc_* types. These are ProcArg, ProcAssign and ProcList.+A processing command may receive several arguments+of the same or different Proc_* types.+We encode arguments under the ProcArg type. The+ProcArg type is the disjoint union of the different+Proc_* types. For a complete list, see the+Graphics.Web.Processing.Core.TH module.+The list is called procTypeNames.++In the other hand, variable assignments are also+encoded in a particular type, named ProcAssign.+The ProcAssign type is the disjoint union of the+product of each Proc_* type with Text. This means+that a value of this type contains a value of any+of the different Proc_* types together with a value+of type Text. This text represents the name of the+variable in the assignment.++ProcList is a type for lists of processing values,+used in the implementation of arrays. The ProcList+type is the disjoint union of each Proc_* type+embedded into a list.++All ProcArg, ProcAssign and ProcList are generated+automatically, together with instances of the+Pretty class, by procTypeMechs.+Compile with "-f info" to see the generated+code. The structure for each Proc_* type is as+follows:++data ProcArg = (union in *) *Arg Proc_*++instance Pretty ProcArg where+ (for each *) ppr (*Arg x) = ppr x++data ProcAssign = (union in *) *Assign Text Proc_*++instance Pretty ProcAssign where+ (for each *) ppr (*Assign t x) =+ fromText t <+> fromText "=" <+> ppr x++data ProcList = (union in *) *List [Proc_*]++instance Pretty ProcList where+ (for each *) ppr (*List xs) =+ fromText "{" <> commasep (fmap ppr xs) <> fromText "}"++In addition, the following two functions are defined.++ptype :: ProcAssign -> Doc+(for each *) ptype (*Assign _ _) = fromText "Name of * in processing.js"++ltype :: ProcList -> Doc+(for each *) ltype (*List _) = fromText $ "Name of * in processing.js" ++ "[]"++-}++$(procTypeMechs)++instance PArbitrary ProcArg++instance Arbitrary ProcArg where+ arbitrary = parbitrary++instance PArbitrary ProcAssign++instance PArbitrary ProcList+ -- CODE -- | A piece of Processing code. -- The type parameter indicates what the -- context of the code is. -- This context will allow or disallow--- the use of certain commands.+-- the use of certain commands along+-- different events. data ProcCode c = Command Text [ProcArg] - | CreateVar ProcAsign- | Assignment ProcAsign+ | CreateVar ProcAssign+ | CreateArrayVar Text ProcList+ | Assignment ProcAssign | Conditional Proc_Bool -- IF (ProcCode c) -- THEN (ProcCode c) -- ELSE | Comment Text | Sequence (Seq.Seq (ProcCode c))- deriving Eq+ 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 ";"+ -- ptype is defined by $(procTypeMechs). ppr (CreateVar a) = ptype a <+> ppr a <+> fromText ";"+ -- ltype is defined by $(procTypeMechs).+ 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)- <+> fromText "else" <+> enclose lbrace rbrace (line <> c2)+ <+> 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 --- | Code for commands.-command :: Text -- ^ Name of the command.- -> [ProcArg] -- ^ Arguments.- -> ProcCode c -- ^ Code result.-command = Command---- | Code for assignments.-assignment :: ProcAsign -- ^ Assignment.- -> ProcCode c -- ^ Code result.-assignment = Assignment---- | Code for variable creation.-createVar :: ProcAsign -- ^ Initial assignment.- -> ProcCode c -- ^ Code result.-createVar = CreateVar---- | Code for comments.-comment :: Text -> ProcCode c-comment = Comment---- | Code for conditionals.-conditional :: Proc_Bool -> ProcCode c -> ProcCode c -> ProcCode c-conditional = Conditional- -- | Sequence to pieces of code with the same -- context type. This way, code that belongs -- to different parts of the program will -- never get mixed. (>>.) :: ProcCode c -> ProcCode c -> ProcCode c (Sequence xs) >>. (Sequence ys) = Sequence $ xs Seq.>< ys-(Sequence xs) >>. p = Sequence $ xs Seq.|> p-p >>. (Sequence xs) = Sequence $ p Seq.<| xs+(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] -- | An empty piece of code.@@ -652,51 +956,6 @@ mempty = emptyCode mappend = (>>.) --- | A command argument.-data ProcArg =- BoolArg Proc_Bool- | IntArg Proc_Int- | FloatArg Proc_Float- | ImageArg Proc_Image- | TextArg Proc_Text- | CharArg Proc_Char- deriving Eq--instance Pretty ProcArg where- ppr (BoolArg b) = ppr b- ppr (IntArg i) = ppr i- ppr (FloatArg f) = ppr f- ppr (ImageArg i) = ppr i- ppr (TextArg t) = ppr t- ppr (CharArg c) = ppr c---- | Assigments.-data ProcAsign =- BoolAsign Text Proc_Bool- | IntAsign Text Proc_Int- | FloatAsign Text Proc_Float- | ImageAsign Text Proc_Image- | TextAsign Text Proc_Text- | CharAsign Text Proc_Char- deriving Eq--instance Pretty ProcAsign where- ppr (BoolAsign n b) = fromText n <+> fromText "=" <+> ppr b- ppr (IntAsign n i) = fromText n <+> fromText "=" <+> ppr i- ppr (FloatAsign n f) = fromText n <+> fromText "=" <+> ppr f- ppr (ImageAsign n i) = fromText n <+> fromText "=" <+> ppr i- ppr (TextAsign n t) = fromText n <+> fromText "=" <+> ppr t- ppr (CharAsign n c) = fromText n <+> fromText "=" <+> ppr c---- | Returns the name of the type (processing version) in an assignment.-ptype :: ProcAsign -> Doc-ptype (BoolAsign _ _) = fromText "boolean"-ptype (IntAsign _ _) = fromText "int"-ptype (FloatAsign _ _) = fromText "float"-ptype (ImageAsign _ _) = fromText "PImage"-ptype (TextAsign _ _) = fromText "String"-ptype (CharAsign _ _) = fromText "char"- ---- ProcType class and instances -- | Type of variables.@@ -707,6 +966,27 @@ varFromText :: Text -> Var a varFromText = Var +-- | Type of variables storing arrays.+data ArrayVar a =+ ArrayVar { -- | Size of the array.+ arraySize :: Int+ , innerVar :: Var a }++-- | Get the name of a variable storing an array.+arrayVarName :: ArrayVar a -> Text+arrayVarName = varName . innerVar++-- | Internal function to create array variables.+arrayVarFromText :: Int -> Text -> ArrayVar a+arrayVarFromText n t = ArrayVar n (Var t)++-- | Translate an Array variable to the correspondent+-- component variable.+arrayVarToVar :: ArrayVar a -> Proc_Int -> Var a+arrayVarToVar v n = varFromText $ arrayVarName v <> "[" <> f n <> "]"+ where+ f = toStrict . prettyLazyText 80 . ppr+ ----- CLASSES -- | Class of Processing value types (@Proc_*@ types).@@ -733,50 +1013,58 @@ class ProcType a where -- | Create a variable assignment, provided -- the name of the variable and the value to asign.- proc_asign :: Text -> a -> ProcAsign+ proc_assign :: Text -> a -> ProcAssign+ -- | Create a list.+ proc_list :: [a] -> ProcList -- | Create an argument for a command. proc_arg :: a -> ProcArg -- | Variable reading. proc_read :: Var a -> a -- | Conditional value. proc_cond :: Proc_Bool -> a -> a -> a+ -- | Check if a variable is contained in an expression.+ checkForVar :: Text -> a -> Bool -instance ProcType Proc_Bool where- proc_asign = BoolAsign- proc_arg = BoolArg- proc_read (Var v) = Bool_Var v- proc_cond = Bool_Cond+{- Template Haskell and Proc_* types. -instance ProcType Proc_Int where- proc_asign = IntAsign- proc_arg = IntArg- proc_read (Var v) = Int_Var v- proc_cond = Int_Cond+Template Haskell is used in order to derive instances+of the ProcType class. These instances consist merely+in select the appropiate data constructor of the+appropiate datatype. Use "-f info" when compiling+with cabal to see the generated instances. This is+the general format for each Proc_* type: -instance ProcType Proc_Float where- proc_asign = FloatAsign- proc_arg = FloatArg- proc_read (Var v) = Float_Var v- proc_cond = Float_Cond+instance ProcType Proc_* where+ proc_assign = *Assign+ proc_list = *List+ proc_arg = *Arg+ proc_read (Var v) = *_Var v+ proc_cond = *_Cond -instance ProcType Proc_Image where- proc_asign = ImageAsign- proc_arg = ImageArg- proc_read (Var v) = Image_Var v- proc_cond = Image_Cond+-} -instance ProcType Proc_Char where- proc_asign = CharAsign- proc_arg = CharArg- proc_read (Var v) = Char_Var v- proc_cond = Char_Cond+$(deriveProcTypeInsts) -instance ProcType Proc_Text where- proc_asign = TextAsign- proc_arg = TextArg- proc_read (Var v) = Text_Var v- proc_cond = Text_Cond+{- Eq and Ord classes for Proc_* types +Since Proc_* types represent expressions,+they cannot be compared in the usual way.+We cannot decide if two expressions will reduce+to the same value. In fact, sometimes they will,+and sometimes they will not. What we can do is+to, given two expressions, return a boolean+expression, which will evaluate to the correct+value in the appropiate context.++Therefore, we define the Proc_Eq and Proc_Ord+classes similarly to Eq and Ord, but returning+a Proc_Bool value instead of a Bool value.++Operators have the same name than their+analagous, but preceded with #.++-}+ infix 4 #==, #/= -- | 'Eq' class for @Proc_*@ values.@@ -833,12 +1121,28 @@ (#>=) = Float_GE (#>) = Float_G +{- Proc_* types and recursion++Since some of the Proc_* types are recursive,+we derive the correspondent instances using+Template Haskell. Otherwise, they would be+long and tedious.++-}++$(deriveRecursive ''Proc_Bool)+$(deriveRecursive ''Proc_Int)+$(deriveRecursive ''Proc_Float)+ -- | Class of reducible types. Values of these -- types contain expressions that can be -- reducible. class Eq a => Reducible a where reduce :: a -> a +-- | Find a fix point of the 'reduce' function from+-- any value. If 'reduce' is well defined, this function+-- must end. iteratedReduce :: Reducible a => a -> a iteratedReduce = fst . firstWith (uncurry (==)) . pairing . iterate reduce where@@ -852,7 +1156,7 @@ FLOAT REDUCTION Float is probably the most common argument type.-Below a case-by-case analysis try to reduce a+Below a case-by-case analysis tries to reduce a float expression to its minimal extension. The more we reduce, the more effective will be the Processing output code, since we save@@ -861,24 +1165,40 @@ -} instance Reducible Proc_Float where- reduce (Float_Sum x y) =- if x == y then 2 * reduce x- else reduce x + reduce y- reduce (Float_Substract x y) =- if x == y then 0- else reduce x - reduce y- reduce (Float_Mult x y) =- if x == y- -- x*x = x^2- then reduce x ** 2- else reduce x * reduce y+ -- Distribution+ 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+ -- x + (-y) = x - y+ reduce (Float_Sum x (Float_Neg y)) = reduce $ Float_Substract x y+ -- (-x) + y = y - x+ 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+ -- x - (-y) = x + 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 -- (x*y)/z = y*(x/z) reduce (Float_Divide (Float_Mult (Proc_Float x) y) (Proc_Float z)) = reduce $ (y*) $ Proc_Float $ x / z -- (x*y)/z = x*(y/z) reduce (Float_Divide (Float_Mult x (Proc_Float y)) (Proc_Float z)) = reduce $ (x*) $ Proc_Float $ y / z- reduce x = recFloat reduce x+ reduce x = recursor reduce x instance Reducible ProcArg where reduce (FloatArg x) = FloatArg $ iteratedReduce x@@ -933,7 +1253,12 @@ , 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 -- | Empty script. emptyScript :: ProcScript
+ Graphics/Web/Processing/Core/TH.hs view
@@ -0,0 +1,452 @@++{-# LANGUAGE TemplateHaskell #-}++-- | Template Haskell, i.e. where magic happens.+module Graphics.Web.Processing.Core.TH (+ deriveRecursive+ , procTypeMechs+ , deriveProcTypeInsts+ , deriveCustomValues+ , deriveOptimizable+ ) where++import Language.Haskell.TH+import Control.Monad+import Data.Maybe (catMaybes)+import Data.List (isSuffixOf)++{- About this module++This module gathers all the Template Haskell definitions+of the library.++Currently, the code is a mess, even when it works as+expected. However, that it works is not enough. The+code should be readable and easy to maintain as well.+Therefore, refactor this module and write the appropiate+code annotations to make it easy to understand is in+the to-do list.++-}++{- RECURSOR -}++-- | Define recursor over a data type. The recursor will apply an inner function+-- over subexpressions of the same type.+defineRecursor :: Name -> Q Dec+defineRecursor t = do+ (TyConI (DataD _ _ _ cs _)) <- reify t+ let cs' = filter (\(NormalC _ args_) ->+ let args = fmap snd args_+ in elem (ConT t) args+ ) cs+ binds <- mapM (\(NormalC n args_) -> do+ let args = fmap snd args_+ vars <- mapM (const $ newName "x") args+ return $ Clause [VarP (mkName "f") , ConP n (fmap VarP vars)]+ (NormalB $ foldl AppE (ConE n) $+ zipWith (\v a -> if a == ConT t+ then AppE (VarE $ mkName "f") (VarE v)+ else VarE v+ ) vars args)+ []+ ) cs'+ let lastbind = Clause [WildP,VarP $ mkName "x"] (NormalB $ VarE $ mkName "x") []+ fname = mkName "recursor"+ return $ FunD fname $ binds ++ [lastbind]++-- | Automatic derivation of Recursive class, using 'defineRecursor'.+deriveRecursive :: Name -> Q [Dec]+deriveRecursive t = do+ r <- defineRecursor t+ return . return $ InstanceD [] (AppT (ConT $ mkName "Recursive") (ConT t)) [r]++{- PROC TYPES -}++-- | List of the Proc_* types which can be used as arguments, set into variables, etc.+procTypeNames :: [String]+procTypeNames = [ "Bool", "Int", "Float", "Image", "Text", "Char" ]++-- | Return the actual name of a type used in processing.js code.+realName :: String -> String+realName "Bool" = "boolean"+realName "Int" = "int"+realName "Float" = "float"+realName "Image" = "PImage"+realName "Text" = "String"+realName "Char" = "char"+realName _ = "undefined"++dataProcArg :: Dec+dataProcArg = DataD [] (mkName "ProcArg") [] (fmap cons procTypeNames) [mkName "Eq",mkName "Generic"]+ where+ cons x = NormalC (mkName $ x ++ "Arg") [(NotStrict,ConT $ mkName $ "Proc_" ++ x)]++dataProcAssign :: Dec+dataProcAssign = DataD [] (mkName "ProcAssign") [] (fmap cons procTypeNames) [mkName "Eq",mkName "Generic"]+ where+ cons x = NormalC (mkName $ x ++ "Assign")+ [ (NotStrict,ConT $ mkName "Text")+ , (NotStrict,ConT $ mkName $ "Proc_" ++ x)]++ptype :: [Dec]+ptype = [+ SigD (mkName "ptype") $ AppT ArrowT (ConT $ mkName "ProcAssign") `AppT` (ConT $ mkName "Doc")+ , FunD (mkName "ptype") $ fmap cons procTypeNames+ ]+ where+ cons x = Clause [ConP (mkName $ x ++ "Assign") [WildP,WildP]]+ (NormalB $ AppE (VarE $ mkName "fromText") $ LitE $ StringL $ realName x) []++ltype :: [Dec]+ltype = [+ SigD (mkName "ltype") $ AppT ArrowT (ConT $ mkName "ProcList") `AppT` (ConT $ mkName "Doc")+ , FunD (mkName "ltype") $ fmap cons procTypeNames+ ]+ where+ cons x = Clause [ConP (mkName $ x ++ "List") [WildP]]+ (NormalB $ AppE (VarE $ mkName "fromText") $ LitE $ StringL $ realName x ++ "[]") []++dataProcList :: Dec+dataProcList = DataD [] (mkName "ProcList") [] (fmap cons procTypeNames) [mkName "Eq",mkName "Generic"]+ where+ cons x = NormalC (mkName $ x ++ "List") [(NotStrict,AppT ListT $ ConT $ mkName $ "Proc_" ++ x)]++-- | Pretty instance of ProcList.+procListPrettyInst :: Dec -> Dec+procListPrettyInst procList =+ let DataD _ _ _ cs _ = procList+ _fmap e1 e2 = AppE (VarE $ mkName "fmap") e1 `AppE` e2+ _ppr = VarE $ mkName "ppr"+ _xs = VarE $ mkName "xs"+ _fromText = AppE (VarE $ mkName "fromText")+ _commasep = AppE (VarE $ mkName "commasep")+ e1 <> e2 = InfixE (Just e1) (VarE $ mkName "<>") (Just e2)+ leftbr = _fromText $ LitE $ StringL "{"+ rightbr = _fromText $ LitE $ StringL "}"+ defs = fmap (\(NormalC n _) ->+ Clause [ConP n [VarP $ mkName "xs"]]+ (NormalB $ leftbr <> (_commasep $ _fmap _ppr _xs) <> rightbr)+ []+ ) cs+ inst = FunD (mkName "ppr") defs+ in InstanceD [] (AppT (ConT $ mkName "Pretty") (ConT $ mkName "ProcList")) [inst]++-- | Create 'ProcType' instance for a @Proc_*@ type,+-- given the function declaration of checkForArg.+procTypeInst :: String -> Dec -> Dec+procTypeInst n cfa = InstanceD [] (AppT (ConT $ mkName "ProcType") $ ConT $ mkName $ "Proc_" ++ n)+ [ FunD (mkName "proc_assign") [ Clause [] (NormalB $ ConE $ mkName $ n ++ "Assign") [] ]+ , FunD (mkName "proc_list") [ Clause [] (NormalB $ ConE $ mkName $ n ++ "List") [] ]+ , FunD (mkName "proc_arg" ) [ Clause [] (NormalB $ ConE $ mkName $ n ++ "Arg" ) [] ]+ , FunD (mkName "proc_read" ) [ Clause [ConP (mkName "Var") [VarP $ mkName "v"]]+ ( NormalB $ AppE (ConE $ mkName $ n ++ "_Var")+ (VarE $ mkName "v") )+ [] ]+ , FunD (mkName "proc_cond" ) [ Clause [] (NormalB $ ConE $ mkName $ n ++ "_Cond") [] ]+ , cfa+ ]++(||*) :: Exp -> Exp -> Exp+e1 ||* e2 = InfixE (Just e1) (VarE $ mkName "||") (Just e2)++checkForVar :: String -> Q Dec+checkForVar t = do+ TyConI (DataD _ _ _ cs _) <- reify $ mkName $ "Proc_" ++ t+ ds <- sequence + [ do vs <- mapM (\(ConT a) -> if elem (nameBase a) $ fmap ("Proc_"++) procTypeNames+ then fmap Just $ newName "x"+ else return Nothing) $ fmap snd as+ let patf Nothing = WildP+ patf (Just v) = VarP v+ bodyf v = VarE (mkName "checkForVar") `AppE` VarE (mkName "t") `AppE` VarE v+ vs' = catMaybes vs+ return $ Clause [if null vs' then WildP else VarP $ mkName "t" , ConP n $ fmap patf vs]+ (NormalB $ foldr (\x y -> bodyf x ||* y) (ConE $ mkName "False") vs')+ []+ | NormalC n as <- cs+ , let str = nameBase n+ , str /= t ++ "_Var"+ ]+ b <- [| $(dyn "t") == $(dyn "v") |]+ let d = Clause [VarP $ mkName "t" , ConP (mkName $ t ++ "_Var") [VarP $ mkName "v"]]+ (NormalB b)+ []+ return $ FunD (mkName "checkForVar") $ d : ds++-- | Pretty instance of ProcArg.+procArgPrettyInst :: Dec -> Dec+procArgPrettyInst procArg =+ let DataD _ _ _ cs _ = procArg+ defs = fmap (\(NormalC n _) ->+ Clause [ConP n [VarP $ mkName "x"]]+ (NormalB $ AppE (VarE $ mkName "ppr")+ (VarE $ mkName "x" ) ) [] ) cs+ inst = FunD (mkName "ppr") defs+ in InstanceD [] (AppT (ConT $ mkName "Pretty") (ConT $ mkName "ProcArg")) [inst]++-- | Pretty instance of ProcArg.+procAssignPrettyInst :: Dec -> Dec+procAssignPrettyInst procAssign =+ let DataD _ _ _ cs _ = procAssign+ defs = fmap (\(NormalC n _) ->+ let t = VarE $ mkName "t"+ x = VarE $ mkName "x"+ e1 <+> e2 = InfixE (Just e1) (VarE $ mkName "<+>") (Just e2)+ fromText = AppE $ VarE (mkName "fromText")+ e = fromText t <+> fromText (LitE $ StringL "=") <+> AppE (VarE $ mkName "ppr") x+ in Clause [ConP n [VarP $ mkName "t", VarP $ mkName "x"]] (NormalB e) []+ ) cs+ inst = FunD (mkName "ppr") defs+ in InstanceD [] (AppT (ConT $ mkName "Pretty") (ConT $ mkName "ProcAssign")) [inst]++procTypeMechs :: Q [Dec]+procTypeMechs =+ -- ProcArg Pretty instance+ let argp = procArgPrettyInst dataProcArg+ -- ProcAssign Pretty instance+ assignp = procAssignPrettyInst dataProcAssign+ -- ProcList Pretty instance+ listp = procListPrettyInst dataProcList+ -- Everything+ in return $ [ dataProcArg , argp+ , dataProcAssign , assignp+ , dataProcList , listp ] ++ ptype ++ ltype++deriveProcTypeInsts :: Q [Dec]+deriveProcTypeInsts = fmap (++isVarIn) $ mapM (+ \t -> do d <- checkForVar t+ return $ procTypeInst t d+ ) procTypeNames++isVarIn :: [Dec]+isVarIn = isVarInArg ++ isVarInAssign ++ assignVarName++-- isVarInArg :: Text -> ProcArg -> Bool+isVarInArg :: [Dec]+isVarInArg = [ SigD (mkName "isVarInArg") $ textt ->. argt ->. boolt+ , FunD (mkName "isVarInArg") $ fmap f procTypeNames ]+ where+ textt = ConT $ mkName "Text"+ argt = ConT $ mkName "ProcArg"+ boolt = ConT $ mkName "Bool"+ f t = Clause [VarP $ mkName "t" , ConP (mkName $ t ++ "Arg") [VarP $ mkName "x"]]+ (NormalB $ VarE (mkName "checkForVar") `AppE` VarE (mkName "t") `AppE` VarE (mkName "x"))+ []++-- isVarInAssign :: Text -> ProcAssign -> Bool+isVarInAssign :: [Dec]+isVarInAssign = [ SigD (mkName "isVarInAssign") $ textt ->. argt ->. boolt+ , FunD (mkName "isVarInAssign") $ fmap f procTypeNames ]+ where+ textt = ConT $ mkName "Text"+ argt = ConT $ mkName "ProcAssign"+ boolt = ConT $ mkName "Bool"+ f t = Clause [VarP $ mkName "t" , ConP (mkName $ t ++ "Assign") [WildP, VarP $ mkName "x"]]+ (NormalB $ VarE (mkName "checkForVar") `AppE` VarE (mkName "t") `AppE` VarE (mkName "x"))+ []++-- assignVarName :: ProcAssign -> Text+assignVarName :: [Dec]+assignVarName = [ SigD (mkName "assignVarName") $ ConT (mkName "ProcAssign") ->. ConT (mkName "Text")+ , FunD (mkName "assignVarName") $ fmap f procTypeNames ]+ where+ f t = Clause [ConP (mkName $ t ++ "Assign") [VarP $ mkName "t",WildP]]+ (NormalB $ VarE $ mkName "t") []++infixr 4 ->.++(->.) :: Type -> Type -> Type+t1 ->. t2 = ArrowT `AppT` t1 `AppT` t2++-- CUSTOM VALUES++deriveCustomValues :: Q [Dec]+deriveCustomValues = do+ let xs = fmap varLengthInst procTypeNames+ ys <- mapM customValueInst procTypeNames+ return $ xs ++ ys++varLengthInst :: String -> Dec+varLengthInst t = InstanceD [] (AppT (ConT $ mkName "VarLength") (ConT $ mkName $ "Proc_" ++ t)) [+ FunD (mkName "varLength") [ Clause [WildP] (NormalB $ LitE $ IntegerL 1) [] ]+ ]++customValueInst :: String -> Q Dec+customValueInst t = instanceD (return []) [t|$(conT $ mkName "CustomValue") $(conT $ mkName $ "Proc_" ++ t)|]+ [ funD (mkName "newVarC")+ [ do b <- fmap NormalB $ [|liftM $(dyn "fromVar") . $(dyn "newVar")|]+ return $ Clause [] b []+ ]+ , funD (mkName "newArrayVarC")+ [ do b <- fmap NormalB $ [|liftM $(dyn "fromArrayVar") . $(dyn "newArrayVar")|]+ return $ Clause [] b []+ ]+ , funD (mkName "readVarC")+ [ do b <- fmap NormalB $ [|$(dyn "readVar") . head . $(dyn "fromCustomVar")|]+ return $ Clause [] b []+ ]+ , funD (mkName "writeVarC")+ [ do b <- fmap NormalB $ [|$(dyn "writeVar") (head $ $(dyn "fromCustomVar") $(dyn "v")) $(dyn "x")|]+ return $ Clause [VarP (mkName "v"),VarP (mkName "x")] b []+ ]+ , funD (mkName "ifC")+ [ return $ Clause [] (NormalB $ VarE $ mkName "if_") []+ ]+ ]++-- OPTIMIZATION CLASS++optimizableTypes :: [String]+optimizableTypes = [ "Bool", "Int", "Float" ]++deriveOptimizable :: Q [Dec]+deriveOptimizable = mapM optimizableInst optimizableTypes++optimizableInst :: String -> Q Dec+optimizableInst tn = do+ let t = mkName $ "Proc_" ++ tn+ ts = [ mkName $ "Proc_" ++ str+ | str <- optimizableTypes , str /= tn ]+ -- browse*+ TyConI (DataD _ _ _ cs _) <- reify t+ selfds <- sequence [ browseSelf n $ fmap snd as+ | NormalC n as <- cs ]+ let browseSelfD = FunD (mkName $ "browse" ++ tn) selfds+ browseOthersD <-+ mapM (\ot -> do TyConI (DataD _ _ _ ocs _) <- reify ot+ otherds <- sequence [ browseOther n $ fmap snd as+ | NormalC n as <- ocs ]+ return $ FunD (mkName $ "browse" ++ (drop 5 $ nameBase ot)) otherds+ ) ts+ -- numOps+ numOpsClauses <- sequence [ numOpsC n $ fmap snd as+ | NormalC n as <- tail cs+ , not $ null as+ , let str = nameBase n+ , not $ "Random" `isSuffixOf` str+ , not $ "Var" `isSuffixOf` str+ ]+ let numOpsD = FunD (mkName "numOps") $ numOpsClauses+ ++ [Clause [WildP] (NormalB $ LitE $ IntegerL 0) []]+ -- ReplaceIn*+ let idClause = Clause [WildP,WildP,VarP $ mkName "e"] (NormalB $ VarE $ mkName "e") []+ replaceInSelfCs <- sequence [ replaceInSelfC n $ fmap snd as+ | NormalC n as <- tail cs+ , not $ null as+ , let str = nameBase n+ , not $ "Random" `isSuffixOf` str+ , not $ "Var" `isSuffixOf` str+ ]+ let replaceInSelf = FunD (mkName $ "replaceIn" ++ tn) $ replaceInSelfCs ++ [idClause]+ replaceInOthers <-+ mapM (\ot -> do TyConI (DataD _ _ _ ocs _) <- reify ot+ othersd <- sequence [ replaceInOtherC n $ fmap snd as+ | NormalC n as <- tail ocs+ , not $ null as+ , let str = nameBase n+ , not $ "Random" `isSuffixOf` str+ , not $ "Var" `isSuffixOf` str+ ]+ return $ FunD (mkName $ "replaceIn" ++ (drop 5 $ nameBase ot)) $ othersd ++ [idClause]+ ) ts+ -- Return+ return $ InstanceD [] (ConT (mkName "Optimizable") `AppT` ConT t) $+ (numOpsD : browseSelfD : browseOthersD) +++ (replaceInSelf : replaceInOthers)++replaceInOtherC :: Name -> [Type] -> Q Clause+replaceInOtherC c ts = do+ vs <- mapM (\t -> fmap (\v -> (v,t)) $ newName "x") ts+ let patf (v,_) = VarP v+ bodyf (v,ConT t) = let str = nameBase t+ in if str `elem` fmap ("Proc_"++) optimizableTypes+ then VarE (mkName $ "replaceIn" ++ drop 5 str)+ `AppE` VarE (mkName "o") + `AppE` VarE (mkName "t")+ `AppE` VarE v+ else VarE v+ bodyf _ = error "TH.ReplaceInOther: Bad constructor. Report this as a bug."+ e2 = foldl1 AppE $ ConE c : fmap bodyf vs+ optts = filter (\(ConT t) -> nameBase t `elem` fmap ("Proc_"++) optimizableTypes) ts+ cleanf x = if null optts then WildP else x+ return $ Clause [ cleanf $ VarP $ mkName "o" -- Origin variable+ , cleanf $ VarP $ mkName "t" -- Target variable+ , ConP c $ fmap patf vs]+ (NormalB e2)+ []++replaceInSelfC :: Name -> [Type] -> Q Clause+replaceInSelfC c ts = do+ vs <- mapM (\t -> fmap (\v -> (v,t)) $ newName "x") ts+ let patf (v,_) = VarP v+ b <- [|$(dyn "o") == $(dyn "e")|]+ let e1 = VarE $ mkName "t"+ bodyf (v,ConT t) = let str = nameBase t+ in if str `elem` fmap ("Proc_"++) optimizableTypes+ then VarE (mkName $ "replaceIn" ++ drop 5 str)+ `AppE` VarE (mkName "o") + `AppE` VarE (mkName "t")+ `AppE` VarE v+ else VarE v+ bodyf _ = error "TH.ReplaceInSelf: Bad constructor. Report this as a bug."+ e2 = foldl1 AppE $ ConE c : fmap bodyf vs+ return $ Clause [ VarP $ mkName "o" -- Origin variable+ , VarP $ mkName "t" -- Target variable+ , AsP (mkName "e") $ ConP c $ fmap patf vs]+ (NormalB $ CondE b e1 e2)+ []++(>>>) :: Exp -> Exp -> Exp+e1 >>> e2 = InfixE (Just e1) (VarE $ mkName ">>") (Just e2)++returnu :: Exp+returnu = VarE (mkName "return") `AppE` TupE []++optimizableVars :: [Type] -- Types+ -> Q [Maybe (Name,String)] -- List of pairs (newVar,Proc_* optimizable type without Proc_)+optimizableVars ts = sequence [ if n `elem` fmap ("Proc_"++) optimizableTypes+ then do v <- newName "x"+ return $ Just (v,drop 5 n)+ else return Nothing+ | ConT t <- ts+ , let n = nameBase t+ ]++browseOther :: Name -- Constructor name+ -> [Type] -- Types of the constructor arguments+ -> Q Clause -- Clause of the browse* definition for+ -- the given constructor+browseOther c ts = do+ vs <- optimizableVars ts+ let patf Nothing = WildP+ patf (Just (v,_)) = VarP v+ bodyf (v,t) = VarE (mkName $ "browse" ++ t) `AppE` VarE v+ return $ Clause [ConP c $ fmap patf vs]+ (NormalB $ foldr (>>>) returnu $ fmap bodyf $ catMaybes vs)+ []++browseSelf :: Name -> [Type] -> Q Clause+browseSelf c ts = do+ Clause p (NormalB b) d <- browseOther c ts+ return $ Clause (fmap (AsP $ mkName "e") p)+ (NormalB $ AppE (VarE $ mkName "addExp")+ (VarE $ mkName "e") >>> b) d++(+.) :: Exp -> Exp -> Exp+e1 +. e2 = InfixE (Just e1) (VarE $ mkName "+") (Just e2)++oneE :: Exp+oneE = LitE $ IntegerL 1++numOpsC :: Name -- Constructor name+ -> [Type] -- Types of the constructor arguments (non-empty list)+ -> Q Clause+numOpsC c ts = do+ vs <- optimizableVars ts+ let patf Nothing = WildP+ patf (Just (v,_)) = VarP v+ bodyf (v,_) = VarE (mkName "numOps") `AppE` VarE v+ return $ Clause [ConP c $ fmap patf vs]+ (NormalB $ foldl (+.) oneE $ fmap bodyf $ catMaybes vs)+ []
Graphics/Web/Processing/Core/Types.hs view
@@ -1,5 +1,6 @@ --- | Collection of types.+-- | Collection of types (@Proc_*@ types and others), and+-- some functions on these types as well. module Graphics.Web.Processing.Core.Types ( -- * Processing Script ProcScript (..)@@ -37,6 +38,8 @@ -- ** Text , Proc_Text , fromStText+ , (+.+)+ , Proc_Show (..) -- ** Image , Proc_Image -- * Processing classes@@ -63,6 +66,10 @@ renderFile :: FilePath -> ProcScript -> IO () renderFile fp = T.writeFile fp . renderScript --- | Conditional value.+-- | Conditional value. For example:+--+-- > if_ (x #> 3) "X is greater than 3."+-- > "X is less than or equal to 3."+-- if_ :: ProcType a => Proc_Bool -> a -> a -> a if_ = proc_cond
Graphics/Web/Processing/Core/Var.hs view
@@ -1,15 +1,18 @@ --- | Module exporting 'Var' type and functions.+-- | Module exporting 'Var' and 'ArrayVar' type and functions. module Graphics.Web.Processing.Core.Var ( -- * Variables -- $vars Var+ , ArrayVar+ , arraySize -- ** Functions- , varName+ , varName, arrayVarName , newVar, readVar, writeVar+ , newArrayVar, readArrayVar, writeArrayVar ) where import Graphics.Web.Processing.Core.Primal
Graphics/Web/Processing/Mid.hs view
@@ -31,11 +31,13 @@ -- Note that to make it work, the context of the script /must/ be -- 'Preamble'. ----- Interaction with variables is done via the 'ProcVarMonad' class.--- This class defines methods to interact with variables in both the+-- Interaction with variables is done via the interface provided by+-- the "Graphics.Web.Processing.Core.Var" module.+-- This module defines functions to interact with variables in both the -- 'ScriptM' monad and the 'EventM' monad. -- To store custom types in variables, see the--- "Graphics.Web.Processing.Mid.CustomVar" module.+-- "Graphics.Web.Processing.Mid.CustomVar" module (you have to import+-- this module separately). -- -- Once your script is complete, use 'execScriptM' to get the result -- code.@@ -50,6 +52,7 @@ , ScriptM , on , execScriptM+ , execScriptMFast -- * Variables , module Graphics.Web.Processing.Core.Var -- * Interface@@ -126,7 +129,8 @@ addPCode $ event_preamble s2 addCode $ iff b (event_code s1) (event_code s2) -- Create variables in an event? That should never happen, really.- createVarM = fail "EventM(createVarM): This error should never be called. Report this as an issue."+ createVarM = fail "EventM(createVarM): This error should never be called. Report this as a bug."+ createArrayVarM = fail "EventM(createArrayVarM): This error should never be called. Report this as a bug." writeVar v x = liftProc $ writeVar v x readVar v = do x <- liftProc $ readVar v@@ -138,6 +142,7 @@ liftProc $ readVar v' -- New variable in an event? That should not happen, really. newVar = fail "EventM(newVar): This error should never be called. Report this as an issue."+ newArrayVar = fail "EventM(newArrayVar): This error should never be called. Report this as an issue." data ScriptState c = ScriptState@@ -179,6 +184,7 @@ commandM t as = liftProc $ commandM t as assignM = liftProc . assignM createVarM = liftProc . createVarM+ createArrayVarM n xs = liftProc $ createArrayVarM n xs writeComment = liftProc . writeComment iff b (ScriptM e1) (ScriptM e2) = do c0 <- script_code <$> ScriptM get@@ -192,6 +198,7 @@ liftProc $ setVarNumber n2 liftProc $ iff b c1 c2 newVar = liftProc . newVar+ newArrayVar = liftProc . newArrayVar writeVar v x = liftProc $ writeVar v x readVar v = do x <- liftProc $ readVar v@@ -234,15 +241,11 @@ f = addEvent c $ event_code es in f $ ss { script_code = script_code ss >> event_preamble es } --- | Execute the scripter monad to get the full Processing script.--- Use 'renderScript' or 'renderFile' to render it.------ After generating the script, the output code is optimized--- using 'optimizeBySubstitution'.-execScriptM :: ScriptM Preamble () -> ProcScript-execScriptM (ScriptM s0) =+-- | Like 'execScriptM', but skips optimizations.+execScriptMFast :: ScriptM Preamble () -> ProcScript+execScriptMFast (ScriptM s0) = let s = execState s0 emptyScriptState- in optimizeBySubstitution $ ProcScript+ in ProcScript { proc_preamble = execProcM $ script_code s , proc_setup = maybe mempty execProcM $ script_setup s , proc_draw = fmap execProcM $ script_draw s@@ -250,6 +253,14 @@ , proc_mouseReleased = fmap execProcM $ script_mouseReleased s , proc_keyPressed = fmap execProcM $ script_keyPressed s }++-- | Execute the scripter monad to get the full Processing script.+-- Use 'renderScript' or 'renderFile' to render it.+--+-- After generating the script, the output code is optimized+-- using 'optimizeBySubstitution'.+execScriptM :: ScriptM Preamble () -> ProcScript+execScriptM = optimizeBySubstitution . execScriptMFast -- Coercions
Graphics/Web/Processing/Mid/CustomVar.hs view
@@ -1,5 +1,7 @@ -{-# LANGUAGE DeriveGeneric, TypeOperators, DefaultSignatures, FlexibleContexts #-}+{-# LANGUAGE DeriveGeneric, TypeOperators, DefaultSignatures, FlexibleContexts,+ TemplateHaskell+ #-} -- | This module implements variables which may contain values from -- types different from the native types (@Proc_*@ types).@@ -38,6 +40,9 @@ -- variables, except that they all end in @C@. For example, 'newVar' is -- called 'newVarC' for custom variables. --+-- There are also arrays which may contain custom values.+-- See 'CustomArrayVar'.+-- -- The dependency of this module in several language extensions was -- the reason to make it separate from the rest of the /mid/ interface -- where it belongs to. Somehow, it forces the user to use @DeriveGeneric@@@ -45,27 +50,55 @@ -- custom variables for tuples). module Graphics.Web.Processing.Mid.CustomVar ( CustomVar+ , CustomArrayVar+ , customArraySize , VarLength (..) , CustomValue (..)+ , readArrayVarC+ , writeArrayVarC ) where import Data.Text (Text)+import Data.Text.Lazy (toStrict)+import Text.PrettyPrint.Mainland (ppr, prettyLazyText)+import Data.Monoid ((<>)) import Graphics.Web.Processing.Mid-import Graphics.Web.Processing.Core.Primal (varFromText)+import Graphics.Web.Processing.Core.Primal (varFromText,Proc_Int (..)) import Control.Monad (liftM) -- generics import GHC.Generics+import Graphics.Web.Processing.Core.TH +{-++This module is somehow magic. It allows you handle set of variables+and arrays like if they were a single variable. It is very convenient+to handle other values rather than the primitive Proc_* types.++The interesting part is that you can make, with some restrictions,+your own type be stored in one of these variables.++-}+ -- | Variable with custom values. data CustomVar a = CustomVar [Text] deriving Generic +-- | Modify all the variable names inside a custom variable.+mapCustomVar :: (Text -> Text) -> CustomVar a -> CustomVar a+mapCustomVar f (CustomVar xs) = CustomVar (fmap f xs)+ -- | Typeclass of custom values, which can be stored in custom variables ('CustomVar'). class VarLength a => CustomValue a where -- | Version of 'newVar' for custom variables. newVarC :: (Monad (m Preamble), ProcMonad m) => a -> m Preamble (CustomVar a) default newVarC :: (Monad (m Preamble), ProcMonad m, Generic a, GCustomValue (Rep a)) => a -> m Preamble (CustomVar a)- newVarC x = liftM castCVar $ gnewVarC (from x)+ newVarC = liftM castCVar . gnewVarC . from+ -- | Version of 'newArrayVar' for custom variables.+ newArrayVarC :: (Monad (m Preamble), ProcMonad m) => [a] -> m Preamble (CustomArrayVar a)+ default newArrayVarC :: (Monad (m Preamble), ProcMonad m, Generic a, GCustomValue (Rep a))+ => [a] -> m Preamble (CustomArrayVar a)+ newArrayVarC = liftM castCAVar . gnewArrayVarC . fmap from -- | Version of 'readVar' for custom variables. readVarC :: (Monad (m c), ProcMonad m) => CustomVar a -> m c a default readVarC :: (Monad (m c), ProcMonad m, Generic a, GCustomValue (Rep a))@@ -75,46 +108,55 @@ writeVarC :: (Monad (m c), ProcMonad m) => CustomVar a -> a -> m c () default writeVarC :: (Monad (m c), ProcMonad m, Generic a, GCustomValue (Rep a)) => CustomVar a -> a -> m c () writeVarC v x = gwriteVarC (castCVar v) (from x)+ -- | Version of 'if_' for custom values.+ ifC :: Proc_Bool -> a -> a -> a+ default ifC :: (Generic a, GCustomValue (Rep a)) => Proc_Bool -> a -> a -> a+ ifC b x y = to $ gifC b (from x) (from y) +-- Maybe this function can be written in terms of arrayVarToVar?+arrayVarToVarC :: CustomArrayVar a -> Proc_Int -> CustomVar a+arrayVarToVarC v n = mapCustomVar f $ customInnerVar v+ where+ f t = t <> "[" <> (toStrict $ prettyLazyText 80 $ ppr n) <> "]"++-- | Read a component of a custom array variable.+readArrayVarC :: (ProcMonad m, Monad (m c), CustomValue a)+ => CustomArrayVar a -> Proc_Int -> m c a+readArrayVarC v n =+ case n of+ Proc_Int i -> let s = customArraySize v+ in if (i < 0) || (i >= s)+ then fail $ "readArrayVarC: index out of bounds.\nArray size: "+ ++ show s+ ++ ".\nIndex given: "+ ++ show i+ ++ ".\nRemember that indices start from 0."+ else readVarC $ arrayVarToVarC v n+ _ -> readVarC $ arrayVarToVarC v n++-- | Write a component of a custom array variable.+writeArrayVarC :: (ProcMonad m, Monad (m c), CustomValue a)+ => CustomArrayVar a -> Proc_Int -> a -> m c ()+writeArrayVarC v n x = writeVarC (arrayVarToVarC v n) x+ fromVar :: Var a -> CustomVar a fromVar = CustomVar . (:[]) . varName fromCustomVar :: CustomVar a -> [Var a] fromCustomVar (CustomVar xs) = fmap varFromText xs --- This instances are really boring (they are all equal).--instance CustomValue Proc_Bool where- newVarC = liftM fromVar . newVar- readVarC = readVar . head . fromCustomVar- writeVarC v x = writeVar (head $ fromCustomVar v) x--instance CustomValue Proc_Int where- newVarC = liftM fromVar . newVar- readVarC = readVar . head . fromCustomVar- writeVarC v x = writeVar (head $ fromCustomVar v) x--instance CustomValue Proc_Float where- newVarC = liftM fromVar . newVar- readVarC = readVar . head . fromCustomVar- writeVarC v x = writeVar (head $ fromCustomVar v) x--instance CustomValue Proc_Text where- newVarC = liftM fromVar . newVar- readVarC = readVar . head . fromCustomVar- writeVarC v x = writeVar (head $ fromCustomVar v) x--instance CustomValue Proc_Image where- newVarC = liftM fromVar . newVar- readVarC = readVar . head . fromCustomVar- writeVarC v x = writeVar (head $ fromCustomVar v) x+-- Custom arrays -instance CustomValue Proc_Char where- newVarC = liftM fromVar . newVar- readVarC = readVar . head . fromCustomVar- writeVarC v x = writeVar (head $ fromCustomVar v) x+-- | Array variable of custom values.+data CustomArrayVar a =+ CustomArrayVar { -- | Size of the custom array.+ customArraySize :: Int+ , customInnerVar :: CustomVar a+ } --- GENERICS+fromArrayVar :: ArrayVar a -> CustomArrayVar a+fromArrayVar v =+ CustomArrayVar (arraySize v) $ fromVar $ varFromText $ arrayVarName v -- | Typeclass of values that can be stored in several -- native variables ('Var').@@ -122,15 +164,10 @@ -- | Calculate how many native variables are needed -- to store a value. varLength :: a -> Int- --- varLength _ = 1+ default varLength :: (Generic a, GVarLength (Rep a)) => a -> Int+ varLength = gvarLength . from -instance VarLength Proc_Bool where-instance VarLength Proc_Int where-instance VarLength Proc_Float where-instance VarLength Proc_Text where-instance VarLength Proc_Image where-instance VarLength Proc_Char where+-- GENERICS class GVarLength f where gvarLength :: f a -> Int@@ -139,10 +176,10 @@ gvarLength _ = 1 instance (GVarLength a, GVarLength b) => GVarLength (a :*: b) where- gvarLength (a :*: b) = gvarLength a + gvarLength b+ gvarLength (a :*: b) = gvarLength a + gvarLength b instance GVarLength (a :+: b) where- gvarLength _ = error "gvarLength: Custom variables cannot be sum types."+ gvarLength _ = error "gvarLength: Custom variables cannot contain sum types." instance GVarLength a => GVarLength (M1 i c a) where gvarLength (M1 x) = gvarLength x@@ -156,16 +193,33 @@ castCVar :: CustomVar a -> CustomVar b castCVar (CustomVar xs) = CustomVar xs +castCAVar :: CustomArrayVar a -> CustomArrayVar b+castCAVar (CustomArrayVar n v) = CustomArrayVar n $ castCVar v+ class GCustomValue f where gnewVarC :: (Monad (m Preamble), ProcMonad m) => f a -> m Preamble (CustomVar (f a))+ gnewArrayVarC :: (Monad (m Preamble), ProcMonad m) => [f a] -> m Preamble (CustomArrayVar (f a)) greadVarC :: (Monad (m c), ProcMonad m) => CustomVar (f a) -> m c (f a) gwriteVarC :: (Monad (m c), ProcMonad m) => CustomVar (f a) -> f a -> m c ()+ gifC :: Proc_Bool -> f a -> f a -> f a +leftP :: (a :*: b) c -> a c+leftP (a :*: _) = a++rightP :: (a :*: b) c -> b c+rightP (_ :*: b) = b+ instance (GVarLength a, GCustomValue a, GCustomValue b) => GCustomValue (a :*: b) where gnewVarC (a :*: b) = do CustomVar xs <- gnewVarC a CustomVar ys <- gnewVarC b return $ CustomVar $ xs ++ ys+ gnewArrayVarC l = do+ let as = fmap leftP l+ bs = fmap rightP l+ CustomArrayVar n (CustomVar xs) <- gnewArrayVarC as+ CustomArrayVar _ (CustomVar ys) <- gnewArrayVarC bs+ return $ CustomArrayVar n $ CustomVar $ xs ++ ys greadVarC v = do a <- greadVarC $ castCVar v let n = gvarLength a@@ -175,21 +229,52 @@ let (xs,ys) = splitAt (gvarLength a) v gwriteVarC (CustomVar xs) a gwriteVarC (CustomVar ys) b+ gifC c (a :*: b) (x :*: y) = gifC c a x :*: gifC c b y instance GCustomValue (a :+: b) where- gnewVarC = error "gnewVarC: Custom variables cannot be sum types."- greadVarC = error "greadVarC: Custom variables cannot be sum types."- gwriteVarC = error "gwriteVarC: Custom variables cannot be sum types."+ gnewVarC = error "gnewVarC: Custom variables cannot contain sum types."+ gnewArrayVarC = error "gnewArrayVarC: Custom variables cannot contain sum types."+ greadVarC = error "greadVarC: Custom variables cannot contain sum types."+ gwriteVarC = error "gwriteVarC: Custom variables cannot contain sum types."+ gifC = error "gifC: Custom values are not sum types." instance GCustomValue a => GCustomValue (M1 i c a) where gnewVarC (M1 x) = liftM castCVar $ gnewVarC x+ gnewArrayVarC = liftM castCAVar . gnewArrayVarC . fmap unM1 greadVarC v = liftM M1 $ greadVarC $ castCVar v gwriteVarC v (M1 x) = gwriteVarC (castCVar v) x+ gifC b (M1 x) (M1 y) = M1 $ gifC b x y instance CustomValue a => GCustomValue (K1 i a) where gnewVarC (K1 x) = liftM castCVar $ newVarC x+ gnewArrayVarC = liftM castCAVar . newArrayVarC . fmap unK1 greadVarC v = liftM K1 $ readVarC $ castCVar v gwriteVarC v (K1 x) = writeVarC (castCVar v) x+ gifC b (K1 x) (K1 y) = K1 $ ifC b x y++{- Proc_* types as custom values++Any Proc_* type can be seen as a custom value,+making a trivial instance to the CustomValue class,+using custom variables as usual variables.++For any Proc_* type:++instance VarLength Proc_* where+ varLength _ = 1++instance CustomValue Proc_* where+ newVarC = liftM fromVar . newVar+ newArrayVarC = liftM fromArrayVar . newArrayVar+ readVarC = readVar . head . fromCustomVar+ writeVarC v x = writeVar (head $ fromCustomVar v) x+ ifC = if_++-}++$(deriveCustomValues)++-- Instances for other types. instance (VarLength a, VarLength b) => VarLength (a,b) instance (CustomValue a, CustomValue b) => CustomValue (a,b)
Graphics/Web/Processing/Optimize.hs view
@@ -1,15 +1,19 @@ -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -- | Code optimization module. module Graphics.Web.Processing.Optimize (- -- * Optimizations+ -- * Substitution Optimization+ -- ** Algorithm optimizeBySubstitution+ -- ** Properties+ , prop_optimizeBySubstitution_projection ) where import Graphics.Web.Processing.Core.Primal+import Graphics.Web.Processing.Core.TH import Data.MultiSet (MultiSet, insert, empty- , occur, union, filter)+ , occur, filter) import Control.Monad (when) import Control.Monad.Trans.State import qualified Data.Foldable as F@@ -21,118 +25,151 @@ import Control.Applicative ((<$>)) import Control.Arrow (second) -boolops :: Proc_Bool -> Int-boolops (Proc_Neg x) = 1 + boolops x-boolops (Proc_Or x y) = 1 + boolops x + boolops y-boolops (Proc_And x y) = 1 + boolops x + boolops y-boolops (Float_Eq x y) = 1 + numOps x + numOps y-boolops (Float_NEq x y) = 1 + numOps x + numOps y-boolops (Float_LE x y) = 1 + numOps x + numOps y-boolops (Float_L x y) = 1 + numOps x + numOps y-boolops (Float_GE x y) = 1 + numOps x + numOps y-boolops (Float_G x y) = 1 + numOps x + numOps y-boolops _ = 0+{- About this module --- | Number of operations needed to calculate the--- value of a given 'Proc_Float' value.-numOps :: Proc_Float -> Int--- Really boring function!-numOps (Proc_Float _) = 0-numOps (Float_Sum x y) = 1 + numOps x + numOps y-numOps (Float_Substract x y) = 1 + numOps x + numOps y-numOps (Float_Divide x y) = 1 + numOps x + numOps y-numOps (Float_Mult x y) = 1 + numOps x + numOps y-numOps (Float_Mod x y) = 1 + numOps x + numOps y-numOps (Float_Abs x) = 1 + numOps x-numOps (Float_Exp x) = 1 + numOps x-numOps (Float_Sqrt x) = 1 + numOps x-numOps (Float_Log x) = 1 + numOps x-numOps (Float_Sine x) = 1 + numOps x-numOps (Float_Cosine x) = 1 + numOps x-numOps (Float_Arcsine x) = 1 + numOps x-numOps (Float_Arccosine x) = 1 + numOps x-numOps (Float_Arctangent x) = 1 + numOps x-numOps (Float_Floor x) = 1 + numOps x-numOps (Float_Round x) = 1 + numOps x-numOps (Float_Noise x y) = 1 + numOps x + numOps y-numOps (Float_Cond b x y) = boolops b + max (numOps x) (numOps y)--- Variable things are worth zero.-numOps (Float_Var _) = 0-numOps (Float_Random _ _) = 0+This module defines inner functions over the ProcScript type+with the property that the output script should be equal or+more efficient than the input. Also, both scripts must behave+in the same way. +A property common to any optimization function is that is+a projection. A projection is a function with the following+property:++f . f = f++-}++{- About the Substitution Optimization Algorithm++The intention of this algorithm is to find common subexpressions+and assign a variable with their values, thus avoiding repeated+computations.++An introduction to this idea is given in:++http://deltadiaz.blogspot.com.es/2013/08/processing-optimizations-and-firefox.html++-}++{- | The Optimizable class.++The Optimizable class contains methods to help the production of+optimization functions. Its instances are generated by TH.++-}+class (Ord e, Recursive e, ProcType e) => Optimizable e where+ numOps :: e -> Int+ -- Browsing+ browseBool :: Proc_Bool -> ExpCounter e ()+ browseInt :: Proc_Int -> ExpCounter e ()+ browseFloat :: Proc_Float -> ExpCounter e ()+ -- Replacing (replaceIn* :: original exp -> target exp+ -- -> Proc_* -> Proc_*)+ replaceInBool :: e -> e -> Proc_Bool -> Proc_Bool+ replaceInInt :: e -> e -> Proc_Int -> Proc_Int+ replaceInFloat :: e -> e -> Proc_Float -> Proc_Float+ -- Defaults+ browseBool _ = return ()+ browseInt _ = return ()+ browseFloat _ = return ()+ replaceInBool _ _ = id+ replaceInInt _ _ = id+ replaceInFloat _ _ = id++browseArgs :: Optimizable e => [ProcArg] -> ExpCounter e ()+browseArgs [] = return ()+browseArgs (x:xs) = case x of+ BoolArg e -> browseBool e >> browseArgs xs+ IntArg e -> browseInt e >> browseArgs xs+ FloatArg e -> browseFloat e >> browseArgs xs+ _ -> return ()++browseAssign :: Optimizable e => ProcAssign -> ExpCounter e ()+browseAssign (BoolAssign _ e) = browseBool e+browseAssign (IntAssign _ e) = browseInt e+browseAssign (FloatAssign _ e) = browseFloat e+browseAssign _ = return ()++browseCode :: Optimizable e => ProcCode c -> ExpCounter e ()+browseCode (Command _ xs) = browseArgs xs+browseCode (Conditional b c1 c2) = browseBool b >> browseCode c1 >> browseCode c2+browseCode (Sequence xs) = F.mapM_ browseCode xs+browseCode (Assignment a) = browseAssign a+browseCode _ = return ()++replaceInArg :: Optimizable e => e -> e -> ProcArg -> ProcArg+replaceInArg o t (BoolArg e) = BoolArg $ replaceInBool o t e+replaceInArg o t (IntArg e) = IntArg $ replaceInInt o t e+replaceInArg o t (FloatArg e) = FloatArg $ replaceInFloat o t e+replaceInArg _ _ a = a++replaceInAssign :: Optimizable e => e -> e -> ProcAssign -> ProcAssign+replaceInAssign o t (BoolAssign n e) = BoolAssign n $ replaceInBool o t e+replaceInAssign o t (IntAssign n e) = IntAssign n $ replaceInInt o t e+replaceInAssign o t (FloatAssign n e) = FloatAssign n $ replaceInFloat o t e+replaceInAssign _ _ a = a++replaceInCode :: Optimizable e => e -> e -> ProcCode c -> ProcCode c+replaceInCode o t (Command n xs) = Command n $ fmap (replaceInArg o t) xs+replaceInCode o t (Conditional b c1 c2) =+ Conditional (replaceInBool o t b)+ (replaceInCode o t c1)+ (replaceInCode o t c2)+replaceInCode o t (Sequence xs) = Sequence $ fmap (replaceInCode o t) xs+replaceInCode o t (Assignment a) = Assignment $ replaceInAssign o t a+replaceInCode _ _ c = c+ ----------------------------------------------------- ----------------------------------------------------- ---- SUBSTITUTION OPTIMIZATION SETTINGS --- | Number that indicates the maximum number of--- operations allowed for a 'Proc_Float' calculation--- to consider it cheap.+-- | Maximum number of operations allowed for a+-- 'Proc_Float' calculation to be considered cheap. limitNumber :: Int-limitNumber = 0+limitNumber = 1 -- | Number of times an expression is considered -- repeated enough to be substituted. occurNumber :: Int-occurNumber = 3+occurNumber = 2 ----------------------------------------------------- ----------------------------------------------------- --- | Check if a 'Proc_Float' calculation is expensive,+-- | Check if a calculation is expensive, -- depending on 'limitNumber'.-isExpensive :: Proc_Float -> Bool+isExpensive :: Optimizable e => e -> Bool isExpensive = (> limitNumber) . numOps --- | Check if a 'Proc_Float' calculation is cheap,--- depending on 'limitNumber'.-isCheap :: Proc_Float -> Bool-isCheap = not . isExpensive--type FloatSet = MultiSet Proc_Float+{- | The Expression Counter -type FloatCounter = State FloatSet+The Expression Counter is nothing else than a state monad+storing a multiset. We place in this multiset all the+subexpressions in the code. Expressions that are repeated+several times will have then an ocurrence greater than one.+This allow us to calculate the most common subexpression+in a piece of code. See mostFreq below. --- | Add a 'Proc_Float' to the /float counter/.-addFloat :: Proc_Float -> FloatCounter ()-addFloat x = when (isExpensive x) $ modify $ insert x+-}+type ExpCounter e = State (MultiSet e) --- | Add each expression contained in a 'Proc_Float' to the--- /float counter/.-browseFloat :: Proc_Float -> FloatCounter ()--- Really boring function!-browseFloat f@(Float_Sum x y) = addFloat f >> browseFloat x >> browseFloat y-browseFloat f@(Float_Substract x y) = addFloat f >> browseFloat x >> browseFloat y-browseFloat f@(Float_Divide x y) = addFloat f >> browseFloat x >> browseFloat y-browseFloat f@(Float_Mult x y) = addFloat f >> browseFloat x >> browseFloat y-browseFloat f@(Float_Mod x y) = addFloat f >> browseFloat x >> browseFloat y-browseFloat f@(Float_Abs x) = addFloat f >> browseFloat x-browseFloat f@(Float_Exp x) = addFloat f >> browseFloat x-browseFloat f@(Float_Sqrt x) = addFloat f >> browseFloat x-browseFloat f@(Float_Log x) = addFloat f >> browseFloat x-browseFloat f@(Float_Sine x) = addFloat f >> browseFloat x-browseFloat f@(Float_Cosine x) = addFloat f >> browseFloat x-browseFloat f@(Float_Arcsine x) = addFloat f >> browseFloat x-browseFloat f@(Float_Arccosine x) = addFloat f >> browseFloat x-browseFloat f@(Float_Arctangent x) = addFloat f >> browseFloat x-browseFloat f@(Float_Floor x) = addFloat f >> browseFloat x-browseFloat f@(Float_Round x) = addFloat f >> browseFloat x-browseFloat f@(Float_Noise x y) = addFloat f >> browseFloat x >> browseFloat y-browseFloat f@(Float_Cond _ x y) = addFloat f >> browseFloat x >> browseFloat y-browseFloat _ = return ()+-- | Add an expression to the /expression counter/.+addExp :: Optimizable e => e -> ExpCounter e ()+addExp x = when (isExpensive x) $ modify $ insert x -execCounter :: FloatCounter a -> FloatSet+execCounter :: ExpCounter e a -> MultiSet e execCounter c = execState c empty --- | Most frequent expensive expression within a list--- of expressions.+-- | Most frequent expensive expression within a piece of code. -- It returns 'Nothing' when no expensive expression -- was found, or they are not repeated enough (see 'occurNumber'). -- If there are more than one most frequent expression, -- it returns one of them.-mostFreq :: Seq Proc_Float -> Maybe Proc_Float-mostFreq xs = maxOccur mset+mostFreq :: Optimizable e => e -> ProcCode c -> Maybe e+mostFreq _ c = maxOccur mset where- mset_ = F.foldr (\x y -> union y $ execCounter $ browseFloat x) empty xs+ mset_ = execCounter $ browseCode c mset = Data.MultiSet.filter (\x -> occur x mset_ >= occurNumber) mset_ maxOccur = F.foldr f Nothing f a (Just b) =@@ -141,77 +178,33 @@ else Just b f a Nothing = Just a --- | Apply a substitution.-floatsubs :: Proc_Float -- ^ Origin.- -> Proc_Float -- ^ Target.- -> Proc_Float -- ^ Expression.- -> Proc_Float -- ^ Result.-floatsubs o t x = if x == o then t else recFloat (floatsubs o t) x---- | From a list of arguments, create a sequence of the--- arguments of type 'Proc_Float' (which may be empty).-getFloatArgs :: [ProcArg] -> Seq Proc_Float-getFloatArgs = F.foldr (- \x xs -> case x of- FloatArg a -> a Seq.<| xs- _ -> xs) mempty---- | Gather all the float expressions in a piece of code.-floatsInCode :: ProcCode c -> Seq Proc_Float-floatsInCode (Command _ xs) = getFloatArgs xs-floatsInCode (Conditional _ c1 c2) = floatsInCode c1 <> floatsInCode c2-floatsInCode (Sequence xs) = F.foldMap floatsInCode xs-floatsInCode (Assignment (FloatAsign _ x)) = Seq.singleton x-floatsInCode _ = mempty---- | Like 'mostFreq', but applied to a piece of code.-mostFreqCode :: ProcCode c -> Maybe Proc_Float-mostFreqCode = mostFreq . floatsInCode- optVarName :: Int -- ^ Index. -> Text -- ^ Optimization variable name. optVarName n = "subs_" <> fromString (show n) -- | Assign a /substitution variable/ a expression,--- and use that variable in the rest of the code.-varForExp :: Int -- ^ Substitution variable index.- -> Proc_Float -- ^ Expressions to be substituted.+-- and use that variable in the rest of the code+-- instead of the original expression.+varForExp :: Optimizable e+ => Int -- ^ Substitution variable index.+ -> e -- ^ Expression to be substituted. -> ProcCode c -- ^ Original code. -> (ProcCode c, ProcCode c) -- ^ Assignment and result code. varForExp n e c =- ( Assignment (FloatAsign v e) , codesubs e (Float_Var v) c )+ ( Assignment (proc_assign v e) , replaceInCode e (proc_read $ varFromText v) c ) where v = optVarName n --- | Apply a substitution to a floating argument.--- To other arguments, it does nothing.-argsubs :: Proc_Float -- ^ Origin.- -> Proc_Float -- ^ Target.- -> ProcArg -- ^ Original argument.- -> ProcArg -- ^ Result argument.-argsubs o t (FloatArg x) = FloatArg $ floatsubs o t x-argsubs _ _ x = x---- | Apply a substitution to a piece of code.-codesubs :: Proc_Float -- ^ Origin.- -> Proc_Float -- ^ Target.- -> ProcCode c -- ^ Original code.- -> ProcCode c -- ^ Result code.-codesubs o t (Command n xs) = Command n $ fmap (argsubs o t) xs-codesubs o t (Conditional b c1 c2) = Conditional b (codesubs o t c1) (codesubs o t c2)-codesubs o t (Sequence xs) = Sequence $ fmap (codesubs o t) xs-codesubs o t (Assignment (FloatAsign n x)) = Assignment $ FloatAsign n $ floatsubs o t x-codesubs _ _ c = c--substitutionOver :: Int -> ProcCode c -> (ProcCode c, Int)-substitutionOver = substitutionOverAux mempty+substitutionOver :: Optimizable e => e -> Int -> ProcCode c+ -> (ProcCode c,ProcCode c, Int) -- (Assignments, Code substituted, Updated counter)+substitutionOver aux = substitutionOverAux aux mempty -substitutionOverAux :: Seq (ProcCode c) -> Int -> ProcCode c -> (ProcCode c, Int)-substitutionOverAux as n c =- case mostFreqCode c of- Nothing -> (addSubsComments (F.fold as) <> c,n)+substitutionOverAux :: Optimizable e => e -> Seq (ProcCode c) -> Int -> ProcCode c -> (ProcCode c, ProcCode c, Int)+substitutionOverAux aux as n c =+ case mostFreq aux c of+ Nothing -> (addSubsComments (F.fold as), c,n) Just e -> let (a,c') = varForExp n e c- in substitutionOverAux (as Seq.|> a) (n+1) c'+ in substitutionOverAux aux (as Seq.|> a) (n+1) c' addSubsComments :: ProcCode c -> ProcCode c addSubsComments c =@@ -228,7 +221,8 @@ data SubsState c = SubsState { codeWritten :: ProcCode c , codeStack :: ProcCode c- , substitutionIndex :: Int }+ , substitutionIndex :: Int+ , mutatedVariables :: [Text] } type SubsM c = State (SubsState c) @@ -244,31 +238,67 @@ resetStack :: SubsM c () resetStack = modify $ \s -> s { codeStack = mempty } +mutateVariable :: Text -> SubsM c ()+mutateVariable t = modify $ \s -> s { mutatedVariables = t : mutatedVariables s }++cleanVariables :: SubsM c ()+cleanVariables = modify $ \s -> s { mutatedVariables = [] }++isVarInCode :: Text -> ProcCode c -> Bool+isVarInCode t (Command _ as) = foldr (\a r -> isVarInArg t a || r) False as+isVarInCode t (Assignment a) = isVarInAssign t a+isVarInCode t (Conditional b c1 c2) = checkForVar t b || isVarInCode t c1 || isVarInCode t c2+isVarInCode t (Sequence xs) = F.foldr (\c r -> isVarInCode t c || r) False xs+isVarInCode _ _ = False++{- Apply substitution++Get the current stack, apply the optimization to it,+append the result as written code and reset the stack.++The order in which the substitutions for the different+types are made matters. The most frequent type should+be first.++-} applySubstitution :: SubsM c () applySubstitution = do stack <- codeStack <$> get n <- substitutionIndex <$> get- let (c,m) = substitutionOver n stack- addToWritten c- setIndex m+ let (s1,c1,n1) = substitutionOver (undefined :: Proc_Float) n stack+ addToWritten s1+ let (s2,c2,n2) = substitutionOver (undefined :: Proc_Int) n1 c1+ addToWritten s2+ let (s3,c3,n3) = substitutionOver (undefined :: Proc_Bool) n2 c2+ addToWritten s3+ addToWritten c3+ setIndex n3 resetStack +addWithMutations :: ProcCode c -> SubsM c ()+addWithMutations c = do+ vs <- mutatedVariables <$> get+ let b = any (\v -> isVarInCode v c) vs+ if b then applySubstitution >> cleanVariables >> addToStack c+ else addToStack c+ codeSubstitution :: ProcCode c -> SubsM c ()-codeSubstitution a@(Assignment _) = addToStack a >> applySubstitution+codeSubstitution c@(Command _ _) = addWithMutations c+codeSubstitution c@(Assignment a) = addWithMutations c >> mutateVariable (assignVarName a) codeSubstitution (Conditional b c1 c2) = do applySubstitution n0 <- substitutionIndex <$> get- let (n1,c1') = runSubstitution n0 $ codeSubstitution c1- (n2,c2') = runSubstitution n1 $ codeSubstitution c2+ let (n1,c1') = runSubstitution n0 $ codeSubstitution c1 >> applySubstitution+ (n2,c2') = runSubstitution n1 $ codeSubstitution c2 >> applySubstitution setIndex n2 addToWritten $ Conditional b c1' c2' codeSubstitution (Sequence xs) = F.mapM_ codeSubstitution xs-codeSubstitution x = addToStack x+codeSubstitution c = addToStack c runSubstitution :: Int -> SubsM c a -> (Int,ProcCode c) runSubstitution n m = (substitutionIndex s, codeWritten s) where- (_,s) = runState m $ SubsState mempty mempty n+ (_,s) = runState m $ SubsState mempty mempty n [] subsOptimize :: Int -> ProcCode c -> (Int,ProcCode c) subsOptimize n c = runSubstitution n $ codeSubstitution c >> applySubstitution@@ -277,6 +307,10 @@ -- create variables for them so they are only calculated once. -- -- This optimization is applied automatically when using 'execScriptM'.+--+-- Look at the generated to code to see which substitutions have been made.+-- They are delimited by comments, with title /Substitution Optimization settings/.+-- If this is not present, no substitution has been made. optimizeBySubstitution :: ProcScript -> ProcScript optimizeBySubstitution (ProcScript _preamble@@ -290,16 +324,35 @@ (n2,_draw') = maybe (n1,Nothing) (second Just . subsOptimize n1) _draw (n3,_mouseClicked') = maybe (n2,Nothing) (second Just . subsOptimize n2) _mouseClicked (n4,_mouseReleased') = maybe (n3,Nothing) (second Just . subsOptimize n3) _mouseReleased- (n5,_keyPressed') = maybe (n4,Nothing) (second Just . subsOptimize n4) _keyPressed- vs = fmap (\n -> CreateVar $ FloatAsign (optVarName n) 0) [1 .. n5 - 1]- in ProcScript (_preamble <> subsComment (mconcat vs))- _setup'- _draw'- _mouseClicked'- _mouseReleased'- _keyPressed'+ (_,_keyPressed') = maybe (n4,Nothing) (second Just . subsOptimize n4) _keyPressed+ in ProcScript _preamble+ _setup'+ _draw'+ _mouseClicked'+ _mouseReleased'+ _keyPressed' -subsComment :: ProcCode Preamble -> ProcCode Preamble-subsComment c =- if c == mempty then mempty- else Comment "Variables from the Substitution Optimization." <> c+-- | Optimizations are projections. In particular:+--+-- > let f = optimizeBySubstitution+-- > in f x == f (f x)+--+-- This function checks that this equality holds for a given @x@.+-- Apply it to your own script to check that the property is true.+-- Tests has been applied to randomly generated scripts, but for+-- them, @f@ ≈ @id@.+prop_optimizeBySubstitution_projection :: ProcScript -> Bool+prop_optimizeBySubstitution_projection x =+ let f = optimizeBySubstitution+ y = f x+ in y == f y++{- Optimizable instances++Using Template Haskell we save time and possible mistakes.+It is also convenient since the instances will adapt to+any change in the types.++-}++$(deriveOptimizable)
Graphics/Web/Processing/Simple.hs view
@@ -280,19 +280,19 @@ on Draw $ do size w h translate (intToFloat w/2) (intToFloat h/2)- writeComment "Read state"+ comment "Read state" s <- readVarC v- writeComment "Background color"+ comment "Background color" background $ bg s- writeComment "Draw state"+ comment "Draw state" figureEvent $ _print s- writeComment $ "Update state"+ comment $ "Update state" n <- frameCount writeVarC v $ step n s on MouseClicked $ do- writeComment "Read state"+ comment "Read state" s <- readVarC v- writeComment "Mouse event"+ comment "Mouse event" p <- getMousePoint writeVarC v $ onclick p s when (not $ null keyevents) $ on KeyPressed $ mapM_ (keyEvent v keyv) $ zip keyevents [1..]@@ -300,7 +300,7 @@ keyEvent :: CustomValue w => CustomVar w -> Var Proc_Bool -> ((Key,w -> w),Int) -> EventM KeyPressed () keyEvent v keyv ((k,f),n) = do- writeComment $ "Key event " <> fromString (show n)+ comment $ "Key event " <> fromString (show n) matchKey keyv k b <- readVar keyv ifM b (readVarC v >>= writeVarC v . f)
+ examples/pacman.hs view
@@ -0,0 +1,487 @@++{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}++{- Pac-Man game++An uploaded version can be reached at:++http://daniel-diaz.github.io/projects/processing/pacman.html++-}++import Graphics.Web.Processing.Mid+import Graphics.Web.Processing.Mid.CustomVar+import Graphics.Web.Processing.Html+import Control.Applicative+import GHC.Generics (Generic)+import Data.Monoid ((<>))++-- | Tile types:+--+-- * 0 - Wall+-- * 1 - Dot+-- * 2 - Energizer+-- * 3 - Empty+-- * 4 - Pac-Man only wall+--+type Tile = Proc_Int++isWall :: Tile -> Proc_Bool+isWall t = t #== 0 #|| t #== 4++type Map = [Tile]++intFromChar :: Char -> Int+intFromChar c = read [c]++main :: IO ()+main = do+ map <- (fmap (fmap intFromChar) . lines) <$> readFile "pacman.map"+ let rows = length map+ cols = length $ head map+ map' = concat map+ dots = length $ filter (==1) map'+ writeHtml "processing.js" "pacman.pde" "Pac-Man!" "pacman.html" $ pacmanScript rows cols dots map'++------------------------------+-- CONFIGURATIONS++framesPerSecond :: Num a => a+framesPerSecond = 35++cellWidth :: Proc_Float+cellWidth = 17++cycleLength :: Num a => a+cycleLength = 6++maxFrame :: Proc_Int+maxFrame = 5++scatterTime :: Proc_Int+scatterTime = 5 * framesPerSecond++chaseTime :: Proc_Int+chaseTime = 20 * framesPerSecond++------------------------------++-- (#==) should be generalized to include this case and more.+(#===) :: (Proc_Eq a, Proc_Eq b) => (a,b) -> (a,b) -> Proc_Bool+(a,b) #=== (c,d) = a #== c #&& b #== d++(<+>) :: Num a => (a,a) -> (a,a) -> (a,a)+(a,b) <+> (c,d) = (a+c,b+d)++distance :: Proc_Point -> Proc_Point -> Proc_Float+distance (a,b) (c,d) = sqrt $ (a-c)^2 + (b-d)^2++colorize :: Color -> EventM Draw ()+colorize c = stroke c >> fill c++-- Directions+type Direction = Proc_Float++up,down,left,right :: Direction+up = 3*pi/2+down = pi/2+left = pi+right = 0++frontDirs :: Direction -> [Direction]+frontDirs d = [d, d + down, d + up]++dirVector :: Direction -> Proc_Point+dirVector d = (cos d, sin d)++type Pos = (Proc_Int,Proc_Int)++dirPos :: Direction -> Pos+dirPos d = (pround $ sin d, pround $ cos d)++data State = State {+ -- Pacman+ pacmanPos :: Pos+ , pacmanDir :: Direction+ , pacmanWillDir :: Direction+ , pacmanTarget :: Pos+ -- Ghosts+ , blinkyPos :: Pos+ , blinkyDir :: Direction+ , blinkyTarget :: Pos+ , pinkyPos :: Pos+ , pinkyDir :: Direction+ , pinkyTarget :: Pos+ , inkyPos :: Pos+ , inkyDir :: Direction+ , inkyTarget :: Pos+ , clydePos :: Pos+ , clydeDir :: Direction+ , clydeTarget :: Pos+ -- Move cycle+ , moveCycle :: Proc_Int+ -- Mode+ , chaseMode :: Proc_Bool+ , modeTimer :: Proc_Int+ -- Game State+ , isWon :: Proc_Bool+ , isLost :: Proc_Bool+ } deriving Generic++instance VarLength State+instance CustomValue State++initialState :: State+initialState = State {+ pacmanPos = (23,14)+ , pacmanTarget = (23,15)+ , pacmanDir = right+ , pacmanWillDir = right+ , blinkyPos = (15,12)+ , blinkyDir = up+ , blinkyTarget = blinkyPos initialState <+> dirPos (blinkyDir initialState)+ , pinkyPos = (15,13)+ , pinkyDir = left+ , pinkyTarget = pinkyPos initialState <+> dirPos (pinkyDir initialState)+ , inkyPos = (15,14)+ , inkyDir = right+ , inkyTarget = inkyPos initialState <+> dirPos (inkyDir initialState)+ , clydePos = (15,15)+ , clydeDir = up+ , clydeTarget = clydePos initialState <+> dirPos (clydeDir initialState)+ , moveCycle = 0+ , chaseMode = false -- start in scatter mode+ , modeTimer = scatterTime+ , isWon = false+ , isLost = false+ }++data Ghost = Blinky | Pinky | Inky | Clyde+ deriving Eq++allGhosts :: [Ghost]+allGhosts = [Blinky, Pinky, Inky, Clyde]++ghostColor :: Ghost -> Color+ghostColor Blinky = Color 255 0 0 255+ghostColor Pinky = Color 255 184 255 255+ghostColor Inky = Color 0 255 255 255+ghostColor Clyde = Color 255 184 81 255++ghostPos :: Ghost -> State -> Pos+ghostPos Blinky = blinkyPos+ghostPos Pinky = pinkyPos+ghostPos Inky = inkyPos+ghostPos Clyde = clydePos++ghostDir :: Ghost -> State -> Direction+ghostDir Blinky = blinkyDir+ghostDir Pinky = pinkyDir+ghostDir Inky = inkyDir+ghostDir Clyde = clydeDir++ghostTarget :: Ghost -> State -> Pos+ghostTarget Blinky = blinkyTarget+ghostTarget Pinky = pinkyTarget+ghostTarget Inky = inkyTarget+ghostTarget Clyde = clydeTarget++ghostHome :: Ghost -> Pos+ghostHome Blinky = (0,27)+ghostHome Pinky = (0,0)+ghostHome Inky = (30,27)+ghostHome Clyde = (30,-10)++cancelPoint :: Num a => (a,a) -> (a,a)+cancelPoint (x,y) = (-x,-y)++scalePoint :: Num a => a -> (a,a) -> (a,a)+scalePoint k (x,y) = (k*x,k*y)++middlePoint :: Proc_Float -- t <- 0~1+ -> Proc_Point -- p <- R2+ -> Proc_Point -- q <- R2+ -> Proc_Point -- (1-t)p + tq+middlePoint t p q = scalePoint (1-t) p <+> scalePoint t q++drawGhost :: Color -> Proc_Point -> Direction -> EventM Draw ()+drawGhost c p d = do+ colorize c+ let corner = p <+> ((-cellWidth)/2,cellWidth/2)+ bezier corner+ (corner <+> (0,-cellWidth))+ (corner <+> (cellWidth,-cellWidth))+ (corner <+> (cellWidth,0))+ let eye1 = p <+> ((-cellWidth)/4,(-cellWidth)/6)+ eye2 = p <+> (cellWidth/4,(-cellWidth)/6)+ eyer = cellWidth/6+ -- Eye 1+ colorize $ Color 255 255 255 255+ uncurry translate eye1+ circle (0,0) eyer+ colorize $ Color 0 0 0 255+ circle (scalePoint (eyer/2) $ dirVector d) $ eyer/2+ uncurry translate $ cancelPoint eye1+ -- Eye 2+ colorize $ Color 255 255 255 255+ uncurry translate eye2+ circle (0,0) eyer+ colorize $ Color 0 0 0 255+ circle (scalePoint (eyer/2) $ dirVector d) $ eyer/2+ uncurry translate $ cancelPoint eye2++drawPacman :: Proc_Point -> Direction -> Proc_Int -> EventM Draw ()+drawPacman p d fr = do+ colorize $ Color 255 255 0 255+ let initAngle = (pi*intToFloat fr)/(4*intToFloat maxFrame)+ endAngle = 2*pi - initAngle+ arc p cellWidth cellWidth (d+initAngle) (d+endAngle)++cornerOf :: Proc_Int -> Proc_Int -> Proc_Point+cornerOf i j = (intToFloat j * cellWidth, intToFloat i * cellWidth)++centerOf :: Proc_Int -> Proc_Int -> Proc_Point+centerOf i j = cornerOf i j <+> (cellWidth/2, cellWidth/2)++pacmanScript :: Int -- Number of rows+ -> Int -- Number of columns+ -> Int -- Number of dots+ -> [Int] -- Map+ -> ProcScript+pacmanScript rows cols dots map = execScriptM $ do+ mapv <- newArrayVar $ fmap fromInt map+ dotv <- newVar $ fromInt dots -- Remaining dots+ stv <- newVarC initialState+ framev <- newVar 1 -- Pacman frame+ mouthv <- newVar 1 -- Mouth switcher+ boolv <- newVar false -- Boolean aux var+ let tileIndex :: Num a => a -> a -> a+ tileIndex i j = i * fromIntegral cols + j+ getTile :: Proc_Int -> Proc_Int -> EventM c Tile+ getTile i j = readArrayVar mapv $ tileIndex i j+ on Setup $ do+ setFrameRate framesPerSecond+ on Draw $ do+ -- Size+ size screenWidth screenHeight+ -- Background+ background $ Color 0 0 0 255+ -- Set center at the center of the screen+ translate (intToFloat screenWidth/2) (intToFloat screenHeight/2)+ -- Read state+ st <- readVarC stv+ -- Set bottom-left corner as the origin of coordinates+ let (cornerX,cornerY) = ((-cellWidth) * intToFloat (fromInt rows)/2+ ,(-cellWidth) * (intToFloat (fromInt cols)/2))+ translate cornerX cornerY+ -- Draw map+ let drawAt :: Proc_Int -- Row number+ -> Proc_Int -- Col number+ -> (Proc_Point -> EventM Draw ()) -- Drawing function+ -> EventM Draw ()+ drawAt i j f = f $ cornerOf i j+ tilesOf :: Int -> [(Proc_Int,Proc_Int)]+ tilesOf t = [ (fromInt i,fromInt j)+ | i <- [ 0 .. rows - 1 ] , j <- [ 0 .. cols - 1 ]+ , map !! tileIndex i j == t ]+ twalls = tilesOf 0+ tdots = tilesOf 1+ tenergizers = tilesOf 2+ tgwalls = tilesOf 4+ mapM_ (\(i,j) -> drawAt i j drawWall) twalls -- Walls+ mapM_ (\(i,j) -> drawAt i j drawGWall) tgwalls -- Ghost walls+ mapM_ (\(i,j) -> do t <- getTile i j+ when (t #== 1) $ drawAt i j drawDot) tdots -- Dots+ mapM_ (\(i,j) -> do t <- getTile i j+ when (t #== 2) $ drawAt i j drawEnergizer) tenergizers -- Energizers+ -- Draw helper+ fill $ Color 255 255 255 255+ drawAt (-1) 0 $ \p -> drawtext (fromStText $ "Use Arrow keys to move. Yellow dots will make "+ <> "ghosts not follow you for a few seconds.") p 500 200+ -- Remove ghost walls after the first scatter time+ when (chaseMode st) $ mapM_ (\(i,j) -> writeArrayVar mapv (tileIndex i j) 0) tgwalls+ -- Cycle scalar+ let cycleScalar = intToFloat (moveCycle st) / cycleLength+ -- Draw ghosts+ mapM_ (\g -> drawGhost (ghostColor g)+ (middlePoint cycleScalar (uncurry centerOf $ ghostPos g st)+ (uncurry centerOf $ ghostTarget g st))+ (ghostDir g st)) allGhosts+ -- Read pacman frame+ fr <- readVar framev+ mouth <- readVar mouthv+ -- Draw pacman+ let pacmanR2 = middlePoint cycleScalar (uncurry centerOf $ pacmanPos st)+ (uncurry centerOf $ pacmanTarget st)+ drawPacman pacmanR2 (pacmanDir st) fr+ -- Update pacman frame+ ifM (fr #== maxFrame #|| fr #== 0)+ (do writeVar mouthv $ negate mouth+ writeVar framev $ fr + negate mouth)+ (writeVar framev $ fr + mouth)+ -- Pacman movement+ let (willI,willJ) = pacmanTarget st <+> dirPos (pacmanWillDir st)+ willwall <- fmap isWall $ getTile willI willJ+ let newDir = if_ (moveCycle st #== cycleLength #&& pnot willwall) (pacmanWillDir st) (pacmanDir st)+ (targetI,targetJ) = pacmanTarget st+ targetTile <- getTile targetI targetJ+ comment "Eating"+ when (moveCycle st #== cycleLength)+ (do -- Eat dot+ when (targetTile #== 1) $ do writeArrayVar mapv (tileIndex targetI targetJ) 3+ readVar dotv >>= writeVar dotv . (+ negate 1)+ -- Eat energizer+ when (targetTile #== 2) $ do writeArrayVar mapv (tileIndex targetI targetJ) 3+ )+ let (ntargetI,ntargetJ) = pacmanTarget st <+> dirPos newDir+ headedToWall <- fmap isWall $ getTile ntargetI ntargetJ+ -- Ghosts movement (blinky, pinky, inky, clyde)+ [ (bpos,bdir,btar),(ppos,pdir,ptar)+ , (ipos,idir,itar),(cpos,cdir,ctar)] <- mapM (+ \g -> moveGhost g st getTile+ ) allGhosts+ -- Check if game is lost+ let nextToGhost g =+ (pacmanPos st #=== ghostTarget g st #&& pacmanDir st #/= ghostDir g st) #||+ (pacmanPos st #=== ghostPos g st)+ lose = foldr (#||) false $ fmap nextToGhost allGhosts+ -- End of the game titles+ resetMatrix+ translate (intToFloat screenWidth/2) (intToFloat screenHeight/2)+ scale 5 5+ fill $ Color 255 255 255 255+ -- Lost title+ when (isLost st) $ drawtext "You have been eaten!" (-65,-5) 500 500+ -- Won title+ when (isWon st) $ drawtext "You win!" (-28,-5) 500 500+ -- Remaining dots+ remdots <- readVar dotv+ -- Update state+ comment "Update state"+ when (pnot $ isWon st #|| isLost st) $ writeVarC stv $ st {+ pacmanPos = ifC (moveCycle st #== cycleLength)+ (pacmanTarget st)+ (pacmanPos st)+ , pacmanDir = newDir+ , pacmanTarget = ifC (moveCycle st #== cycleLength #&& pnot headedToWall)+ (ntargetI,ntargetJ)+ (pacmanTarget st)+ , moveCycle = if_ (moveCycle st #== cycleLength) 0 (moveCycle st + 1)+ , blinkyPos = bpos+ , blinkyDir = bdir+ , blinkyTarget = btar+ , pinkyPos = ppos+ , pinkyDir = pdir+ , pinkyTarget = ptar+ , inkyPos = ipos+ , inkyDir = idir+ , inkyTarget = itar+ , clydePos = cpos+ , clydeDir = cdir+ , clydeTarget = ctar+ , chaseMode = if_ (moveCycle st #== cycleLength #&& targetTile #== 2)+ false+ (if_ (modeTimer st #== 0) (pnot $ chaseMode st) (chaseMode st))+ , modeTimer = if_ (moveCycle st #== cycleLength #&& targetTile #== 2)+ (2*scatterTime)+ (if_ (modeTimer st #== 0)+ (if_ (chaseMode st) scatterTime chaseTime)+ (modeTimer st - 1))+ , isLost = lose+ , isWon = remdots #== 0+ }+ on KeyPressed $ do+ st <- readVarC stv+ -- Change will dir+ matchKey boolv $ ArrowKey UP+ bUP <- readVar boolv+ matchKey boolv $ ArrowKey DOWN+ bDOWN <- readVar boolv+ matchKey boolv $ ArrowKey LEFT+ bLEFT <- readVar boolv+ matchKey boolv $ ArrowKey RIGHT+ bRIGHT <- readVar boolv+ let will = if_ bUP up+ $ if_ bDOWN down+ $ if_ bLEFT left+ $ if_ bRIGHT right+ $ pacmanWillDir st+ writeVarC stv $ st { pacmanWillDir = will }++wallColor :: Color+wallColor = Color 0 0 255 255++dotColor :: Color+dotColor = Color 240 240 255 255++energizerColor :: Color+energizerColor = Color 255 255 0 255++ghostWallColor :: Color+ghostWallColor = Color 255 192 203 255++when :: Proc_Bool -> EventM c () -> EventM c ()+when b x = ifM b x $ return ()++drawWall :: Proc_Point -> EventM Draw ()+drawWall p = colorize wallColor >> rect p cellWidth cellWidth++drawGWall :: Proc_Point -> EventM Draw ()+drawGWall p = colorize ghostWallColor >> rect p cellWidth cellWidth++drawDot :: Proc_Point -> EventM Draw ()+drawDot p = colorize dotColor >> circle (p <+> (cellWidth/2,cellWidth/2)) (cellWidth/10)++drawEnergizer :: Proc_Point -> EventM Draw ()+drawEnergizer p = colorize energizerColor >> circle (p <+> (cellWidth/2,cellWidth/2)) (cellWidth/5)++-- GHOST BEHAVIOR (Blinky, Pinky, Inky and Clyde)++ghostWill :: Ghost -> State -> Pos+ghostWill Blinky st = pacmanPos st+ghostWill Pinky st = pacmanPos st <+> scalePoint 4 (dirPos $ pacmanDir st)+ghostWill Inky st =+ let pac2 = pacmanPos st <+> scalePoint 2 (dirPos $ pacmanDir st)+ in blinkyPos st <+> scalePoint 2 (pac2 <+> cancelPoint (blinkyPos st))+ghostWill Clyde st =+ let d = distance (uncurry centerOf $ clydePos st) (uncurry centerOf $ pacmanPos st)+ in ifC (d #> 8*cellWidth) (pacmanPos st) (ghostHome Clyde)++closestTo :: Pos -- Current position+ -> Pos -- Target position+ -> [(Direction,Tile)] -- List of directions to take, and what is in each one+ -> (Direction,Tile)+closestTo _ _ [(d,t)] = (d,t)+closestTo p0 pT ((d,t):xs) = ifC (t' #== 0) (d,t) $+ ifC (t #== 0) (d',t') $+ ifC (d1 #<= d2) (d,t) (d',t')+ where+ (d',t') = closestTo p0 pT xs+ d1 = distance (uncurry centerOf $ p0 <+> dirPos d ) $ uncurry centerOf pT+ d2 = distance (uncurry centerOf $ p0 <+> dirPos d') $ uncurry centerOf pT++chooseDir :: Ghost -> State -> [(Direction,Tile)] -> Direction+chooseDir g st xs = fst $ closestTo (ghostPos g st) willPos xs+ where+ willPos :: Pos+ willPos = ifC (chaseMode st) (ghostWill g st) (ghostHome g)++moveGhost :: Ghost -> State+ -> (Proc_Int -> Proc_Int -> EventM Draw Tile)+ -> EventM Draw (Pos,Direction,Pos)+moveGhost g st getTile = do+ let newPos = ifC (moveCycle st #== cycleLength)+ (ghostTarget g st)+ (ghostPos g st)+ -- Direction+ let fronts = frontDirs $ ghostDir g st+ frontTiles <- mapM (uncurry getTile) $ fmap (\d -> ghostTarget g st <+> dirPos d) fronts+ let newDir = if_ (moveCycle st #== cycleLength)+ (chooseDir g st $ zip fronts frontTiles)+ (ghostDir g st)+ -- Target+ let newTarget = ifC (moveCycle st #== cycleLength)+ (ghostTarget g st <+> dirPos newDir)+ (ghostTarget g st)+ -- Return+ return (newPos,newDir,newTarget)
+ examples/pacman.map view
@@ -0,0 +1,31 @@+0000000000000000000000000000+0111111111111001111111111110+0100001000001001000001000010+0200001000001001000001000020+0100001000001001000001000010+0111111111111111111111111110+0100001001000000001001000010+0100001001000000001001000010+0111111001111001111001111110+0000001000003003000001000000+3333301000003003000001033333+3333301003333333333001033333+3333301003004004003001033333+3333301003003003003001033333+3333301333003003003331033333+3333301003003333003001033333+3333301003000000003001033333+3333301003333333333001033333+3333301003000000003001033333+0000001003000000003001000000+0111111111111001111111111110+0100001000001001000001000010+0100001000001001000001000010+0211001111111111111111001120+0001001001000000001001001000+0001001001000000001001001000+0111111001111001111001111110+0100000000001001000000000010+0100000000001001000000000010+0111111111111111111111111110+0000000000000000000000000000
license view
@@ -1,30 +1,30 @@-Copyright (c)2013, Daniel Díaz - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Daniel Díaz nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c)2013, Daniel Díaz++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Daniel Díaz nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
processing.cabal view
@@ -1,5 +1,5 @@ Name: processing-Version: 1.1.0.0+Version: 1.2.0.0 Author: Daniel Díaz Category: Graphics Build-type: Simple@@ -7,7 +7,7 @@ License-file: license Maintainer: Daniel Díaz (dhelta.diaz `at` gmail.com) Bug-reports: https://github.com/Daniel-Diaz/processing/issues-Synopsis: Web graphic applications with Processing.+Synopsis: Web graphic applications with processing.js. Stability: In development Tested-with: GHC == 7.6.3 Description:@@ -24,16 +24,25 @@ . /Where can I see a running example?/ .- An example output can be reached at <http://liibe.com/experimental/rocket.html>.- Also, take a look at <http://liibe.com/experimental/mill.html>.- The code of the latter is included in the source distribution (\/examples\/mill.hs).+ Running examples are provided in the /examples/ directory.+ These are some of the outputs: .+ * Mill demo. Preview: <http://daniel-diaz.github.io/projects/processing/mill.html>.+ Code: <https://github.com/Daniel-Diaz/processing/blob/master/examples/mill.hs>.+ .+ * Pacman demo. Preview: <http://daniel-diaz.github.io/projects/processing/pacman.html>.+ Code: <https://github.com/Daniel-Diaz/processing/blob/master/examples/pacman.hs>.+ .+ The code of the latter is included in the source distribution.+ . /How do I learn to use it?/ . The API reference of the library includes guidance and is complemented with code examples. Look also to the /examples/ directory included in the source- distribution. It contains some fully working examples.+ distribution. It contains some fully working examples. Also online at: .+ <https://github.com/Daniel-Diaz/processing/tree/master/examples>+ . The library provides different APIs (interfaces). Each one with a different philosophy. .@@ -59,6 +68,8 @@ examples/mill.hs examples/keys.hs examples/random.hs+ examples/pacman.hs+ examples/pacman.map Source-repository head type: git@@ -73,8 +84,13 @@ , mainland-pretty >= 0.2 && < 0.3 , blaze-html >= 0.5.1 && < 0.7 , multiset >= 0.2.2 && < 0.3- , directory- , filepath+ , directory >= 1.2 && < 1.3+ , filepath >= 1.1.0.0 && < 1.4+ -- QuickCheck+ , QuickCheck+ , quickcheck-instances+ -- Template Haskell+ , template-haskell -- Compatibility with previous GHC versions. if impl(ghc < 7.6) Build-depends: ghc-prim@@ -97,14 +113,15 @@ -- HTML Graphics.Web.Processing.Html Other-modules:+ Graphics.Web.Processing.Core.TH Graphics.Web.Processing.Core.Primal Graphics.Web.Processing.Core.Monad Extensions: OverloadedStrings , EmptyDataDecls- -- , DeriveGeneric+ -- , DeriveGeneric (used, but not recognized) , MultiParamTypeClasses , FunctionalDependencies , TypeOperators- -- , DefaultSignatures+ -- , DefaultSignatures (used, but not recognized) , FlexibleContexts GHC-Options: -Wall