pictikz 1.0.0.0 → 1.0.0.1
raw patch · 9 files changed
+698/−3 lines, 9 files
Files
- ChangeLog.md +4/−0
- pictikz.1 +60/−0
- pictikz.cabal +7/−3
- src/Pictikz/Drawing.hs +29/−0
- src/Pictikz/Geometry.hs +60/−0
- src/Pictikz/Graph.hs +85/−0
- src/Pictikz/Loader.hs +176/−0
- src/Pictikz/Organizer.hs +79/−0
- src/Pictikz/Parser.hs +198/−0
ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for pictikz +## 1.0.0.1 -- 2017-04-02++* Fixed small problem with the .cabal file.+ ## 1.0.0.0 -- 2017-04-02 * First version. Released on an unsuspecting world.
+ pictikz.1 view
@@ -0,0 +1,60 @@+.\" Manpage for pictikz.+.\" Contact marcelogmillani@gmail.com to correct errors or typos.+.TH man 1 "26 Mar 2017" "1.0.0.0" "pictikz man page"+.SH NAME+pictikz \- a tool for converting SVG images into tikz code.+.SH SYNOPSIS+pictikz [OPTIONS...] FILE+.SH DESCRIPTION+Tikz is often used to draw graphs (i.e., networks) in LaTeX. Even though the resulting image can be very clean, manually writing tikz code can be time consuming, especially when the picture needs to be modified afterwards.++On the other side of the spectrum, drawing with graphical tools like inkscape is easy, but getting a clean looking result can be complicated.++With pictikz you get the best of both worlds: You draw using a graphical tool and pictikz converts the resulting SVG file to tikz code, making some automatic style adjustments if you desire.+.SH OPTIONS+.PP+\fB-f, --fit WIDTH HEIGHT\fR+.RS+fit coordinates into a box of size WIDTH x HEIGHT without changing aspect ratio+.RE+\fB-g, --grid [PERCENT]\fR+.RS+fit coordinates into a grid (implies --uniform [PERCENT])+.RE+\fB-h, --help\fR+.RS+shows help+.RE+\fB-o, --output FILE\fR+.RS+writes output into FILE instead of stdout+.RE+\fB-s, --scale WIDTH HEIGHT\fR+.RS+scale coordinates into a box of size WIDTH x HEIGHT+.RE+\fB-u, --uniform [PERCENT]\fR+.RS+group coordinates by distance. Maximum distance for grouping is PERCENT of the axis in question.+.RE+\fB-v, --version\fR+.RS+outputs version and exits+.SH CONVERSION+Every circle and ellipse in the SVG file becomes a \\node[pictikz-node] in tikz.++Every rect becomes a \\node[pictikz-rectangle].++A path is converted to an edge from its initial point to its destination. Intermediary points of the path are irrelevant. The nearest nodes are used as endpoints of the edge.++If the marker-end attribute of an edge is set, it is converted to \\draw[pictikz-edgeto] in tikz. The attribute marker-start produces edgefrom instead, and both together produce edgeboth.++The pictikz-thick property in tikz is set if the stroke-width attribute of the path is at least 50% larger than the minimum stroke-width and larger than the average between the minimum and maximum stroke-width.++An edge becomes pictikz-dashed if the stroke-dasharray property is set and the length of the first dash is at least twice the stroke-width of the edge. If it is set but smaller than that, the edge becomes pictikz-dotted instead.++Finally, text objects in SVG can become labels for nodes. For each text, the nearest node is taken.+.SH BUGS+No known bugs.+.SH AUTHOR+Marcelo Garlet Millani (marcelogmillani@gmail.com)
pictikz.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: pictikz-version: 1.0.0.0+version: 1.0.0.1 synopsis: Converts a svg image to tikz code. description: Tikz is often used to draw graphs (i.e., networks) in LaTeX. Even though the resulting image can be very clean, manually writing tikz code can be time consuming, especially when the picture needs to be modified afterwards. @@ -16,13 +16,17 @@ -- copyright: category: Graphics build-type: Simple-extra-source-files: ChangeLog.md+extra-source-files: ChangeLog.md, pictikz.1 cabal-version: >=1.10 executable pictikz main-is: Main.hs- -- other-modules:+ other-modules: Pictikz.Drawing, Pictikz.Graph, Pictikz.Loader, Pictikz.Organizer, Pictikz.Geometry, Pictikz.Parser -- other-extensions: build-depends: base >=4.9 && <4.10, xml >= 1.3, transformers >= 0.5, matrix >= 0.3 hs-source-dirs: src default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/mgmillani/pictikz
+ src/Pictikz/Drawing.hs view
@@ -0,0 +1,29 @@+-- Copyright 2017 Marcelo Garlet Millani+-- This file is part of pictikz.++-- pictikz is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.++-- pictikz is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.++-- You should have received a copy of the GNU General Public License+-- along with pictikz. If not, see <http://www.gnu.org/licenses/>.++module Pictikz.Drawing where++class Drawable a where+ draw :: a -> String++class Positionable t where+ getPos :: t a -> (a,a)+ fPos :: ((a,a) -> (a,a)) -> t a -> t a++tikzpicture d = concat+ [ "\\begin{tikzpicture}\n"+ , draw d+ , "\\end{tikzpicture}\n"]
+ src/Pictikz/Geometry.hs view
@@ -0,0 +1,60 @@+-- Copyright 2017 Marcelo Garlet Millani+-- This file is part of pictikz.++-- pictikz is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.++-- pictikz is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.++-- You should have received a copy of the GNU General Public License+-- along with pictikz. If not, see <http://www.gnu.org/licenses/>.++module Pictikz.Geometry where++import Data.Matrix++data Shape a = Rectangle a a a a | Ellipsis a a a a deriving (Show, Eq)++rotate a =+ fromList 3 3 [cos a, - sin a, 0+ ,sin a, cos a, 0+ , 0, 0, 1]+translate x y =+ fromList 3 3 [1,0,x+ ,0,1,y+ ,0,0,1]+skewx a =+ fromList 3 3 [1, tan a, 0+ ,0, 1, 0+ ,0, 0, 1]+skewy a =+ fromList 3 3 [1 , 0, 0+ ,tan a, 1, 0+ ,0 , 0, 1]+scale x y =+ fromList 3 3 [x,0,0+ ,0,y,0+ ,0,0,1]++squareDistance (x0,y0) (Rectangle x y w h) =+ let dx+ | x0 >= x && x0 <= x + w = 0+ | x0 >= x + w = x0 - (x+w)+ | x0 < x = x - x0+ dy+ | y0 >= y && y0 <= y + h = 0+ | y0 >= y + h = y0 - (y+h)+ | y0 < y = y - y0+ in dx*dx + dy*dy+squareDistance (x0,y0) (Ellipsis x1 y1 rx ry) =+ let dx = (x0 - x1) / rx+ dy = (y0 - y1) / ry+ sd = dx*dx + dy*dy+ in if sd < 1 then 0 else sd+distance p0 p1 = sqrt $ squareDistance p0 p1+
+ src/Pictikz/Graph.hs view
@@ -0,0 +1,85 @@+-- Copyright 2017 Marcelo Garlet Millani+-- This file is part of pictikz.++-- pictikz is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.++-- pictikz is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.++-- You should have received a copy of the GNU General Public License+-- along with pictikz. If not, see <http://www.gnu.org/licenses/>.+++module Pictikz.Graph where++import Pictikz.Drawing++data ArrowType = ArrowTo | ArrowFrom | ArrowNone | ArrowBoth deriving (Read, Eq, Ord)+joinArrow a ArrowNone = a+joinArrow ArrowBoth b = ArrowBoth+joinArrow ArrowTo ArrowFrom = ArrowBoth+joinArrow ArrowFrom ArrowTo = ArrowBoth+joinArrow a b = b++data NodeStyle = Rectangle deriving (Show, Read, Eq, Ord)+data EdgeStyle =+ Dashed+ | Dotted+ | Thick+ | Arrow ArrowType deriving (Show, Read, Eq, Ord)+data Node a = Node a a String String [NodeStyle] deriving (Show, Read, Eq, Ord)+data Edge = Edge String String [EdgeStyle] deriving (Show, Read, Eq, Ord)+data Graph a = Graph [Node a] [Edge] deriving (Show, Read, Eq, Ord)++instance Show ArrowType where+ show ArrowTo = "pictikz-edgeto"+ show ArrowFrom = "pictikz-edgefrom"+ show ArrowBoth = "pictikz-edgeboth"+ show ArrowNone = ""++instance Positionable Node where+ getPos (Node x y _ _ _) = (x,y)+ fPos f (Node x y id name style) = let (x1,y1) = f (x,y) in Node x1 y1 id name style++instance Drawable NodeStyle where+ draw Rectangle = ", pictikz-rectangle"++instance Drawable EdgeStyle where+ draw Dotted = ", pictikz-dotted"+ draw Dashed = ", pictikz-dashed"+ draw Thick = ", pictikz-thick"+ draw (Arrow t) = ", " ++ show t++instance (Num a, Show a) => Drawable (Node a) where+ draw (Node x y id name style) = concat+ [ "\\node[pictikz-node"+ , concatMap draw style+ , "] ("+ , id,+ ") at ("+ , show x+ , ", "+ , show y+ , ") {"+ , name+ , "};\n"+ ]++instance Drawable Edge where+ draw (Edge n1 n2 style) = concat+ [ "\\draw["+ , concatMap draw style+ , "] ("+ , n1+ , ") edge ("+ , n2+ , ");\n"+ ]++instance (Num a, Show a) => Drawable (Graph a) where+ draw (Graph nodes edges) = concat $ map draw nodes ++ map draw edges
+ src/Pictikz/Loader.hs view
@@ -0,0 +1,176 @@+-- Copyright 2017 Marcelo Garlet Millani+-- This file is part of pictikz.++-- pictikz is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.++-- pictikz is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.++-- You should have received a copy of the GNU General Public License+-- along with pictikz. If not, see <http://www.gnu.org/licenses/>.++module Pictikz.Loader where++import Data.Matrix hiding (trace)+import Pictikz.Geometry+import Pictikz.Drawing+import Pictikz.Parser+import qualified Pictikz.Graph as G+import Data.List+import Data.Char+import Data.Maybe+import qualified Debug.Trace as D (trace)++import qualified Text.XML.Light as X++data Element a b = Object (Shape a) String String | Line a a a a [b] | Text a a String deriving (Show, Eq)++isObject (Object _ _ _) = True+isObject _ = False+isLine (Line _ _ _ _ _) = True+isLine _ = False+isText (Text _ _ _) = True+isText _ = False++lineStyle (Line _ _ _ _ style) = style++defaultText = Text 0 0 "ERROR"+defaultRectangle = (Rectangle 0 0 0 0, "", "", identity 3)+defaultEllipsis = (Ellipsis 0 0 0 0, "", "", identity 3)+defaultGNode = G.Node 0 0 "" ""++loadGraph svg =+ let contents = X.parseXML svg+ elements = concatMap (parseElements (identity 3)) contents+ gnames = filter isText elements+ gnodes = assignNames (filter isObject elements) gnames+ gedges = map (closest gnodes) $ fixEdgeStyle $ filter isLine elements+ in G.Graph (map (fPos (\(x,y) -> (x,-y))) (map toNode gnodes)) gedges+ where+ parseElements matrix (X.Elem element)+ -- Objects+ | (X.qName $ X.elName element) `elem` ["rect"] =+ let (shape, id, name, m2) = foldl parseRectangle defaultRectangle $ X.elAttribs element+ in [transform (matrix * m2) (Object shape id name)]+ | (X.qName $ X.elName element) `elem` ["ellipse", "circle"] =+ let (shape, id, name, m2) = foldl parseEllipsis defaultEllipsis $ X.elAttribs element+ in [transform (matrix * m2) (Object shape id name)]+ -- Transformations+ | (X.qName $ X.elName element) `elem` ["defs"] = []+ | (X.qName $ X.elName element) `elem` ["g"] =+ let matrix' = foldl parseG matrix $ X.elAttribs element+ in concatMap (parseElements (matrix * matrix') ) $ X.elContent element+ -- Edges+ | (X.qName $ X.elName element) == "path" = [transform matrix $ foldl parseEdge (Line 0 0 0 0 []) $ X.elAttribs element]+ -- Text+ | (X.qName $ X.elName element) == "text" = [transform matrix $ parseName $ X.elContent element]+ | otherwise = concatMap (parseElements matrix ) $ X.elContent element+ parseElements matrix _ = []+ transform matrix ( Object (Rectangle x y w h) id name) =+ let [x', y',_] = toList $ matrix * (fromList 3 1 [x,y,1])+ [w1,h1,w2,h2,_,_] = toList $ matrix * (fromList 3 2 [w,0,0,h,0,0])+ w' = maximum [w1,h1,0] - minimum [w1,h1,0]+ h' = maximum [w2,h2,0] - minimum [w2,h2,0]+ in (Object (Rectangle x' y' w' h') id name)+ transform matrix (Object (Ellipsis x y rx ry) id name) =+ let [x', y',_] = toList $ matrix * (fromList 3 1 [x,y,1])+ [rx1,ry1,rx2,ry2,_,_] = toList $ matrix * (fromList 3 2 [rx,0,0,ry,0,0])+ rx' = maximum [rx1,ry1,0] - minimum [rx1,ry1,0]+ ry' = maximum [rx2,ry2,0] - minimum [rx2,ry2,0]+ in (Object (Ellipsis x' y' rx' ry') id name)+ transform matrix (Line x0 y0 x1 y1 a) =+ let [x0', y0',_, x1', y1', _] = toList $ matrix * (fromList 3 2 [x0,y0,1, x1,y1,1])+ in Line x0' y0' x1' y1' a+ transform matrix (Text x y str) =+ let [x', y',_] = toList $ matrix * (fromList 3 1 [x,y,1])+ in (Text x' y' str)+ parseG matrix attr+ | "transform" == (X.qName $ X.attrKey attr) = matrix * (parseTransform $ X.attrVal attr)+ | otherwise = matrix+ parseRectangle (Rectangle x y w h, id, name, matrix) attr+ | "id" == (X.qName $ X.attrKey attr) = (Rectangle x y w h, (X.attrVal attr), name, matrix)+ | "x" == (X.qName $ X.attrKey attr) = (Rectangle (read $ X.attrVal attr :: Float) y w h, id, name, matrix)+ | "y" == (X.qName $ X.attrKey attr) = (Rectangle x (read $ X.attrVal attr :: Float) w h, id, name, matrix)+ | "height" == (X.qName $ X.attrKey attr) = (Rectangle x y w (read $ X.attrVal attr :: Float), id, name, matrix)+ | "width" == (X.qName $ X.attrKey attr) = (Rectangle x y (read $ X.attrVal attr :: Float) h, id, name, matrix)+ | "transform" == (X.qName $ X.attrKey attr) = (Rectangle x y (read $ X.attrVal attr :: Float) h, id, name, matrix * (parseTransform $ X.attrVal attr))+ | otherwise = (Rectangle x y w h, id, name, matrix)+ parseEllipsis (Ellipsis x y rx ry, id, name, matrix) attr+ | "id" == (X.qName $ X.attrKey attr) = (Ellipsis x y rx ry, (X.attrVal attr), name, matrix)+ | "cx" == (X.qName $ X.attrKey attr) = (Ellipsis (read $ X.attrVal attr :: Float) y rx ry, id, name, matrix)+ | "cy" == (X.qName $ X.attrKey attr) = (Ellipsis x (read $ X.attrVal attr :: Float) rx ry, id, name, matrix)+ | "rx" == (X.qName $ X.attrKey attr) = (Ellipsis x y (read $ X.attrVal attr :: Float) ry, id, name, matrix)+ | "ry" == (X.qName $ X.attrKey attr) = (Ellipsis x y rx (read $ X.attrVal attr :: Float) , id, name, matrix)+ | "r" == (X.qName $ X.attrKey attr) = (Ellipsis x y (read $ X.attrVal attr :: Float) (read $ X.attrVal attr :: Float), id, name, matrix)+ | "transform" == (X.qName $ X.attrKey attr) = (Ellipsis x y rx ry, id, name, matrix * (parseTransform $ X.attrVal attr))+ | otherwise = (Ellipsis x y rx ry, id, name, matrix)+ toNode (Object (Rectangle x y w h) id name) = G.Node (x + w/2) (y + h/2) id name [G.Rectangle]+ toNode (Object (Ellipsis x y _ _) id name) = G.Node x y id name []+ parseName [] = defaultText+ parseName ((X.Elem element):xs)+ | (X.qName $ X.elName element) == "tspan" =+ let (x,y, matrix) = foldl parseCoordinates (0,0, identity 3) $ X.elAttribs element+ getName (X.Text cdata) = Left $ X.cdData cdata+ getName _ = Right ""+ name = foldl (>>) (Right "") $ map getName $ X.elContent element+ in case name of+ Left n -> Text x y n+ Right _ -> defaultText+ | otherwise = parseName xs+ parseEdge (Line xa ya xb yb a) attr+ | "d" == (X.qName $ X.attrKey attr) =+ let path = parsePath $ X.attrVal attr+ ((x0,y0), (x1,y1)) = ((head path :: (Float, Float)), (last path :: (Float, Float)))+ in Line x0 y0 x1 y1 a+ | "style" == (X.qName $ X.attrKey attr) =+ let fields = parseStyle $ X.attrVal attr+ style = edgeStyle fields+ in Line xa ya xb yb style+ | otherwise = Line xa ya xb yb a+ edgeStyle :: [(String, String)] -> [(G.EdgeStyle, Float)]+ edgeStyle [] = []+ edgeStyle (x:xs) = case x of+ ("marker-end", "none") -> (G.Arrow G.ArrowNone, undefined) : edgeStyle xs+ ("marker-end", _) -> (G.Arrow G.ArrowTo, undefined) : edgeStyle xs+ ("marker-start", "none") -> (G.Arrow G.ArrowNone, undefined) : edgeStyle xs+ ("marker-start", _) -> (G.Arrow G.ArrowFrom, undefined) : edgeStyle xs+ ("stroke-width", len) -> (G.Thick, (readLength len)) : edgeStyle xs+ ("stroke-dasharray", "none") -> edgeStyle xs+ ("stroke-dasharray", dashes) -> let dash = takeWhile (/=',') dashes in (G.Dashed, (read dash :: Float)) : edgeStyle xs+ _ -> edgeStyle xs+ fixEdgeStyle ls =+ let strokeWs = map snd $ filter (\(s,v) -> s == G.Thick) $ concatMap lineStyle ls+ minStroke = minimum strokeWs+ maxStroke = maximum strokeWs+ midStroke = minStroke + (maxStroke - minStroke) / 2+ fixLine arrow [] = [G.Arrow arrow]+ fixLine arrow (s:ss) = case s of+ (G.Thick, v) -> if v > midStroke && v > minStroke * 1.4 then G.Thick : fixLine arrow ss else (fixLine arrow ss)+ (G.Dashed, v) -> (if v > 2*minStroke then G.Dashed else G.Dotted) : (fixLine arrow ss)+ (G.Arrow a, _) -> fixLine (G.joinArrow a arrow) ss+ in map (\(Line x0 y0 x1 y1 s) -> Line x0 y0 x1 y1 (fixLine G.ArrowNone s)) ls+ parseCoordinates (x,y, matrix) attr+ | "x" == (X.qName $ X.attrKey attr) = ((read $ X.attrVal attr :: Float), y, matrix)+ | "y" == (X.qName $ X.attrKey attr) = (x,(read $ X.attrVal attr :: Float), matrix)+ | "transform" == (X.qName $ X.attrKey attr) = (x,y, matrix * (parseTransform $ X.attrVal attr))+ | otherwise = (x,y, matrix)+ assignNames [] _ = []+ assignNames gnodes [] = gnodes+ assignNames gnodes (t:ts) =+ let (Object s iD n) = assignName gnodes t+ in (Object s iD n) : assignNames (filter (\(Object _ iD1 _) -> iD1 /= iD) gnodes) ts+ assignName gnodes (Text x0 y0 n) =+ let dist s = squareDistance (x0,y0) s+ (Object s iD _ ) = minimumBy (\(Object s0 _ _) (Object s1 _ _) -> compare (dist s0) (dist s1) ) gnodes+ in (Object s iD n )+ closest vertices (Line x0 y0 x1 y1 a) =+ let p0 = (x0, y0)+ p1 = (x1, y1)+ (n0,_) = minimumBy (\p q -> compare (snd p) (snd q)) $ map (\(Object shape id _) -> (id, squareDistance p0 shape)) vertices+ (n1,_) = minimumBy (\p q -> compare (snd p) (snd q)) $ map (\(Object shape id _) -> (id, squareDistance p1 shape)) vertices+ in G.Edge n0 n1 a
+ src/Pictikz/Organizer.hs view
@@ -0,0 +1,79 @@+-- Copyright 2017 Marcelo Garlet Millani+-- This file is part of pictikz.++-- pictikz is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.++-- pictikz is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.++-- You should have received a copy of the GNU General Public License+-- along with pictikz. If not, see <http://www.gnu.org/licenses/>.++module Pictikz.Organizer where++import Pictikz.Drawing+import Pictikz.Graph+import Data.List++import qualified Debug.Trace as D (trace)++fitToBox w h objects =+ let positions = map getPos objects+ xs = map fst positions+ ys = map snd positions+ shiftx = - minimum xs+ shifty = - minimum ys+ scalex = maximum xs+ scaley = maximum ys+ scale = max (scalex + shiftx) (scaley + shifty)+ in map (fPos (\(x,y) -> ((x + shiftx) * w/scale, (y + shifty) * h/scale))) objects++scaleToBox w h objects =+ let positions = map getPos objects+ xs = map fst positions+ ys = map snd positions+ shiftx = - minimum xs+ shifty = - minimum ys+ scalex = shiftx + maximum xs+ scaley = shifty + maximum ys+ in map (fPos (\(x,y) -> ((x + shiftx) * w/scalex, (y + shifty) * h/scaley))) objects++average xs = realToFrac (sum xs) / genericLength xs++-- | Organizes nodes in a way that the amount of x and y coordinates used is decreased.+-- | The given parameter `d` the maximum difference in order to merge two coordinates.+-- | The function `groupf` should convert coordinates into their grouped form+uniformCoordinatesBy groupf d ns =+ let nsx = sortBy (\n m -> compare (fst $ getPos n) (fst $ getPos m)) ns+ xs = map (fst . getPos) nsx+ dx = d * ((maximum xs) - (minimum xs))+ ux = concat $ groupf dx xs+ -- update x coordinates+ ns1 = zipWith (\n x1 -> fPos (\(x,y) -> (x1,y)) n) nsx ux+ nsy = sortBy (\n m -> compare (snd $ getPos n) (snd $ getPos m)) ns1+ ys = map (snd . getPos) nsy+ dy = d * ((maximum ys) - (minimum ys))+ uy = concat $ groupf dy ys+ in zipWith (\n y1 -> fPos (\(x,y) -> (x,y1)) n) nsy uy++genGroup f d [] = []+genGroup f d as =+ let (bs, r1) = f d as in bs : genGroup f d r1++distanceGroup d0 [] = ([], [])+distanceGroup d0 (a:as) = group' d0 d0 0 a (a:as)+ where+ group' d d0 l a0 as =+ let (g, rest) = span (\x -> x - a0 < d0) as+ a1 = average g+ l1 = genericLength g+ d1 = 0.55 * d+ in if g == [] then (take l $ repeat a0, rest) else (group' d d1 (l + l1) a1 rest)++isometricGroup d0 as =+ let gs = genGroup distanceGroup d0 as in zipWith (\g i -> map (\x -> fromIntegral i) g) gs [0,1..]
+ src/Pictikz/Parser.hs view
@@ -0,0 +1,198 @@+-- Copyright 2017 Marcelo Garlet Millani+-- This file is part of pictikz.++-- pictikz is free software: you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.++-- pictikz is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU General Public License for more details.++-- You should have received a copy of the GNU General Public License+-- along with pictikz. If not, see <http://www.gnu.org/licenses/>.++module Pictikz.Parser where++import Prelude hiding (splitAt)+import Data.Matrix+import qualified Pictikz.Geometry as G+import Control.Monad.Trans.State+import Control.Monad+import Data.List hiding (splitAt)+import Data.Char+import qualified Debug.Trace as D (trace)++splitBy :: (Char -> Bool) -> String -> [String]+splitBy _ [] = []+splitBy p xs =+ let (w, r) = span (not . p) (dropWhile p xs)+ in w : (splitBy p r)++consumeWhile :: (Char -> Bool) -> State String String+consumeWhile f = do+ str <- get+ let (x,r) = span f str+ put r+ return x++whenNotEmpty e x = do+ s <- get+ if s == "" then return e else x++mmFactor "in" = 25.4+mmFactor "cm" = 10+mmFactor "pt" = 2.834646+mmFactor "pc" = 0.2362205+mmFactor _ = 1++readLength len =+ let (n,u) = span (\x -> isNumber x || x == '.') len in (read n :: Float) * (mmFactor u)++parseStyle style = map (\f -> let (k,v) = span (/=':') f in (k,tail v) ) $ splitBy (==';') style++parseTransform transform = evalState parseTransform' transform+ where+ parseTransform' :: State String (Matrix Float)+ parseTransform' = do+ f <- function+ ps <- parameters+ let m = buildTransform f ps+ rest <- whenNotEmpty (identity 3) $ parseTransform'+ return $ m * rest+ function :: State String String+ function = do+ consumeWhile (\x -> x `elem` [' ','\t'])+ f <- consumeWhile isAlpha+ return $ map toLower f+ parameters :: State String [Float]+ parameters = do+ consumeWhile (\x -> x `elem` [' ', '(', '\t'])+ ps <- consumeWhile (/= ')')+ consumeWhile (\x -> x `elem` [' ', ')', '\t'])+ let params = (splitBy (==',') ps)+ return $ map read params+ buildTransform :: String -> [Float] -> (Matrix Float)+ buildTransform "scale" [sx] = G.scale sx sx+ buildTransform "scale" [sx,sy] = G.scale sx sy+ buildTransform "translate" [tx] = G.translate tx 0+ buildTransform "translate" [tx, ty] = G.translate tx ty+ buildTransform "rotate" [a] = G.rotate a+ buildTransform "rotate" [a,cx ,cy] = (G.translate cx cy) * (G.rotate a) * (G.translate (-cx) (-cy))+ buildTransform "matrix" [a,b,c,d,e,f] = fromList 3 3 [a,c,e,b,d,f,0,0,1]+ buildTransform "skewx" [a] = G.skewx a+ buildTransform "skewy" [a] = G.skewy a+ buildTransform _ _ = identity 3++parsePath path = evalState parsePath' path+ where+ parsePath' :: State String [(Float, Float)]+ parsePath' = do+ c <- command+ processCommand (0,0) (Right (0,0)) c+ processCommand (cx,cy) first cmd+ | cmd == "m" || cmd == "l" || cmd == "t" = do+ (x,y) <- coordPair+ c <- command+ let this = (x + cx, y + cy)+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "M" || cmd == "L" || cmd == "T" = do+ (x,y) <- coordPair+ c <- command+ let this = (x, y)+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "H" = do+ x <- value+ c <- command+ let this = (x, cy)+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "h" = do+ x <- value+ c <- command+ let this = (cx + x, cy)+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "V" = do+ y <- value+ c <- command+ let this = (cx, y)+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "v" = do+ y <- value+ c <- command+ let this = (cx, cy + y)+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "c" = do+ coordPair -- first and second control points are irrelevant+ coordPair+ (x,y) <- coordPair+ c <- command+ let this = (x + cx, y + cy)+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "C" = do+ coordPair -- first and second control points are irrelevant+ coordPair+ (x,y) <- coordPair+ c <- command+ let this = (x, y)+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "s" || cmd == "q" = do+ coordPair -- first control point is irrelevant+ (x,y) <- coordPair+ c <- command+ let this = ((x + cx), (y + cy))+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "S" || cmd == "Q"= do+ coordPair -- first control point is irrelevant+ (x,y) <- coordPair+ c <- command+ let this = (x, y)+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "A" = do+ skipNValue 5 -- rx ry x-rotation larg-arc-flag sweep-flag are irrelevant+ (x,y) <- coordPair+ c <- command+ let this = (x, y)+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "a" = do+ skipNValue 5 -- rx ry x-rotation larg-arc-flag sweep-flag are irrelevant+ (x,y) <- coordPair+ c <- command+ let this = (x + cx, y + cy)+ rest <- whenNotEmpty [] $ processCommand this (first >> (Left this)) (if c == "" then cmd else c)+ return $ this : rest+ | cmd == "z" || cmd == "Z" =+ case first of+ Left p -> return [p]+ Right p -> return [p]+ coordPair :: State String (Float, Float)+ coordPair = do+ consumeWhile (\x -> x `elem` [' ','\t',','])+ x <- consumeWhile ((\x -> not $ x `elem` [' ','\t',',']))+ consumeWhile (\x -> x `elem` [' ','\t',','])+ y <- consumeWhile ((\x -> not $ x `elem` [' ','\t',',']))+ return (read x, read y)+ command :: State String String+ command = do+ consumeWhile (\x -> x `elem` [' ','\t',','])+ c <- consumeWhile isAlpha+ return c+ value :: State String Float+ value = do+ consumeWhile (\x -> x `elem` [' ','\t',','])+ x <- consumeWhile ((\x -> not $ x `elem` [' ','\t',',']))+ return $ read x+ skipNValue :: Int -> State String ()+ skipNValue n = replicateM_ n value