module HGeometry.Miso.Canvas.Zoom
  ( ZoomDirection(..)
  , HasZoomLevel(..)
  , ZoomAction(..)
  , update
  ) where

import Control.Lens
import Control.Monad.State
import HGeometry.Interval
import Miso (Effect)


--------------------------------------------------------------------------------
-- * Model

data ZoomDirection = ZoomIn | ZoomOut deriving (Int -> ZoomDirection -> ShowS
[ZoomDirection] -> ShowS
ZoomDirection -> String
(Int -> ZoomDirection -> ShowS)
-> (ZoomDirection -> String)
-> ([ZoomDirection] -> ShowS)
-> Show ZoomDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ZoomDirection -> ShowS
showsPrec :: Int -> ZoomDirection -> ShowS
$cshow :: ZoomDirection -> String
show :: ZoomDirection -> String
$cshowList :: [ZoomDirection] -> ShowS
showList :: [ZoomDirection] -> ShowS
Show,ReadPrec [ZoomDirection]
ReadPrec ZoomDirection
Int -> ReadS ZoomDirection
ReadS [ZoomDirection]
(Int -> ReadS ZoomDirection)
-> ReadS [ZoomDirection]
-> ReadPrec ZoomDirection
-> ReadPrec [ZoomDirection]
-> Read ZoomDirection
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ZoomDirection
readsPrec :: Int -> ReadS ZoomDirection
$creadList :: ReadS [ZoomDirection]
readList :: ReadS [ZoomDirection]
$creadPrec :: ReadPrec ZoomDirection
readPrec :: ReadPrec ZoomDirection
$creadListPrec :: ReadPrec [ZoomDirection]
readListPrec :: ReadPrec [ZoomDirection]
Read,ZoomDirection -> ZoomDirection -> Bool
(ZoomDirection -> ZoomDirection -> Bool)
-> (ZoomDirection -> ZoomDirection -> Bool) -> Eq ZoomDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ZoomDirection -> ZoomDirection -> Bool
== :: ZoomDirection -> ZoomDirection -> Bool
$c/= :: ZoomDirection -> ZoomDirection -> Bool
/= :: ZoomDirection -> ZoomDirection -> Bool
Eq)

-- | Types that have a zoom-level
class HasZoomLevel canvas r | canvas -> r where
  -- | Lens to access the current zoom-level of the canvas
  zoomLevel :: Lens' canvas r

--------------------------------------------------------------------------------
-- * Controller

newtype ZoomAction = ZoomAction ZoomDirection deriving (Int -> ZoomAction -> ShowS
[ZoomAction] -> ShowS
ZoomAction -> String
(Int -> ZoomAction -> ShowS)
-> (ZoomAction -> String)
-> ([ZoomAction] -> ShowS)
-> Show ZoomAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ZoomAction -> ShowS
showsPrec :: Int -> ZoomAction -> ShowS
$cshow :: ZoomAction -> String
show :: ZoomAction -> String
$cshowList :: [ZoomAction] -> ShowS
showList :: [ZoomAction] -> ShowS
Show,ZoomAction -> ZoomAction -> Bool
(ZoomAction -> ZoomAction -> Bool)
-> (ZoomAction -> ZoomAction -> Bool) -> Eq ZoomAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ZoomAction -> ZoomAction -> Bool
== :: ZoomAction -> ZoomAction -> Bool
$c/= :: ZoomAction -> ZoomAction -> Bool
/= :: ZoomAction -> ZoomAction -> Bool
Eq)

-- | Update the zoom-level
update      :: ( Fractional r, Ord r
               , HasZoomLevel canvas r
               )
            => ZoomAction -> Effect parent canvas action
update :: forall r canvas parent action.
(Fractional r, Ord r, HasZoomLevel canvas r) =>
ZoomAction -> Effect parent canvas action
update ZoomAction
za = LensLike'
  (Zoomed
     (RWST (ComponentInfo parent) [Schedule action] r Identity) ())
  canvas
  r
-> RWST (ComponentInfo parent) [Schedule action] r Identity ()
-> RWST (ComponentInfo parent) [Schedule action] canvas Identity ()
forall c.
LensLike'
  (Zoomed
     (RWST (ComponentInfo parent) [Schedule action] r Identity) c)
  canvas
  r
-> RWST (ComponentInfo parent) [Schedule action] r Identity c
-> RWST (ComponentInfo parent) [Schedule action] canvas Identity c
forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom (r -> FocusingWith [Schedule action] Identity () r)
-> canvas -> FocusingWith [Schedule action] Identity () canvas
LensLike'
  (Zoomed
     (RWST (ComponentInfo parent) [Schedule action] r Identity) ())
  canvas
  r
forall canvas r. HasZoomLevel canvas r => Lens' canvas r
Lens' canvas r
zoomLevel (RWST (ComponentInfo parent) [Schedule action] r Identity ()
 -> RWST
      (ComponentInfo parent) [Schedule action] canvas Identity ())
-> RWST (ComponentInfo parent) [Schedule action] r Identity ()
-> RWST (ComponentInfo parent) [Schedule action] canvas Identity ()
forall a b. (a -> b) -> a -> b
$ ZoomAction
-> RWST (ComponentInfo parent) [Schedule action] r Identity ()
forall r parent action.
(Fractional r, Ord r) =>
ZoomAction -> Effect parent r action
updateZoom' ZoomAction
za
  -- note: the zoom is the lens version of zoom

updateZoom' :: (Fractional r, Ord r)
            => ZoomAction -> Effect parent r action
updateZoom' :: forall r parent action.
(Fractional r, Ord r) =>
ZoomAction -> Effect parent r action
updateZoom' = \case
    ZoomAction ZoomDirection
dir  -> (r -> r) -> Effect parent r action
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((r -> r) -> Effect parent r action)
-> (r -> r) -> Effect parent r action
forall a b. (a -> b) -> a -> b
$ ZoomDirection -> r -> r
forall r. (Fractional r, Ord r) => ZoomDirection -> r -> r
applyZoom ZoomDirection
dir


applyZoom       :: forall r.(Fractional r, Ord r) => ZoomDirection -> r -> r
applyZoom :: forall r. (Fractional r, Ord r) => ZoomDirection -> r -> r
applyZoom ZoomDirection
dir r
z = let delta :: r
delta = case ZoomDirection
dir of
                                ZoomDirection
ZoomIn  -> r
0.1
                                ZoomDirection
ZoomOut -> (-r
1)r -> r -> r
forall a. Num a => a -> a -> a
*r
0.1
                  in ClosedInterval r -> r -> r
forall interval r.
(ClosedInterval_ interval r, Ord r) =>
interval -> r -> r
clampTo ClosedInterval r
rng (r
z r -> r -> r
forall a. Num a => a -> a -> a
+ r
delta)
  where
    rng :: ClosedInterval r
rng = forall r. r -> r -> ClosedInterval r
ClosedInterval @r r
0.5 r
10