-- | James Boros. "Some Properties of the All-Trichord Hexachord".
-- _In Theory Only_, 11(6):19--41, 1990.
module Music.Theory.Z.Boros_1990 where

import Data.Char {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import Numeric {- base -}

import qualified Data.Graph.Inductive.Graph as G {- fgl -}
import qualified Data.Graph.Inductive.Basic as G {- fgl -}
import qualified Data.Graph.Inductive.PatriciaTree as G {- fgl -}
import qualified Data.Graph.Inductive.Query.BFS as G {- fgl -}

import qualified Music.Theory.Array.Text as T
import qualified Music.Theory.Combinations as T
import qualified Music.Theory.Graph.Dot as T
import qualified Music.Theory.Graph.Fgl as T
import qualified Music.Theory.List as T
import qualified Music.Theory.Set.List as T
import qualified Music.Theory.Tuple as T
import qualified Music.Theory.Z as T
import qualified Music.Theory.Z.Forte_1973 as T
import qualified Music.Theory.Z.Tto as T

-- * Util

singular :: String -> [t] -> t
singular :: forall t. SC_Name -> [t] -> t
singular SC_Name
err [t]
l =
    case [t]
l of
      [t
x] -> t
x
      [t]
_ -> forall a. HasCallStack => SC_Name -> a
error (SC_Name
"not singular: " forall a. [a] -> [a] -> [a]
++ SC_Name
err)

set_eq :: Ord t => [t] -> [t] -> Bool
set_eq :: forall t. Ord t => [t] -> [t] -> Bool
set_eq [t]
p [t]
q = forall a. Ord a => [a] -> [a]
T.set [t]
p forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> [a]
T.set [t]
q

elem_by :: (t -> t -> Bool) -> t -> [t] -> Bool
elem_by :: forall t. (t -> t -> Bool) -> t -> [t] -> Bool
elem_by t -> t -> Bool
f t
e = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (t -> t -> Bool
f t
e)

-- * Tto

tto_tni_univ :: Integral i => [T.Tto i]
tto_tni_univ :: forall i. Integral i => [Tto i]
tto_tni_univ = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== i
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Tto t -> t
T.tto_M) (forall t. Integral t => t -> Z t -> [Tto t]
T.z_tto_univ i
5 forall i. Num i => Z i
T.z12)

all_tn :: Integral i => [i] -> [[i]]
all_tn :: forall i. Integral i => [i] -> [[i]]
all_tn [i]
p = forall a b. (a -> b) -> [a] -> [b]
map (\i
n -> forall a b. (a -> b) -> [a] -> [b]
map (forall i. Integral i => Z i -> i -> i -> i
T.z_add forall i. Num i => Z i
T.z12 i
n) [i]
p) [i
0..i
11]

all_tni :: Integral i => [i] -> [[i]]
all_tni :: forall i. Integral i => [i] -> [[i]]
all_tni [i]
p = forall a b. (a -> b) -> [a] -> [b]
map (\Tto i
f -> forall t. Integral t => Z t -> Tto t -> [t] -> [t]
T.z_tto_apply forall i. Num i => Z i
T.z12 Tto i
f [i]
p) forall i. Integral i => [Tto i]
tto_tni_univ

uniq_tni :: Integral i => [i] -> [[i]]
uniq_tni :: forall i. Integral i => [i] -> [[i]]
uniq_tni = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Integral i => [i] -> [[i]]
all_tni

type Pc = Int
type Pcset = [Pc]
type Sc = Pcset

-- > pcset_trs 3 [0,1,9] == [0,3,4]
pcset_trs :: Int -> Pcset -> Pcset
pcset_trs :: Pc -> [Pc] -> [Pc]
pcset_trs = forall i. Integral i => Z i -> i -> [i] -> [i]
T.z_tto_tn forall i. Num i => Z i
T.z12

-- | Forte prime forms of the twelve trichordal set classes.
--
-- > length trichords == 12
trichords :: [Pcset]
trichords :: [[Pc]]
trichords = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== Pc
3) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Pc
length) (forall i. Integral i => Z i -> [[i]]
T.z_sc_univ forall i. Num i => Z i
T.z12)

