module Data.Component.Selection where

import Control.Lens
import Control.Lens.TH.Rules
import Control.Monad.State
import Data.Aeson hiding ((.=))
import qualified Data.Config.Font as Font
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import Data.Typeable (Typeable)
import qualified Data.Vector as V
import Linear
import MiniLight
import qualified SDL.Font
import qualified SDL.Vect as Vect
import qualified Data.Component.Basic as Basic
import qualified Data.Component.Layer as Layer

data Config = Config {
  Config -> Config
basic :: Basic.Config,
  Config -> Vector Text
labels :: V.Vector T.Text,
  Config -> Config
fontConfig :: Font.Config,
  Config -> FilePath
image :: FilePath
}

instance FromJSON Config where
  parseJSON :: Value -> Parser Config
parseJSON = FilePath -> (Object -> Parser Config) -> Value -> Parser Config
forall a. FilePath -> (Object -> Parser a) -> Value -> Parser a
withObject "selection" ((Object -> Parser Config) -> Value -> Parser Config)
-> (Object -> Parser Config) -> Value -> Parser Config
forall a b. (a -> b) -> a -> b
$ \v :: Object
v ->
    Config -> Vector Text -> Config -> FilePath -> Config
Config
      (Config -> Vector Text -> Config -> FilePath -> Config)
-> Parser Config
-> Parser (Vector Text -> Config -> FilePath -> Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser Config
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
v)
      Parser (Vector Text -> Config -> FilePath -> Config)
-> Parser (Vector Text) -> Parser (Config -> FilePath -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe (Vector Text))
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "labels" Parser (Maybe (Vector Text)) -> Vector Text -> Parser (Vector Text)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Vector Text
forall a. Vector a
V.empty
      Parser (Config -> FilePath -> Config)
-> Parser Config -> Parser (FilePath -> Config)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Value -> Parser Config
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser Config) -> Parser Value -> Parser Config
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object
v Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: "font"))
      Parser (FilePath -> Config) -> Parser FilePath -> Parser Config
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser FilePath
forall a. FromJSON a => Object -> Text -> Parser a
.: "image"

data Selection = Selection {
  Selection -> Layer
layer :: Layer.Layer,
  Selection -> Font
font :: SDL.Font.Font,
  Selection -> Maybe Int
hover :: Maybe Int,
  Selection -> Config
config :: Config,
  Selection -> Vector Text
currentLabels :: V.Vector T.Text
}

makeLensesWith lensRules_ ''Config
makeLensesWith lensRules_ ''Selection

instance Basic.HasConfig Config where
  config :: (Config -> f Config) -> Config -> f Config
config = (Config -> f Config) -> Config -> f Config
Lens' Config Config
_basic

instance ComponentUnit Selection where
  update :: Selection -> LightT env m Selection
update = Selection -> LightT env m Selection
forall (m :: * -> *) a. Monad m => a -> m a
return

  figures :: Selection -> LightT env m [Figure]
figures comp :: Selection
comp = do
    let p :: V2 Int
p = Int -> Int -> V2 Int
forall a. a -> a -> V2 a
Vect.V2 15 10
    Vector Figure
textTextures <- Vector (Int, Text)
-> ((Int, Text) -> LightT env m Figure)
-> LightT env m (Vector Figure)
forall (m :: * -> *) a b.
Monad m =>
Vector a -> (a -> m b) -> m (Vector b)
V.forM (Vector Text -> Vector (Int, Text)
forall a. Vector a -> Vector (Int, a)
V.indexed (Vector Text -> Vector (Int, Text))
-> Vector Text -> Vector (Int, Text)
forall a b. (a -> b) -> a -> b
$ Selection
comp Selection
-> Getting (Vector Text) Selection (Vector Text) -> Vector Text
forall s a. s -> Getting a s a -> a
^. Getting (Vector Text) Selection (Vector Text)
Lens' Selection (Vector Text)
_currentLabels) (((Int, Text) -> LightT env m Figure)
 -> LightT env m (Vector Figure))
