-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

-- | Cmds related to view level state.
module Cmd.ViewConfig where
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Tuple as Tuple

import qualified Util.Control as Control
import qualified Util.Lens as Lens
import qualified Util.Lists as Lists
import qualified Util.Num as Num
import qualified Util.Rect as Rect

import qualified App.Config as Config
import qualified Cmd.Cmd as Cmd
import qualified Cmd.Create as Create
import qualified Cmd.Selection as Selection
import qualified Cmd.TimeStep as TimeStep
import qualified Cmd.Views as Views

import qualified Ui.Block as Block
import qualified Ui.Meter.Meter as Meter
import qualified Ui.ScoreTime as ScoreTime
import qualified Ui.Sel as Sel
import qualified Ui.Ui as Ui
import qualified Ui.UiConfig as UiConfig
import qualified Ui.Zoom as Zoom

import           Global
import           Types


-- * zoom

cmd_zoom_around_insert :: Cmd.M m => (Double -> Double) -> m ()
cmd_zoom_around_insert :: forall (m :: * -> *). M m => (Double -> Double) -> m ()
cmd_zoom_around_insert Double -> Double
f = do
    (ViewId
view_id, (BlockId
_, Int
_, TrackTime
pos)) <- forall (m :: * -> *). M m => m (ViewId, AnyPoint)
Selection.get_any_insert
    forall (m :: * -> *).
M m =>
ViewId -> TrackTime -> (Double -> Double) -> m ()
cmd_zoom_around ViewId
view_id TrackTime
pos Double -> Double
f

cmd_zoom_around :: Cmd.M m => ViewId -> ScoreTime -> (Double -> Double) -> m ()
cmd_zoom_around :: forall (m :: * -> *).
M m =>
ViewId -> TrackTime -> (Double -> Double) -> m ()
cmd_zoom_around ViewId
view_id TrackTime
pos Double -> Double
f = do
    -- Zoom by the given factor, but try to keep pos in the same place on the
    -- screen.
    Zoom
zoom <- forall (m :: * -> *). M m => ViewId -> m Zoom
Ui.get_zoom ViewId
view_id
    forall (m :: * -> *). M m => ViewId -> Zoom -> m ()
Views.set_zoom ViewId
view_id (Zoom -> TrackTime -> (Double -> Double) -> Zoom
zoom_around Zoom
zoom TrackTime
pos Double -> Double
f)

zoom_around :: Zoom.Zoom -> ScoreTime -> (Double -> Double) -> Zoom.Zoom
zoom_around :: Zoom -> TrackTime -> (Double -> Double) -> Zoom
zoom_around (Zoom.Zoom TrackTime
offset Double
factor) TrackTime
pos Double -> Double
f = Zoom.Zoom
    { offset :: TrackTime
offset = TrackTime -> TrackTime -> TrackTime -> TrackTime -> TrackTime
zoom_pos TrackTime
offset TrackTime
pos (Double -> TrackTime
ScoreTime.from_double Double
factor)
        (Double -> TrackTime
ScoreTime.from_double Double
newf)
    , factor :: Double
factor = Double
newf
    }
    where newf :: Double
newf = Double -> Double
f Double
factor

zoom_pos :: ScoreTime -> ScoreTime -> ScoreTime -> ScoreTime -> ScoreTime
zoom_pos :: TrackTime -> TrackTime -> TrackTime -> TrackTime -> TrackTime
zoom_pos TrackTime
offset TrackTime
pos TrackTime
oldf TrackTime
newf = (TrackTime
offset forall a. Num a => a -> a -> a
- TrackTime
pos) forall a. Num a => a -> a -> a
* (TrackTime
oldfforall a. Fractional a => a -> a -> a
/TrackTime
newf) forall a. Num a => a -> a -> a
+ TrackTime
pos

modify_factor :: Cmd.M m => ViewId -> (Double -> Double) -> m ()
modify_factor :: forall (m :: * -> *). M m => ViewId -> (Double -> Double) -> m ()
modify_factor ViewId
view_id Double -> Double
f = do
    Zoom
