{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo     #-}

module Potato.Flow.Vty.Canvas (
  CanvasWidgetConfig(..)
  , CanvasWidget(..)
  , holdCanvasWidget
) where


import           Relude

import           Potato.Flow
import           Potato.Flow.Vty.Input
import           Potato.Reflex.Vty.Helpers
import Potato.Flow.Vty.PotatoReader

import qualified Data.Text as T
import qualified Data.List.Index as L
import Data.Tuple.Extra (thd3)

import qualified Graphics.Vty                   as V
import           Reflex
import           Reflex.Vty


-- TODO why does this not handle wide chars correctly?
-- alternative text rendering methods that don't show spaces
textNoRenderSpaces
  :: (HasDisplayRegion t m, HasImageWriter t m, HasTheme t m)
  => Behavior t Text
  -> m ()
textNoRenderSpaces :: forall t (m :: * -> *).
(HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) =>
Behavior t Text -> m ()
textNoRenderSpaces Behavior t Text
t = do
  Behavior t Attr
bt <- forall {k} (t :: k) (m :: * -> *).
HasTheme t m =>
m (Behavior t Attr)
theme
  let img :: Behavior t [[Image]]
img = (\Attr
a Text
s -> [Attr -> Text -> [Image]
makeimages Attr
a Text
s])
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Behavior t Attr
bt
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Behavior t Text
t
  forall {k} (t :: k) (m :: * -> *).
HasImageWriter t m =>
Behavior t [Image] -> m ()
tellImages (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Behavior t [[Image]]
img)
  where
    -- revout is of type [(Text, Int)] where the int is offset from BoL
    foldlinefn :: (a, b, [([Char], a)]) -> Char -> (a, b, [([Char], a)])
foldlinefn (a
offset, b
spaces, [([Char], a)]
revout) Char
c = (a
offsetforall a. Num a => a -> a -> a
+ (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int8
getPCharWidth Char
c)), b
newspaces, [([Char], a)]
newrevout) where
      (b
newspaces, [([Char], a)]
newrevout) = if Char
c forall a. Eq a => a -> a -> Bool
== Char
' '
        then (b
spacesforall a. Num a => a -> a -> a
+b
1, [([Char], a)]
revout)
        else if b
spaces forall a. Eq a => a -> a -> Bool
/= b
0
          then (b
0, ([Char
c], a
offset)forall a. a -> [a] -> [a]
:[([Char], a)]
revout)
          else case [([Char], a)]
revout of
            ([Char]
x,a
n):[([Char], a)]
xs -> (b
0, (Char
cforall a. a -> [a] -> [a]
:[Char]
x,a
n)forall a. a -> [a] -> [a]
:[([Char], a)]
xs)
            -- first character case
            [] -> (b
0, [([Char
c], a
0)])
    makeimages :: Attr -> Text -> [Image]
makeimages Attr
th =
      forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Int -> a -> b) -> [a] -> [b]
L.imap (\Int
i -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Image -> Image
V.translateY Int
i)) -- for each line, offset the image vertically
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\([Char]
txt,Int
offset) -> Int -> Image -> Image
V.translateX Int
offset forall a b. (a -> b) -> a -> b
$  Attr -> [Char] -> Image
V.string Attr
th (forall a. [a] -> [a]
reverse [Char]
txt))) -- for each chunk and offset, convert to image
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a, b, c) -> c
thd3 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 {b} {a}.
(Eq b, Num b, Num a) =>
(a, b, [([Char], a)]) -> Char -> (a, b, [([Char], a)])
foldlinefn (Int
0,Integer
0,[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) -- for each line, split into chunks with offset
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
==Char
'\n') -- split into lines

lBox_to_region :: LBox -> Region
lBox_to_region :: LBox -> Region
lBox_to_region (LBox (V2 Int
x Int
y) (V2 Int
w Int
h)) = Int -> Int -> Int -> Int -> Region
Region Int
x Int
y Int
w Int
h