-- | Is a pcset self-inversional, ie. is the inversion of /p/ a transposition of /p/.
--
-- > map (\p -> (p,self_inv p)) trichords
self_inv :: Pcset -> Bool
self_inv :: [Pc] -> Bool
self_inv [Pc]
p = forall t. (t -> t -> Bool) -> t -> [t] -> Bool
elem_by forall t. Ord t => [t] -> [t] -> Bool
set_eq (forall a b. (a -> b) -> [a] -> [b]
map (forall i. Integral i => Z i -> i -> i
T.z_negate forall i. Num i => Z i
T.z12) [Pc]
p) (forall i. Integral i => [i] -> [[i]]
all_tn [Pc]
p)

-- | Pretty printer, comma separated.
--
-- > pcset_pp [0,3,7,10] == "0,3,7,10"
pcset_pp :: Pcset -> String
pcset_pp :: [Pc] -> SC_Name
pcset_pp = forall a. [a] -> [[a]] -> [a]
intercalate SC_Name
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> SC_Name
show

-- | Pretty printer, hexadecimal, no separator.
--
-- > pcset_pp_hex [0,3,7,10] == "037A"
pcset_pp_hex :: Pcset -> String
pcset_pp_hex :: [Pc] -> SC_Name
pcset_pp_hex = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. (Integral a, Show a) => a -> ShowS
`showHex` SC_Name
"")

-- * Ath

-- | Forte prime form of the all-trichord hexachord.
--
-- > T.sc_name ath == "6-Z17"
-- > T.sc "6-Z17" == ath
ath :: Pcset
ath :: [Pc]
ath = [Pc
0,Pc
1,Pc
2,Pc
4,Pc
7,Pc
8]

-- | Is /p/ an instance of 'ath'.
is_ath :: Pcset -> Bool
is_ath :: [Pc] -> Bool
is_ath [Pc]
p = forall i. Integral i => Z i -> [i] -> [i]
T.z_forte_prime forall i. Num i => Z i
T.z12 [Pc]
p forall a. Eq a => a -> a -> Bool
== [Pc]
ath

-- | Table 1, p.20
--
-- > length ath_univ == 24
ath_univ :: [Pcset]
ath_univ :: [[Pc]]
ath_univ = forall i. Integral i => [i] -> [[i]]
uniq_tni [Pc]
ath

-- | Calculate 'T.Tto' of pcset, which must be an instance of 'ath'.
--
-- > ath_tni [1,2,3,7,8,11] == T.Tto 3 1 True
ath_tni :: Pcset -> T.Tto Pc
ath_tni :: [Pc] -> Tto Pc
ath_tni = forall t. SC_Name -> [t] -> t
singular SC_Name
"ath_tni" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== Pc
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Tto t -> t
T.tto_M) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. (Ord t, Integral t) => t -> Z t -> [t] -> [t] -> [Tto t]
T.z_tto_rel Pc
5 forall i. Num i => Z i
T.z12 [Pc]
ath

-- | Give label for instance of 'ath', prime forms are written H and inversions h.
--
-- > ath_pp [1,2,3,7,8,11] == "h3"
ath_pp :: Pcset -> String
ath_pp :: [Pc] -> SC_Name
ath_pp [Pc]
p =
    let r :: Tto Pc
r = [Pc] -> Tto Pc
ath_tni [Pc]
p
        h :: Char
h = if forall t. Tto t -> Bool
T.tto_I Tto Pc
r then Char
'h' else Char
'H'
    in Char
h forall a. a -> [a] -> [a]
: forall a. Show a => a -> SC_Name
show (forall t. Tto t -> t
T.tto_T Tto Pc
r)

-- | The twenty three-element subsets of 'ath'.
--
-- > length ath_trichords == 20
ath_trichords :: [Pcset]
ath_trichords :: [[Pc]]
ath_trichords = forall a. Pc -> [a] -> [[a]]
T.combinations (Pc
3::Int) [Pc]
ath

-- | '\\' of 'ath' and /p/, ie. the pitch classes that are in 'ath' and not in /p/.
--
-- > ath_complement [0,1,2] == [4,7,8]
ath_complement :: Pcset -> Pcset
ath_complement :: [Pc] -> [Pc]
ath_complement [Pc]
p = [Pc]
ath forall a. Eq a => [a] -> [a] -> [a]
\\ [Pc]
p

