{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE BlockArguments, LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables, TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Control.Moffy.Samples.Boxes.Run.Gtk3 where

import Prelude hiding (until)

import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM hiding (retry)
import Data.Maybe
import Data.Type.Set
import Data.Type.Flip
import Data.Time.Clock.System
import Data.Color

import Control.Moffy
import Control.Moffy.Event.Time
import Control.Moffy.Handle
import Control.Moffy.Handle.Time
import Control.Moffy.Samples.Event.Delete
import Control.Moffy.Samples.Event.Mouse qualified as Mouse
import Control.Moffy.Samples.Event.CalcTextExtents
import Control.Moffy.Samples.Handle.TChan
import Control.Moffy.Samples.View qualified as V
import Control.Moffy.Samples.Run.TChan
import Control.Moffy.Samples.Boxes.Viewable

import Control.Moffy.Samples.Run.Gtk3

runBoxes :: Sig s es [Box] a -> IO ()
runBoxes Sig s es [Box] a
bxs = Sig s es View () -> IO ()
forall s (es :: Set (*)) r.
(Adjustable
   (Merge es (Singleton DeleteEvent))
   (CalcTextExtents
    :- (Move
        :- (Down
            :- (Up :- (DeltaTime :- (TryWait :- (DeleteEvent :- 'Nil))))))),
 Firstable
   es
   (Singleton DeleteEvent)
   (ISig s (Merge es (Singleton DeleteEvent)) View r)
   ()) =>
Sig s es View r -> IO ()
runBoxes_ (Sig s es View () -> IO ()) -> Sig s es View () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Box] -> View
boxesToView ([Box] -> View) -> Sig s es [Box] a -> Sig s es View a
forall (t :: * -> * -> *) c a b.
Functor (Flip t c) =>
(a -> b) -> t a c -> t b c
<$%> ([Box] -> Sig s es [Box] ()
forall a s (es :: Set (*)). a -> Sig s es a ()
emit [] Sig s es [Box] () -> Sig s es [Box] a -> Sig s es [Box] a
forall a b.
Sig s es [Box] a -> Sig s es [Box] b -> Sig s es [Box] b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Sig s es [Box] a
bxs) Sig s es View a -> Sig s es View () -> Sig s es View ()
forall a b. Sig s es View a -> Sig s es View b -> Sig s es View b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> View -> Sig s es View ()
forall a s (es :: Set (*)). a -> Sig s es a ()
emit View
V.Stopped

runBoxes_ :: forall s es r . (
	Adjustable
		(Merge es (Singleton DeleteEvent))
		(CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- DeltaTime :- TryWait :- DeleteEvent :- 'Nil),
	Firstable es (Singleton DeleteEvent) (ISig s (es :+: Singleton DeleteEvent) V.View r) () ) =>
	Sig s es V.View r -> IO ()
runBoxes_ :: forall s (es :: Set (*)) r.
(Adjustable
   (Merge es (Singleton DeleteEvent))
   (CalcTextExtents
    :- (Move
        :- (Down
            :- (Up :- (DeltaTime :- (TryWait :- (DeleteEvent :- 'Nil))))))),
 Firstable
   es
   (Singleton DeleteEvent)
   (ISig s (Merge es (Singleton DeleteEvent)) View r)
   ()) =>
Sig s es View r -> IO ()
runBoxes_ Sig s es View r
b = do
	er <- STM
  (TChan
     (EvReqs
        (Move
         ':~ (Down
              ':~ (Up ':~ (CalcTextExtents ':~ Singleton DeleteEvent))))))
-> IO
     (TChan
        (EvReqs
           (Move
            ':~ (Down
                 ':~ (Up ':~ (CalcTextExtents ':~ Singleton DeleteEvent))))))
forall a. STM a -> IO a
atomically STM
  (TChan
     (EvReqs
        (Move
         ':~ (Down
              ':~ (Up ':~ (CalcTextExtents ':~ Singleton DeleteEvent))))))
forall a. STM (TChan a)
newTChan
	eo <- atomically newTChan
	v <- atomically newTChan
	void $ forkIO do
		now <- systemToTAITime <$> getSystemTime
		void . ($ (InitialMode, now)) $ interpretSt
			(retrySt . ($ (0.05, ())) . popInput . handleTimeEvPlus . pushInput . const . liftHandle' . sleepIfNothing 50000
				$ handleNew @(CalcTextExtents :- Mouse.Move :- Mouse.Down :- Mouse.Up :- Singleton DeleteEvent) er eo) v do
			b `until` deleteEvent :: Sig s (Merge es (Singleton DeleteEvent)) V.View (Either r (V.View, ()))
			emit V.Stopped
	runSingleWin er eo v

boxesToView :: [Box] -> V.View
boxesToView :: [Box] -> View
boxesToView = [View1] -> View
V.View ([View1] -> View) -> ([Box] -> [View1]) -> [Box] -> View
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Box -> View1
boxToView1 (Box -> View1) -> [Box] -> [View1]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

boxToView1 :: Box -> V.View1
boxToView1 :: Box -> View1
boxToView1 (Box (Rect Point
lu Point
rd) BColor
c) = Point -> Point -> Rgb Double -> View1
V.Box Point
lu Point
rd (Rgb Double -> View1) -> Rgb Double -> View1
forall a b. (a -> b) -> a -> b
$ BColor -> Rgb Double
bColorToColor BColor
c

bColorToColor :: BColor -> Rgb Double
bColorToColor :: BColor -> Rgb Double
bColorToColor = Maybe (Rgb Double) -> Rgb Double
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Rgb Double) -> Rgb Double)
-> (BColor -> Maybe (Rgb Double)) -> BColor -> Rgb Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
	BColor
Red -> Double -> Double -> Double -> Maybe (Rgb Double)
forall d. (Ord d, Num d) => d -> d -> d -> Maybe (Rgb d)
rgbDouble Double
0.8 Double
0.1 Double
0.05
	BColor
Green -> Double -> Double -> Double -> Maybe (Rgb Double)
forall d. (Ord d, Num d) => d -> d -> d -> Maybe (Rgb d)
rgbDouble Double
0.2 Double
0.6 Double
0.1
	BColor
Blue -> Double -> Double -> Double -> Maybe (Rgb Double)
forall d. (Ord d, Num d) => d -> d -> d -> Maybe (Rgb d)
rgbDouble Double
0.2 Double
0.2 Double
0.8
	BColor
Yellow -> Double -> Double -> Double -> Maybe (Rgb Double)
forall d. (Ord d, Num d) => d -> d -> d -> Maybe (Rgb d)
rgbDouble Double
0.8 Double
0.7 Double
0.1
	BColor
Cyan -> Double -> Double -> Double -> Maybe (Rgb Double)
forall d. (Ord d, Num d) => d -> d -> d -> Maybe (Rgb d)
rgbDouble Double
0.2 Double
0.6 Double
0.6
	BColor
Magenta -> Double -> Double -> Double -> Maybe (Rgb Double)
forall d. (Ord d, Num d) => d -> d -> d -> Maybe (Rgb d)
rgbDouble Double
0.5 Double
0.2 Double
0.4