region_to_lBox :: Region -> LBox
region_to_lBox :: Region -> LBox
region_to_lBox (Region Int
x Int
y Int
w Int
h) = (V2 Int -> V2 Int -> LBox
LBox (forall a. a -> a -> V2 a
V2 Int
x Int
y) (forall a. a -> a -> V2 a
V2 Int
w Int
h))

dynLBox_to_dynRegion :: (Reflex t) => Dynamic t LBox -> Dynamic t Region
dynLBox_to_dynRegion :: forall t. Reflex t => Dynamic t LBox -> Dynamic t Region
dynLBox_to_dynRegion Dynamic t LBox
dlb = forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
ffor Dynamic t LBox
dlb forall a b. (a -> b) -> a -> b
$ LBox -> Region
lBox_to_region

{- DELETE ME
translate_dynRegion :: (Reflex t) => Dynamic t XY -> Dynamic t Region -> Dynamic t Region
translate_dynRegion dpos dr = ffor2 dpos dr $ \(V2 x y) region -> region {
    _region_left = _region_left region + x
    , _region_top = _region_top region + y
  }
-}

data CanvasWidgetConfig t = CanvasWidgetConfig {
  forall t. CanvasWidgetConfig t -> Dynamic t (V2 Int)
_canvasWidgetConfig_pan            :: Dynamic t XY
  -- TODO DELETE
  , forall t. CanvasWidgetConfig t -> Dynamic t BroadPhaseState
_canvasWidgetConfig_broadPhase     :: Dynamic t BroadPhaseState
  , forall t. CanvasWidgetConfig t -> Dynamic t RenderedCanvasRegion
_canvasWidgetConfig_renderedCanvas :: Dynamic t RenderedCanvasRegion
  , forall t. CanvasWidgetConfig t -> Dynamic t RenderedCanvasRegion
_canvasWidgetConfig_renderedSelection :: Dynamic t RenderedCanvasRegion
  , forall t. CanvasWidgetConfig t -> Dynamic t SCanvas
_canvasWidgetConfig_canvas         :: Dynamic t SCanvas
  , forall t. CanvasWidgetConfig t -> Dynamic t HandlerRenderOutput
_canvasWidgetConfig_handles        :: Dynamic t HandlerRenderOutput
}


data CanvasWidget t = CanvasWidget {
  forall t. CanvasWidget t -> Event t LMouseData
_canvasWidget_mouse :: Event t LMouseData
  , forall t. CanvasWidget t -> Event t (V2 Int)
_canvasWidget_regionDim :: Event t XY
}

holdCanvasWidget :: forall t m. (MonadWidget t m, HasPotato t m)
  => CanvasWidgetConfig t
  -> m (CanvasWidget t)
holdCanvasWidget :: forall t (m :: * -> *).
(MonadWidget t m, HasPotato t m) =>
CanvasWidgetConfig t -> m (CanvasWidget t)
holdCanvasWidget CanvasWidgetConfig {Dynamic t (V2 Int)
Dynamic t HandlerRenderOutput
Dynamic t RenderedCanvasRegion
Dynamic t BroadPhaseState
Dynamic t SCanvas
_canvasWidgetConfig_handles :: Dynamic t HandlerRenderOutput
_canvasWidgetConfig_canvas :: Dynamic t SCanvas
_canvasWidgetConfig_renderedSelection :: Dynamic t RenderedCanvasRegion
_canvasWidgetConfig_renderedCanvas :: Dynamic t RenderedCanvasRegion
_canvasWidgetConfig_broadPhase :: Dynamic t BroadPhaseState
_canvasWidgetConfig_pan :: Dynamic t (V2 Int)
_canvasWidgetConfig_handles :: forall t. CanvasWidgetConfig t -> Dynamic t HandlerRenderOutput
_canvasWidgetConfig_canvas :: forall t. CanvasWidgetConfig t -> Dynamic t SCanvas
_canvasWidgetConfig_renderedSelection :: forall t. CanvasWidgetConfig t -> Dynamic t RenderedCanvasRegion
_canvasWidgetConfig_renderedCanvas :: forall t. CanvasWidgetConfig t -> Dynamic t RenderedCanvasRegion
_canvasWidgetConfig_broadPhase :: forall t. CanvasWidgetConfig t -> Dynamic t BroadPhaseState
_canvasWidgetConfig_pan :: forall t. CanvasWidgetConfig t -> Dynamic t (V2 Int)
..} = mdo

  Behavior t PotatoStyle
