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

showStateful :: ControlPattern -> String
showStateful :: ControlPattern -> String
showStateful ControlPattern
p = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" [String]
evStrings
  where (ValueMap
_, [Event ValueMap]
evs) = ValueMap -> [Event ValueMap] -> (ValueMap, [Event ValueMap])
resolveState (ValueMap
forall k a. Map k a
Map.empty) ([Event ValueMap] -> (ValueMap, [Event ValueMap]))
-> [Event ValueMap] -> (ValueMap, [Event ValueMap])
forall a b. (a -> b) -> a -> b
$ (Event ValueMap -> Arc) -> [Event ValueMap] -> [Event ValueMap]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Event ValueMap -> Arc
forall a b. EventF a b -> a
part ([Event ValueMap] -> [Event ValueMap])
-> [Event ValueMap] -> [Event ValueMap]
forall a b. (a -> b) -> a -> b
$ ControlPattern -> Arc -> [Event ValueMap]
forall a. Pattern a -> Arc -> [Event a]
queryArc (ControlPattern -> ControlPattern
forall a. Pattern a -> Pattern a
filterOnsets ControlPattern
p) (Time -> Time -> Arc
forall a. a -> a -> ArcF a
Arc Time
0 Time
1)
        evs' :: [(String, String)]
evs' = (Event ValueMap -> (String, String))
-> [Event ValueMap] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map Event ValueMap -> (String, String)
forall a. Show a => Event a -> (String, String)
showEvent [Event ValueMap]
evs
        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 (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))) Char
' ')
                       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'

