diff --git a/Data/CG/Minus.hs b/Data/CG/Minus.hs
--- a/Data/CG/Minus.hs
+++ b/Data/CG/Minus.hs
@@ -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
--- .
---
--- > 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
diff --git a/Data/CG/Minus/Arrow.hs b/Data/CG/Minus/Arrow.hs
--- a/Data/CG/Minus/Arrow.hs
+++ b/Data/CG/Minus/Arrow.hs
@@ -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)
diff --git a/Data/CG/Minus/Bearing.hs b/Data/CG/Minus/Bearing.hs
--- a/Data/CG/Minus/Bearing.hs
+++ b/Data/CG/Minus/Bearing.hs
@@ -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
diff --git a/Data/CG/Minus/Bezier.hs b/Data/CG/Minus/Bezier.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Bezier.hs
@@ -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
diff --git a/Data/CG/Minus/Colour.hs b/Data/CG/Minus/Colour.hs
--- a/Data/CG/Minus/Colour.hs
+++ b/Data/CG/Minus/Colour.hs
@@ -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)
diff --git a/Data/CG/Minus/Colour/Crayola.hs b/Data/CG/Minus/Colour/Crayola.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Colour/Crayola.hs
@@ -0,0 +1,181 @@
+-- |
+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
+
diff --git a/Data/CG/Minus/Colour/Grey.hs b/Data/CG/Minus/Colour/Grey.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Colour/Grey.hs
@@ -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
diff --git a/Data/CG/Minus/Colour/NCS.hs b/Data/CG/Minus/Colour/NCS.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Colour/NCS.hs
@@ -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)
diff --git a/Data/CG/Minus/Colour/Names.hs b/Data/CG/Minus/Colour/Names.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Colour/Names.hs
@@ -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)
+ ]
diff --git a/Data/CG/Minus/Colour/Planck.hs b/Data/CG/Minus/Colour/Planck.hs
--- a/Data/CG/Minus/Colour/Planck.hs
+++ b/Data/CG/Minus/Colour/Planck.hs
@@ -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
diff --git a/Data/CG/Minus/Colour/RAL.hs b/Data/CG/Minus/Colour/RAL.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Colour/RAL.hs
@@ -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
+
diff --git a/Data/CG/Minus/Colour/RYB.hs b/Data/CG/Minus/Colour/RYB.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Colour/RYB.hs
@@ -0,0 +1,135 @@
+-- | &
+--
+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
diff --git a/Data/CG/Minus/Colour/SVG.hs b/Data/CG/Minus/Colour/SVG.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Colour/SVG.hs
@@ -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.
+--
+--
+-- > 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
diff --git a/Data/CG/Minus/Colour/VGA.hs b/Data/CG/Minus/Colour/VGA.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Colour/VGA.hs
@@ -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
diff --git a/Data/CG/Minus/Core.hs b/Data/CG/Minus/Core.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Core.hs
@@ -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'.
+
+
+
+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
+--
+--
+-- > 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
+-- .
+--
+-- > 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)
+
diff --git a/Data/CG/Minus/Geometry.hs b/Data/CG/Minus/Geometry.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Geometry.hs
@@ -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
+
+-- |
+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
+
+{- |
+
+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)))
diff --git a/Data/CG/Minus/Picture.hs b/Data/CG/Minus/Picture.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Picture.hs
@@ -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
+
diff --git a/Data/CG/Minus/Polygon.hs b/Data/CG/Minus/Polygon.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Polygon.hs
@@ -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
diff --git a/Data/CG/Minus/Types.hs b/Data/CG/Minus/Types.hs
new file mode 100644
--- /dev/null
+++ b/Data/CG/Minus/Types.hs
@@ -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
+
diff --git a/README b/README
--- a/README
+++ b/README
@@ -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/
diff --git a/hcg-minus.cabal b/hcg-minus.cabal
--- a/hcg-minus.cabal
+++ b/hcg-minus.cabal
@@ -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