hcg-minus 0.15 → 0.16
raw patch · 21 files changed
+2951/−1232 lines, 21 filesdep +randomdep ~base
Dependencies added: random
Dependency ranges changed: base
Files
- Data/CG/Minus.hs +4/−977
- Data/CG/Minus/Arrow.hs +1/−1
- Data/CG/Minus/Bearing.hs +43/−17
- Data/CG/Minus/Bezier.hs +101/−0
- Data/CG/Minus/Colour.hs +53/−228
- Data/CG/Minus/Colour/Crayola.hs +181/−0
- Data/CG/Minus/Colour/Grey.hs +66/−0
- Data/CG/Minus/Colour/NCS.hs +25/−0
- Data/CG/Minus/Colour/Names.hs +38/−0
- Data/CG/Minus/Colour/Planck.hs +4/−3
- Data/CG/Minus/Colour/RAL.hs +236/−0
- Data/CG/Minus/Colour/RYB.hs +135/−0
- Data/CG/Minus/Colour/SVG.hs +175/−0
- Data/CG/Minus/Colour/VGA.hs +60/−0
- Data/CG/Minus/Core.hs +1326/−0
- Data/CG/Minus/Geometry.hs +171/−0
- Data/CG/Minus/Picture.hs +103/−0
- Data/CG/Minus/Polygon.hs +60/−0
- Data/CG/Minus/Types.hs +148/−0
- README +1/−1
- hcg-minus.cabal +20/−5
Data/CG/Minus.hs view
@@ -1,979 +1,6 @@ -- | CG library (minus).-module Data.CG.Minus where--import Data.Complex {- base -}-import Data.Maybe {- base -}-import Text.Printf {- base -}---- * Types---- | Two-dimensional point.------ Pt are 'Num', pointwise, ie:------ > Pt 1 2 + Pt 3 4 == Pt 4 6--- > Pt 1 2 * Pt 3 4 == Pt 3 8--- > negate (Pt 0 1) == Pt 0 (-1)--- > abs (Pt (-1) 1) == Pt 1 1--- > signum (Pt (-1/2) (1/2)) == Pt (-1) 1-data Pt a = Pt {pt_x :: a,pt_y :: a} deriving (Eq,Ord,Show)--instance Num a => Num (Pt a) where- (+) = pt_binop (+)- (-) = pt_binop (-)- (*) = pt_binop (*)- negate = pt_uop negate- abs = pt_uop abs- signum = pt_uop signum- fromInteger n = let n' = fromInteger n in Pt n' n'---- | Two-dimensional vector. Vector are 'Num' in the same manner as--- 'Pt'.-data Vc a = Vc {vc_x :: a,vc_y :: a} deriving (Eq,Ord,Show)--instance Num a => Num (Vc a) where- (+) = vc_binop (+)- (-) = vc_binop (-)- (*) = vc_binop (*)- negate = vc_uop negate- abs = vc_uop abs- signum = vc_uop signum- fromInteger n = let n' = fromInteger n in Vc n' n'---- | Two-dimensional line.-data Ln a = Ln {ln_start :: Pt a,ln_end :: Pt a} deriving (Eq,Ord,Show)---- | Line segments.-type Ls a = [Pt a]---- | Window, given by a /lower left/ 'Pt' and an /extent/ 'Vc'.-data Wn a = Wn {wn_ll :: Pt a,wn_ex :: Vc a} deriving (Eq,Show)---- | Real number, synonym for 'Double'.-type R = Double---- * R(eal) functions---- | Epsilon.-epsilon :: Floating n => n-epsilon = 0.000001---- | Is absolute difference less than 'epsilon'.-(~=) :: (Floating a, Ord a) => a -> a -> Bool-p ~= q = abs (p - q) < epsilon---- | Degrees to radians.------ > map r_to_radians [-180,-90,0,90,180] == [-pi,-pi/2,0,pi/2,pi]-r_to_radians :: R -> R-r_to_radians x = (x / 180) * pi---- | Radians to degrees, inverse of 'r_to_radians'.------ > map r_from_radians [-pi,-pi/2,0,pi/2,pi] == [-180,-90,0,90,180]-r_from_radians :: R -> R-r_from_radians x = (x / pi) * 180---- | 'R' modulo within range.------ > map (r_constrain (3,5)) [2.75,5.25] == [4.75,3.25]-r_constrain :: (R,R) -> R -> R-r_constrain (l,r) =- let down n i x = if x > i then down n i (x - n) else x- up n i x = if x < i then up n i (x + n) else x- both n i j x = up n i (down n j x)- in both (r - l) l r---- | Sum of squares.-mag_sq :: Num a => a -> a -> a-mag_sq x y = x * x + y * y---- | 'sqrt' of 'mag_sq'.-mag :: Floating c => c -> c -> c-mag x = sqrt . mag_sq x---- * Pt functions---- | Tuple constructor.-pt' :: (a,a) -> Pt a-pt' (x,y) = Pt x y---- | Tuple accessor.-pt_xy :: Pt t -> (t, t)-pt_xy (Pt x y) = (x,y)---- | 'Pt' of (0,0).------ > pt_origin == Pt 0 0-pt_origin :: Num a => Pt a-pt_origin = Pt 0 0---- | Unary operator at 'Pt', ie. basis for 'Num' instances.-pt_uop :: (a -> b) -> Pt a -> Pt b-pt_uop f (Pt x y) = Pt (f x) (f y)---- | Binary operator at 'Pt', ie. basis for 'Num' instances.-pt_binop :: (a -> b -> c) -> Pt a -> Pt b -> Pt c-pt_binop f (Pt x1 y1) (Pt x2 y2) = Pt (x1 `f` x2) (y1 `f` y2)---- | 'Pt' at /(n,n)/.------ > pt_from_scalar 1 == Pt 1 1-pt_from_scalar :: (Num a) => a -> Pt a-pt_from_scalar a = Pt a a---- | Clip /x/ and /y/ to lie in /(0,n)/.------ > pt_clipu 1 (Pt 0.5 1.5) == Pt 0.5 1-pt_clipu :: (Ord a,Num a) => a -> Pt a -> Pt a-pt_clipu u =- let f n = if n < 0 then 0 else if n > u then u else n- in pt_uop f---- | Swap /x/ and /y/ coordinates at 'Pt'.------ > pt_swap (Pt 1 2) == Pt 2 1-pt_swap :: Pt a -> Pt a-pt_swap (Pt x y) = Pt y x---- | Negate /y/ element of 'Pt'.------ > pt_negate_y (Pt 1 1) == Pt 1 (-1)-pt_negate_y :: (Num a) => Pt a -> Pt a-pt_negate_y (Pt x y) = Pt x (negate y)---- | 'Pt' variant of 'r_to_radians'.------ > pt_to_radians (Pt 90 270) == Pt (pi/2) (pi*(3/2))-pt_to_radians :: Pt R -> Pt R-pt_to_radians = pt_uop r_to_radians---- | Cartesian to polar.------ > pt_to_polar (Pt 0 pi) == Pt pi (pi/2)-pt_to_polar :: Pt R -> Pt R-pt_to_polar (Pt x y) =- let (x',y') = polar (x :+ y)- in Pt x' y'---- | Polar to cartesian, inverse of 'pt_to_polar'.------ > pt_from_polar (Pt pi (pi/2)) ~= Pt 0 pi-pt_from_polar :: Pt R -> Pt R-pt_from_polar (Pt mg ph) =- let c = mkPolar mg ph- in Pt (realPart c) (imagPart c)---- | Scalar 'Pt' '+'.------ > pt_offset 1 pt_origin == Pt 1 1-pt_offset :: Num a => a -> Pt a -> Pt a-pt_offset = pt_uop . (+)---- | Scalar 'Pt' '*'.------ > pt_scale 2 (Pt 1 2) == Pt 2 4-pt_scale :: Num a => a -> Pt a -> Pt a-pt_scale = pt_uop . (*)---- | Pointwise 'min'.-pt_min :: (Ord a) => Pt a -> Pt a -> Pt a-pt_min = pt_binop min---- | Pointwise 'max'.-pt_max :: (Ord a) => Pt a -> Pt a -> Pt a-pt_max = pt_binop max---- | Apply function to /x/ and /y/ fields of three 'Pt'.-pt_ternary_f :: (a->a->b->b->c->c->d) -> Pt a -> Pt b -> Pt c -> d-pt_ternary_f f (Pt x0 y0) (Pt x1 y1) (Pt x2 y2) = f x0 y0 x1 y1 x2 y2---- | Given a /(minima,maxima)/ pair, expand so as to include /p/.------ > pt_minmax (Pt 0 0,Pt 1 1) (Pt (-1) 2) == (Pt (-1) 0,Pt 1 2)-pt_minmax :: Ord a => (Pt a,Pt a) -> Pt a -> (Pt a,Pt a)-pt_minmax (p0,p1) p =- let f x0 y0 x1 y1 x y =- (Pt (min x x0) (min y y0)- ,Pt (max x x1) (max y y1))- in pt_ternary_f f p0 p1 p---- | 'Pt' variant of 'constrain'.-pt_constrain :: (Pt R,Pt R) -> Pt R -> Pt R-pt_constrain (p0,p1) p =- let f x0 y0 x1 y1 x y =- let x' = r_constrain (x0,x1) x- y' = r_constrain (y0,y1) y- in Pt x' y'- in pt_ternary_f f p0 p1 p---- | Angle to origin.------ > pt_angle_o (Pt 0 1) == pi / 2-pt_angle_o :: Pt R -> R-pt_angle_o (Pt x y) = atan2 y x---- | Angle from /p/ to /q/.------ > pt_angle (Pt 0 (-1)) (Pt 0 1) == pi/2--- > pt_angle (Pt 1 0) (Pt 0 1) == pi * 3/4--- > pt_angle (Pt 0 1) (Pt 0 1) == 0-pt_angle :: Pt R -> Pt R -> R-pt_angle p q = pt_angle_o (q - p)---- | Pointwise '+'.------ pt_translate (Pt 0 0) (vc 1 1) == pt 1 1-pt_translate :: (Num a,Eq a) => Pt a -> Vc a -> Pt a-pt_translate (Pt x y) (Vc dx dy) = Pt (x + dx) (y + dy)---- | 'pt_uop' 'fromIntegral'.-pt_from_i :: (Integral i,Num a) => Pt i -> Pt a-pt_from_i = pt_uop fromIntegral---- | 'mag_sq' of /x/ /y/ of 'Pt'.-pt_mag_sq :: Num a => Pt a -> a-pt_mag_sq (Pt x y) = mag_sq x y---- | 'mag' of /x/ /y/ of 'Pt'.-pt_mag :: Floating a => Pt a -> a-pt_mag (Pt x y) = mag x y---- | Distance from 'Pt' /p/ to 'Pt' /q/.------ > pt_distance (Pt 0 0) (Pt 0 1) == 1--- > pt_distance (Pt 0 0) (Pt 1 1) == sqrt 2-pt_distance :: (Floating a,Eq a) => Pt a -> Pt a -> a-pt_distance (Pt x1 y1) (Pt x2 y2) = pt_mag (Pt (x2 - x1) (y2 - y1))---- | Are /x/ and /y/ of 'Pt' /p/ in range (0,1).------ > map pt_is_normal [Pt 0 0,Pt 1 1,Pt 2 2] == [True,True,False]-pt_is_normal :: (Ord a,Num a) => Pt a -> Bool-pt_is_normal (Pt x y) = 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 (Pt x y) =- let s = sin a- c = cos a- in Pt (x * c - y * s) (y * c + x * s)--pt_rotate_about :: Floating a => a -> Pt a -> Pt a -> Pt a-pt_rotate_about r p0 p1 = pt_rotate r (p1 - p0) + p0---- * Vc functions---- | Unary operator at 'Vc', ie. basis for 'Num' instances.-vc_uop :: (a -> b) -> Vc a -> Vc b-vc_uop f (Vc x y) = Vc (f x) (f y)---- | Binary operator at 'Vc', ie. basis for 'Num' instances.-vc_binop :: (a -> b -> c) -> Vc a -> Vc b -> Vc c-vc_binop f (Vc x1 y1) (Vc x2 y2) = Vc (x1 `f` x2) (y1 `f` y2)---- | 'mag_sq' of 'Vc'.-vc_mag_sq :: Floating c => Vc c -> c-vc_mag_sq (Vc dx dy) = mag_sq dx dy---- | 'mag' of 'Vc'.-vc_mag :: Floating c => Vc c -> c-vc_mag (Vc dx dy) = mag dx dy---- | Multiply 'Vc' pointwise by scalar.------ > vc_scale 2 (Vc 3 4) == Vc 6 8-vc_scale :: Num a => a -> Vc a -> Vc a-vc_scale n (Vc x y) = Vc (x * n) (y * n)---- | 'Vc' dot product.------ > vc_dot (Vc 1 2) (Vc 3 4) == 11-vc_dot :: Num a => Vc a -> Vc a -> a-vc_dot (Vc x y) (Vc x' y') = (x * x') + (y * y')---- | 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 v- | abs (vc_mag_sq v - 1) < epsilon = v- | vc_mag_sq v == 0 = v- | otherwise = let Vc x y = v- m = mag x y- in Vc (x / m) (y / m)---- | The angle between two vectors on a plane. The angle is from v1 to--- v2, positive anticlockwise. The result is in (-pi,pi)-vc_angle :: Vc R -> Vc R -> R-vc_angle (Vc x1 y1) (Vc x2 y2) =- let t1 = atan2 y1 x1- t2 = atan2 y2 x2- in r_constrain (-pi,pi) (t2 - t1)---- * Line functions---- | Variant on 'Ln' which takes 'Pt' co-ordinates as duples.------ > ln' (0,0) (1,1) == Ln (Pt 0 0) (Pt 1 1)--- > ln_start (Ln (Pt 0 0) (Pt 1 1)) == Pt 0 0--- > ln_end (Ln (Pt 0 0) (Pt 1 1)) == Pt 1 1-ln' :: (Num a,Eq a) => (a,a) -> (a,a) -> Ln a-ln' (x1,y1) (x2,y2) = Ln (Pt x1 y1) (Pt x2 y2)---- | '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,Eq a) => Ln a -> Vc a-ln_vc (Ln p q) = let Pt x y = q - p in Vc x y---- | 'Pt' UOp at 'Ln'.-ln_uop :: (Pt a -> Pt b) -> Ln a -> Ln b-ln_uop f (Ln l r) = Ln (f l) (f r)---- | 'pt_scale' at 'Ln'.-ln_scale :: Num b => b -> Ln b -> Ln b-ln_scale m = ln_uop (pt_scale m)---- | The angle, in /radians/, anti-clockwise from the /x/-axis.------ > ln_angle (ln' (0,0) (0,0)) == 0--- > ln_angle (ln' (0,0) (1,1)) == pi/4--- > 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 ln =- let Vc dx dy = ln_vc ln- in if dx == 0 && dy == 0 then 0 else atan2 dy dx---- | 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,Eq a) => Ln a -> (Pt a,Pt a)-ln_pt (Ln s e) = (s,e)---- | 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,Eq a) => Ln a -> ((a,a),(a,a))-ln_pt' (Ln (Pt x1 y1) (Pt x2 y2)) = ((x1,y1),(x2,y2))---- | Midpoint of a 'Ln'.------ > ln_midpoint (Ln (Pt 0 0) (Pt 2 1)) == Pt 1 (1/2)-ln_midpoint :: (Fractional a,Eq a) => Ln a -> Pt a-ln_midpoint (Ln (Pt x1 y1) (Pt x2 y2)) =- let x = (x1 + x2) / 2- y = (y1 + y2) / 2- in Pt x y---- | Variant on 'ln_midpoint'.------ > cc_midpoint (Just (Pt 0 0),Nothing) == Pt 0 0--- > cc_midpoint (Nothing,Just (Pt 2 1)) == Pt 2 1--- > cc_midpoint (Just (Pt 0 0),Just (Pt 2 1)) == Pt 1 (1/2)-cc_midpoint :: (Maybe (Pt R), Maybe (Pt R)) -> Pt R-cc_midpoint cc =- case cc of- (Nothing,Nothing) -> Pt 0 0- (Just p,Nothing) -> p- (Nothing, Just q) -> q- (Just p, Just q) -> ln_midpoint (Ln p q)---- | Magnitude of 'Ln', ie. length of line.------ > 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 = vc_mag . ln_vc---- | Order 'Pt' at 'Ln' so that /p/ is to the left of /q/. If /x/--- fields are equal, sort on /y/.------ > ln_sort (Ln (Pt 1 0) (Pt 0 0)) == Ln (Pt 0 0) (Pt 1 0)--- > ln_sort (Ln (Pt 0 1) (Pt 0 0)) == Ln (Pt 0 0) (Pt 0 1)-ln_sort :: (Num a,Ord a) => Ln a -> Ln a-ln_sort ln =- let Ln p q = ln- Pt x1 y1 = p- Pt x2 y2 = q- in case compare x1 x2 of- LT -> ln- EQ -> if y1 <= y2 then ln else Ln q p- GT -> Ln q p---- | Adjust 'Ln' to have equal starting 'Pt' but magnitude 'R'.------ > 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 z ln =- let Ln p _ = ln- v = vc_scale z (vc_unit (ln_vc ln))- in Ln p (pt_translate p v)---- | Extend 'Ln' by 'R', ie. 'ln_adjust' with /n/ added to--- 'ln_magnitude'.------ > ln_extend (sqrt 2) (Ln (Pt 0 0) (Pt 1 1)) ~= Ln (Pt 0 0) (Pt 2 2)-ln_extend :: R -> Ln R -> Ln R-ln_extend n l = Ln (ln_start l) (pt_linear_extension n l)---- | Variant definition of 'ln_extend'.------ > ln_extend_ (sqrt 2) (Ln (Pt 0 0) (Pt 1 1)) == Ln (Pt 0 0) (Pt 2 2)-ln_extend_ :: R -> Ln R -> Ln R-ln_extend_ n l = ln_adjust (n + ln_magnitude l) l---- | Calculate the point that extends a line by length 'n'.------ > pt_linear_extension (sqrt 2) (Ln (Pt 1 1) (Pt 2 2)) ~= Pt 3 3--- > pt_linear_extension 1 (Ln (Pt 1 1) (Pt 1 2)) ~= Pt 1 3-pt_linear_extension :: R -> Ln R -> Pt R-pt_linear_extension n (Ln p q) =- let Pt mg ph = pt_to_polar (q - p)- in pt_from_polar (Pt (mg + n) ph) + p---- | Does 'Pt' /p/ lie on 'Ln' (inclusive).------ > let {f = pt_on_line (Ln (Pt 0 0) (Pt 1 1))--- > ;r = [True,False,False,True]}--- > in map f [Pt 0.5 0.5,Pt 2 2,Pt (-1) (-1),Pt 0 0] == r-pt_on_line :: Ln R -> Pt R -> Bool-pt_on_line l r =- let (p,q) = ln_pt l- Pt i j = pt_to_polar (q - p)- Pt i' j' = pt_to_polar (r - p)- in r == p || r == q || (j == j' && i' <= i)---- * Intersection--ln_intersect :: (Eq t, Fractional t) => Ln t -> Ln t -> Maybe (t,t)-ln_intersect l1 l2 =- let Ln (Pt x1 y1) _ = l1- Vc dx1 dy1 = ln_vc l1- Ln (Pt x2 y2) _ = l2- Vc dx2 dy2 = ln_vc l2- a = (dx2 * dy1) - (dx1 * dy2)- t' = ((dx1 * (y2 - y1)) - (dy1 * (x2 - x1))) / a- t = ((dx2 * (y1 - y2)) - (dy2 * (x1 - x2))) / (negate a)- in if a == 0 then Nothing else Just (t,t')--ln_pt_along :: (Eq a, Num a) => a -> Ln a -> Pt a-ln_pt_along z ln =- let v = vc_scale z (ln_vc ln)- Ln p _ = ln- in pt_translate p v---- | Do two 'Ln's intersect, and if so at which 'Pt'.------ > ln_intersection (ln' (0,0) (5,5)) (ln' (5,0) (0,5)) == Just (Pt 2.5 2.5)--- > ln_intersection (ln' (1,3) (9,3)) (ln' (0,1) (2,1)) == Nothing--- > ln_intersection (ln' (1,5) (6,8)) (ln' (0.5,3) (6,4)) == Nothing--- > ln_intersection (ln' (1,2) (3,6)) (ln' (2,4) (4,8)) == Nothing--- > ln_intersection (ln' (2,3) (7,9)) (ln' (1,2) (5,7)) == Nothing--- > 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 ln_intersect l0 l1 of- Nothing -> Nothing- Just (i,j) -> if i >= 0 && i <= 1 && j >= 0 && j <= 1- then Just (ln_pt_along i l0)- else Nothing---- | Variant definition of 'ln_intersection', using algorithm at--- <http://paulbourke.net/geometry/lineline2d/>.------ > ln_intersection_ (ln' (1,2) (3,6)) (ln' (2,4) (4,8)) == Nothing--- > 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 =- let ((x1,y1),(x2,y2)) = ln_pt' l0- ((x3,y3),(x4,y4)) = ln_pt' l1- d = (y4 - y3) * (x2 - x1) - (x4 - x3) * (y2 - y1)- ua' = (x4 - x3) * (y1 - y3) - (y4 - y3) * (x1 - x3)- ub' = (x2 - x1) * (y1 - y3) - (y2 - y1) * (x1 - x3)- in if d == 0- then Nothing- else if ua' == 0 && ub' == 0- then Just (Pt x1 y1)- else let ua = ua' / d- ub = ub' / d- in if in_range 0 1 ua && in_range 0 1 ub- then let x = x1 + ua * (x2 - x1)- y = y1 + ua * (y2 - y1)- in Just (Pt x y)- else Nothing---- | Predicate variant of 'ln_intersection'.------ > ln_intersect_p (ln' (1,1) (3,8)) (ln' (0.5,2) (4,7)) == True--- > ln_intersect_p (ln' (3.5,9) (3.5,0.5)) (ln' (3,1) (9,1)) == True-ln_intersect_p :: (Ord a, Fractional a) => Ln a -> Ln a -> Bool-ln_intersect_p l = isJust . ln_intersection l---- * Line slope---- | Slope of 'Ln' or 'Nothing' if /vertical/.------ > 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,Eq a) => Ln a -> Maybe a-ln_slope l =- let ((x1,y1),(x2,y2)) = ln_pt' l- in case x2 - x1 of- 0 -> Nothing- dx -> Just ((y2 - y1) / dx)---- | Are 'Ln's parallel, ie. have equal 'ln_slope'. Note that the--- direction of the 'Ln' is not relevant, ie. this is not equal to--- 'ln_same_direction'.------ > ln_parallel (ln' (0,0) (1,1)) (ln' (2,2) (1,1)) == True--- > ln_parallel (ln' (0,0) (1,1)) (ln' (2,0) (1,1)) == False--- > ln_parallel (ln' (1,2) (3,6)) (ln' (2,4) (4,8)) == True--- > map ln_slope [ln' (2,2) (1,1),ln' (2,0) (1,1)] == [Just 1,Just (-1)]-ln_parallel :: (Ord a,Fractional a) => Ln a -> Ln a -> Bool-ln_parallel p q = ln_slope p == ln_slope q---- | Are 'Ln's parallel, ie. have equal 'ln_angle'.------ > 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_angle (ln_sort p) == ln_angle (ln_sort q)---- | Are two vectors are in the same direction (to within a small--- tolerance).-vc_same_direction :: (Ord a, Floating a) => Vc a -> Vc a -> Bool-vc_same_direction v w =- let Vc dx1 dy1 = vc_unit v- Vc dx2 dy2 = vc_unit w- in abs (dx2 - dx1) < epsilon && abs (dy2 - dy1) < epsilon---- | Do 'Ln's have same direction (within tolerance).------ > 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 `vc_same_direction` 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) `vc_same_direction` 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,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,Eq a) => Ln a -> Bool-ln_vertical = (== Nothing) . ln_slope---- * Ln sets---- | 'pt_minmax' for set of 'Ln'.-lns_minmax :: Ord n => [Ln n] -> (Pt n,Pt n)-lns_minmax = ls_minmax . concatMap (\(Ln l r) -> [l,r])---- | Normalise to (0,m).-lns_normalise :: (Fractional n,Ord n) => n -> [Ln n] -> [Ln n]-lns_normalise m l =- let w = wn_from_extent (lns_minmax l)- in map (ln_scale m . ln_normalise_w w) l---- * L(ine) s(egment) functions---- | 'Ls' constructor.-ls :: [Pt a] -> Ls a-ls = id---- | Variant 'Ls' constructor from 'Pt' co-ordinates as duples.-ls' :: [(a,a)] -> Ls a-ls' = map (uncurry Pt)---- | Negate /y/ elements.-ls_negate_y :: (Num a) => Ls a -> Ls a-ls_negate_y = map pt_negate_y---- | Generate /minima/ and /maxima/ 'Point's from 'Ls'.-ls_minmax :: Ord a => Ls a -> (Pt a,Pt a)-ls_minmax s =- case s of- [] -> undefined- p:ps -> foldl pt_minmax (p,p) ps---- | Separate 'Ls' at points where the 'Vc' from one element to the--- next exceeds the indicated distance.------ > map length (ls_separate (Vc 2 2) (map (uncurry Pt) [(0,0),(1,1),(3,3)])) == [2,1]-ls_separate :: (Ord a,Num a) => Vc a -> Ls a -> [Ls a]-ls_separate (Vc dx dy) =- let f (Pt x0 y0) (Pt x1 y1) = abs (x1 - x0) < dx &&- abs (y1 - y0) < dy- in segment_f f---- | Delete 'Pt' from 'Ls' so that no two 'Pt' are within a tolerance--- given by 'Vc'.-ls_tolerate :: (Ord a,Num a) => Vc a -> Ls a -> Ls a-ls_tolerate (Vc x y) =- let too_close (Pt x0 y0) (Pt x1 y1) =- let dx = abs (x1 - x0)- dy = abs (y1 - y0)- in dx < x && dy < y- in delete_f too_close---- | Variant of 'ls_tolerate' where 'Vc' is optional, and 'Nothing' gives 'id'.-ls_tolerate' :: (Ord a,Num a) => Maybe (Vc a) -> Ls a -> Ls a-ls_tolerate' i =- case i of- Nothing -> id- Just i' -> ls_tolerate i'---- | Test if point 'Pt' lies inside polygon 'Ls'.------ > ls_pt_inside (ls' [(0,0),(1,0),(1,1),(0,1)]) (Pt 0.5 0.5) == True-ls_pt_inside :: Ls R -> Pt R -> Bool-ls_pt_inside s (Pt x y) =- case s of- [] -> undefined- l0:l -> let xs = pairs ((l0:l)++[l0])- f (Pt x1 y1,Pt x2 y2) =- and [y > min y1 y2- ,y <= max y1 y2- ,x <= max x1 x2- ,y1 /= y2- ,x1 == x2 ||- x <= (y-y1)*(x2-x1)/(y2-y1)+x1]- in odd (length (filter id (map f xs)))---- | Variant that counts points at vertices as inside.------ > 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 = 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-ls_check_normalised s =- case s of- [] -> True- p:z -> pt_is_normal p && ls_check_normalised z---- | Line co-ordinates as /x/,/y/ list.------ > ls_xy [Pt 0 0,Pt 1 1] == [0,0,1,1]-ls_xy :: Ls a -> [a]-ls_xy = concatMap (\(Pt x y) -> [x,y])---- | 'Ls' average.-ls_centroid :: Fractional t => Ls t -> Pt t-ls_centroid l =- let (x,y) = unzip (map pt_xy l)- length' = fromIntegral . length- in Pt (sum x / length' x) (sum y / length' y)---- | 'map' of 'pt_rotate_about'.-ls_rotate_about :: Floating t => t -> Pt t -> Ls t -> Ls t-ls_rotate_about r c = map (pt_rotate_about r c)---- | 'ls_rotate_about' of 'ls_centroid'.-ls_rotate_about_centroid :: Floating t => t -> Ls t -> Ls t-ls_rotate_about_centroid r l = ls_rotate_about r (ls_centroid l) l---- * Window---- | Variant 'Wn' constructor.-wn' :: Num a => (a,a) -> (a,a) -> Wn a-wn' (x,y) (i,j) = Wn (Pt x y) (Vc i j)---- | Extract /(x,y)/ and /(dx,dy)/ pairs.------ > wn_extract (Wn (Pt 0 0) (Vc 1 1)) == ((0,0),(1,1))-wn_extract :: Wn a -> ((a,a),(a,a))-wn_extract (Wn (Pt x y) (Vc dx dy)) = ((x,y),(dx,dy))---- | Show function for window with fixed precision of 'n'.------ > wn_show 1 (Wn (Pt 0 0) (Vc 1 1)) == "((0.0,0.0),(1.0,1.0))"-wn_show :: Int -> Wn R -> String-wn_show n (Wn (Pt x0 y0) (Vc dx dy)) =- let fs = printf "((%%.%df,%%.%df),(%%.%df,%%.%df))" n n n n- in printf fs x0 y0 dx dy---- | Unit window at origin.-wn_unit :: Num n => Wn n-wn_unit = Wn pt_origin (Vc 1 1)---- | Is 'Pt' within 'Wn' exclusive of edge.------ > map (pt_in_window (wn' (0,0) (1,1))) [Pt 0.5 0.5,Pt 1 1] == [True,False]-pt_in_window :: (Ord a,Num a) => Wn a -> Pt a -> Bool-pt_in_window (Wn (Pt lx ly) (Vc dx dy)) (Pt x y) =- let (ux,uy) = (lx+dx,ly+dy)- in x > lx && x < ux && y > ly && y < uy---- | 'Wn' from /(lower-left,upper-right)/ extent.-wn_from_extent :: (Num a,Ord a) => (Pt a,Pt a) -> Wn a-wn_from_extent (Pt x0 y0,Pt x1 y1) = Wn (Pt x0 y0) (Vc (x1-x0) (y1-y0))---- | 'Wn' containing 'Ls'.------ > ls_window (ls' [(0,0),(1,1),(2,0)]) == wn' (0,0) (2,1)-ls_window :: (Num a,Ord a) => Ls a -> Wn a-ls_window = wn_from_extent . ls_minmax---- | A 'Wn' that encompasses both input 'Wn's.-wn_join :: (Num a,Ord a) => Wn a -> Wn a -> Wn a-wn_join (Wn (Pt x0 y0) (Vc dx0 dy0)) (Wn (Pt x1 y1) (Vc dx1 dy1)) =- let x = min x0 x1- y = min y0 y1- dx = max (x0+dx0) (x1+dx1) - x- dy = max (y0+dy0) (y1+dy1) - y- in Wn (Pt x y) (Vc dx dy)---- | Predictate to determine if two 'Wn's intersect.-wn_intersect :: (Num a,Ord a) => Wn a -> Wn a -> Bool-wn_intersect w0 w1 =- let (Wn (Pt x0 y0) (Vc dx0 dy0)) = w0- (Wn (Pt x1 y1) (Vc dx1 dy1)) = w1- in not (x0 > x1+dx1 || x1 > x0+dx0 || y0 > y1+dy1 || y1 > y0+dy0)---- | Are all points at 'Ls' within the 'Wn'.-ls_in_window :: Wn R -> Ls R -> Bool-ls_in_window w = all (pt_in_window w)---- | Are any points at 'Ls' within the window 'Wn'.-ls_enters_window :: Wn R -> Ls R -> Bool-ls_enters_window w = any (pt_in_window w)---- | Are all points at 'Ls' outside the 'Wn'.-ls_not_in_window :: Wn R -> Ls R -> Bool-ls_not_in_window w = all (not . pt_in_window w)---- | Break 'Ls' into segments that are entirely within the 'Wn'.-ls_segment_window :: Wn R -> Ls R -> [Ls R]-ls_segment_window w =- let g [] = []- g xs = let (i,xs') = span (pt_in_window w) xs- in i : g (dropWhile (not . pt_in_window w) xs')- in filter (not . null) . g---- | Normalisation function for 'Wn', ie. map 'Pt' to lie within (0,1).-wn_normalise_f :: (Ord n,Fractional n) => Wn n -> Pt n -> Pt n-wn_normalise_f (Wn (Pt x0 y0) (Vc dx dy)) (Pt x y) =- let z = max dx dy- in Pt ((x - x0) / z) ((y - y0) / z)---- | Given 'Wn' normalise the 'Ls'.-ls_normalise_w :: (Ord n,Fractional n) => Wn n -> Ls n -> Ls n-ls_normalise_w w = map (wn_normalise_f w)---- | Given 'Wn' normalise 'Ln'.-ln_normalise_w :: (Ord n,Fractional n) => Wn n -> Ln n -> Ln n-ln_normalise_w w (Ln p q) =- let f = wn_normalise_f w- in Ln (f p) (f q)---- | Variant of 'ls_normalise_w', the window is determined by the--- extent of the 'Ls'.-ls_normalise :: (Ord n,Fractional n) => Ls n -> Ls n-ls_normalise l = ls_normalise_w (wn_from_extent (ls_minmax l)) l---- | Normalise a set of line segments using composite window.-ls_normalise_set :: (Ord n,Fractional n) => [Ls n] -> [Ls n]-ls_normalise_set l =- let w = wn_from_extent (ls_minmax (concat l))- in map (ls_normalise_w w) l---- | Shift lower left 'Pt' of 'Wn' by indicated 'Pt'.-pt_shift_w :: Num a => Pt a -> Wn a -> Wn a-pt_shift_w p (Wn dp ex) = Wn (p + dp) ex---- | Negate /y/ field of lower left 'Pt' of 'Wn'.-wn_negate_y :: Num a => Wn a -> Wn a-wn_negate_y (Wn p v) = Wn (pt_negate_y p) v---- * Matrix---- | Transformation matrix data type.-data Matrix n = Matrix n n n n n n deriving (Eq,Show)---- | Enumeration of 'Matrix' indices.-data Matrix_Index = I0 | I1 | I2--mx_row :: Num n => Matrix n -> Matrix_Index -> (n,n,n)-mx_row (Matrix a b c d e f) i =- case i of- I0 -> (a,b,0)- I1 -> (c,d,0)- I2 -> (e,f,1)--mx_col :: Num n => Matrix n -> Matrix_Index -> (n,n,n)-mx_col (Matrix a b c d e f) i =- case i of- I0 -> (a,c,e)- I1 -> (b,d,f)- I2 -> (0,0,1)--mx_multiply :: Num n => Matrix n -> Matrix n -> Matrix n-mx_multiply a b =- let f i j = let (r1,r2,r3) = mx_row a i- (c1,c2,c3) = mx_col b j- in r1 * c1 + r2 * c2 + r3 * c3- in Matrix (f I0 I0) (f I0 I1) (f I1 I0) (f I1 I1) (f I2 I0) (f I2 I1)---- | Pointwise unary operator.-mx_uop :: (n -> n) -> Matrix n -> Matrix n-mx_uop g (Matrix a b c d e f) =- Matrix (g a) (g b) (g c) (g d) (g e) (g f)---- | Pointwise binary operator.-mx_binop :: (n -> n -> n) -> Matrix n -> Matrix n -> Matrix n-mx_binop g (Matrix a b c d e f) (Matrix a' b' c' d' e' f') =- Matrix (g a a') (g b b') (g c c') (g d d') (g e e') (g f f')--instance Num n => Num (Matrix n) where- (*) = mx_multiply- (+) = mx_binop (+)- (-) = mx_binop (-)- abs = mx_uop abs- signum = mx_uop signum- fromInteger n = let n' = fromInteger n- in Matrix n' 0 0 n' 0 0---- | A translation matrix with independent x and y offsets.-mx_translation :: Num n => n -> n -> Matrix n-mx_translation = Matrix 1 0 0 1---- | A scaling matrix with independent x and y scalars.-mx_scaling :: Num n => n -> n -> Matrix n-mx_scaling x y = Matrix x 0 0 y 0 0---- | A rotation matrix through the indicated angle (in radians).-mx_rotation :: Floating n => n -> Matrix n-mx_rotation a =- let c = cos a- s = sin a- t = negate s- in Matrix c s t c 0 0---- | The identity matrix.-mx_identity :: Num n => Matrix n-mx_identity = Matrix 1 0 0 1 0 0--mx_translate :: Num n => n -> n -> Matrix n -> Matrix n-mx_translate x y m = m * (mx_translation x y)--mx_scale :: Num n => n -> n -> Matrix n -> Matrix n-mx_scale x y m = m * (mx_scaling x y)--mx_rotate :: Floating n => n -> Matrix n -> Matrix n-mx_rotate r m = m * (mx_rotation r)--mx_scalar_multiply :: Num n => n -> Matrix n -> Matrix n-mx_scalar_multiply scalar = mx_uop (* scalar)--mx_adjoint :: Num n => Matrix n -> Matrix n-mx_adjoint (Matrix a b c d x y) =- Matrix d (-b) (-c) a (c * y - d * x) (b * x - a * y)--mx_invert :: Fractional n => Matrix n -> Matrix n-mx_invert m =- let Matrix xx yx xy yy _ _ = m- d = xx*yy - yx*xy- in mx_scalar_multiply (recip d) (mx_adjoint m)--mx_list :: Matrix n -> [n]-mx_list (Matrix a b c d e f) = [a,b,c,d,e,f]---- | Apply a transformation matrix to a point.-pt_transform :: Num n => Matrix n -> Pt n -> Pt n-pt_transform (Matrix a b c d e f) (Pt x y) =- let x' = x * a + y * c + e- y' = x * b + y * d + f- in Pt x' y'---- * Bezier functions.--bezier3 :: Num n => Pt n -> Pt n -> Pt n -> n -> Pt n-bezier3 (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) mu = (Pt x y)- where a = mu*mu- b = 1 - mu- c = b*b- x = x1*c + 2*x2*b*mu + x3*a- y = y1*c + 2*y2*b*mu + y3*a---- | Four-point bezier curve interpolation. The index /mu/ is--- in the range zero to one.-bezier4 :: Num n => Pt n -> Pt n -> Pt n -> Pt n -> n -> Pt n-bezier4 (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) (Pt x4 y4) mu =- let a = 1 - mu- b = a*a*a- c = mu*mu*mu- x = b*x1 + 3*mu*a*a*x2 + 3*mu*mu*a*x3 + c*x4- y = b*y1 + 3*mu*a*a*y2 + 3*mu*mu*a*y3 + c*y4- in Pt x y---- * Ord---- | Given /left/ and /right/, is /x/ in range (inclusive).------ > map (in_range 0 1) [-1,0,1,2] == [False,True,True,False]-in_range :: Ord a => a -> a -> a -> Bool-in_range l r x = l <= x && x <= r---- * List---- | Split list at element where predicate /f/ over adjacent elements--- first holds.------ > split_f (\p q -> q - p < 3) [1,2,4,7,11] == ([1,2,4],[7,11])-split_f :: (a -> a -> Bool) -> [a] -> ([a],[a])-split_f f =- let go i [] = (reverse i,[])- go i [p] = (reverse (p:i), [])- go i (p:q:r) =- if f p q- then go (p:i) (q:r)- else (reverse (p:i),q:r)- in go []---- | Variant on 'split_f' that segments input.------ > segment_f (\p q -> abs (q - p) < 3) [1,3,7,9,15] == [[1,3],[7,9],[15]]-segment_f :: (a -> a -> Bool) -> [a] -> [[a]]-segment_f f xs =- let (p,q) = split_f f xs- in if null q- then [p]- else p : segment_f f q---- | Delete elements of a list using a predicate over the--- previous and current elements.-delete_f :: (a -> a -> Bool) -> [a] -> [a]-delete_f f =- let go [] = []- go [p] = [p]- go (p:q:r) =- if f p q- then go (p:r)- else p : go (q:r)- in go+module Data.CG.Minus (module C) where --- | All adjacent pairs of a list.------ > pairs [1..5] == [(1,2),(2,3),(3,4),(4,5)]-pairs :: [x] -> [(x,x)]-pairs l =- case l of- x:y:z -> (x,y) : pairs (y:z)- _ -> []+import Data.CG.Minus.Types as C+import Data.CG.Minus.Colour as C+import Data.CG.Minus.Core as C
Data/CG/Minus/Arrow.hs view
@@ -9,7 +9,7 @@ -- > arrow_coord (Ln (Pt 0 0) (Pt 1 1)) 0.1 (pi/9) arrow_coord :: Ln R -> R -> R -> (Pt R,Pt R) arrow_coord l n a =- let ((x0,y0),(x1,y1)) = ln_pt' l+ let ((x0,y0),(x1,y1)) = ln_elem l a' = atan2 (y1 - y0) (x1 - x0) + pi x2 = x1 + n * cos (a' - a) y2 = y1 + n * sin (a' - a)
Data/CG/Minus/Bearing.hs view
@@ -3,35 +3,61 @@ import Data.CG.Minus --- | Enumeration of compass bearings-data Bearing = N | NNE | NE | ENE- | E | ESE | SE | SSE- | S | SSW | SW | WSW- | W | WNW | NW | NNW+-- | Enumeration of compass bearings (32 divisions).+data Bearing = N | NbE | NNE | NEbN | NE | NEbE | ENE | EbN+ | E | EbS | ESE | SEbE | SE | SEbS | SSE | SbE+ | S | SbW | SSW | SWbS | SW | SWbW | WSW | WbS+ | W | WbN | WNW | NWbW | NW | NWbN | NNW | NbW deriving (Eq,Enum,Bounded,Show) +-- | The 4, 8 and 16 element subsets of bearings, and all 32 bearings.+bearings_4,bearings_8,bearings_16,bearings_32 :: [Bearing]+bearings_4 = [N,E,S,W]+bearings_8 = [N,NE,E,SE,S,SW,W,NW]+bearings_16 = [N,NNE,NE,ENE,E,ESE,SE,SSE,S,SSW,SW,WSW,W,WNW,NW,NNW]+bearings_32 = [N .. NbW]++-- | The point on the unit circle of 'Bearing'.+--+-- > map bearing_pt_u [N,E,S,W]+-- > let n = sqrt 0.5 in pt_eq_by (~=) (bearing_pt_u NE) (Pt n n)+bearing_pt_u :: Bearing -> Pt R+bearing_pt_u b = pt_from_polar (Pt 1 (bearing_angle b))++-- | 'E' is zero, direction is counter-clockwise, in radians, in (-pi,pi).+--+-- > map (r_from_radians . bearing_angle) bearings_8 == [90,45,0,-45,-90,-135,180,135]+bearing_angle :: Bearing -> R+bearing_angle b =+ let ph = pi / 16+ n = 8 - fromIntegral (fromEnum b)+ a = n * ph+ in if a <= -pi then a + 2 * pi else a++bearing_n :: Integral i => i -> Pt R -> Pt R -> i+bearing_n dv p q =+ let dv' = fromIntegral dv+ a = negate (pt_angle p q) + pi+ in round ((a * ((dv' / 2) / pi)) - (dv' / 4)) `mod` dv+ -- | Bearing from 'Pt' /p/ to /q/. -- -- > let f (x,y) = bearing (Pt 0 0) (Pt x y) -- > map f [(0,1),(1,1),(1,0),(1,-1)] == [N,NE,E,SE] -- > map f [(0,-1),(-1,-1),(-1,0),(-1,1)] == [S,SW,W,NW]--- > map f [(1/4,1),(1,1/4),(1,-1/4),(1/4,-1)] == [NNE,ENE,ESE,SSE]--- > map f [(-1/4,-1),(-1,-1/4),(-1,1.4),(-1/4,1)] == [SSW,WSW,NW,NNW]+-- > map f [(1/2,1),(1,1/2),(1,-1/2),(1/2,-1)] == [NNE,ENE,ESE,SSE]+-- > map f [(1/4,1),(1,1/4),(1,-1/4),(1/4,-1)] == [NbE,EbN,EbS,SbE]+-- > map f [(-1/2,-1),(-1,-1/2),(-1,1/2),(-1/2,1)] == [SSW,WSW,WNW,NNW]+-- > map f [(-1/4,-1),(-1,-1/4),(-1,1.4),(-1/4,1)] == [SbW,WbS,NWbN,NbW] bearing :: Pt R -> Pt R -> Bearing-bearing p q =- let a = negate (pt_angle p q) + pi- c = round ((a * (8 / pi)) - 4) `mod` 16- in toEnum c+bearing p = toEnum . bearing_n 32 p -- | Bearing to nearest eight point compass bearing -- -- > let f (x,y) = bearing_8 (Pt 0 0) (Pt x y) -- > map f [(1/4,1),(1,1/4),(1,-1/4),(1/4,-1)] == [N,E,E,S] bearing_8 :: Pt R -> Pt R -> Bearing-bearing_8 p q =- let a = negate (pt_angle p q) + pi- c = round ((a * (4 / pi)) - 2) `mod` 8- in toEnum (c * 2)+bearing_8 p = toEnum . (* 4) . bearing_n 8 p -- | Predicate that is 'True' if bearings are opposite. --@@ -39,5 +65,5 @@ -- > map bearing_opposite (zip [N,E,S,W] [S,W,N,E]) == [True,True,True,True] bearing_opposite :: (Bearing,Bearing) -> Bool bearing_opposite (p, q) =- let n = (fromEnum p - fromEnum q) `mod` 16- in n == 8+ let n = (fromEnum p - fromEnum q) `mod` 32+ in n == 16
+ Data/CG/Minus/Bezier.hs view
@@ -0,0 +1,101 @@+-- * Bezier functions.+module Data.CG.Minus.Bezier where++import Data.CG.Minus.Types++-- | Three-point bezier curve interpolation. The index /mu/ is+-- in the range zero to one.+bezier3 :: Num n => Pt n -> Pt n -> Pt n -> n -> Pt n+bezier3 (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) mu =+ let a = mu*mu+ b = 1 - mu+ c = b*b+ x = x1*c + 2*x2*b*mu + x3*a+ y = y1*c + 2*y2*b*mu + y3*a+ in Pt x y++-- | Four-point bezier curve interpolation. The index /mu/ is+-- in the range zero to one.+bezier4 :: Num n => Pt n -> Pt n -> Pt n -> Pt n -> n -> Pt n+bezier4 (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) (Pt x4 y4) mu =+ let a = 1 - mu+ b = a*a*a+ c = mu*mu*mu+ x = b*x1 + 3*mu*a*a*x2 + 3*mu*mu*a*x3 + c*x4+ y = b*y1 + 3*mu*a*a*y2 + 3*mu*mu*a*y3 + c*y4+ in Pt x y++-- | Generic variant, given a scaling function, ie. 'pt_scale' or 'p3_scale'.+bezier4' :: (Num a, Num t) => (a -> t -> t) -> t -> t -> t -> t -> a -> t+bezier4' f p0 p1 p2 p3 t =+ let u = 1 - t+ tt = t * t+ ttt = tt * t+ uu = u * u+ uuu = uu * u+ in (uuu `f` p0) + ((3 * uu * t) `f` p1) + ((3 * u * tt) `f` p2) + (ttt `f` p3)++unwrap_mu :: Fractional a => a -> a -> a -> a+unwrap_mu x0 x3 mu = let d = x3 - x0 in (mu - x0) / d++next_mu :: Fractional a => a -> a -> a+next_mu x0 x3 = x0 + ((x3 - x0) / 2)++-- | Requires that x is monotonic (increasing), so that a simple+-- binary search will work. Initial /mu/ allows fast forwarding to+-- last result for left to right lookup (unused in variants here).+bezier4_y_mt' :: (Ord a, Fractional a) => a -> Pt a -> Pt a -> Pt a -> Pt a -> a -> a -> (a,a)+bezier4_y_mt' dx (Pt x0 y0) (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) i_mu x =+ let f = bezier4 (Pt x0 y0) (Pt x1 y1) (Pt x2 y2) (Pt x3 y3)+ recur l r mu =+ let (Pt x' y') = f (unwrap_mu x0 x3 mu)+ in if abs (x - x') <= dx+ then (mu,y')+ else let (l',r') = if x' < x then (mu,r) else (l,mu)+ mu' = next_mu l' r'+ in recur l' r' mu'+ in recur x0 x3 i_mu++-- | Variant with initial /mu/ at mid-point.+--+-- > import Sound.SC3.Plot+--+-- > let f = bezier4_y_mt 0.0001 (Pt 0 0) (Pt 0.1 0.3) (Pt 0.5 0.2) (Pt 1 0.5)+-- > plotTable1 (map (snd . f) [0.0,0.01 .. 1.0])+--+-- > let f = bezier4_y_mt 0.0001 (Pt 0 0) (Pt 0.4 1.3) (Pt 0.6 1.3) (Pt 1 0)+-- > plotTable1 (map (snd . f) [0.0,0.01 .. 1.0])+--+-- > let f = bezier4_y_mt 0.0001 (Pt 1 0) (Pt 1.4 1.3) (Pt 1.6 1.3) (Pt 2 0)+-- > plotTable1 (map (snd . f) [1.0,1.01 .. 2.0])+bezier4_y_mt :: (Ord a, Fractional a) => a -> Pt a -> Pt a -> Pt a -> Pt a -> a -> (a, a)+bezier4_y_mt dx p0 c1 c2 p3 x =+ let x0 = pt_x p0+ x3 = pt_x p3+ mu = x0 + ((x3 - x0) / 2)+ in bezier4_y_mt' dx p0 c1 c2 p3 mu x++-- | Variant that scans a list [p0,c1,c2,p3,c4,c5,p6...] to resolve /x/.+bezier4_seq_y' :: (Ord a, Fractional a) => a -> [Pt a] -> a -> Maybe (a,a)+bezier4_seq_y' dx pt_l x =+ case pt_l of+ p0:c1:c2:p3:pt_l' -> if x >= pt_x p0 && x <= pt_x p3+ then Just (bezier4_y_mt dx p0 c1 c2 p3 x)+ else bezier4_seq_y' dx (p3 : pt_l') x+ _ -> Nothing++-- | Variant giving only /y/ and zero for out of range /x/.+bezier4_seq_y0 :: (Ord a, Fractional a) => a -> [Pt a] -> a -> a+bezier4_seq_y0 dx pt = maybe 0 snd . bezier4_seq_y' dx pt++-- | Variant to generate a /wavetable/, ie. /n/ equally spaced /x/ across range of /pt/.+--+-- > let pt = [Pt 0 0,Pt 0.4 (-1.3),Pt 0.6 (-1.3),Pt 1 0,Pt 1.4 1.3,Pt 1.6 1.3,Pt 2 0]+-- > plotTable1 (bezier4_seq_wt 1e-4 pt 1024)+bezier4_seq_wt :: (Ord a, Integral i, Fractional a, Enum a) => a -> [Pt a] -> i -> [a]+bezier4_seq_wt dx pt n =+ let l = pt_x (head pt)+ r = pt_x (last pt)+ l' = l + ((r - l) / fromIntegral n)+ ix = [l,l' .. r]+ in map (bezier4_seq_y0 dx pt) ix
Data/CG/Minus/Colour.hs view
@@ -1,259 +1,84 @@ -- | Colour related functions module Data.CG.Minus.Colour where -import Data.Colour {- colour -}-import qualified Data.Colour.SRGB as S {- colour -}-import qualified Data.Colour.Names as N {- colour -}---- | Opaque colour.-type C = Colour Double---- | Colour with /alpha/ channel.-type Ca = AlphaColour Double+import Data.Bits {- base -}+import qualified Data.Colour as C {- colour -}+import qualified Data.Colour.SRGB as SRGB {- colour -}+import qualified Data.Colour.RGBSpace.HSL as HSL {- colour -} -- | Grey 'Colour'.-mk_grey :: (Ord a,Floating a) => a -> Colour a-mk_grey x = S.sRGB x x x+mk_grey :: (Ord a,Floating a) => a -> C.Colour a+mk_grey x = SRGB.sRGB x x x -- | Reduce 'Colour' to grey. Constants are @0.3@, @0.59@ and @0.11@.-to_greyscale :: (Ord a,Floating a) => Colour a -> a+to_greyscale :: (Ord a,Floating a) => C.Colour a -> a to_greyscale c =- let (S.RGB r g b) = S.toSRGB c+ let (SRGB.RGB r g b) = SRGB.toSRGB c in r * 0.3 + g * 0.59 + b * 0.11 -- | 'mk_grey' '.' 'to_greyscale'.-to_greyscale_c :: (Ord a,Floating a) => Colour a -> Colour a+to_greyscale_c :: (Ord a,Floating a) => C.Colour a -> C.Colour a to_greyscale_c = mk_grey . to_greyscale -- | Discard /alpha/ channel, if possible.-pureColour :: (Ord a, Fractional a) => AlphaColour a -> Colour a+pureColour :: (Ord a, Fractional a) => C.AlphaColour a -> C.Colour a pureColour c =- let a = alphaChannel c+ let a = C.alphaChannel c in if a > 0- then darken (recip a) (c `over` black)- else error "transparent has no pure colour"+ then C.darken (recip a) (c `C.over` C.black)+ else error "hcg-: transparent has no pure colour" -- * Tuples --- | Tuple to 'C', inverse of 'unC'.-toC :: (Double,Double,Double) -> C-toC (r,g,b) = S.sRGB r g b---- | 'C' to /(red,green,blue)/ tuple.-unC :: C -> (Double,Double,Double)-unC x =- let x' = S.toSRGB x- in (S.channelRed x',S.channelGreen x',S.channelBlue x')---- | Tuple to 'Ca', inverse of 'unCa'.-toCa :: (Double,Double,Double,Double) -> Ca-toCa (r,g,b,a) = toC (r,g,b) `withOpacity` a---- | 'Ca' to /(red,green,blue,alpha)/ tuple-unCa :: Ca -> (Double,Double,Double,Double)-unCa x =- let x' = S.toSRGB (pureColour x)- in (S.channelRed x'- ,S.channelGreen x'- ,S.channelBlue x'- ,alphaChannel x)+-- > hex_to_rgb24 0xC80815 == (0xC8,0x08,0x15)+hex_to_rgb24 :: (Bits t, Num t) => t -> (t,t,t)+hex_to_rgb24 n = (shiftR (n .&. 0xFF0000) 16,shiftR (n .&. 0x00FF00) 8,n .&. 0x0000FF) --- * Constants+srgb_components :: SRGB.RGB t -> (t,t,t)+srgb_components c = (SRGB.channelRed c,SRGB.channelGreen c,SRGB.channelBlue c) --- | Venetian red (@#c80815@).-venetianRed :: C-venetianRed = S.sRGB24read "#c80815"+-- | 'C' to /(red,green,blue)/ tuple.+c_to_rgb :: (Ord t,Floating t) => C.Colour t -> (t,t,t)+c_to_rgb = srgb_components . SRGB.toSRGB --- | Swedish azure blue (@#005b99@).-swedishAzureBlue :: C-swedishAzureBlue = S.sRGB24read "#005b99"+-- | Tuple to 'C', inverse of 'c_to_rgb'.+rgb_to_c :: (Ord t,Floating t) => (t,t,t) -> C.Colour t+rgb_to_c (r,g,b) = SRGB.sRGB r g b --- | Safety orange (@#ff6600@).-safetyOrange :: C-safetyOrange = S.sRGB24read "#ff6600"+-- > rgb24_to_c ((0xC8,0x08,0x15) :: (Int,Int,Int))+rgb24_to_c :: (Real r,Ord t,Floating t) => (r, r, r) -> C.Colour t+rgb24_to_c (r,g,b) = rgb_to_c (realToFrac r / 255,realToFrac g / 255,realToFrac b / 255) --- | Dye magenta (@#ca1f7b@).-dyeMagenta :: C-dyeMagenta = S.sRGB24read "#ca1f7b"+c_to_hsl :: (Ord t,Floating t) => C.Colour t -> (t,t,t)+c_to_hsl c = HSL.hslView (SRGB.toSRGB c) --- | Candlelight yellow (@#fcd116@).-candlelightYellow :: C-candlelightYellow = S.sRGB24read "#fcd116"+hsl_to_c :: (RealFrac t,Floating t) => (t,t,t) -> C.Colour t+hsl_to_c (h,s,l) = rgb_to_c (srgb_components (HSL.hsl h s l)) --- | Subtractive primary cyan (@#00B7EB@).-subtractivePrimaryCyan :: C-subtractivePrimaryCyan = S.sRGB24read "#00B7EB"+-- > rgb_to_hsl (1,0,0) == (0,1,0.5)+rgb_to_hsl :: (Ord t,Floating t) => (t,t,t) -> (t,t,t)+rgb_to_hsl = c_to_hsl . rgb_to_c --- | Fern green (@#009246@).-fernGreen :: C-fernGreen = S.sRGB24read "#009246"+-- > hsl_to_rgb (0,1,0.5) == (1,0,0)+hsl_to_rgb :: (RealFrac t,Floating t) => (t,t,t) -> (t,t,t)+hsl_to_rgb = c_to_rgb . hsl_to_c --- | Sepia brown (@#704214@).-sepiaBrown :: C-sepiaBrown = S.sRGB24read "#704214"+-- | Tuple to 'Ca', inverse of 'c_to_rgba'.+rgba_to_ca :: (Ord t,Floating t) => (t,t,t,t) -> C.AlphaColour t+rgba_to_ca (r,g,b,a) = rgb_to_c (r,g,b) `C.withOpacity` a --- | The set of named colours defined in this module.-non_svg_colour_set :: [C]-non_svg_colour_set =- [venetianRed- ,swedishAzureBlue- ,safetyOrange- ,dyeMagenta- ,candlelightYellow- ,subtractivePrimaryCyan- ,fernGreen- ,sepiaBrown]+rgb_to_ca :: (Ord t,Floating t) => (t,t,t) -> C.AlphaColour t+rgb_to_ca (r,g,b) = rgb_to_c (r,g,b) `C.withOpacity` 1 --- * SVG colours+-- | 'Ca' to /(red,green,blue,alpha)/ tuple+ca_to_rgba :: (Ord t,Floating t) => C.AlphaColour t -> (t,t,t,t)+ca_to_rgba x =+ let x' = SRGB.toSRGB (pureColour x)+ in (SRGB.channelRed x'+ ,SRGB.channelGreen x'+ ,SRGB.channelBlue x'+ ,C.alphaChannel x) --- | The set of named colours in the @SVG@ specification (in--- alphabetical order).-svg_colour_set :: [C]-svg_colour_set =- [N.aliceblue- ,N.antiquewhite- ,N.aqua- ,N.aquamarine- ,N.azure- ,N.beige- ,N.bisque- ,N.black- ,N.blanchedalmond- ,N.blue- ,N.blueviolet- ,N.brown- ,N.burlywood- ,N.cadetblue- ,N.chartreuse- ,N.chocolate- ,N.coral- ,N.cornflowerblue- ,N.cornsilk- ,N.crimson- ,N.cyan- ,N.darkblue- ,N.darkcyan- ,N.darkgoldenrod- ,N.darkgray- ,N.darkgreen- ,N.darkgrey- ,N.darkkhaki- ,N.darkmagenta- ,N.darkolivegreen- ,N.darkorange- ,N.darkorchid- ,N.darkred- ,N.darksalmon- ,N.darkseagreen- ,N.darkslateblue- ,N.darkslategray- ,N.darkslategrey- ,N.darkturquoise- ,N.darkviolet- ,N.deeppink- ,N.deepskyblue- ,N.dimgray- ,N.dimgrey- ,N.dodgerblue- ,N.firebrick- ,N.floralwhite- ,N.forestgreen- ,N.fuchsia- ,N.gainsboro- ,N.ghostwhite- ,N.gold- ,N.goldenrod- ,N.gray- ,N.grey- ,N.green- ,N.greenyellow- ,N.honeydew- ,N.hotpink- ,N.indianred- ,N.indigo- ,N.ivory- ,N.khaki- ,N.lavender- ,N.lavenderblush- ,N.lawngreen- ,N.lemonchiffon- ,N.lightblue- ,N.lightcoral- ,N.lightcyan- ,N.lightgoldenrodyellow- ,N.lightgray- ,N.lightgreen- ,N.lightgrey- ,N.lightpink- ,N.lightsalmon- ,N.lightseagreen- ,N.lightskyblue- ,N.lightslategray- ,N.lightslategrey- ,N.lightsteelblue- ,N.lightyellow- ,N.lime- ,N.limegreen- ,N.linen- ,N.magenta- ,N.maroon- ,N.mediumaquamarine- ,N.mediumblue- ,N.mediumorchid- ,N.mediumpurple- ,N.mediumseagreen- ,N.mediumslateblue- ,N.mediumspringgreen- ,N.mediumturquoise- ,N.mediumvioletred- ,N.midnightblue- ,N.mintcream- ,N.mistyrose- ,N.moccasin- ,N.navajowhite- ,N.navy- ,N.oldlace- ,N.olive- ,N.olivedrab- ,N.orange- ,N.orangered- ,N.orchid- ,N.palegoldenrod- ,N.palegreen- ,N.paleturquoise- ,N.palevioletred- ,N.papayawhip- ,N.peachpuff- ,N.peru- ,N.pink- ,N.plum- ,N.powderblue- ,N.purple- ,N.red- ,N.rosybrown- ,N.royalblue- ,N.saddlebrown- ,N.salmon- ,N.sandybrown- ,N.seagreen- ,N.seashell- ,N.sienna- ,N.silver- ,N.skyblue- ,N.slateblue- ,N.slategray- ,N.slategrey- ,N.snow- ,N.springgreen- ,N.steelblue- ,N.tan- ,N.teal- ,N.thistle- ,N.tomato- ,N.turquoise- ,N.violet- ,N.wheat- ,N.white- ,N.whitesmoke- ,N.yellow- ,N.yellowgreen]+-- | Is the /alpha/ channel zero.+ca_is_transparent :: (Ord t, Num t) => C.AlphaColour t -> Bool+ca_is_transparent x = not (C.alphaChannel x > 0)
+ Data/CG/Minus/Colour/Crayola.hs view
@@ -0,0 +1,181 @@+-- | <https://en.wikipedia.org/wiki/List_of_Crayola_crayon_colors>+module Data.CG.Minus.Colour.Crayola where++import qualified Data.Colour.SRGB as S {- colour -}++crayola_colour_table :: [(String,String)]+crayola_colour_table =+ [("Red","#ED0A3F")+ ,("Maroon","#C32148")+ ,("Scarlet","#FD0E35")+ ,("Brick Red","#C62D42")+ ,("English Vermilion","#CC474B")+ ,("Madder Lake","#CC3336")+ ,("Permanent Geranium Lake","#E12C2C")+ ,("Maximum Red","#D92121")+ ,("Indian Red","#B94E48")+ ,("Orange-Red","#FF5349")+ ,("Sunset Orange","#FE4C40")+ ,("Bittersweet","#FE6F5E")+ ,("Dark Venetian Red","#B33B24")+ ,("Venetian Red","#CC553D")+ ,("Light Venetian Red","#E6735C")+ ,("Vivid Tangerine","#FF9980")+ ,("Middle Red","#E58E73")+ ,("Burnt Orange","#FF7F49")+ ,("Red-Orange","#FF681F")+ ,("Orange","#FF8833")+ ,("Macaroni and Cheese","#FFB97B")+ ,("Middle Yellow Red","#ECB176")+ ,("Mango Tango","#E77200")+ ,("Yellow-Orange","#FFAE42")+ ,("Maximum Yellow Red","#F2BA49")+ ,("Banana Mania","#FBE7B2")+ ,("Maize","#F2C649")+ ,("Orange-Yellow","#F8D568")+ ,("Goldenrod","#FCD667")+ ,("Dandelion","#FED85D")+ ,("Yellow","#FBE870")+ ,("Green-Yellow","#F1E788")+ ,("Middle Yellow","#FFEB00")+ ,("Olive Green","#B5B35C")+ ,("Spring Green","#ECEBBD")+ ,("Maximum Yellow","#FAFA37")+ ,("Canary","#FFFF99")+ ,("Lemon Yellow","#FFFF9F")+ ,("Maximum Green Yellow","#D9E650")+ ,("Middle Green Yellow","#ACBF60")+ ,("Inchworm","#AFE313")+ ,("Light Chrome Green","#BEE64B")+ ,("Yellow-Green","#C5E17A")+ ,("Maximum Green","#5E8C31")+ ,("Asparagus","#7BA05B")+ ,("Granny Smith Apple","#9DE093")+ ,("Fern","#63B76C")+ ,("Middle Green","#4D8C57")+ ,("Green","#3AA655")+ ,("Medium Chrome Green","#6CA67C")+ ,("Forest Green","#5FA777")+ ,("Sea Green","#93DFB8")+ ,("Shamrock","#33CC99")+ ,("Mountain Meadow","#1AB385")+ ,("Jungle Green","#29AB87")+ ,("Caribbean Green","#00CC99")+ ,("Tropical Rain Forest","#00755E")+ ,("Middle Blue Green","#8DD9CC")+ ,("Pine Green","#01786F")+ ,("Maximum Blue Green","#30BFBF")+ ,("Robin's Egg Blue","#00CCCC")+ ,("Teal Blue","#008080")+ ,("Light Blue","#8FD8D8")+ ,("Aquamarine","#95E0E8")+ ,("Turquoise Blue","#6CDAE7")+ ,("Outer Space","#2D383A")+ ,("Sky Blue","#76D7EA")+ ,("Middle Blue","#7ED4E6")+ ,("Blue-Green","#0095B7")+ ,("Pacific Blue","#009DC4")+ ,("Cerulean","#02A4D3")+ ,("Maximum Blue","#47ABCC")+ ,("Blue (I)","#4997D0")+ ,("Cerulean Blue","#339ACC")+ ,("Cornflower","#93CCEA")+ ,("Green-Blue","#2887C8")+ ,("Midnight Blue","#00468C")+ ,("Navy Blue","#0066CC")+ ,("Denim","#1560BD")+ ,("Blue (III)","#0066FF")+ ,("Cadet Blue","#A9B2C3")+ ,("Periwinkle","#C3CDE6")+ ,("Blue (II)","#4570E6")+ ,("Wild Blue Yonder","#7A89B8")+ ,("Indigo","#4F69C6")+ ,("Manatee","#8D90A1")+ ,("Cobalt Blue","#8C90C8")+ ,("Celestial Blue","#7070CC")+ ,("Blue Bell","#9999CC")+ ,("Maximum Blue Purple","#ACACE6")+ ,("Violet-Blue","#766EC8")+ ,("Blue-Violet","#6456B7")+ ,("Ultramarine Blue","#3F26BF")+ ,("Middle Blue Purple","#8B72BE")+ ,("Purple Heart","#652DC1")+ ,("Royal Purple","#6B3FA0")+ ,("Violet (II)","#8359A3")+ ,("Medium Violet","#8F47B3")+ ,("Wisteria","#C9A0DC")+ ,("Lavender (I)","#BF8FCC")+ ,("Vivid Violet","#803790")+ ,("Maximum Purple","#733380")+ ,("Purple Mountains' Majesty","#D6AEDD")+ ,("Fuchsia","#C154C1")+ ,("Pink Flamingo","#FC74FD")+ ,("Violet (I)","#732E6C")+ ,("Brilliant Rose","#E667CE")+ ,("Orchid","#E29CD2")+ ,("Plum","#8E3179")+ ,("Medium Rose","#D96CBE")+ ,("Thistle","#EBB0D7")+ ,("Mulberry","#C8509B")+ ,("Red-Violet","#BB3385")+ ,("Middle Purple","#D982B5")+ ,("Maximum Red Purple","#A63A79")+ ,("Jazzberry Jam","#A50B5E")+ ,("Eggplant","#614051")+ ,("Magenta","#F653A6")+ ,("Cerise","#DA3287")+ ,("Wild Strawberry","#FF3399")+ ,("Lavender (II)","#FBAED2")+ ,("Cotton Candy","#FFB7D5")+ ,("Carnation Pink","#FFA6C9")+ ,("Violet-Red","#F7468A")+ ,("Razzmatazz","#E30B5C")+ ,("Pig Pink","#FDD7E4")+ ,("Carmine","#E62E6B")+ ,("Blush","#DB5079")+ ,("Tickle Me Pink","#FC80A5")+ ,("Mauvelous","#F091A9")+ ,("Salmon","#FF91A4")+ ,("Middle Red Purple","#A55353")+ ,("Mahogany","#CA3435")+ ,("Melon","#FEBAAD")+ ,("Pink Sherbert","#F7A38E")+ ,("Burnt Sienna","#E97451")+ ,("Brown","#AF593E")+ ,("Sepia","#9E5B40")+ ,("Fuzzy Wuzzy","#87421F")+ ,("Beaver","#926F5B")+ ,("Tumbleweed","#DEA681")+ ,("Raw Sienna","#D27D46")+ ,("Van Dyke Brown","#664228")+ ,("Tan","#D99A6C")+ ,("Desert Sand","#EDC9AF")+ ,("Peach","#FFCBA4")+ ,("Burnt Umber","#805533")+ ,("Apricot","#FDD5B1")+ ,("Almond","#EED9C4")+ ,("Raw Umber","#665233")+ ,("Shadow","#837050")+ ,("Raw Sienna (I)","#E6BC5C")+ ,("Timberwolf","#D9D6CF")+ ,("Gold (I)","#92926E")+ ,("Gold (II)","#E6BE8A")+ ,("Silver","#C9C0BB")+ ,("Copper","#DA8A67")+ ,("Antique Brass","#C88A65")+ ,("Black","#000000")+ ,("Charcoal Gray","#736A62")+ ,("Gray","#8B8680")+ ,("Blue-Gray","#C8C8CD")+ ,("White","#FFFFFF")++ ,("Green-Blue","#1164B4")+ ,("Blue-Green","#0D98BA")++ ]++crayola_colour_table_srgb :: [(String, S.Colour Double)]+crayola_colour_table_srgb =+ let f (nm,hx) = (nm,S.sRGB24read hx)+ in map f crayola_colour_table+
+ Data/CG/Minus/Colour/Grey.hs view
@@ -0,0 +1,66 @@+-- | RGB to greyscale conversion functions.+module Data.CG.Minus.Colour.Grey where++-- | (R,G,B) triple.+type RGB a = (a,a,a)++-- | Grey luminance.+type GREY a = a++-- | Apply binary function at triple, leftmost first.+f2_t3_left :: (t -> t -> t) -> (t,t,t) -> t+f2_t3_left f (p,q,r) = f (f p q) r++-- | Triple variant of 'min'.+min3 :: Ord t => (t,t,t) -> t+min3 = f2_t3_left min++-- | Triple variant of 'max'.+max3 :: Ord t => (t,t,t) -> t+max3 = f2_t3_left max++-- | Desaturation.+rgb_to_gs_lightness :: (Fractional a, Ord a) => RGB a -> GREY a+rgb_to_gs_lightness c = (min3 c + max3 c) / 2++-- | Simple average.+rgb_to_gs_average :: Fractional a => RGB a -> GREY a+rgb_to_gs_average (r,g,b) = (r + g + b) / 3++-- | Luminosity coefficents, ie. (R,G,B) multipliers.+type COEF a = (a,a,a)++rgb_to_gs_luminosity :: Num a => COEF a -> RGB a -> GREY a+rgb_to_gs_luminosity (rm,gm,bm) (r,g,b) = r * rm + g * gm + b * bm++luminosity_coef_rec_709 :: Fractional a => COEF a+luminosity_coef_rec_709 = (0.2126,0.7152,0.0722)++luminosity_coef_rec_601 :: Fractional a => COEF a+luminosity_coef_rec_601 = (0.299,0.587,0.114)++luminosity_coef_smpte_240m :: Fractional a => COEF a+luminosity_coef_smpte_240m = (0.212,0.701,0.087)++rgb_to_gs_decompose_min :: Ord a => RGB a -> GREY a+rgb_to_gs_decompose_min = f2_t3_left min++rgb_to_gs_decompose_max :: Ord a => RGB a -> GREY a+rgb_to_gs_decompose_max = f2_t3_left max++rgb_to_gs_r :: RGB t -> GREY t+rgb_to_gs_r (r,_,_) = r++rgb_to_gs_g :: RGB t -> GREY t+rgb_to_gs_g (_,g,_) = g++rgb_to_gs_b :: RGB t -> GREY t+rgb_to_gs_b (_,_,b) = b++-- | Requires R and G and B components to be equal.+rgb_to_gs_eq :: Eq a => RGB a -> Maybe (GREY a)+rgb_to_gs_eq (r,g,b) = if r == g && r == b then Just r else Nothing++-- | 'error'ing variant.+rgb_to_gs_eq' :: Eq a => RGB a -> GREY a+rgb_to_gs_eq' = maybe (error "rgb_to_gs_eq: not equal") id . rgb_to_gs_eq
+ Data/CG/Minus/Colour/NCS.hs view
@@ -0,0 +1,25 @@+-- | Natural Color System+module Data.CG.Minus.Colour.NCS where++import qualified Data.Colour as C {- colour -}++import Data.CG.Minus.Colour {- hcg-minus -}++ncs_table :: Num n => [(String,n,n,n,n)]+ncs_table =+ [("White",0xFFFFFF,255,255,255)+ ,("Black",0x000000,0,0,0)+ ,("Green",0x009F6B,0,159,107) -- 0x00A368+ ,("Red",0xC40233,196,2,51)+ ,("Yellow",0xFFD300,255,211,0)+ ,("Blue",0x0087BD,0,135,189) -- 0x0088BF+ ]++ncs_colour :: (Int,Int,Int) -> C.Colour Double+ncs_colour = rgb24_to_c++ncs_red,ncs_green,ncs_yellow,ncs_blue :: C.Colour Double+ncs_red = ncs_colour (196,2,51)+ncs_green = ncs_colour (0,159,107)+ncs_yellow = ncs_colour (255,211,0)+ncs_blue = ncs_colour (0,135,189)
+ Data/CG/Minus/Colour/Names.hs view
@@ -0,0 +1,38 @@+-- | Colour names, non-specific.+module Data.CG.Minus.Colour.Names where++import Data.Maybe {- base -}++import qualified Data.Colour as C {- colour -}++import Data.CG.Minus.Colour {- hcg-minus -}++hex_to_c :: Int -> C.Colour Double+hex_to_c = rgb24_to_c . hex_to_rgb24++colour_tbl :: [(String,C.Colour Double)]+colour_tbl =+ let f (_,nm,hex) = (nm,hex_to_c hex)+ in map f colour_names_table++-- > map colour_lookup_err ["Cerulean","Fern green","Candlelight yellow"]+colour_lookup_err :: String -> C.Colour Double+colour_lookup_err = fromMaybe (error "colour_lookup") . flip lookup colour_tbl++-- > map (\(_,_,n) -> hex_to_rgb24 n) colour_names_table+colour_names_table :: Num n => [(String,String,n)]+colour_names_table =+ [("red","Venetian red",0xC80815)+ ,("blue","Swedish azure blue",0x005B99)+ ,("orange","Safety orange",0xFF6600)+ ,("magenta","Dye magenta",0xCA1F7B)+ ,("magenta","Process magenta",0xFF0090)+ ,("yellow","Candlelight yellow",0xFCD116)+ ,("cyan","Cyan additive secondary",0x00FFFF)+ ,("cyan","Cyan subtractive primary",0x00B7EB)+ ,("green","Fern green",0x009246)+ ,("brown","Sepia brown",0x704214)+ ,("green","Verdigris",0x43B3AE)+ ,("cyan","Viridian",0x40826D)+ ,("cyan","Cerulean",0x007BA7)+ ]
Data/CG/Minus/Colour/Planck.hs view
@@ -1,7 +1,8 @@ -- | Planck radiation equation. module Data.CG.Minus.Colour.Planck where -import Data.CG.Minus.Colour+import qualified Data.Colour as C {- colour -}+import qualified Data.CG.Minus.Colour as CG {- hcg-minus -} -- | Given wavelength (in microns) and temperature (in degrees Kelvin) -- solve Planck's radiation equation.@@ -36,5 +37,5 @@ in (r * s,g * s,b * s) -- | 'toC' '.' 'k_to_rgb'.-k_to_colour :: Double -> C-k_to_colour = toC . k_to_rgb+k_to_colour :: Double -> C.Colour Double+k_to_colour = CG.rgb_to_c . k_to_rgb
+ Data/CG/Minus/Colour/RAL.hs view
@@ -0,0 +1,236 @@+-- | ReichsAusschuss für Lieferbedingungen (1927)+module Data.CG.Minus.Colour.RAL where++import Data.List {- base -}++import qualified Data.Colour as C {- colour -}+import qualified Data.Colour.CIE as C {- colour -}+import qualified Data.Colour.CIE.Illuminant as I {- colour -}+import qualified Data.Colour.SRGB as SRGB {- colour -}++ral_colour_data :: Fractional n => [(Int,n,n,n,String)]+ral_colour_data =+ [(1000,76.02,-0.37,27.64,"Green beige")+ ,(1001,74.99,5.1,24.64,"Beige")+ ,(1002,73.45,6.83,33.8,"Sand yellow")+ ,(1003,75.99,18.8,72.93,"Signal yellow")+ ,(1004,71.42,15.28,69.28,"Golden yellow")+ ,(1005,65.65,12.3,61.9,"Honey yellow")+ ,(1006,68.2,21.13,65.98,"Maize yellow")+ ,(1007,68.38,25.44,67.13,"Daffodil yellow")+ ,(1011,59.92,11.35,29.17,"Brown beige")+ ,(1012,75.04,4.64,61.31,"Lemon yellow")+ ,(1013,88.13,0.19,9.67,"Oyster white")+ ,(1014,81.22,2.47,22.88,"Ivory")+ ,(1015,86.4,2.06,15.48,"Light ivory")+ ,(1016,88.37,-9.78,71.3,"Sulfur yellow")+ ,(1017,76.32,19.37,51.02,"Saffron yellow")+ ,(1018,84.83,3.05,69.19,"Zinc yellow")+ ,(1019,62.62,4.31,12.94,"Grey beige")+ ,(1020,61.98,0.39,23.18,"Olive yellow")+ ,(1021,78.88,10.03,82.04,"Rape yellow")+ ,(1023,79.07,10.46,80.5,"Traffic yellow")+ ,(1024,64.2,7.95,36.66,"Ochre yellow")+ ,(1026,95.36,-21.56,120.18,"Luminous yellow")+ ,(1027,58.15,5.83,47.68,"Curry")+ ,(1028,74.97,29.64,79.69,"Melon yellow")+ ,(1032,72.32,12.16,66.97,"Broom yellow")+ ,(1033,73.2,26.5,63.47,"Dahlia yellow")+ ,(1034,72.73,21.4,45.09,"Pastel yellow")+ ,(1035,54.79,0.35,11.86,"Pearl beige")+ ,(1036,48.95,4.77,26.69,"Pearl gold")+ ,(1037,70.28,26.19,64.79,"Sun yellow")+ ,(2000,60.35,34.64,54.65,"Yellow orange")+ ,(2001,49.41,39.79,35.29,"Red orange")+ ,(2002,47.74,47.87,33.73,"Vermillion")+ ,(2003,66.02,41.22,52.36,"Pastel orange")+ ,(2004,56.89,50.34,49.81,"Pure orange")+ ,(2005,62.26,87.83,94.26,"Luminous orange")+ ,(2007,76.86,47.87,97.63,"Luminous bright orange")+ ,(2008,61.99,44.64,51.72,"Bright red orange")+ ,(2009,55.83,47.79,48.83,"Traffic orange")+ ,(2010,55.39,40.1,42.42,"Signal orange")+ ,(2011,61.76,38.16,52.39,"Deep orange")+ ,(2012,57.75,40.28,30.66,"Salmon orange")+ ,(2013,40.73,32.14,34.92,"Pearl orange")+ ,(3000,42.4,43.24,25,"Flame red")+ ,(3001,40.19,41.21,21.6,"Signal red")+ ,(3002,39.82,41.84,22.04,"Carmine red")+ ,(3003,35.59,35.87,15.75,"Ruby red")+ ,(3004,33.05,25.61,9.02,"Purple red")+ ,(3005,30.96,18.46,5.76,"Wine red")+ ,(3007,28.34,8.14,2.22,"Black red")+ ,(3009,35.05,19.93,11.53,"Oxide red")+ ,(3011,34.52,28.66,13.44,"Brown red")+ ,(3012,63.81,20.79,20.45,"Beige red")+ ,(3013,40.7,36.67,21.37,"Tomato red")+ ,(3014,60.17,32.49,12.58,"Antique pink")+ ,(3015,72.73,20.48,3.96,"Light pink")+ ,(3016,44.7,37.92,23.96,"Coral red")+ ,(3017,54.24,44.26,16.87,"Rose")+ ,(3018,50.77,49.15,19.86,"Strawberry red")+ ,(3020,44.66,52.03,32.26,"Traffic red")+ ,(3022,58.1,36.44,27.34,"Salmon pink")+ ,(3024,51.32,82.52,71.62,"Luminous red")+ ,(3026,54.38,86.26,76.07,"Luminous bright red")+ ,(3027,43.07,46.96,15.81,"Raspberry red")+ ,(3028,48.8,54.42,33.08,"Pure red")+ ,(3031,43.87,41.37,18.33,"Orient red")+ ,(3032,26.88,41.34,19.4,"Pearl ruby red")+ ,(3033,44.29,45.11,28.62,"Pearl pink")+ ,(4001,49.1,17.35,-12.85,"Red lilac")+ ,(4002,41.91,30.05,5.67,"Red violet")+ ,(4003,56.81,40.89,-5.53,"Heather violet")+ ,(4004,32.22,24.83,0.06,"Claret violet")+ ,(4005,50.92,15.38,-23.06,"Blue lilac")+ ,(4006,42.38,39.48,-14.94,"Traffic purple")+ ,(4007,30.05,13.16,-5.1,"Purple violet")+ ,(4008,44.82,29.08,-18.58,"Signal violet")+ ,(4009,60.59,10.38,-2.88,"Pastel violet")+ ,(4010,50.39,48.95,-4.24,"Telemagenta")+ ,(4011,47.92,18.89,-20.83,"Pearl violet")+ ,(4012,46.33,7.27,-11.94,"Pearl blackberry")+ ,(5000,38.3,1.9,-19.45,"Violet blue")+ ,(5001,35.43,-7.52,-16.65,"Green blue")+ ,(5002,33.11,8.43,-35.4,"Ultramarine blue")+ ,(5003,30.53,-0.37,-16.68,"Sapphire blue")+ ,(5004,26.56,-0.19,-4.07,"Black blue")+ ,(5005,38.35,-5.03,-32.56,"Signal blue")+ ,(5007,46.37,-6.24,-21.71,"Brilliant blue")+ ,(5008,32,-2.09,-6.07,"Grey blue")+ ,(5009,41.22,-9.56,-18.34,"Azure blue")+ ,(5010,36.57,-5.81,-28.94,"Gentian blue")+ ,(5011,28.21,-1.11,-8.72,"Steel blue")+ ,(5012,55.62,-13.84,-30.72,"Light blue")+ ,(5013,29.81,1.67,-17.2,"Cobalt blue")+ ,(5014,53.79,-2.64,-15.59,"Pigeon blue")+ ,(5015,51.13,-12.69,-34.21,"Sky blue")+ ,(5017,40.4,-10.67,-32,"Traffic blue")+ ,(5018,55.13,-27.27,-8.47,"Turquoise blue")+ ,(5019,41.18,-9.97,-25.87,"Capri blue")+ ,(5020,32.3,-13.01,-9.39,"Ocean blue")+ ,(5021,47.15,-29.26,-9.32,"Water blue")+ ,(5022,29.61,7.97,-21.5,"Night blue")+ ,(5023,47.64,-2.96,-21.18,"Distant blue")+ ,(5024,60.5,-9.53,-17.38,"Pastel blue")+ ,(5025,35.93,-11.81,-16.28,"Pearl Gentian blue")+ ,(5026,16,7.84,-29.1,"Pearl night blue")+ ,(6000,48.7,-20.58,4.64,"Patina green")+ ,(6001,43.86,-23.57,18.31,"Emerald green")+ ,(6002,39.87,-19.39,16.95,"Leaf green")+ ,(6003,39.25,-4.36,10.17,"Olive green")+ ,(6004,33.4,-13.17,-3.07,"Blue green")+ ,(6005,32.26,-13.69,2.85,"Moss green")+ ,(6006,33.04,-1.11,4.17,"Grey olive")+ ,(6007,30.42,-3.85,4.77,"Bottle green")+ ,(6008,29.82,-0.67,4.34,"Brown green")+ ,(6009,29.81,-5.74,3.12,"Fir green")+ ,(6010,46.05,-20.46,22.24,"Grass green")+ ,(6011,53.24,-11.61,14.48,"Reseda green")+ ,(6012,31.94,-4.36,-0.46,"Black green")+ ,(6013,52.3,-2.08,14.26,"Reed green")+ ,(6014,33.84,0.46,6.15,"Yellow olive")+ ,(6015,31.93,-1.44,2.99,"Black olive")+ ,(6016,42.92,-32.22,6.72,"Turquoise green")+ ,(6017,52.33,-23.24,26.15,"May green")+ ,(6018,59.83,-32.96,37.72,"Yellow green")+ ,(6019,81.42,-12.57,13.5,"Pastel green")+ ,(6020,34.77,-5.82,6.23,"Chrome green")+ ,(6021,63.69,-11.28,14.13,"Pale green")+ ,(6022,30.43,0.54,5.62,"Brown olive")+ ,(6024,51.81,-38.02,15.5,"Traffic green")+ ,(6025,47.45,-13.45,21.37,"Fern green")+ ,(6026,39.25,-29.43,0.67,"Opal green")+ ,(6027,72.8,-19.82,-3.62,"Light green")+ ,(6028,38.15,-12.86,3.82,"Pine green")+ ,(6029,44.18,-39.06,15.73,"Mint green")+ ,(6032,50.67,-33.25,14.76,"Signal green")+ ,(6033,54.93,-20.4,-2.06,"Mint turquoise")+ ,(6034,69.16,-15.95,-5.1,"Pastel turquoise")+ ,(6035,29.14,-29.19,16.35,"Pearl green")+ ,(6036,33.97,-29.04,0.68,"Pearl opal green")+ ,(6037,53.49,-46.77,34.32,"Pure green")+ ,(6038,63.64,-80.23,54,"Luminous green")+ ,(7000,58.32,-3.14,-4.71,"Squirrel grey")+ ,(7001,63.81,-2.22,-4.05,"Silver grey")+ ,(7002,54.51,-0.09,10.69,"Olive grey")+ ,(7003,52.32,-1.18,6.92,"Moss grey")+ ,(7004,65.77,0.2,-0.81,"Signal grey")+ ,(7005,50,-1.55,0.82,"Mouse grey")+ ,(7006,48.53,2.15,7.57,"Beige grey")+ ,(7008,45.91,3.34,17.92,"Khaki grey")+ ,(7009,43.19,-2.43,3.87,"Green grey")+ ,(7010,42.69,-2.09,2.04,"Tarpaulin grey")+ ,(7011,41.52,-1.68,-2.72,"Iron grey")+ ,(7012,44.34,-1.77,-1.71,"Basalt grey")+ ,(7013,39.21,0.59,6.33,"Brown-grey")+ ,(7015,40.5,-0.25,-3.4,"Slate grey")+ ,(7016,33.84,-1.33,-2.83,"Anthracite grey")+ ,(7021,30.65,-0.43,-1.22,"Black grey")+ ,(7022,37.75,-0.07,2.23,"Umbra grey")+ ,(7023,55.6,-1.45,4.52,"Concrete grey")+ ,(7024,36.97,-0.13,-3.32,"Graphite grey")+ ,(7026,34.71,-3.02,-2.48,"Granite grey")+ ,(7030,61.31,-0.26,4.53,"Stone grey")+ ,(7031,47.83,-2.96,-4.01,"Blue grey")+ ,(7032,73.39,-0.93,8.09,"Pebble grey")+ ,(7033,56.78,-3.36,6.32,"Cement grey")+ ,(7034,59.68,-0.1,12.74,"Yellow grey")+ ,(7035,81.29,-1.24,0.79,"Light grey")+ ,(7036,63.49,1.27,0.78,"Platinum grey")+ ,(7037,55.3,-0.46,0.22,"Dusty grey")+ ,(7038,72.97,-1.5,2.97,"Agate grey")+ ,(7039,47.86,0.17,4,"Quartz grey")+ ,(7040,66.63,-1.17,-2.82,"Window grey")+ ,(7042,62.58,-1.51,-0.21,"Traffic grey A")+ ,(7043,40.23,-1.28,0,"Traffic grey B")+ ,(7044,74.66,-0.04,5.08,"Silk grey")+ ,(7045,62.71,-1.24,-2.14,"Telegrey 1")+ ,(7046,57.75,-1.6,-3,"Telegrey 2")+ ,(7047,81.43,0.01,0.1,"Telegrey 4")+ ,(7048,54.55,-0.45,7.59,"Pearl mouse grey")+ --,(8000,,,,"Green brown")+ ,(8001,50.62,17.02,31.31,"Ochre brown")+ ,(8002,41.88,14.45,13.31,"Signal brown")+ ,(8003,42.56,15.59,21.67,"Clay brown")+ ,(8004,43.78,22.83,20.22,"Copper brown")+ ,(8007,38.99,12.62,17.08,"Fawn brown")+ ,(8008,41.1,10.45,19.33,"Olive brown")+ ,(8011,33.98,10.04,10.97,"Nut brown")+ ,(8012,34.39,17.06,10.17,"Red brown")+ ,(8014,31.99,4.77,7.71,"Sepia brown")+ ,(8015,33.52,15.02,9.25,"Chestnut brown")+ ,(8016,31.19,9.63,7.56,"Mahogany brown")+ ,(8017,30.6,5.99,4.34,"Chocolate brown")+ ,(8019,31.46,2.12,1.1,"Grey brown")+ ,(8022,25.08,1.18,0.67,"Black brown")+ ,(8023,49.37,24.91,30.25,"Orange brown")+ ,(8024,42.93,11.88,15.9,"Beige brown")+ ,(8025,44,7.95,11.73,"Pale brown")+ ,(8028,34.19,5.72,8.58,"Terra brown")+ ,(8029,35.06,25.58,27.32,"Pearl copper")+ ,(9001,90.4,0.66,6.64,"Cream")+ ,(9002,86.05,-0.89,4.21,"Grey white")+ ,(9003,94.13,-0.55,0.81,"Signal white")+ ,(9004,28.66,0.24,-0.66,"Signal black")+ ,(9005,25.33,0.13,-0.16,"Jet black")+ ,(9006,67.77,-0.58,0.76,"White aluminium")+ ,(9007,59.39,0.01,2.34,"Grey aluminium")+ ,(9010,94.57,-0.47,4.14,"Pure white")+ ,(9011,26.54,-0.05,-1.13,"Graphite black")+ ,(9016,95.26,-0.76,2.11,"Traffic white")+ ,(9017,27.25,0.44,0.51,"Traffic black")+ ,(9018,82.71,-2.06,1.93,"Papyrus white")+ ,(9022,65.38,-0.43,0.34,"Pearl light grey")+ ,(9023,57.32,-0.31,-0.98,"Pearl dark grey")]++ral_colour_tbl :: [(Int, String, SRGB.Colour Double)]+ral_colour_tbl =+ let f (k,l,a,b,nm) = (k,nm,C.cieLAB I.d65 l a b)+ in map f ral_colour_data++-- > let Just (_,_,c) = ral_lookup_name "Sepia brown"+-- > SRGB.sRGB24show c == "#57483f"+ral_lookup_name :: String -> Maybe (Int, String, C.Colour Double)+ral_lookup_name nm = find (\(_,nm',_) -> nm == nm') ral_colour_tbl+
+ Data/CG/Minus/Colour/RYB.hs view
@@ -0,0 +1,135 @@+-- | <http://afriggeri.github.io/RYB/> &+-- <http://web.siat.ac.cn/~baoquan/papers/InfoVis_Paint.pdf>+module Data.CG.Minus.Colour.RYB where++import Data.List {- base -}++import qualified Data.Fixed as F {- base -}++import qualified Data.Colour.SRGB as SRGB {- colour -}++type R = Double+type RYB = (R,R,R)+type RGB = (R,R,R)+type RGB_U8 = (Int,Int,Int)++t3_to_list :: (t,t,t) -> [t]+t3_to_list (p,q,r) = [p,q,r]++t3_from_list :: [t] -> (t, t, t)+t3_from_list l =+ case l of+ [p,q,r] -> (p,q,r)+ _ -> error "t3_from_list"++ryb_clr :: [(String,[R])]+ryb_clr =+ [("white", [1,1,1])+ ,("red", [1,0,0])+ ,("yellow", [1,1,0])+ ,("blue", [0.163,0.373,0.6])+ ,("violet", [0.5,0,0.5])+ ,("green", [0,0.66,0.2])+ ,("orange", [1,0.5,0])+ ,("black", [0.2,0.094,0.0])]++ryb_clr_ix :: String -> Int -> R+ryb_clr_ix nm ix = maybe (error "ryb_clr_ix") (!! ix) (lookup nm ryb_clr)++unit_to_u8 :: R -> Int+unit_to_u8 = floor . (* 255.0)++t3_unit_to_u8 :: (R,R,R) -> (Int,Int,Int)+t3_unit_to_u8 (p,q,r) = (unit_to_u8 p,unit_to_u8 q,unit_to_u8 r)++rgb_to_u8 :: RGB -> RGB_U8+rgb_to_u8 = t3_unit_to_u8++-- > map (ryb_to_u8 . ryb_to_rgb) [(0,0,0),(1,1,1),(1,0,0),(0,1,0),(0,0,1)]+-- > ryb_to_rgb (0,1,1) == (0.0,0.66,0.2) -- green+-- > ryb_to_rgb (0,0.5,1) -- cyan = blue+green = (0,1,2)+ryb_to_rgb :: RYB -> RGB+ryb_to_rgb (r, y, b) =+ let f ix =+ ryb_clr_ix "white" ix * (1-r) * (1 - b) * (1 - y) ++ ryb_clr_ix "red" ix * r * (1 - b) * (1 - y) ++ ryb_clr_ix "blue" ix * (1-r) * b * (1 - y) ++ ryb_clr_ix "violet" ix * r * b * (1 - y) ++ ryb_clr_ix "yellow" ix * (1-r) * (1 - b) * y ++ ryb_clr_ix "orange" ix * r * (1 - b) * y ++ ryb_clr_ix "green" ix * (1-r) * b * y ++ ryb_clr_ix "black" ix * r * b * y+ in t3_from_list (map f [0..2])++-- > map (euclidian_distance [0,1,0]) [[1,1,0],[0,1,0],[1,1,1],[0.5,0.5,0.5]] == [1,0,2,0.75]+euclidian_distance :: Floating t => [t] -> [t] -> t+euclidian_distance p1 =+ let f x1 x2 = (x2 - x1) ** 2+ in sum . zipWith f p1++euclidian_distance_t3 :: Floating t => (t,t,t) -> (t,t,t) -> t+euclidian_distance_t3 (p1,p2,p3) (q1,q2,q3) =+ let f x1 x2 = (x2 - x1) ** 2+ in f p1 q1 + f p2 q2 + f p3 q3++euclidian_distance_t3_set :: Floating t => [(t,t,t)] -> (t,t,t) -> t+euclidian_distance_t3_set l x = sum (map (euclidian_distance_t3 x) l)++int_to_r :: Int -> R+int_to_r = fromIntegral++-- > map n_triples [8,27,64,125,216,343,512]+n_triples :: Int -> (R,R)+n_triples k =+ let fceil = int_to_r . ceiling+ b = fceil (int_to_r k ** (1/3))+ n = (b ** 3)+ in (b,n)++-- > gen_triples 8 == [(0,0,0),(0,0,1),(0,1,0),(0,1,1),(1,0,0),(1,0,1),(1,1,0),(1,1,1)]+gen_triples :: Int -> [RYB]+gen_triples k =+ let ffloor = int_to_r . floor+ (base,base_n) = n_triples k+ (%) = F.mod'+ f n = (ffloor (n / (base * base)) / (base - 1)+ ,ffloor ((n / base) % base) / (base - 1)+ ,ffloor (n % base) / (base - 1))+ in map f [0 .. base_n - 1]++-- > most_distant_set [(0,0,0)] (gen_triples 8)+most_distant_set :: (Ord t, Floating t) => [(t,t,t)] -> [(t,t,t)] -> ((t,t,t),[(t,t,t)])+most_distant_set x l =+ let d = map (euclidian_distance_t3_set x) l+ z = maximum d+ in case find ((== z) . fst) (zip d l) of+ Just (_,e) -> (e,delete e l)+ Nothing -> error "most_distant_set"++distance_step :: (Ord t, Floating t) => [(t,t,t)] -> [(t,t,t)] -> [(t,t,t)]+distance_step lhs rhs =+ case rhs of+ [] -> []+ _ -> let (e,rhs') = most_distant_set lhs rhs+ in e : distance_step (e:lhs) rhs'++-- > map (rgb_to_u8 . ryb_to_rgb) (distance_sort (gen_triples 8))+distance_sort :: (Ord t, Floating t) => [(t,t,t)] -> [(t,t,t)]+distance_sort l =+ case l of+ e:l' -> e : distance_step [e] l'+ _ -> error "distance_sort"++-- > ryb_colour_gen 8 == [(0,0,0),(1,1,1),(0,0,1),(1,1,0),(0,1,0),(1,0,1),(0,1,1),(1,0,0)]+ryb_colour_gen :: Int -> [RYB]+ryb_colour_gen = distance_sort . gen_triples++rgb_colour_gen :: Int -> [RGB]+rgb_colour_gen = map ryb_to_rgb . ryb_colour_gen++-- > rgb_u8_colour_gen 27+rgb_u8_colour_gen :: Int -> [RGB_U8]+rgb_u8_colour_gen = map rgb_to_u8 . rgb_colour_gen++colour_gen :: Int -> [SRGB.Colour R]+colour_gen = map (\(r,g,b) -> SRGB.sRGB r g b) . rgb_colour_gen
+ Data/CG/Minus/Colour/SVG.hs view
@@ -0,0 +1,175 @@+-- | SVG colours+module Data.CG.Minus.Colour.SVG where++import qualified Data.Colour as C {- colour -}+import qualified Data.Colour.Names as N {- colour -}+import qualified Data.Colour.SRGB as C {- colour -}+import Data.Functor.Identity {- base -}++-- | Type specialised 'N.readColourName'.+svg_name_to_colour :: String -> C.Colour Double+svg_name_to_colour = runIdentity . N.readColourName++-- | The named colours of the @SVG@ specification, alphabetical order.+-- <https://www.w3.org/TR/SVG11/types.html#ColorKeywords>+--+-- > length svg_colour_data == 147+svg_colour_data :: Num n => [(String,n,n,n)]+svg_colour_data =+ [("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)+ ]++-- | More useful form of 'svg_colour_data'.+svg_color_tbl :: [(String,C.Colour Double)]+svg_color_tbl =+ let f (nm,r,g,b) = (nm,C.sRGB24 r g b)+ in map f svg_colour_data++svg_colour_set :: [C.Colour Double]+svg_colour_set = map snd svg_color_tbl
+ Data/CG/Minus/Colour/VGA.hs view
@@ -0,0 +1,60 @@+module Data.CG.Minus.Colour.VGA where++import Data.Bits {- base -}+import Data.Function {- base -}+import Data.List {- base -}++type T3 t = (t,t,t)++t3_map :: (t -> u) -> T3 t -> T3 u+t3_map f (p,q,r) = (f p,f q,f r)++type T6 t = (t,t,t,t,t,t)++t6_from_list :: [t] -> T6 t+t6_from_list l = case l of {[a,b,c,d,e,f] -> (a,b,c,d,e,f);_ -> error "t6_from_list"}++-- | Table in binary form (r,g,b,R,G,B), ie. {0,1}.+ega_color_table_t6 :: [T6 Int]+ega_color_table_t6 =+ let f i = map (fromEnum . testBit i) [5::Int,4 .. 0]+ in map (t6_from_list . f) [0::Int .. 63]++t6_one_bit_to_t3_two_bit :: T6 Int -> T3 Int+t6_one_bit_to_t3_two_bit (r,g,b,r',g',b') = (r + 2 * r',g + 2 * g',b + 2 * b')++-- | Table in ternary form (r,g,b), ie. {0,1,2}.+--+-- > length ega_color_table == 64+-- > map (ega_color_table !!) [31,32] == [(2,3,3),(1,0,0)]+-- > let f = t3_map (* 0x55) in map f ega_color_table+ega_color_table :: [T3 Int]+ega_color_table = map t6_one_bit_to_t3_two_bit ega_color_table_t6++-- | Indices for the default 16-colour table.+--+-- > map (ega_color_table !!) ega_default_16_indices == ega_default_16+ega_default_16_indices :: [Int]+ega_default_16_indices = [0 .. 5] ++ [20,7] ++ [56 .. 63]++-- | (index,name,two-bit-rgb)+cga_16_color_palette :: [(Int,String,T3 Int)]+cga_16_color_palette =+ [(0,"black",(0,0,0)),(8,"gray",(1,1,1))+ ,(1,"blue",(0,0,2)),(9,"light blue",(1,1,3))+ ,(2,"green",(0,2,0)),(10,"light green",(1,3,1))+ ,(3,"cyan",(0,2,2)),(11,"light cyan",(1,3,3))+ ,(4,"red",(2,0,0)),(12,"light red",(3,1,1))+ ,(5,"magenta",(2,0,2)),(13,"light magenta",(3,1,3))+ ,(6,"brown",(2,1,0)),(14,"yellow",(3,3,1))+ ,(7,"light gray",(2,2,2)),(15,"white (high intensity)",(3,3,3))]++-- > let f = t3_map (* 0x55) in map f cga_16_color_table+cga_16_color_table :: [T3 Int]+cga_16_color_table =+ let sq = map (\(i,_,c) -> (i,c)) cga_16_color_palette+ in map snd (sortBy (compare `on` fst) sq)++-- | Synonym for 'cga_16_color_table'.+ega_default_16 :: [T3 Int]+ega_default_16 = cga_16_color_table
+ Data/CG/Minus/Core.hs view
@@ -0,0 +1,1326 @@+module Data.CG.Minus.Core where++import qualified Data.Fixed as F {- base -}+import Data.List {- base -}+import Data.Maybe {- base -}+import System.Random {- random -}+import Text.Printf {- base -}++import Data.CG.Minus.Types+import Data.CG.Minus.Geometry++pt_eq_by :: (t -> t -> Bool) -> Pt t -> Pt t -> Bool+pt_eq_by f (Pt x1 y1) (Pt x2 y2) = f x1 x2 && f y1 y2++pt_eq_approx :: (Ord n,Floating n) => Pt n -> Pt n -> Bool+pt_eq_approx = pt_eq_by (~=)++-- * R(eal) functions++-- | Epsilon.+epsilon :: Floating n => n+epsilon = 0.000001++-- | Is absolute difference less than 'epsilon'.+(~=) :: (Floating a, Ord a) => a -> a -> Bool+p ~= q = abs (p - q) < epsilon++-- | Degrees to radians.+--+-- > map r_to_radians [-180,-90,0,90,180] == [-pi,-pi/2,0,pi/2,pi]+r_to_radians :: R -> R+r_to_radians x = (x / 180) * pi++-- | Radians to degrees, inverse of 'r_to_radians'.+--+-- > map r_from_radians [-pi,-pi/2,0,pi/2,pi] == [-180,-90,0,90,180]+-- > r_from_radians (pi/8) == 22.5+r_from_radians :: R -> R+r_from_radians x = (x / pi) * 180++-- | 'R' modulo within range.+--+-- > map (r_constrain (3,5)) [2.75,5.25] == [4.75,3.25]+r_constrain :: (R,R) -> R -> R+r_constrain (l,r) =+ let down n i x = if x > i then down n i (x - n) else x+ up n i x = if x < i then up n i (x + n) else x+ both n i j x = up n i (down n j x)+ in both (r - l) l r++-- | Sum of squares.+mag_sq :: Num a => a -> a -> a+mag_sq x y = x * x + y * y++-- | 'sqrt' of 'mag_sq'.+mag :: Floating c => c -> c -> c+mag x = sqrt . mag_sq x++-- * Pt functions++-- | Tuple constructor.+mk_pt :: (a,a) -> Pt a+mk_pt (x,y) = Pt x y++-- | Tuple accessor.+pt_xy :: Pt t -> (t,t)+pt_xy (Pt x y) = (x,y)++-- | 'Pt' of (0,0).+--+-- > pt_origin == Pt 0 0+pt_origin :: Num a => Pt a+pt_origin = Pt 0 0++-- | 'Pt' at /(n,n)/.+--+-- > pt_from_scalar 1 == Pt 1 1+pt_from_scalar :: a -> Pt a+pt_from_scalar a = Pt a a++-- | Clip /x/ and /y/ to lie in /(0,n)/.+--+-- > pt_clipu 1 (Pt 0.5 1.5) == Pt 0.5 1+pt_clipu :: (Ord a,Num a) => a -> Pt a -> Pt a+pt_clipu u =+ let f n = if n < 0 then 0 else if n > u then u else n+ in pt_uop f++-- | Swap /x/ and /y/ coordinates at 'Pt'.+--+-- > pt_swap (Pt 1 2) == Pt 2 1+pt_swap :: Pt a -> Pt a+pt_swap (Pt x y) = Pt y x++-- | Negate /y/ element of 'Pt'.+--+-- > pt_negate_y (Pt 1 1) == Pt 1 (-1)+pt_negate_y :: (Num a) => Pt a -> Pt a+pt_negate_y (Pt x y) = Pt x (negate y)++-- | 'Pt' variant of 'r_to_radians'.+--+-- > pt_to_radians (Pt 90 270) == Pt (pi/2) (pi*(3/2))+pt_to_radians :: Pt R -> Pt R+pt_to_radians = pt_uop r_to_radians++-- | 'Pt' variant of 'r_from_radians'.+pt_from_radians :: Pt R -> Pt R+pt_from_radians = pt_uop r_from_radians++-- | Cartesian (x,y) to polar (distance,angle) coordinate form.+--+-- > map pt_to_polar [Pt 1 0,Pt 0 pi] == [Pt 1 0,Pt pi (pi/2)]+pt_to_polar :: Pt R -> Pt R+pt_to_polar = mk_pt . rectangular_to_polar . pt_xy++{- | Polar to cartesian, inverse of 'pt_to_polar'.++<http://mathworld.wolfram.com/PolarCoordinates.html>++rho (magnitude) is the radial distance from the origin,+theta (phase )is the counterclockwise angle from the x-axis++> pt_eq_by (~=) (pt_from_polar (Pt pi (pi/2))) (Pt 0 pi)+> pt_eq_by (~=) (pt_from_polar (Pt (sqrt 2) (r_to_radians 45))) (Pt 1 1)++-}+pt_from_polar :: Pt R -> Pt R+pt_from_polar = mk_pt . polar_to_rectangular . pt_xy++mk_pt_polar :: (R,R) -> Pt R+mk_pt_polar = mk_pt . polar_to_rectangular++pt_polar :: R -> R -> Pt R+pt_polar = curry mk_pt_polar++-- | Scalar 'Pt' '+'.+--+-- > pt_offset 1 pt_origin == Pt 1 1+pt_offset :: Num a => a -> Pt a -> Pt a+pt_offset = pt_uop . (+)++-- | Scalar 'Pt' '*'.+--+-- > pt_scale 2 (Pt 1 2) == Pt 2 4+pt_scale :: Num a => a -> Pt a -> Pt a+pt_scale = pt_uop . (*)++{-+infixl 7 |*, *|++(|*) :: Num a => a -> Pt a -> Pt a+(|*) = pt_scale++(*|) :: Num a => Pt a -> a -> Pt a+(*|) = flip pt_scale+-}++-- | Pointwise 'min'.+pt_min :: (Ord a) => Pt a -> Pt a -> Pt a+pt_min = pt_binop min++-- | Pointwise 'max'.+pt_max :: (Ord a) => Pt a -> Pt a -> Pt a+pt_max = pt_binop max++-- | Apply function to /x/ and /y/ fields of three 'Pt'.+pt_ternary_f :: (a->a->b->b->c->c->d) -> Pt a -> Pt b -> Pt c -> d+pt_ternary_f f (Pt x0 y0) (Pt x1 y1) (Pt x2 y2) = f x0 y0 x1 y1 x2 y2++-- | Given a /(minima,maxima)/ pair, expand so as to include /p/.+--+-- > pt_minmax (Pt 0 0,Pt 1 1) (Pt (-1) 2) == (Pt (-1) 0,Pt 1 2)+pt_minmax :: Ord a => (Pt a,Pt a) -> Pt a -> (Pt a,Pt a)+pt_minmax (p0,p1) p =+ let f x0 y0 x1 y1 x y =+ (Pt (min x x0) (min y y0)+ ,Pt (max x x1) (max y y1))+ in pt_ternary_f f p0 p1 p++-- | 'Pt' variant of 'constrain'.+pt_constrain :: (Pt R,Pt R) -> Pt R -> Pt R+pt_constrain (p0,p1) p =+ let f x0 y0 x1 y1 x y =+ let x' = r_constrain (x0,x1) x+ y' = r_constrain (y0,y1) y+ in Pt x' y'+ in pt_ternary_f f p0 p1 p++-- | Angle to origin. By convention the angle is zero rightwards+-- along the X axis, and is measured counter-clockwise.+--+-- > map pt_angle_o [Pt 0 1,Pt 1 0,Pt 0 (-1),Pt (-1) 0] == [pi / 2,0,-pi / 2,pi]+-- > r_from_radians (pt_angle_o (Pt 2 1)) ~= 26.565051177077986+pt_angle_o :: Pt R -> R+pt_angle_o (Pt x y) = atan2 y x++-- | Angle from /p/ to /q/.+--+-- > pt_angle (Pt 0 (-1)) (Pt 0 1) == pi/2+-- > pt_angle (Pt 1 0) (Pt 0 1) == pi * 3/4+-- > pt_angle (Pt 0 1) (Pt 0 1) == 0+pt_angle :: Pt R -> Pt R -> R+pt_angle p q = pt_angle_o (q - p)++-- | Pointwise '+'.+--+-- pt_translate (Vc 1 1) (Pt 0 0) == pt 1 1+pt_translate :: Num a => Vc a -> Pt a -> Pt a+pt_translate (Vc dx dy) (Pt x y) = Pt (x + dx) (y + dy)++-- | 'pt_uop' 'fromIntegral'.+pt_from_i :: (Integral i,Num a) => Pt i -> Pt a+pt_from_i = pt_uop fromIntegral++-- | 'mag_sq' of /x/ /y/ of 'Pt'.+pt_mag_sq :: Num a => Pt a -> a+pt_mag_sq (Pt x y) = mag_sq x y++-- | 'mag' of /x/ /y/ of 'Pt'.+pt_mag :: Floating a => Pt a -> a+pt_mag (Pt x y) = mag x y++-- | Distance from 'Pt' /p/ to 'Pt' /q/.+--+-- > 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 p1 p2 = pt_mag (p2 - p1)++-- | Are /x/ and /y/ of 'Pt' /p/ in range (0,1).+--+-- > map pt_is_normal [Pt 0 0,Pt 1 1,Pt 2 2] == [True,True,False]+pt_is_normal :: (Ord a,Num a) => Pt a -> Bool+pt_is_normal (Pt x y) = 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 (Pt x y) =+ let s = sin a+ c = cos a+ in Pt (x * c - y * s) (y * c + x * s)++pt_rotate_about :: Floating a => a -> Pt a -> Pt a -> Pt a+pt_rotate_about r p0 p1 = pt_rotate r (p1 - p0) + p0++pt_lift3 :: ((a,a) -> (b,b) -> (c,c) -> (d,d)) -> Pt a -> Pt b -> Pt c -> Pt d+pt_lift3 f (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) =+ let (x,y) = f (x1,y1) (x2,y2) (x3,y3)+ in Pt x y++-- | Copy /x/ and /y/ from 'Pt' to 'Vc'.+pt_to_vc :: Pt a -> Vc a+pt_to_vc (Pt x y) = Vc x y++-- | The reflection of 'Pt' across a vertical line at /x/.+pt_reflect_x :: Num a => a -> Pt a -> Pt a+pt_reflect_x rx (Pt x y) = Pt (rx + (rx - x)) y++-- | The reflection of 'Pt' across a horizontal line at /y/.+pt_reflect_y :: Num a => a -> Pt a -> Pt a+pt_reflect_y ry (Pt x y) = Pt x (ry + (ry - y))++-- | The reflection of 'Pt' across the minimum distance to (/x/,/y/).+--+-- > pt_reflect_xy (1,1) (Pt (-1) 0) == Pt 3 2+pt_reflect_xy :: Num a => (a,a) -> Pt a -> Pt a+pt_reflect_xy (rx,ry) (Pt x y) = Pt (rx + (rx - x)) (ry + (ry - y))++-- * Vc functions++mk_vc :: (R,R) -> Vc R+mk_vc = uncurry Vc++mk_vc_polar :: (R,R) -> Vc R+mk_vc_polar = mk_vc . polar_to_rectangular++vc_polar :: R -> R -> Vc R+vc_polar = curry mk_vc_polar++vc_to_polar :: Vc R -> Vc R+vc_to_polar = mk_vc . rectangular_to_polar . vc_xy++vc_xy :: Vc t -> (t,t)+vc_xy (Vc x y) = (x,y)++-- | 'mag_sq' of 'Vc'.+vc_mag_sq :: Floating c => Vc c -> c+vc_mag_sq (Vc dx dy) = mag_sq dx dy++-- | 'mag' of 'Vc'.+vc_mag :: Floating c => Vc c -> c+vc_mag (Vc dx dy) = mag dx dy++-- | Multiply 'Vc' pointwise by scalar.+--+-- > vc_scale 2 (Vc 3 4) == Vc 6 8+vc_scale :: Num a => a -> Vc a -> Vc a+vc_scale n (Vc x y) = Vc (x * n) (y * n)++-- | 'Vc' dot product.+--+-- > vc_dot (Vc 1 2) (Vc 3 4) == 11+vc_dot :: Num a => Vc a -> Vc a -> a+vc_dot (Vc x y) (Vc x' y') = (x * x') + (y * y')++-- | Scale 'Vc' to have unit magnitude (to within tolerance).+--+-- > let x = (sqrt 2) / 2+-- > vc_mag_sq (Vc x x) ~= 1.0+-- > vc_unit (Vc x x) == Vc x x+-- > vc_unit (Vc 0 0) == Vc 0 0+-- > vc_unit (Vc 1 1) ~= Vc x x+vc_unit :: (Ord a, Floating a) => Vc a -> Vc a+vc_unit v =+ if abs (vc_mag_sq v - 1) < epsilon+ then v+ else if vc_mag_sq v == 0+ then v+ else let m = vc_mag v in Vc (vc_x v / m) (vc_y v / m)++-- | The angle between two vectors on a plane. The angle is from v1 to+-- v2, positive anticlockwise. The result is in (-pi,pi)+vc_angle :: Vc R -> Vc R -> R+vc_angle (Vc x1 y1) (Vc x2 y2) =+ let t1 = atan2 y1 x1+ t2 = atan2 y2 x2+ in r_constrain (-pi,pi) (t2 - t1)++-- * Line functions++-- | Variant on 'Ln' which takes 'Pt' co-ordinates as duples.+--+-- > mk_ln ((0,0),(1,1)) == Ln (Pt 0 0) (Pt 1 1)+mk_ln :: ((a,a),(a,a)) -> Ln a+mk_ln ((x1,y1),(x2,y2)) = Ln (Pt x1 y1) (Pt x2 y2)++{-+ln :: (Pt a, Pt a) -> Ln a+ln = uncurry Ln+-}++ln' :: (a, a) -> (a, a) -> Ln a+ln' = curry mk_ln++-- | '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 (Ln p q) = let Pt x y = q - p in Vc x y++-- | 'ln_start' and 'ln_vc'.+ln_pt_vc :: Num a => Ln a -> (Pt a,Vc a)+ln_pt_vc l = (ln_start l,ln_vc l)++-- | 'Pt' UOp at 'Ln'.+ln_uop :: (Pt a -> Pt b) -> Ln a -> Ln b+ln_uop f (Ln l r) = Ln (f l) (f r)++-- | 'pt_translate' at 'Ln'.+ln_translate :: Num n => Vc n -> Ln n -> Ln n+ln_translate v (Ln a b) = Ln (pt_translate v a) (pt_translate v b)++-- | Variant with 'Pt' in place of 'Vc'.+ln_translate_pt :: Num n => Pt n -> Ln n -> Ln n+ln_translate_pt v (Ln a b) = Ln (a + v) (b + v)++ln_multiply :: Num n => Pt n -> Ln n -> Ln n+ln_multiply p (Ln a b) = Ln (a * p) (b * p)++-- | 'pt_scale' at 'Ln'.+ln_scale :: Num b => b -> Ln b -> Ln b+ln_scale m = ln_uop (pt_scale m)++-- | The angle, in /radians/, anti-clockwise from the /x/-axis.+--+-- > ln_angle (mk_ln ((0,0),(0,0))) == 0+-- > ln_angle (mk_ln ((0,0),(1,1))) == pi/4+-- > ln_angle (mk_ln ((0,0),(0,1))) == pi/2+-- > ln_angle (mk_ln ((0,0),(-1,1))) == pi * 3/4+ln_angle :: Ln R -> R+ln_angle ln =+ let Vc dx dy = ln_vc ln+ in if dx == 0 && dy == 0 then 0 else atan2 dy dx++-- | Start and end points of 'Ln'.+--+-- > ln_pt (Ln (Pt 1 0) (Pt 0 0)) == (Pt 1 0,Pt 0 0)+ln_pt :: Ln a -> (Pt a,Pt a)+ln_pt (Ln s e) = (s,e)++-- | Variant of 'ln_pt' giving co-ordinates as duples.+--+-- > ln_elem (Ln (Pt 1 0) (Pt 0 0)) == ((1,0),(0,0))+ln_elem :: Ln a -> ((a,a),(a,a))+ln_elem (Ln (Pt x1 y1) (Pt x2 y2)) = ((x1,y1),(x2,y2))++-- | 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 (Ln (Pt x1 y1) (Pt x2 y2)) =+ let x = (x1 + x2) / 2+ y = (y1 + y2) / 2+ in Pt x y++-- | Variant on 'ln_midpoint'.+--+-- > cc_midpoint (Just (Pt 0 0),Nothing) == Pt 0 0+-- > cc_midpoint (Nothing,Just (Pt 2 1)) == Pt 2 1+-- > cc_midpoint (Just (Pt 0 0),Just (Pt 2 1)) == Pt 1 (1/2)+cc_midpoint :: (Maybe (Pt R), Maybe (Pt R)) -> Pt R+cc_midpoint cc =+ case cc of+ (Nothing,Nothing) -> Pt 0 0+ (Just p,Nothing) -> p+ (Nothing, Just q) -> q+ (Just p, Just q) -> ln_midpoint (Ln p q)++-- | Magnitude of 'Ln', ie. length of line.+--+-- > 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 = vc_mag . ln_vc++-- | Order 'Pt' at 'Ln' so that /p/ is to the left of /q/. If /x/+-- fields are equal, sort on /y/.+--+-- > ln_sort (Ln (Pt 1 0) (Pt 0 0)) == Ln (Pt 0 0) (Pt 1 0)+-- > ln_sort (Ln (Pt 0 1) (Pt 0 0)) == Ln (Pt 0 0) (Pt 0 1)+ln_sort :: Ord a => Ln a -> Ln a+ln_sort ln =+ let Ln p q = ln+ Pt x1 y1 = p+ Pt x2 y2 = q+ in case compare x1 x2 of+ LT -> ln+ EQ -> if y1 <= y2 then ln else Ln q p+ GT -> Ln q p++-- | Adjust 'Ln' to have equal starting 'Pt' but magnitude 'R'.+--+-- > 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 z ln =+ let Ln p _ = ln+ v = vc_scale z (vc_unit (ln_vc ln))+ in Ln p (pt_translate v p)++-- | Extend 'Ln' by 'R', ie. 'ln_adjust' with /n/ added to+-- 'ln_magnitude'.+--+-- > ln_extend (sqrt 2) (Ln (Pt 0 0) (Pt 1 1)) ~= Ln (Pt 0 0) (Pt 2 2)+ln_extend :: R -> Ln R -> Ln R+ln_extend n l = Ln (ln_start l) (pt_linear_extension n l)++-- | Variant definition of 'ln_extend'.+--+-- > ln_extend_ (sqrt 2) (Ln (Pt 0 0) (Pt 1 1)) == Ln (Pt 0 0) (Pt 2 2)+ln_extend_ :: R -> Ln R -> Ln R+ln_extend_ n l = ln_adjust (n + ln_magnitude l) l++-- | Calculate the point that extends a line by length 'n'.+--+-- > pt_linear_extension (sqrt 2) (Ln (Pt 1 1) (Pt 2 2)) ~= Pt 3 3+-- > pt_linear_extension 1 (Ln (Pt 1 1) (Pt 1 2)) ~= Pt 1 3+pt_linear_extension :: R -> Ln R -> Pt R+pt_linear_extension n (Ln p q) =+ let Pt mg ph = pt_to_polar (q - p)+ in pt_from_polar (Pt (mg + n) ph) + p++-- | Does 'Pt' /p/ lie on 'Ln' (inclusive).+--+-- > let {f = pt_on_line (Ln (Pt 0 0) (Pt 1 1))+-- > ;r = [True,False,False,True]}+-- > in map f [Pt 0.5 0.5,Pt 2 2,Pt (-1) (-1),Pt 0 0] == r+pt_on_line :: Ln R -> Pt R -> Bool+pt_on_line l r =+ let (p,q) = ln_pt l+ Pt i j = pt_to_polar (q - p)+ Pt i' j' = pt_to_polar (r - p)+ in r == p || r == q || (j == j' && i' <= i)++-- | Vertical line.+ln_x_aligned :: a -> (a,a) -> Ln a+ln_x_aligned x (y0,y1) = Ln (Pt x y0) (Pt x y1)++-- | Horizontal line.+ln_y_aligned :: a -> (a,a) -> Ln a+ln_y_aligned y (x0,x1) = Ln (Pt x0 y) (Pt x1 y)++-- | Minimum Distance between a Point and a Line+-- <http://paulbourke.net/geometry/pointlineplane/>+--+-- > map (pt_ln_intersect_md_raw ((0,0),(10,10))) [(10,5),(15,0)] == [(7.5,7.5),(7.5,7.5)]+pt_ln_intersect_md_raw :: Fractional t => ((t,t),(t,t)) -> (t,t) -> (t,t,t)+pt_ln_intersect_md_raw ((x1,y1),(x2,y2)) (x3,y3) =+ let xd = x2 - x1+ yd = y2 - y1+ u = ((x3 - x1) * xd + (y3 - y1) * yd) / (xd * xd + yd * yd)+ x4 = x1 + u * (x2 - x1)+ y4 = y1 + u * (y2 - y1)+ in (u,x4,y4)++-- | Wrapper for 'pt_ln_intersect_md_raw'.+pt_ln_intersect_md :: Fractional a => Ln a -> Pt a -> (a,Pt a)+pt_ln_intersect_md ln pt =+ let (u,x,y) = pt_ln_intersect_md_raw (ln_elem ln) (pt_xy pt)+ in (u,Pt x y)++-- | 'pt_reflect_xy' about 'pt_ln_intersect_md'.+--+-- > map (pt_ln_reflect_md (Ln (Pt 0 0) (Pt 1 1))) [Pt 1 0,Pt 0.25 1] == [Pt 0 1,Pt 1 0.25]+pt_ln_reflect_md :: Fractional a => Ln a -> Pt a -> Pt a+pt_ln_reflect_md ln p =+ let (_,Pt x y) = pt_ln_intersect_md ln p+ in pt_reflect_xy (x,y) p++-- | Swap start and end points.+ln_reverse :: Ln a -> Ln a+ln_reverse (Ln p q) = Ln q p++-- * Intersection++-- | Intersection of two infinite lines, given as Pt and Vc.+ln_intersect_sg :: (Eq a,Fractional a) => (Pt a,Vc a) -> (Pt a,Vc a) -> Maybe (a,a)+ln_intersect_sg (Pt x1 y1,Vc dx1 dy1) (Pt x2 y2,Vc dx2 dy2) =+ let a = (dx2 * dy1) - (dx1 * dy2)+ t' = ((dx1 * (y2 - y1)) - (dy1 * (x2 - x1))) / a+ t = ((dx2 * (y1 - y2)) - (dy2 * (x1 - x2))) / (negate a)+ in if a == 0 then Nothing else Just (t,t')++ln_intersect :: (Eq t, Fractional t) => Ln t -> Ln t -> Maybe (t,t)+ln_intersect l1 l2 = ln_intersect_sg (ln_start l1,ln_vc l1) (ln_start l2,ln_vc l2)++-- | The 'Pt' at /z/ along 'Ln', 0 is the start of the line and 1 is the end.+ln_pt_along :: Num n => n -> Ln n -> Pt n+ln_pt_along z ln =+ let v = vc_scale z (ln_vc ln)+ Ln p _ = ln+ in pt_translate v p++-- | Do two 'Ln's intersect, and if so at which 'Pt'.+--+-- > ln_intersection (ln' (0,0) (5,5)) (ln' (5,0) (0,5)) == Just (Pt 2.5 2.5)+-- > ln_intersection (ln' (1,3) (9,3)) (ln' (0,1) (2,1)) == Nothing+-- > ln_intersection (ln' (1,5) (6,8)) (ln' (0.5,3) (6,4)) == Nothing+-- > ln_intersection (ln' (1,2) (3,6)) (ln' (2,4) (4,8)) == Nothing+-- > ln_intersection (ln' (2,3) (7,9)) (ln' (1,2) (5,7)) == Nothing+-- > 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 ln_intersect l0 l1 of+ Nothing -> Nothing+ Just (i,j) -> if i >= 0 && i <= 1 && j >= 0 && j <= 1+ then Just (ln_pt_along i l0)+ else Nothing++-- | Variant definition of 'ln_intersection', using algorithm at+-- <http://paulbourke.net/geometry/lineline2d/>.+--+-- > let comp_f x y = (ln_intersection x y,ln_intersection_ x y)+-- > comp_f (ln' (1,2) (3,6)) (ln' (2,4) (4,8)) == (Nothing,Nothing)+-- > comp_f (ln' (0,0) (1,1)) (ln' (0,0) (1,0)) == (Just (Pt 0 0),Just (Pt 0 0))+-- > comp_f (ln' (0,0) (1,2)) (ln' (0,1) (2,1)) == (Just (Pt 0.5 1),Just (Pt 0.5 1))+ln_intersection_ :: (Ord a,Fractional a) => Ln a -> Ln a -> Maybe (Pt a)+ln_intersection_ l0 l1 =+ let ((x1,y1),(x2,y2)) = ln_elem l0+ ((x3,y3),(x4,y4)) = ln_elem l1+ d = (y4 - y3) * (x2 - x1) - (x4 - x3) * (y2 - y1)+ ua' = (x4 - x3) * (y1 - y3) - (y4 - y3) * (x1 - x3)+ ub' = (x2 - x1) * (y1 - y3) - (y2 - y1) * (x1 - x3)+ in if d == 0+ then Nothing+ else if ua' == 0 && ub' == 0+ then Just (Pt x1 y1)+ else let ua = ua' / d+ ub = ub' / d+ in if in_range 0 1 ua && in_range 0 1 ub+ then let x = x1 + ua * (x2 - x1)+ y = y1 + ua * (y2 - y1)+ in Just (Pt x y)+ else Nothing++-- | Predicate variant of 'ln_intersection'.+--+-- > ln_intersect_p (ln' (1,1) (3,8)) (ln' (0.5,2) (4,7)) == True+-- > ln_intersect_p (ln' (3.5,9) (3.5,0.5)) (ln' (3,1) (9,1)) == True+ln_intersect_p :: (Ord a, Fractional a) => Ln a -> Ln a -> Bool+ln_intersect_p l = isJust . ln_intersection l++{- | Distances along a line, given as Pt and Vc, that it intersects with a circle.++> let o = Pt 0 0+> let c = (o,1)+> let z = sqrt 2 / 2+> map (\v -> ln_circle_intersection (o,v) c) [Vc 1 0,Vc 1 1] == [Just (1,-1),Just (z,-z)]++-}+ln_circle_intersection :: (Ord a,Floating a) => (Pt a,Vc a) -> (Pt a,a) -> Maybe (a,a)+ln_circle_intersection (Pt lx ly,Vc dx dy) (Pt cx cy,r) =+ let a = (dx * dx + dy * dy)+ b = 2 * ((lx - cx) * dx + (ly - cy) * dy)+ c = (lx - cx) * (lx - cx) + (ly - cy) * (ly - cy) - r * r+ z = b * b - 4 * a * c+ in if z < 0+ then Nothing+ else if a == 0+ then if c == 0 then Just (0,0) else Nothing+ else Just ((-b + sqrt z) / (2 * a)+ ,(-b - sqrt z) / (2 * a))++-- | Variant with input as 'Ln' and output as list of actual intersection points.+ln_circle_intersection_set :: (Ord t, Floating t) => Ln t -> (Pt t,t) -> [Pt t]+ln_circle_intersection_set l c =+ case ln_circle_intersection (ln_pt_vc l) c of+ Nothing -> []+ Just (p,q) -> let f n = if n >= 0 && n <= 1 then Just n else Nothing+ in map (flip ln_pt_along l) (catMaybes [f p,f q])++-- * Line slope++-- | Slope of 'Ln' or 'Nothing' if /vertical/.+--+-- > let l = map (ln' (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,Eq a) => Ln a -> Maybe a+ln_slope l =+ let ((x1,y1),(x2,y2)) = ln_elem l+ in case x2 - x1 of+ 0 -> Nothing+ dx -> Just ((y2 - y1) / dx)++-- | Are 'Ln's parallel, ie. have equal 'ln_slope'. Note that the+-- direction of the 'Ln' is not relevant, ie. this is not equal to+-- 'ln_same_direction'.+--+-- > ln_parallel (ln' (0,0) (1,1)) (ln' (2,2) (1,1)) == True+-- > ln_parallel (ln' (0,0) (1,1)) (ln' (2,0) (1,1)) == False+-- > ln_parallel (ln' (1,2) (3,6)) (ln' (2,4) (4,8)) == True+-- > map ln_slope [ln' (2,2) (1,1),ln' (2,0) (1,1)] == [Just 1,Just (-1)]+ln_parallel :: (Ord a,Fractional a) => Ln a -> Ln a -> Bool+ln_parallel p q = ln_slope p == ln_slope q++-- | Are 'Ln's parallel, ie. have equal 'ln_angle'.+--+-- > 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_angle (ln_sort p) == ln_angle (ln_sort q)++-- | Are two vectors are in the same direction (to within a small+-- tolerance).+vc_same_direction :: (Ord a, Floating a) => Vc a -> Vc a -> Bool+vc_same_direction v w =+ let Vc dx1 dy1 = vc_unit v+ Vc dx2 dy2 = vc_unit w+ in abs (dx2 - dx1) < epsilon && abs (dy2 - dy1) < epsilon++-- | Do 'Ln's have same direction (within tolerance).+--+-- > 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 `vc_same_direction` 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) `vc_same_direction` 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,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,Eq a) => Ln a -> Bool+ln_vertical = (== Nothing) . ln_slope++ln_minmax :: Ord a => Ln a -> (Pt a, Pt a)+ln_minmax (Ln (Pt x1 y1) (Pt x2 y2)) = (Pt (min x1 x2) (min y1 y2),Pt (max x1 x2) (max y1 y2))++ln_wn :: (Num n,Ord n) => Ln n -> Wn n+ln_wn = wn_from_extent . ln_minmax++-- | 'pt_rotate_about' at 'Ln'.+ln_rotate_about :: R -> Pt R -> Ln R -> Ln R+ln_rotate_about r c (Ln p q) = let f = pt_rotate_about r c in Ln (f p) (f q)++-- | Give translation and rotation from /p/ to /q/.+-- Magnitude is not considered.+--+-- > let l0 = Ln (Pt 0 0) (Pt 1 0)+-- > let l1 = Ln (Pt 1 1) (Pt 1 2)+-- > let (tr,(c,r)) = ln_align l0 l1+-- > ln_rotate_about r c (CG.ln_translate_pt tr l0) == l1+ln_align :: Ln R -> Ln R -> (Pt R, (Pt R, R))+ln_align p q =+ let (pt0,vc0) = ln_pt_vc p+ (pt1,vc1) = ln_pt_vc q+ (Vc _ ph0) = vc_to_polar vc0+ (Vc _ ph1) = vc_to_polar vc1+ in (pt1 - pt0,(pt1,ph1 -ph0))++-- * Ln sets++-- | 'pt_minmax' for set of 'Ln'.+lns_minmax :: Ord n => [Ln n] -> (Pt n,Pt n)+lns_minmax = ls_minmax . Ls . concatMap (\(Ln l r) -> [l,r])++lns_translate :: Num n => Vc n -> [Ln n] -> [Ln n]+lns_translate v = map (ln_translate v)++-- | Variant with 'Pt' not 'Vc'.+lns_translate_pt :: Num n => Pt n -> [Ln n] -> [Ln n]+lns_translate_pt p = map (ln_translate_pt p)++lns_multiply :: Num n => Pt n -> [Ln n] -> [Ln n]+lns_multiply p = map (ln_multiply p)++-- | Normalise to (0,m).+lns_normalise :: (Fractional n,Ord n) => n -> [Ln n] -> [Ln n]+lns_normalise m l =+ let w = wn_from_extent (lns_minmax l)+ in map (ln_scale m . ln_normalise_w w) l++-- * L(ine) s(egment) functions++-- | Alias for 'Ls'.+ls :: [Pt a] -> Ls a+ls = Ls++-- | Variant 'Ls' constructor from 'Pt' co-ordinates as duples.+mk_ls :: [(a,a)] -> Ls a+mk_ls = ls . map (uncurry Pt)++list_close :: [a] -> [a]+list_close l =+ case l of+ e:_ -> l ++ [e]+ _ -> error "list_close"++ls_close :: Ls t -> Ls t+ls_close = ls_elem_f list_close++ls_null :: Ls a -> Bool+ls_null = null . ls_elem++ls_map :: (Pt t -> Pt a) -> Ls t -> Ls a+ls_map f (Ls l) = Ls (map f l)++ls_multiply :: Num n => Pt n -> Ls n -> Ls n+ls_multiply p = ls_map (* p)++-- | Negate /y/ elements.+ls_negate_y :: (Num a) => Ls a -> Ls a+ls_negate_y = ls_map pt_negate_y++pts_minmax :: Ord a => [Pt a] -> (Pt a, Pt a)+pts_minmax s =+ case s of+ [] -> error "pts_minmax"+ p:ps -> foldl pt_minmax (p,p) ps++-- | Generate /minima/ and /maxima/ 'Point's from 'Ls'.+ls_minmax :: Ord a => Ls a -> (Pt a,Pt a)+ls_minmax = pts_minmax . ls_elem++-- | Separate 'Ls' at points where the 'Vc' from one element to the+-- next exceeds the indicated distance.+--+-- > map length (ls_separate (Vc 2 2) (map (uncurry Pt) [(0,0),(1,1),(3,3)])) == [2,1]+ls_separate :: (Ord a,Num a) => Vc a -> Ls a -> [Ls a]+ls_separate (Vc dx dy) (Ls l) =+ let f (Pt x0 y0) (Pt x1 y1) = abs (x1 - x0) < dx &&+ abs (y1 - y0) < dy+ in map Ls (segment_f f l)++-- | Delete 'Pt' from 'Ls' so that no two 'Pt' are within a tolerance+-- given by 'Vc'.+ls_tolerate :: (Ord a,Num a) => Vc a -> Ls a -> Ls a+ls_tolerate (Vc x y) (Ls l) =+ let too_close (Pt x0 y0) (Pt x1 y1) =+ let dx = abs (x1 - x0)+ dy = abs (y1 - y0)+ in dx < x && dy < y+ in Ls (delete_f too_close l)++-- | Variant of 'ls_tolerate' where 'Vc' is optional, and 'Nothing' gives 'id'.+ls_tolerate_maybe :: (Ord a,Num a) => Maybe (Vc a) -> Ls a -> Ls a+ls_tolerate_maybe i =+ case i of+ Nothing -> id+ Just i' -> ls_tolerate i'++-- | Test if point 'Pt' lies inside polygon 'Ls'.+--+-- > ls_pt_inside (mk_ls [(0,0),(1,0),(1,1),(0,1)]) (Pt 0.5 0.5) == True+ls_pt_inside :: Ls R -> Pt R -> Bool+ls_pt_inside (Ls s) (Pt x y) =+ case s of+ [] -> undefined+ l0:l -> let xs = pairs ((l0:l)++[l0])+ f (Pt x1 y1,Pt x2 y2) =+ and [y > min y1 y2+ ,y <= max y1 y2+ ,x <= max x1 x2+ ,y1 /= y2+ ,x1 == x2 ||+ x <= (y-y1)*(x2-x1)/(y2-y1)+x1]+ in odd (length (filter id (map f xs)))++-- | Variant that counts points at vertices as inside.+--+-- > ls_pt_inside_or_vertex (mk_ls [(0,0),(1,0),(1,1),(0,1)]) (Pt 0 1) == True+ls_pt_inside_or_vertex :: Ls R -> Pt R -> Bool+ls_pt_inside_or_vertex l p = p `elem` ls_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+ls_check_normalised (Ls s) = all pt_is_normal s++-- | Line co-ordinates as /x/,/y/ list.+--+-- > ls_xy [Pt 0 0,Pt 1 1] == [0,0,1,1]+ls_xy :: Ls a -> [a]+ls_xy = concatMap (\(Pt x y) -> [x,y]) . ls_elem++-- | 'Ls' average.+ls_centroid :: Fractional t => Ls t -> Pt t+ls_centroid (Ls l) =+ let (x,y) = unzip (map pt_xy l)+ length' = fromIntegral . length+ in Pt (sum x / length' x) (sum y / length' y)++-- | 'ls_map' of 'pt_rotate_about'.+ls_rotate_about :: Floating t => t -> Pt t -> Ls t -> Ls t+ls_rotate_about r c = ls_map (pt_rotate_about r c)++-- | 'ls_rotate_about' of 'ls_centroid'.+ls_rotate_about_centroid :: Floating t => t -> Ls t -> Ls t+ls_rotate_about_centroid r l = ls_rotate_about r (ls_centroid l) l++ls_elem_f :: ([Pt t] -> [Pt u]) -> Ls t -> Ls u+ls_elem_f f = Ls . f . ls_elem++ls_unlift :: (Ls t -> Ls u) -> [Pt t] -> [Pt u]+ls_unlift f = ls_elem . f . Ls++-- | Midpoints of line segments.+ls_midpoints :: Ls R -> Ls R+ls_midpoints =+ let adj l = zip l (tail l)+ in ls_elem_f (map (\(p,q) -> ln_midpoint (Ln p q)) . adj)++-- | 'pt_x' of 'ls_minmax'.+ls_minmax_x :: Ord t => Ls t -> (t,t)+ls_minmax_x = bimap1 pt_x . ls_minmax++-- | 'pt_y' of 'ls_minmax'.+ls_minmax_y :: Ord t => Ls t -> (t,t)+ls_minmax_y = bimap1 pt_y . ls_minmax++ls_to_ln_set :: Ls t -> [Ln t]+ls_to_ln_set (Ls l) = zipWith Ln l (tail l)++-- | Points at which /ln/ intersects /ls/.+ls_intersections :: Ls R -> Ln R -> [Pt R]+ls_intersections p ln = mapMaybe (ln_intersection ln) (ls_to_ln_set p)++ls_intersect_p :: (Fractional a, Ord a) => Ls a -> Ls a -> Bool+ls_intersect_p p q = any id [ln_intersect_p r s | r <- ls_to_ln_set p, s <- ls_to_ln_set q]++-- | @y@ co-ordinates of intersection with vertical line given by @(y0,y1)@ and @x@.+ls_intersections_y :: (R,R) -> Ls R -> R -> [R]+ls_intersections_y y p x = map pt_y (ls_intersections p (ln_x_aligned x y))++-- | @x@ co-ordinates of intersection with horizontal line given by @(x0,x1)@ and @y@.+ls_intersections_x :: (R,R) -> Ls R -> R -> [R]+ls_intersections_x x p y = map pt_x (ls_intersections p (ln_y_aligned y x))++-- | Shift each 'Pt' set in a sequence, the amount and direction are given+-- by /get_mm/ and /mk_vc/.+pts_sequence :: Num a => ([Pt a] -> (a,a)) -> (a -> Vc a) -> [[Pt a]] -> [[Pt a]]+pts_sequence get_mm get_vc l =+ let f st e = let (x0,x1) = get_mm e+ in (st + (x1 - x0)+ ,map (pt_translate (get_vc (st - x0))) e)+ in case l of+ l0:l' -> l0 : snd (mapAccumL f (snd (get_mm l0)) l')+ [] -> l++pts_sequence_right :: (Num t,Ord t) => t -> [[Pt t]] -> [[Pt t]]+pts_sequence_right k = pts_sequence (bimap id (+ k) . bimap1 pt_x . pts_minmax) (\x -> Vc x 0)++pts_sequence_above :: (Num t,Ord t) => t -> [[Pt t]] -> [[Pt t]]+pts_sequence_above k = pts_sequence (bimap id (+ k) . bimap1 pt_y . pts_minmax) (\y -> Vc 0 y)++ls_sequence :: Num a => (Ls a -> (a,a)) -> (a -> Vc a) -> [Ls a] -> [Ls a]+ls_sequence get_mm get_vc l = map Ls (pts_sequence (get_mm . Ls) get_vc (map ls_elem l))++-- | Shift each 'Ls' so that it is /k/ to the right of the rightmost point of the preceding 'Ls'+ls_sequence_right :: (Num t,Ord t) => t -> [Ls t] -> [Ls t]+ls_sequence_right k = ls_sequence (bimap id (+ k) . ls_minmax_x) (\x -> Vc x 0)++-- | Vertical variant of 'ls_sequence_right'.+ls_sequence_above :: (Num t,Ord t) => t -> [Ls t] -> [Ls t]+ls_sequence_above k = ls_sequence (bimap id (+ k) . ls_minmax_y) (\y -> Vc 0 y)++-- * Window++-- | Variant 'Wn' constructor.+wn' :: (a,a) -> (a,a) -> Wn a+wn' (x,y) (i,j) = Wn (Pt x y) (Vc i j)++-- | Extract /(x,y)/ and /(dx,dy)/ pairs.+--+-- > wn_extract (Wn (Pt 0 0) (Vc 1 1)) == ((0,0),(1,1))+wn_extract :: Wn a -> ((a,a),(a,a))+wn_extract (Wn (Pt x y) (Vc dx dy)) = ((x,y),(dx,dy))++-- | Show function for window with fixed precision of 'n'.+--+-- > wn_show 1 (Wn (Pt 0 0) (Vc 1 1)) == "((0.0,0.0),(1.0,1.0))"+wn_show :: Int -> Wn R -> String+wn_show n (Wn (Pt x0 y0) (Vc dx dy)) =+ let fs = printf "((%%.%df,%%.%df),(%%.%df,%%.%df))" n n n n+ in printf fs x0 y0 dx dy++-- | Unit window, lower left at origin.+wn_unit :: Num n => Wn n+wn_unit = Wn pt_origin (Vc 1 1)++-- | Square bounding circle at 'Pt' with radius.+--+-- > wn_square (Pt 0 0) 1 == wn' (-1,-1) (2,2)+wn_square :: Num n => Pt n -> n -> Wn n+wn_square (Pt x y) n = Wn (Pt (x - n) (y - n)) (Vc (n * 2) (n * 2))++-- | Square window, center at origin. /n/ is half the length of each+-- side of the square.+--+-- > wn_square_o 1 == wn' (-1,-1) (2,2)+wn_square_o :: Num n => n -> Wn n+wn_square_o = wn_square (Pt 0 0)++-- | Is 'Pt' within 'Wn' exclusive of edge.+--+-- > map (pt_in_window (wn' (0,0) (1,1))) [Pt 0.5 0.5,Pt 1 1] == [True,False]+pt_in_window :: (Ord a,Num a) => Wn a -> Pt a -> Bool+pt_in_window (Wn (Pt lx ly) (Vc dx dy)) (Pt x y) =+ let (ux,uy) = (lx+dx,ly+dy)+ in x > lx && x < ux && y > ly && y < uy++-- | 'Wn' from /(lower-left,upper-right)/ extent.+wn_from_extent :: Num a => (Pt a,Pt a) -> Wn a+wn_from_extent (Pt x0 y0,Pt x1 y1) = Wn (Pt x0 y0) (Vc (x1 - x0) (y1 - y0))++-- | 'Wn' containing 'Ls'.+--+-- > ls_window (mk_ls [(0,0),(1,1),(2,0)]) == wn' (0,0) (2,1)+ls_window :: (Num a,Ord a) => Ls a -> Wn a+ls_window = wn_from_extent . ls_minmax++pts_window :: (Num t,Ord t) => [Pt t] -> Wn t+pts_window = wn_from_extent . pts_minmax++-- | A 'Wn' that encompasses both input 'Wn's.+wn_join :: (Num a,Ord a) => Wn a -> Wn a -> Wn a+wn_join (Wn (Pt x0 y0) (Vc dx0 dy0)) (Wn (Pt x1 y1) (Vc dx1 dy1)) =+ let x = min x0 x1+ y = min y0 y1+ dx = max (x0+dx0) (x1+dx1) - x+ dy = max (y0+dy0) (y1+dy1) - y+ in Wn (Pt x y) (Vc dx dy)++wn_join_l :: (Num a,Ord a) => [Wn a] -> Wn a+wn_join_l = foldl1 wn_join++-- | Predictate to determine if two 'Wn's intersect.+wn_intersect :: (Num a,Ord a) => Wn a -> Wn a -> Bool+wn_intersect w0 w1 =+ let (Wn (Pt x0 y0) (Vc dx0 dy0)) = w0+ (Wn (Pt x1 y1) (Vc dx1 dy1)) = w1+ in not (x0 > x1+dx1 || x1 > x0+dx0 || y0 > y1+dy1 || y1 > y0+dy0)++-- | Are all points at 'Ls' within the 'Wn'.+ls_in_window :: Wn R -> Ls R -> Bool+ls_in_window w = all (pt_in_window w). ls_elem++-- | Are any points at 'Ls' within the window 'Wn'.+ls_enters_window :: Wn R -> Ls R -> Bool+ls_enters_window w = any (pt_in_window w) . ls_elem++-- | Are all points at 'Ls' outside the 'Wn'.+ls_not_in_window :: Wn R -> Ls R -> Bool+ls_not_in_window w = all (not . pt_in_window w) . ls_elem++-- | Break 'Ls' into segments that are entirely within the 'Wn'.+ls_segment_window :: Wn R -> Ls R -> [Ls R]+ls_segment_window w =+ let g [] = []+ g xs = let (i,xs') = span (pt_in_window w) xs+ in i : g (dropWhile (not . pt_in_window w) xs')+ in map Ls . filter (not . null) . g . ls_elem++-- | Normalisation function for 'Wn', ie. map 'Pt' to lie within (0,1).+wn_normalise_f :: (Ord n,Fractional n) => Wn n -> Pt n -> Pt n+wn_normalise_f (Wn (Pt x0 y0) (Vc dx dy)) (Pt x y) =+ let z = max dx dy+ in Pt ((x - x0) / z) ((y - y0) / z)++-- | Given 'Wn' normalise the 'Ls'.+ls_normalise_w :: (Ord n,Fractional n) => Wn n -> Ls n -> Ls n+ls_normalise_w w = ls_elem_f (map (wn_normalise_f w))++-- | Given 'Wn' normalise 'Ln'.+ln_normalise_w :: (Ord n,Fractional n) => Wn n -> Ln n -> Ln n+ln_normalise_w w (Ln p q) =+ let f = wn_normalise_f w+ in Ln (f p) (f q)++-- | Variant of 'ls_normalise_w', the window is determined by the+-- extent of the 'Ls'.+ls_normalise :: (Ord n,Fractional n) => Ls n -> Ls n+ls_normalise l = ls_normalise_w (wn_from_extent (ls_minmax l)) l++ls_concat :: [Ls a] -> Ls a+ls_concat = Ls . concat . map ls_elem++-- | Normalise a set of line segments using composite window.+ls_normalise_set :: (Ord n,Fractional n) => [Ls n] -> [Ls n]+ls_normalise_set l =+ let w = wn_from_extent (ls_minmax (ls_concat l))+ in map (ls_normalise_w w) l++-- | Shift lower left 'Pt' of 'Wn' by indicated 'Pt'.+pt_shift_w :: Num a => Pt a -> Wn a -> Wn a+pt_shift_w p (Wn dp ex) = Wn (p + dp) ex++-- | Negate /y/ field of lower left 'Pt' of 'Wn'.+wn_negate_y :: Num a => Wn a -> Wn a+wn_negate_y (Wn p v) = Wn (pt_negate_y p) v++-- | 'Wn' to 'Ls' (CCW), open.+wn_to_ls :: Num t => Wn t -> Ls t+wn_to_ls (Wn (Pt x y) (Vc dx dy)) =+ let (x',y') = (x + dx,y + dy)+ in Ls [Pt x y,Pt x y',Pt x' y',Pt x' y]++-- | Closed form.+wn_to_ls_closed :: Num t => Wn t -> Ls t+wn_to_ls_closed = ls_close . wn_to_ls++-- | Vector giving width and height of each cell of an (r,c) grid at w.+--+-- > wn_grid_vc div (wn_square_o 200) (8,8) == Vc 50 50+wn_grid_vc :: (t -> t -> t) -> Wn t -> (t,t) -> Vc t+wn_grid_vc div_f (Wn _ (Vc dx dy)) (r,c) = Vc (dx `div_f` c) (dy `div_f` r)++-- | Grid dividing window into indicated number of rows and columns.+-- Row order, lowest row first. Points at lower left.+--+-- > wn_grid_pt_ll div (wn_square_o 200) (8,8)+wn_grid_pt_ll :: (Enum t,Num t) => (t -> t -> t) -> Wn t -> (t,t) -> [[Pt t]]+wn_grid_pt_ll div_f w g =+ let Vc ix iy = wn_grid_vc div_f w g+ Wn (Pt x y) (Vc dx dy) = w+ f y' = map (\x' -> Pt x' y') [x,x + ix .. x + dx - ix]+ in map f [y,y + iy .. y + dy - iy]++-- | Variant with points at center.+--+-- > wn_grid_pt_c div (wn_square_o 200) (8,8)+wn_grid_pt_c :: (Enum t,Num t) => (t -> t -> t) -> Wn t -> (t,t) -> [[Pt t]]+wn_grid_pt_c div_f w g =+ let Vc ix iy = wn_grid_vc div_f w g+ v = Vc (ix `div_f` 2) (iy `div_f` 2)+ in map (map (\p -> pt_translate v p)) (wn_grid_pt_ll div_f w g)++-- | Variant with derived 'Wn' for each cell.+wn_grid_wn :: (Enum t,Num t) => (t -> t -> t) -> t -> Wn t -> (t,t) -> [[Wn t]]+wn_grid_wn div_f sc w g =+ let v = vc_scale sc (wn_grid_vc div_f w g)+ v' = vc_uop (\n -> negate (n `div_f` 2)) v+ in map (map (\p -> Wn (pt_translate v' p) v)) (wn_grid_pt_c div_f w g)++-- | Variant with derived closed 'Ls' for each cell.+--+-- > concat $ wn_grid_ls (/) 0.75 (wn_square_o 200) (8,8)+wn_grid_ls :: (Enum t,Num t) => (t -> t -> t) -> t -> Wn t -> (t,t) -> [[Ls t]]+wn_grid_ls div_f sc w = map (map wn_to_ls_closed) . wn_grid_wn div_f sc w++-- * Random++-- | Generate a random 'Pt' within 'Wn'.+--+-- > pt_random (wn_square_o 1.0)+pt_random :: (Num a,Random a) => Wn a -> IO (Pt a)+pt_random (Wn (Pt x y) (Vc dx dy)) = do+ x' <- randomRIO (x,x + dx)+ y' <- randomRIO (y,y + dy)+ return (Pt x' y')++-- | Generate a random 'P3' within cube.+--+-- > p3_random_u (-1.0,1.0)+p3_random :: Random a => (a,a) -> IO (P3 a)+p3_random (l,r) = do+ x <- randomRIO (l,r)+ y <- randomRIO (l,r)+ z <- randomRIO (l,r)+ return (P3 x y z)++-- | Generate a random 'Ln' within 'Wn'.+--+-- > ln_random (wn_square_o 1.0)+ln_random :: (Num a,Random a) => Wn a -> IO (Ln a)+ln_random w = do+ p <- pt_random w+ q <- pt_random w+ return (Ln p q)++-- * Matrix++-- | A translation matrix with independent x and y offsets.+mx_translation :: Num n => n -> n -> Matrix n+mx_translation = Matrix 1 0 0 1++-- | A scaling matrix with independent x and y scalars.+mx_scaling :: Num n => n -> n -> Matrix n+mx_scaling x y = Matrix x 0 0 y 0 0++-- | A rotation matrix through the indicated angle (in radians).+mx_rotation :: Floating n => n -> Matrix n+mx_rotation a =+ let c = cos a+ s = sin a+ t = negate s+ in Matrix c s t c 0 0++-- | The identity matrix.+mx_identity :: Num n => Matrix n+mx_identity = Matrix 1 0 0 1 0 0++mx_translate :: Num n => n -> n -> Matrix n -> Matrix n+mx_translate x y m = m * (mx_translation x y)++mx_scale :: Num n => n -> n -> Matrix n -> Matrix n+mx_scale x y m = m * (mx_scaling x y)++mx_rotate :: Floating n => n -> Matrix n -> Matrix n+mx_rotate r m = m * (mx_rotation r)++mx_scalar_multiply :: Num n => n -> Matrix n -> Matrix n+mx_scalar_multiply scalar = mx_uop (* scalar)++mx_adjoint :: Num n => Matrix n -> Matrix n+mx_adjoint (Matrix a b c d x y) =+ Matrix d (-b) (-c) a (c * y - d * x) (b * x - a * y)++mx_invert :: Fractional n => Matrix n -> Matrix n+mx_invert m =+ let Matrix xx yx xy yy _ _ = m+ d = xx * yy - yx * xy+ in mx_scalar_multiply (recip d) (mx_adjoint m)++mx_list :: Matrix n -> [n]+mx_list (Matrix a b c d e f) = [a,b,c,d,e,f]++-- | Apply a transformation matrix to a point.+pt_transform :: Num n => Matrix n -> Pt n -> Pt n+pt_transform (Matrix a1 a2 b1 b2 c1 c2) (Pt x y) =+ let x' = x * a1 + y * b1 + c1+ y' = x * a2 + y * b2 + c2+ in Pt x' y'++-- * Polygon++-- | {A,B,C,D,E} are vertices.+-- /A/ is the interior angle at vertex /A/.+-- /a/ is the distance from /E/ to /A/.+--+-- > let f p = map (pt_xy . pt_uop round) . polygon_unfold (Pt 0 0,0) p . map degrees_to_radians+-- > let rp = replicate+-- > let g n p q = f (rp n p) (rp n q)+-- > g 3 100 60 == [(0,0),(100,0),(50,87)]+-- > g 4 100 90 == [(0,0),(100,0),(100,100),(0,100)]+-- > g 5 100 108 == [(0,0),(100,0),(131,95),(50,154),(-31,95)]+-- > g 6 100 120 == [(0,0),(100,0),(150,87),(100,173),(0,173),(-50,87)]+-- > g 7 100 (900/7) == [(0,0),(100,0),(162,78),(140,176),(50,219),(-40,176),(-62,78)]+-- > g 8 100 135 == [(0,0),(100,0),(171,71),(171,171),(100,241),(0,241),(-71,171),(-71,71)]+-- > f [30,82.24,73.27,60,60] [90,90,101.5,101.5,157] == [(0,0),(30,0),(30,82),(-43,82),(-55,23)]+polygon_unfold :: (Pt R,R) -> [R] -> [R] -> [Pt R]+polygon_unfold i p q =+ let f (pt,ph0) (mg,ph) =+ let r = pt_translate (mk_vc_polar (mg,ph0)) pt+ in ((r,ph0 + (pi - ph)),r)+ rem_last = reverse . tail . reverse -- hmm...+ in fst i : rem_last (snd (mapAccumL f i (zip p q)))++-- | Inverse of 'polygon_unfold'.+--+-- > let f = polygon_param . map mk_pt+-- > let g (p,q) = (map round p,map (round . radians_to_degrees) q)+-- > let h = g . f+-- > h [(0,0),(100,0),(50,87)] == ([100,100,100],[60,60,60])+-- > h [(0,0),(100,0),(131,95),(50,154),(-31,95)] == ([100,100,100,100,100],[108,108,108,108,108])+-- > h [(0,0),(30,0),(30,82),(-43,82),(-55,23)] == ([30,82,73,60,60],[157,90,90,101,101])+polygon_param :: [Pt R] -> ([R],[R])+polygon_param p =+ let adj l = zip l (tail (cycle l))+ vc = map (vc_to_polar . ln_vc . uncurry Ln) (adj p)+ f z ph = let r = pi - (ph - z) in (ph,r `F.mod'` two_pi)+ ph0 = vc_y (last vc)+ in (map vc_x vc+ ,snd (mapAccumL f ph0 (map vc_y vc)))++-- * P3 functions++-- | Tuple constructor.+p3' :: (a,a,a) -> P3 a+p3' (x,y,z) = P3 x y z++-- | Tuple accessor.+p3_xyz :: P3 t -> (t,t,t)+p3_xyz (P3 x y z) = (x,y,z)++-- | 'P3' of (0,0,0).+--+-- > p3_origin == P3 0 0 0+p3_origin :: Num a => P3 a+p3_origin = P3 0 0 0++-- | 'P3' at /(n,n,n)/.+--+-- > p3_from_scalar 1 == P3 1 1 1+p3_from_scalar :: a -> P3 a+p3_from_scalar a = P3 a a a++-- | Scalar 'P3' '+'.+--+-- > p3_offset 1 p3_origin == P3 1 1 1+p3_offset :: Num a => a -> P3 a -> P3 a+p3_offset = p3_uop . (+)++-- | Scalar 'P3' '*'.+--+-- > p3_scale 2 (P3 1 2 3) == P3 2 4 6+p3_scale :: Num a => a -> P3 a -> P3 a+p3_scale = p3_uop . (*)++-- * Ord++-- | Given /left/ and /right/, is /x/ in range (inclusive).+--+-- > map (in_range 0 1) [-1,0,1,2] == [False,True,True,False]+in_range :: Ord a => a -> a -> a -> Bool+in_range l r x = l <= x && x <= r++-- * List++-- | Split list at element where predicate /f/ over adjacent elements+-- first holds.+--+-- > split_f (\p q -> q - p < 3) [1,2,4,7,11] == ([1,2,4],[7,11])+split_f :: (a -> a -> Bool) -> [a] -> ([a],[a])+split_f f =+ let go i [] = (reverse i,[])+ go i [p] = (reverse (p:i), [])+ go i (p:q:r) =+ if f p q+ then go (p:i) (q:r)+ else (reverse (p:i),q:r)+ in go []++-- | Variant on 'split_f' that segments input.+--+-- > segment_f (\p q -> abs (q - p) < 3) [1,3,7,9,15] == [[1,3],[7,9],[15]]+segment_f :: (a -> a -> Bool) -> [a] -> [[a]]+segment_f f xs =+ let (p,q) = split_f f xs+ in if null q+ then [p]+ else p : segment_f f q++-- | Delete elements of a list using a predicate over the+-- previous and current elements.+delete_f :: (a -> a -> Bool) -> [a] -> [a]+delete_f f =+ let go [] = []+ go [p] = [p]+ go (p:q:r) =+ if f p q+ then go (p:r)+ else p : go (q:r)+ in go++-- | All adjacent pairs of a list.+--+-- > pairs [1..5] == [(1,2),(2,3),(3,4),(4,5)]+pairs :: [x] -> [(x,x)]+pairs l =+ case l of+ x:y:z -> (x,y) : pairs (y:z)+ _ -> []++-- * Bifunctor++-- > bimap id succ (0,0) == (0,1)+-- > fmap succ (0,0) == (0,1)+bimap :: (a -> b) -> (c -> d) -> (a,c) -> (b,d)+bimap f g (p,q) = (f p,g q)++bimap1 :: (c -> d) -> (c,c) -> (d,d)+bimap1 f (p,q) = (f p,f q)+
+ Data/CG/Minus/Geometry.hs view
@@ -0,0 +1,171 @@+{- | Simple geometric functions.++Polygon variables:++n = degree, a = side length, r,ir = inradius, R,cr = circumradius, A,ar = area, s = sagitta++-}+module Data.CG.Minus.Geometry where++import Data.Complex {- base -}++-- * Math++two_pi :: Floating n => n+two_pi = 2 * pi++-- | Square, inverse of 'sqrt'.+--+-- > sqrt (sqr 3) == 3+sqr :: Num a => a -> a+sqr n = n * n++-- | Secant.+sec :: Floating a => a -> a+sec z = 1 / cos z++-- | Cotangent.+cot :: Floating a => a -> a+cot z = 1 / tan z++-- | Degrees to radians.+--+-- > degrees_to_radians 60 == (pi/3)+degrees_to_radians :: Floating n => n -> n+degrees_to_radians = (* pi) . (/ 180)++-- > radians_to_degrees (pi/3) == 60+radians_to_degrees :: Floating n => n -> n+radians_to_degrees = (* 180) . (/ pi)++polar_to_rectangular :: Floating t => (t,t) -> (t,t)+polar_to_rectangular (mg,ph) =+ let c = mkPolar mg ph+ in (realPart c,imagPart c)++rectangular_to_polar :: RealFloat a => (a, a) -> (a,a)+rectangular_to_polar (x,y) = polar (x :+ y)++-- * Triangle++-- > triangle_semiperimeter_sss 1 1 1 == 1.5+triangle_semiperimeter_sss :: Fractional a => a -> a -> a -> a+triangle_semiperimeter_sss a b c = (1/2) * (a + b + c)++-- > triangle_area_herons_sss 1 1 1+triangle_area_herons_sss :: Floating a => a -> a -> a -> a+triangle_area_herons_sss a b c =+ let s = triangle_semiperimeter_sss a b c+ in sqrt (s * (s - a) * (s - b) * (s - c))++-- > triangle_area_aas (radians 120) (radians 30) 1+triangle_area_aas :: Floating a => a -> a -> a -> a+triangle_area_aas alpha beta a =+ let gamma = pi - alpha - beta+ n = sqr a * sin beta * sin gamma+ d = 2 * sin alpha+ in n / d++-- > triangle_area_asa (radians 30) 1 (radians 30)+triangle_area_asa :: Floating a => a -> a -> a -> a+triangle_area_asa alpha c beta =+ let n = sqr c+ d = 2 * (cot alpha + cot beta)+ in n / d++-- > triangle_side_asa (radians 30) 1 (radians 30)+triangle_side_asa :: Floating a => a -> a -> a -> a+triangle_side_asa alpha c beta =+ let gamma = pi - alpha - beta+ in (sin alpha / sin gamma) * c++-- | <http://mathworld.wolfram.com/LawofCosines.html>+law_of_cosines :: Floating a => a -> a -> a -> a+law_of_cosines s a s' = sqrt (sqr s + sqr s' - 2 * s * s' * cos a)++-- > triangle_side_sas 0.5 (radians 120) 0.5+triangle_side_sas :: Floating a => a -> a -> a -> a+triangle_side_sas = law_of_cosines++triangle_centroid :: Fractional t => (t,t) -> (t,t) -> (t,t) -> (t,t)+triangle_centroid (x1,y1) (x2,y2) (x3,y3) =+ let x = (x1 + x2 + x3) / 3+ y = (y1 + y2 + y3) / 3+ in (x,y)++-- * Pentagon++-- > pentagon_circumradius_a 1+pentagon_circumradius_a :: Floating a => a -> a+pentagon_circumradius_a a = 0.1 * sqrt (50 + 10 * sqrt 5) * a++-- > pentagon_inradius_a 1+pentagon_inradius_a :: Floating a => a -> a+pentagon_inradius_a a = 0.1 * sqrt (25 + 10 * sqrt 5) * a++-- > pentagon_sagitta_a 1+pentagon_sagitta_a :: Floating a => a -> a+pentagon_sagitta_a a = 0.1 * sqrt (25 - 10 * sqrt 5) * a++-- > pentagon_area_a 1+pentagon_area_a :: Floating a => a -> a+pentagon_area_a a = 0.25 * sqrt (25 + 10 * sqrt 5) * a * a++-- * Hexagon++-- > hexagon_inradius_a 1 == 0.8660254037844386+hexagon_inradius_a :: Floating a => a -> a+hexagon_inradius_a a = 0.5 * sqrt 3 * a++-- | For hexagons, the side length (a) and the circumradius (R) are equal.+--+-- > hexagon_circumradius_a 1 == 1+hexagon_circumradius_a :: a -> a+hexagon_circumradius_a = id++-- > hexagon_sagitta_a 1 == 0.1339745962155614+hexagon_sagitta_a :: Floating a => a -> a+hexagon_sagitta_a a = 0.5 * (2 - sqrt 3) * a++-- > hexagon_area_a 1 == 2.598076211353316+hexagon_area_a :: Floating a => a -> a+hexagon_area_a a = 1.5 * sqrt 3 * sqr a++-- * Polygon++{- | <http://mathworld.wolfram.com/PolygonArea.html>++Note that the area of a convex polygon is defined to be positive if+the points are arranged in a counterclockwise order, and negative+if they are in clockwise order (Beyer 1987).++> let u = [(0,0),(1,0),(1,1),(0,1)]+> polygon_signed_area u == 1+> polygon_signed_area (reverse u) == -1++-}+polygon_signed_area :: Fractional t => [(t,t)] -> t+polygon_signed_area p =+ let q = zip p (tail (cycle p))+ f ((x1,y1),(x2,y2)) = x1 * y2 - x2 * y1+ in sum (map f q) / 2++-- > regular_polygon_side_length 5 1+regular_polygon_side_length :: Floating a => a -> a -> a+regular_polygon_side_length n cr = 2 * cr * sin (pi / n)++-- > map (\n -> regular_polygon_inradius n 1) [3,4,5,6]+regular_polygon_inradius :: Floating a => a -> a -> a+regular_polygon_inradius n cr = cr * cos (pi / n)++-- > regular_polygon_circumradius 5 1+regular_polygon_circumradius :: Floating a => a -> a -> a+regular_polygon_circumradius n r = r * sec (pi / n)++-- > regular_polygon_area 6 1+regular_polygon_area :: Floating a => a -> a -> a+regular_polygon_area n cr = 0.5 * n * sqr cr * sin (two_pi / n)++-- > regular_polygon_sagitta 6 1+regular_polygon_sagitta :: Floating a => a -> a -> a+regular_polygon_sagitta n cr = 2 * cr * sqr (sin (pi / (2 * n)))
+ Data/CG/Minus/Picture.hs view
@@ -0,0 +1,103 @@+-- | Very simple picture model.+module Data.CG.Minus.Picture where++import Data.List {- base -}+import Data.Maybe {- base -}++import Data.CG.Minus.Types {- hcg-minus -}+import qualified Data.CG.Minus as CG {- hcg-minus -}++type Line_Width = R++type Dash = ([R],R)++data Pen = Pen Line_Width Ca Dash+ deriving (Eq,Show)++data Mark = Line Pen (Ln R)+ | Polygon (Either Pen Ca) [Pt R]+ | Circle (Either Pen Ca) (Pt R,R)+ | Dot Ca (Pt R,R)+ deriving (Eq,Show)++type Picture = [Mark]++no_dash :: Dash+no_dash = ([],0)++line_seq :: Pen -> [Pt R] -> [Mark]+line_seq pen =+ let adj l = zip l (tail l)+ in map (Line pen . uncurry Ln) . adj++polygon_l :: Pen -> [Pt R] -> Mark+polygon_l pen = Polygon (Left pen)++polygon_f :: Ca -> [Pt R] -> Mark+polygon_f clr = Polygon (Right clr)++circle_l :: Pen -> (Pt R,R) -> Mark+circle_l pen = Circle (Left pen)++circle_f :: Ca -> (Pt R,R) -> Mark+circle_f clr = Circle (Right clr)++mark_wn :: Mark -> Wn R+mark_wn m =+ case m of+ Line _ ln -> CG.ln_wn ln+ Polygon _ p -> CG.pts_window p+ Circle _ (c,r) -> CG.wn_square c r+ Dot _ (c,r) -> CG.wn_square c r++mark_normal :: Mark -> Mark+mark_normal m =+ case m of+ Line p ln -> Line p (CG.ln_sort ln)+ Polygon _ _ -> m -- should ensure CCW+ Circle _ _ -> m+ Dot _ _ -> m++mark_pt_set :: Mark -> [Pt R]+mark_pt_set m =+ case m of+ Line _ (Ln p q) -> [p,q]+ Polygon _ p -> p+ Circle _ (p,_) -> [p]+ Dot _ (p,_) -> [p]++mark_ln :: Mark -> Maybe (Ln R)+mark_ln m =+ case m of+ Line _ l -> Just l+ _ -> Nothing++mark_circle :: Mark -> Maybe (Pt R,R)+mark_circle m =+ case m of+ Circle _ c -> Just c+ _ -> Nothing++picture_pt_set :: Picture -> [Pt R]+picture_pt_set = concatMap mark_pt_set++picture_ln_set :: Picture -> [Ln R]+picture_ln_set = mapMaybe mark_ln++picture_ln_intersections :: Picture -> [Pt R]+picture_ln_intersections p =+ let l = picture_ln_set p+ in catMaybes [CG.ln_intersection l0 l1 | l0 <- l, l1 <- l, l0 /= l1]++picture_ln_circle_intersections :: Picture -> [Pt R]+picture_ln_circle_intersections p =+ let l_set = picture_ln_set p+ c_set = mapMaybe mark_circle p+ in concat [CG.ln_circle_intersection_set l c | l <- l_set, c <- c_set]++picture_normalise :: Picture -> Picture+picture_normalise = nub . map mark_normal++picture_wn :: Picture -> Wn R+picture_wn = foldl1 CG.wn_join . map mark_wn+
+ Data/CG/Minus/Polygon.hs view
@@ -0,0 +1,60 @@+module Data.CG.Minus.Polygon where++import Data.CG.Minus.Core+import Data.CG.Minus.Types++-- | Polygon.+type Polygon = [Pt R]++-- | Degree is the number of points.+--+-- > let tri = [Pt 0 0,Pt 1 0,Pt 0 1]+-- > polygon_degree tri == 3+polygon_degree :: Polygon -> Int+polygon_degree = length++-- | List of /k/ edges of /k/ polygon.+--+-- > polygon_edges tri == zipWith Ln tri (tail (cycle tri))+polygon_edges :: Polygon -> [Ln R]+polygon_edges =+ let adj_cyc l = zip l (tail (cycle l))+ in map (uncurry Ln) . adj_cyc++-- | Index /n/th point.+polygon_pt :: Polygon -> Int -> Pt R+polygon_pt p k = p !! k++-- | Index /n/th edge.+polygon_edge :: Polygon -> Int -> Ln R+polygon_edge p k = polygon_edges p !! k++polygon_align_ln :: Polygon -> Int -> (Int,Bool) -> Polygon+polygon_align_ln p k0 (k1,k1_rev) =+ let l0 = polygon_edge p k0+ l1 = (if k1_rev then ln_reverse else id) (polygon_edge p k1)+ (tr,(c,r)) = ln_align l0 l1+ f = pt_rotate_about r c . pt_translate (pt_to_vc tr)+ in map f p++polygon_reflect_ln_md :: Ln R -> Polygon -> Polygon+polygon_reflect_ln_md ln = map (pt_ln_reflect_md ln)++polygon_reflect_xy :: (R,R) -> Polygon -> Polygon+polygon_reflect_xy xy = map (pt_reflect_xy xy)++polygon_edge_reflect :: Polygon -> Int -> Polygon+polygon_edge_reflect p k = polygon_reflect_ln_md (polygon_edge p k) p++polygon_pt_reflect :: Polygon -> Int -> Polygon+polygon_pt_reflect p k = polygon_reflect_xy (pt_xy (polygon_pt p k)) p++polygon_reflect_x_right :: [Pt R] -> [Pt R]+polygon_reflect_x_right l =+ let m = maximum (map pt_x l)+ in map (pt_reflect_x m) l++polygon_reflect_y_up :: [Pt R] -> [Pt R]+polygon_reflect_y_up l =+ let m = maximum (map pt_y l)+ in map (pt_reflect_y m) l
+ Data/CG/Minus/Types.hs view
@@ -0,0 +1,148 @@+-- | Types+module Data.CG.Minus.Types where++import qualified Data.Colour as C {- colour -}++-- | Two-dimensional point.+--+-- Pt are 'Num', pointwise, ie:+--+-- > Pt 1 2 + Pt 3 4 == Pt 4 6+-- > Pt 1 2 * Pt 3 4 == Pt 3 8+-- > negate (Pt 0 1) == Pt 0 (-1)+-- > abs (Pt (-1) 1) == Pt 1 1+-- > signum (Pt (-1/2) (1/2)) == Pt (-1) 1+data Pt a = Pt {pt_x :: a,pt_y :: a} deriving (Eq,Ord,Show)++-- | Unary operator at 'Pt', ie. basis for 'Num' instances.+pt_uop :: (a -> b) -> Pt a -> Pt b+pt_uop f (Pt x y) = Pt (f x) (f y)++-- | Binary operator at 'Pt', ie. basis for 'Num' instances.+pt_binop :: (a -> b -> c) -> Pt a -> Pt b -> Pt c+pt_binop f (Pt x1 y1) (Pt x2 y2) = Pt (x1 `f` x2) (y1 `f` y2)++instance Num a => Num (Pt a) where+ (+) = pt_binop (+)+ (-) = pt_binop (-)+ (*) = pt_binop (*)+ negate = pt_uop negate+ abs = pt_uop abs+ signum = pt_uop signum+ fromInteger n = let n' = fromInteger n in Pt n' n'++data P3 a = P3 {p3_x :: a,p3_y :: a,p3_z :: a} deriving (Eq,Ord,Show)++-- | Unary operator at 'P3', ie. basis for 'Num' instances.+p3_uop :: (a -> b) -> P3 a -> P3 b+p3_uop f (P3 x y z) = P3 (f x) (f y) (f z)++-- | Binary operator at 'P3', ie. basis for 'Num' instances.+p3_binop :: (a -> b -> c) -> P3 a -> P3 b -> P3 c+p3_binop f (P3 x1 y1 z1) (P3 x2 y2 z2) = P3 (x1 `f` x2) (y1 `f` y2) (z1 `f` z2)++instance Num a => Num (P3 a) where+ (+) = p3_binop (+)+ (-) = p3_binop (-)+ (*) = p3_binop (*)+ negate = p3_uop negate+ abs = p3_uop abs+ signum = p3_uop signum+ fromInteger n = let n' = fromInteger n in P3 n' n' n'++-- | Two-dimensional vector. Vector are 'Num' in the same manner as 'Pt'.+data Vc a = Vc {vc_x :: a,vc_y :: a} deriving (Eq,Ord,Show)++-- | Unary operator at 'Vc', ie. basis for 'Num' instances.+vc_uop :: (a -> b) -> Vc a -> Vc b+vc_uop f (Vc x y) = Vc (f x) (f y)++-- | Binary operator at 'Vc', ie. basis for 'Num' instances.+vc_binop :: (a -> b -> c) -> Vc a -> Vc b -> Vc c+vc_binop f (Vc x1 y1) (Vc x2 y2) = Vc (x1 `f` x2) (y1 `f` y2)++instance Num a => Num (Vc a) where+ (+) = vc_binop (+)+ (-) = vc_binop (-)+ (*) = vc_binop (*)+ negate = vc_uop negate+ abs = vc_uop abs+ signum = vc_uop signum+ fromInteger n = let n' = fromInteger n in Vc n' n'++-- | Two-dimensional line.+--+-- > ln_start (Ln (Pt 0 0) (Pt 1 1)) == Pt 0 0+-- > ln_end (Ln (Pt 0 0) (Pt 1 1)) == Pt 1 1+data Ln a = Ln {ln_start :: Pt a,ln_end :: Pt a} deriving (Eq,Ord,Show)++-- | Line segments.+data Ls a = Ls {ls_elem :: [Pt a]} deriving (Eq,Show)++-- | Window, given by a /lower left/ 'Pt' and an /extent/ 'Vc'.+data Wn a = Wn {wn_ll :: Pt a,wn_ex :: Vc a} deriving (Eq,Show)++-- | Real number, synonym for 'Double'.+type R = Double++-- | Transformation matrix data type (Matrix a1 a2 b1 b2 c1 c2)+-- x' = a1 * x + b1 * y + c1+-- y' = a2 * x + b2 * y + c2+data Matrix n = Matrix n n n n n n deriving (Eq,Show)++-- | See 'pt_transform' for typed variant.+matrix_apply_raw :: Num t => (t,t,t,t,t,t) -> (t,t) -> (t,t)+matrix_apply_raw (a1,a2,b1,b2,c1,c2) (x,y) =+ let x' = x * a1 + y * b1 + c1+ y' = x * a2 + y * b2 + c2+ in (x',y')++-- | Enumeration of 'Matrix' indices.+data Matrix_Index = I0 | I1 | I2++mx_row :: Num n => Matrix n -> Matrix_Index -> (n,n,n)+mx_row (Matrix a b c d e f) i =+ case i of+ I0 -> (a,b,0)+ I1 -> (c,d,0)+ I2 -> (e,f,1)++mx_col :: Num n => Matrix n -> Matrix_Index -> (n,n,n)+mx_col (Matrix a b c d e f) i =+ case i of+ I0 -> (a,c,e)+ I1 -> (b,d,f)+ I2 -> (0,0,1)++mx_multiply :: Num n => Matrix n -> Matrix n -> Matrix n+mx_multiply a b =+ let f i j = let (r1,r2,r3) = mx_row a i+ (c1,c2,c3) = mx_col b j+ in r1 * c1 + r2 * c2 + r3 * c3+ in Matrix (f I0 I0) (f I0 I1) (f I1 I0) (f I1 I1) (f I2 I0) (f I2 I1)++-- | Pointwise unary operator.+mx_uop :: (n -> n) -> Matrix n -> Matrix n+mx_uop g (Matrix a b c d e f) =+ Matrix (g a) (g b) (g c) (g d) (g e) (g f)++-- | Pointwise binary operator.+mx_binop :: (n -> n -> n) -> Matrix n -> Matrix n -> Matrix n+mx_binop g (Matrix a b c d e f) (Matrix a' b' c' d' e' f') =+ Matrix (g a a') (g b b') (g c c') (g d d') (g e e') (g f f')++instance Num n => Num (Matrix n) where+ (*) = mx_multiply+ (+) = mx_binop (+)+ (-) = mx_binop (-)+ abs = mx_uop abs+ signum = mx_uop signum+ fromInteger n = let n' = fromInteger n+ in Matrix n' 0 0 n' 0 0++-- | Opaque colour.+type C = C.Colour R++-- | Colour with /alpha/ channel.+type Ca = C.AlphaColour R+
README view
@@ -5,7 +5,7 @@ [hs]: http://haskell.org/ -© [rohan drape][rd], 2009-2014, [gpl]+© [rohan drape][rd], 2009-2017, [gpl] [rd]: http://rd.slavepianos.org/ [gpl]: http://gnu.org/copyleft/
hcg-minus.cabal view
@@ -1,29 +1,44 @@ name: hcg-minus-version: 0.15+version: 0.16 synopsis: haskell cg (minus) description: cg (minus) library license: BSD3 category: Math-copyright: (c) rohan drape, 2011-2014+copyright: (c) rohan drape, 2011-2017 author: Rohan Drape maintainer: rd@slavepianos.org stability: Experimental homepage: http://rd.slavepianos.org/t/hcg-minus-tested-with: GHC == 7.8.2+tested-with: GHC == 8.0.1 build-type: Simple cabal-version: >= 1.8 data-files: README library- build-depends: base == 4.*,- colour+ build-depends: base == 4.* && < 5,+ colour,+ random ghc-options: -Wall -fwarn-tabs exposed-modules: Data.CG.Minus Data.CG.Minus.Arrow Data.CG.Minus.Bearing+ Data.CG.Minus.Bezier Data.CG.Minus.Colour+ Data.CG.Minus.Colour.Crayola+ Data.CG.Minus.Colour.Grey+ Data.CG.Minus.Colour.Names+ Data.CG.Minus.Colour.NCS Data.CG.Minus.Colour.Planck+ Data.CG.Minus.Colour.RAL+ Data.CG.Minus.Colour.RYB+ Data.CG.Minus.Colour.SVG+ Data.CG.Minus.Colour.VGA+ Data.CG.Minus.Core+ Data.CG.Minus.Geometry+ Data.CG.Minus.Picture+ Data.CG.Minus.Polygon+ Data.CG.Minus.Types Source-Repository head Type: darcs