{-# LANGUAGE FlexibleInstances, RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Sound.Tidal.Show (show, showAll, draw, drawLine, drawLineSz, stepcount, showStateful) where


{-
    Show.hs - Library for visualising Tidal patterns as text
    Copyright (C) 2020, Alex McLean and contributors

    This library is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This library is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this library.  If not, see <http://www.gnu.org/licenses/>.
-}

import Sound.Tidal.Pattern

import Data.List (intercalate, sortOn)
import Data.Ratio (numerator, denominator)
import Data.Maybe (fromMaybe, isJust)

import qualified Data.Map.Strict as Map

instance (Show a) => Show (Pattern a) where
  show :: Pattern a -> String
show = forall a. Show a => Arc -> Pattern a -> String
showPattern (forall a. a -> a -> ArcF a
Arc Rational
0 Rational
1)

showStateful :: ControlPattern -> String
showStateful :: ControlPattern -> String
showStateful ControlPattern
p = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [String]
evStrings
  where (ValueMap
_, [Event ValueMap]
evs) = ValueMap -> [Event ValueMap] -> (ValueMap, [Event ValueMap])
resolveState (forall k a. Map k a
Map.empty) forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. EventF a b -> a
part forall a b. (a -> b) -> a -> b
$ forall a. Pattern a -> Arc -> [Event a]
queryArc (forall a. Pattern a -> Pattern a
filterOnsets ControlPattern
p) (forall a. a -> a -> ArcF a
Arc Rational
0 Rational
1)
        evs' :: [(String, String)]
evs' = forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => Event a -> (String, String)
showEvent [Event ValueMap]
evs
        maxPartLength :: Int
        maxPartLength :: Int
maxPartLength = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(String, String)]
evs'
        evString :: (String, String) -> String
        evString :: (String, String) -> String
evString (String, String)
ev = ((forall a. Int -> a -> [a]
replicate (Int
maxPartLength forall a. Num a => a -> a -> a
- (forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a b. (a, b) -> a
fst (String, String)
ev))) Char
' ')
                       forall a. [a] -> [a] -> [a]
++ forall a b. (a, b) -> a
fst (String, String)
ev
                       forall a. [a] -> [a] -> [a]
++ forall a b. (a, b) -> b
snd (String, String)
ev
                      )
        evStrings :: [String]
evStrings = forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
evString [(String, String)]
evs'

showPattern :: Show a => Arc -> Pattern a -> String
showPattern :: forall a. Show a => Arc -> Pattern a -> String
showPattern Arc
a Pattern a
p = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [String]
evStrings
  where evs :: [(String, String)]
evs = forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => Event a -> (String, String)
showEvent forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. EventF a b -> a
part forall a b. (a -> b) -> a -> b
$ forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern a
p Arc
a
        maxPartLength :: Int
        maxPartLength :: Int
maxPartLength = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(String, String)]
evs
        evString :: (String, String) -> String
        evString :: (String, String) -> String
evString (String, String)
ev = forall a. Int -> a -> [a]
replicate (Int
maxPartLength forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall a b. (a, b) -> a
fst (String, String)
ev)) Char
' '
                       forall a. [a] -> [a] -> [a]
++ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++) (String, String)
ev
        evStrings :: [String]
evStrings = forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
evString [(String, String)]
evs

showEvent :: Show a => Event a -> (String, String)
showEvent :: forall a. Show a => Event a -> (String, String)
showEvent (Event Context
_ (Just (Arc Rational
ws Rational
we)) a :: Arc
a@(Arc Rational
ps Rational
pe) a
e) =
  (String
h forall a. [a] -> [a] -> [a]
++ String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Arc
a forall a. [a] -> [a] -> [a]
++ String
")" forall a. [a] -> [a] -> [a]
++ String
t forall a. [a] -> [a] -> [a]
++ String
"|", forall a. Show a => a -> String
show a
e)
  where h :: String
h | Rational
ws forall a. Eq a => a -> a -> Bool
== Rational
ps = String
""
          | Bool
otherwise = Rational -> String
prettyRat Rational
ws forall a. [a] -> [a] -> [a]
++ String
"-"
        t :: String
t | Rational
we forall a. Eq a => a -> a -> Bool
== Rational
pe = String
""
          | Bool
