{-# LANGUAGE PartialTypeSignatures #-}

module Lib
    ( someFunc
    ) where

import qualified Graphics.UI.Threepenny as UI
import Graphics.UI.Threepenny.Core
import Safe

someFunc :: IO ()
someFunc = startGUI defaultConfig setup

class PrintType a where
    printType :: a -> b

black = "#000000"
blue = "#66CCFF"

circle :: String -> UI.Point -> Double -> UI.Canvas -> UI ()
circle color p r c = do
  c # set' UI.fillStyle (UI.htmlColor color)
  c # UI.beginPath
  c # UI.arc p r (-pi) pi
  c # UI.closePath
  c # UI.fill

wrapper :: Int -> Int -> UI Element
wrapper width height =
  UI.canvas
    # set UI.height height
    # set UI.width width
    # set style [("border", "solid black 1px")]

data MouseState = MouseUp | MouseDown deriving Eq

newtype Reversed a = Reversed [a]

mouseState :: MonadIO m => Element -> m (Behavior MouseState)
mouseState e = MouseUp `stepper` unionWith undefined (MouseDown <$ UI.mousedown e) (MouseUp <$ UI.mouseup e)

currentStroke :: MonadIO m => Element -> m (Behavior (Reversed (Int, Int)))
currentStroke e = do
  mouseIsDown <- (fmap . fmap) (const . (== MouseDown)) $ mouseState e
  mouseDownMove <- return $ fmap (\x (Reversed xs) -> Reversed (x:xs)) $ filterApply mouseIsDown $ UI.mousemove e
  mouseUpClear <- return $ fmap (const $ const $ Reversed []) $ UI.mouseup e
  accumB (Reversed []) (unionWith undefined mouseDownMove mouseUpClear)

mouseStroke :: MonadIO m => Element -> m (Event (Reversed (Int, Int)))
mouseStroke e = do
  l <- currentStroke e
  return $ l <@ UI.mouseup e

smooth :: Double -> [UI.Point] -> [UI.Point]
smooth smoothFact x = scanl1 (\(xl, xr) (yl, yr) -> (smoothFact * xl + (1 - smoothFact) * yl, smoothFact * xr + (1 - smoothFact) * yr)) x

setup :: Window -> UI ()
setup w = do
  return w # set UI.title "Ordinary"
  wrap <- wrapper 1024 640
  smoothFactIn <- UI.input
  getBody w #+ [row [element wrap, column [string "smooth by", element smoothFactIn]]]
  smoothFact <- stepper 0.5 $ filterJust $ fmap (readMay :: _ -> Maybe Double) $ UI.valueChange smoothFactIn
  stroke <- mouseStroke wrap
  unEvent <- onEvent stroke $
    \(Reversed x) -> do
      return w # set UI.title (show (reverse x))
      points <- return $ map (\(l, r) -> (fromIntegral l, fromIntegral r)) (reverse x)
      mapM (\p -> circle blue p 5 wrap) points
      smoothFactCur <- currentValue smoothFact
      mapM (\p -> circle black p 5 wrap) (smooth smoothFactCur points)
  return ()