potatostylebeh <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t. PotatoConfig t -> Behavior t PotatoStyle
_potatoConfig_style forall t (m :: * -> *). HasPotato t m => m (PotatoConfig t)
askPotato

  Dynamic t Int
dh <- forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayHeight
  Dynamic t Int
dw <- forall {k} (t :: k) (m :: * -> *).
HasDisplayRegion t m =>
m (Dynamic t Int)
displayWidth

  -- ::draw the canvas::
  let
    -- the screen region
    screenRegion' :: Dynamic t LBox
screenRegion' = forall (f :: * -> *) a b c.
Applicative f =>
f a -> f b -> (a -> b -> c) -> f c
ffor2 Dynamic t Int
dw Dynamic t Int
dh (\Int
w Int
h -> V2 Int -> V2 Int -> LBox
LBox V2 Int
0 (forall a. a -> a -> V2 a
V2 Int
w Int
h))
    screenRegion :: Dynamic t Region
screenRegion = forall t. Reflex t => Dynamic t LBox -> Dynamic t Region
dynLBox_to_dynRegion Dynamic t LBox
screenRegion'
    -- the screen region in canvas space
    canvasScreenRegion' :: Dynamic t LBox
canvasScreenRegion' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RenderedCanvasRegion -> LBox
_renderedCanvasRegion_box Dynamic t RenderedCanvasRegion
_canvasWidgetConfig_renderedCanvas

    -- true region is the canvas region cropped to the panned screen (i.e. the intersection of screen and canvas in canvas space)
    maybeCropAndPan :: V2 Int -> SCanvas -> LBox -> LBox
maybeCropAndPan V2 Int
pan SCanvas
scanvas LBox
screen = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (V2 Int -> V2 Int -> LBox
LBox V2 Int
0 V2 Int
0) (V2 Int -> LBox -> LBox
translate_lBox V2 Int
pan) forall a b. (a -> b) -> a -> b
$ LBox -> LBox -> Maybe LBox
intersect_lBox LBox
screen (SCanvas -> LBox
_sCanvas_box SCanvas
scanvas)
    trueRegion' :: Dynamic t LBox
trueRegion' = forall (f :: * -> *) a b c d.
Applicative f =>
f a -> f b -> f c -> (a -> b -> c -> d) -> f d
ffor3 Dynamic t (V2 Int)
_canvasWidgetConfig_pan Dynamic t SCanvas
_canvasWidgetConfig_canvas Dynamic t LBox
canvasScreenRegion' V2 Int -> SCanvas -> LBox -> LBox
maybeCropAndPan
    trueRegion :: Dynamic t Region
trueRegion = forall t. Reflex t => Dynamic t LBox -> Dynamic t Region
dynLBox_to_dynRegion Dynamic t LBox
trueRegion'
    oobRegions' :: Dynamic t [LBox]
oobRegions' = forall (f :: * -> *) a b c.
Applicative f =>
f a -> f b -> (a -> b -> c) -> f c
ffor2 Dynamic t LBox
screenRegion' Dynamic t LBox
trueRegion' forall a b. (a -> b) -> a -> b
$ \LBox
sc LBox
tr -> LBox -> LBox -> [LBox]
substract_lBox LBox
sc LBox
tr
    oobRegions :: Dynamic t [Region]
oobRegions = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LBox -> Region
lBox_to_region) Dynamic t [LBox]
oobRegions'

    -- reg is in screen space so we need to translate back to canvas space by undoing the pan
    renderRegionFn :: V2 Int -> Region -> RenderedCanvasRegion -> Text