otherwise = String
"-" forall a. [a] -> [a] -> [a]
++ Rational -> String
prettyRat Rational
we

showEvent (Event Context
_ Maybe Arc
Nothing Arc
a a
e) =
  (String
"~" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Arc
a forall a. [a] -> [a] -> [a]
++ String
"~|", forall a. Show a => a -> String
show a
e)

-- Show everything, including event context
showAll :: Show a => Arc -> Pattern a -> String
showAll :: forall a. Show a => Arc -> Pattern a -> String
showAll Arc
a Pattern a
p = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => Event a -> String
showEventAll forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. EventF a b -> a
part forall a b. (a -> b) -> a -> b
$ forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern a
p Arc
a

-- Show context of an event
showEventAll :: Show a => Event a -> String
showEventAll :: forall a. Show a => Event a -> String
showEventAll Event a
e = forall a. Show a => a -> String
show (forall a b. EventF a b -> Context
context Event a
e) forall a. [a] -> [a] -> [a]
++ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++) (forall a. Show a => Event a -> (String, String)
showEvent Event a
e)

instance Show Context where
  show :: Context -> String
show (Context [((Int, Int), (Int, Int))]
cs) = forall a. Show a => a -> String
show [((Int, Int), (Int, Int))]
cs

instance Show Value where
  show :: Value -> String
show (VS String
s)  = (Char
'"'forall a. a -> [a] -> [a]
:String
s) forall a. [a] -> [a] -> [a]
++ String
"\""
  show (VI Int
i)  = forall a. Show a => a -> String
show Int
i
  show (VF Double
f)  = forall a. Show a => a -> String
show Double
f forall a. [a] -> [a] -> [a]
++ String
"f"
  show (VN Note
n)  = forall a. Show a => a -> String
show Note
n
  show (VR Rational
r)  = Rational -> String
prettyRat Rational
r forall a. [a] -> [a] -> [a]
++ String
"r"
  show (VB Bool
b)  = forall a. Show a => a -> String
show Bool
b
  show (VX [Word8]
xs) = forall a. Show a => a -> String
show [Word8]
xs
  show (VPattern Pattern Value
pat) = String
"(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Pattern Value
pat forall a. [a] -> [a] -> [a]
++ String
")"
  show (VState ValueMap -> (ValueMap, Value)
f) = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ ValueMap -> (ValueMap, Value)
f forall k a. Map k a
Map.empty
  show (VList [Value]
vs) = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Value]
vs

instance {-# OVERLAPPING #-} Show ValueMap where
  show :: ValueMap -> String
show ValueMap
m = forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(String
name, Value
v) -> String
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
v) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList ValueMap
m