zoom <- forall (m :: * -> *). M m => ViewId -> m Zoom
Ui.get_zoom ViewId
view_id
    forall (m :: * -> *). M m => ViewId -> Zoom -> m ()
Views.set_zoom ViewId
view_id forall a b. (a -> b) -> a -> b
$ Zoom
zoom { factor :: Double
Zoom.factor = Double -> Double
f (Zoom -> Double
Zoom.factor Zoom
zoom) }

-- | Zoom to the ruler duration if the selection is a point, or zoom to the
-- selection if it's not.
zoom_to_ruler_or_selection :: Cmd.M m => m ()
zoom_to_ruler_or_selection :: forall (m :: * -> *). M m => m ()
zoom_to_ruler_or_selection = do
    (ViewId
view_id, Selection
sel) <- forall (m :: * -> *). M m => m (ViewId, Selection)
Selection.get_view_sel
    if Selection -> Bool
Sel.is_point Selection
sel
        then forall (m :: * -> *). M m => ViewId -> m ()
Views.zoom_to_ruler ViewId
view_id
        else forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall (m :: * -> *).
M m =>
ViewId -> TrackTime -> TrackTime -> m ()
zoom_to ViewId
view_id) (Selection -> (TrackTime, TrackTime)
Sel.range Selection
sel)

zoom_to :: Cmd.M m => ViewId -> TrackTime -> TrackTime -> m ()
zoom_to :: forall (m :: * -> *).
M m =>
ViewId -> TrackTime -> TrackTime -> m ()
zoom_to ViewId
view_id TrackTime
start TrackTime
end =
    forall (m :: * -> *). M m => ViewId -> Zoom -> m ()
Views.set_zoom ViewId
view_id forall b c a. (b -> c) -> (a -> b) -> a -> c
. TrackTime -> Double -> Zoom
Zoom.Zoom TrackTime
start
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => ViewId -> TrackTime -> m Double
Views.zoom_factor ViewId
view_id (TrackTime
end forall a. Num a => a -> a -> a
- TrackTime
start)

-- | Go through zoom factors for timesteps at the current point, and pick the
-- next larger or smaller one.
zoom_by_rank :: Cmd.M m => TimeStep.Direction -> m ()
zoom_by_rank :: forall (m :: * -> *). M m => Direction -> m ()
zoom_by_rank Direction
direction = do
    (ViewId
view_id, (BlockId
block_id, Int
tracknum, TrackTime
pos)) <- forall (m :: * -> *). M m => m (ViewId, AnyPoint)
Selection.get_any_insert
    Double
factor <- Zoom -> Double
Zoom.factor forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => ViewId -> m Zoom
Ui.get_zoom ViewId
view_id
    let dur_at :: Rank -> m (Maybe TrackTime)
dur_at = forall (m :: * -> *).
M m =>
BlockId -> Int -> TrackTime -> TimeStep -> m (Maybe TrackTime)
TimeStep.duration_at BlockId
block_id Int
tracknum TrackTime
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rank -> TimeStep
TimeStep.rank
    Maybe Double
mb_factor <- forall state a. state -> ((state -> a) -> state -> a) -> a
Control.loop1 [Rank]
ranks forall a b. (a -> b) -> a -> b
$ \[Rank] -> m (Maybe Double)
loop -> \case
        Rank
rank : [Rank]
ranks -> Rank -> m (Maybe TrackTime)
dur_at Rank
rank forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just TrackTime
dur
                | Double -> Double -> Bool
cmp Double
f Double
factor -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Double
f
                | Bool
otherwise -> [Rank] -> m (Maybe Double)
loop [Rank]
ranks
                where
                cmp :: Double -> Double -> Bool
cmp = case Direction
direction of
                    Direction
TimeStep.Advance -> forall a. Ord a => a -> a -> Bool
(>)
                    Direction
