codeworld-api-0.6.0: src/CodeWorld/Reflex.hs

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

{-
  Copyright 2019 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
-- 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 program = runReactive $ \input -> runReactiveProgram program 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 program = runReactive $ \input -> flip runReactiveProgram input $ do
  hoverAlpha <- getHoverAlpha
  controlState <- reactiveDebugControls hoverAlpha
  logicalInputs <- makeLogicalInputs controlState =<< getReactiveInput
  withReactiveInput logicalInputs program

data ControlState t
  = ControlState
      { csRunning :: Dynamic t Bool,
        csTimeDilation :: Dynamic t Double,
        csPointTransform :: Dynamic t (Point -> Point),
        csSyntheticStep :: Event t ()
      }

makeLogicalInputs :: (Reflex t, MonadHold t m) => ControlState t -> ReactiveInput t -> m (ReactiveInput t)
makeLogicalInputs ControlState {..} input = do
  keyPress <- return $ gateDyn csRunning $ keyPress input
  keyRelease <- return $ gateDyn csRunning $ keyRelease input
  textEntry <- return $ gateDyn csRunning $ textEntry input
  pointerPress <- return $ gateDyn csRunning $ attachWith ($) (current csPointTransform) (pointerPress input)
  pointerRelease <- return $ gateDyn csRunning $ attachWith ($) (current csPointTransform) (pointerRelease input)
  pointerPosition <- freezeDyn csRunning $ csPointTransform <*> pointerPosition input
  pointerDown <- freezeDyn csRunning $ pointerDown input
  timePassing <-
    return $
      mergeWith
        (+)
        [ gateDyn csRunning $ attachWith (*) (current csTimeDilation) (timePassing input),
          0.1 <$ csSyntheticStep
        ]
  return ReactiveInput {..}

freezeDyn :: (Reflex t, MonadHold t m) => Dynamic t Bool -> Dynamic t a -> m (Dynamic t a)
freezeDyn predicate dyn = do
  initial <- sample (current dyn)
  holdDyn initial (gateDyn predicate (updated 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 hoverAlpha = do
  fastForwardClick <- fastForwardButton hoverAlpha (-4, -9)
  rec speedDragged <- speedSlider hoverAlpha (-6, -9) speedFactor
      playPauseClick <- playPauseButton hoverAlpha running (-8, -9)
      speedFactor <-
        foldDyn ($) 1 $
          mergeWith
            (.)
            [ (\s -> if s == 0 then 1 else 0) <$ playPauseClick,
              (\s -> max 2.0 (s + 1)) <$ fastForwardClick,
              const <$> speedDragged
            ]
      let running = (> 0) <$> speedFactor
  rec resetViewClick <- resetViewButton hoverAlpha (9, -3) needsReset
      zoomFactor <- zoomControls hoverAlpha (9, -6) resetViewClick
      panOffset <- panControls running resetViewClick
      let needsReset =
            (||) <$> ((/= 1) <$> zoomFactor)
              <*> ((/= (0, 0)) <$> panOffset)
  stepClick <- stepButton hoverAlpha (-2, -9) running
  transformUserPicture $ uncurry translated <$> panOffset
  transformUserPicture $ dilated <$> zoomFactor
  return $ ControlState
    { csRunning = running,
      csTimeDilation = speedFactor,
      csPointTransform = transformPoint <$> zoomFactor <*> panOffset,
      csSyntheticStep = stepClick
    }
  where
    transformPoint z (dx, dy) (x, y) = ((x - dx) / z, (y - dy) / z)

getHoverAlpha :: ReflexCodeWorld t m => m (Dynamic t Double)
getHoverAlpha = do
  time <- getTimePassing
  move <- updated <$> getPointerPosition
  rec timeSinceMove <-
        foldDyn ($) 999 $
          mergeWith
            (.)
            [ (+) <$> gateDyn ((< 5) <$> timeSinceMove) time,
              const 0 <$ move
            ]
  return (alphaFromTime <$> timeSinceMove)
  where
    alphaFromTime t
      | t < 4.5 = 1
      | t > 5.0 = 0
      | otherwise = 10 - 2 * 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 hoverAlpha running pos = do
  systemDraw $
    uncurry translated pos
      <$> (bool (playButton <$> hoverAlpha) (pauseButton <$> hoverAlpha) =<< running)
  click <- ffilter (onRect 0.8 0.8 pos) <$> getPointerClick
  return $ () <$ click
  where
    playButton a =
      colored
        (RGBA 0 0 0 a)
        (solidPolygon [(-0.2, 0.25), (-0.2, -0.25), (0.2, 0)])
        <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 0.8)
    pauseButton a =
      colored
        (RGBA 0 0 0 a)
        ( translated (-0.15) 0 (solidRectangle 0.2 0.6)
            <> translated 0.15 0 (solidRectangle 0.2 0.6)
        )
        <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 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 hoverAlpha pos running = do
  systemDraw $
    uncurry translated pos
      <$> (bool (button <$> hoverAlpha) (constDyn blank) =<< running)
  click <- gateDyn (not <$> running) <$> ffilter (onRect 0.8 0.8 pos) <$> getPointerClick
  return $ () <$ click
  where
    button a =
      colored
        (RGBA 0 0 0 a)
        ( translated (-0.15) 0 (solidRectangle 0.2 0.5)
            <> solidPolygon [(0.05, 0.25), (0.05, -0.25), (0.3, 0)]
        )
        <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 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 hoverAlpha pos = do
  systemDraw $ uncurry translated pos <$> button <$> hoverAlpha
  click <- ffilter (onRect 0.8 0.8 pos) <$> getPointerClick
  return $ () <$ click
  where
    button a =
      colored
        (RGBA 0 0 0 a)
        ( solidPolygon [(-0.3, 0.25), (-0.3, -0.25), (-0.05, 0)]
            <> solidPolygon [(0.05, 0.25), (0.05, -0.25), (0.3, 0)]
        )
        <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 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 hoverAlpha pos speedFactor = do
  systemDraw $ uncurry translated pos <$> (slider <$> hoverAlpha <*> speedFactor)
  click <- ffilter (onRect 3.0 0.8 pos) <$> getPointerClick
  release <- ffilter not <$> updated <$> isPointerDown
  dragging <- holdDyn False $ mergeWith (&&) [True <$ click, False <$ release]
  pointer <- getPointerPosition
  return $ speedFromPoint <$> mergeWith const [gateDyn dragging (updated pointer), click]
  where
    speedFromPoint (x, _y) = scaleRange (-1.4, 1.4) (0, 5) (x - fst pos)
    xFromSpeed speed = scaleRange (0, 5) (-1.4, 1.4) speed
    slider a speed =
      let xoff = xFromSpeed speed
       in colored
            (RGBA 0 0 0 a)
            ( translated xoff 0.75 $ scaled 0.5 0.5 $
                lettering (T.pack (showFFloatAlt (Just 2) speed "x"))
            )
            <> colored (RGBA 0 0 0 a) (translated xoff 0 (solidRectangle 0.2 0.8))
            <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 2.8 0.25)
            <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 2.8 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 hoverAlpha pos needsReset = do
  click <- gateDyn needsReset . ffilter (onRect 0.8 0.8 pos) <$> getPointerClick
  systemDraw $ uncurry translated pos <$> (bool (constDyn blank) (button <$> hoverAlpha) =<< needsReset)
  return $ () <$ click
  where
    button a =
      colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.7 0.2)
        <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.2 0.7)
        <> colored (RGBA 0.0 0.0 0.0 a) (thickRectangle 0.1 0.5 0.5)
        <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 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 running resetClick = do
  click <- gateDyn (not <$> running) <$> getPointerClick
  release <- ffilter not <$> updated <$> isPointerDown
  dragging <- holdDyn False $ mergeWith (&&) [True <$ click, False <$ release]
  pos <- getPointerPosition
  let dragPos = bool (const Nothing) Just <$> dragging <*> pos
  diffPairs <- foldDyn (\x (y, _) -> (x, y)) (Nothing, Nothing) (updated dragPos)
  let drags = fmapMaybe toMovement (updated diffPairs)
  foldDyn ($) (0, 0) $
    mergeWith
      (.)
      [ vectorSum <$> drags,
        const (0, 0) <$ resetClick
      ]
  where
    toMovement (Just (x1, y1), Just (x2, y2)) = Just (x1 - x2, y1 - y2)
    toMovement _ = 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 hoverAlpha (x, y) resetClick = do
  zoomInClick <- zoomInButton hoverAlpha (x, y + 2)
  zoomOutClick <- zoomOutButton hoverAlpha (x, y - 2)
  rec zoomDrag <- zoomSlider hoverAlpha (x, y) zoomFactor
      zoomFactor <-
        foldDyn ($) 1 $
          mergeWith
            (.)
            [ (* zoomIncrement) <$ zoomInClick,
              (/ zoomIncrement) <$ zoomOutClick,
              const <$> zoomDrag,
              const 1 <$ resetClick
            ]
  return 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 hoverAlpha pos = do
  systemDraw $ uncurry translated pos <$> button <$> hoverAlpha
  (() <$) <$> ffilter (onRect 0.8 0.8 pos) <$> getPointerClick
  where
    button a =
      colored
        (RGBA 0 0 0 a)
        ( translated
            (-0.05)
            (0.05)
            ( thickCircle 0.1 0.22
                <> solidRectangle 0.06 0.25
                <> solidRectangle 0.25 0.06
                <> rotated (- pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1))
            )
        )
        <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 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 hoverAlpha pos = do
  systemDraw $ uncurry translated pos <$> button <$> hoverAlpha
  (() <$) <$> ffilter (onRect 0.8 0.8 pos) <$> getPointerClick
  where
    button a =
      colored
        (RGBA 0 0 0 a)
        ( translated
            (-0.05)
            (0.05)
            ( thickCircle 0.1 0.22
                <> solidRectangle 0.25 0.06
                <> rotated (- pi / 4) (translated 0.35 0 (solidRectangle 0.2 0.1))
            )
        )
        <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.8 0.8)
        <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.8 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 hoverAlpha pos factor = do
  systemDraw $ uncurry translated pos <$> (slider <$> hoverAlpha <*> factor)
  click <- ffilter (onRect 0.8 3.0 pos) <$> getPointerClick
  release <- ffilter not <$> updated <$> isPointerDown
  dragging <- holdDyn False $ mergeWith (&&) [True <$ click, False <$ release]
  pointer <- getPointerPosition
  return $ zoomFromPoint <$> mergeWith const [gateDyn dragging (updated pointer), click]
  where
    zoomFromPoint (_x, y) = zoomIncrement ** (scaleRange (-1.4, 1.4) (-10, 10) (y - snd pos))
    yFromZoom z = scaleRange (-10, 10) (-1.4, 1.4) (logBase zoomIncrement z)
    slider a z =
      let yoff = yFromZoom z
       in colored
            (RGBA 0 0 0 a)
            ( translated (-1.1) yoff $ scaled 0.5 0.5 $
                lettering (T.pack (show (round (z * 100) :: Int) ++ "%"))
            )
            <> colored (RGBA 0 0 0 a) (translated 0 yoff (solidRectangle 0.8 0.2))
            <> colored (RGBA 0.2 0.2 0.2 a) (rectangle 0.25 2.8)
            <> colored (RGBA 0.8 0.8 0.8 a) (solidRectangle 0.25 2.8)

zoomIncrement :: Double
zoomIncrement = 8 ** (1 / 10)

onRect :: Double -> Double -> Point -> Point -> Bool
onRect w h (x1, y1) (x2, y2) = abs (x1 - x2) < w / 2 && abs (y1 - y2) < h / 2

scaleRange :: (Double, Double) -> (Double, Double) -> Double -> Double
scaleRange (a1, b1) (a2, b2) x = min b2 $ max a2 $ (x - a1) / (b1 - a1) * (b2 - a2) + a2