-- | /p/ is a pcset, /q/ a sc, calculate pcsets in /q/ that with /p/ form 'ath'.
--
-- > ath_completions [0,1,2] (T.sc "3-3") == [[6,7,10],[4,7,8]]
-- > ath_completions [6,7,10] (T.sc "3-5") == [[1,2,8]]
ath_completions :: Pcset -> Sc -> [Pcset]
ath_completions :: [Pc] -> [Pc] -> [[Pc]]
ath_completions [Pc]
p [Pc]
q =
    let f :: [Pc] -> Bool
f [Pc]
z = [Pc] -> Bool
is_ath ([Pc]
p forall a. [a] -> [a] -> [a]
++ [Pc]
z)
    in forall a. (a -> Bool) -> [a] -> [a]
filter [Pc] -> Bool
f (forall i. Integral i => [i] -> [[i]]
uniq_tni [Pc]
q)

realise_ath_seq :: [Pcset] -> [[Pcset]]
realise_ath_seq :: [[Pc]] -> [[[Pc]]]
realise_ath_seq [[Pc]]
sq =
    case [[Pc]]
sq of
      [Pc]
p:[Pc]
q:[[Pc]]
sq' -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[Pc]
z -> forall a b. (a -> b) -> [a] -> [b]
map ([Pc]
p forall a. a -> [a] -> [a]
:) ([[Pc]] -> [[[Pc]]]
realise_ath_seq ([Pc]
z forall a. a -> [a] -> [a]
: [[Pc]]
sq'))) ([Pc] -> [Pc] -> [[Pc]]
ath_completions [Pc]
p [Pc]
q)
      [[Pc]]
_ -> [[[Pc]]
sq]

-- return edges that connect z to nodes at gr in an ATH relation
ath_gr_extend :: [T.Edge Pcset] -> Pcset -> [T.Edge Pcset]
ath_gr_extend :: [Edge [Pc]] -> [Pc] -> [Edge [Pc]]
ath_gr_extend [Edge [Pc]]
gr [Pc]
c =
    let f :: [Pc] -> [Pc] -> Maybe (Edge [Pc])
f [Pc]
x [Pc]
y = if [Pc] -> Bool
is_ath ([Pc]
x forall a. [a] -> [a] -> [a]
++ [Pc]
y) then forall a. a -> Maybe a
Just ([Pc]
x,[Pc]
y) else forall a. Maybe a
Nothing
        g :: Edge [Pc] -> [Edge [Pc]]
g ([Pc]
p,[Pc]
q) = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Pc] -> [Pc] -> Maybe (Edge [Pc])
f [Pc]
c) [[Pc]
p,[Pc]
q]
    in 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 (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Edge [Pc] -> [Edge [Pc]]
g [Edge [Pc]]
gr))

gr_trs :: Int -> [T.Edge Pcset] -> [T.Edge Pcset]
gr_trs :: Pc -> [Edge [Pc]] -> [Edge [Pc]]
gr_trs Pc
n = let f :: Edge [Pc] -> Edge [Pc]
f ([Pc]
p,[Pc]
q) = (Pc -> [Pc] -> [Pc]
pcset_trs Pc
n [Pc]
p,Pc -> [Pc] -> [Pc]
pcset_trs Pc
n [Pc]
q) in forall a b. (a -> b) -> [a] -> [b]
map Edge [Pc] -> Edge [Pc]
f

-- * Tables