instance {-# OVERLAPPING #-} Show Arc where
  show :: Arc -> String
show (Arc Rational
s Rational
e) = Rational -> String
prettyRat Rational
s forall a. [a] -> [a] -> [a]
++ String
">" forall a. [a] -> [a] -> [a]
++ Rational -> String
prettyRat Rational
e

instance {-# OVERLAPPING #-} Show a => Show (Event a) where
  show :: Event a -> String
show Event a
e = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++) (forall a. Show a => Event a -> (String, String)
showEvent Event a
e)

prettyRat :: Rational -> String
prettyRat :: Rational -> String
prettyRat Rational
r | Int
unit forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Rational
frac forall a. Ord a => a -> a -> Bool
> Rational
0 = Integer -> Integer -> String
showFrac (forall a. Ratio a -> a
numerator Rational
frac) (forall a. Ratio a -> a
denominator Rational
frac)
            | Bool
otherwise =  forall a. Show a => a -> String
show Int
unit forall a. [a] -> [a] -> [a]
++ Integer -> Integer -> String
showFrac (forall a. Ratio a -> a
numerator Rational
frac) (forall a. Ratio a -> a
denominator Rational
frac)
  where unit :: Int
unit = forall a b. (RealFrac a, Integral b) => a -> b
floor Rational
r :: Int
        frac :: Rational
frac = Rational
r forall a. Num a => a -> a -> a
- forall a. Real a => a -> Rational
toRational Int
unit

showFrac :: Integer -> Integer -> String
showFrac :: Integer -> Integer -> String
showFrac Integer
0 Integer
_ = String
""
showFrac Integer
1 Integer
2 = String
"½"
showFrac Integer
1 Integer
3 = String
"⅓"
showFrac Integer
2 Integer
3 = String
"⅔"
showFrac Integer
1 Integer
4 = String
"¼"
showFrac Integer
3 Integer
4 = String
"¾"
showFrac Integer
1 Integer
5 = String
"⅕"
showFrac Integer
2 Integer
5 = String
"⅖"
showFrac Integer
3 Integer
5 = String
"⅗"
showFrac Integer
4 Integer
5 = String
"⅘"
showFrac Integer
1 Integer
6 = String
"⅙"
showFrac Integer
5 Integer
6 = String
"⅚"
showFrac Integer
1 Integer
7 = String
"⅐"
showFrac Integer
1 Integer
8 = String
"⅛"
showFrac Integer
3 Integer
8 = String
"⅜"
showFrac Integer
5 Integer
8 = String
"⅝"
showFrac Integer
7 Integer
8 = String
"⅞"
showFrac Integer
1 Integer
9 = String
"⅑"
showFrac Integer
1 Integer
10 = String
"⅒"

showFrac Integer
n Integer
d = forall a. a -> Maybe a -> a
fromMaybe String
plain forall a b. (a -> b) -> a -> b
$ do String
n' <- forall {a}. (Eq a, Num a) => a -> Maybe String
up Integer
n
                                    String
d' <- forall {a}. (Eq a, Num a) => a -> Maybe String
down Integer
d
                                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
n' forall a. [a] -> [a] -> [a]
++ String
d'
  where plain :: String
plain = forall a. Show a => a -> String
show Integer
n forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
d
        up :: a -> Maybe String
up a
1 = forall a. a -> Maybe a
Just String
"¹"
        up a
2 = forall a. a -> Maybe a
Just String
"²"
        up a
3 = forall a. a -> Maybe a
Just String
"³"
        up a
4 = forall a. a -> Maybe a
Just String
"⁴"
        up a
5 = forall a. a -> Maybe a
Just String
"⁵"
        up a
6 = forall a. a -> Maybe a
Just String
"⁶"
        up a
7 = forall a. a -> Maybe a
Just String
"⁷"
        up a
8 = forall a. a -> Maybe a
Just String
"⁸"
        up a
9 = forall a. a -> Maybe a
Just String
"⁹"
        up a
0 = forall a. a -> Maybe a
Just String
"⁰"
        up a
_ = forall a. Maybe a
Nothing
        down :: a -> Maybe String
down a
1 = forall a. a -> Maybe a
Just String
"₁"
        down a
2 = forall a. a -> Maybe a
Just String
"₂"
        down a
3 = forall a. a -> Maybe a
Just String
"₃"
        down a
4 = forall a. a -> Maybe a
Just String
"₄"
        down a
5 = forall a. a -> Maybe a
Just String
"₅"
        down a
6 = forall a. a -> Maybe a
Just String
"₆"
        down a
7 = forall a. a -> Maybe a
Just String
"₇"
        down a
8 = forall a. a -> Maybe a
Just String
"₈"
        down a
9 = forall a. a -> Maybe a
Just String
"₉"
        down a
0 = forall a. a -> Maybe a
Just String
"₀"
        down a
_ = forall a. Maybe a
Nothing

stepcount :: Pattern a -> Int
stepcount :: forall a. Pattern a -> Int
stepcount Pattern a
pat = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *} {b}.
(Foldable t, Integral b) =>
t (Ratio b) -> b
eventSteps forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\Arc
ev -> [forall a. ArcF a -> a
start Arc
ev, forall a. ArcF a -> a
stop Arc
ev]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. EventF a b -> a
part) (forall a. (a -> Bool) -> [a] -> [a]
filter forall a. Event a -> Bool
eventHasOnset forall a b. (a -> b) -> a -> b
$ forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern a
pat (forall a. a -> a -> ArcF a
Arc Rational
0 Rational
1))
  where eventSteps :: t (Ratio b) -> b
eventSteps t (Ratio b)
xs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. Integral a => a -> a -> a
lcm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ratio a -> a
denominator) b
1 t (Ratio b)
xs

data Render = Render Int Int String

instance Show Render where
  show :: Render -> String