TimeStep.Rewind -> forall a. Ord a => a -> a -> Bool
(<)
                f :: Double
f = TrackTime -> Double
time_to_zoom TrackTime
dur
            Maybe TrackTime
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Double
mb_factor forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
M m =>
ViewId -> TrackTime -> (Double -> Double) -> m ()
cmd_zoom_around ViewId
view_id TrackTime
pos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
    where
    ranks :: [Rank]
ranks = case Direction
direction of
        Direction
TimeStep.Advance -> [Rank]
rs
        Direction
TimeStep.Rewind -> forall a. [a] -> [a]
reverse [Rank]
rs
        where rs :: [Rank]
rs = [Rank
Meter.W .. forall a. Bounded a => a
maxBound]

-- | Set zoom to where text at the given timestep should be visible.
-- This means the timestep amount of score should get Config.event_text_height
-- pixels.
zoom_to_rank :: Cmd.M m => Meter.Rank -> m ()
zoom_to_rank :: forall (m :: * -> *). M m => Rank -> m ()
zoom_to_rank Rank
rank = do
    (ViewId
view_id, (BlockId
block_id, Int
tracknum, TrackTime
pos)) <- forall (m :: * -> *). M m => m (ViewId, AnyPoint)
Selection.get_any_insert
    forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> (a -> m ()) -> m ()
whenJustM (forall (m :: * -> *).
M m =>
BlockId -> Int -> TrackTime -> TimeStep -> m (Maybe TrackTime)
TimeStep.duration_at BlockId
block_id Int
tracknum TrackTime
pos TimeStep
tstep) forall a b. (a -> b) -> a -> b
$ \TrackTime
dur ->
        forall (m :: * -> *).
M m =>
ViewId -> TrackTime -> (Double -> Double) -> m ()
cmd_zoom_around ViewId
view_id TrackTime
pos (forall a b. a -> b -> a
const (TrackTime -> Double
time_to_zoom TrackTime
dur))
    where tstep :: TimeStep
tstep = Rank -> TimeStep
TimeStep.rank Rank
rank

time_to_zoom :: TrackTime -> Double
time_to_zoom :: TrackTime -> Double
time_to_zoom TrackTime
step = Double
text forall a. Fractional a => a -> a -> a
/ TrackTime -> Double
ScoreTime.to_double TrackTime
step
    where text :: Double
text = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
Config.event_text_height

-- * scroll

-- | Scroll by the number of pages, where a page is a fraction of the score
-- visible at the current zoom.
scroll_pages :: Cmd.M m => TrackTime -> m ()
scroll_pages :: forall (m :: * -> *). M m => TrackTime -> m ()
scroll_pages TrackTime
pages = do
    ViewId
view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    View
view <- forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id
    let visible :: TrackTime
visible = View -> TrackTime
Block.visible_time View
view
        offset :: TrackTime
offset = Zoom -> TrackTime
Zoom.offset forall a b. (a -> b) -> a -> b
$ View -> Zoom
Block.view_zoom View
view
    forall (m :: * -> *). M m => ViewId -> TrackTime -> m ()
Views.set_time_offset ViewId
view_id (TrackTime
offset forall a. Num a => a -> a -> a
+ TrackTime
pages forall a. Num a => a -> a -> a
* TrackTime
visible)

scroll_to_end :: Cmd.M m => m ()
scroll_to_end :: forall (m :: * -> *). M m => m ()
scroll_to_end = do
    ViewId
view_id <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    forall (m :: * -> *). M m => ViewId -> TrackTime -> m ()
Views.set_time_offset ViewId
view_id forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => ViewId -> m TrackTime
Views.block_end ViewId
view_id

scroll_to_home :: Cmd.M m => m ()
scroll_to_home :: forall (m :: * -> *). M m => m ()
scroll_to_home = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *). M m => ViewId -> TrackTime -> m ()
Views.set_time_offset TrackTime
0 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view

-- * resize