renderRegionFn V2 Int
pan Region
reg RenderedCanvasRegion
rc = LBox -> RenderedCanvasRegion -> Text
renderedCanvasRegionToText (V2 Int -> LBox -> LBox
translate_lBox (-V2 Int
pan) (Region -> LBox
region_to_lBox Region
reg)) RenderedCanvasRegion
rc

    -- same as renderRegionFn
    debugRenderRegionFn :: V2 Int -> Region -> RenderedCanvasRegion -> Text
debugRenderRegionFn V2 Int
pan Region
reg RenderedCanvasRegion
rc = Text
r where
      txt :: Text
txt = LBox -> RenderedCanvasRegion -> Text
renderedCanvasRegionToText (V2 Int -> LBox -> LBox
translate_lBox (-V2 Int
pan) (Region -> LBox
region_to_lBox Region
reg)) RenderedCanvasRegion
rc
      --r = trace (T.unpack txt) txt
      r :: Text
r = Text
txt

    renderRegion :: Dynamic t Region -> m ()
renderRegion Dynamic t Region
dreg = forall {k} (m :: * -> *) (t :: k) a.
(MonadFix m, MonadHold t m, HasInput t m, HasImageWriter t m,
 HasDisplayRegion t m, HasFocusReader t m) =>
Dynamic t Region -> Dynamic t Bool -> m a -> m a
pane Dynamic t Region
dreg (forall {k} (t :: k) a. Reflex t => a -> Dynamic t a
constDyn Bool
False) forall a b. (a -> b) -> a -> b
$ do
      forall {k} (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasDisplayRegion t m, HasImageWriter t m,
 HasTheme t m) =>
Behavior t Text -> m ()
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b c d.
Applicative f =>
f a -> f b -> f c -> (a -> b -> c -> d) -> f d
ffor3 Dynamic t (V2 Int)
_canvasWidgetConfig_pan Dynamic t Region
dreg Dynamic t RenderedCanvasRegion
_canvasWidgetConfig_renderedCanvas forall a b. (a -> b) -> a -> b
$ V2 Int -> Region -> RenderedCanvasRegion -> Text
renderRegionFn


  -- 1. render out of bounds region
  forall {k} (t :: k) (m :: * -> *) a.
HasTheme t m =>
(Behavior t Attr -> Behavior t Attr) -> m a -> m a
localTheme (forall a b. a -> b -> a
const (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PotatoStyle -> Attr
_potatoStyle_canvas_oob Behavior t PotatoStyle
potatostylebeh)) forall a b. (a -> b) -> a -> b
$ do
    forall {k} (t :: k) (m :: * -> *).
(HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) =>
Behavior t Char -> m ()
fill (forall {k} (t :: k) a. Reflex t => a -> Behavior t a
constant Char
' ')
    forall t (m :: * -> *) v a.
(Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m, Eq v) =>
Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
simpleList Dynamic t [Region]
oobRegions Dynamic t Region -> m ()
renderRegion
    return ()

  -- 2. render the canvas region
  Dynamic t Region -> m ()
renderRegion Dynamic t Region
trueRegion

  -- 3. render the selection
  forall {k} (t :: k) (m :: * -> *) a.
HasTheme t m =>
(Behavior t Attr -> Behavior t Attr) -> m a -> m a
localTheme (forall a b. a -> b -> a
const (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PotatoStyle -> Attr
_potatoStyle_selected Behavior t PotatoStyle
potatostylebeh)) forall a b. (a -> b) -> a -> b
$ do
    -- this version does not handle wide chars correctly
    forall t (m :: * -> *).
(HasDisplayRegion t m, HasImageWriter t m, HasTheme t m) =>
Behavior t Text -> m ()
textNoRenderSpaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b c d.
Applicative f =>
f a -> f b -> f c -> (a -> b -> c -> d) -> f d
ffor3 Dynamic t (V2 Int)
_canvasWidgetConfig_pan Dynamic t Region
screenRegion Dynamic t RenderedCanvasRegion
_canvasWidgetConfig_renderedSelection forall a b. (a -> b) -> a -> b
$ V2 Int -> Region -> RenderedCanvasRegion -> Text
debugRenderRegionFn
    return ()

  -- 4. render the handlers
  let
    makerhimage :: Attr -> V2 Int -> RenderHandle -> Image
