hcg-minus 0.11 → 0.12
raw patch · 6 files changed
+92/−170 lines, 6 filesdep −cairo
Dependencies removed: cairo
Files
- Data/CG/Minus.hs +73/−50
- Data/CG/Minus/Colour.hs +2/−2
- README +10/−3
- Render/CG/Minus.hs +0/−68
- Render/CG/Minus/Arrow.hs +0/−40
- hcg-minus.cabal +7/−7
Data/CG/Minus.hs view
@@ -4,19 +4,22 @@ import Control.Applicative import Data.Complex import Data.Maybe-import Data.SG+import qualified Data.SG as G {- SG -} import Text.Printf -- * Types -- | Two-dimensional point.-type Pt = Point2'+type Pt = G.Point2'+-- type Pt a = Pt {pt_x :: a, pt_y :: a} -- | Two-dimensional vector.-type Vc = Rel2'+type Vc = G.Rel2'+-- type Vc a = Vc {vc_x :: a, vc_y :: a} -- | Two-dimensional line.-type Ln = Line2'+type Ln = G.Line2'+-- type Ln a = Ln (Pt a) (Pt a) -- | Line segments. type Ls a = [Pt a]@@ -57,25 +60,27 @@ -- -- > pt_xy (pt 0 pi) == (0,pi) pt :: a -> a -> Pt a-pt = curry Point2+pt = curry G.Point2+-- pt = Pt -- | Variant 'Pt' constructor, ie. 'uncurry' 'pt'. -- -- > pt_xy (pt' (0,pi)) == (0,pi) pt' :: (a,a) -> Pt a-pt' = Point2+pt' = G.Point2+--pt' = uncurry pt -- | /x/ field of 'Pt'. -- -- > pt_x (pt 0 pi) == 0 pt_x :: Pt t -> t-pt_x = getX+pt_x = G.getX -- | /y/ field of 'Pt'. -- -- > pt_y (pt 0 pi) == pi pt_y :: Pt t -> t-pt_y = getY+pt_y = G.getY -- | /x/ and /y/ fields of 'Pt'. --@@ -87,7 +92,7 @@ -- -- > pt_origin == pt 0 0 pt_origin :: Num a => Pt a-pt_origin = origin+pt_origin = pt 0 0 -- | Binary operator at 'Pt'. Given the 'Applicative' instance for -- 'Pt' this is a synonym for 'liftA2'.@@ -259,8 +264,10 @@ pt_angle p q = pt_angle_o (q `pt_sub` p) -- | Pointwise '+'.-pt_translate :: Num a => Pt a -> Vc a -> Pt a-pt_translate = plusDir+pt_translate :: (Num a,Eq a) => Pt a -> Vc a -> Pt a+pt_translate = G.plusDir+-- pt_translate p v = pt (pt_x p + vc_x v) (pt_y p + vc_y v)+-- pt_translate (Pt x y) (Vc dx dy) = Pt (x + dx) (y + dy) -- | Alternate implementation of 'pt_translate'. pt_translate_ :: Num a => Pt a -> Vc a -> Pt a@@ -277,8 +284,8 @@ -- -- > pt_distance (pt 0 0) (pt 0 1) == 1 -- > pt_distance (pt 0 0) (pt 1 1) == sqrt 2-pt_distance :: (Floating a) => Pt a -> Pt a -> a-pt_distance = distFrom+pt_distance :: (Floating a,Eq a) => Pt a -> Pt a -> a+pt_distance = G.distFrom -- | Are /x/ and /y/ of 'Pt' /p/ in range (0,1). --@@ -288,23 +295,37 @@ let (x,y) = pt_xy p in x >= 0 && x <= 1 && y >= 0 && y <= 1 +-- | Rotate 'Pt' /n/ radians.+--+-- > pt_rotate pi (pt 1 0) ~= pt (-1) 0+pt_rotate :: Floating a => a -> Pt a -> Pt a+pt_rotate a p =+ let (x,y) = pt_xy p+ s = sin a+ c = cos a+ in pt (x * c - y * s) (y * c + x * s)+ -- * Vc functions -- | Construct 'Vc'. vc :: Num a => a -> a -> Vc a-vc = curry makeRel2+vc = curry G.makeRel2+-- vc = Vc -- | Alernate constructor for 'Vc'.+--+-- > (vc 0 0 == vc' (0,0)) == True vc' :: Num a => (a,a) -> Vc a-vc' = makeRel2+vc' = G.makeRel2+-- vc' = uncurry vc -- | 'Vc' /x/ field. vc_x :: Vc t -> t-vc_x = getX+vc_x = G.getX -- | 'Vc' /y/ field. vc_y :: Vc t -> t-vc_y = getY+vc_y = G.getY -- | 'Vc' /x/ and /y/ fields. vc_xy :: Vc a -> (a,a)@@ -314,19 +335,21 @@ -- -- > vc_scale 2 (vc 3 4) == vc 6 8 vc_scale :: Num a => a -> Vc a -> Vc a-vc_scale = scaleRel+vc_scale = G.scaleRel+-- vc_scale n v = vc (vc_x v * n) (vc_y v * n) -- | 'Vc' dot product. -- -- > vc_dot (vc 1 2) (vc 3 4) == 11 vc_dot :: Num a => Vc a -> Vc a -> a-vc_dot = dotProduct+vc_dot = G.dotProduct+-- vc_dot p q = (vc_x p * vc_x q) + (vc_y p * vc_y q) -- | Scale 'Vc' to have unit magnitude (to within tolerance). -- -- > vc_unit (vc 1 1) ~= let x = (sqrt 2) / 2 in vc x x vc_unit :: (Ord a, Floating a) => Vc a -> Vc a-vc_unit = unitVector+vc_unit = G.unitVector -- | The angle between two vectors on a plane. The angle is from v1 to -- v2, positive anticlockwise. The result is in (-pi,pi)@@ -343,51 +366,51 @@ -- | 'Ln' constructor. -- -- > ln_start (ln (pt 0 0) (pt 1 1)) == pt 0 0-ln :: Num a => Pt a -> Pt a -> Ln a-ln = lineTo+ln :: (Num a,Eq a) => Pt a -> Pt a -> Ln a+ln = G.lineTo -- | Variant constructor. -- -- > ln_start (ln_ (pt 1 1) (pt 0 0)) == pt 1 1-ln_ :: Num a => Pt a -> Pt a -> Ln a-ln_ p q = Line2 p (fromPt q p)+ln_ :: (Num a,Eq a) => Pt a -> Pt a -> Ln a+ln_ p q = G.Line2 p (G.fromPt q p) -- | Variant on 'ln' which takes 'Pt' co-ordinates as duples. -- -- > ln' (0,0) (1,1) == ln (pt 0 0) (pt 1 1)-ln' :: Num a => (a,a) -> (a,a) -> Ln a+ln' :: (Num a,Eq a) => (a,a) -> (a,a) -> Ln a ln' (x1,y1) (x2,y2) = ln (pt x1 y1) (pt x2 y2) -- | Initial 'Pt' of 'Ln'. -- -- > ln_start (ln (pt 0 0) (pt 1 1)) == pt 0 0-ln_start :: Num a => Ln a -> Pt a-ln_start = getLineStart+ln_start :: (Num a,Eq a) => Ln a -> Pt a+ln_start = G.getLineStart -- | Alternate implementation of 'ln_start' (without 'Num' constraint). ln_start_ :: Ln a -> Pt a-ln_start_ (Line2 p _) = p+ln_start_ (G.Line2 p _) = p -- | End 'Pt' of 'Ln'. -- -- > ln_end (ln (pt 0 0) (pt 1 1)) == pt 1 1-ln_end :: Num a => Ln a -> Pt a-ln_end = getLineEnd+ln_end :: (Num a,Eq a) => Ln a -> Pt a+ln_end = G.getLineEnd -- | Alternate implementation of 'ln_end'.-ln_end_ :: Num a => Ln a -> Pt a-ln_end_ (Line2 p v) = p `pt_translate` v+ln_end_ :: (Num a,Eq a) => Ln a -> Pt a+ln_end_ (G.Line2 p v) = p `pt_translate` v -- | 'Vc' that 'pt_translate's start 'Pt' to end 'Pt' of 'Ln'. -- -- > let l = ln (pt 0 0) (pt 1 1) -- > in ln_start l `pt_translate` ln_vc l == pt 1 1-ln_vc :: Num a => Ln a -> Vc a-ln_vc = getLineDir+ln_vc :: (Num a,Eq a) => Ln a -> Vc a+ln_vc = G.getLineDir -- | Alternate implementation of 'ln_vc', without 'Num' constraint. ln_vc_ :: Ln a -> Vc a-ln_vc_ (Line2 _ v) = v+ln_vc_ (G.Line2 _ v) = v -- | The angle, in /radians/, anti-clockwise from the /x/-axis. --@@ -396,18 +419,18 @@ -- > ln_angle (ln' (0,0) (0,1)) == pi/2 -- > ln_angle (ln' (0,0) (-1,1)) == pi * 3/4 ln_angle :: Ln R -> R-ln_angle = toAngle . ln_vc+ln_angle = G.toAngle . ln_vc -- | Start and end points of 'Ln'. -- -- > ln_pt (ln (pt 1 0) (pt 0 0)) == (pt 1 0,pt 0 0)-ln_pt :: Num a => Ln a -> (Pt a, Pt a)+ln_pt :: (Num a,Eq a) => Ln a -> (Pt a, Pt a) ln_pt l = (ln_start l,ln_end l) -- | Variant of 'ln_pt' giving co-ordinates as duples. -- -- > ln_pt' (ln (pt 1 0) (pt 0 0)) == ((1,0),(0,0))-ln_pt' :: Num a => Ln a -> ((a,a),(a,a))+ln_pt' :: (Num a,Eq a) => Ln a -> ((a,a),(a,a)) ln_pt' l = let (p1,p2) = ln_pt l in (pt_xy p1,pt_xy p2)@@ -415,7 +438,7 @@ -- | Midpoint of a 'Ln'. -- -- > ln_midpoint (ln (pt 0 0) (pt 2 1)) == pt 1 (1/2)-ln_midpoint :: (Fractional a) => Ln a -> Pt a+ln_midpoint :: (Fractional a,Eq a) => Ln a -> Pt a ln_midpoint l = let (p1,p2) = ln_pt l x = (pt_x p1 + pt_x p2) / 2@@ -440,7 +463,7 @@ -- > ln_magnitude (ln (pt 0 0) (pt 1 1)) == sqrt 2 -- > pt_x (pt_to_polar (pt 1 1)) == sqrt 2 ln_magnitude :: Ln R -> R-ln_magnitude = mag . ln_vc+ln_magnitude = G.mag . ln_vc -- | Variant definition of 'ln_magnitude'. ln_magnitude_ :: Ln R -> R@@ -467,7 +490,7 @@ -- -- > ln_adjust (sqrt 2) (ln (pt 0 0) (pt 2 2)) == ln (pt 0 0) (pt 1 1) ln_adjust :: (Floating a, Ord a) => a -> Ln a -> Ln a-ln_adjust = makeLength+ln_adjust = G.makeLength -- | Extend 'Ln' by 'R', ie. 'ln_adjust' with /n/ added to -- 'ln_magnitude'.@@ -499,7 +522,7 @@ -- > in map f [pt 0.5 0.5,pt 2 2,pt (-1) (-1),pt 0 0] == [True,False,False,False] pt_on_line_ :: Ln R -> Pt R -> Bool pt_on_line_ l p =- case distAlongLine p l of+ case G.distAlongLine p l of Nothing -> False Just d -> d >= 0 && d <= 1 @@ -530,10 +553,10 @@ -- > ln_intersection (ln' (0,0) (1,1)) (ln' (0,0) (1,0)) == Just (pt 0 0) ln_intersection :: (Ord a,Fractional a) => Ln a -> Ln a -> Maybe (Pt a) ln_intersection l0 l1 =- case intersectLines2 l0 l1 of+ case G.intersectLines2 l0 l1 of Nothing -> Nothing Just (i,j) -> if i >= 0 && i <= 1 && j >= 0 && j <= 1- then Just (alongLine i l0)+ then Just (G.alongLine i l0) else Nothing -- | Variant definition of 'ln_intersection', using algorithm at@@ -573,7 +596,7 @@ -- -- > let l = zipWith ln' (repeat (0,0)) [(1,0),(2,1),(1,1),(0,1),(-1,1)] -- > in map ln_slope l == [Just 0,Just (1/2),Just 1,Nothing,Just (-1)]-ln_slope :: (Fractional a) => Ln a -> Maybe a+ln_slope :: (Fractional a,Eq a) => Ln a -> Maybe a ln_slope l = let ((x1,y1),(x2,y2)) = ln_pt' l in case x2 - x1 of@@ -602,25 +625,25 @@ -- > ln_same_direction (ln' (0,0) (1,1)) (ln' (0,0) (2,2)) == True -- > ln_same_direction (ln' (0,0) (1,1)) (ln' (2,2) (0,0)) == False ln_same_direction :: (Ord a, Floating a) => Ln a -> Ln a -> Bool-ln_same_direction p q = ln_vc p `sameDirection` ln_vc q+ln_same_direction p q = ln_vc p `G.sameDirection` ln_vc q -- | Are 'Ln's parallel, ie. does 'ln_vc' of each equal 'ln_same_direction'. -- -- > ln_parallel__ (ln' (0,0) (1,1)) (ln' (2,2) (1,1)) == True ln_parallel__ :: Ln R -> Ln R -> Bool-ln_parallel__ p q = ln_vc (ln_sort p) `sameDirection` ln_vc (ln_sort q)+ln_parallel__ p q = ln_vc (ln_sort p) `G.sameDirection` ln_vc (ln_sort q) -- | Is 'Ln' horizontal, ie. is 'ln_slope' zero. -- -- > ln_horizontal (ln' (0,0) (1,0)) == True -- > ln_horizontal (ln' (1,0) (0,0)) == True-ln_horizontal :: (Fractional a) => Ln a -> Bool+ln_horizontal :: (Fractional a,Eq a) => Ln a -> Bool ln_horizontal = (== Just 0) . ln_slope -- | Is 'Ln' vertical, ie. is 'ln_slope' 'Nothing'. -- -- > ln_vertical (ln' (0,0) (0,1)) == True-ln_vertical :: (Fractional a) => Ln a -> Bool+ln_vertical :: (Fractional a,Eq a) => Ln a -> Bool ln_vertical = (== Nothing) . ln_slope -- * L(ine) s(egment) functions@@ -746,7 +769,7 @@ -- -- > ls_pt_inside' (ls' [(0,0),(1,0),(1,1),(0,1)]) (pt 0 1) == True ls_pt_inside' :: Ls R -> Pt R -> Bool-ls_pt_inside' l p = any (== p) l || ls_pt_inside l p+ls_pt_inside' l p = p `elem` l || ls_pt_inside l p -- | Check all 'Pt' at 'Ls' are 'pt_is_normal'. ls_check_normalised :: (Ord a,Num a) => Ls a -> Bool
Data/CG/Minus/Colour.hs view
@@ -1,9 +1,9 @@ -- | Colour related functions module Data.CG.Minus.Colour where -import Data.Colour+import Data.Colour {- colour -} import Data.Colour.SRGB-import Data.Colour.Names as N {- colour -}+import Data.Colour.Names as N -- | Opaque colour. type C = Colour Double
README view
@@ -1,4 +1,11 @@-hcg-minus -- a simple-minded non-optimised haskell cg library+hcg-minus+--------- -(c) rohan drape, 2009-2011- gpl, http://gnu.org/copyleft/+a simple-minded non-optimised [haskell][hs] cg library++[hs]: http://haskell.org/++© [rohan drape][rd], 2009-2012, [gpl]++[rd]: http://rd.slavepianos.org/+[gpl]: http://gnu.org/copyleft/
− Render/CG/Minus.hs
@@ -1,68 +0,0 @@--- | CG (minus) rendering in terms of 'C.Render'.-module Render.CG.Minus where--import Data.CG.Minus-import Data.CG.Minus.Colour-import Data.Colour-import qualified Graphics.Rendering.Cairo as C {- cairo -}---- | Render nothing.-nil :: C.Render ()-nil = return ()---- | Render 'Ls' as 'C.moveTo' then sequence of 'C.lineTo'.-line :: Ls R -> C.Render ()-line l =- case l of- [] -> nil- (p0:pp) -> do let (x0,y0) = pt_xy p0- C.moveTo x0 y0- let f p = let (x,y) = pt_xy p in C.lineTo x y- mapM_ f pp---- | Variant of 'line' that runs 'C.closePath'.-polygon :: Ls R -> C.Render ()-polygon l =- case l of- [] -> nil- _ -> line l >> C.closePath---- | Render 'Ls' as set of square points with 'R' dimension.-points :: R -> Ls R -> C.Render ()-points n l = do- let f p = let (x,y) = pt_xy p in C.rectangle x y n n >> C.fill- mapM_ f l---- | Greyscale call to 'C.setSourceRGBA'.-grey :: R -> C.Render ()-grey x = C.setSourceRGBA x x x 1---- | 'Ca' call to 'C.setSourceRGBA'.-colour :: Ca -> C.Render ()-colour c =- let (r,g,b,a) = unCa c- in C.setSourceRGBA r g b a---- | Run 'colour' then 'C.fillPreserve'.-fill :: Ca -> C.Render ()-fill c = colour c >> C.fillPreserve---- | Run 'C.stroke' with line width 'R' and 'Ca'.-stroke :: R -> Ca -> C.Render ()-stroke lw c = C.setLineWidth lw >> colour c >> C.stroke---- | Run 'polygon' on 'Ls' then 'fill' and 'stroke'.-area :: R -> Ca -> Ca -> Ls R -> C.Render ()-area lw sc fc a = do- polygon a- fill fc- stroke lw sc---- | Variant of 'area' with fixed grey border of width @0.005@ and--- grey @0.15@.-area' :: Ca -> Ls R -> C.Render ()-area' = area 0.005 (opaque (mk_grey 0.15))---- | Run 'polygon' on 'Ls' then 'stroke'.-outline :: R -> Ca -> Ls R -> C.Render ()-outline lw c l = polygon l >> stroke lw c
− Render/CG/Minus/Arrow.hs
@@ -1,40 +0,0 @@--- | Rendering of "Data.CG.Minus.Arrow".-module Render.CG.Minus.Arrow where--import Data.CG.Minus-import Data.CG.Minus.Arrow-import Data.CG.Minus.Colour-import qualified Graphics.Rendering.Cairo as C-import Render.CG.Minus---- | Render 'Ln' with solid arrow tip at endpoint. Arrow tip--- co-ordinates are given by 'arrow_coord'.-arrow_ep :: R -> R -> Ca -> Ln R -> C.Render ()-arrow_ep n a c l = do- let (p0,p1) = ln_pt l- (p2,p3) = arrow_coord l n a- line [p0,ln_midpoint (ln p2 p3)]- C.setLineCap C.LineCapRound- stroke 0.01 c- polygon [p2,p1,p3]- C.fill---- | Variant of 'arrow_ep' to render 'Ls' as sequence of arrows.-arrows_ep :: R -> R -> Ca -> Ls R -> C.Render ()-arrows_ep n a c xs = mapM_ (arrow_ep n a c) (zipWith ln xs (tail xs))---- | Variant of 'arrow_ep' with draws tip at mid-point of 'Ln'.-arrow_mp :: R -> R -> Ca -> Ln R -> C.Render ()-arrow_mp n a c l = do- let (p0,p1) = ln_pt l- p1' = ln_midpoint (ln p0 (pt_linear_extension n l))- (p2,p3) = arrow_coord (ln p0 p1') n a- line [p0,p1]- C.setLineCap C.LineCapRound- stroke 0.01 c- polygon [p2,p1',p3]- C.fill---- | Variant of 'arrow_mp' to render 'Ls' as sequence of arrows.-arrows_mp :: R -> R -> Ca -> Ls R -> C.Render ()-arrows_mp n a c xs = mapM_ (arrow_mp n a c) (zipWith ln xs (tail xs))
hcg-minus.cabal view
@@ -1,32 +1,32 @@ name: hcg-minus-version: 0.11+version: 0.12 synopsis: haskell cg (minus) description: cg (minus) library license: BSD3 category: Math+copyright: (c) rohan drape, 2011-2012 author: Rohan Drape maintainer: rd@slavepianos.org-homepage: http://slavepianos.org/rd/?t=hcg-minus-tested-with: GHC==7.2.2+stability: Experimental+homepage: http://rd.slavepianos.org/?t=hcg-minus+tested-with: GHC==7.6.1 build-type: Simple cabal-version: >= 1.8 data-files: README library- build-depends: base==4.*,cairo,colour,SG+ build-depends: base==4.*,colour,SG ghc-options: -Wall -fwarn-tabs exposed-modules: Data.CG.Minus Data.CG.Minus.Arrow Data.CG.Minus.Bearing Data.CG.Minus.Colour Data.CG.Minus.Colour.Planck- Render.CG.Minus- Render.CG.Minus.Arrow Source-Repository head Type: darcs- Location: http://slavepianos.org/rd/sw/hcg-minus+ Location: http://rd.slavepianos.org/sw/hcg-minus -- Local Variables: -- truncate-lines:t