resize_all :: Cmd.M m => m ()
resize_all :: forall (m :: * -> *). M m => m ()
resize_all = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => Bool -> ViewId -> m ()
Views.resize_to_fit Bool
False) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m [ViewId]
Ui.all_view_ids

set_suggested_track_widths :: Cmd.M m => ViewId -> m ()
set_suggested_track_widths :: forall (m :: * -> *). M m => ViewId -> m ()
set_suggested_track_widths ViewId
view_id = do
    BlockId
block_id <- forall (m :: * -> *). M m => ViewId -> m BlockId
Ui.block_id_of ViewId
view_id
    [(Track, Int)]
tracks <- forall (m :: * -> *). M m => BlockId -> m [(Track, Int)]
Ui.block_tracknums BlockId
block_id
    let changes :: [(Int, Int)]
changes = do
            (Track
track, Int
tracknum) <- [(Track, Int)]
tracks
            let suggested :: Int
suggested = Track -> Int
Block.track_suggested_width Track
track
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
suggested forall a. Eq a => a -> a -> Bool
/= Track -> Int
Block.track_width Track
track)
            forall (m :: * -> *) a. Monad m => a -> m a
return (Int
tracknum, Int
suggested)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, Int)]
changes) forall a b. (a -> b) -> a -> b
$ do
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall (m :: * -> *). M m => BlockId -> Int -> Int -> m ()
Ui.set_track_width BlockId
block_id)) [(Int, Int)]
changes
        forall (m :: * -> *). M m => Bool -> ViewId -> m ()
Views.resize_to_fit Bool
False ViewId
view_id

-- * window management

-- If a window significantly overlaps its left neighbor, and is a certain
-- distance below it, then shorten the neighbor and line up to the neigbor's
-- left edge.
--
-- Or, try to tile, but if a window winds up going off the screen, then shorten
-- everything in that column until they fit.  So I can do 'fit_rects', and then
-- just shrink horizontally and vertically.
--
-- In general I don't want to expand windows because I want to leave space for
-- new ones.  Or maybe I could expand vertically, but leave horizontal space
-- open.
--
-- Use cases: put a window halfway down another one and expect them to tile
-- vertically.

-- -- | Infer a tiling layout based on current window position, and move and
-- -- resize them to fit.
-- auto_tile :: Cmd.M m => m ()
-- auto_tile = do

-- | Fit rectangles into a tiling pattern.  The algorithm is to sort them by
-- X and Y, and place the first rectangle at (0, 0).  Then try to fit each
-- rectangle to the below or the right of each already placed rectangle,
-- filtering out the positions that would cause an overlap, and pick the spot
-- closest to the rectangle's original position.  The whole process is started
-- again with any rectangles that wind up totally outside the screen.
fit_rects :: Rect.Rect -> [(ViewId, Rect.Rect)] -> [(ViewId, Rect.Rect)]
fit_rects :: Rect -> [(ViewId, Rect)] -> [(ViewId, Rect)]
fit_rects Rect
screen =
    forall {p}. p -> p
redo_outside forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}. [(a, Rect)] -> (a, Rect) -> [(a, Rect)]
fit []
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn (\(ViewId
_, Rect
r) -> (Rect -> Int
Rect.x Rect
r, Rect -> Int
Rect.y Rect
r))
    where
    fit :: [(a, Rect)] -> (a, Rect) -> [(a, Rect)]
fit [(a, Rect)]
windows (a
view_id, Rect
rect) = case forall a. [a] -> Maybe a
Lists.head (Rect -> [(Int, Int)] -> [(Int, Int)]
sort Rect
rect [(Int, Int)]
corners) of
        Just (Int
x, Int
y) -> (a
view_id, Int -> Int -> Rect -> Rect
Rect.place Int
x Int
y Rect
rect) forall a. a -> [a] -> [a]
: [(a, Rect)]
windows
        -- Shouldn't happen since you can always place to the right or
        -- below the rightmost or bottom rectangle.
        -- Nothing -> error $ "no corners for " <> show rect
        Maybe (Int, Int)