makerhimage Attr
attr' (V2 Int
px Int
py) RenderHandle
rh = Image
r where
      LBox (V2 Int
x Int
y) (V2 Int
w Int
h) = RenderHandle -> LBox
_renderHandle_box RenderHandle
rh
      rc :: Char
rc = forall a. a -> Maybe a -> a
fromMaybe Char
' ' forall a b. (a -> b) -> a -> b
$ RenderHandle -> Maybe Char
_renderHandle_char RenderHandle
rh
      attr :: Attr
attr = Attr
attr' -- TODO eventually RenderHandle may be styled somehow
      r :: Image
r = Int -> Int -> Image -> Image
V.translate (Int
xforall a. Num a => a -> a -> a
+Int
px) (Int
yforall a. Num a => a -> a -> a
+Int
py) forall a b. (a -> b) -> a -> b
$ forall d. Integral d => Attr -> Char -> d -> d -> Image
V.charFill Attr
attr Char
rc Int
w Int
h
  forall {k} (t :: k) (m :: * -> *).
HasImageWriter t m =>
Behavior t [Image] -> m ()
tellImages forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b c d.
Applicative f =>
f a -> f b -> f c -> (a -> b -> c -> d) -> f d
ffor3 (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t HandlerRenderOutput
_canvasWidgetConfig_handles) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PotatoStyle -> RenderHandleColor -> Attr
_potatoStyle_makeCanvasManipulator Behavior t PotatoStyle
potatostylebeh) (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t (V2 Int)
_canvasWidgetConfig_pan)
    forall a b. (a -> b) -> a -> b
$ \(HandlerRenderOutput [RenderHandle]
hs) RenderHandleColor -> Attr
attrfn V2 Int
reg -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\RenderHandle
rh -> Attr -> V2 Int -> RenderHandle -> Image
makerhimage (RenderHandleColor -> Attr
attrfn (RenderHandle -> RenderHandleColor
_renderHandle_color RenderHandle
rh)) V2 Int
reg RenderHandle
rh) [RenderHandle]
hs

  Event t LMouseData
inp <- forall t (m :: * -> *).
(Reflex t, MonadFix m, MonadHold t m, HasInput t m) =>
Dynamic t (Int, Int) -> Bool -> m (Event t LMouseData)
makeLMouseDataInputEv (forall {k} (t :: k) a. Reflex t => a -> Dynamic t a
constDyn (Int
0,Int
0)) Bool
False
  Event t ()
postBuildEv <- forall t (m :: * -> *). PostBuild t m => m (Event t ())
getPostBuild

  let
    regionDimDyn :: Dynamic t (V2 Int)
regionDimDyn = forall (f :: * -> *) a b c.
Applicative f =>
f a -> f b -> (a -> b -> c) -> f c
ffor2 Dynamic t Int
dw Dynamic t Int
dh forall a. a -> a -> V2 a
V2
    regionDimEv :: Event t (V2 Int)
regionDimEv = forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t (V2 Int)
regionDimDyn
    forceDimEv :: Event t (V2 Int)
forceDimEv = forall {k} (t :: k) a b.
Reflex t =>
(a -> PushM t b) -> Event t a -> Event t b
pushAlways (\()
_ -> forall {k} (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current forall a b. (a -> b) -> a -> b
$ Dynamic t (V2 Int)
regionDimDyn) Event t ()
postBuildEv


  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t. Event t LMouseData -> Event t (V2 Int) -> CanvasWidget t
CanvasWidget Event t LMouseData
inp (forall {k} (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost [Event t (V2 Int)
regionDimEv, Event t (V2 Int)
forceDimEv])