{-# LANGUAGE PartialTypeSignatures, OverloadedStrings #-}

module Lib
    ( someFunc
    ) where

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

someFunc :: IO ()
someFunc = startGUI defaultConfig { jsAddr = Just "0.0.0.0" } 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
  let mouseDownMove = fmap (\x (Reversed xs) -> Reversed (x:xs)) $ filterApply mouseIsDown $ UI.mousemove e
  let mouseUpClear = 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

thin :: Double -> [UI.Point] -> [UI.Point]
thin dist [] = []
thin dist (x@(lx, ly):xs) = x : thin dist (dropWhile (\(rx, ry) -> (lx - rx) ** 2 + (ly - ry) ** 2 < dist ** 2) xs)

data Curvature = CUp | CDown | CLeft | CRight deriving (Eq, Ord, Show)

mapBetween :: (a -> a -> b) -> [a] -> [b]
mapBetween f x | length x < 2 = []
mapBetween f x = zipWith f x (tail x)

mapBetween4 :: (a -> a -> a -> a -> b) -> [a] -> [b]
mapBetween4 f x | length x < 4 = []
mapBetween4 f x = zipWith4 f x tx ttx tttx
  where
    tx = tail x
    ttx = tail tx
    tttx = tail ttx

direction :: UI.Point -> UI.Point -> Curvature
direction (lx, ly) (rx, ry) =
  if abs (lx - rx) < abs (ly - ry)
  then if ly < ry then CDown else CUp
  else if lx < rx then CRight else CLeft

directions :: [UI.Point] -> [Curvature]
directions = map head . group . mapBetween direction

toPoint :: (Int, Int) -> UI.Point
toPoint (x, y) = (fromIntegral x, fromIntegral y)

withAngles :: [UI.Point] -> [(UI.Point, Double)]
withAngles = mapBetween (\(lx, ly) (rx, ry) -> ((rx, ry), atan2 (ly - ry) (rx - lx)))

corners :: Double -> Double -> [UI.Point] -> [UI.Point]
corners sameLimit changeLimit =
  map fst . filter snd .
  mapBetween4 (\(_, a0) (_, a1) (p, a2) (_, a3) -> (p, abs (a0 - a1) < sameLimit && abs (a2 - a3) < sameLimit && abs (a1 - a2) > changeLimit)) .
  withAngles

data Grid = Grid { gridLeftTop :: UI.Point, gridRightDown :: UI.Point }

makeGrid :: [UI.Point] -> Maybe Grid
makeGrid [] = Nothing
makeGrid l = Just $ Grid (left, top) (right, down)
  where
    xs = map fst l
    ys = map snd l
    left = minimum xs
    right = maximum xs
    top = minimum ys
    down = maximum ys

locateInRange :: Double -> Double -> Int -> Double -> Maybe Int
locateInRange down up numBracket val = if down <= val && val <= up then Just (min (floor ((val - down) / (up - down) * (fromIntegral numBracket))) numBracket) else Nothing
 
locateInGrid :: Grid -> Int -> Int -> UI.Point -> Maybe (Int, Int)
locateInGrid (Grid (left, top) (right, down)) numCol numRow (x, y) = do
  x' <- locateInRange left right numCol x
  y' <- locateInRange top down numRow y
  return (x', y')

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 :: String -> Maybe Double) $ UI.valueChange smoothFactIn
  stroke <- mouseStroke wrap
  unEvent <- onEvent stroke $
    \(Reversed x) -> do
      let points = map toPoint $ reverse x
      mapM (\p -> circle blue p 5 wrap) points
      smoothFactCur <- currentValue smoothFact
      let processedPoints = thin 20 $ smooth smoothFactCur points
      mapM (\p -> circle black p 5 wrap) $ processedPoints
      mapM (\p -> circle black p 20 wrap) $ corners (pi/6) (pi/3) processedPoints
  return ()