-- | Geometrical Drawings
--
-- A. Bernard Deacon and Camilla H. Wedgwood. “Geometrical Drawings
-- from Malekula and Other Islands of the New Hebrides”. The Journal
-- of the Royal Anthropological Institute of Great Britain and
-- Ireland, 64:129—175, 1934.
module Music.Theory.Graph.Deacon_1934 where

import Data.Bifunctor {- base -}
import Data.List {- base -}

import qualified Music.Theory.Array.Cell_Ref as T {- hmt-base -}
import qualified Music.Theory.List as T {- hmt-base -}
import qualified Music.Theory.Tuple as T {- hmt-base -}

import qualified Music.Theory.Array.Direction as T {- hmt -}
import qualified Music.Theory.Graph.Dot as T {- hmt -}
import qualified Music.Theory.Graph.Fgl as T {- hmt -}

gen_graph :: Ord v => [T.Dot_Attr] -> T.Graph_Pp v e -> [T.Edge_Lbl v e] -> [String]
gen_graph :: forall v e.
Ord v =>
[Edge String] -> Graph_Pp v e -> [Edge_Lbl v e] -> [String]
gen_graph [Edge String]
opt Graph_Pp v e
pp [Edge_Lbl v e]
es = forall (gr :: * -> * -> *) v e.
Graph gr =>
[Edge String] -> Graph_Pp v e -> gr v e -> [String]
T.fgl_to_udot [Edge String]
opt Graph_Pp v e
pp (forall v e. (Eq v, Ord v) => [Edge_Lbl v e] -> Gr v e
T.g_from_edges_l [Edge_Lbl v e]
es)

gen_graph_ul :: Ord v => [T.Dot_Attr] -> (v -> String) -> [T.Edge v] -> [String]
gen_graph_ul :: forall v.
Ord v =>
[Edge String] -> (v -> String) -> [Edge v] -> [String]
gen_graph_ul [Edge String]
opt v -> String
pp [Edge v]
es = forall (gr :: * -> * -> *) v e.
Graph gr =>
[Edge String] -> Graph_Pp v e -> gr v e -> [String]
T.fgl_to_udot [Edge String]
opt (forall v e. (v -> String) -> Graph_Pp v e
T.gr_pp_label_v v -> String
pp) (forall v. Ord v => [Edge v] -> Gr v ()
T.g_from_edges [Edge v]
es)

gen_digraph :: Ord v => [T.Dot_Attr] -> T.Graph_Pp v e -> [T.Edge_Lbl v e] -> [String]
gen_digraph :: forall v e.
Ord v =>
[Edge String] -> Graph_Pp v e -> [Edge_Lbl v e] -> [String]
gen_digraph [Edge String]
opt Graph_Pp v e
pp [Edge_Lbl v e]
es = forall (gr :: * -> * -> *) v e.
Graph gr =>
Graph_Type -> [Edge String] -> Graph_Pp v e -> gr v e -> [String]
T.fgl_to_dot Graph_Type
T.Graph_Digraph [Edge String]
opt Graph_Pp v e
pp (forall v e. (Eq v, Ord v) => [Edge_Lbl v e] -> Gr v e
T.g_from_edges_l [Edge_Lbl v e]
es)

type G = ([T.Edge String],[T.Dot_Attr],FilePath)

-- * E
g1 :: G
g1 :: G
g1 =
    let c1 :: [String]
c1 = String -> [String]
words String
"A1 B2 A3 B4 C3 B2 C1 D2 C3 D4 D3 D2 D1 C2 D3 C4 B3 C2 B1 A2 B3 A4 A3 A2 A1"
        o1 :: [Edge String]
o1 = [(String
"node:shape",String
"circle"),(String
"edge:len",String
"1.5"),(String
"edge:fontsize",String
"7")]
    in (forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
1 [String]
c1,[Edge String]
o1,String
"E")