-> ((Int, Text) -> LightT env m Figure)
-> LightT env m (Vector Figure)
forall a b. (a -> b) -> a -> b
$ \(i :: Int
i,label :: Text
label) -> MiniLight Figure -> LightT env m Figure
forall env (m :: * -> *) a.
(HasLightEnv env, MonadIO m) =>
MiniLight a -> LightT env m a
liftMiniLight (MiniLight Figure -> LightT env m Figure)
-> MiniLight Figure -> LightT env m Figure
forall a b. (a -> b) -> a -> b
$ (Figure -> Figure) -> MiniLight Figure -> MiniLight Figure
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (V2 Int -> Figure -> Figure
forall r (m :: * -> *). Rendering r m => V2 Int -> r -> r
translate (V2 Int
p V2 Int -> V2 Int -> V2 Int
forall a. Num a => a -> a -> a
+ Int -> Int -> V2 Int
forall a. a -> a -> V2 a
Vect.V2 0 (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* 30))) (MiniLight Figure -> MiniLight Figure)
-> MiniLight Figure -> MiniLight Figure
forall a b. (a -> b) -> a -> b
$ Font -> V4 Word8 -> Text -> MiniLight Figure
forall r (m :: * -> *).
Rendering r m =>
Font -> V4 Word8 -> Text -> m r
text (Selection -> Font
font Selection
comp) (Config -> V4 Word8
Font.color (Config -> V4 Word8) -> Config -> V4 Word8
forall a b. (a -> b) -> a -> b
$ Config -> Config
fontConfig (Config -> Config) -> Config -> Config
forall a b. (a -> b) -> a -> b
$ Selection
comp Selection -> Getting Config Selection Config -> Config
forall s a. s -> Getting a s a -> a
^. Getting Config Selection Config
Lens' Selection Config
_config) Text
label
    [Figure]
base <- Layer -> LightT env m [Figure]
forall c env (m :: * -> *).
(ComponentUnit c, HasLightEnv env, MonadIO m, MonadMask m) =>
c -> LightT env m [Figure]
figures (Selection -> Layer
layer Selection
comp)
    Figure
highlight <- MiniLight Figure -> LightT env m Figure
forall env (m :: * -> *) a.
(HasLightEnv env, MonadIO m) =>
MiniLight a -> LightT env m a
liftMiniLight (MiniLight Figure -> LightT env m Figure)
-> MiniLight Figure -> LightT env m Figure
forall a b. (a -> b) -> a -> b
$ V4 Word8 -> V2 Int -> MiniLight Figure
forall r (m :: * -> *). Rendering r m => V4 Word8 -> V2 Int -> m r
rectangleFilled (Word8 -> Word8 -> Word8 -> Word8 -> V4 Word8
forall a. a -> a -> a -> a -> V4 a
Vect.V4 240 240 240 40) (V2 Int -> MiniLight Figure) -> V2 Int -> MiniLight Figure
forall a b. (a -> b) -> a -> b
$ (Int -> Identity Int) -> V2 Int -> Identity (V2 Int)
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y ((Int -> Identity Int) -> V2 Int -> Identity (V2 Int))
-> Int -> V2 Int -> V2 Int
forall s t a b. ASetter s t a b -> b -> s -> t
.~ 30 (V2 Int -> V2 Int) -> V2 Int -> V2 Int
forall a b. (a -> b) -> a -> b
$ Selection
comp Selection -> Getting (V2 Int) Selection (V2 Int) -> V2 Int
forall s a. s -> Getting a s a -> a
^. (Config -> Const (V2 Int) Config)
-> Selection -> Const (V2 Int) Selection
Lens' Selection Config
_config ((Config -> Const (V2 Int) Config)
 -> Selection -> Const (V2 Int) Selection)
