{-# LANGUAGE RecordWildCards #-} module Monomer.Dragboard.UI ( buildUI ) where import Control.Lens import Data.Maybe import Data.Text (Text) import Data.Typeable import Monomer.Checkerboard import Monomer.Core.Combinators import Monomer.Graphics.ColorTable import Monomer.Graphics.Types import Monomer.Widgets.Animation import Monomer.Widgets.Containers.Box import Monomer.Widgets.Containers.Draggable import Monomer.Widgets.Containers.DropTarget import Monomer.Widgets.Singles.Image import Monomer.Widgets.Singles.Spacer import Monomer.Widgets.Composite import TextShow import qualified Data.Map as Map import Monomer.Dragboard.DragboardCfg import Monomer.Dragboard.DragboardEvent import Monomer.Dragboard.DragboardModel buildUI :: (Typeable a) => DragboardCfg s e a -> Int -> Int -> (a -> Either Text Color) -> UIBuilder (DragboardModel a) (DragboardEvent a) buildUI :: forall a s e. Typeable a => DragboardCfg s e a -> Int -> Int -> (a -> Either Text Color) -> UIBuilder (DragboardModel a) (DragboardEvent a) buildUI DragboardCfg{[CheckerboardCfg] [Info a -> WidgetRequest s e] [Path -> WidgetRequest s e] Maybe Bool Maybe Int Maybe Color Maybe Millisecond Maybe (Info a -> Bool) _dcOnChangeReq :: forall s e a. DragboardCfg s e a -> [Info a -> WidgetRequest s e] _dcOnBlurReq :: forall s e a. DragboardCfg s e a -> [Path -> WidgetRequest s e] _dcOnFocusReq :: forall s e a. DragboardCfg s e a -> [Path -> WidgetRequest s e] _dcCheckerCfg :: forall s e a. DragboardCfg s e a -> [CheckerboardCfg] _dcDuration :: forall s e a. DragboardCfg s e a -> Maybe Millisecond _dcRenderS :: forall s e a. DragboardCfg s e a -> Maybe Bool _dcNoClick :: forall s e a. DragboardCfg s e a -> Maybe Bool _dcSelectColor :: forall s e a. DragboardCfg s e a -> Maybe Color _dcOffset :: forall s e a. DragboardCfg s e a -> Maybe Int _dcValidator :: forall s e a. DragboardCfg s e a -> Maybe (Info a -> Bool) _dcOnChangeReq :: [Info a -> WidgetRequest s e] _dcOnBlurReq :: [Path -> WidgetRequest s e] _dcOnFocusReq :: [Path -> WidgetRequest s e] _dcCheckerCfg :: [CheckerboardCfg] _dcDuration :: Maybe Millisecond _dcRenderS :: Maybe Bool _dcNoClick :: Maybe Bool _dcSelectColor :: Maybe Color _dcOffset :: Maybe Int _dcValidator :: Maybe (Info a -> Bool) ..} Int c Int r a -> Either Text Color getPathOrColor WidgetEnv (DragboardModel a) (DragboardEvent a) _ DragboardModel a model = WidgetNode (DragboardModel a) (DragboardEvent a) node where node :: WidgetNode (DragboardModel a) (DragboardEvent a) node = forall s e. (WidgetModel s, WidgetEvent e) => [BoxCfg s e] -> WidgetNode s e -> WidgetNode s e box_ [ forall t e a. CmbOnFocus t e a => (a -> e) -> t onFocus forall a. Path -> DragboardEvent a EventFocus , forall t e a. CmbOnBlur t e a => (a -> e) -> t onBlur forall a. Path -> DragboardEvent a EventBlur ] forall a b. (a -> b) -> a -> b $ forall s e (t :: * -> *). (WidgetModel s, WidgetEvent e, Traversable t) => Int -> Int -> [CheckerboardCfg] -> t (WidgetNode s e) -> WidgetNode s e checkerboard_ Int c Int r [CheckerboardCfg] cc forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith forall {s}. Typeable s => Int -> [a] -> WidgetNode s (DragboardEvent a) f [Int offset..] [[a]] boardState' cc :: [CheckerboardCfg] cc = [CheckerboardCfg] _dcCheckerCfg offset :: Int offset = forall a. a -> Maybe a -> a fromMaybe Int 0 Maybe Int _dcOffset f :: Int -> [a] -> WidgetNode s (DragboardEvent a) f Int i [a] xs = forall {s} {a}. (Typeable s, Typeable a) => Int -> WidgetNode s (DragboardEvent a) -> WidgetNode s (DragboardEvent a) clickBox Int i forall a b. (a -> b) -> a -> b $ forall {a} {s}. Typeable a => Int -> WidgetNode s (DragboardEvent a) -> WidgetNode s (DragboardEvent a) makeDrop Int i forall a b. (a -> b) -> a -> b $ if forall (t :: * -> *) a. Foldable t => t a -> Bool null [a] xs then forall s e. WidgetNode s e filler else forall a s e. DragMsg a => a -> [DraggableCfg s e] -> WidgetNode s e -> WidgetNode s e draggable_ (Int -> DragId DragId Int i) forall {s} {e}. [DraggableCfg s e] draggableConfigs forall a b. (a -> b) -> a -> b $ forall {s}. [a] -> WidgetNode s (DragboardEvent a) managed [a] xs makeDrop :: Int -> WidgetNode s (DragboardEvent a) -> WidgetNode s (DragboardEvent a) makeDrop Int i = forall a e s. (DragMsg a, WidgetEvent e) => (a -> e) -> WidgetNode s e -> WidgetNode s e dropTarget (forall a. Int -> DragId -> DragboardEvent a EventDrop Int i) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall {a} {s}. Typeable a => Int -> WidgetNode s (DragboardEvent a) -> WidgetNode s (DragboardEvent a) makeAnim Int i clickBox :: Int -> WidgetNode s (DragboardEvent a) -> WidgetNode s (DragboardEvent a) clickBox Int i WidgetNode s (DragboardEvent a) x = if Maybe Bool _dcNoClick forall a. Eq a => a -> a -> Bool == forall a. a -> Maybe a Just Bool True then WidgetNode s (DragboardEvent a) x else forall {t}. CmbStyleBasic t => Int -> t -> t paint Int i forall a b. (a -> b) -> a -> b $ forall s e. (WidgetModel s, WidgetEvent e) => [BoxCfg s e] -> WidgetNode s e -> WidgetNode s e box_ [forall t e. CmbOnBtnReleased t e => (Button -> Int -> e) -> t onBtnReleased forall a b. (a -> b) -> a -> b $ \Button _ Int _ -> forall a. Int -> DragboardEvent a EventClick Int i] WidgetNode s (DragboardEvent a) x paint :: Int -> t -> t paint Int i t x = if DragboardModel a model forall s a. s -> Getting a s a -> a ^. forall s a. HasSelectedSquare s a => Lens' s a selectedSquare forall a. Eq a => a -> a -> Bool == forall a. a -> Maybe a Just Int i then t x forall t. CmbStyleBasic t => t -> [StyleState] -> t `styleBasic` [forall t. CmbBgColor t => Color -> t bgColor Color selectedColor] else t x draggableConfigs :: [DraggableCfg s e] draggableConfigs = [forall s e. Bool -> DraggableCfg s e draggableRenderSource_ Bool renderS] renderS :: Bool renderS = forall a. a -> Maybe a -> a fromMaybe Bool False Maybe Bool _dcRenderS selectedColor :: Color selectedColor = forall a. a -> Maybe a -> a fromMaybe Color yellow Maybe Color _dcSelectColor makeAnim :: Int -> WidgetNode s (DragboardEvent a) -> WidgetNode s (DragboardEvent a) makeAnim Int i WidgetNode s (DragboardEvent a) x = forall e s. WidgetEvent e => [TransformCfg s e] -> Transformer -> WidgetNode s e -> WidgetNode s e animTransform_ [ forall t a. CmbDuration t a => a -> t duration Millisecond dur , forall t e. CmbOnFinished t e => e -> t onFinished forall a b. (a -> b) -> a -> b $ forall a. Int -> DragboardEvent a EventFinished Int i ] (Int -> Transformer fa Int i) WidgetNode s (DragboardEvent a) x forall s e. WidgetNode s e -> Text -> WidgetNode s e `nodeKey` (Text "dragItem" forall a. Semigroup a => a -> a -> a <> forall a. TextShow a => a -> Text showt Int i) fa :: Int -> Transformer fa Int i Double t (Rect Double x2 Double y2 Double _ Double _) = [RenderTransform] transformation where transformation :: [RenderTransform] transformation = if forall (t :: * -> *) a. Foldable t => t a -> Bool null Maybe Rect sourceRect then [] else [ Point -> RenderTransform animTranslation forall a b. (a -> b) -> a -> b $ Double -> Double -> Point Point Double x Double y , Rect -> RenderTransform animScissor forall a b. (a -> b) -> a -> b $ Double -> Double -> Double -> Double -> Rect Rect (-Double 10000) (-Double 10000) Double 20000 Double 20000 ] (Double x, Double y) = ((Double x2forall a. Num a => a -> a -> a -Double x1)forall a. Num a => a -> a -> a *Double tforall a. Fractional a => a -> a -> a /Double dur'forall a. Num a => a -> a -> a -Double x2forall a. Num a => a -> a -> a +Double x1, (Double y2forall a. Num a => a -> a -> a -Double y1)forall a. Num a => a -> a -> a *Double tforall a. Fractional a => a -> a -> a /Double dur'forall a. Num a => a -> a -> a -Double y2forall a. Num a => a -> a -> a +Double y1) Rect Double x1 Double y1 Double _ Double _ = forall a. HasCallStack => Maybe a -> a fromJust Maybe Rect sourceRect sourceRect :: Maybe Rect sourceRect = forall k a. Ord k => k -> Map k a -> Maybe a Map.lookup Int i forall a b. (a -> b) -> a -> b $ DragboardModel a model forall s a. s -> Getting a s a -> a ^. forall s a. HasAnimationSources s a => Lens' s a animationSources managed :: [a] -> WidgetNode s (DragboardEvent a) managed = forall {e} {s}. Typeable e => Either Text Color -> WidgetNode s e makeWidget forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Either Text Color getPathOrColor forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. [a] -> a head makeWidget :: Either Text Color -> WidgetNode s e makeWidget (Left Text path) = forall e s. WidgetEvent e => Text -> [ImageCfg e] -> WidgetNode s e image_ Text path [forall t. CmbFitEither t => t fitEither] makeWidget (Right Color color) = forall s e. WidgetNode s e filler forall t. CmbStyleBasic t => t -> [StyleState] -> t `styleBasic` [forall t. CmbBgColor t => Color -> t bgColor Color color] boardState' :: [[a]] boardState' = DragboardModel a model forall s a. s -> Getting a s a -> a ^. forall s a. HasBoardState s a => Lens' s a boardState dur' :: Double dur' = forall a b. (Integral a, Num b) => a -> b fromIntegral Millisecond dur dur :: Millisecond dur = forall a. a -> Maybe a -> a fromMaybe Millisecond 500 Maybe Millisecond _dcDuration