show (Render Int
cyc Int
i String
render) | Int
i forall a. Ord a => a -> a -> Bool
<= Int
1024 = String
"\n[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
cyc forall a. [a] -> [a] -> [a]
++ (if Int
cyc forall a. Eq a => a -> a -> Bool
== Int
1 then String
" cycle" else String
" cycles") forall a. [a] -> [a] -> [a]
++ String
"]\n" forall a. [a] -> [a] -> [a]
++ String
render
                             | Bool
otherwise = String
"That pattern is too complex to draw."


drawLine :: Pattern Char -> Render
drawLine :: Pattern Char -> Render
drawLine = Int -> Pattern Char -> Render
drawLineSz Int
78

drawLineSz :: Int -> Pattern Char -> Render
drawLineSz :: Int -> Pattern Char -> Render
drawLineSz Int
sz Pattern Char
pat = Int -> [Render] -> Render
joinCycles Int
sz forall a b. (a -> b) -> a -> b
$ Pattern Char -> [Render]
drawCycles Pattern Char
pat
  where
    drawCycles :: Pattern Char -> [Render]
    drawCycles :: Pattern Char -> [Render]
drawCycles Pattern Char
pat' = Pattern Char -> Render
draw Pattern Char
pat'forall a. a -> [a] -> [a]
:Pattern Char -> [Render]
drawCycles (forall a. Rational -> Pattern a -> Pattern a
rotL Rational
1 Pattern Char
pat')
    joinCycles :: Int -> [Render] -> Render
    joinCycles :: Int -> [Render] -> Render
joinCycles Int
_ [] = Int -> Int -> String -> Render
Render Int
0 Int
0 String
""
    joinCycles Int
n ((Render Int
cyc Int
l String
s):[Render]
cs) | Int
l forall a. Ord a => a -> a -> Bool
> Int
n = Int -> Int -> String -> Render
Render Int
0 Int
0 String
""
                                       | Bool
otherwise = Int -> Int -> String -> Render
Render (Int
cycforall a. Num a => a -> a -> a
+Int
cyc') (Int
l forall a. Num a => a -> a -> a
+ Int
l' forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. [a] -> [a] -> [a]
(++)) [(String, String)]
lineZip
      where
        (Render Int
cyc' Int
l' String
s') = Int -> [Render] -> Render
joinCycles (Int
nforall a. Num a => a -> a -> a
-Int
lforall a. Num a => a -> a -> a
-Int
1) [Render]
cs
        linesN :: Int
linesN = forall a. Ord a => a -> a -> a
max (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s) (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s')
        lineZip :: [(String, String)]
lineZip = forall a. Int -> [a] -> [a]
take Int
linesN forall a b. (a -> b) -> a -> b
$
          forall a b. [a] -> [b] -> [(a, b)]
zip (String -> [String]
lines String
s forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat (forall a. Int -> a -> [a]
replicate Int
l Char
' '))
              (String -> [String]
lines String
s' forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat (forall a. Int -> a -> [a]
replicate Int
l' Char
' '))

      -- where maximum (map (length . head . (++ [""]) . lines) cs)


draw :: Pattern Char -> Render
draw :: Pattern Char -> Render
draw Pattern Char
pat = Int -> Int -> String -> Render
Render Int
1 Int
s (forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((Char
'|' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Event Char] -> String
drawLevel) [[Event Char]]
ls)
  where ls :: [[Event Char]]
ls = forall a. Eq a => Pattern a -> [[Event a]]
levels Pattern Char
pat
        s :: Int
s = forall a. Pattern a -> Int
stepcount Pattern Char
pat
        rs :: Rational
rs = forall a. Real a => a -> Rational
toRational Int
s
        drawLevel :: [Event Char] -> String
        drawLevel :: [Event Char] -> String
drawLevel [] = forall a. Int -> a -> [a]
replicate Int
s Char
'.'
        drawLevel (Event Char
e:[Event Char]
es) = forall a b. (a -> b) -> [a] -> [b]
map (Char, Char) -> Char
f forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
s forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip ([Event Char] -> String
drawLevel [Event Char]
es forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Char
'.') (Event Char -> String
drawEvent Event Char
e forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Char
'.')
        f :: (Char, Char) -> Char
f (Char
'.', Char
x) = Char
x
        f (Char
x, Char
_) = Char
x
        drawEvent :: Event Char -> String
        drawEvent :: Event Char -> String
drawEvent Event Char
ev = forall a. Int -> a -> [a]
replicate (forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ Rational
rs forall a. Num a => a -> a -> a
* Rational
evStart) Char
'.'
                       forall a. [a] -> [a] -> [a]
++ (forall a b. EventF a b -> b
value Event Char
evforall a. a -> [a] -> [a]
:forall a. Int -> a -> [a]
replicate (forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
rs forall a. Num a => a -> a -> a
* (Rational
evStop forall a. Num a => a -> a -> a
- Rational
evStart)) forall a. Num a => a -> a -> a
- Int
1) Char
'-')
          where evStart :: Rational
evStart = forall a. ArcF a -> a
start forall a b. (a -> b) -> a -> b
$ forall a. Event a -> Arc
wholeOrPart Event Char
ev
                evStop :: Rational
evStop = forall a. ArcF a -> a
stop forall a b. (a -> b) -> a -> b
$ forall a. Event a -> Arc
wholeOrPart Event Char
ev

{-
fitsWhole :: Event b -> [Event b] -> Bool
fitsWhole event events =
  not $ any (\event' -> isJust $ subArc (wholeOrPart event) (wholeOrPart event')) events

addEventWhole :: Event b -> [[Event b]] -> [[Event b]]
addEventWhole e [] = [[e]]
addEventWhole e (level:ls)
    | isAnalog e = level:ls
    | fitsWhole e level = (e:level) : ls
    | otherwise = level : addEventWhole e ls

arrangeEventsWhole :: [Event b] -> [[Event b]]
arrangeEventsWhole = foldr addEventWhole []

levelsWhole :: Eq a => Pattern a -> [[Event a]]
levelsWhole pat = arrangeEventsWhole $ sortOn' ((\Arc{..} -> 0 - (stop - start)) . wholeOrPart) (defragParts $ queryArc pat (Arc 0 1))

sortOn' :: Ord a => (b -> a) -> [b] -> [b]
sortOn' f = map snd . sortOn fst . map (\x -> let y = f x in y `seq` (y, x))
-}

