{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Viewport
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- A Geometric viewport; i.e. some way of "viewing" only one
-- particular rectangular region of a larger 2d space.
--
--------------------------------------------------------------------------------
module HGeometry.Viewport
  ( Viewport(Viewport)
  , viewPort, worldToHost, hostToWorld
  -- * Smart constructors
  , centeredOrigin
  , alignedOrigin
  , graphicsOrigin, normalizedCenteredOrigin
  -- * Low level constructors
  , mkViewport
  , fromSize, flipY
  -- * Functions
  , toWorldIn, toHostFrom
  , wrtCenter
  -- * ZoomConfiging
  , ZoomConfig(ZoomConfig), range, currentLevel
  )
  where

import Control.Lens
import HGeometry.Box
import HGeometry.Interval
import HGeometry.Point
import HGeometry.Properties
import HGeometry.Transformation
import HGeometry.Vector

--------------------------------------------------------------------------------

-- | Represents a viewport ; i.e. a rectangle through which we view
-- the world.
data Viewport r = Viewport { forall r. Viewport r -> Rectangle (Point 2 r)
_viewPort    :: Rectangle (Point 2 r)
                             -- ^ in host world
                           , forall r. Viewport r -> Transformation 2 r
_worldToHost :: Transformation 2 r
                             -- ^ Transformation that turns world
                           -- coordinates into host coordinates.

                           -- _hostToWorld :: Transformation 2 r
                           }
                  deriving stock (Viewport r -> Viewport r -> Bool
(Viewport r -> Viewport r -> Bool)
-> (Viewport r -> Viewport r -> Bool) -> Eq (Viewport r)
forall r. Eq r => Viewport r -> Viewport r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall r. Eq r => Viewport r -> Viewport r -> Bool
== :: Viewport r -> Viewport r -> Bool
$c/= :: forall r. Eq r => Viewport r -> Viewport r -> Bool
/= :: Viewport r -> Viewport r -> Bool
Eq, Int -> Viewport r -> ShowS
[Viewport r] -> ShowS
Viewport r -> String
(Int -> Viewport r -> ShowS)
-> (Viewport r -> String)
-> ([Viewport r] -> ShowS)
-> Show (Viewport r)
forall r. Show r => Int -> Viewport r -> ShowS
forall r. Show r => [Viewport r] -> ShowS
forall r. Show r => Viewport r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall r. Show r => Int -> Viewport r -> ShowS
showsPrec :: Int -> Viewport r -> ShowS
$cshow :: forall r. Show r => Viewport r -> String
show :: Viewport r -> String
$cshowList :: forall r. Show r => [Viewport r] -> ShowS
showList :: [Viewport r] -> ShowS
Show)

-- | Lens to access the viewport rectangle
viewPort :: Lens' (Viewport r) (Rectangle (Point 2 r))
viewPort :: forall r (f :: * -> *).
Functor f =>
(Rectangle (Point 2 r) -> f (Rectangle (Point 2 r)))
-> Viewport r -> f (Viewport r)
viewPort = (Viewport r -> Rectangle (Point 2 r))
-> (Viewport r -> Rectangle (Point 2 r) -> Viewport r)
-> Lens
     (Viewport r)
     (Viewport r)
     (Rectangle (Point 2 r))
     (Rectangle (Point 2 r))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Viewport r -> Rectangle (Point 2 r)
forall r. Viewport r -> Rectangle (Point 2 r)
_viewPort (\(Viewport Rectangle (Point 2 r)
_ Transformation 2 r
t) Rectangle (Point 2 r)
vp -> Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
forall r. Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
Viewport Rectangle (Point 2 r)
vp Transformation 2 r
t)

-- | The transformation
worldToHost :: Lens' (Viewport r) (Transformation 2 r)
worldToHost :: forall r (f :: * -> *).
Functor f =>
(Transformation 2 r -> f (Transformation 2 r))
-> Viewport r -> f (Viewport r)
worldToHost = (Viewport r -> Transformation 2 r)
-> (Viewport r -> Transformation 2 r -> Viewport r)
-> Lens
     (Viewport r) (Viewport r) (Transformation 2 r) (Transformation 2 r)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Viewport r -> Transformation 2 r
forall r. Viewport r -> Transformation 2 r
_worldToHost (\(Viewport Rectangle (Point 2 r)
t Transformation 2 r
_) -> Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
forall r. Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
Viewport Rectangle (Point 2 r)
t)

-- | Host to world transformation, i.e. given a point in the host
-- coordinate system, we can compute the point in world coordinates
-- using this transformation.
hostToWorld :: (Fractional r)
            => Getter (Viewport r) (Transformation 2 r)
hostToWorld :: forall r. Fractional r => Getter (Viewport r) (Transformation 2 r)
hostToWorld = (Transformation 2 r -> f (Transformation 2 r))
-> Viewport r -> f (Viewport r)
forall r (f :: * -> *).
Functor f =>
(Transformation 2 r -> f (Transformation 2 r))
-> Viewport r -> f (Viewport r)
worldToHost((Transformation 2 r -> f (Transformation 2 r))
 -> Viewport r -> f (Viewport r))
-> ((Transformation 2 r -> f (Transformation 2 r))
    -> Transformation 2 r -> f (Transformation 2 r))
-> (Transformation 2 r -> f (Transformation 2 r))
-> Viewport r
-> f (Viewport r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Transformation 2 r -> Transformation 2 r)
-> (Transformation 2 r -> f (Transformation 2 r))
-> Transformation 2 r
-> f (Transformation 2 r)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Transformation 2 r -> Transformation 2 r
forall r (d :: Nat).
(Fractional r, OptMatrix_ (d + 1) r, Invertible (d + 1)) =>
Transformation d r -> Transformation d r
inverseOf

--------------------------------------------------------------------------------
-- * Smart constructors

-- | Create a viewport whose world-space is \([-1,1] \times [-1,1]\) whose origin is in
-- the center of the screen (which is defined by the given input rectangle)
normalizedCenteredOrigin      :: ( Fractional r, Rectangle_ rectangle point
                                 , Point_ point 2 r
                                 )
                              => rectangle -> Viewport r
normalizedCenteredOrigin :: forall r rectangle point.
(Fractional r, Rectangle_ rectangle point, Point_ point 2 r) =>
rectangle -> Viewport r
normalizedCenteredOrigin rectangle
rect = let Vector2 r
w r
h = rectangle -> Vector 2 r
forall box (d :: Nat) point r.
(Box_ box point, Point_ point d r, Num r, Functor (Vector d)) =>
box -> Vector d r
size rectangle
rect
                                    s :: Vector 2 r
s           = r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 (r
wr -> r -> r
forall a. Fractional a => a -> a -> a
/r
2) ((-r
1)r -> r -> r
forall a. Num a => a -> a -> a
*r
hr -> r -> r
forall a. Fractional a => a -> a -> a
/r
2)
                                in rectangle -> Transformation 2 r -> Viewport r
forall rectangle point r.
(Rectangle_ rectangle point, Point_ point 2 r, Fractional r) =>
rectangle -> Transformation 2 r -> Viewport r
mkViewport rectangle
rect (Transformation 2 r -> Viewport r)
-> Transformation 2 r -> Viewport r
forall a b. (a -> b) -> a -> b
$ Vector 2 r -> Transformation 2 r
forall (d :: Nat) r vector.
(Num r, Vector_ vector d r, TransformationConstraints d r) =>
vector -> Transformation d r
scaling Vector 2 r
s

-- | Creates a viewport in which the origin is at the center of the viewport
centeredOrigin       :: ( Fractional r
                        , Rectangle_ rectangle point
                        , Point_ point 2 r
                        ) => rectangle -> Viewport r
centeredOrigin :: forall r rectangle point.
(Fractional r, Rectangle_ rectangle point, Point_ point 2 r) =>
rectangle -> Viewport r
centeredOrigin rectangle
rect' = Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
forall r. Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
Viewport Rectangle (Point 2 r)
rect
                                (Vector (Dimension point) (NumType point) -> Transformation 2 r
forall (d :: Nat) r vector.
(Num r, Vector_ vector d r, TransformationConstraints d r,
 d <= ((d + 1) - 1)) =>
vector -> Transformation d r
translation (Vector (Dimension point) (NumType point) -> Transformation 2 r)
-> Vector (Dimension point) (NumType point) -> Transformation 2 r
forall a b. (a -> b) -> a -> b
$ (rectangle -> point
forall box point (d :: Nat) r.
(Box_ box point, Point_ point d r, Fractional r) =>
box -> point
centerPoint rectangle
rect')point
-> Getting
     (Vector (Dimension point) (NumType point))
     point
     (Vector (Dimension point) (NumType point))
-> Vector (Dimension point) (NumType point)
forall s a. s -> Getting a s a -> a
^.Getting
  (Vector (Dimension point) (NumType point))
  point
  (Vector (Dimension point) (NumType point))
forall (d :: Nat) r s.
(Dimension point ~ d, NumType point ~ r, Dimension point ~ d,
 NumType point ~ s) =>
Lens point point (Vector d r) (Vector d s)
forall point point' (d :: Nat) r s.
(HasVector point point', Dimension point ~ d, NumType point ~ r,
 Dimension point' ~ d, NumType point' ~ s) =>
Lens point point' (Vector d r) (Vector d s)
Lens
  point
  point
  (Vector (Dimension point) (NumType point))
  (Vector (Dimension point) (NumType point))
vector)
  where rect :: Rectangle (Point 2 r)
rect = Point 2 r -> Point 2 r -> Rectangle (Point 2 r)
forall point. point -> point -> Box point
Box (rectangle
rect'rectangle -> Getting (Point 2 r) rectangle (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> rectangle -> Const (Point 2 r) rectangle
forall box point. HasMinPoint box point => Lens' box point
Lens' rectangle point
minPoint((point -> Const (Point 2 r) point)
 -> rectangle -> Const (Point 2 r) rectangle)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) rectangle (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint) (rectangle
rect'rectangle -> Getting (Point 2 r) rectangle (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(point -> Const (Point 2 r) point)
-> rectangle -> Const (Point 2 r) rectangle
forall box point. HasMaxPoint box point => Lens' box point
Lens' rectangle point
maxPoint((point -> Const (Point 2 r) point)
 -> rectangle -> Const (Point 2 r) rectangle)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> point -> Const (Point 2 r) point)
-> Getting (Point 2 r) rectangle (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> point -> Const (Point 2 r) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point 2 r)
asPoint)

-- | Creates a viewport in which the origin at the bottom left of the viewport
alignedOrigin       :: ( Num r
                       ) => Rectangle (Point 2 r) -> Viewport r
alignedOrigin :: forall r. Num r => Rectangle (Point 2 r) -> Viewport r
alignedOrigin Rectangle (Point 2 r)
rect' = Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
forall r. Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
Viewport Rectangle (Point 2 r)
rect' (Vector 2 r -> Transformation 2 r
forall (d :: Nat) r vector.
(Num r, Vector_ vector d r, TransformationConstraints d r,
 d <= ((d + 1) - 1)) =>
vector -> Transformation d r
translation (Vector 2 r -> Transformation 2 r)
-> Vector 2 r -> Transformation 2 r
forall a b. (a -> b) -> a -> b
$ Point 2 r
bottomLeft Point 2 r -> Point 2 r -> Vector 2 r
forall point (d :: Nat) r.
(Affine_ point d r, Num r) =>
point -> point -> Vector d r
.-. Point 2 r
forall point (d :: Nat) r.
(Num r, ConstructablePoint_ point d r) =>
point
origin)
  where
    bottomLeft :: Point 2 r