-- * D
g2 :: G
g2 :: G
g2 =
    let c2' :: [String]
c2' = String -> [String]
words String
"B3 C2 = C3 B2 A1 = A2 B1 C2 = C1 B2 A3 = A2 B3 C3 C2 B2 B3 ~ C3 ~ C2 C1 == C3 C2 C1 B1 B2 C2 ~ C1 ~ B1 A1 C1 B1 A1 A2 B2 B1 ~ A1 ~ A2 A3 == A1 A2 A3 B3 B2 A2 ~ A3 ~ B3 C3 C3 ~~ C1 ~~ A1 ~~ A3 A3 B3"
        c2 :: [String]
c2 = forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
T.is_cell_ref [String]
c2'
        o2 :: [Edge String]
o2 = [(String
"node:shape",String
"circle"),(String
"edge:len",String
"3"),(String
"edge:fontsize",String
"7")]
    in (forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
1 [String]
c2,[Edge String]
o2,String
"D")

-- * A
g4 :: G
g4 :: G
g4 =
    let c4' :: [String]
c4' = String -> [String]
words String
"B1 C2 C3 B3 B2 C2 ~~ C3 C2 ~~ C1 C2 C2 B3 A3 A2 B2 B3 ~~ A3 B3 ~~ C3 B3 B3 A2 A1 B1 B2 A2 ~~ A1 A2 ~~ A3 A2 A2 B1 C1 C2 B2 B1 ~~ C1 B1 ~~ A1 B1 B1"
        c4 :: [String]
c4 = forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
T.is_cell_ref [String]
c4'
        o4 :: [Edge String]
o4 = [(String
"node:shape",String
"circle"),(String
"edge:len",String
"3"),(String
"edge:fontsize",String
"7")]
    in (forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
1 [String]
c4,[Edge String]
o4,String
"A")

g6 :: G
g6 :: G
g6 =
    let c6' :: [String]
c6' = String -> [String]
words String
"B1 C2 B2 C1 B1 A2 B2 A1 B1 B2 B3 B3 B3 B3 B2 B1 B0 B0 B0 B0 B1 C1 ~~~ C2 B2 B2 B2 A2 ~~~ A1 B1 B1 B1"
        c6 :: [String]
c6 = forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
T.is_cell_ref [String]
c6'
        o6 :: [Edge String]
o6 = [(String
"node:shape",String
"circle"),(String
"edge:len",String
"3"),(String
"edge:fontsize",String
"7")]
    in (forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
1 [String]
c6,[Edge String]
o6,String
"B")

g8 :: G
g8 :: G
g8 =
    let c8' :: [String]
c8' = String -> [String]
words String
"C2 B1 B1 A2 ~ (04) B1 B2 B3 ~ (08) C2 B3 B3 A2 ~ (13) B3 B2 A2 (17) A3 A3 B2 C1 C1 C2 B2 B1 ~ (23) C2 B2 A2 A1 A1 B2 C3 C3 C2"
        c8 :: [String]
c8 = forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
T.is_cell_ref [String]
c8'
        o8 :: [Edge String]
o8 = [(String
"node:shape",String
"circle"),(String
"edge:len",String
"3"),(String
"edge:fontsize",String
"7")]
    in (forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
1 [String]
c8,[Edge String]
o8,String
"C")

g9 :: G
g9 :: G
g9 =
    let d9' :: (String, [String])
d9' = (String
"E6",String -> [String]
words String
"U R D LL (03/D6) U R R U L D D LL (11/C6) U R R U U R D L L D D LL (22/B6) U R R U U R R U L D D L L D D LL (38/A6) U R R U U R R U U R D L L D D L L D D LUU (56/A4) R R U U R R U L D D L L D D L UU (71/A3) R R U U R D L L D D L UU (83/A2) R R U L D D L UU (91/A1) R D L")
        d9 :: (String, [String])
