{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
module CodeWorld.Reflex
(
reflexOf,
debugReflexOf,
ReflexCodeWorld,
getKeyPress,
getKeyRelease,
getTextEntry,
getPointerClick,
getPointerPosition,
isPointerDown,
getTimePassing,
draw,
Picture,
blank,
polyline,
thickPolyline,
polygon,
thickPolygon,
solidPolygon,
curve,
thickCurve,
closedCurve,
thickClosedCurve,
solidClosedCurve,
rectangle,
solidRectangle,
thickRectangle,
circle,
solidCircle,
thickCircle,
arc,
sector,
thickArc,
lettering,
TextStyle (..),
Font (..),
styledLettering,
colored,
coloured,
translated,
scaled,
dilated,
rotated,
reflected,
clipped,
pictures,
(<>),
(&),
coordinatePlane,
codeWorldLogo,
Point,
translatedPoint,
rotatedPoint,
scaledPoint,
dilatedPoint,
Vector,
vectorLength,
vectorDirection,
vectorSum,
vectorDifference,
scaledVector,
rotatedVector,
dotProduct,
Color (..),
Colour,
pattern RGB,
pattern HSL,
black,
white,
red,
green,
blue,
yellow,
orange,
brown,
pink,
purple,
gray,
grey,
mixed,
lighter,
light,
darker,
dark,
brighter,
bright,
duller,
dull,
translucent,
assortedColors,
hue,
saturation,
luminosity,
alpha,
)
where
import CodeWorld.Color
import CodeWorld.Driver
import CodeWorld.Picture
import Control.Monad.Fix
import Control.Monad.Trans
import Data.Bool
import qualified Data.Text as T
import Numeric (showFFloatAlt)
import Reflex
reflexOf :: (forall t m. ReflexCodeWorld t m => m ()) -> IO ()
reflexOf :: (forall t (m :: * -> *). ReflexCodeWorld t m => m ()) -> IO ()
reflexOf forall t (m :: * -> *). ReflexCodeWorld t m => m ()
program = (forall t (m :: * -> *).
(Reflex t, Adjustable t m, MonadHold t m, NotReady t m,
PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadFix m,
MonadIO m, MonadIO (Performable m)) =>
ReactiveInput t -> m (Dynamic t Picture, Dynamic t Picture))
-> IO ()
runReactive forall a b. (a -> b) -> a -> b
$ \ReactiveInput t
input -> forall t (m :: * -> *).
(Reflex t, MonadFix m) =>
ReactiveProgram t m ()
-> ReactiveInput t -> m (Dynamic t Picture, Dynamic t Picture)
runReactiveProgram forall t (m :: * -> *). ReflexCodeWorld t m => m ()
program ReactiveInput t
input
debugReflexOf :: (forall t m. ReflexCodeWorld t m => m ()) -> IO ()
debugReflexOf :: (forall t (m :: * -> *). ReflexCodeWorld t m => m ()) -> IO ()
debugReflexOf forall t (m :: * -> *). ReflexCodeWorld t m => m ()
program = (forall t (m :: * -> *).
(Reflex t, Adjustable t m, MonadHold t m, NotReady t m,
PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadFix m,
MonadIO m, MonadIO (Performable m)) =>
ReactiveInput t -> m (Dynamic t Picture, Dynamic t Picture))
-> IO ()
runReactive forall a b. (a -> b) -> a -> b
$ \ReactiveInput t
input -> forall a b c. (a -> b -> c) -> b -> a -> c
flip forall t (m :: * -> *).
(Reflex t, MonadFix m) =>
ReactiveProgram t m ()
-> ReactiveInput t -> m (Dynamic t Picture, Dynamic t Picture)
runReactiveProgram ReactiveInput t
input forall a b. (a -> b) -> a -> b
$ do
Dynamic t Double
hoverAlpha <- forall t (m :: * -> *). ReflexCodeWorld t m => m (Dynamic t Double)
getHoverAlpha
ControlState t
controlState <- forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double -> ReactiveProgram t m (ControlState t)
reactiveDebugControls Dynamic t Double
hoverAlpha
ReactiveInput t
logicalInputs <- forall t (m :: * -> *).
(Reflex t, MonadHold t m) =>
ControlState t -> ReactiveInput t -> m (ReactiveInput t)
makeLogicalInputs ControlState t
controlState forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) t.
Monad m =>
ReactiveProgram t m (ReactiveInput t)
getReactiveInput
forall t (m :: * -> *) a.
ReactiveInput t -> ReactiveProgram t m a -> ReactiveProgram t m a
withReactiveInput ReactiveInput t
logicalInputs forall t (m :: * -> *). ReflexCodeWorld t m => m ()
program
data ControlState t = ControlState
{ forall t. ControlState t -> Dynamic t Bool
csRunning :: Dynamic t Bool,
forall t. ControlState t -> Dynamic t Double
csTimeDilation :: Dynamic t Double,
forall t. ControlState t -> Dynamic t (Point -> Point)
csPointTransform :: Dynamic t (Point -> Point),
forall t. ControlState t -> Event t ()
csSyntheticStep :: Event t ()
}
makeLogicalInputs :: (Reflex t, MonadHold t m) => ControlState t -> ReactiveInput t -> m (ReactiveInput t)
makeLogicalInputs :: forall t (m :: * -> *).
(Reflex t, MonadHold t m) =>
ControlState t -> ReactiveInput t -> m (ReactiveInput t)
makeLogicalInputs (ControlState {Dynamic t Bool
Dynamic t Double
Dynamic t (Point -> Point)
Event t ()
csSyntheticStep :: Event t ()
csPointTransform :: Dynamic t (Point -> Point)
csTimeDilation :: Dynamic t Double
csRunning :: Dynamic t Bool
csSyntheticStep :: forall t. ControlState t -> Event t ()
csPointTransform :: forall t. ControlState t -> Dynamic t (Point -> Point)
csTimeDilation :: forall t. ControlState t -> Dynamic t Double
csRunning :: forall t. ControlState t -> Dynamic t Bool
..}) ReactiveInput t
input = do
Event t Text
keyPress <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn Dynamic t Bool
csRunning forall a b. (a -> b) -> a -> b
$ forall t. ReactiveInput t -> Event t Text
keyPress ReactiveInput t
input
Event t Text
keyRelease <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn Dynamic t Bool
csRunning forall a b. (a -> b) -> a -> b
$ forall t. ReactiveInput t -> Event t Text
keyRelease ReactiveInput t
input
Event t Text
textEntry <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn Dynamic t Bool
csRunning forall a b. (a -> b) -> a -> b
$ forall t. ReactiveInput t -> Event t Text
textEntry ReactiveInput t
input
Event t Point
pointerPress <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn Dynamic t Bool
csRunning forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a b c.
Reflex t =>
(a -> b -> c) -> Behavior t a -> Event t b -> Event t c
attachWith forall a b. (a -> b) -> a -> b
($) (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t (Point -> Point)
csPointTransform) (forall t. ReactiveInput t -> Event t Point
pointerPress ReactiveInput t
input)
Event t Point
pointerRelease <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn Dynamic t Bool
csRunning forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a b c.
Reflex t =>
(a -> b -> c) -> Behavior t a -> Event t b -> Event t c
attachWith forall a b. (a -> b) -> a -> b
($) (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t (Point -> Point)
csPointTransform) (forall t. ReactiveInput t -> Event t Point
pointerRelease ReactiveInput t
input)
Dynamic t Point
pointerPosition <- forall t (m :: * -> *) a.
(Reflex t, MonadHold t m) =>
Dynamic t Bool -> Dynamic t a -> m (Dynamic t a)
freezeDyn Dynamic t Bool
csRunning forall a b. (a -> b) -> a -> b
$ Dynamic t (Point -> Point)
csPointTransform forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. ReactiveInput t -> Dynamic t Point
pointerPosition ReactiveInput t
input
Dynamic t Bool
pointerDown <- forall t (m :: * -> *) a.
(Reflex t, MonadHold t m) =>
Dynamic t Bool -> Dynamic t a -> m (Dynamic t a)
freezeDyn Dynamic t Bool
csRunning forall a b. (a -> b) -> a -> b
$ forall t. ReactiveInput t -> Dynamic t Bool
pointerDown ReactiveInput t
input
Event t Double
timePassing <-
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith
forall a. Num a => a -> a -> a
(+)
[ forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn Dynamic t Bool
csRunning forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a b c.
Reflex t =>
(a -> b -> c) -> Behavior t a -> Event t b -> Event t c
attachWith forall a. Num a => a -> a -> a
(*) (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t Double
csTimeDilation) (forall t. ReactiveInput t -> Event t Double
timePassing ReactiveInput t
input),
Double
0.1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
csSyntheticStep
]
forall (m :: * -> *) a. Monad m => a -> m a
return (ReactiveInput {Dynamic t Bool
Dynamic t Point
Event t Double
Event t Point
Event t Text
timePassing :: Event t Double
timePassing :: Event t Double
pointerDown :: Dynamic t Bool
pointerDown :: Dynamic t Bool
pointerPosition :: Dynamic t Point
pointerPosition :: Dynamic t Point
pointerRelease :: Event t Point
pointerRelease :: Event t Point
pointerPress :: Event t Point
pointerPress :: Event t Point
textEntry :: Event t Text
textEntry :: Event t Text
keyRelease :: Event t Text
keyRelease :: Event t Text
keyPress :: Event t Text
keyPress :: Event t Text
..})
freezeDyn :: (Reflex t, MonadHold t m) => Dynamic t Bool -> Dynamic t a -> m (Dynamic t a)
freezeDyn :: forall t (m :: * -> *) a.
(Reflex t, MonadHold t m) =>
Dynamic t Bool -> Dynamic t a -> m (Dynamic t a)
freezeDyn Dynamic t Bool
predicate Dynamic t a
dyn = do
a
initial <- forall {k} (t :: k) (m :: * -> *) a.
MonadSample t m =>
Behavior t a -> m a
sample (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t a
dyn)
forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn a
initial (forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn Dynamic t Bool
predicate (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t a
dyn))
reactiveDebugControls ::
( PerformEvent t m,
TriggerEvent t m,
Adjustable t m,
NotReady t m,
MonadIO m,
MonadIO (Performable m),
PostBuild t m,
MonadHold t m,
MonadFix m
) =>
Dynamic t Double ->
ReactiveProgram t m (ControlState t)
reactiveDebugControls :: forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double -> ReactiveProgram t m (ControlState t)
reactiveDebugControls Dynamic t Double
hoverAlpha = do
Event t ()
fastForwardClick <- forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double -> Point -> ReactiveProgram t m (Event t ())
fastForwardButton Dynamic t Double
hoverAlpha (-Double
4, -Double
9)
rec Event t Double
speedDragged <- forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Point
-> Dynamic t Double
-> ReactiveProgram t m (Event t Double)
speedSlider Dynamic t Double
hoverAlpha (-Double
6, -Double
9) Dynamic t Double
speedFactor
Event t ()
playPauseClick <- forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Dynamic t Bool -> Point -> ReactiveProgram t m (Event t ())
playPauseButton Dynamic t Double
hoverAlpha Dynamic t Bool
running (-Double
8, -Double
9)
Dynamic t Double
speedFactor <-
forall {k} (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn forall a b. (a -> b) -> a -> b
($) Double
1 forall a b. (a -> b) -> a -> b
$
forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
[ (\Double
s -> if Double
s forall a. Eq a => a -> a -> Bool
== Double
0 then Double
1 else Double
0) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
playPauseClick,
(\Double
s -> forall a. Ord a => a -> a -> a
max Double
2.0 (Double
s forall a. Num a => a -> a -> a
+ Double
1)) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
fastForwardClick,
forall a b. a -> b -> a
const forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t Double
speedDragged
]
let running :: Dynamic t Bool
running = (forall a. Ord a => a -> a -> Bool
> Double
0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
speedFactor
rec Event t ()
resetViewClick <- forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Point -> Dynamic t Bool -> ReactiveProgram t m (Event t ())
resetViewButton Dynamic t Double
hoverAlpha (Double
9, -Double
3) Dynamic t Bool
needsReset
Dynamic t Double
zoomFactor <- forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Point -> Event t () -> ReactiveProgram t m (Dynamic t Double)
zoomControls Dynamic t Double
hoverAlpha (Double
9, -Double
6) Event t ()
resetViewClick
Dynamic t Point
panOffset <- forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Bool
-> Event t () -> ReactiveProgram t m (Dynamic t Point)
panControls Dynamic t Bool
running Event t ()
resetViewClick
let needsReset :: Dynamic t Bool
needsReset =
Bool -> Bool -> Bool
(||) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a. Eq a => a -> a -> Bool
/= Double
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
zoomFactor)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((forall a. Eq a => a -> a -> Bool
/= (Double
0, Double
0)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Point
panOffset)
Event t ()
stepClick <- forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Point -> Dynamic t Bool -> ReactiveProgram t m (Event t ())
stepButton Dynamic t Double
hoverAlpha (-Double
2, -Double
9) Dynamic t Bool
running
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t (Picture -> Picture) -> ReactiveProgram t m ()
transformUserPicture forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Double -> Double -> Picture -> Picture
translated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Point
panOffset
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t (Picture -> Picture) -> ReactiveProgram t m ()
transformUserPicture forall a b. (a -> b) -> a -> b
$ HasCallStack => Double -> Picture -> Picture
dilated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
zoomFactor
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
ControlState
{ csRunning :: Dynamic t Bool
csRunning = Dynamic t Bool
running,
csTimeDilation :: Dynamic t Double
csTimeDilation = Dynamic t Double
speedFactor,
csPointTransform :: Dynamic t (Point -> Point)
csPointTransform = forall {b}. Fractional b => b -> (b, b) -> (b, b) -> (b, b)
transformPoint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
zoomFactor forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Point
panOffset,
csSyntheticStep :: Event t ()
csSyntheticStep = Event t ()
stepClick
}
where
transformPoint :: b -> (b, b) -> (b, b) -> (b, b)
transformPoint b
z (b
dx, b
dy) (b
x, b
y) = ((b
x forall a. Num a => a -> a -> a
- b
dx) forall a. Fractional a => a -> a -> a
/ b
z, (b
y forall a. Num a => a -> a -> a
- b
dy) forall a. Fractional a => a -> a -> a
/ b
z)
getHoverAlpha :: ReflexCodeWorld t m => m (Dynamic t Double)
getHoverAlpha :: forall t (m :: * -> *). ReflexCodeWorld t m => m (Dynamic t Double)
getHoverAlpha = do
Event t Double
time <- forall t (m :: * -> *). ReflexCodeWorld t m => m (Event t Double)
getTimePassing
Event t Point
move <- forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Dynamic t Point)
getPointerPosition
rec Dynamic t Double
timeSinceMove <-
forall {k} (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn forall a b. (a -> b) -> a -> b
($) Double
999 forall a b. (a -> b) -> a -> b
$
forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
[ forall a. Num a => a -> a -> a
(+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn ((forall a. Ord a => a -> a -> Bool
< Double
5) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
timeSinceMove) Event t Double
time,
forall a b. a -> b -> a
const Double
0 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t Point
move
]
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {a}. (Ord a, Fractional a) => a -> a
alphaFromTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
timeSinceMove)
where
alphaFromTime :: a -> a
alphaFromTime a
t
| a
t forall a. Ord a => a -> a -> Bool
< a
4.5 = a
1
| a
t forall a. Ord a => a -> a -> Bool
> a
5.0 = a
0
| Bool
otherwise = a
10 forall a. Num a => a -> a -> a
- a
2 forall a. Num a => a -> a -> a
* a
t
playPauseButton ::
( PerformEvent t m,
TriggerEvent t m,
Adjustable t m,
NotReady t m,
MonadIO m,
MonadIO (Performable m),
PostBuild t m,
MonadHold t m,
MonadFix m
) =>
Dynamic t Double ->
Dynamic t Bool ->
Point ->
ReactiveProgram t m (Event t ())
playPauseButton :: forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Dynamic t Bool -> Point -> ReactiveProgram t m (Event t ())
playPauseButton Dynamic t Double
hoverAlpha Dynamic t Bool
running Point
pos = do
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t Picture -> ReactiveProgram t m ()
systemDraw forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Double -> Double -> Picture -> Picture
translated Point
pos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. a -> a -> Bool -> a
bool (Double -> Picture
playButton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
hoverAlpha) (Double -> Picture
pauseButton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
hoverAlpha) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Dynamic t Bool
running)
Event t Point
click <- forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
ffilter (Double -> Double -> Point -> Point -> Bool
onRect Double
0.8 Double
0.8 Point
pos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Event t Point)
getPointerClick
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t Point
click
where
playButton :: Double -> Picture
playButton Double
a =
HasCallStack => Color -> Picture -> Picture
colored
(Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
a)
(HasCallStack => [Point] -> Picture
solidPolygon [(-Double
0.2, Double
0.25), (-Double
0.2, -Double
0.25), (Double
0.2, Double
0)])
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.2 Double
0.2 Double
0.2 Double
a) (HasCallStack => Double -> Double -> Picture
rectangle Double
0.8 Double
0.8)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.8 Double
0.8 Double
0.8 Double
a) (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.8 Double
0.8)
pauseButton :: Double -> Picture
pauseButton Double
a =
HasCallStack => Color -> Picture -> Picture
colored
(Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
a)
( HasCallStack => Double -> Double -> Picture -> Picture
translated (-Double
0.15) Double
0 (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.2 Double
0.6)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Double -> Double -> Picture -> Picture
translated Double
0.15 Double
0 (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.2 Double
0.6)
)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.2 Double
0.2 Double
0.2 Double
a) (HasCallStack => Double -> Double -> Picture
rectangle Double
0.8 Double
0.8)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.8 Double
0.8 Double
0.8 Double
a) (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.8 Double
0.8)
stepButton ::
( PerformEvent t m,
TriggerEvent t m,
Adjustable t m,
NotReady t m,
MonadIO m,
MonadIO (Performable m),
PostBuild t m,
MonadHold t m,
MonadFix m
) =>
Dynamic t Double ->
Point ->
Dynamic t Bool ->
ReactiveProgram t m (Event t ())
stepButton :: forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Point -> Dynamic t Bool -> ReactiveProgram t m (Event t ())
stepButton Dynamic t Double
hoverAlpha Point
pos Dynamic t Bool
running = do
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t Picture -> ReactiveProgram t m ()
systemDraw forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Double -> Double -> Picture -> Picture
translated Point
pos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. a -> a -> Bool -> a
bool (Double -> Picture
button forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
hoverAlpha) (forall {k} (t :: k) a. Reflex t => a -> Dynamic t a
constDyn HasCallStack => Picture
blank) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Dynamic t Bool
running)
Event t Point
click <- forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Bool
running) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
ffilter (Double -> Double -> Point -> Point -> Bool
onRect Double
0.8 Double
0.8 Point
pos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Event t Point)
getPointerClick
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t Point
click
where
button :: Double -> Picture
button Double
a =
HasCallStack => Color -> Picture -> Picture
colored
(Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
a)
( HasCallStack => Double -> Double -> Picture -> Picture
translated (-Double
0.15) Double
0 (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.2 Double
0.5)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => [Point] -> Picture
solidPolygon [(Double
0.05, Double
0.25), (Double
0.05, -Double
0.25), (Double
0.3, Double
0)]
)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.2 Double
0.2 Double
0.2 Double
a) (HasCallStack => Double -> Double -> Picture
rectangle Double
0.8 Double
0.8)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.8 Double
0.8 Double
0.8 Double
a) (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.8 Double
0.8)
fastForwardButton ::
( PerformEvent t m,
TriggerEvent t m,
Adjustable t m,
NotReady t m,
MonadIO m,
MonadIO (Performable m),
PostBuild t m,
MonadHold t m,
MonadFix m
) =>
Dynamic t Double ->
Point ->
ReactiveProgram t m (Event t ())
fastForwardButton :: forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double -> Point -> ReactiveProgram t m (Event t ())
fastForwardButton Dynamic t Double
hoverAlpha Point
pos = do
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t Picture -> ReactiveProgram t m ()
systemDraw forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Double -> Double -> Picture -> Picture
translated Point
pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Double -> Picture
button forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
hoverAlpha
Event t Point
click <- forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
ffilter (Double -> Double -> Point -> Point -> Bool
onRect Double
0.8 Double
0.8 Point
pos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Event t Point)
getPointerClick
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t Point
click
where
button :: Double -> Picture
button Double
a =
HasCallStack => Color -> Picture -> Picture
colored
(Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
a)
( HasCallStack => [Point] -> Picture
solidPolygon [(-Double
0.3, Double
0.25), (-Double
0.3, -Double
0.25), (-Double
0.05, Double
0)]
forall a. Semigroup a => a -> a -> a
<> HasCallStack => [Point] -> Picture
solidPolygon [(Double
0.05, Double
0.25), (Double
0.05, -Double
0.25), (Double
0.3, Double
0)]
)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.2 Double
0.2 Double
0.2 Double
a) (HasCallStack => Double -> Double -> Picture
rectangle Double
0.8 Double
0.8)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.8 Double
0.8 Double
0.8 Double
a) (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.8 Double
0.8)
speedSlider ::
( PerformEvent t m,
TriggerEvent t m,
Adjustable t m,
NotReady t m,
MonadIO m,
MonadIO (Performable m),
PostBuild t m,
MonadHold t m,
MonadFix m
) =>
Dynamic t Double ->
Point ->
Dynamic t Double ->
ReactiveProgram t m (Event t Double)
speedSlider :: forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Point
-> Dynamic t Double
-> ReactiveProgram t m (Event t Double)
speedSlider Dynamic t Double
hoverAlpha Point
pos Dynamic t Double
speedFactor = do
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t Picture -> ReactiveProgram t m ()
systemDraw forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Double -> Double -> Picture -> Picture
translated Point
pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> Double -> Picture
slider forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
hoverAlpha forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Double
speedFactor)
Event t Point
click <- forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
ffilter (Double -> Double -> Point -> Point -> Bool
onRect Double
3.0 Double
0.8 Point
pos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Event t Point)
getPointerClick
Event t Bool
release <- forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
ffilter Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Dynamic t Bool)
isPointerDown
Dynamic t Bool
dragging <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn Bool
False forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith Bool -> Bool -> Bool
(&&) [Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t Point
click, Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t Bool
release]
Dynamic t Point
pointer <- forall t (m :: * -> *). ReflexCodeWorld t m => m (Dynamic t Point)
getPointerPosition
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {b}. (Double, b) -> Double
speedFromPoint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith forall a b. a -> b -> a
const [forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn Dynamic t Bool
dragging (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t Point
pointer), Event t Point
click]
where
speedFromPoint :: (Double, b) -> Double
speedFromPoint (Double
x, b
_y) = Point -> Point -> Double -> Double
scaleRange (-Double
1.4, Double
1.4) (Double
0, Double
5) (Double
x forall a. Num a => a -> a -> a
- forall a b. (a, b) -> a
fst Point
pos)
xFromSpeed :: Double -> Double
xFromSpeed Double
speed = Point -> Point -> Double -> Double
scaleRange (Double
0, Double
5) (-Double
1.4, Double
1.4) Double
speed
slider :: Double -> Double -> Picture
slider Double
a Double
speed =
let xoff :: Double
xoff = Double -> Double
xFromSpeed Double
speed
in HasCallStack => Color -> Picture -> Picture
colored
(Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
a)
( HasCallStack => Double -> Double -> Picture -> Picture
translated Double
xoff Double
0.75 forall a b. (a -> b) -> a -> b
$ HasCallStack => Double -> Double -> Picture -> Picture
scaled Double
0.5 Double
0.5 forall a b. (a -> b) -> a -> b
$
HasCallStack => Text -> Picture
lettering (String -> Text
T.pack (forall a. RealFloat a => Maybe Int -> a -> ShowS
showFFloatAlt (forall a. a -> Maybe a
Just Int
2) Double
speed String
"x"))
)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
a) (HasCallStack => Double -> Double -> Picture -> Picture
translated Double
xoff Double
0 (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.2 Double
0.8))
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.2 Double
0.2 Double
0.2 Double
a) (HasCallStack => Double -> Double -> Picture
rectangle Double
2.8 Double
0.25)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.8 Double
0.8 Double
0.8 Double
a) (HasCallStack => Double -> Double -> Picture
solidRectangle Double
2.8 Double
0.25)
resetViewButton ::
( PerformEvent t m,
TriggerEvent t m,
Adjustable t m,
NotReady t m,
MonadIO m,
MonadIO (Performable m),
PostBuild t m,
MonadHold t m,
MonadFix m
) =>
Dynamic t Double ->
Point ->
Dynamic t Bool ->
ReactiveProgram t m (Event t ())
resetViewButton :: forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Point -> Dynamic t Bool -> ReactiveProgram t m (Event t ())
resetViewButton Dynamic t Double
hoverAlpha Point
pos Dynamic t Bool
needsReset = do
Event t Point
click <- forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn Dynamic t Bool
needsReset forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
ffilter (Double -> Double -> Point -> Point -> Bool
onRect Double
0.8 Double
0.8 Point
pos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Event t Point)
getPointerClick
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t Picture -> ReactiveProgram t m ()
systemDraw forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Double -> Double -> Picture -> Picture
translated Point
pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. a -> a -> Bool -> a
bool (forall {k} (t :: k) a. Reflex t => a -> Dynamic t a
constDyn HasCallStack => Picture
blank) (Double -> Picture
button forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
hoverAlpha) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Dynamic t Bool
needsReset)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t Point
click
where
button :: Double -> Picture
button Double
a =
HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.8 Double
0.8 Double
0.8 Double
a) (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.7 Double
0.2)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.8 Double
0.8 Double
0.8 Double
a) (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.2 Double
0.7)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.0 Double
0.0 Double
0.0 Double
a) (HasCallStack => Double -> Double -> Double -> Picture
thickRectangle Double
0.1 Double
0.5 Double
0.5)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.2 Double
0.2 Double
0.2 Double
a) (HasCallStack => Double -> Double -> Picture
rectangle Double
0.8 Double
0.8)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.8 Double
0.8 Double
0.8 Double
a) (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.8 Double
0.8)
panControls ::
( PerformEvent t m,
TriggerEvent t m,
Adjustable t m,
NotReady t m,
MonadIO m,
MonadIO (Performable m),
PostBuild t m,
MonadHold t m,
MonadFix m
) =>
Dynamic t Bool ->
Event t () ->
ReactiveProgram t m (Dynamic t (Double, Double))
panControls :: forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Bool
-> Event t () -> ReactiveProgram t m (Dynamic t Point)
panControls Dynamic t Bool
running Event t ()
resetClick = do
Event t Point
click <- forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Bool
running) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Event t Point)
getPointerClick
Event t Bool
release <- forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
ffilter Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Dynamic t Bool)
isPointerDown
Dynamic t Bool
dragging <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn Bool
False forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith Bool -> Bool -> Bool
(&&) [Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t Point
click, Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t Bool
release]
Dynamic t Point
pos <- forall t (m :: * -> *). ReflexCodeWorld t m => m (Dynamic t Point)
getPointerPosition
let dragPos :: Dynamic t (Maybe Point)
dragPos = forall a. a -> a -> Bool -> a
bool (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Bool
dragging forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Point
pos
Dynamic t (Maybe Point, Maybe Point)
diffPairs <- forall {k} (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn (\Maybe Point
x (Maybe Point
y, Maybe Point
_) -> (Maybe Point
x, Maybe Point
y)) (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing) (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t (Maybe Point)
dragPos)
let drags :: Event t Point
drags = forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
fmapMaybe forall {a} {b}.
(Num a, Num b) =>
(Maybe (a, b), Maybe (a, b)) -> Maybe (a, b)
toMovement (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t (Maybe Point, Maybe Point)
diffPairs)
forall {k} (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn forall a b. (a -> b) -> a -> b
($) (Double
0, Double
0) forall a b. (a -> b) -> a -> b
$
forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
[ Point -> Point -> Point
vectorSum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t Point
drags,
forall a b. a -> b -> a
const (Double
0, Double
0) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
resetClick
]
where
toMovement :: (Maybe (a, b), Maybe (a, b)) -> Maybe (a, b)
toMovement (Just (a
x1, b
y1), Just (a
x2, b
y2)) = forall a. a -> Maybe a
Just (a
x1 forall a. Num a => a -> a -> a
- a
x2, b
y1 forall a. Num a => a -> a -> a
- b
y2)
toMovement (Maybe (a, b), Maybe (a, b))
_ = forall a. Maybe a
Nothing
zoomControls ::
( PerformEvent t m,
TriggerEvent t m,
Adjustable t m,
NotReady t m,
MonadIO m,
MonadIO (Performable m),
PostBuild t m,
MonadHold t m,
MonadFix m
) =>
Dynamic t Double ->
Point ->
Event t () ->
ReactiveProgram t m (Dynamic t Double)
zoomControls :: forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Point -> Event t () -> ReactiveProgram t m (Dynamic t Double)
zoomControls Dynamic t Double
hoverAlpha (Double
x, Double
y) Event t ()
resetClick = do
Event t ()
zoomInClick <- forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double -> Point -> ReactiveProgram t m (Event t ())
zoomInButton Dynamic t Double
hoverAlpha (Double
x, Double
y forall a. Num a => a -> a -> a
+ Double
2)
Event t ()
zoomOutClick <- forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double -> Point -> ReactiveProgram t m (Event t ())
zoomOutButton Dynamic t Double
hoverAlpha (Double
x, Double
y forall a. Num a => a -> a -> a
- Double
2)
rec Event t Double
zoomDrag <- forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Point
-> Dynamic t Double
-> ReactiveProgram t m (Event t Double)
zoomSlider Dynamic t Double
hoverAlpha (Double
x, Double
y) Dynamic t Double
zoomFactor
Dynamic t Double
zoomFactor <-
forall {k} (t :: k) (m :: * -> *) a b.
(Reflex t, MonadHold t m, MonadFix m) =>
(a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
foldDyn forall a b. (a -> b) -> a -> b
($) Double
1 forall a b. (a -> b) -> a -> b
$
forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
[ (forall a. Num a => a -> a -> a
* Double
zoomIncrement) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
zoomInClick,
(forall a. Fractional a => a -> a -> a
/ Double
zoomIncrement) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
zoomOutClick,
forall a b. a -> b -> a
const forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t Double
zoomDrag,
forall a b. a -> b -> a
const Double
1 forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t ()
resetClick
]
forall (m :: * -> *) a. Monad m => a -> m a
return Dynamic t Double
zoomFactor
zoomInButton ::
( PerformEvent t m,
TriggerEvent t m,
Adjustable t m,
NotReady t m,
MonadIO m,
MonadIO (Performable m),
PostBuild t m,
MonadHold t m,
MonadFix m
) =>
Dynamic t Double ->
Point ->
ReactiveProgram t m (Event t ())
zoomInButton :: forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double -> Point -> ReactiveProgram t m (Event t ())
zoomInButton Dynamic t Double
hoverAlpha Point
pos = do
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t Picture -> ReactiveProgram t m ()
systemDraw forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Double -> Double -> Picture -> Picture
translated Point
pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Double -> Picture
button forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
hoverAlpha
(() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
ffilter (Double -> Double -> Point -> Point -> Bool
onRect Double
0.8 Double
0.8 Point
pos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Event t Point)
getPointerClick
where
button :: Double -> Picture
button Double
a =
HasCallStack => Color -> Picture -> Picture
colored
(Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
a)
( HasCallStack => Double -> Double -> Picture -> Picture
translated
(-Double
0.05)
(Double
0.05)
( HasCallStack => Double -> Double -> Picture
thickCircle Double
0.1 Double
0.22
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.06 Double
0.25
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.25 Double
0.06
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Double -> Picture -> Picture
rotated (- forall a. Floating a => a
pi forall a. Fractional a => a -> a -> a
/ Double
4) (HasCallStack => Double -> Double -> Picture -> Picture
translated Double
0.35 Double
0 (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.2 Double
0.1))
)
)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.2 Double
0.2 Double
0.2 Double
a) (HasCallStack => Double -> Double -> Picture
rectangle Double
0.8 Double
0.8)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.8 Double
0.8 Double
0.8 Double
a) (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.8 Double
0.8)
zoomOutButton ::
( PerformEvent t m,
TriggerEvent t m,
Adjustable t m,
NotReady t m,
MonadIO m,
MonadIO (Performable m),
PostBuild t m,
MonadHold t m,
MonadFix m
) =>
Dynamic t Double ->
Point ->
ReactiveProgram t m (Event t ())
zoomOutButton :: forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double -> Point -> ReactiveProgram t m (Event t ())
zoomOutButton Dynamic t Double
hoverAlpha Point
pos = do
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t Picture -> ReactiveProgram t m ()
systemDraw forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Double -> Double -> Picture -> Picture
translated Point
pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Double -> Picture
button forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
hoverAlpha
(() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
ffilter (Double -> Double -> Point -> Point -> Bool
onRect Double
0.8 Double
0.8 Point
pos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Event t Point)
getPointerClick
where
button :: Double -> Picture
button Double
a =
HasCallStack => Color -> Picture -> Picture
colored
(Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
a)
( HasCallStack => Double -> Double -> Picture -> Picture
translated
(-Double
0.05)
(Double
0.05)
( HasCallStack => Double -> Double -> Picture
thickCircle Double
0.1 Double
0.22
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.25 Double
0.06
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Double -> Picture -> Picture
rotated (- forall a. Floating a => a
pi forall a. Fractional a => a -> a -> a
/ Double
4) (HasCallStack => Double -> Double -> Picture -> Picture
translated Double
0.35 Double
0 (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.2 Double
0.1))
)
)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.2 Double
0.2 Double
0.2 Double
a) (HasCallStack => Double -> Double -> Picture
rectangle Double
0.8 Double
0.8)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.8 Double
0.8 Double
0.8 Double
a) (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.8 Double
0.8)
zoomSlider ::
( PerformEvent t m,
TriggerEvent t m,
Adjustable t m,
NotReady t m,
MonadIO m,
MonadIO (Performable m),
PostBuild t m,
MonadHold t m,
MonadFix m
) =>
Dynamic t Double ->
Point ->
Dynamic t Double ->
ReactiveProgram t m (Event t Double)
zoomSlider :: forall t (m :: * -> *).
(PerformEvent t m, TriggerEvent t m, Adjustable t m, NotReady t m,
MonadIO m, MonadIO (Performable m), PostBuild t m, MonadHold t m,
MonadFix m) =>
Dynamic t Double
-> Point
-> Dynamic t Double
-> ReactiveProgram t m (Event t Double)
zoomSlider Dynamic t Double
hoverAlpha Point
pos Dynamic t Double
factor = do
forall t (m :: * -> *).
(Reflex t, Monad m) =>
Dynamic t Picture -> ReactiveProgram t m ()
systemDraw forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => Double -> Double -> Picture -> Picture
translated Point
pos forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> Double -> Picture
slider forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dynamic t Double
hoverAlpha forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Dynamic t Double
factor)
Event t Point
click <- forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
ffilter (Double -> Double -> Point -> Point -> Bool
onRect Double
0.8 Double
3.0 Point
pos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Event t Point)
getPointerClick
Event t Bool
release <- forall (f :: * -> *) a. Filterable f => (a -> Bool) -> f a -> f a
ffilter Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *). ReflexCodeWorld t m => m (Dynamic t Bool)
isPointerDown
Dynamic t Bool
dragging <- forall {k} (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn Bool
False forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith Bool -> Bool -> Bool
(&&) [Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t Point
click, Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t Bool
release]
Dynamic t Point
pointer <- forall t (m :: * -> *). ReflexCodeWorld t m => m (Dynamic t Point)
getPointerPosition
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {a}. (a, Double) -> Double
zoomFromPoint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (t :: k) a.
Reflex t =>
(a -> a -> a) -> [Event t a] -> Event t a
mergeWith forall a b. a -> b -> a
const [forall t a. Reflex t => Dynamic t Bool -> Event t a -> Event t a
gateDyn Dynamic t Bool
dragging (forall {k} (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t Point
pointer), Event t Point
click]
where
zoomFromPoint :: (a, Double) -> Double
zoomFromPoint (a
_x, Double
y) = Double
zoomIncrement forall a. Floating a => a -> a -> a
** (Point -> Point -> Double -> Double
scaleRange (-Double
1.4, Double
1.4) (-Double
10, Double
10) (Double
y forall a. Num a => a -> a -> a
- forall a b. (a, b) -> b
snd Point
pos))
yFromZoom :: Double -> Double
yFromZoom Double
z = Point -> Point -> Double -> Double
scaleRange (-Double
10, Double
10) (-Double
1.4, Double
1.4) (forall a. Floating a => a -> a -> a
logBase Double
zoomIncrement Double
z)
slider :: Double -> Double -> Picture
slider Double
a Double
z =
let yoff :: Double
yoff = Double -> Double
yFromZoom Double
z
in HasCallStack => Color -> Picture -> Picture
colored
(Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
a)
( HasCallStack => Double -> Double -> Picture -> Picture
translated (-Double
1.1) Double
yoff forall a b. (a -> b) -> a -> b
$ HasCallStack => Double -> Double -> Picture -> Picture
scaled Double
0.5 Double
0.5 forall a b. (a -> b) -> a -> b
$
HasCallStack => Text -> Picture
lettering (String -> Text
T.pack (forall a. Show a => a -> String
show (forall a b. (RealFrac a, Integral b) => a -> b
round (Double
z forall a. Num a => a -> a -> a
* Double
100) :: Int) forall a. [a] -> [a] -> [a]
++ String
"%"))
)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0 Double
0 Double
0 Double
a) (HasCallStack => Double -> Double -> Picture -> Picture
translated Double
0 Double
yoff (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.8 Double
0.2))
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.2 Double
0.2 Double
0.2 Double
a) (HasCallStack => Double -> Double -> Picture
rectangle Double
0.25 Double
2.8)
forall a. Semigroup a => a -> a -> a
<> HasCallStack => Color -> Picture -> Picture
colored (Double -> Double -> Double -> Double -> Color
RGBA Double
0.8 Double
0.8 Double
0.8 Double
a) (HasCallStack => Double -> Double -> Picture
solidRectangle Double
0.25 Double
2.8)
zoomIncrement :: Double
zoomIncrement :: Double
zoomIncrement = Double
8 forall a. Floating a => a -> a -> a
** (Double
1 forall a. Fractional a => a -> a -> a
/ Double
10)
onRect :: Double -> Double -> Point -> Point -> Bool
onRect :: Double -> Double -> Point -> Point -> Bool
onRect Double
w Double
h (Double
x1, Double
y1) (Double
x2, Double
y2) = forall a. Num a => a -> a
abs (Double
x1 forall a. Num a => a -> a -> a
- Double
x2) forall a. Ord a => a -> a -> Bool
< Double
w forall a. Fractional a => a -> a -> a
/ Double
2 Bool -> Bool -> Bool
&& forall a. Num a => a -> a
abs (Double
y1 forall a. Num a => a -> a -> a
- Double
y2) forall a. Ord a => a -> a -> Bool
< Double
h forall a. Fractional a => a -> a -> a
/ Double
2
scaleRange :: (Double, Double) -> (Double, Double) -> Double -> Double
scaleRange :: Point -> Point -> Double -> Double
scaleRange (Double
a1, Double
b1) (Double
a2, Double
b2) Double
x = forall a. Ord a => a -> a -> a
min Double
b2 forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max Double
a2 forall a b. (a -> b) -> a -> b
$ (Double
x forall a. Num a => a -> a -> a
- Double
a1) forall a. Fractional a => a -> a -> a
/ (Double
b1 forall a. Num a => a -> a -> a
- Double
a1) forall a. Num a => a -> a -> a
* (Double
b2 forall a. Num a => a -> a -> a
- Double
a2) forall a. Num a => a -> a -> a
+ Double
a2