bottomLeft = Rectangle (Point 2 r)
rect'Rectangle (Point 2 r)
-> Getting (Point 2 r) (Rectangle (Point 2 r)) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Rectangle (Point 2 r)) (Point 2 r)
forall box point. HasMinPoint box point => Lens' box point
Lens' (Rectangle (Point 2 r)) (Point 2 r)
minPoint

-- | Same as 'alignedOrigin', except that we also flip the y-direction.
--
-- From the view of a math coordinate system, this puts the origin in the top-left, and
-- has the y-coordinates going down.
--
-- From the view of a "graphics" coordiante system, this actually puts the origin
-- in the bottom left of the rectangle and the y-axixs up; so it turns the
-- viewport into a "proper" math viewport.
graphicsOrigin      :: Num r => Rectangle (Point 2 r) -> Viewport r
graphicsOrigin :: forall r. Num r => Rectangle (Point 2 r) -> Viewport r
graphicsOrigin Rectangle (Point 2 r)
rect = Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
forall r. Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
Viewport Rectangle (Point 2 r)
rect
                    (Transformation 2 r -> Viewport r)
-> Transformation 2 r -> Viewport r
forall a b. (a -> b) -> a -> b
$     Vector 2 r -> Transformation 2 r
forall (d :: Nat) r vector.
(Num r, Vector_ vector d r, TransformationConstraints d r,
 d <= ((d + 1) - 1)) =>