d9 = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
T.is_direction) (String, [String])
d9'
        c9 :: [String]
c9 = (String, [String]) -> [String]
T.dir_seq_to_cell_seq (String, [String])
d9
        o9 :: [Edge String]
o9 = [(String
"node:shape",String
"circle"),(String
"edge:len",String
"1.5"),(String
"edge:fontsize",String
"7")]
    in (forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
1 [String]
c9,[Edge String]
o9,String
"F")

g10 :: G
g10 :: G
g10 =
    let d10' :: (String, [String])
d10' = (String
"B7",String -> [String]
words String
"U R LL (03/A6) R R U L D D LUU (10/A5) R R U L D D L UU (18/A4) R R U L D D L UU (26/A3) R R U L D D L UU (34/A2) R R U L D D L UU (41/A1) R D L")
        d10 :: (String, [String])
d10 = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
T.is_direction) (String, [String])
d10'
        c10 :: [String]
c10 = (String, [String]) -> [String]
T.dir_seq_to_cell_seq (String, [String])
d10
        e10 :: [Edge String]
e10 = forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
1 [String]
c10
        o10 :: [Edge String]
o10 = [(String
"node:shape",String
"circle"),(String
"edge:len",String
"1.5"),(String
"edge:fontsize",String
"7")]
    in ([Edge String]
e10,[Edge String]
o10,String
"G")

g11 :: G
g11 :: G
g11 =
    let d11' :: (String, [String])
d11' = (String
"C3",String -> [String]
words String
"DR DDL UUR U L (05/C3) DL DDR UUL U R (10/C3) D D U UL UUR DDL (16/B3) DL R U (18/B3) L DR R (21/C4) UR UUL DDR DR L (26/D4) U R DL L U (31/C3) U D (33/C3) R UUR DDDDD UUL L . (40/C4) L DDL UUUUU DDR R (44/C3)")
        d11 :: (String, [String])
d11 = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
T.is_direction) (String, [String])
d11'
        c11 :: [String]
c11 = (String, [String]) -> [String]
T.dir_seq_to_cell_seq (String, [String])
d11
        e11 :: [Edge String]
e11 = forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
1 [String]
c11
        o11 :: [Edge String]
o11 = [(String
"node:shape",String
"circle"),(String
"edge:len",String
"1.5"),(String
"edge:fontsize",String
"7")]
    in ([Edge String]
e11,[Edge String]
o11,String
"H")

g12 :: G
g12 :: G
g12 =
    let d12' :: (String, [String])
d12' = (String
"C2",String -> [String]
words String
"DR UR (02/E2) L DL UL L (06/A2) DR UR UR DR (10/E2) L UL DL L (14/A2) UR DR (16/C2)")
        d12 :: (String, [String])
d12 = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
T.is_direction) (String, [String])
d12'
        c12 :: [String]
c12 = (String, [String]) -> [String]
T.dir_seq_to_cell_seq (String, [String])
d12
        e12 :: [Edge String]
e12 = forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
1 [String]
c12
        o12 :: [Edge String]
o12 = [(String
"node:shape",String
"circle"),(String
"edge:len",String
"1.5"),(String
"edge:fontsize",String
"7")]
    in ([Edge String]
e12,[Edge String]
o12,String
"I")

g13 :: G
g13 :: G
g13 =
    let d13' :: (String, [String])
d13' = (String
"B3",String -> [String]
words String
"U D D U R DDL UUL R (07/C3) R UU DDL L UU DDR (11/C3)")
        d13 :: (String, [String])
d13 = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
T.is_direction) (String, [String])
d13'
        c13 :: [String]
c13 = (String, [String]) -> [String]
T.dir_seq_to_cell_seq (String, [String])
d13
        e13 :: [Edge String]
e13 = forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
1 [String]
c13
        o13 :: [Edge String]
