diff --git a/Art/Geometry.hs b/Art/Geometry.hs --- a/Art/Geometry.hs +++ b/Art/Geometry.hs @@ -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 diff --git a/Art/Interpreter.hs b/Art/Interpreter.hs --- a/Art/Interpreter.hs +++ b/Art/Interpreter.hs @@ -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 diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -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\"> " cx=\"0.0\" cy=\"0.0\" />" +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 diff --git a/context-free-art.cabal b/context-free-art.cabal --- a/context-free-art.cabal +++ b/context-free-art.cabal @@ -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