-- > length table_3 == 20
table_3 :: [((Pcset,Sc,T.SC_Name),(Pcset,Sc,T.SC_Name))]
table_3 :: [(([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name))]
table_3 =
    let f :: [Pc] -> (([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name))
f [Pc]
p = let q :: [Pc]
q = [Pc] -> [Pc]
ath_complement [Pc]
p
                  i :: [i] -> ([i], [i], SC_Name)
i [i]
x = ([i]
x,forall i. Integral i => Z i -> [i] -> [i]
T.z_forte_prime forall i. Num i => Z i
T.z12 [i]
x,forall i. Integral i => [i] -> SC_Name
T.sc_name [i]
x)
              in (forall {i}. Integral i => [i] -> ([i], [i], SC_Name)
i [Pc]
p,forall {i}. Integral i => [i] -> ([i], [i], SC_Name)
i [Pc]
q)
    in forall a b. (a -> b) -> [a] -> [b]
map [Pc] -> (([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name))
f [[Pc]]
ath_trichords

pp_tbl :: T.Text_Table -> [String]
pp_tbl :: Text_Table -> [SC_Name]
pp_tbl = Text_Table_Opt -> Text_Table -> [SC_Name]
T.table_pp Text_Table_Opt
T.table_opt_simple

-- > putStrLn $ unlines $ table_3_md
table_3_md :: [String]
table_3_md :: [SC_Name]
table_3_md =
    let pp :: [Pc] -> SC_Name
pp = [Pc] -> SC_Name
pcset_pp_hex
        f :: (([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name)) -> [SC_Name]
f (([Pc]
p,[Pc]
q,SC_Name
r),([Pc]
s,[Pc]
t,SC_Name
u)) = [[Pc] -> SC_Name
pp [Pc]
p,[Pc] -> SC_Name
pp [Pc]
q,SC_Name
r,[Pc] -> SC_Name
pp [Pc]
s,[Pc] -> SC_Name
pp [Pc]
t,SC_Name
u]
        hdr :: [SC_Name]
hdr = [SC_Name
"P",SC_Name
"P/SC",SC_Name
"P/F",SC_Name
"Q=H0-P",SC_Name
"Q/SC",SC_Name
"Q/F"]
    in Text_Table -> [SC_Name]
pp_tbl ([SC_Name]
hdr forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name)) -> [SC_Name]
f [(([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name))]
table_3)

-- > length table_4 == 10
table_4 :: [((Pcset,Pcset,T.SC_Name),(Pcset,Pcset,T.SC_Name))]
table_4 :: [(([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name))]
table_4 = 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 [(([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name))]
table_3)

-- > putStrLn $ unlines $ table_4_md
table_4_md :: [String]
table_4_md :: [SC_Name]
table_4_md =
    let pp :: [Pc] -> SC_Name
pp = [Pc] -> SC_Name
pcset_pp_hex
        f :: (([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name)) -> [SC_Name]
f (([Pc]
p,[Pc]
q,SC_Name
r),([Pc]
s,[Pc]
t,SC_Name
u)) = [[Pc] -> SC_Name
pp [Pc]
p forall a. [a] -> [a] -> [a]
++ SC_Name
"/" forall a. [a] -> [a] -> [a]
++ [Pc] -> SC_Name
pp [Pc]
s,[Pc] -> SC_Name
pp [Pc]
q forall a. [a] -> [a] -> [a]
++ SC_Name
"/" forall a. [a] -> [a] -> [a]
++ [Pc] -> SC_Name
pp [Pc]
t,SC_Name
r forall a. [a] -> [a] -> [a]
++ SC_Name
"/" forall a. [a] -> [a] -> [a]
++ SC_Name
u]
        hdr :: [SC_Name]
hdr = [SC_Name
"Trichords",SC_Name
"Prime Forms",SC_Name
"Forte Numbers"]
    in Text_Table -> [SC_Name]
pp_tbl ([SC_Name]
hdr forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name)) -> [SC_Name]
f [(([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name))]
table_4)

table_5 :: [(Pcset,Int)]
table_5 :: [([Pc], Pc)]
table_5 = forall a. Ord a => [a] -> [(a, Pc)]
T.histogram (forall a b. (a -> b) -> [a] -> [b]
map (forall i. Integral i => Z i -> [i] -> [i]
T.z_forte_prime forall i. Num i => Z i
T.z12) [[Pc]]
ath_trichords)

-- > putStrLn $ unlines $ table_5_md
table_5_md :: [String]
table_5_md :: [SC_Name]
table_5_md =
    let f :: ([Pc], a) -> [SC_Name]
f ([Pc]
p,a
q) = [[Pc] -> SC_Name
pcset_pp_hex [Pc]
p,forall a. Show a => a -> SC_Name
show a
q]
    in Text_Table -> [SC_Name]
pp_tbl ([SC_Name
"SC",SC_Name
"#ATH"] forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => ([Pc], a) -> [SC_Name]
f [([Pc], Pc)]
table_5)

table_6 :: [(Pcset,Int,Int)]
table_6 :: [([Pc], Pc, Pc)]
table_6 =
    let f :: ([Pc], b) -> ([Pc], b, Pc)
f ([Pc]
p,b
n) = ([Pc]
p,b
n,forall (t :: * -> *) a. Foldable t => t a -> Pc
length (forall a. (a -> Bool) -> [a] -> [a]
filter (\[Pc]
q -> [Pc]
p forall a. Eq a => [a] -> [a] -> Bool
`T.is_subset` [Pc]
q) [[Pc]]
ath_univ))
    in forall a b. (a -> b) -> [a] -> [b]
map forall {b}. ([Pc], b) -> ([Pc], b, Pc)
f [([Pc], Pc)]
table_5

-- > putStrLn $ unlines $ table_6_md
table_6_md :: [String]
table_6_md :: [SC_Name]
table_6_md =
    let f :: ([Pc], a, a) -> [SC_Name]
f ([Pc]
p,a
q,a
r) = [[Pc] -> SC_Name
pcset_pp_hex [Pc]
p,forall a. Show a => a -> SC_Name
show a
q,forall a. Show a => a -> SC_Name
show a
r]
    in Text_Table -> [SC_Name]
pp_tbl ([SC_Name
"SC",SC_Name
"#H0",SC_Name
"#Hn"] forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (Show a, Show a) => ([Pc], a, a) -> [SC_Name]
f [([Pc], Pc, Pc)]
table_6)

-- * Figures

fig_1 :: [T.Edge Pcset]
fig_1 :: [Edge [Pc]]
fig_1 = forall a b. (a -> b) -> [a] -> [b]
map (forall p q. (p -> q) -> T2 p -> T2 q
T.t2_map forall a b c. (a, b, c) -> b
T.p3_snd) [(([Pc], [Pc], SC_Name), ([Pc], [Pc], SC_Name))]
table_4

fig_1_gr :: G.Gr Pcset ()
fig_1_gr :: Gr [Pc] ()
fig_1_gr = forall v. Ord v => [Edge v] -> Gr v ()
T.g_from_edges [Edge [Pc]]
fig_1

-- > putStrLn $ unlines $ map (unwords . map pcset_pp) fig_2
fig_2 :: [[Pcset]]
fig_2 :: [[[Pc]]]
fig_2 =
 let g :: Gr [Pc] ()
g = forall b (gr :: * -> * -> *) a.
(Eq b, DynGraph gr) =>
gr a b -> gr a b
G.undir Gr [Pc] ()
fig_1_gr
     n :: [LNode [Pc]]
n = forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
G.labNodes Gr [Pc] ()
g
     n' :: [LNode [Pc]]
n' = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== Pc
2) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Pc -> Pc
G.deg Gr [Pc] ()
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [LNode [Pc]]
n
     c :: [[LNode [Pc]]]
c = forall a. Pc -> [a] -> [[a]]
T.combinations (Pc
2::Int) [LNode [Pc]]
n'
     p :: [[Pc]]
p = forall a b. (a -> b) -> [a] -> [b]
map (\[LNode [Pc]]
l -> let (LNode [Pc]
lhs,LNode [Pc]
rhs) = forall t. [t] -> (t, t)
T.firstSecond [LNode [Pc]]
l in forall (gr :: * -> * -> *) a b.
Graph gr =>
Pc -> Pc -> gr a b -> [Pc]
G.esp (forall a b. (a, b) -> a
fst LNode [Pc]
lhs) (forall a b. (a, b) -> a
fst LNode [Pc]
rhs) Gr [Pc] ()
g) [[LNode [Pc]]]
c
     p' :: [[Pc]]
p' = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Pc]]
p
 in forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [LNode [Pc]]
n)) [[Pc]]
p'

fig_3 :: [[T.Edge Pcset]]
fig_3 :: [[Edge [Pc]]]
fig_3 = forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall t. Pc -> [t] -> [(t, t)]
T.adj2 Pc
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Pc]] -> [[[Pc]]]
realise_ath_seq) [[[Pc]]]
fig_2

