-- 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