vector -> Transformation d r
translation ((Rectangle (Point 2 r)
rectRectangle (Point 2 r)
-> Getting (Point 2 r) (Rectangle (Point 2 r)) (Point 2 r)
-> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Rectangle (Point 2 r)) (Point 2 r)
forall box point. HasMinPoint box point => Lens' box point
Lens' (Rectangle (Point 2 r)) (Point 2 r)
minPoint) Point 2 r -> Point 2 r -> Vector 2 r
forall point (d :: Nat) r.
(Affine_ point d r, Num r) =>
point -> point -> Vector d r
.-. Point 2 r
forall point (d :: Nat) r.
(Num r, ConstructablePoint_ point d r) =>
point
origin Vector 2 r -> Vector 2 r -> Vector 2 r
forall r vector (d :: Nat).
(Num r, Additive_ vector d r) =>
vector -> vector -> vector
^+^ r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
0 r
h)
                      Transformation 2 r -> Transformation 2 r -> Transformation 2 r
forall r (d :: Nat).
(Num r, OptMatrix_ (d + 1) r) =>
Transformation d r -> Transformation d r -> Transformation d r
|.| Vector 2 r -> Transformation 2 r
forall (d :: Nat) r vector.
(Num r, Vector_ vector d r, TransformationConstraints d r) =>
vector -> Transformation d r
scaling (r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
1 (-r
1))
  where
    h :: r