-> ((V2 Int -> Const (V2 Int) (V2 Int))
    -> Config -> Const (V2 Int) Config)
-> Getting (V2 Int) Selection (V2 Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (V2 Int -> Const (V2 Int) (V2 Int))
-> Config -> Const (V2 Int) Config
forall c. HasConfig c => Lens' c (V2 Int)
Basic._size

    [Figure] -> LightT env m [Figure]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Figure] -> LightT env m [Figure])
-> [Figure] -> LightT env m [Figure]
forall a b. (a -> b) -> a -> b
$ Config -> [Figure] -> [Figure]
Basic.wrapFigures (Selection
comp Selection -> Getting Config Selection Config -> Config
forall s a. s -> Getting a s a -> a
^. (Config -> Const Config Config)
-> Selection -> Const Config Selection
Lens' Selection Config
_config ((Config -> Const Config Config)
 -> Selection -> Const Config Selection)
-> ((Config -> Const Config Config)
    -> Config -> Const Config Config)
-> Getting Config Selection Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> Const Config Config) -> Config -> Const Config Config
forall c. HasConfig c => Lens' c Config
Basic.config) ([Figure] -> [Figure]) -> [Figure] -> [Figure]
forall a b. (a -> b) -> a -> b
$ [Figure]
base
      [Figure] -> [Figure] -> [Figure]
forall a. [a] -> [a] -> [a]
++ (V2 Int -> Figure -> Figure
forall r (m :: * -> *). Rendering r m => V2 Int -> r -> r
translate (Int -> Int -> V2 Int
forall a. a -> a -> V2 a
Vect.V2 0 (Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 0 Int -> Int
forall a. a -> a
id (Selection -> Maybe Int
hover Selection
comp) Int -> Int -> Int
forall a. Num a => a -> a -> a
* 30 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ V2 Int
p V2 Int -> Getting Int (V2 Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (V2 Int) Int
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y)) Figure
highlight
      Figure -> [Figure] -> [Figure]
forall a. a -> [a] -> [a]
: Vector Figure -> [Figure]
forall a. Vector a -> [a]
V.toList Vector Figure
textTextures)

  useCache :: Selection -> Selection -> Bool
useCache c1 :: Selection
c1 c2 :: Selection
c2
    = Selection
c1 Selection
-> Getting (Vector Text) Selection (Vector Text) -> Vector Text
forall s a. s -> Getting a s a -> a
^. Getting (Vector Text) Selection (Vector Text)
Lens' Selection (Vector Text)
_currentLabels Vector Text -> Vector Text -> Bool
forall a. Eq a => a -> a -> Bool
== Selection
c2 Selection
-> Getting (Vector Text) Selection (Vector Text) -> Vector Text
forall s a. s -> Getting a s a -> a
^. Getting (Vector Text) Selection (Vector Text)
Lens' Selection (Vector Text)
_currentLabels
    Bool -> Bool -> Bool
&& Selection
c1 Selection -> Getting Bool Selection Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (Config -> Const Bool Config) -> Selection -> Const Bool Selection
Lens' Selection Config
_config ((Config -> Const Bool Config)
 -> Selection -> Const Bool Selection)
-> ((Bool -> Const Bool Bool) -> Config -> Const Bool Config)
-> Getting Bool Selection Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const Bool Bool) -> Config -> Const Bool Config
forall c. HasConfig c => Lens' c Bool
Basic._visible Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Selection
c2 Selection -> Getting Bool Selection Bool -> Bool
forall s a. s -> Getting a s a -> a
^. (Config -> Const Bool Config) -> Selection -> Const Bool Selection
Lens' Selection Config
_config ((Config -> Const Bool Config)
 -> Selection -> Const Bool Selection)