Nothing -> (a
view_id, Rect
rect) forall a. a -> [a] -> [a]
: [(a, Rect)]
windows
        where
        rects :: [Rect]
rects = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, Rect)]
windows
        corners :: [(Int, Int)]
corners =
            forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Rect] -> Rect -> (Int, Int) -> Bool
would_overlap [Rect]
rects Rect
rect) (Rect -> [Rect] -> [(Int, Int)]
corners_of Rect
screen [Rect]
rects)

    sort :: Rect -> [(Int, Int)] -> [(Int, Int)]
sort Rect
rect = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Int, Int) -> Double
Rect.point_distance (Rect -> (Int, Int)
Rect.upper_left Rect
rect)
    -- If there are rects outside the screen, fit them again into an empty
    -- screen.  I should run out eventually.
    redo_outside :: p -> p
redo_outside p
rects = p
rects
        -- - | null outside = inside
        -- - | otherwise = fit_rects screen outside ++ inside
        -- where
        -- (inside, outside) = List.partition
        --     (Rect.contains_point screen . Rect.upper_left . snd) rects

corners_of :: Rect.Rect -> [Rect.Rect] -> [(Int, Int)]
corners_of :: Rect -> [Rect] -> [(Int, Int)]
corners_of Rect
screen [] = [Rect -> (Int, Int)
Rect.upper_left Rect
screen]
corners_of Rect
_ [Rect]
rects =
    forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int, Int)
p -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ (Int, Int) -> Bool
point_above (Int, Int)
p Bool -> Bool -> Bool
|| (Int, Int) -> Bool
point_left (Int, Int)
p) [(Int, Int)]
not_touching
    where
    not_touching :: [(Int, Int)]
not_touching = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Bool
touches) forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map Rect -> (Int, Int)
Rect.lower_left [Rect]
rects forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Rect -> (Int, Int)
Rect.upper_right [Rect]
rects
    point_above :: (Int, Int) -> Bool
point_above (Int
x, Int
y) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Int
x1, Int
y1) -> Int
x1 forall a. Eq a => a -> a -> Bool
== Int
x Bool -> Bool -> Bool
&& Int
y1 forall a. Ord a => a -> a -> Bool
< Int
y) [(Int, Int)]
not_touching
    point_left :: (Int, Int) -> Bool
point_left (Int
x, Int
y) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Int
x1, Int
y1) -> Int
x1 forall a. Ord a => a -> a -> Bool
< Int
x Bool -> Bool -> Bool
&& Int
y1 forall a. Eq a => a -> a -> Bool
== Int
y) [(Int, Int)]
not_touching
    touches :: (Int, Int) -> Bool
touches (Int, Int)
p = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Rect
r -> Rect -> (Int, Int) -> Bool
Rect.contains_point Rect
r (Int, Int)
p) [Rect]
rects

-- If I move the rect to the point, will it overlap with anything in the
-- list?
would_overlap :: [Rect.Rect] -> Rect.Rect -> (Int, Int) -> Bool
would_overlap :: [Rect] -> Rect -> (Int, Int) -> Bool
would_overlap [Rect]
rects Rect
rect (Int
x, Int
y) =
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Rect -> Rect -> Bool
Rect.overlaps (Int -> Int -> Rect -> Rect
Rect.place Int
x Int
y Rect
rect)) [Rect]
rects

-- | Arrange views horizontally on each screen.  They'll overlap if there isn't
-- room for all of them.
horizontal_tile :: Cmd.M m => m ()
horizontal_tile :: forall (m :: * -> *). M m => m ()
horizontal_tile = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {m :: * -> *}. M m => Rect -> [(ViewId, Rect)] -> m ()
tile_screen) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m [(Rect, [(ViewId, Rect)])]
windows_by_screen
    where
    tile_screen :: Rect -> [(ViewId, Rect)] -> m ()
