dia-functions 0.1 → 0.2
raw patch · 2 files changed
+68/−52 lines, 2 files
Files
- Graphics/Diagrams/FunctionGraphs.hs +65/−51
- dia-functions.cabal +3/−1
Graphics/Diagrams/FunctionGraphs.hs view
@@ -4,19 +4,9 @@ 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+-- | The coordinate system. coords :: Point -> Point -> Diagram coords (a1,a2) (b1,b2) = union [ (a1,0) ~~ (b1,0)@@ -28,54 +18,78 @@ , (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+-- | Draw the given function graph with gray coordinate system.+withCoords :: Point -> Point -> Diagram -> Diagram+withCoords a b d + = clip a b+ $ coords a b `stroke` gray+ <|> d `stroke` black `strokeWidth` 0.15 - 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)] +-- | Display a function defined on integer values.+displayDiscreteFun + :: (Integral a, Real b) + => Point -- ^ display area left-bottom corner+ -> Point -- ^ display area right-up corner+ -> (a -> b) + -> Diagram+displayDiscreteFun a@(a1,a2) b@(b1,b2) f + = withCoords a b $ union+ [ circle 0.1 `move` (fromIntegral x, y)+ | x <- [ceiling a1 .. floor b1]+ , let y = realToFrac (f x)+ , y <= b2 && y >= a2 ] --- 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+-- | Display a continuous function.+displayFun + :: (RealFrac a, Real b) + => Point -- ^ display area left-bottom corner+ -> Point -- ^ display area right-up corner+ -> (a -> b) + -> Diagram+displayFun a b f + = displayArc a b (fst a, fst b) $ \t -> (t, f t)+++-- | Display an arc given by a function.+displayArc+ :: (Fractional a, Real b) + => Point -- ^ display area left-bottom corner+ -> Point -- ^ display area right-up corner+ -> (Double, Double) -- ^ parameter interval+ -> (a -> (b, b)) -- ^ arc on the plain+ -> Diagram+displayArc a b (k1,k2) f + = withCoords a b $ joinPoints (arcPoints int f)+ where+ arcPoints (k1,k2) f+ = [ (realToFrac x, realToFrac y)+ | t <- [k1-0.1, k1.. k2+0.1]+ , let (x, y) = f (realToFrac t) ]++++-- | Join points to form a continuous path with singularities.+joinPoints :: [Point] -> Diagram+joinPoints points = union $ lines ++ dots 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)+ vectors = zipWith (\(a1,a2) (b1,b2) -> (b1-a1, b2-a2)) points (drop 1 points) - (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+ cont = zipWith f vectors (drop 1 vectors) where - 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)]+ (a1,a2) `f` (b1,b2) + = (a1*b1 + a2*b2) / sqrt ((a1*a1 + a2*a2)*(b1*b1 + b2*b2)) > 0.5++ join = zipWith (||) cont (drop 1 cont)++ lines = [ e ~~ f | (e, True, f) <- zip3 (drop 1 points) join (drop 2 points) ]++ dots = [ circle 0.1 `move` z + | (i, z, j) <- zip3 join (drop 2 points) (drop 1 join)+ , not (i && j)+ ]
dia-functions.cabal view
@@ -1,5 +1,5 @@ name: dia-functions-version: 0.1+version: 0.2 category: Graphics, Education synopsis: An EDSL for teaching Haskell with diagrams - functions description:@@ -7,6 +7,8 @@ and an SVG backend. . For exaples see <http://pnyf.inf.elte.hu/fp/Diagrams_en.xml>+ .+ Changes since 0.1: Reimplement the Graphics.Diagrams.FunctionGraphs module. stability: alpha license: BSD3 license-file: LICENSE