fig_3_gr :: [G.Gr Pcset ()]
fig_3_gr :: [Gr [Pc] ()]
fig_3_gr = forall a b. (a -> b) -> [a] -> [b]
map forall v. Ord v => [Edge v] -> Gr v ()
T.g_from_edges [[Edge [Pc]]]
fig_3

fig_4 :: [[T.Edge Pcset]]
fig_4 :: [[Edge [Pc]]]
fig_4 =
    let p :: [[[Pc]]]
p = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [[Pc]] -> [[[Pc]]]
realise_ath_seq [[[Pc]]]
fig_2
        q :: [[[Pc]]]
q = forall a. (a -> Bool) -> [a] -> [a]
filter ([Pc
0,Pc
1,Pc
2] forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`) [[[Pc]]]
p
    in forall a b. (a -> b) -> [a] -> [b]
map (forall t. Pc -> [t] -> [(t, t)]
T.adj2 Pc
1) [[[Pc]]]
q

fig_5 :: [[T.Edge Pcset]]
fig_5 :: [[Edge [Pc]]]
fig_5 =
    let c :: [Pc]
c = [Pc
0,Pc
4,Pc
8]
        f :: [Edge [Pc]] -> Maybe [Edge [Pc]]
f [Edge [Pc]]
gr = case [Edge [Pc]] -> [Pc] -> [Edge [Pc]]
ath_gr_extend [Edge [Pc]]
gr [Pc]
c of
                 [] -> forall a. Maybe a
Nothing
                 [Edge [Pc]]
r -> forall a. a -> Maybe a
Just ([Edge [Pc]]
gr forall a. [a] -> [a] -> [a]
++ [Edge [Pc]]
r)
        g0 :: [Edge [Pc]]
g0 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge [Pc]]]
fig_4
    in forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Pc
n -> [Edge [Pc]] -> Maybe [Edge [Pc]]
f (Pc -> [Edge [Pc]] -> [Edge [Pc]]
gr_trs Pc
n [Edge [Pc]]
g0)) [Pc
0 .. Pc
11]

-- * Drawing

uedge_set :: Ord v => [T.Edge v] -> [T.Edge v]
uedge_set :: forall v. Ord v => [Edge v] -> [Edge v]
uedge_set = forall a. Eq a => [a] -> [a]
nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall t. Ord t => (t, t) -> (t, t)
T.t2_sort

-- | Self-inversional pcsets are drawn in a double circle, other pcsets in a circle.
set_shape :: Pcset -> T.Dot_Attr
set_shape :: [Pc] -> Dot_Attr
set_shape [Pc]
v = (SC_Name
"shape",if [Pc] -> Bool
self_inv [Pc]
v then SC_Name
"doublecircle" else SC_Name
"circle")

type Gr = G.Gr Pcset ()

gr_pp' :: (Pcset -> String) -> T.Graph_Pp Pcset ()
gr_pp' :: ([Pc] -> SC_Name) -> Graph_Pp [Pc] ()
gr_pp' [Pc] -> SC_Name
f = (\(Pc
_,[Pc]
v) -> [[Pc] -> Dot_Attr
set_shape [Pc]
v,(SC_Name
"label",[Pc] -> SC_Name
f [Pc]
v)],forall a b. a -> b -> a
const [])

gr_pp :: T.Graph_Pp Pcset ()
gr_pp :: Graph_Pp [Pc] ()
gr_pp = ([Pc] -> SC_Name) -> Graph_Pp [Pc] ()
gr_pp' [Pc] -> SC_Name
pcset_pp

d_fig_1 :: [String]
d_fig_1 :: [SC_Name]
d_fig_1 = forall (gr :: * -> * -> *) v e.
Graph gr =>
[Dot_Attr] -> Graph_Pp v e -> gr v e -> [SC_Name]
T.fgl_to_udot [] Graph_Pp [Pc] ()
gr_pp Gr [Pc] ()
fig_1_gr

d_fig_3_g :: Gr
d_fig_3_g :: Gr [Pc] ()
d_fig_3_g = forall v. Ord v => [Edge v] -> Gr v ()
T.g_from_edges (forall v. Ord v => [Edge v] -> [Edge v]
uedge_set (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge [Pc]]]
fig_3))

d_fig_3 :: [String]
d_fig_3 :: [SC_Name]
d_fig_3 = forall (gr :: * -> * -> *) v e.
Graph gr =>
[Dot_Attr] -> Graph_Pp v e -> gr v e -> [SC_Name]
T.fgl_to_udot [] Graph_Pp [Pc] ()
gr_pp Gr [Pc] ()
d_fig_3_g

d_fig_3' :: [[String]]
d_fig_3' :: Text_Table
d_fig_3' = forall a b. (a -> b) -> [a] -> [b]
map (forall (gr :: * -> * -> *) v e.
Graph gr =>
[Dot_Attr] -> Graph_Pp v e -> gr v e -> [SC_Name]
T.fgl_to_udot [(SC_Name
"node:shape",SC_Name
"circle")] Graph_Pp [Pc] ()
gr_pp) [Gr [Pc] ()]
fig_3_gr

d_fig_4_g :: Gr
d_fig_4_g :: Gr [Pc] ()
d_fig_4_g = forall v. Ord v => [Edge v] -> Gr v ()
T.g_from_edges (forall v. Ord v => [Edge v] -> [Edge v]
uedge_set (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge [Pc]]]
fig_4))

d_fig_4 :: [String]
d_fig_4 :: [SC_Name]
d_fig_4 = forall (gr :: * -> * -> *) v e.
Graph gr =>
[Dot_Attr] -> Graph_Pp v e -> gr v e -> [SC_Name]
T.fgl_to_udot [] Graph_Pp [Pc] ()
gr_pp Gr [Pc] ()
d_fig_4_g

d_fig_5_g :: Gr
d_fig_5_g :: Gr [Pc] ()
d_fig_5_g = forall v. Ord v => [Edge v] -> Gr v ()
T.g_from_edges (forall v. Ord v => [Edge v] -> [Edge v]
uedge_set (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge [Pc]]]
fig_5))

d_fig_5 :: [String]
d_fig_5 :: [SC_Name]
d_fig_5 = forall (gr :: * -> * -> *) v e.
Graph gr =>
[Dot_Attr] -> Graph_Pp v e -> gr v e -> [SC_Name]
T.fgl_to_udot [(SC_Name
"edge:len",SC_Name
"1.5")] (([Pc] -> SC_Name) -> Graph_Pp [Pc] ()
gr_pp' [Pc] -> SC_Name
pcset_pp_hex) Gr [Pc] ()
d_fig_5_g

d_fig_5_e :: [T.Edge_Lbl Pcset Pcset]
d_fig_5_e :: [Edge_Lbl [Pc] [Pc]]
d_fig_5_e = forall a b. (a -> b) -> [a] -> [b]
map (\([Pc]
p,[Pc]
q) -> (([Pc]
p,[Pc]
q),[Pc]
pforall a. [a] -> [a] -> [a]
++[Pc]
q)) (forall v. Ord v => [Edge v] -> [Edge v]
uedge_set (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Edge [Pc]]]
fig_5))

d_fig_5_g' :: G.Gr Pcset Pcset
d_fig_5_g' :: Gr [Pc] [Pc]
d_fig_5_g' = forall v e. (Eq v, Ord v) => [Edge_Lbl v e] -> Gr v e
T.g_from_edges_l [Edge_Lbl [Pc] [Pc]]
d_fig_5_e

d_fig_5' :: [String]
d_fig_5' :: [SC_Name]
d_fig_5' =
    let pp :: (b -> [Dot_Attr], (a, [Pc]) -> [Dot_Attr])
pp = (forall a b. a -> b -> a
const [(SC_Name
"shape",SC_Name
"")],\(a
_,[Pc]
e) -> [(SC_Name
"label",[Pc] -> SC_Name
ath_pp [Pc]
e)])
    in forall (gr :: * -> * -> *) v e.
Graph gr =>
[Dot_Attr] -> Graph_Pp v e -> gr v e -> [SC_Name]
T.fgl_to_udot [(SC_Name
"node:shape",SC_Name
"point"),(SC_Name
"edge:len",SC_Name
"1.25")] forall {b} {a}. (b -> [Dot_Attr], (a, [Pc]) -> [Dot_Attr])
pp Gr [Pc] [Pc]
d_fig_5_g'