tile_screen Rect
screen [(ViewId, Rect)]
view_rects =
        forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ forall (m :: * -> *). M m => ViewId -> Rect -> m ()
Ui.set_view_rect [ViewId]
view_ids forall a b. (a -> b) -> a -> b
$
            Rect -> [Rect] -> [Rect]
horizontal_tile_rects Rect
screen [Rect]
rects
        where ([ViewId]
view_ids, [Rect]
rects) = forall a b. [(a, b)] -> ([a], [b])
unzip (forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn (Rect -> Int
Rect.x forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(ViewId, Rect)]
view_rects)

windows_by_screen :: Cmd.M m => m [(Rect.Rect, [(ViewId, Rect.Rect)])]
windows_by_screen :: forall (m :: * -> *). M m => m [(Rect, [(ViewId, Rect)])]
windows_by_screen = do
    [(ViewId, Rect)]
view_rects <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second View -> Rect
Block.view_rect) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
Ui.state_views
    [Rect]
screens <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Cmd.gets State -> [Rect]
Cmd.state_screens
    let ([(Rect, [(ViewId, Rect)])]
screen_views, [(ViewId, Rect)]
orphaned) = forall key val.
(key -> val -> Bool) -> [key] -> [val] -> ([(key, [val])], [val])
group_with
            (\Rect
s -> Rect -> Rect -> Bool
Rect.overlaps Rect
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [Rect]
screens [(ViewId, Rect)]
view_rects
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *). M m => ViewId -> m ()
Ui.destroy_view forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(ViewId, Rect)]
orphaned
    forall (m :: * -> *) a. Monad m => a -> m a
return [(Rect, [(ViewId, Rect)])]
screen_views

horizontal_tile_rects :: Rect.Rect -> [Rect.Rect] -> [Rect.Rect]
horizontal_tile_rects :: Rect -> [Rect] -> [Rect]
horizontal_tile_rects Rect
screen [Rect]
rects = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Rect -> Int -> Rect
place [Rect]
rects [Int]
xs
    where
    place :: Rect -> Int -> Rect
place Rect
rect Int
x = Int -> Int -> Rect -> Rect
Rect.place Int
x (Rect -> Int
Rect.y Rect
screen) Rect
rect
    xs :: [Int]
xs = forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl forall a. Num a => a -> a -> a
(+) (Rect -> Int
Rect.x Rect
screen) (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
subtract Int
overlap forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rect -> Int
Rect.w) [Rect]
rects)
    overlap :: Int
overlap = case [Rect]
rects of
        Rect
_ : Rect
_ : [Rect]
_ -> forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$
            (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
Num.sum (forall a b. (a -> b) -> [a] -> [b]
map Rect -> Int
Rect.w [Rect]
rects) forall a. Num a => a -> a -> a
- Rect -> Int
Rect.w Rect
screen)
                forall a. Integral a => a -> a -> a
`div` (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rect]
rects forall a. Num a => a -> a -> a
- Int
1)
        -- 0 or 1 rects are not going to have any overlap.
        [Rect]
_ -> Int
0

group_with :: (key -> val -> Bool) -> [key] -> [val] -> ([(key, [val])], [val])
group_with :: forall key val.
(key -> val -> Bool) -> [key] -> [val] -> ([(key, [val])], [val])
group_with key -> val -> Bool
cmp [key]
keys [val]
vals = forall a b. (a, b) -> (b, a)
Tuple.swap forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL [val] -> key -> ([val], (key, [val]))
go [val]
vals [key]
keys
    where
    go :: [val] -> key -> ([val], (key, [val]))
go [val]
vals key
key = ([val]
out, (key
key, [val]
inside))
        where ([val]
inside, [val]
out) = forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition (key -> val -> Bool
cmp key
key) [val]
vals

-- ** focus

cycle_focus :: Cmd.M m => Bool -> m ()
cycle_focus :: forall (m :: * -> *). M m => Bool -> m ()
cycle_focus Bool
forward = do
    ViewId
