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

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

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 = Arc -> Pattern a -> String
forall a. Show a => Arc -> Pattern a -> String
showPattern (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc 0 1)

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

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

showEvent (Event _ Nothing a :: Arc
a e :: a
e) =
  ("~" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Arc -> String
forall a. Show a => a -> String
show Arc
a String -> ShowS
forall a. [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 :: Arc -> Pattern a -> String
showAll a :: Arc
a p :: Pattern a
p = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (EventF Arc a -> String) -> [EventF Arc a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map EventF Arc a -> String
forall a. Show a => a -> String
show ([EventF Arc a] -> [String]) -> [EventF Arc a] -> [String]
forall a b. (a -> b) -> a -> b
$ (EventF Arc a -> Arc) -> [EventF Arc a] -> [EventF Arc a]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn EventF Arc a -> Arc
forall a b. EventF a b -> a
part ([EventF Arc a] -> [EventF Arc a])
-> [EventF Arc a] -> [EventF Arc a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> Arc -> [EventF Arc a]
forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern a
p Arc
a

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

instance Show Value where
  show :: Value -> String
show (VS s :: String
s) = ('"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\""
  show (VI i :: Int
i) = Int -> String
forall a. Show a => a -> String
show Int
i
  show (VF f :: Double
f) = Double -> String
forall a. Show a => a -> String
show Double
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ "f"
  show (VR r :: Time
r) = Time -> String
forall a. Show a => a -> String
show Time
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ "r"
  show (VB b :: Bool
b) = Bool -> String
forall a. Show a => a -> String
show Bool
b
  show (VX xs :: [Word8]
xs) = [Word8] -> String
forall a. Show a => a -> String
show [Word8]
xs

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

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

instance {-# OVERLAPPING #-} Show a => Show (Event a) where
  show :: Event a -> String
show e :: Event a
e = Context -> String
forall a. Show a => a -> String
show (Event a -> Context
forall a b. EventF a b -> Context
context Event a
e) String -> ShowS
forall a. [a] -> [a] -> [a]
++ ((\(a :: String
a,b :: String
b) -> String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
b) ((String, String) -> String) -> (String, String) -> String
forall a b. (a -> b) -> a -> b
$ Event a -> (String, String)
forall a. Show a => Event a -> (String, String)
showEvent Event a
e)

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

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

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

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

data Render = Render Int Int String

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


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

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


draw :: Pattern Char -> Render
draw :: Pattern Char -> Render
draw pat :: Pattern Char
pat = Int -> Int -> String -> Render
Render 1 Int
s (String -> Render) -> String -> Render
forall a b. (a -> b) -> a -> b
$ (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ([Event Char] -> String) -> [[Event Char]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((\x :: String
x -> ('|'Char -> ShowS
forall a. a -> [a] -> [a]
:String
x)) ShowS -> ([Event Char] -> String) -> [Event Char] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[Event Char] -> String
drawLevel) [[Event Char]]
ls)
  where ls :: [[Event Char]]
ls = Pattern Char -> [[Event Char]]
forall a. Eq a => Pattern a -> [[Event a]]
levels Pattern Char
pat
        s :: Int
s = Pattern Char -> Int
forall a. Pattern a -> Int
stepcount Pattern Char
pat
        rs :: Time
rs = Int -> Time
forall a. Real a => a -> Time
toRational Int
s
        drawLevel :: [Event Char] -> String
        drawLevel :: [Event Char] -> String
drawLevel [] = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
s ' '
        drawLevel (e :: Event Char
e:es :: [Event Char]
es) = ((Char, Char) -> Char) -> [(Char, Char)] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Char, Char) -> Char
f ([(Char, Char)] -> String) -> [(Char, Char)] -> String
forall a b. (a -> b) -> a -> b
$ Int -> [(Char, Char)] -> [(Char, Char)]
forall a. Int -> [a] -> [a]
take Int
s ([(Char, Char)] -> [(Char, Char)])
-> [(Char, Char)] -> [(Char, Char)]
forall a b. (a -> b) -> a -> b
$ String -> String -> [(Char, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Event Char] -> String
drawLevel [Event Char]
es String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat ' ') (Event Char -> String
drawEvent Event Char
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. a -> [a]
repeat ' ')
        f :: (Char, Char) -> Char
f (' ', x :: Char
x) = Char
x
        f (x :: Char
x, _) = Char
x
        drawEvent :: Event Char -> String
        drawEvent :: Event Char -> String
drawEvent ev :: Event Char
ev = (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Time -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Time -> Int) -> Time -> Int
forall a b. (a -> b) -> a -> b
$ Time
rs Time -> Time -> Time
forall a. Num a => a -> a -> a
* Time
evStart) ' ')
                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Event Char -> Char
forall a b. EventF a b -> b
value Event Char
evChar -> ShowS
forall a. a -> [a] -> [a]
:(Int -> Char -> String
forall a. Int -> a -> [a]
replicate ((Time -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Time -> Int) -> Time -> Int
forall a b. (a -> b) -> a -> b
$ Time
rs Time -> Time -> Time
forall a. Num a => a -> a -> a
* (Time
evStop Time -> Time -> Time
forall a. Num a => a -> a -> a
- Time
evStart)) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) '-'))
          where evStart :: Time
evStart = Arc -> Time
forall a. ArcF a -> a
start (Arc -> Time) -> Arc -> Time
forall a b. (a -> b) -> a -> b
$ Event Char -> Arc
forall a. Event a -> Arc
wholeOrPart Event Char
ev
                evStop :: Time
evStop = Arc -> Time
forall a. ArcF a -> a
stop (Arc -> Time) -> Arc -> Time
forall a b. (a -> b) -> a -> b
$ Event Char -> Arc
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 :: Event b -> [Event b] -> Bool
fits (Event _ _ part' :: Arc
part' _) events :: [Event b]
events = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Event b -> Bool) -> [Event b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Event{..} -> Maybe Arc -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Arc -> Bool) -> Maybe Arc -> Bool
forall a b. (a -> b) -> a -> b
$ Arc -> Arc -> Maybe Arc
subArc Arc
part' Arc
part) [Event b]
events

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

arrangeEvents :: [Event b] -> [[Event b]]
arrangeEvents :: [Event b] -> [[Event b]]
arrangeEvents = (Event b -> [[Event b]] -> [[Event b]])
-> [[Event b]] -> [Event b] -> [[Event b]]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Event b -> [[Event b]] -> [[Event b]]
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 :: Pattern a -> [[Event a]]
levels pat :: Pattern a
pat = [Event a] -> [[Event a]]
forall b. [Event b] -> [[Event b]]
arrangeEvents ([Event a] -> [[Event a]]) -> [Event a] -> [[Event a]]
forall a b. (a -> b) -> a -> b
$ [Event a] -> [Event a]
forall a. [a] -> [a]
reverse ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall a b. (a -> b) -> a -> b
$ [Event a] -> [Event a]
forall a. Eq a => [Event a] -> [Event a]
defragParts ([Event a] -> [Event a]) -> [Event a] -> [Event a]
forall a b. (a -> b) -> a -> b
$ Pattern a -> Arc -> [Event a]
forall a. Pattern a -> Arc -> [Event a]
queryArc Pattern a
pat (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc 0 1)