h = (Rectangle (Point 2 r) -> Vector 2 r
forall box (d :: Nat) point r.
(Box_ box point, Point_ point d r, Num r, Functor (Vector d)) =>
box -> Vector d r
size Rectangle (Point 2 r)
rect) Vector 2 r -> Getting r (Vector 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.forall (i :: Nat) vector r (d :: Nat).
(i <= (d - 1), KnownNat i, Vector_ vector d r) =>
IndexedLens' Int vector r
component @1 -- height of the rect

--------------------------------------------------------------------------------

-- | Creates a viewport from the given rectangle and the
-- transformation. The transformation is applied with respect to the
-- center of the viewport.
mkViewport     :: ( Rectangle_ rectangle point, Point_ point 2 r, Fractional r
                  ) => rectangle -> Transformation 2 r -> Viewport r
mkViewport :: forall rectangle point r.
(Rectangle_ rectangle point, Point_ point 2 r, Fractional r) =>
rectangle -> Transformation 2 r -> Viewport r
mkViewport rectangle
r Transformation 2 r
t = rectangle -> Viewport r
forall r rectangle point.
(Fractional r, Rectangle_ rectangle point, Point_ point 2 r) =>
rectangle -> Viewport r
centeredOrigin rectangle
r Viewport r -> (Viewport r -> Viewport r) -> Viewport r
forall a b. a -> (a -> b) -> b
& (Transformation 2 r -> Identity (Transformation 2 r))
-> Viewport r -> Identity (Viewport r)
forall r (f :: * -> *).
Functor f =>
(Transformation 2 r -> f (Transformation 2 r))
-> Viewport r -> f (Viewport r)
worldToHost ((Transformation 2 r -> Identity (Transformation 2 r))
 -> Viewport r -> Identity (Viewport r))
-> (Transformation 2 r -> Transformation 2 r)
-> Viewport r
-> Viewport r
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Transformation 2 r -> Transformation 2 r -> Transformation 2 r
forall r (d :: Nat).
(Num r, OptMatrix_ (d + 1) r) =>
Transformation d r -> Transformation d r -> Transformation d r
|.| Transformation 2 r
t)

-- | Given a vector with widht w and height h, crates a viewport with
  -- focussing on [0,w] x [0,h]
fromSize   :: ( Num r, Vector_ vector 2 r
              ) => vector -> Viewport r