focused <- forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view
    [ViewId]
view_ids <- (if Bool
forward then forall {p}. p -> p
id else forall a. [a] -> [a]
reverse) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). M m => m [ViewId]
Ui.all_view_ids
    case forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/=ViewId
focused) [ViewId]
view_ids of
        ViewId
next : [ViewId]
_ -> forall (m :: * -> *). M m => ViewId -> m ()
Cmd.focus ViewId
next
        [] -> forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust (forall a. [a] -> Maybe a
Lists.head [ViewId]
view_ids) forall (m :: * -> *). M m => ViewId -> m ()
Cmd.focus

-- | Right and Left would clash with Either.
data Direction = North | South | East | West deriving (Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show)

move_focus :: Cmd.M m => Direction -> m ()
move_focus :: forall (m :: * -> *). M m => Direction -> m ()
move_focus Direction
dir = do
    [(ViewId, Rect)]
rects <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets forall a b. (a -> b) -> a -> b
$
        forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second View -> Rect
Block.view_rect) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map ViewId View
Ui.state_views
    Rect
focused <- View -> Rect
Block.view_rect forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). M m => m ViewId
Cmd.get_focused_view)
    let get_rects :: (b -> b -> Bool) -> (Rect -> b) -> [(ViewId, b)]
get_rects b -> b -> Bool
cmp Rect -> b
f = forall k a. Ord k => (a -> k) -> [a] -> [a]
Lists.sortOn forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> b -> Bool
`cmp` Rect -> b
f Rect
focused) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
            forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Rect -> b
f) [(ViewId, Rect)]
rects
    let next :: Maybe (ViewId, Int)
next = case Direction
dir of
            Direction
East -> forall a. [a] -> Maybe a
Lists.head forall a b. (a -> b) -> a -> b
$ forall {b}.
Ord b =>
(b -> b -> Bool) -> (Rect -> b) -> [(ViewId, b)]
get_rects forall a. Ord a => a -> a -> Bool
(>) Rect -> Int
Rect.x
            Direction
West -> forall a. [a] -> Maybe a
Lists.last forall a b. (a -> b) -> a -> b
$ forall {b}.
Ord b =>
(b -> b -> Bool) -> (Rect -> b) -> [(ViewId, b)]
get_rects forall a. Ord a => a -> a -> Bool
(<) Rect -> Int
Rect.x
            Direction
South -> forall a. [a] -> Maybe a
Lists.head forall a b. (a -> b) -> a -> b
$ forall {b}.
Ord b =>
(b -> b -> Bool) -> (Rect -> b) -> [(ViewId, b)]
get_rects forall a. Ord a => a -> a -> Bool
(>) Rect -> Int
Rect.y
            Direction
North -> forall a. [a] -> Maybe a
Lists.last forall a b. (a -> b) -> a -> b
$ forall {b}.
Ord b =>
(b -> b -> Bool) -> (Rect -> b) -> [(ViewId, b)]
get_rects forall a. Ord a => a -> a -> Bool
(<) Rect -> Int
Rect.y
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (ViewId, Int)
next forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). M m => ViewId -> m ()
Cmd.focus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst

-- * create views

-- | For the current window, open enough views at the current zoom to see the
-- score from the current time until the end of the block.
views_covering :: Cmd.M m => ViewId -> m [ViewId]
views_covering :: forall (m :: * -> *). M m => ViewId -> m [ViewId]
views_covering ViewId
view_id = do
    View
view <- forall (m :: * -> *). M m => ViewId -> m View
Ui.get_view ViewId
view_id
    TrackTime
block_dur <- forall (m :: * -> *). M m => BlockId -> m TrackTime
Ui.block_end forall a b. (a -> b) -> a -> b
$ View -> BlockId
Block.view_block View
view
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (TrackTime -> View -> [TrackTime]
views_covering_starts TrackTime
block_dur View
view) forall a b. (a -> b) -> a -> b
$ \TrackTime
start -> do
        ViewId