fits :: Event b -> [Event b] -> Bool
fits :: forall b. Event b -> [Event b] -> Bool
fits (Event Context
_ Maybe Arc
_ Arc
part' b
_) [EventF Arc b]
events = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Event{b
Maybe Arc
Arc
Context
whole :: forall a b. EventF a b -> Maybe a
value :: b
part :: Arc
whole :: Maybe Arc
context :: Context
value :: forall a b. EventF a b -> b
context :: forall a b. EventF a b -> Context
part :: forall a b. EventF a b -> a
..} -> forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ Arc -> Arc -> Maybe Arc
subArc Arc
part' Arc
part) [EventF Arc b]
events

addEvent :: Event b -> [[Event b]] -> [[Event b]]
addEvent :: forall b. Event b -> [[Event b]] -> [[Event b]]
addEvent Event b
e [] = [[Event b
e]]
addEvent Event b
e ([Event b]
level:[[Event b]]
ls)
    | forall b. Event b -> [Event b] -> Bool
fits Event b
e [Event b]
level = (Event b
eforall a. a -> [a] -> [a]
:[Event b]
level) forall a. a -> [a] -> [a]
: [[Event b]]
ls
    | Bool
otherwise = [Event b]
level forall a. a -> [a] -> [a]
: forall b. Event b -> [[Event b]] -> [[Event b]]
addEvent Event b
e [[Event b]]
ls

arrangeEvents :: [Event b] -> [[Event b]]
arrangeEvents :: forall b. [Event b] -> [[Event b]]
arrangeEvents = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b. Event b -> [[Event b]] -> [[Event b]]
addEvent []

levels :: Eq a => Pattern a -> [[Event a]]
-- levels pat = arrangeEvents $ sortOn' ((\Arc{..} -> stop - start) . part) (defragParts $ queryArc pat (Arc 0 1))
levels :: forall a. Eq a => Pattern a -> [[Event a]]
levels Pattern a
pat = forall b. [Event b] -> [[Event b]]
arrangeEvents forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [Event a] -> [Event a]
defragParts forall a b. (a -> b) -> a -> b
$ forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern a
pat (forall a. a -> a -> ArcF a
Arc Rational
0 Rational
1)