fromSize :: forall r vector.
(Num r, Vector_ vector 2 r) =>
vector -> Viewport r
fromSize vector
v = Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
forall r. Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
Viewport (Point 2 r -> Point 2 r -> Rectangle (Point 2 r)
forall point. point -> point -> Box point
Box Point 2 r
forall point (d :: Nat) r.
(Num r, ConstructablePoint_ point d r) =>
point
origin (Vector 2 r -> Point 2 r
forall v. v -> PointF v
Point (Vector 2 r -> Point 2 r) -> Vector 2 r -> Point 2 r
forall a b. (a -> b) -> a -> b
$ vector
vvector -> Getting (Vector 2 r) vector (Vector 2 r) -> Vector 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Vector 2 r) vector (Vector 2 r)
forall vector vector' (d :: Nat) r s.
AsVector_ vector vector' d r s =>
Iso vector vector' (Vector d r) (Vector d s)
Iso vector vector (Vector 2 r) (Vector 2 r)
_Vector)) Transformation 2 r
forall r (d :: Nat).
(Num r, OptMatrix_ (d + 1) r) =>
Transformation d r
identity

-- | Flips the y-coordinate so that the origin is in the bottom left.
--
flipY    :: ( Num r, Vector_ vector 2 r)
         => vector -- ^ the dimensions of the viewport
         -> Viewport r
flipY :: forall r vector.
(Num r, Vector_ vector 2 r) =>
vector -> Viewport r
flipY vector
v = Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
forall r. Rectangle (Point 2 r) -> Transformation 2 r -> Viewport r
Viewport (Point 2 r -> Point 2 r -> Rectangle (Point 2 r)
forall point. point -> point -> Box point
Box Point 2 r
forall point (d :: Nat) r.
(Num r, ConstructablePoint_ point d r) =>
point
origin (Vector 2 r -> Point 2 r
forall v. v -> PointF v
Point (Vector 2 r -> Point 2 r) -> Vector 2 r -> Point 2 r
forall a b. (a -> b) -> a -> b
$ vector
vvector -> Getting (Vector 2 r) vector (Vector 2 r) -> Vector 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Vector 2 r) vector (Vector 2 r)
forall vector vector' (d :: Nat) r s.
AsVector_ vector vector' d r s =>
Iso vector vector' (Vector d r) (Vector d s)
Iso vector vector (Vector 2 r) (Vector 2 r)
_Vector))
                   (r -> Transformation 2 r
forall r. Num r => r -> Transformation 2 r
flipY' (r -> Transformation 2 r) -> r -> Transformation 2 r
forall a b. (a -> b) -> a -> b
$ vector
vvector -> Getting r vector r -> r
forall s a. s -> Getting a s a -> a
^.Getting r vector r
forall vector (d :: Nat) r.
(Vector_ vector d r, 1 <= (d - 1)) =>
IndexedLens' Int vector r
IndexedLens' Int vector r
yComponent)

--------------------------------------------------------------------------------

-- | Convert some geometry in host coordinates to world coordinates in
-- the viewport
toWorldIn    :: ( IsTransformable g
                , NumType g ~ r, Dimension g ~ 2, Fractional r)
             => Viewport r -> g -> g
toWorldIn :: forall g r.
(IsTransformable g, NumType g ~ r, Dimension g ~ 2,
 Fractional r) =>
Viewport r -> g -> g
toWorldIn Viewport r
vp = Transformation (Dimension g) (NumType g) -> g -> g
forall g.
IsTransformable g =>
Transformation (Dimension g) (NumType g) -> g -> g
transformBy (Viewport r
vpViewport r
-> Getting (Transformation 2 r) (Viewport r) (Transformation 2 r)
-> Transformation 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Transformation 2 r) (Viewport r) (Transformation 2 r)
forall r. Fractional r => Getter (Viewport r) (Transformation 2 r)
Getter (Viewport r) (Transformation 2 r)
hostToWorld)

-- | Convert some geometry in world coordinates to host coordinates
-- according to the viewport
toHostFrom  :: (IsTransformable g, NumType g ~ r, Dimension g ~ 2, Num r)
             => Viewport r -> g -> g
