{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE 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 Data.List (intercalate, sortOn)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, isJust)
import Data.Ratio (denominator, numerator)
import Sound.Tidal.Pattern

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 (Rational -> Rational -> Arc
forall a. a -> a -> ArcF a
Arc Rational
0 Rational
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) (Rational -> Rational -> Arc
forall a. a -> a -> ArcF a
Arc Rational
0 Rational
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 a. Ord a => [a] -> a
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 a. [a] -> 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 a. [a] -> 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 :: forall a. Show a => Arc -> Pattern a -> String
showPattern Arc
_ (Pattern State -> [Event a]
_ Maybe (Pattern Rational)
_ (Just a
v)) = String
"(pure " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v String -> ShowS
forall a. [a] -> [a] -> [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 a. Ord a => [a] -> a
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 a. [a] -> 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 a. [a] -> 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 :: 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 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
      | Rational
ws Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
ps = String
""
      | Bool
otherwise = Rational -> String
prettyRat Rational
ws String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-"
    t :: String
t
      | Rational
we Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
pe = String
""
      | Bool
otherwise = String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Rational -> String
prettyRat Rational
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 :: forall a. Show a => 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
$ (Event a -> String) -> [Event a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Event a -> String
forall a. Show a => Event a -> String
showEventAll ([Event a] -> [String]) -> [Event a] -> [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

-- Show context of an event
showEventAll :: (Show a) => Event a -> String
showEventAll :: forall a. Show a => Event a -> String
showEventAll 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)

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 Rational
r) = Rational -> String
prettyRat Rational
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 Rational
s Rational
e) = Rational -> String
prettyRat Rational
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">" String -> ShowS
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 = (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 :: Rational -> String
prettyRat Rational
r
  | Int
unit Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Rational
frac Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> Rational
0 = Integer -> Integer -> String
showFrac (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
frac) (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
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 (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
frac) (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
frac)
  where
    unit :: Int
unit = Rational -> Int
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor Rational
r :: Int
    frac :: Rational
frac = Rational
r Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Int -> Rational
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 = 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 a. a -> Maybe a
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 :: forall a. 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
$ [Rational] -> Integer
forall {t :: * -> *} {b}.
(Foldable t, Integral b) =>
t (Ratio b) -> b
eventSteps ([Rational] -> Integer) -> [Rational] -> Integer
forall a b. (a -> b) -> a -> b
$ (EventF Arc a -> [Rational]) -> [EventF Arc a] -> [Rational]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\Arc
ev -> [Arc -> Rational
forall a. ArcF a -> a
start Arc
ev, Arc -> Rational
forall a. ArcF a -> a
stop Arc
ev]) (Arc -> [Rational])
-> (EventF Arc a -> Arc) -> EventF Arc a -> [Rational]
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 (Rational -> Rational -> Arc
forall a. a -> a -> ArcF a
Arc Rational
0 Rational
1))
  where
    eventSteps :: t (Ratio b) -> b
eventSteps t (Ratio b)
xs = (Ratio b -> b -> b) -> b -> t (Ratio b) -> b
forall a b. (a -> b -> b) -> b -> t a -> 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 (Rational -> Pattern Char -> Pattern Char
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 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
cyc Int -> 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
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l Int -> 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 a. [a] -> 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 a. [a] -> 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 :: Rational
rs = Int -> Rational
forall a. Real a => a -> Rational
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 (Rational -> Int
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ Rational
rs Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
evStart) Char
'.'
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Event Char -> Char
forall a b. EventF a b -> b
value Event Char
ev Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Rational -> Int
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational
rs Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Rational
evStop Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
evStart)) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
'-')
      where
        evStart :: Rational
evStart = Arc -> Rational
forall a. ArcF a -> a
start (Arc -> Rational) -> Arc -> Rational
forall a b. (a -> b) -> a -> b
$ Event Char -> Arc
forall a. Event a -> Arc
wholeOrPart Event Char
ev
        evStop :: Rational
evStop = Arc -> Rational
forall a. ArcF a -> a
stop (Arc -> Rational) -> Arc -> Rational
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 :: forall b. Event b -> [Event b] -> Bool
fits (Event Context
_ Maybe Arc
_ Arc
part' b
_) [EventF Arc b]
events = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (EventF Arc b -> Bool) -> [EventF Arc b] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Event {b
Maybe Arc
Arc
Context
part :: forall a b. EventF a b -> a
context :: forall a b. EventF a b -> Context
value :: forall a b. EventF a b -> b
context :: Context
whole :: Maybe Arc
part :: Arc
value :: b
whole :: forall a b. EventF a b -> Maybe 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) [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)
  | Event b -> [Event b] -> Bool
forall b. Event b -> [Event b] -> Bool
fits Event b
e [Event b]
level = (Event b
e Event 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 :: forall b. [Event b] -> [[Event b]]
arrangeEvents = (Event b -> [[Event b]] -> [[Event b]])
-> [[Event b]] -> [Event b] -> [[Event b]]
forall a b. (a -> b -> b) -> b -> [a] -> 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 :: forall a. Eq a => 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 (Rational -> Rational -> Arc
forall a. a -> a -> ArcF a
Arc Rational
0 Rational
1)