context-free-art 0.2.0.2 → 0.2.0.3
raw patch · 4 files changed
+122/−65 lines, 4 filesdep +safePVP ok
version bump matches the API change (PVP)
Dependencies added: safe
API changes (from Hackage documentation)
Files
- Art/Geometry.hs +12/−1
- Art/Interpreter.hs +49/−60
- Tests.hs +57/−3
- context-free-art.cabal +4/−1
Art/Geometry.hs view
@@ -1,6 +1,5 @@ module Art.Geometry where -import Control.Arrow import Data.Biapplicative -- | A vector in 2d euclidian space.@@ -20,3 +19,15 @@ scaleVec :: Float -> Vec -> Vec scaleVec n = both (* n)++radDegRatio :: Float+radDegRatio = pi / 180++degToRad :: Float -> Float+degToRad = (* radDegRatio)++rotateZero :: Float -> Vec -> Vec+rotateZero amtd (x, y)+ = (x * cos amt - y * sin amt, y * cos amt + x * sin amt)+ where+ amt = degToRad amtd
Art/Interpreter.hs view
@@ -4,20 +4,15 @@ module Art.Interpreter ( interpret ) where -import TextShow+import Control.Arrow import Data.List import Data.List.NonEmpty hiding (reverse)-import Data.Functor-import Data.Function import Data.Maybe import System.Random import Text.Blaze-import qualified Data.Text as T-import qualified TextShow as T import Text.Blaze.Svg11 ((!)) import qualified Text.Blaze.Svg11 as S import qualified Text.Blaze.Svg11.Attributes as A-import Text.Blaze.Svg.Renderer.String (renderSvg) import Art.Geometry import Art.Grammar@@ -26,20 +21,10 @@ type Bound = (Float, Float, Float, Float) type BoundRes = Maybe Bound type Res = (BoundRes, S.Svg)--data State- = State- { position :: Vec- , scale :: Float- }--emptyBound = Nothing-emptyRes = (emptyBound, mempty)-zeroPt = (0, 0)-emptyState = State { position = zeroPt, scale = 1.0 }+type State = Vec -zero :: AttributeValue-zero = toValue (0 :: Int)+emptyRes :: Res+emptyRes = (Nothing, mempty) combineBounds :: [BoundRes] -> BoundRes combineBounds boundsM =@@ -50,17 +35,17 @@ -- pos, path poly :: State -> [Vec] -> Res-poly State{ position=pos, scale=scale } pts = - let newPts = scaleVec scale <$> pos : pts+poly pos pts =+ let newPts = pos : pts (x, y) = pos (_, b) = foldl nextRes (pos, Just (x, y, x, y)) newPts in (b, S.path ! A.d (toValue $ toPath newPts)) where nextRes ((x, y), b) (dx, dy) = let (i, j) = (x + dx, y + dy)- in ( (i, j)- , combineBounds [b, Just (i, j, i, j)]- )+ in ( (i, j)+ , combineBounds [b, Just (i, j, i, j)]+ ) -- rad, pos circle :: Float -> Vec -> Res@@ -71,35 +56,34 @@ ! A.cx (toValue x) ! A.cy (toValue y)) -groupModifier :: State -> Modifier -> Maybe (S.Svg -> S.Svg)-groupModifier State { position = (x, y) } = \case+modifyGroup :: Modifier -> Maybe (S.Svg -> S.Svg)+modifyGroup = \case Color c -> Just (! A.fill (toValue c))- Rotate n -> Just (! A.transform- (toValue $ "rotate(" <> T.unwords (T.showt <$> [n, x, y]) <> ")")) _ -> Nothing modifyState :: State -> Modifier -> State-modifyState s@State{ position = pos, scale = scale } = \case- Move p -> s{ position = addVecs pos (scaleVec scale p) }- Scale n -> s{ scale = scale * n }- _ -> s+modifyState pos = \case+ Move p -> addVecs pos p+ _ -> pos +modifySubs :: Modifier -> Symbol -> Symbol+modifySubs (Move _) subs = subs+modifySubs (Scale s) (Circle r) = Circle $ s * r+modifySubs (Scale s) (Poly vs) = Poly $ scaleVec s <$> vs+modifySubs (Rotate r) (Poly vs) = Poly $ rotateZero r <$> vs+modifySubs m (NonTerminal prods)+ = NonTerminal $ second (modifySubs m) <$> prods+modifySubs mo (Mod ms a)+ = Mod (modifyMod mo <$> ms) $ modifySubs mo a+ where+ modifyMod (Scale s) (Move m) = Move $ scaleVec s m+ modifyMod (Rotate r) (Move m) = Move $ rotateZero r m+ modifyMod _ m = m+modifySubs _ subs = subs+ in100 :: Int -> Int in100 = (`mod` 100) . abs -foldMods :: State -> [Modifier] -> (State, S.Svg -> S.Svg)-foldMods state mods =- let (maybeGroupMods, newState) = foldl applyMod ([], state) mods- groupMods = catMaybes maybeGroupMods- maybeLayer =- if null groupMods- then id- else foldl (<&>) S.g groupMods- in (newState, maybeLayer)- where- applyMod (groupMods, state) mod =- (groupModifier state mod : groupMods , modifyState state mod)- joinRes :: Res -> Res -> Res joinRes (b1, s1) (b2, s2) = (combineBounds [b1, b2], s1 >> s2) @@ -107,26 +91,31 @@ sequenceRes rs = foldl joinRes emptyRes <$> sequence rs interpretNonTerminal :: State -> Production -> IO Res-interpretNonTerminal state prod@(prob, sym)+interpretNonTerminal state (prob, sym) = (< prob) . fromIntegral . in100 <$> randomIO >>= \case True -> interpretSymbol state sym False -> pure emptyRes -second :: (a -> b) -> (c, a) -> (c, b)-second f (a, b) = (a, f b)- interpretSymbol :: State -> Symbol -> IO Res-interpretSymbol state@State{ position = pos, scale = scale }- = \case- NonTerminal (x :| []) -> interpretNonTerminal state x- NonTerminal (x :| (y: ys)) ->- sequenceRes (interpretNonTerminal state <$> (x :| y : ys))- Circle r -> pure $ circle (r * scale) pos- Poly pts -> pure $ poly state pts- Mod mods sym ->- let (newState, layerMod) = foldMods state mods- in second layerMod <$> interpretSymbol newState sym+interpretSymbol state = \case+ NonTerminal (x :| []) -> interpretNonTerminal state x+ NonTerminal (x :| (y: ys)) ->+ sequenceRes (interpretNonTerminal state <$> (x :| y : ys))+ Circle r -> pure $ circle r state+ Poly pts -> pure $ poly state pts+ Mod [] sym -> interpretSymbol state sym+ Mod ms sym ->+ let groupMods = catMaybes $ modifyGroup <$> ms+ ed = if null groupMods then id else foldl (flip fmap) S.g groupMods+ sub = interpretMods state ms sym+ in second ed <$> sub+ where+ interpretMods state' [] sym = interpretSymbol state' sym+ interpretMods state' (m : ms) sym =+ let newState = modifyState state' m+ newMods = modifySubs m $ Mod ms sym+ in interpretSymbol newState newMods fourTupLst :: (a, a, a, a) -> [a] fourTupLst (a, b, c, d) = [a, b, c, d]@@ -145,7 +134,7 @@ -- blaze-svg's render functions, for example 'renderSvg'. interpret :: Symbol -> IO S.Svg interpret sym =- finalise <$> interpretSymbol emptyState sym+ finalise <$> interpretSymbol (0, 0) sym where finalise :: Res -> S.Svg finalise (bounds, svg) = toSVG (boundsToViewBox (fromMaybe (0, 0, 0, 0) bounds)) svg
Tests.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -import Data.List import Data.List.NonEmpty import Test.HUnit hiding (path) import Text.Blaze@@ -34,18 +33,21 @@ path :: [Vec] -> S.Svg path pts = S.path ! A.d (toValue $ toPath pts) +rendersCircle :: Test rendersCircle = testRender "circle" circleSym [-1, -1, 2, 2] $ circle 1 (0, 0) where circleSym = Circle 1 +rendersCircleWithRadius :: Test rendersCircleWithRadius = testRender "circlewith radius" circleSym [-2, -2, 4, 4] $ circle 2 (0, 0) where circleSym = Circle 2 +translatedCircle :: Test translatedCircle = testRender "translated circle" a [5, 5, 2, 2] $ circle 1 (6, 6)@@ -53,6 +55,7 @@ a = Mod [Move (6, 6)] b b = Circle 1 +scaledCircle :: Test scaledCircle = testRender "scaled circle" a [-0.5, -0.5, 1, 1] $ circle 0.5 (0, 0)@@ -60,6 +63,7 @@ a = Mod [Scale 0.5] b b = Circle 1 +translatedScaledCircle :: Test translatedScaledCircle = testRender "translated scaled circle" a [10, 10, 4, 4] $ circle 2 (12, 12)@@ -67,6 +71,7 @@ a = Mod [Scale 2, Move (6, 6)] b b = Circle 1 +scaledTranslatedCircle :: Test scaledTranslatedCircle = testRender "scaled translated circle" a [4, 4, 4, 4] $ circle 2 (6, 6)@@ -74,6 +79,7 @@ a = Mod [Move (6, 6), Scale 2] b b = Circle 1 +multipleScaledTranslatedCircles :: Test multipleScaledTranslatedCircles = testRender "multiple symbols under one non-terminal" a [10, 10, 20, 20] $ circle 2 (12, 12) >> circle 2 (28, 28)@@ -84,12 +90,14 @@ d = Circle 0.5 e = NonTerminal $ (100, b) :| [(100, c)] +rendersPoly :: Test rendersPoly = testRender "poly" a [0, 0, 2, 1] $ path [(0, 0), (1, 1), (1, -1)] where a = Poly [(1, 1), (1, -1)] +rendersPolyTranslated :: Test rendersPolyTranslated = testRender "translated poly" a [1, 1, 3, 2] $ path [(1, 1), (1, 1), (1, 0)]@@ -97,6 +105,7 @@ a = Mod [Move (1, 1)] b b = Poly [(1, 1), (1, 0)] +rendersPolyScaled :: Test rendersPolyScaled = testRender "scaled poly" a [0, -3, 6, 6] $ path [(0, 0), (3, 3), (3, -6)]@@ -104,6 +113,7 @@ a = Mod [Scale 3] b b = Poly [(1, 1), (1, -2)] +rendersPolyScaled2 :: Test rendersPolyScaled2 = testRender "another scaled poly" a [-4, 0, 4, 4] $ path [(0, 0), (-4, 4), (2, -4)]@@ -111,6 +121,7 @@ a = Mod [Scale 2] b b = Poly [(-2, 2), (1, -2)] +fill :: Test fill = testRender "fill" a [-1, -1, 2, 2] $ S.g ! A.fill "green" $ circle 1 (0, 0)@@ -118,13 +129,49 @@ a = Mod [Color "green"] b b = Circle 1 +rotate :: Test rotate = testRender "rotation" a [-1, -1, 2, 2]- $ S.g ! A.transform "rotate(10.0 0.0 0.0)" $ circle 1 (0, 0)+ $ circle 1 (0, 0) where a = Mod [Rotate 10] b b = Circle 1 +rotateAndMove :: Test+rotateAndMove+ = testRender "rotate and move" a [0, -1, 2, 2]+ $ circle 1 (1, 0)+ where+ a = Mod [Rotate 90, Move (0, -1)] b+ b = Circle 1++rotateAndMove2 :: Test+rotateAndMove2+ = testRender "rotate and move" a [0, -1, 2, 3]+ $ circle 1 (1, 0) >> circle 1 (1, 1)+ where+ a = modif $ NonTerminal $ (100, Circle 1) :| [(100, modif $ Circle 1)]+ modif = Mod [Rotate 90, Move (0, -1)]++assertClose :: String -> Float -> Float -> Assertion+assertClose s a b = assertEqual s True $ abs (a - b) < 0.000001++testRotateVec :: Test+testRotateVec+ = let (x, y) = rotateZero 90 (0, -1)+ in TestCase $ do+ assertClose "rotate vec x" 1 x+ assertClose "rotate vec x" 0 y++testReflectVec :: Test+testReflectVec+ = TestCase $ assertEqual "reflect vec" (1, 1) $ reflectVec (-1, -1)++testSubVecs :: Test+testSubVecs+ = TestCase $ assertEqual "sub vec" (1, 2) $ subVecs (2, 4) (1, 2)++svgToText :: Test svgToText = TestCase $ do res <- renderSvg <$> interpret (Circle 1) assertEqual "svg text generation" res $@@ -136,6 +183,7 @@ <> "viewBox=\"-1.0 -1.0 2.0 2.0\"><circle r=\"1.0\"" <> " cx=\"0.0\" cy=\"0.0\" /></svg>" +tests :: Test tests = TestList [ svgToText , rendersCircle@@ -146,11 +194,17 @@ , scaledTranslatedCircle , multipleScaledTranslatedCircles , rendersPoly- , rendersPolyTranslated+ , rendersPolyTranslated -- 10 , rendersPolyScaled , rendersPolyScaled2 , fill , rotate+ , testRotateVec+ , testReflectVec+ , rotateAndMove+ , rotateAndMove2+ , testSubVecs ] +main :: IO Counts main = runTestTT tests
context-free-art.cabal view
@@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/ name: context-free-art-version: 0.2.0.2+version: 0.2.0.3 synopsis: Generate art from context-free grammars description: .@@ -62,6 +62,8 @@ , text-show >= 3.8 , text >= 1.2 , HUnit >= 1.6+ , safe+ ghc-options: -Wall -fwarn-incomplete-patterns default-language: Haskell2010 library@@ -77,4 +79,5 @@ , bifunctors >= 5.5 , text-show >= 3.8 , text >= 1.2+ , safe default-language: Haskell2010