view_id <- forall (m :: * -> *). M m => BlockId -> m ViewId
Create.view (View -> BlockId
Block.view_block View
view)
        forall (m :: * -> *). M m => ViewId -> (Zoom -> Zoom) -> m ()
Views.modify_zoom ViewId
view_id forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Zoom.Zoom
            { factor :: Double
factor = Zoom -> Double
Zoom.factor (View -> Zoom
Block.view_zoom View
view)
            , offset :: TrackTime
offset = TrackTime
start
            }
        forall (m :: * -> *) a. Monad m => a -> m a
return ViewId
view_id

views_covering_starts :: TrackTime -> Block.View -> [TrackTime]
views_covering_starts :: TrackTime -> View -> [TrackTime]
views_covering_starts TrackTime
block_dur View
view =
    -- drop 1 to exclude the given view.
    forall a. Int -> [a] -> [a]
drop Int
1 forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
needed forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> [a]
Lists.range_ TrackTime
offset (TrackTime
block_dur forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
needed)
    where
    offset :: TrackTime
offset = Zoom -> TrackTime
Zoom.offset (View -> Zoom
Block.view_zoom View
view)
    visible :: TrackTime
visible = View -> TrackTime
Block.visible_time View
view forall a. Num a => a -> a -> a
- TrackTime
offset
    needed :: Int
needed = forall a b. (RealFrac a, Integral b) => a -> b
ceiling (TrackTime
block_dur forall a. Fractional a => a -> a -> a
/ TrackTime
visible)

-- * saved views

-- | Save the current views under the given name.
save_views :: Cmd.M m => Text -> m ()
save_views :: forall (m :: * -> *). M m => Text -> m ()
save_views Text
name = do
    Map ViewId View
views <- forall (m :: * -> *) a. M m => (State -> a) -> m a
Ui.gets State -> Map ViewId View
Ui.state_views
    Maybe ViewId
focused <- forall (m :: * -> *). M m => m (Maybe ViewId)
Cmd.lookup_focused_view
    forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Config :-> SavedViews
UiConfig.saved_views forall f a. Lens f a -> (a -> a) -> f -> f
%= forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name (Map ViewId View
views, Maybe ViewId
focused)

-- | Replace the current views with the saved ones.  The current one is first
-- saved as \"prev\".
restore_views :: Cmd.M m => Text -> m ()
restore_views :: forall (m :: * -> *). M m => Text -> m ()
restore_views Text
name = do
    (Map ViewId View
views, Maybe ViewId
focused) <- forall (m :: * -> *) a. (Stack, M m) => Text -> Maybe a -> m a
Cmd.require (Text
"no saved views named: " forall a. Semigroup a => a -> a -> a
<> Text
name)
        forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Lens State Config
Ui.configforall a b c. Lens a b -> Lens b c -> Lens a c
#Config :-> SavedViews
UiConfig.saved_views forall a b c. Lens a b -> Lens b c -> Lens a c
# forall k a. Ord k => k -> Lens (Map k a) (Maybe a)
Lens.map Text
name forall (f :: * -> *) a b. Functor f => Lens a b -> f a -> f b
<#> forall (m :: * -> *). M m => m State
Ui.get
    forall (m :: * -> *). M m => Text -> m ()
save_views Text
"prev"
    forall (m :: * -> *). M m => Map ViewId View -> m ()
Ui.put_views Map ViewId View
views
    forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe ViewId
focused forall (m :: * -> *). M m => ViewId -> m ()
Cmd.focus

remove_views :: Ui.M m => Text -> m ()
remove_views :: forall (m :: * -> *). M m => Text -> m ()
remove_views Text
name = forall (m :: * -> *). M m => (Config -> Config) -> m ()
Ui.modify_config forall a b. (a -> b) -> a -> b
$ Config :-> SavedViews
UiConfig.saved_views forall f a. Lens f a -> (a -> a) -> f -> f
%= forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
name