-- 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)