module Music.Theory.Diagram.Path where
import Data.CG.Minus
import Data.Function
import Data.List
import Data.Maybe
parts :: [a] -> [([a],a,[a])]
parts inp =
let f p i q = let r = (p,i,q)
in case q of
[] -> [r]
(q':q'') -> r : f (p ++ [i]) q' q''
in case inp of
(x:xs) -> f [] x xs
[] -> []
parts' :: [a] -> [(a,[a])]
parts' = let f (p,i,q) = (i,p++q) in map f . parts
gather :: (Ord a) => [(a,i)] -> [(a,[i])]
gather =
let f xs = (fst (head xs),map snd xs)
in map f . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
ln_on :: Ln R -> Ln R -> Bool
ln_on (Ln p q) l = pt_on_line l p || pt_on_line l q
overlap :: Ln R -> Ln R -> Bool
overlap p q = ln_parallel p q && (ln_on p q || ln_on q p)
includes :: Ln R -> Ln R -> Bool
includes l (Ln p q) =
let f = pt_on_line l
in f p && f q
is_included :: Ln R -> Ln R -> Bool
is_included = flip includes
pt_fn :: ((a,a) -> b) -> Pt a -> b
pt_fn f (Pt x y) = f (x,y)
ln_fn :: (Num a,Eq a) => ((Pt a,Pt a) -> b) -> Ln a -> b
ln_fn f (Ln p q) = f (p,q)
ln_pt_fn :: (Num a,Eq a,Num b,Eq b) => (Pt a -> Pt b) -> Ln a -> Ln b
ln_pt_fn f = ln_fn (\(p,q) -> Ln (f p) (f q))
to_unit :: R -> [Ln R] -> [Ln R]
to_unit m p =
let p' = concatMap (ln_fn (\(i,j) -> [i,j])) p
x = maximum (map pt_x p')
y = maximum (map pt_y p')
f n = pt_fn (\(i,j) -> Pt (i*m/n) (m (j*m/n)))
g n = ln_pt_fn (f n)
in map (g (max x y)) p
data Orientation a = Vertical | Horizontal | Diagonal a
deriving (Eq,Show)
orientation :: (Fractional a,Eq a) => Ln a -> Orientation a
orientation l =
case ln_slope l of
Nothing -> Vertical
Just m -> if m == 0 then Horizontal else Diagonal m
type Shift_Map a = [(Pt a,[Orientation a])]
mk_shift_map :: [Ln R] -> Shift_Map R
mk_shift_map =
let f i l = if overlap i l then Just (i,orientation l) else Nothing
g (x,i,_) = mapMaybe (f i) x
h (l0,o) = let (p,q) = ln_pt l0 in [(p,o),(q,o)]
in gather . concatMap h . concatMap g . parts
shift_map_pt :: Shift_Map R -> Pt R -> Pt R
shift_map_pt tbl i =
let n = 0.1
Pt x y = i
g o = let x' = if Vertical `elem` o then x+n else x
y' = if Horizontal `elem` o then y+n else y
in Pt x' y'
in maybe i g (lookup i tbl)
shift_map_ln :: Shift_Map R -> Ln R -> Ln R
shift_map_ln tbl = ln_pt_fn (shift_map_pt tbl)
type Shift_Table a = [(Pt a,Pt a)]
mk_shift_tbl_m :: (Ln R,Bool) -> Maybe (Shift_Table R)
mk_shift_tbl_m (Ln p1 p2,occ) =
if occ
then let Pt x1 y1 = p1
Pt x2 y2 = p2
n = 0.1
in if x1 == x2
then let x = x1 + n in Just [(p1,Pt x y1),(p2,Pt x y2)]
else let y = y1 + n in Just [(p1,Pt x1 y),(p2,Pt x2 y)]
else Nothing
mk_shift_tbl :: Collision_Table -> Shift_Table R
mk_shift_tbl = concat . mapMaybe mk_shift_tbl_m
shift_table_ln :: Shift_Table R -> Ln R -> Ln R
shift_table_ln tbl =
let f i = fromMaybe i (lookup i tbl)
in ln_fn (\(p,q) -> Ln (f p) (f q))
type Collision_Table = [(Ln R,Bool)]
mk_collision_table :: [Ln R] -> Collision_Table
mk_collision_table =
let f (x,xs) = (x,any (is_included x) xs)
in map f . parts'
collision_table_rewrite :: Collision_Table -> [Ln R]
collision_table_rewrite xs =
let tbl = mk_shift_tbl xs
in map (shift_table_ln tbl . fst) xs
type Path_Diagram = [(Int,Int)]
path_diagram_ln :: Path_Diagram -> [Ln R]
path_diagram_ln xs =
let xs' = map (pt_from_i . uncurry Pt) xs
in zipWith Ln xs' (tail xs')
mk_path_ct :: Path_Diagram -> [Ln R]
mk_path_ct = collision_table_rewrite . mk_collision_table . path_diagram_ln
mk_path_sm :: Path_Diagram -> [Ln R]
mk_path_sm p =
let p' = path_diagram_ln p
in map (shift_map_ln (mk_shift_map p')) p'