toHostFrom :: forall g r.
(IsTransformable g, NumType g ~ r, Dimension g ~ 2, Num r) =>
Viewport r -> g -> g
toHostFrom Viewport r
vp = Transformation (Dimension g) (NumType g) -> g -> g
forall g.
IsTransformable g =>
Transformation (Dimension g) (NumType g) -> g -> g
transformBy (Viewport r
vpViewport r
-> Getting (Transformation 2 r) (Viewport r) (Transformation 2 r)
-> Transformation 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Transformation 2 r) (Viewport r) (Transformation 2 r)
forall r (f :: * -> *).
Functor f =>
(Transformation 2 r -> f (Transformation 2 r))
-> Viewport r -> f (Viewport r)
worldToHost)


--------------------------------------------------------------------------------

-- | Transformation that flips the y-axis and shifts by h, essenitally
-- moving the origin from the top-left facing downards to the
-- bottom-left and upwards.
flipY'   :: ( Num r
            ) => r -> Transformation 2 r
flipY' :: forall r. Num r => r -> Transformation 2 r
flipY' r
h = Vector 2 r -> Transformation 2 r
forall (d :: Nat) r vector.
(Num r, Vector_ vector d r, TransformationConstraints d r,
 d <= ((d + 1) - 1)) =>
vector -> Transformation d r
translation (r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
0 r
h) Transformation 2 r -> Transformation 2 r -> Transformation 2 r
forall r (d :: Nat).
(Num r, OptMatrix_ (d + 1) r) =>
Transformation d r -> Transformation d r -> Transformation d r
|.| Vector 2 r -> Transformation 2 r
forall (d :: Nat) r vector.
(Num r, Vector_ vector d r, TransformationConstraints d r) =>
vector -> Transformation d r
scaling (r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
1 (-r
1))


--------------------------------------------------------------------------------


-- | make the transformation with respect to the center of the viewport
wrtCenter             :: ( Fractional r
                         ) => Viewport r -> Transformation 2 r -> Transformation 2 r
wrtCenter :: forall r.
Fractional r =>
Viewport r -> Transformation 2 r -> Transformation 2 r
wrtCenter Viewport r
vp Transformation 2 r
trans' = let v :: Vector 2 r
v = Rectangle (PointF (Vector 2 r)) -> PointF (Vector 2 r)
forall box point (d :: Nat) r.
(Box_ box point, Point_ point d r, Fractional r) =>
box -> point
centerPoint (Viewport r
vpViewport r
-> Getting
     (Rectangle (PointF (Vector 2 r)))
     (Viewport r)
     (Rectangle (PointF (Vector 2 r)))
-> Rectangle (PointF (Vector 2 r))
forall s a. s -> Getting a s a -> a
^.Getting
  (Rectangle (PointF (Vector 2 r)))
  (Viewport r)
  (Rectangle (PointF (Vector 2 r)))
forall r (f :: * -> *).
Functor f =>
(Rectangle (Point 2 r) -> f (Rectangle (Point 2 r)))
-> Viewport r -> f (Viewport r)
viewPort) PointF (Vector 2 r) -> PointF (Vector 2 r) -> Vector 2 r
forall point (d :: Nat) r.
(Affine_ point d r, Num r) =>
point -> point -> Vector d r
.-. PointF (Vector 2 r)
forall point (d :: Nat) r.
(Num r, ConstructablePoint_ point d r) =>
point
origin
                      in Vector 2 r -> Transformation 2 r
forall (d :: Nat) r vector.
(Num r, Vector_ vector d r, TransformationConstraints d r,
 d <= ((d + 1) - 1)) =>
vector -> Transformation d r
translation Vector 2 r
v Transformation 2 r -> Transformation 2 r -> Transformation 2 r
forall r (d :: Nat).
(Num r, OptMatrix_ (d + 1) r) =>
Transformation d r -> Transformation d r -> Transformation d r
|.| Transformation 2 r
trans' Transformation 2 r -> Transformation 2 r -> Transformation 2 r
forall r (d :: Nat).
(Num r, OptMatrix_ (d + 1) r) =>
Transformation d r -> Transformation d r -> Transformation d r
|.| Vector 2 r -> Transformation 2 r
forall (d :: Nat) r vector.
(Num r, Vector_ vector d r, TransformationConstraints d r,
 d <= ((d + 1) - 1)) =>
vector -> Transformation d r
translation ((-r
1) r -> Vector 2 r -> Vector 2 r
forall r vector (d :: Nat).
(Num r, Vector_ vector d r) =>
r -> vector -> vector
*^ Vector 2 r
v)

--------------------------------------------------------------------------------

