context-free-art (empty) → 0.1.0.0
raw patch · 10 files changed
+467/−0 lines, 10 filesdep +HUnitdep +basedep +bifunctorssetup-changed
Dependencies added: HUnit, base, bifunctors, blaze-markup, blaze-svg, extra, random, text, text-show
Files
- Art/ContextFree.hs +23/−0
- Art/Geometry.hs +20/−0
- Art/Grammar.hs +26/−0
- Art/Interpreter.hs +140/−0
- Art/Util.hs +14/−0
- CHANGELOG.md +5/−0
- LICENSE +11/−0
- Setup.hs +2/−0
- Tests.hs +144/−0
- context-free-art.cabal +82/−0
+ Art/ContextFree.hs view
@@ -0,0 +1,23 @@+{-|+Module : Art.ContextFree+Description : Generate art from context-free grammars+Copyright : (c) Owen Shepherd, 2019+License : BSD-3-Clause+Maintainer : 414owen@gmail.com+Stability : experimental++Create art via context free grammar production rules.+-}++module Art.ContextFree+ ( Modifier(..)+ , Symbol(..)+ , Vec+ , Production+ , interpret+ ) where++import Art.Grammar+import Art.Interpreter+import Art.Util+import Art.Geometry
+ Art/Geometry.hs view
@@ -0,0 +1,20 @@+module Art.Geometry where++import Control.Arrow+import Data.Tuple.Extra+import Data.Biapplicative++-- | A vector in 2d euclidian space.+type Vec = (Float, Float)++addVecs :: Vec -> Vec -> Vec+addVecs = biliftA2 (+) (+)++reflectVec :: Vec -> Vec+reflectVec = both negate++subVecs :: Vec -> Vec -> Vec+subVecs v1 v2 = addVecs v1 $ reflectVec v2++scaleVec :: Float -> Vec -> Vec+scaleVec n = both (* n)
+ Art/Grammar.hs view
@@ -0,0 +1,26 @@+module Art.Grammar where++import Data.List.NonEmpty+import Art.Geometry++-- | Change the style applied to all downstream terminal symbols.+data Modifier+ = Color String+ | Scale Float+ | Move Vec++-- | A production rule, including a starting probability of generation,+-- a list of styles to be applied to sub-grammars, and a non-empty list of+-- symbols to produce.+type Production = (Float, [Modifier], NonEmpty Symbol)++-- | A Terminal or non-terminal symbol.+data Symbol+ = NonTerminal (NonEmpty Production)++ -- | Produce a circle with a radius.+ | Circle Float++ -- | Produce a polygon by relative points.+ -- Starts and ends at (0, 0).+ | Poly [Vec]
+ Art/Interpreter.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}++module Art.Interpreter ( interpret ) where++import TextShow+import Data.List+import Data.List.NonEmpty hiding (reverse)+import Data.Tuple.Extra+import Data.Functor+import Data.Function+import Data.Maybe+import System.Random+import Text.Blaze+import qualified Data.Text 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+import Art.Util++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 }++zero :: AttributeValue+zero = toValue (0 :: Int)++combineBounds :: [BoundRes] -> BoundRes+combineBounds boundsM =+ let bounds = catMaybes boundsM+ (x1, y1, x2, y2) = unzip4 bounds+ in if null bounds then Nothing else+ Just (minimum x1, minimum y1, maximum x2, maximum y2)++-- pos, path+poly :: State -> [Vec] -> Res+poly State{ position=pos, scale=scale } pts = + let newPts = scaleVec scale <$> 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)]+ )++-- rad, pos+circle :: Float -> Vec -> Res+circle rad (x, y)+ = ( Just (x - rad, y - rad, x + rad, y + rad)+ , S.circle+ ! A.r (toValue rad)+ ! A.cx (toValue x)+ ! A.cy (toValue y))++groupModifier :: Modifier -> Maybe (S.Svg -> S.Svg)+groupModifier = \case+ Color c -> Just (! A.fill (toValue c))+ _ -> 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++in100 :: Int -> Int+in100 = (`mod` 100) . abs++foldMods :: State -> [Modifier] -> (State, S.Svg -> S.Svg)+foldMods state mods =+ let newState = foldl modifyState state mods+ groupMods = mapMaybe groupModifier mods+ maybeLayer =+ if null groupMods+ then id+ else foldl (<&>) S.g groupMods+ in (newState, maybeLayer)++joinRes :: Res -> Res -> Res+joinRes (b1, s1) (b2, s2) = (combineBounds [b1, b2], s1 >> s2)++sequenceRes :: (Monad m, Traversable t) => t (m Res) -> m Res+sequenceRes rs = foldl joinRes emptyRes <$> sequence rs++interpretNonTerminal :: State -> Production -> IO Res+interpretNonTerminal state prod@(prob, mods, syms)+ = (< prob) . fromIntegral . in100 <$> randomIO+ >>= \case+ True ->+ let (newState, layerMod) = foldMods state mods+ in second layerMod <$> sequenceRes (interpretSymbol newState <$> syms)+ False -> pure emptyRes++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++fourTupLst :: (a, a, a, a) -> [a]+fourTupLst (a, b, c, d) = [a, b, c, d]++toSVG :: Bound -> S.Svg -> S.Svg+toSVG bound+ = S.docTypeSvg+ ! A.version "1.1"+ ! A.viewbox (toValue $ unwords $ show <$> fourTupLst bound)++boundsToViewBox :: Bound -> Bound+boundsToViewBox (x1, y1, x2, y2) = (x1, y1, x2 - x1, y2 - y1)++-- | Create a drawing from a grammar.+interpret :: Symbol -> IO S.Svg+interpret sym =+ finalise <$> interpretSymbol emptyState sym+ where+ finalise :: Res -> S.Svg+ finalise (Just bounds, svg) = toSVG (boundsToViewBox bounds) svg
+ Art/Util.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}++module Art.Util where++import Data.Tuple.Extra+import qualified Data.Text as T+import TextShow+import Art.Geometry++tupLst :: (a, a) -> [a]+tupLst (a, b) = [a, b]++toPath :: [Vec] -> T.Text+toPath pts = T.intercalate " l" (T.unwords . tupLst . both showt <$> pts) <> "Z"
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for context-free-art++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright 2019 Owen Shepherd++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Tests.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.List+import Data.List.NonEmpty+import Test.HUnit hiding (path)+import Data.Tuple.Extra+import Text.Blaze+import Text.Blaze.Svg11 ((!))+import qualified Text.Blaze.Svg11 as S+import qualified Text.Blaze.Svg11.Attributes as A+import Text.Blaze.Svg.Renderer.Text (renderSvg)++import Art.Grammar+import Art.Geometry+import Art.Interpreter+import Art.Util++toSvg :: [Float] -> S.Svg -> S.Svg+toSvg bound = S.docTypeSvg+ ! A.version "1.1"+ ! A.viewbox (toValue $ unwords $ show <$> bound)++testRender :: String -> Symbol -> [Float] -> S.Svg -> Test+testRender desc start bound expected = TestCase $ do+ result <- interpret start+ assertEqual desc (renderSvg $ toSvg bound expected) (renderSvg result)++circle :: Float -> Vec -> S.Svg+circle r (x, y)+ = S.circle+ ! A.r (toValue r)+ ! A.cx (toValue x)+ ! A.cy (toValue y)++path :: [Vec] -> S.Svg+path pts = S.path ! A.d (toValue $ toPath pts)++rendersCircle+ = testRender "circle" circleSym [-1, -1, 2, 2]+ $ circle 1 (0, 0)+ where+ circleSym = Circle 1++rendersCircleWithRadius+ = testRender "circlewith radius" circleSym [-2, -2, 4, 4]+ $ circle 2 (0, 0)+ where+ circleSym = Circle 2++translatedCircle+ = testRender "translated circle" a [5, 5, 2, 2]+ $ circle 1 (6, 6)+ where+ a = NonTerminal $ (100, [Move (6, 6)], b :| []) :| []+ b = Circle 1++scaledCircle+ = testRender "scaled circle" a [-0.5, -0.5, 1, 1]+ $ circle 0.5 (0, 0)+ where+ a = NonTerminal $ (100, [Scale 0.5], b :| []) :| []+ b = Circle 1++translatedScaledCircle+ = testRender "translated scaled circle" a [10, 10, 4, 4]+ $ circle 2 (12, 12)+ where+ a = NonTerminal $ (100, [Scale 2, Move (6, 6)], b :| []) :| []+ b = Circle 1++scaledTranslatedCircle+ = testRender "scaled translated circle" a [4, 4, 4, 4]+ $ circle 2 (6, 6)+ where+ a = NonTerminal $ (100, [Move (6, 6), Scale 2], b :| []) :| []+ b = Circle 1++multipleScaledTranslatedCircles+ = testRender "multiple symbols under one non-terminal" a [10, 10, 20, 20]+ $ circle 2 (12, 12) >> circle 2 (28, 28)+ where+ a = NonTerminal $ (100, [Scale 2, Move (6, 6)], b :| [c]) :| []+ b = Circle 1+ c = NonTerminal $ (100, [Scale 2, Move (4, 4)], d :| []) :| []+ d = Circle 0.5++rendersPoly+ = testRender "poly" a [0, 0, 2, 1]+ $ path [(0, 0), (1, 1), (1, -1)]+ where+ a = Poly [(1, 1), (1, -1)]++rendersPolyTranslated+ = testRender "translated poly" a [1, 1, 3, 2]+ $ path [(1, 1), (1, 1), (1, 0)]+ where+ a = NonTerminal $ (100, [Move (1, 1)], Poly [(1, 1), (1, 0)] :| []) :| []++rendersPolyScaled+ = testRender "scaled poly" a [0, -3, 6, 6]+ $ path [(0, 0), (3, 3), (3, -6)]+ where+ a = NonTerminal $ (100, [Scale 3], Poly [(1, 1), (1, -2)] :| []) :| []++rendersPolyScaled2+ = testRender "another scaled poly" a [-4, 0, 4, 4]+ $ path [(0, 0), (-4, 4), (2, -4)]+ where+ a = NonTerminal $ (100, [Scale 2], Poly [(-2, 2), (1, -2)] :| []) :| []++fill+ = testRender "another scaled poly" a [-1, -1, 2, 2]+ $ S.g ! A.fill "green" $ circle 1 (0, 0)+ where+ a = NonTerminal $ (100, [Color "green"], Circle 1 :| []) :| []++svgToText = TestCase $ do+ res <- renderSvg <$> interpret (Circle 1)+ assertEqual "svg text generation" res $+ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+ <> "<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\"\n"+ <> " \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">\n"+ <> "<svg xmlns=\"http://www.w3.org/2000/svg\" "+ <> "xmlns:xlink=\"http://www.w3.org/1999/xlink\" version=\"1.1\" "+ <> "viewBox=\"-1.0 -1.0 2.0 2.0\"><circle r=\"1.0\""+ <> " cx=\"0.0\" cy=\"0.0\" /></svg>"++tests = TestList+ [ svgToText+ , rendersCircle+ , rendersCircleWithRadius+ , scaledCircle+ , translatedCircle+ , translatedScaledCircle+ , scaledTranslatedCircle+ , multipleScaledTranslatedCircles+ , rendersPoly+ , rendersPolyTranslated+ , rendersPolyScaled+ , rendersPolyScaled2+ , fill+ ]++main = runTestTT tests
+ context-free-art.cabal view
@@ -0,0 +1,82 @@+cabal-version: 2.4+-- Initial package description 'context-free-art.cabal' generated by 'cabal+-- init'. For further documentation, see+-- http://haskell.org/cabal/users-guide/++name: context-free-art+version: 0.1.0.0+synopsis: Generate art from context-free grammars+description:+ .+ Create art via context free grammar production rules.+ Includes an SVG backend.+ .+ == Context free grammar primer+ .+ Context free grammars consist of a set of terminal symbols, a set of+ non-terminal symbols, and production rules that map non-terminals to+ other symbols.+ .+ With a context-free grammar, we can generate strings of terminals that+ conform to the specified language.+ .+ Our language will describe graphics.+ .+ == Example+ .+ > import Art.ContextFree+ > import Data.List.NonEmpty+ >+ > -- let's define a Production rule+ > a = Circle 1+ >+ > -- this will produce an IO Svg from the blaze-svg package+ > -- to turn it into a string we can use one of the `blaze-svg` renderers+ > graphic1 = interpret $ Circle 1+ >+ > -- let's create a non-terminal, at every layer,+ > -- this will have an 85% chance of rendering another circle+ > circles = NonTerminal $ (85, [Move (2, 0)], Circle 1 :| [circles]) :| []++homepage: https://github.com/414owen/context-free-art+-- bug-reports:+license: BSD-3-Clause+license-file: LICENSE+author: Owen Shepherd+maintainer: 414owen@gmail.com+-- copyright:+category: Graphics+extra-source-files: CHANGELOG.md++executable tests+ main-is: Tests.hs+ other-modules: Art.Interpreter+ , Art.Geometry+ , Art.Grammar+ , Art.Util+ build-depends: base ^>= 4.12.0.0+ , blaze-svg ^>= 0.3.6+ , random ^>= 1.1+ , blaze-markup+ , extra ^>= 1.6+ , bifunctors ^>= 5.5+ , text-show ^>= 3.8+ , text ^>= 1.2+ , HUnit ^>= 1.6+ default-language: Haskell2010++library+ exposed-modules: Art.ContextFree+ other-modules: Art.Geometry+ , Art.Util+ , Art.Interpreter+ , Art.Grammar+ build-depends: base ^>= 4.12.0.0+ , blaze-svg ^>= 0.3.6+ , random ^>= 1.1+ , blaze-markup+ , extra ^>= 1.6+ , bifunctors ^>= 5.5+ , text-show ^>= 3.8+ , text ^>= 1.2+ default-language: Haskell2010