Parameter.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}

{-
  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 CodeWorld.Parameter
  {-# WARNING "This is an experimental API.  It can change at any time." #-}
  ( Parameter,
    parametricDrawingOf,
    slider,
    toggle,
    counter,
    constant,
    random,
    timer,
    currentHour,
    currentMinute,
    currentSecond,
    converted,
    renamed,
  )
where

import CodeWorld
import CodeWorld.Driver (runInspect)
import Data.Function (on)
import Data.List (sortBy)
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.LocalTime
import Numeric (showFFloatAlt)
import System.IO.Unsafe (unsafePerformIO)
import System.Random (newStdGen, randomR)

-- | Bounds information for a parameter UI.  The fields are the
-- left and top coordinate, then the width and height.
type Bounds = (Double, Double, Double, Double)

-- | The source for a parameter that can be adjusted in a parametric
-- drawing.  Parameters can get their values from sliders, buttons,
-- counters, timers, etc.
data Parameter where
  Parameter ::
    Text ->
    Double ->
    Picture ->
    Bounds ->
    (Event -> Parameter) ->
    Parameter

-- | A drawing that depends on parameters.  The first argument is a
-- list of parameters.  The second is a picture, which depends on the
-- values of those parameters.  Each number used to retrieve the picture
-- is the value of the corresponding parameter in the first list.
parametricDrawingOf :: [Parameter] -> ([Double] -> Picture) -> IO ()
parametricDrawingOf initialParams mainPic =
  runInspect
    (zip [0 :: Int ..] (layoutParams 0 (-9.5) 9.5 initialParams), True, 5)
    (const id)
    change
    picture
    rawPicture
  where
    change (KeyPress " ") (params, vis, _) = (params, not vis, 2)
    change (PointerPress pt) (params, vis, t) =
      case (vis, pullMatch (hitTest pt . snd) params) of
        (True, (Just p, ps)) -> (fmap (changeParam (PointerPress pt)) p : ps, vis, t)
        _ -> (params, vis, t)
    change event (params, vis, t) =
      (map (fmap (changeParam event)) params, vis, changeTime event t)
    picture (params, vis, t) =
      showHideBanner t
        & (picWhen vis $ pictures (map (showParam . snd) params))
        & rawPicture (params, vis, t)
    rawPicture (params, _, _) =
      mainPic (map (getParam . snd) (sortBy (compare `on` fst) params))
    changeParam event (Parameter _ _ _ _ handle) = handle event
    showParam (Parameter _ _ pic _ _) = pic
    getParam (Parameter _ val _ _ _) = val
    changeTime (TimePassing dt) t = max 0 (t - dt)
    changeTime _ t = t
    showHideBanner t =
      picWhen (t > 0)
        $ translated 0 (-9)
        $ dilated 0.5
        $ colored (RGBA 0 0 0 t) (rectangle 18 2)
          & colored
            (RGBA 0 0 0 t)
            (lettering "Press Space to show/hide parameters.")
          & colored (RGBA 0.75 0.75 0.75 (min 0.8 t)) (solidRectangle 18 2)

-- | Wraps a list of parameters in frames to lay them out on the screen.
layoutParams :: Double -> Double -> Double -> [Parameter] -> [Parameter]
layoutParams _ _ _ [] = []
layoutParams maxw x y (p : ps)
  | y > (-9.5) + h + titleHeight =
    framedParam (x - left) (y - top - titleHeight) p
      : layoutParams (max maxw w) x (y - h - titleHeight - gap) ps
  | otherwise = layoutParams 0 (x + maxw + gap) 9.5 (p : ps)
  where
    Parameter _ _ _ (left, top, w, h) _ = p
    gap = 0.5

-- | Finds the first element of a list that matches the predicate, if any,
-- and removes it from the list, returning it separately from the remaining
-- elements.
pullMatch :: (a -> Bool) -> [a] -> (Maybe a, [a])
pullMatch _ [] = (Nothing, [])
pullMatch p (a : as)
  | p a = (Just a, as)
  | otherwise = fmap (a :) (pullMatch p as)

-- | Determines if a point is inside the screen area for a given parameter.
hitTest :: Point -> Parameter -> Bool
hitTest (x, y) (Parameter _ _ _ (left, top, w, h) _) =
  x > left && x < left + w && y < top && y > top - h

-- | Builds a parameter from an explicit state.
parameterOf ::
  Text ->
  state ->
  (Event -> state -> state) ->
  (state -> Double) ->
  (state -> Picture) ->
  (state -> Bounds) ->
  Parameter
parameterOf name initial change value picture bounds =
  Parameter
    name
    (value initial)
    (picture initial)
    (bounds initial)
    (\e -> parameterOf name (change e initial) change value picture bounds)

-- Puts a simple parameter in a draggable widget that let the user
-- manipulate it on the screen, and displays the name and value.
-- All parameters are enclosed in one of these automatically.
framedParam :: Double -> Double -> Parameter -> Parameter
framedParam ix iy iparam =
  parameterOf
    name
    (iparam, (ix, iy), True, Nothing)
    framedHandle
    (\(Parameter _ v _ _ _, _, _, _) -> v)
    framedPicture
    framedBounds
  where
    (Parameter name _ _ _ _) = iparam

-- | The state of a framedParam, which includes the original parameter,
-- its location, whether it's open (expanded) or not, and the anchor if
-- it is currently being dragged.
type FrameState = (Parameter, Point, Bool, Maybe Point)

framedHandle :: Event -> FrameState -> FrameState
framedHandle (PointerPress (px, py)) (param, (x, y), open, anchor)
  | onOpenButton = (param, (x, y), not open, anchor)
  | onTitleBar = (param, (x, y), open, Just (px, py))
  where
    Parameter _ _ _ (left, top, w, h) _ = param
    onTitleBar =
      abs (px - x - (left + w / 2)) < w / 2
        && abs (py - y - top - titleHeight / 2) < titleHeight / 2
    onOpenButton
      | w * h > 0 =
        abs (px - x - (left + w - titleHeight / 2)) < 0.2
          && abs (py - y - (top + titleHeight / 2)) < 0.2
      | otherwise = False
framedHandle (PointerRelease _) (param, loc, open, Just _) =
  (param, loc, open, Nothing)
framedHandle (PointerMovement (px, py)) (param, (x, y), open, Just (ax, ay)) =
  (param, (x + px - ax, y + py - ay), open, Just (px, py))
framedHandle (TimePassing dt) (Parameter _ _ _ _ handle, loc, open, anchor) =
  (handle (TimePassing dt), loc, open, anchor)
framedHandle event (Parameter _ _ _ _ handle, (x, y), True, anchor) =
  (handle (untranslated x y event), (x, y), True, anchor)
framedHandle _ other = other

framedPicture :: FrameState -> Picture
framedPicture (Parameter n v pic (left, top, w, h) _, (x, y), open, _) =
  translated x y $
    translated (left + w / 2) (top + titleHeight / 2) titleBar
      & translated (left + w / 2) (top - h / 2) clientArea
  where
    titleBar
      | w * h > 0 =
        rectangle w titleHeight
          & translated
            ((w - titleHeight) / 2)
            0
            (if open then collapseButton else expandButton)
          & translated
            (- titleHeight / 2)
            0
            ( clipped
                (w - titleHeight)
                titleHeight
                (dilated 0.5 (lettering titleText))
            )
          & colored titleColor (solidRectangle w titleHeight)
      | otherwise =
        rectangle w titleHeight
          & clipped w titleHeight (dilated 0.5 (lettering titleText))
          & colored titleColor (solidRectangle w titleHeight)
    titleText
      | T.length n > 10 = T.take 8 n <> "... = " <> formattedVal
      | otherwise = n <> " = " <> formattedVal
    formattedVal = pack (showFFloatAlt (Just 2) v "")
    collapseButton = rectangle 0.4 0.4 & solidPolygon [(-0.1, -0.1), (0.1, -0.1), (0, 0.1)]
    expandButton = rectangle 0.4 0.4 & solidPolygon [(-0.1, 0.1), (0.1, 0.1), (0, -0.1)]
    clientArea =
      picWhen (w * h > 0) $
        rectangle w h
          & clipped w h pic
          & colored bgColor (solidRectangle 5 1)

framedBounds :: FrameState -> Bounds
framedBounds (Parameter _ _ _ (left, top, w, h) _, (x, y), True, _) =
  (x + left, y + top + titleHeight, w, h + titleHeight)
framedBounds (Parameter _ _ _ (left, top, w, _) _, (x, y), False, _) =
  (x + left, y + top + titleHeight, w, titleHeight)

titleHeight :: Double
titleHeight = 0.7

untranslated :: Double -> Double -> Event -> Event
untranslated x y (PointerPress (px, py)) = PointerPress (px - x, py - y)
untranslated x y (PointerRelease (px, py)) = PointerRelease (px - x, py - y)
untranslated x y (PointerMovement (px, py)) = PointerMovement (px - x, py - y)
untranslated _ _ other = other

-- | Adjusts the output of a parameter by passing it through a conversion
-- function.  Built-in parameters usually range from 0 to 1, and conversions
-- can be used to rescale the output to a different range.
converted :: (Double -> Double) -> Parameter -> Parameter
converted c (Parameter name val pic bounds handle) =
  Parameter name (c val) pic bounds (converted c . handle)

-- | Changes the name of an existing parameter.
renamed :: Text -> Parameter -> Parameter
renamed name (Parameter _ val pic bounds handle) =
  Parameter name val pic bounds (renamed name . handle)

-- | A 'Parameter' with a constant value, and no way to change it.
constant :: Text -> Double -> Parameter
constant name n =
  parameterOf
    name
    n
    (const id)
    id
    (const blank)
    (const (-2.5, 0, 5, 0))

-- | Builder for 'Parameter' types that are clickable and 5x1 in size.
buttonOf ::
  Text ->
  state ->
  (state -> state) ->
  (state -> Double) ->
  (state -> Picture) ->
  Parameter
buttonOf name initial click value pic =
  parameterOf
    name
    (initial, False)
    change
    (value . fst)
    ( \(state, press) ->
        pic state
          & picWhen press (colored (RGBA 0 0 0 0.3) (solidRectangle 5 1))
    )
    (const (-2.5, 0.5, 5, 1))
  where
    change (PointerPress (px, py)) (state, _)
      | abs px < 2.5, abs py < 0.5 = (state, True)
    change (PointerRelease (px, py)) (state, True)
      | abs px < 2.5, abs py < 0.5 = (click state, False)
      | otherwise = (state, False)
    change _ (state, press) = (state, press)

-- | A 'Parameter' that can be toggled between 0 (off) and 1 (on).
toggle :: Text -> Parameter
toggle name = buttonOf name False not value picture
  where
    value True = 1
    value False = 0
    picture True = dilated 0.5 $ lettering "\x2611"
    picture False = dilated 0.5 $ lettering "\x2610"

-- | A 'Parameter' that counts how many times it has been clicked.
counter :: Text -> Parameter
counter name = buttonOf name 0 (+ 1) id picture
  where
    picture _ = dilated 0.5 (lettering "Next")

-- | A 'Parameter' that can be adjusted continuously between 0 and 1.
slider :: Text -> Parameter
slider name =
  parameterOf
    name
    (0.5, False)
    change
    fst
    picture
    (const (-2.5, 0.5, 5, 1))
  where
    change (PointerPress (px, py)) (_, _)
      | abs px < 2, abs py < 0.25 = (min 1 $ max 0 $ (px + 2) / 4, True)
    change (PointerRelease _) (v, _) = (v, False)
    change (PointerMovement (px, _)) (_, True) =
      (min 1 $ max 0 $ (px + 2) / 4, True)
    change _ state = state
    picture (v, _) =
      translated (v * 4 - 2) 0 (solidRectangle 0.125 0.5)
        & solidRectangle 4 0.1

-- | A 'Parameter' that has a randomly chosen value.  It offers a button to
-- regenerate its value.
random :: Text -> Parameter
random name = buttonOf name initial (next . snd) fst picture
  where
    initial = next (unsafePerformIO newStdGen)
    picture _ = dilated 0.5 $ lettering "\x21ba Regenerate"
    next = randomR (0.0, 1.0)

-- | A 'Parameter' that changes over time. It can be paused or reset.
timer :: Text -> Parameter
timer name =
  parameterOf
    name
    (0, 1)
    change
    fst
    picture
    (const (-2.5, 0.5, 5, 1))
  where
    change (TimePassing dt) (t, r) = (t + r * dt, r)
    change (PointerPress (px, py)) (t, r)
      | abs (px - 5 / 6) < 5 / 6, abs py < 0.75 = (t, 1 - r)
      | abs (px + 5 / 6) < 5 / 6, abs py < 0.75 = (0, 0)
    change _ state = state
    picture (_, 0) =
      (translated (5 / 6) 0 $ dilated 0.5 $ lettering "\x23e9")
        & (translated (-5 / 6) 0 $ dilated 0.5 $ lettering "\x23ee")
    picture _ =
      (translated (5 / 6) 0 $ dilated 0.5 $ lettering "\x23f8")
        & (translated (-5 / 6) 0 $ dilated 0.5 $ lettering "\x23ee")

-- | A 'Parameter' that tracks the current hour, in local time.  The hour
-- is on a scale from 0 (meaning midnight) to 23 (meaning 11:00 pm).
currentHour :: Parameter
currentHour =
  parameterOf
    "hour"
    ()
    (const id)
    (\_ -> unsafePerformIO $ fromIntegral <$> todHour <$> getTimeOfDay)
    (const blank)
    (const (-2.5, 0, 5, 0))

-- | A 'Parameter' that tracks the current minute, in local time.  It
-- ranges from 0 to 59.
currentMinute :: Parameter
currentMinute =
  parameterOf
    "minute"
    ()
    (const id)
    (\_ -> unsafePerformIO $ fromIntegral <$> todMin <$> getTimeOfDay)
    (const blank)
    (const (-2.5, 0, 5, 0))

-- | A 'Parameter' that tracks the current second, in local time.  It
-- ranges from 0.0 up to (but not including) 60.0.  This includes
-- fractions of a second.  If that's not what you want, you can use
-- 'withConversion' to truncate the number.
currentSecond :: Parameter
currentSecond =
  parameterOf
    "second"
    ()
    (const id)
    (\_ -> unsafePerformIO $ realToFrac <$> todSec <$> getTimeOfDay)
    (const blank)
    (const (-2.5, 0, 5, 0))

getTimeOfDay :: IO TimeOfDay
getTimeOfDay = do
  now <- getCurrentTime
  timezone <- getCurrentTimeZone
  return (localTimeOfDay (utcToLocalTime timezone now))

titleColor :: Color
titleColor = RGBA 0.7 0.7 0.7 0.9

bgColor :: Color
bgColor = RGBA 0.8 0.85 0.95 0.8

picWhen :: Bool -> Picture -> Picture
picWhen True = id
picWhen False = const blank