-- | Data type representing possibilities for zooming in and out in a
-- viewport.
data ZoomConfig r = ZoomConfig { forall r. ZoomConfig r -> ClosedInterval r
_range        :: ClosedInterval r
                               , forall r. ZoomConfig r -> r
_currentLevel :: r
                               }

deriving stock instance (Eq (ClosedInterval r), Eq r) => Eq (ZoomConfig r)
deriving stock instance (Show (ClosedInterval r), Show r) => Show (ZoomConfig r)

instance Functor ZoomConfig where
  fmap :: forall a b. (a -> b) -> ZoomConfig a -> ZoomConfig b
fmap a -> b
f (ZoomConfig ClosedInterval a
r a
l) = ClosedInterval b -> b -> ZoomConfig b
forall r. ClosedInterval r -> r -> ZoomConfig r
ZoomConfig ((a -> b) -> ClosedInterval a -> ClosedInterval b
forall a b.
(a -> b)
-> Interval (EndPoint 'Closed) a -> Interval (EndPoint 'Closed) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ClosedInterval a
r) (a -> b
f a
l)
instance Foldable ZoomConfig where
  foldMap :: forall m a. Monoid m => (a -> m) -> ZoomConfig a -> m
foldMap a -> m
f (ZoomConfig ClosedInterval a
r a
l) = (a -> m) -> ClosedInterval a -> m
forall m a.
Monoid m =>
(a -> m) -> Interval (EndPoint 'Closed) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f ClosedInterval a
r m -> m -> m
forall a. Semigroup a => a -> a -> a
<> a -> m
f a
l
instance Traversable ZoomConfig where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ZoomConfig a -> f (ZoomConfig b)
traverse a -> f b
f (ZoomConfig ClosedInterval a
r a
l) = ClosedInterval b -> b -> ZoomConfig b
forall r. ClosedInterval r -> r -> ZoomConfig r
ZoomConfig (ClosedInterval b -> b -> ZoomConfig b)
-> f (ClosedInterval b) -> f (b -> ZoomConfig b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> ClosedInterval a -> f (ClosedInterval b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> Interval (EndPoint 'Closed) a
-> f (Interval (EndPoint 'Closed) b)
traverse a -> f b
f ClosedInterval a
r f (b -> ZoomConfig b) -> f b -> f (ZoomConfig b)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> f b
f a
l



-- | Lens to access the zoom-range
range :: Lens' (ZoomConfig r) (ClosedInterval r)
range :: forall r (f :: * -> *).
Functor f =>
(ClosedInterval r -> f (ClosedInterval r))
-> ZoomConfig r -> f (ZoomConfig r)
range = (ZoomConfig r -> ClosedInterval r)
-> (ZoomConfig r -> ClosedInterval r -> ZoomConfig r)
-> Lens
     (ZoomConfig r) (ZoomConfig r) (ClosedInterval r) (ClosedInterval r)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ZoomConfig r -> ClosedInterval r
forall r. ZoomConfig r -> ClosedInterval r
_range (\(ZoomConfig ClosedInterval r
_ r
l) ClosedInterval r
r' -> ClosedInterval r -> r -> ZoomConfig r
forall r. ClosedInterval r -> r -> ZoomConfig r
ZoomConfig ClosedInterval r
r' r
l)

-- | Clamps the value to the right range on set
currentLevel :: Ord r => Lens' (ZoomConfig r) r
currentLevel :: forall r. Ord r => Lens' (ZoomConfig r) r
currentLevel = (ZoomConfig r -> r)
-> (ZoomConfig r -> r -> ZoomConfig r)
-> Lens (ZoomConfig r) (ZoomConfig r) r r
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ZoomConfig r -> r
forall r. ZoomConfig r -> r
_currentLevel (\(ZoomConfig ClosedInterval r
r r
_) r
l' -> ClosedInterval r -> r -> ZoomConfig r
forall r. ClosedInterval r -> r -> ZoomConfig r
ZoomConfig ClosedInterval r
r (ClosedInterval r -> r -> r
forall interval r.
(ClosedInterval_ interval r, Ord r) =>
interval -> r -> r
clampTo ClosedInterval r
r r
l'))

-- instance Fractional r => Default (ZoomConfig r) where
--   def = ZoomConfig (ClosedRange 0.1 4) 1