{-# LANGUAGE CPP #-}
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
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
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
type Edge = (TrackNum, TrackNum)
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
-> Skeleton
-> [Tree.Tree TrackNum]
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
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))
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
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)
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
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
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)