-- Copyright 2013 Evan Laforge -- This program is distributed under the terms of the GNU General Public -- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt {-# LANGUAGE CPP #-} -- | Operations on 'Skeleton's. -- -- A skeleton is a tree, but it's stored as a "Data.Graph" and converted to -- a tree when needed. This seems weird, but at the time it seemed overly -- awkward to add and remove edges to a tree, and to detect cycles, while -- graphs have those operations built in. In retrospect, dealing with -- Data.Graph was probably more of a pain, so maybe someday if I have a lot of -- extra time and feel like some aggravation I'll see about redoing Skeleton as -- a Tree. I could also maybe clean up "Ui.TrackTree". module Ui.Skeleton ( Skeleton, Edge , empty, make, draw , has_edge, add_edges, remove_edges , lonely_vertex, flatten, to_forest, parents, children , insert, remove, toggle_edge , splice_above, splice_below , move #ifdef TESTING , module Ui.Skeleton #endif ) where import qualified Data.Array.IArray as IArray import qualified Data.Graph as Graph import qualified Data.List as List import qualified Data.Tree as Tree import qualified Util.Graphs as Graphs import qualified Util.Seq as Seq import qualified Util.Serialize as Serialize import Global import Types -- | The skeleton describes a hierarchical relationship between tracks. It's -- used at the UI level only to display the hierarchy visually, but the -- deriver level will presumably use it for derivation. A given track may -- appear multiple times or not at all. newtype Skeleton = Skeleton Graph.Graph deriving (ReadPrec [Skeleton] ReadPrec Skeleton Vertex -> ReadS Skeleton ReadS [Skeleton] (Vertex -> ReadS Skeleton) -> ReadS [Skeleton] -> ReadPrec Skeleton -> ReadPrec [Skeleton] -> Read Skeleton forall a. (Vertex -> ReadS a) -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a readListPrec :: ReadPrec [Skeleton] $creadListPrec :: ReadPrec [Skeleton] readPrec :: ReadPrec Skeleton $creadPrec :: ReadPrec Skeleton readList :: ReadS [Skeleton] $creadList :: ReadS [Skeleton] readsPrec :: Vertex -> ReadS Skeleton $creadsPrec :: Vertex -> ReadS Skeleton Read, Vertex -> Skeleton -> ShowS [Skeleton] -> ShowS Skeleton -> String (Vertex -> Skeleton -> ShowS) -> (Skeleton -> String) -> ([Skeleton] -> ShowS) -> Show Skeleton forall a. (Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [Skeleton] -> ShowS $cshowList :: [Skeleton] -> ShowS show :: Skeleton -> String $cshow :: Skeleton -> String showsPrec :: Vertex -> Skeleton -> ShowS $cshowsPrec :: Vertex -> Skeleton -> ShowS Show, Get Skeleton Putter Skeleton Putter Skeleton -> Get Skeleton -> Serialize Skeleton forall a. Putter a -> Get a -> Serialize a get :: Get Skeleton $cget :: Get Skeleton put :: Putter Skeleton $cput :: Putter Skeleton Serialize.Serialize) instance Pretty Skeleton where pretty :: Skeleton -> Text pretty = [Edge] -> Text forall a. Pretty a => a -> Text pretty ([Edge] -> Text) -> (Skeleton -> [Edge]) -> Skeleton -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . Skeleton -> [Edge] flatten -- Data.Graph is just a type synonym to Data.Array, which means that -- 'make [(1, 2), (1, 3)]' compare inequal even though they describe the same -- graph. instance Eq Skeleton where Skeleton s1 == :: Skeleton -> Skeleton -> Bool == Skeleton s2 = Skeleton -> [Edge] flatten Skeleton s1 [Edge] -> [Edge] -> Bool forall a. Eq a => a -> a -> Bool == Skeleton -> [Edge] flatten Skeleton s2 -- | This is @(parent, child)@. type Edge = (TrackNum, TrackNum) -- Graph Vertex is an Int and so is TrackNum, so no conversion is required. empty :: Skeleton empty :: Skeleton empty = Graph -> Skeleton Skeleton (Edge -> [Edge] -> Graph Graph.buildG (Vertex 0, -Vertex 1) []) make :: [Edge] -> Skeleton make :: [Edge] -> Skeleton make [Edge] edges = Graph -> Skeleton Skeleton ([Edge] -> Graph Graphs.build [Edge] edges) draw :: Skeleton -> String draw :: Skeleton -> String draw (Skeleton Graph graph) = Graph -> String Graphs.draw Graph graph has_edge :: Skeleton -> Edge -> Bool has_edge :: Skeleton -> Edge -> Bool has_edge (Skeleton Graph skel) Edge edge = Graph -> Edge -> Bool Graphs.has_edge Graph skel Edge edge add_edges :: [Edge] -> Skeleton -> Maybe Skeleton add_edges :: [Edge] -> Skeleton -> Maybe Skeleton add_edges [Edge] edges = Skeleton -> Maybe Skeleton acyclic (Skeleton -> Maybe Skeleton) -> (Skeleton -> Skeleton) -> Skeleton -> Maybe Skeleton forall b c a. (b -> c) -> (a -> b) -> a -> c . (Graph -> Graph) -> Skeleton -> Skeleton map_skel ([Edge] -> Graph -> Graph Graphs.add_edges [Edge] edges) remove_edges :: [Edge] -> Skeleton -> Skeleton remove_edges :: [Edge] -> Skeleton -> Skeleton remove_edges [Edge] edges = (Graph -> Graph) -> Skeleton -> Skeleton map_skel ([Edge] -> Graph -> Graph Graphs.remove_edges [Edge] edges) lonely_vertex :: Skeleton -> TrackNum -> Bool lonely_vertex :: Skeleton -> Vertex -> Bool lonely_vertex (Skeleton Graph graph) = Graph -> Vertex -> Bool Graphs.lonely_vertex Graph graph flatten :: Skeleton -> [Edge] flatten :: Skeleton -> [Edge] flatten (Skeleton Graph graph) = [Edge] -> [Edge] forall a. Ord a => [a] -> [a] List.sort (Graph -> [Edge] Graph.edges Graph graph) to_forest :: TrackNum -- ^ Total number of tracks. This is needed because the -- underlying graph may be smaller than the number of tracks. I don't -- want to allow a skeleton that doesn't have certain tracks (and hence -- makes them invisible) so any missing tracks are appended. -> Skeleton -> [Tree.Tree TrackNum] -- ^ Each list of Nodes is sorted so the tree -- appears in the same order as the tracks. This is essential for calls -- that want to deal with tracks left-to-right. to_forest :: Vertex -> Skeleton -> [Tree Vertex] to_forest Vertex ntracks (Skeleton Graph graph) = [Tree Vertex] -> [Tree Vertex] sort_tree ([Tree Vertex] -> [Tree Vertex]) -> [Tree Vertex] -> [Tree Vertex] forall a b. (a -> b) -> a -> b $ Graph -> [Tree Vertex] Graphs.to_forest Graph graph [Tree Vertex] -> [Tree Vertex] -> [Tree Vertex] forall a. [a] -> [a] -> [a] ++ [Tree Vertex] rest where -- from 1 past array end to last track index (ntracks-1) rest :: [Tree Vertex] rest = [Vertex -> [Tree Vertex] -> Tree Vertex forall a. a -> [Tree a] -> Tree a Graph.Node Vertex n [] | Vertex n <- [Edge -> Vertex forall a b. (a, b) -> b snd (Graph -> Edge forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> (i, i) IArray.bounds Graph graph) Vertex -> Vertex -> Vertex forall a. Num a => a -> a -> a + Vertex 1 .. Vertex ntracksVertex -> Vertex -> Vertex forall a. Num a => a -> a -> a -Vertex 1]] sort_tree :: [Tree Vertex] -> [Tree Vertex] sort_tree = (Tree Vertex -> Vertex) -> [Tree Vertex] -> [Tree Vertex] forall k a. Ord k => (a -> k) -> [a] -> [a] Seq.sort_on Tree Vertex -> Vertex forall a. Tree a -> a Tree.rootLabel ([Tree Vertex] -> [Tree Vertex]) -> ([Tree Vertex] -> [Tree Vertex]) -> [Tree Vertex] -> [Tree Vertex] forall b c a. (b -> c) -> (a -> b) -> a -> c . (Tree Vertex -> Tree Vertex) -> [Tree Vertex] -> [Tree Vertex] forall a b. (a -> b) -> [a] -> [b] map (\(Tree.Node Vertex val [Tree Vertex] subs) -> Vertex -> [Tree Vertex] -> Tree Vertex forall a. a -> [Tree a] -> Tree a Tree.Node Vertex val ([Tree Vertex] -> [Tree Vertex] sort_tree [Tree Vertex] subs)) -- | Get the parents of a TrackNum. parents :: Skeleton -> TrackNum -> [TrackNum] parents :: Skeleton -> Vertex -> [Vertex] parents (Skeleton Graph graph) Vertex tracknum = Graph -> Vertex -> [Vertex] Graphs.parents Graph graph Vertex tracknum children :: Skeleton -> TrackNum -> [TrackNum] children :: Skeleton -> Vertex -> [Vertex] children (Skeleton Graph graph) Vertex tracknum = Graph -> Vertex -> [Vertex] Graphs.children Graph graph Vertex tracknum -- | Increment all vertices at and above, insert new empty vertex. insert :: TrackNum -> Skeleton -> Skeleton insert :: Vertex -> Skeleton -> Skeleton insert Vertex tracknum = (Graph -> Graph) -> Skeleton -> Skeleton map_skel (Vertex -> Graph -> Graph Graphs.insert_vertex Vertex tracknum) -- | All vertices pointing to the removed vertex instead point to what it -- pointed to. All vertices above the removed one get (-1). remove :: TrackNum -> Skeleton -> Skeleton remove :: Vertex -> Skeleton -> Skeleton remove Vertex tracknum = (Graph -> Graph) -> Skeleton -> Skeleton map_skel (Vertex -> Graph -> Graph Graphs.remove_vertex Vertex tracknum) toggle_edge :: Edge -> Skeleton -> Maybe Skeleton toggle_edge :: Edge -> Skeleton -> Maybe Skeleton toggle_edge Edge edge (Skeleton Graph graph) = Graph -> Skeleton Skeleton (Graph -> Skeleton) -> Maybe Graph -> Maybe Skeleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Edge -> Graph -> Maybe Graph Graphs.toggle_edge Edge edge Graph graph splice_above :: TrackNum -> TrackNum -> Skeleton -> Maybe Skeleton splice_above :: Vertex -> Vertex -> Skeleton -> Maybe Skeleton splice_above Vertex new Vertex to = Skeleton -> Maybe Skeleton acyclic (Skeleton -> Maybe Skeleton) -> (Skeleton -> Skeleton) -> Skeleton -> Maybe Skeleton forall b c a. (b -> c) -> (a -> b) -> a -> c . (Graph -> Graph) -> Skeleton -> Skeleton map_skel (Vertex -> Vertex -> Graph -> Graph Graphs.splice_above Vertex new Vertex to) splice_below :: TrackNum -> TrackNum -> Skeleton -> Maybe Skeleton splice_below :: Vertex -> Vertex -> Skeleton -> Maybe Skeleton splice_below Vertex new Vertex to = Skeleton -> Maybe Skeleton acyclic (Skeleton -> Maybe Skeleton) -> (Skeleton -> Skeleton) -> Skeleton -> Maybe Skeleton forall b c a. (b -> c) -> (a -> b) -> a -> c . (Graph -> Graph) -> Skeleton -> Skeleton map_skel (Vertex -> Vertex -> Graph -> Graph Graphs.splice_below Vertex new Vertex to) acyclic :: Skeleton -> Maybe Skeleton acyclic :: Skeleton -> Maybe Skeleton acyclic skel :: Skeleton skel@(Skeleton Graph graph) | Graph -> Bool Graphs.has_cycle Graph graph = Maybe Skeleton forall a. Maybe a Nothing | Bool otherwise = Skeleton -> Maybe Skeleton forall a. a -> Maybe a Just Skeleton skel -- | If from<to, then @from@ is inserted after @to@. -- If to<from, then @from@ is inserted before @to@. move :: TrackNum -> TrackNum -> Skeleton -> Skeleton move :: Vertex -> Vertex -> Skeleton -> Skeleton move Vertex from Vertex to = [Edge] -> Skeleton make ([Edge] -> Skeleton) -> (Skeleton -> [Edge]) -> Skeleton -> Skeleton forall b c a. (b -> c) -> (a -> b) -> a -> c . [Edge] -> [Edge] go ([Edge] -> [Edge]) -> (Skeleton -> [Edge]) -> Skeleton -> [Edge] forall b c a. (b -> c) -> (a -> b) -> a -> c . Skeleton -> [Edge] flatten -- TODO should be possible to translate into a map over the graph array where go :: [Edge] -> [Edge] go | Vertex from Vertex -> Vertex -> Bool forall a. Ord a => a -> a -> Bool < Vertex to = (Edge -> Edge) -> [Edge] -> [Edge] forall a b. (a -> b) -> [a] -> [b] map ((Edge -> Edge) -> [Edge] -> [Edge]) -> (Edge -> Edge) -> [Edge] -> [Edge] forall a b. (a -> b) -> a -> b $ (Vertex -> Vertex) -> (Vertex -> Vertex) -> Edge -> Edge forall (p :: * -> * -> *) a b c d. Bifunctor p => (a -> b) -> (c -> d) -> p a c -> p b d bimap Vertex -> Vertex up Vertex -> Vertex up | Vertex to Vertex -> Vertex -> Bool forall a. Ord a => a -> a -> Bool < Vertex from = (Edge -> Edge) -> [Edge] -> [Edge] forall a b. (a -> b) -> [a] -> [b] map ((Edge -> Edge) -> [Edge] -> [Edge]) -> (Edge -> Edge) -> [Edge] -> [Edge] forall a b. (a -> b) -> a -> b $ (Vertex -> Vertex) -> (Vertex -> Vertex) -> Edge -> Edge forall (p :: * -> * -> *) a b c d. Bifunctor p => (a -> b) -> (c -> d) -> p a c -> p b d bimap Vertex -> Vertex down Vertex -> Vertex down | Bool otherwise = [Edge] -> [Edge] forall a. a -> a id up :: Vertex -> Vertex up Vertex x | Vertex x Vertex -> Vertex -> Bool forall a. Eq a => a -> a -> Bool == Vertex from = Vertex to | Vertex x Vertex -> Vertex -> Bool forall a. Ord a => a -> a -> Bool > Vertex from Bool -> Bool -> Bool && Vertex x Vertex -> Vertex -> Bool forall a. Ord a => a -> a -> Bool <= Vertex to = Vertex x Vertex -> Vertex -> Vertex forall a. Num a => a -> a -> a - Vertex 1 | Bool otherwise = Vertex x down :: Vertex -> Vertex down Vertex x | Vertex x Vertex -> Vertex -> Bool forall a. Eq a => a -> a -> Bool == Vertex from = Vertex to | Vertex x Vertex -> Vertex -> Bool forall a. Ord a => a -> a -> Bool >= Vertex to Bool -> Bool -> Bool && Vertex x Vertex -> Vertex -> Bool forall a. Ord a => a -> a -> Bool < Vertex from = Vertex x Vertex -> Vertex -> Vertex forall a. Num a => a -> a -> a + Vertex 1 | Bool otherwise = Vertex x map_skel :: (Graph.Graph -> Graph.Graph) -> Skeleton -> Skeleton map_skel :: (Graph -> Graph) -> Skeleton -> Skeleton map_skel Graph -> Graph f (Skeleton Graph graph) = Graph -> Skeleton Skeleton (Graph -> Graph f Graph graph)