-> ((Bool -> Const Bool Bool) -> Config -> Const Bool Config)
-> Getting Bool Selection Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Const Bool Bool) -> Config -> Const Bool Config
forall c. HasConfig c => Lens' c Bool
Basic._visible Bool -> Bool -> Bool
&& Selection
c1 Selection -> Getting (Maybe Int) Selection (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Int) Selection (Maybe Int)
Lens' Selection (Maybe Int)
_hover Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Selection
c2 Selection -> Getting (Maybe Int) Selection (Maybe Int) -> Maybe Int
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Int) Selection (Maybe Int)
Lens' Selection (Maybe Int)
_hover

  onSignal :: Event -> Selection -> LightT env m Selection
onSignal = Lens' Selection Config
-> (Event -> Selection -> LightT env m Selection)
-> Event
-> Selection
-> LightT env m Selection
forall env (m :: * -> *) c.
(HasLightEnv env, HasLoopEnv env, HasComponentEnv env, MonadIO m,
 ComponentUnit c) =>
Lens' c Config
-> (Event -> c -> LightT env m c) -> Event -> c -> LightT env m c
Basic.wrapSignal ((Config -> f Config) -> Selection -> f Selection
Lens' Selection Config
_config ((Config -> f Config) -> Selection -> f Selection)
-> ((Config -> f Config) -> Config -> f Config)
-> (Config -> f Config)
-> Selection
-> f Selection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Config -> f Config) -> Config -> f Config
forall c. HasConfig c => Lens' c Config
Basic.config) ((Event -> Selection -> LightT env m Selection)
 -> Event -> Selection -> LightT env m Selection)
-> (Event -> Selection -> LightT env m Selection)
-> Event
-> Selection
-> LightT env m Selection
forall a b. (a -> b) -> a -> b
$ \ev :: Event
ev -> StateT Selection (LightT env m) ()
-> Selection -> LightT env m Selection
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT Selection (LightT env m) ()
 -> Selection -> LightT env m Selection)
-> StateT Selection (LightT env m) ()
-> Selection
-> LightT env m Selection
forall a b. (a -> b) -> a -> b
$ do
    Vector Text
labels <- Getting (Vector Text) Selection (Vector Text)
-> StateT Selection (LightT env m) (Vector Text)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Vector Text) Selection (Vector Text)
Lens' Selection (Vector Text)
_currentLabels

    case Event -> Maybe Signal