o13 = [(String
"node:shape",String
"circle"),(String
"edge:len",String
"1.5"),(String
"edge:fontsize",String
"7")]
    in ([Edge String]
e13,[Edge String]
o13,String
"J")

g_all :: [G]
g_all :: [G]
g_all = [G
g1,G
g2,G
g4,G
g6,G
g8,G
g9,G
g10,G
g11,G
g12,G
g13]

-- G = unlabeled, GL = labeled
-- GC = collated, GF = filtered (unique edges)
-- GD = directed
wr :: G -> IO ()
wr :: G -> IO ()
wr ([Edge String]
e,[Edge String]
o,String
nm) = do
  let mk_nm :: String -> String
mk_nm String
ty = String
"/home/rohan/sw/hmt/data/dot/deacon/" forall a. [a] -> [a] -> [a]
++ String
nm forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ String
ty forall a. [a] -> [a] -> [a]
++ String
".dot"
      wr_f :: String -> [String] -> IO ()
wr_f String
ty [String]
g = String -> String -> IO ()
writeFile (String -> String
mk_nm String
ty) ([String] -> String
unlines [String]
g)
  String -> [String] -> IO ()
wr_f String
"G" (forall v.
Ord v =>
[Edge String] -> (v -> String) -> [Edge v] -> [String]
gen_graph_ul [Edge String]
o forall a. a -> a
id [Edge String]
e)
  String -> [String] -> IO ()
wr_f String
"GL" (forall v e.
Ord v =>
[Edge String] -> Graph_Pp v e -> [Edge_Lbl v e] -> [String]
gen_graph [Edge String]
o (forall v e. (v -> String) -> (e -> String) -> Graph_Pp v e
T.gr_pp_label forall a. a -> a
id forall a. Show a => a -> String
show) (forall v. [Edge v] -> [Edge_Lbl v Int]
T.e_label_seq [Edge String]
e))
  String -> [String] -> IO ()
wr_f String
"GC" (forall v e.
Ord v =>
[Edge String] -> Graph_Pp v e -> [Edge_Lbl v e] -> [String]
gen_graph [Edge String]
o (forall v e. (v -> String) -> (e -> String) -> Graph_Pp v e
T.gr_pp_label forall a. a -> a
id forall t. Show t => [t] -> String
T.br_csl_pp) (forall v l. Ord v => [Edge_Lbl v l] -> [Edge_Lbl v [l]]
T.e_collate_normalised_l (forall v. [Edge v] -> [Edge_Lbl v Int]
T.e_label_seq [Edge String]
e)))
  String -> [String] -> IO ()
wr_f String
"GF" (forall v.
Ord v =>
[Edge String] -> (v -> String) -> [Edge v] -> [String]
gen_graph_ul [Edge String]
o forall a. a -> a
id (forall a. Eq a => [a] -> [a]
nub (forall a b. (a -> b) -> [a] -> [b]
map forall t. Ord t => (t, t) -> (t, t)
T.t2_sort [Edge String]
e)))
  String -> [String] -> IO ()
wr_f String
"GD" (forall v e.
Ord v =>
[Edge String] -> Graph_Pp v e -> [Edge_Lbl v e] -> [String]
gen_digraph [Edge String]
o (forall v e. (v -> String) -> (e -> String) -> Graph_Pp v e
T.gr_pp_label forall a. a -> a
id forall t. Show t => [t] -> String
T.br_csl_pp) (forall v l. Ord v => [Edge_Lbl v l] -> [Edge_Lbl v [l]]
T.e_collate_normalised_l (forall v. [Edge v] -> [Edge_Lbl v Int]
T.e_label_seq [Edge String]
e)))
{-
  let o' = ("graph:layout","fdp") : o
  wr_f "GC_" (gen_graph o' T.gr_pp_id_br_csl (T.e_collate_normalised_l (T.e_label_seq e)))
-}

wr_all :: IO ()
wr_all :: IO ()
wr_all = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ G -> IO ()
wr [G]
g_all