showPattern :: Show a => Arc -> Pattern a -> String
showPattern :: Arc -> Pattern a -> String
showPattern Arc
a Pattern a
p = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\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 (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)) Char
' '
                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ (String -> ShowS) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (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 Context
_ (Just (Arc Time
ws Time
we)) a :: Arc
a@(Arc Time
ps Time
pe) a
e) =
  (String
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"(" 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
")" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|", 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 = String
""
          | Bool
otherwise = Time -> String
prettyRat Time
ws String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-"
        t :: String
t | Time
we Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
pe = String
""
          | Bool
otherwise = String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Time -> String
prettyRat Time
we

showEvent (Event Context
_ Maybe Arc
Nothing Arc
a a
e) =
  (String
"~" 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
"~|", 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 Arc
a Pattern a
p = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\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 [((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 String
s)  = (Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""
  show (VI Int
i)  = Int -> String
forall a. Show a => a -> String
show Int
i
  show (VF Double
f)  = Double -> String
forall a. Show a => a -> String
show Double
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"f"
  show (VN Note
n)  = Note -> String
forall a. Show a => a -> String
show Note
n
  show (VR Time
r)  = Time -> String
prettyRat Time
r String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"r"
  show (VB Bool
b)  = Bool -> String
forall a. Show a => a -> String
show Bool
b
  show (VX [Word8]
xs) = [Word8] -> String
forall a. Show a => a -> String
show [Word8]
xs
  show (VPattern Pattern Value
pat) = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Pattern Value -> String
forall a. Show a => a -> String
show Pattern Value
pat String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  show (VState ValueMap -> (ValueMap, Value)
f) = (ValueMap, Value) -> String
forall a. Show a => a -> String
show ((ValueMap, Value) -> String) -> (ValueMap, Value) -> String
forall a b. (a -> b) -> a -> b
$ ValueMap -> (ValueMap, Value)
f ValueMap
forall k a. Map k a
Map.empty
  show (VList [Value]
vs) = [String] -> String
forall a. Show a => a -> String
show ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Value -> String) -> [Value] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Value -> String
forall a. Show a => a -> String
show [Value]
vs

instance {-# OVERLAPPING #-} Show ValueMap where
  show :: ValueMap -> String
show ValueMap
m = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([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 (\(String
name, Value
v) -> String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " 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
$ ValueMap -> [(String, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList ValueMap
m

instance {-# OVERLAPPING #-} Show Arc where
  show :: Arc -> String
show (Arc Time
s Time
e) = Time -> String
prettyRat Time
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">" 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 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]
++ (String -> ShowS) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> ShowS
forall a. [a] -> [a] -> [a]
(++) (Event a -> (String, String)
forall a. Show a => Event a -> (String, String)
showEvent Event a
e)

prettyRat :: Rational -> String
prettyRat :: Time -> String
prettyRat Time
r | Int
unit Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Time
frac Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
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 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 = 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
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
d
        up :: a -> Maybe String
up a
1 = String -> Maybe String
forall a. a -> Maybe a
Just String
"¹"
        up a
2 = String -> Maybe String
forall a. a -> Maybe a
Just String
"²"
        up a
3 = String -> Maybe String
forall a. a -> Maybe a
Just String
"³"
        up a
4 = String -> Maybe String
forall a. a -> Maybe a
Just String
"⁴"
        up a
5 = String -> Maybe String
forall a. a -> Maybe a
Just String
"⁵"
        up a
6 = String -> Maybe String
forall a. a -> Maybe a
Just String
"⁶"
        up a
7 = String -> Maybe String
forall a. a -> Maybe a
Just String
"⁷"
        up a
8 = String -> Maybe String
forall a. a -> Maybe a
Just String
"⁸"
        up a
9 = String -> Maybe String
forall a. a -> Maybe a
Just String
"⁹"
        up a
0 = String -> Maybe String
forall a. a -> Maybe a
Just String
"⁰"
        up a
_ = Maybe String
forall a. Maybe a
Nothing
        down :: a -> Maybe String
down a
1 = String -> Maybe String
forall a. a -> Maybe a
Just String
"₁"
        down a
2 = String -> Maybe String
forall a. a -> Maybe a
Just String
"₂"
        down a
3 = String -> Maybe String
forall a. a -> Maybe a
Just String
"₃"
        down a
4 = String -> Maybe String
forall a. a -> Maybe a
Just String
"₄"
        down a
5 = String -> Maybe String
forall a. a -> Maybe a
Just String
"₅"
        down a
6 = String -> Maybe String
forall a. a -> Maybe a
Just String
"₆"
        down a
7 = String -> Maybe String
forall a. a -> Maybe a
Just String
"₇"
        down a
8 = String -> Maybe String
forall a. a -> Maybe a
Just String
"₈"
        down a
9 = String -> Maybe String
forall a. a -> Maybe a
Just String
"₉"
        down a
0 = String -> Maybe String
forall a. a -> Maybe a
Just String
"₀"
        down a
_ = Maybe String
forall a. Maybe a
Nothing

stepcount :: Pattern a -> Int
stepcount :: Pattern a -> Int
stepcount 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 (t :: * -> *) b.
(Foldable t, Integral b) =>
t (Ratio b) -> b
eventSteps ([Time] -> Integer) -> [Time] -> Integer
forall a b. (a -> b) -> a -> b
$ (EventF Arc a -> [Time]) -> [EventF Arc a] -> [Time]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\Arc
ev -> [Arc -> Time
forall a. ArcF a -> a
start Arc
ev, Arc -> Time
forall a. ArcF a -> a
stop Arc
ev]) (Arc -> [Time]) -> (EventF Arc a -> Arc) -> EventF Arc a -> [Time]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EventF Arc a -> Arc
forall a b. EventF a b -> a
part) ((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 Time
0 Time
1))
  where eventSteps :: t (Ratio b) -> b
eventSteps t (Ratio b)
xs = (Ratio b -> b -> b) -> b -> t (Ratio 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 (b -> b -> b) -> (Ratio b -> b) -> Ratio b -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ratio b -> b
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1024 = String
"\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
== Int
1 then String
" cycle" else String
" cycles") String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]\n" String -> ShowS
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 ([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 Pattern Char
pat' = Pattern Char -> Render
draw Pattern Char
pat'Render -> [Render] -> [Render]
forall a. a -> [a] -> [a]
:Pattern Char -> [Render]
drawCycles (Time -> Pattern Char -> Pattern Char
forall a. Time -> Pattern a -> Pattern a
rotL Time
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 Int -> Int -> Bool
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
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
+ Int
1) (String -> Render) -> String -> Render
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\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 ((String -> ShowS) -> (String, String) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> ShowS
forall a. [a] -> [a] -> [a]
(++)) [(String, String)]
lineZip
      where
        (Render Int
cyc' Int
l' 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
-Int
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 (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
l Char
' '))
              (String -> [String]
lines String
s' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
forall a. a -> [a]
repeat (Int -> Char -> String
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 (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\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 ((Char
'|' Char -> ShowS
forall a. a -> [a] -> [a]
:) 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 Char
'.'
        drawLevel (Event Char
e:[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 Char
'.') (Event Char -> String
drawEvent Event Char
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
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 = 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) Char
'.'
                       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
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
- Int
1) Char
'-')
          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 Context
_ Maybe Arc
_ Arc
part' b
_) [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{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
..} -> 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 Event b
e [] = [[Event b
e]]
addEvent Event b
e ([Event b]
level:[[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 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 Time
0 Time
1)