forall a. EventType a => Event -> Maybe a
asSignal Event
ev of
      Just (Basic.MouseOver pos :: V2 Int
pos) | (V2 Int
pos V2 Int -> Getting Int (V2 Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (V2 Int) Int
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 30 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Vector Text -> Int
forall a. Vector a -> Int
V.length Vector Text
labels Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 -> do
        (Maybe Int -> Identity (Maybe Int))
-> Selection -> Identity Selection
Lens' Selection (Maybe Int)
_hover ((Maybe Int -> Identity (Maybe Int))
 -> Selection -> Identity Selection)
-> Maybe Int -> StateT Selection (LightT env m) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Int -> Maybe Int
forall a. a -> Maybe a
Just ((V2 Int
pos V2 Int -> Getting Int (V2 Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (V2 Int) Int
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 30)
      Just (Basic.MouseReleased pos :: V2 Int
pos) | (V2 Int
pos V2 Int -> Getting Int (V2 Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (V2 Int) Int
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 30 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Vector Text -> Int
forall a. Vector a -> Int
V.length Vector Text
labels Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 -> do
        LightT env m () -> StateT Selection (LightT env m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LightT env m () -> StateT Selection (LightT env m) ())
-> LightT env m () -> StateT Selection (LightT env m) ()
forall a b. (a -> b) -> a -> b
$ SelectionEvent -> LightT env m ()
forall env (m :: * -> *) et.
(HasLoopEnv env, HasComponentEnv env, MonadIO m, EventType et) =>
et -> LightT env m ()
emitGlobally (SelectionEvent -> LightT env m ())
-> SelectionEvent -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ Int -> SelectionEvent
Select ((V2 Int
pos V2 Int -> Getting Int (V2 Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (V2 Int) Int
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 30)
      _ -> () -> StateT Selection (LightT env m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    case Event -> Maybe SelectionEvent
forall a. EventType a => Event -> Maybe a
asSignal Event
ev of
      Just (SetOptions xs :: [Text]
xs) -> (Vector Text -> Identity (Vector Text))
-> Selection -> Identity Selection
Lens' Selection (Vector Text)
_currentLabels ((Vector Text -> Identity (Vector Text))
 -> Selection -> Identity Selection)
-> Vector Text -> StateT Selection (LightT env m) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= [Text] -> Vector Text
forall a. [a] -> Vector a
V.fromList [Text]
xs
      _ -> () -> StateT Selection (LightT env m) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  -- OMG
  beforeClearCache :: Selection -> [Figure] -> LightT env m ()
beforeClearCache _ [] = () -> LightT env m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  beforeClearCache _ figs :: [Figure]
figs = (Figure -> LightT env m ()) -> [Figure] -> LightT env m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Figure -> LightT env m ()
forall (m :: * -> *). MonadIO m => Figure -> m ()
freeFigure ([Figure] -> LightT env m ()) -> [Figure] -> LightT env m ()
forall a b. (a -> b) -> a -> b
$ [Figure] -> [Figure]
forall a. [a] -> [a]
tail [Figure]
figs

data SelectionEvent
  = Select Int
  | SetOptions [T.Text]
  deriving (Typeable)

instance EventType SelectionEvent where
  getEventType :: SelectionEvent -> Text
getEventType (Select _) = "select"
  getEventType (SetOptions _) = "set-options"

  getEventProperties :: SelectionEvent -> Object
getEventProperties (Select n :: Int
n) = [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [("index", Scientific -> Value
Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)]
  getEventProperties (SetOptions ts :: [Text]
ts) = [(Text, Value)] -> Object
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [("options", Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (Text -> Value) -> Vector Text -> Array
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Value
String (Vector Text -> Array) -> Vector Text -> Array
forall a b. (a -> b) -> a -> b
$ [Text] -> Vector Text
forall a. [a] -> Vector a
V.fromList [Text]
ts)]

new :: Config -> MiniLight Selection
new :: Config -> MiniLight Selection
new conf :: Config
conf = do
  Font
font  <- Config -> MiniLight Font
Font.loadFontFrom (Config -> Config
fontConfig Config
conf)
  Layer
layer <- Config -> MiniLight Layer
Layer.newNineTile (Config -> MiniLight Layer) -> Config -> MiniLight Layer
forall a b. (a -> b) -> a -> b
$ Config -> FilePath -> Config
Layer.Config
    (Config
Basic.defConfig { size :: V2 Int
Basic.size = Config -> V2 Int
Basic.size (Config -> V2 Int) -> Config -> V2 Int
forall a b. (a -> b) -> a -> b
$ Config -> Config
basic Config
conf })
    (Config -> FilePath
image Config
conf)
  Selection -> MiniLight Selection
forall (m :: * -> *) a. Monad m => a -> m a
return (Selection -> MiniLight Selection)
-> Selection -> MiniLight Selection
forall a b. (a -> b) -> a -> b
$ $WSelection :: Layer -> Font -> Maybe Int -> Config -> Vector Text -> Selection
Selection
    { font :: Font
font          = Font
font
    , config :: Config
config        = Config
conf
    , hover :: Maybe Int
hover         = Maybe Int
forall a. Maybe a
Nothing
    , layer :: Layer
layer         = Layer
layer
    , currentLabels :: Vector Text
currentLabels = Config
conf Config -> Getting (Vector Text) Config (Vector Text) -> Vector Text
forall s a. s -> Getting a s a -> a
^. Getting (Vector Text) Config (Vector Text)
Lens' Config (Vector Text)
_labels
    }