{-# 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
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
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)
[] -> (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))
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)))
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)
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')
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
data CanvasWidgetConfig t = CanvasWidgetConfig {
forall t. CanvasWidgetConfig t -> Dynamic t (V2 Int)
_canvasWidgetConfig_pan :: Dynamic t XY
, 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
let
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'
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
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'
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
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 :: 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
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 ()
Dynamic t Region -> m ()
renderRegion Dynamic t Region
trueRegion
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
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 ()
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'
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])