{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}

{-
  Copyright 2020 The CodeWorld Authors. All rights reserved.

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

-- | Module for using CodeWorld pictures in Reflex-based FRP applications.
module CodeWorld.Reflex
  ( -- $intro
    reflexOf,
    debugReflexOf,
    ReflexCodeWorld,
    getKeyPress,
    getKeyRelease,
    getTextEntry,
    getPointerClick,
    getPointerPosition,
    isPointerDown,
    getTimePassing,
    draw,

    -- * Pictures
    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,

    -- * Colors
    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

-- $intro
-- = Using Reflex with CodeWorld
--
-- This is an alternative to the standard CodeWorld API, which is based on
-- the Reflex library.  You should import this __instead__ of 'CodeWorld', since
-- the 'CodeWorld' module exports conflict with Reflex names.
--
-- When using this module, you can build pictures using the same combinators as
-- the main 'CodeWorld' module.  However, the way you handle user input and draw
-- to the screen is different.  The 'ReflexCodeWorld' constraint gives you a
-- monad that has access to Reflex versions of input, such as keys, the mouse
-- pointer, and the time.  Based on these inputs, you'll use 'draw' to draw
-- output to the screen.
--
-- The Reflex API is documented in many places, but a great reference is
-- available in the <https://github.com/reflex-frp/reflex/blob/develop/Quickref.md Reflex Quick Reference>.

-- | Runs a reactive program, discharging the 'ReflexCodeWorld' constraint.
-- This is the starting point for Reflex programs in CodeWorld.
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

-- | A variant of 'reflexOf' that includes some on-screen debugging controls.
-- You can use this during development, but should usually switch back to
-- 'reflexOf' when you're done debugging.
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