dia-functions (empty) → 0.1
raw patch · 7 files changed
+622/−0 lines, 7 filesdep +basedep +containersdep +data-pprintsetup-changed
Dependencies added: base, containers, data-pprint, deepseq, dia-base, mtl, xhtml
Files
- Graphics/Diagrams/Colors.hs +171/−0
- Graphics/Diagrams/Escape.hs +135/−0
- Graphics/Diagrams/FunctionGraphs.hs +81/−0
- Graphics/Diagrams/SVG.hs +166/−0
- LICENSE +31/−0
- Setup.hs +2/−0
- dia-functions.cabal +36/−0
+ Graphics/Diagrams/Colors.hs view
@@ -0,0 +1,171 @@+module Graphics.Diagrams.Colors where++import Data.Map+import Prelude hiding (lookup)++toRGB :: String -> Maybe (Double, Double, Double)+toRGB s = lookup s colorMap++colors :: [String]+colors = keys colorMap++-- | SVG color codes+colorMap :: Map String (Double, Double, Double)+colorMap = fromList+ [ "aliceblue" ==> (240, 248, 255)+ , "antiquewhite" ==> (250, 235, 215)+ , "aqua" ==> ( 0, 255, 255)+ , "aquamarine" ==> (127, 255, 212)+ , "azure" ==> (240, 255, 255)+ , "beige" ==> (245, 245, 220)+ , "bisque" ==> (255, 228, 196)+ , "black" ==> ( 0, 0, 0)+ , "blanchedalmond" ==> (255, 235, 205)+ , "blue" ==> ( 0, 0, 255)+ , "blueviolet" ==> (138, 43, 226)+ , "brown" ==> (165, 42, 42)+ , "burlywood" ==> (222, 184, 135)+ , "cadetblue" ==> ( 95, 158, 160)+ , "chartreuse" ==> (127, 255, 0)+ , "chocolate" ==> (210, 105, 30)+ , "coral" ==> (255, 127, 80)+ , "cornflowerblue" ==> (100, 149, 237)+ , "cornsilk" ==> (255, 248, 220)+ , "crimson" ==> (220, 20, 60)+ , "cyan" ==> ( 0, 255, 255)+ , "darkblue" ==> ( 0, 0, 139)+ , "darkcyan" ==> ( 0, 139, 139)+ , "darkgoldenrod" ==> (184, 134, 11)+ , "darkgray" ==> (169, 169, 169)+ , "darkgreen" ==> ( 0, 100, 0)+ , "darkgrey" ==> (169, 169, 169)+ , "darkkhaki" ==> (189, 183, 107)+ , "darkmagenta" ==> (139, 0, 139)+ , "darkolivegreen" ==> ( 85, 107, 47)+ , "darkorange" ==> (255, 140, 0)+ , "darkorchid" ==> (153, 50, 204)+ , "darkred" ==> (139, 0, 0)+ , "darksalmon" ==> (233, 150, 122)+ , "darkseagreen" ==> (143, 188, 143)+ , "darkslateblue" ==> ( 72, 61, 139)+ , "darkslategray" ==> ( 47, 79, 79)+ , "darkslategrey" ==> ( 47, 79, 79)+ , "darkturquoise" ==> ( 0, 206, 209)+ , "darkviolet" ==> (148, 0, 211)+ , "deeppink" ==> (255, 20, 147)+ , "deepskyblue" ==> ( 0, 191, 255)+ , "dimgray" ==> (105, 105, 105)+ , "dimgrey" ==> (105, 105, 105)+ , "dodgerblue" ==> ( 30, 144, 255)+ , "firebrick" ==> (178, 34, 34)+ , "floralwhite" ==> (255, 250, 240)+ , "forestgreen" ==> ( 34, 139, 34)+ , "fuchsia" ==> (255, 0, 255)+ , "gainsboro" ==> (220, 220, 220)+ , "ghostwhite" ==> (248, 248, 255)+ , "gold" ==> (255, 215, 0)+ , "goldenrod" ==> (218, 165, 32)+ , "gray" ==> (128, 128, 128)+ , "grey" ==> (128, 128, 128)+ , "green" ==> ( 0, 128, 0)+ , "greenyellow" ==> (173, 255, 47)+ , "honeydew" ==> (240, 255, 240)+ , "hotpink" ==> (255, 105, 180)+ , "indianred" ==> (205, 92, 92)+ , "indigo" ==> ( 75, 0, 130)+ , "ivory" ==> (255, 255, 240)+ , "khaki" ==> (240, 230, 140)+ , "lavender" ==> (230, 230, 250)+ , "lavenderblush" ==> (255, 240, 245)+ , "lawngreen" ==> (124, 252, 0)+ , "lemonchiffon" ==> (255, 250, 205)+ , "lightblue" ==> (173, 216, 230)+ , "lightcoral" ==> (240, 128, 128)+ , "lightcyan" ==> (224, 255, 255)+ , "lightgoldenrodyellow" ==> (250, 250, 210)+ , "lightgray" ==> (211, 211, 211)+ , "lightgreen" ==> (144, 238, 144)+ , "lightgrey" ==> (211, 211, 211)+ , "lightpink" ==> (255, 182, 193)+ , "lightsalmon" ==> (255, 160, 122)+ , "lightseagreen" ==> ( 32, 178, 170)+ , "lightskyblue" ==> (135, 206, 250)+ , "lightslategray" ==> (119, 136, 153)+ , "lightslategrey" ==> (119, 136, 153)+ , "lightsteelblue" ==> (176, 196, 222)+ , "lightyellow" ==> (255, 255, 224)+ , "lime" ==> ( 0, 255, 0)+ , "limegreen" ==> ( 50, 205, 50)+ , "linen" ==> (250, 240, 230)+ , "magenta" ==> (255, 0, 255)+ , "maroon" ==> (128, 0, 0)+ , "mediumaquamarine" ==> (102, 205, 170)+ , "mediumblue" ==> ( 0, 0, 205)+ , "mediumorchid" ==> (186, 85, 211)+ , "mediumpurple" ==> (147, 112, 219)+ , "mediumseagreen" ==> ( 60, 179, 113)+ , "mediumslateblue" ==> (123, 104, 238)+ , "mediumspringgreen" ==> ( 0, 250, 154)+ , "mediumturquoise" ==> ( 72, 209, 204)+ , "mediumvioletred" ==> (199, 21, 133)+ , "midnightblue" ==> ( 25, 25, 112)+ , "mintcream" ==> (245, 255, 250)+ , "mistyrose" ==> (255, 228, 225)+ , "moccasin" ==> (255, 228, 181)+ , "navajowhite" ==> (255, 222, 173)+ , "navy" ==> ( 0, 0, 128)+ , "oldlace" ==> (253, 245, 230)+ , "olive" ==> (128, 128, 0)+ , "olivedrab" ==> (107, 142, 35)+ , "orange" ==> (255, 165, 0)+ , "orangered" ==> (255, 69, 0)+ , "orchid" ==> (218, 112, 214)+ , "palegoldenrod" ==> (238, 232, 170)+ , "palegreen" ==> (152, 251, 152)+ , "paleturquoise" ==> (175, 238, 238)+ , "palevioletred" ==> (219, 112, 147)+ , "papayawhip" ==> (255, 239, 213)+ , "peachpuff" ==> (255, 218, 185)+ , "peru" ==> (205, 133, 63)+ , "pink" ==> (255, 192, 203)+ , "plum" ==> (221, 160, 221)+ , "powderblue" ==> (176, 224, 230)+ , "purple" ==> (128, 0, 128)+ , "red" ==> (255, 0, 0)+ , "rosybrown" ==> (188, 143, 143)+ , "royalblue" ==> ( 65, 105, 225)+ , "saddlebrown" ==> (139, 69, 19)+ , "salmon" ==> (250, 128, 114)+ , "sandybrown" ==> (244, 164, 96)+ , "seagreen" ==> ( 46, 139, 87)+ , "seashell" ==> (255, 245, 238)+ , "sienna" ==> (160, 82, 45)+ , "silver" ==> (192, 192, 192)+ , "skyblue" ==> (135, 206, 235)+ , "slateblue" ==> (106, 90, 205)+ , "slategray" ==> (112, 128, 144)+ , "slategrey" ==> (112, 128, 144)+ , "snow" ==> (255, 250, 250)+ , "springgreen" ==> ( 0, 255, 127)+ , "steelblue" ==> ( 70, 130, 180)+ , "tan" ==> (210, 180, 140)+ , "teal" ==> ( 0, 128, 128)+ , "thistle" ==> (216, 191, 216)+ , "tomato" ==> (255, 99, 71)+ , "turquoise" ==> ( 64, 224, 208)+ , "violet" ==> (238, 130, 238)+ , "wheat" ==> (245, 222, 179)+ , "white" ==> (255, 255, 255)+ , "whitesmoke" ==> (245, 245, 245)+ , "yellow" ==> (255, 255, 0)+ , "yellowgreen" ==> (154, 205, 50)+ ]+ where+ s ==> (r,g,b) = (s, (f r, f g, f b))++ f :: Int -> Double+ f 0 = 0+ f 255 = 1+ f n = fromIntegral n / 255++
+ Graphics/Diagrams/Escape.hs view
@@ -0,0 +1,135 @@+-- | Strict evaluation of diagrams with time and size limit+{-# LANGUAGE ScopedTypeVariables #-}+module Graphics.Diagrams.Escape + ( escapeDiagram+ , numberErrors+ ) where++import Graphics.Diagrams+import Graphics.Diagrams.Types+import Graphics.Diagrams.Colors (toRGB)++import Data.Data.GenRep.Functions (getErrorIndex)+import Control.Exception.Pure (catchPureErrorsSafe)+import System.SimpleTimeout.Limits+import System.IO.Parallel (twoParallel)++import Control.Monad (liftM2)+import Control.DeepSeq (NFData, deepseq)+import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)+import Control.Monad.State (State, runState)++-------------------------++-- | Strict evaluation of diagrams with time and size limit+escapeDiagram :: TimeLimit -> SizeLimit -> Diagram -> IO Diagram+escapeDiagram t s x = do+ ch <- newBudget t s+ idv <- newMVar 1 -- to generate identifiers for groups+ escapeDiagram' ch idv x++escapeDiagram' :: Budget -> MVar Int -> Diagram -> IO Diagram+escapeDiagram' ch idv = fff where++ fff :: Diagram -> IO Diagram+ fff x = do+ m <- checkBudget ch 1 + (return . return . err . timeError) + (return . return $ err "size limit exceeded")+ $ fmap (either err id) (catchPureErrorsSafe x) >>= check+ m+ where+ timeError d+ = "timeout at " ++ show (round $ 100 * d :: Int) ++ "%" ++ err s = Error s EmptyDiagram++ m1 :: NFData a => (a -> Diagram) -> a -> IO (IO Diagram)+ m1 f a = fmap (return . either err f) $ catchPureErrorsSafe $ a `deepseq` a++ m2 :: NFData a => (a -> Diagram -> Diagram) -> a -> Diagram -> IO (IO Diagram)+ m2 f a b + = fmap (either (\s -> fmap (Error s) $ fff b) + (\a -> fmap (f a) $ fff b)) + $ catchPureErrorsSafe $ a `deepseq` a++ checkColor :: Color -> Color+ checkColor (Color s) = case toRGB s of+ Just _ -> Color s+ _ -> error $ "Not an SVG color: " ++ s+ checkColor (RGB r g b) = RGB (f r) (f g) (f b) where+ f x = 0 `max` (1 `min` x)++ check :: Diagram -> IO (IO Diagram)++ check EmptyDiagram = return $ return EmptyDiagram+ check (Circle r) = m1 Circle (if r >= 0 then r else error "negative radius") + check (Text p s) = m1 (uncurry Text) (p, s)+ check (Rect a b) = m1 (uncurry Rect) (a, b)+ check (Polyline loop l) = fmap g $ m1 (uncurry Polyline) (loop, l) where+ g m = m >>= \x -> case x of+ Polyline loop l -> do+ (b, l) <- decSizeBudget ch $ \x -> case splitAt (x+2) l of+ (a,[]) -> (min x (x+2-length a), (True, a))+ (a,_) -> (0, (False, a))+ return $ if b + then Polyline loop l+ else Error "size limit exceeded" $ Polyline False l+ _ -> return x++ check (Link s x) = m2 Link s x+ check (FontFamily s x) = m2 FontFamily s x+ check (Move p x) = m2 Move p x+ check (Scale t x) = m2 Scale t x+ check (ScaleXY x y d) = m2 (uncurry ScaleXY) (x,y) d+ check (Rotate t x) = m2 Rotate t x+ check (Fill t x) = m2 Fill (checkColor t) x+ check (Stroke t x) = m2 Stroke (checkColor t) x+ check (StrokeWidth t x) = m2 StrokeWidth (if t >= 0 then t else error "negative stroke width") x+ check (Clip a b x) = m2 (uncurry Clip) (a, b) x+ check (Error s x) = m2 Error s x+ check (TransformMatrix a b c d e f x)+ = m2 (\(a,b,c,d,e,f) -> TransformMatrix a b c d e f) (a,b,c,d,e,f) x++ check (Pack x f) = return $ do+ i <- modifyMVar idv (\i -> return (i+1,i))+ fmap (\(x,y)-> Group x i y) $ twoParallel (fff x) (fff (f (Ref i)))++ check (Overlay a b) = return $ fmap (uncurry Overlay) $ twoParallel (fff a) (fff b)++ check (Ref i) = return $ return $ Ref i+ check (Group _ _ _) = error "check: Group not possible"++-- | Error message extraction and numbering+numberErrors + :: Diagram+ -> (Diagram, [(String, String)])+numberErrors d = (res, reverse $ map swap errs)+ where+ swap (a,b) = (b,a)++ (res, (_, errs)) = runState (replace d) (0, [])++ m2 f x = fmap f $ replace x++ replace :: Diagram -> State (Int, [(String, String)]) Diagram+ replace (Link s x) = m2 (Link s) x+ replace (FontFamily s x) = m2 (FontFamily s) x+ replace (Move p x) = m2 (Move p) x+ replace (Scale t x) = m2 (Scale t) x+ replace (Rotate t x) = m2 (Rotate t) x+ replace (Fill t x) = m2 (Fill t) x+ replace (Stroke t x) = m2 (Stroke t) x+ replace (StrokeWidth t x) = m2 (StrokeWidth t) x+ replace (Clip a b x) = m2 (Clip a b) x+ replace (TransformMatrix a b c d e f x)+ = m2 (TransformMatrix a b c d e f) x+ replace (Group a i b) = liftM2 (\a b -> Group a i b) (replace a) (replace b)+ replace (Overlay a b) = liftM2 Overlay (replace a) (replace b)+ replace (Error e x) = do+ i <- getErrorIndex e+ x <- replace x+ return $ Overlay x (i `textAt` (0,0) `fill` red)+ replace x = return x++
+ Graphics/Diagrams/FunctionGraphs.hs view
@@ -0,0 +1,81 @@+-- | Display function graphs+{-# LANGUAGE ScopedTypeVariables #-}+module Graphics.Diagrams.FunctionGraphs where++import Graphics.Diagrams++import Data.List (zip5)++-------------------------++-- | Make a function discrete+dotty :: (Num a, Real b) => (a -> b) -> (Double -> Double)+dotty f x+ | abs (fromInteger rx - x) < 0.02 = realToFrac $ f $ fromInteger rx+ | otherwise = sqrt (-1)+ where+ rx = round x++-- | Draw coordinate system+coords :: Point -> Point -> Diagram+coords (a1,a2) (b1,b2) = union + [ (a1,0) ~~ (b1,0)+ , (b1-1,0.5) ~~ (b1,0)+ , (b1-1,-0.5) ~~ (b1,0)+ , (0.5,b2-1) ~~ (0,b2)+ , (-0.5,b2-1) ~~ (0,b2)+ , (0,a2) ~~ (0,b2)+ , (1,-0.5) ~~ (1,0.5)+ ]++-- | Display a function+showFun :: (Fractional a, Real b) => Bool -> Point -> Point -> (a -> b) -> Diagram+showFun dotty a@(a1,a2) b@(b1,b2) f + = clip a b $ rectangle a b `fill` black <|> coords a b `stroke` yellow + <|> union rr `stroke` white `fill` white+ where+ l = map (\x->(x, realToFrac $ f $ realToFrac x)) [a1 - 0.1, a1 .. b1 + 0.1]+ ds = zipWith (-) (map snd l) (map snd $ drop 1 l)++ rr = if dotty then + [circle 0.1 `move` (x, y) | x <- map fromIntegral [round a1 .. round b1 :: Integer]+ , let y = realToFrac $ f $ realToFrac x, y <= b2 && y >= a2]+ else lines ++ dots++ lines = [e >-< f | (e,True,f) <- zip3 (drop 1 l) extralines (drop 2 l)]+ dots = [circle 0.1 `move` b | (x,b,y)+ <- zip3 extralines (drop 2 l) (drop 1 extralines)+ , not (x && y), snd b <= b2 && snd b >= a2]+ extralines = [abs y< (50* abs x) `max` 0.1 && abs y< (50* abs z) `max` 0.1 &&+ (x * y >= 0 || y * z >= 0)+ | (x,e,y,f,z)<-zip5 ds (drop 1 l) (drop 1 ds) (drop 2 l) (drop 2 ds)]+++-- showFun a b f = showArc (fst a, fst b) a b (\t -> (t, f t))++-- | Display an arc+showArc :: (Fractional a, Real b, Real c) => + (Double,Double) -> Point -> Point -> (a -> (b, c)) -> Diagram+showArc (k1,k2) a@(a1,a2) b@(b1,b2) f+ = clip a b $ rectangle a b `fill` black <|> coords a b `stroke` yellow + <|> union (lines ++ dots) `stroke` white `fill` white+ where+ l = map (\(x,y)-> (realToFrac x, realToFrac y)) + $ map (f . realToFrac) [k1-0.1, k1.. k2+0.1]+ ds = zipWith minu l (drop 1 l)++ (a,b) `minu` (c,d) = (c-a, d-b)+ abs (a,b) = sqrt (a*a+b*b)+ (a,b) <<< (c,d) = a <= c && b <= d+ (a,b) .* (c,d) = a*c + b*d++ lines = [e >-< f | (e,True,f) <- zip3 (drop 1 l) extralines (drop 2 l)]+ dots = [circle 0.1 `move` z | (x,z,y)+ <- zip3 extralines (drop 2 l) (drop 1 extralines)+ , not (x && y), a <<< z && z <<< b]+ extralines = [abs y< (10* abs x) `max` 0.1 && abs y< (10* abs z) `max` 0.1 &&+ (x .* y >= 0 || y .* z >= 0)+ | (x,e,y,f,z)<-zip5 ds (drop 1 l) (drop 1 ds) (drop 2 l) (drop 2 ds)]+++
+ Graphics/Diagrams/SVG.hs view
@@ -0,0 +1,166 @@+-- | Diagrams SVG backend+{-# LANGUAGE ScopedTypeVariables #-}+module Graphics.Diagrams.SVG + ( render+ ) where++import Graphics.Diagrams+import Graphics.Diagrams.Types+import Graphics.Diagrams.Escape (escapeDiagram, numberErrors)++import System.SimpleTimeout.Limits++import Text.XHtml.Strict (Html, tag, strAttr, (+++), (<<), (!), intAttr, toHtml, noHtml)++import Data.Char (intToDigit, showLitChar, ord)+import Data.List (intercalate, groupBy, sortBy)+import Data.Function (on)++-------------------------++data SVG + = G String [(String, String)] [SVG] (Maybe SVG)+ | GText String++mkSVG :: String -> [String] -> [String] -> SVG+mkSVG n t l = G n (zip t l) [] Nothing++addAtt :: (String, String) -> SVG -> SVG+addAtt a@(x,_) (G n as l Nothing) + | [j | (i,j)<-as, i == x] /= [""] + = G n (a:as) l Nothing+addAtt a g = G "g" [a] [g] Nothing++mkFun :: String -> [String] -> String+mkFun f l = f ++ "(" ++ intercalate "," l ++ ")"++mkStyle :: String -> String -> SVG -> SVG+mkStyle f c = addAtt ("style", f ++ ": " ++ c)++mkTransform :: SVG -> String -> SVG+g `mkTransform` s = addAtt ("transform", s) g+++showF :: Double -> String+showF x = show (realToFrac x :: Float)++showColor :: Color -> String+showColor (Color s) = s+showColor (RGB r g b) = "#" ++ f r ++ f g ++ f b where+ f x = [intToDigit (i `div` 16 `mod` 16), intToDigit (i `mod` 16)] where+ i = round (x * 255)++---------------++-- | An idetifier is needed+-- because browsers maintain global xlink-s+toSVGWithId :: String -> Diagram -> SVG+toSVGWithId idi = toSVG where++ toSVG :: Diagram -> SVG+ toSVG EmptyDiagram = G "g" [] [] Nothing+ toSVG (Circle r) = mkSVG "circle" ["r"] [showF r]+ toSVG (Text pos s) = G "text" [("style","text-anchor: " ++ showPos pos)] [GText $ concatMap escape s] Nothing+ where+ escape '\\' = "\\"+ escape c | ord c >= 161 = [c]+ escape c = showLitChar c ""++ showPos Start = "start"+ showPos Middle = "middle"+ showPos End = "end"++ toSVG (Link s x) = G "a" [("xlink:href", s)] [toSVG x] Nothing+ toSVG (Rect a b) = mkSVG "rect" ["x","y","width","height"] $ map showF [-a/2, -b/2, a, b]+ toSVG (Polyline _ [(x1, y1), (x2, y2)]) + = mkSVG "line" ["x1","y1","x2","y2"] $ map showF [x1, y1, x2, y2]+ toSVG (Polyline loop l) + = mkSVG (if loop then "polygon" else "polyline") ["points"] + [unwords [showF x ++ "," ++ showF y | (x,y)<-l]]++ toSVG a@(Overlay _ _) = G "g" [] (concatMap (unG . toSVG) $ collectU [] a) Nothing where++ unG (G "g" [] l Nothing) = l+ unG x = [x]++ collectU acc EmptyDiagram = acc+ collectU acc (Overlay a b) = collectU (collectU acc b) a+ collectU acc x = x: acc++ toSVG (Group d i s) = addDef [addAtt ("id", idi ++ show i) $ toSVG d] $ toSVG s where+ addDef [] x = x+ addDef l (G "defs" [] l' (Just x)) = addDef (l++l') x+ addDef l x = G "defs" [] l $ Just x++ toSVG (Ref i) = mkSVG "use" ["xlink:href"] ["#" ++ idi ++ show i]+ toSVG (Move (a,b) x) = toSVG x `mkTransform` mkFun "translate" [showF a, showF b]+ toSVG (Scale t x) = toSVG x `mkTransform` mkFun "scale" [showF t, showF t]+ toSVG (ScaleXY tx ty x) = toSVG x `mkTransform` mkFun "scale" [showF tx, showF ty]+ toSVG (Rotate d x) = toSVG x `mkTransform` mkFun "rotate" [showF d]+ toSVG (FontFamily s x) = mkStyle "font-family" s $ toSVG x+ toSVG (Fill c x) = mkStyle "fill" (showColor c) $ toSVG x+ toSVG (Stroke c x) = mkStyle "stroke" (showColor c) $ toSVG x+ toSVG (StrokeWidth w x) = mkStyle "stroke-width" (showF w) $ toSVG x+ toSVG (TransformMatrix a b c d e f x) + = toSVG x `mkTransform` ("matrix(" ++ intercalate " " (map showF [a,b,c,d,e,f]) ++ ")")+ toSVG (Clip (a1,a2) (b1,b2) x) = toSVG x -- inner clip is not implemented yet+ toSVG (Error s x) = toSVG x -- not possible+ toSVG (Pack x f) = error "toSVG: use escape first"++++---------------------------------------------------++showSVG :: SVG -> Html+showSVG x = case x of+ GText s -> toHtml s+ G n as l e -> (tag n !+ [ strAttr a $ intercalate (sep a) is+ | (a:_,is)<- map unzip $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) as]+ << map showSVG l)+ +++ case e of+ Nothing -> noHtml+ Just x -> showSVG x+ where+ sep "transform" = " "+ sep _ = "; "++addSVGHeader :: Int -> Int -> Html -> Html+addSVGHeader w h =+ tag "svg" ! [ strAttr "xmlns" "http://www.w3.org/2000/svg"+ , strAttr "xmlns:xlink" "http://www.w3.org/1999/xlink" + , strAttr "version" "1.1"+ , strAttr "baseProfile" "full" + , intAttr "width" w+ , intAttr "height" h+ ] +++render + :: Double -- ^ magnification+ -> Point -- ^ bottom-left corner+ -> Point -- ^ top-right corner+ -> TimeLimit -- ^ time limit+ -> SizeLimit -- ^ size limit+ -> String -- ^ identifier (needed only if there are several SVG picture on a page)+ -> Diagram -- ^ diagram to show+ -> IO (Html, [(String,String)]) -- ^ xml code and error messages+render mag bottomLeft topRight t s idi x = do+ xx <- escapeDiagram t s x+ let (x', err) = numberErrors xx+ return (f x', err)+ where+ f (Clip a b x) = g a b x+ f x = g bottomLeft topRight x++ g (a1,a2) (b1,b2) s =+ addSVGHeader (round $ mag * (b1 - a1)) (round $ mag * (b2 - a2)) + << showSVG (+ toSVGWithId idi+ $ TransformMatrix mag 0 0 (-mag) (-mag*a1) (mag*b2) s `fill` white `stroke` black `strokeWidth` 0.1)++++++
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Péter Diviánszky 2010-2011++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 Péter Diviánszky 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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dia-functions.cabal view
@@ -0,0 +1,36 @@+name: dia-functions+version: 0.1+category: Graphics, Education+synopsis: An EDSL for teaching Haskell with diagrams - functions+description:+ This package contains diagram manipulating functions+ and an SVG backend.+ .+ For exaples see <http://pnyf.inf.elte.hu/fp/Diagrams_en.xml>+stability: alpha+license: BSD3+license-file: LICENSE+author: Péter Diviánszky+maintainer: divip@aszt.inf.elte.hu+cabal-version: >=1.2+build-type: Simple++library+ GHC-Options: -Wall -fwarn-tabs -fno-warn-unused-matches -fno-warn-name-shadowing ++ Exposed-Modules:+ Graphics.Diagrams.Colors,+ Graphics.Diagrams.Escape,+ Graphics.Diagrams.FunctionGraphs,+ Graphics.Diagrams.SVG++ Build-Depends:+ data-pprint >= 0.2 && < 0.3,+ dia-base >= 0.1 && < 0.2,+ base >= 4.0 && < 4.4,+ containers >= 0.4 && < 0.5,+ xhtml >= 3000.2 && < 3000.3,+ mtl >= 2.0 && < 2.1,+ deepseq >= 1.1 && < 1.2++