{-# LANGUAGE OverloadedStrings, RankNTypes #-}
import Reflex
import Reflex.Dom
import Data.Text (Text, pack, unpack)
import Data.Map (Map, fromList, empty)
import Text.Read (readMaybe)

width = 600
height = 500

type Point = (Float,Float)
type Segment = (Point,Point)

data Ellipse = Ellipse {a :: Float, b :: Float, n :: Float}

toFloat :: Text -> Maybe Float
toFloat  = readMaybe.unpack

toEllipse :: Maybe Float -> Maybe Float -> Maybe Float -> Maybe Ellipse
toEllipse (Just a) (Just b) (Just n) =
    if a < 1.0 || b <= 1.0 || n <= 0.0  -- not all floats are valid
    then Nothing
    else Just $ Ellipse a b n

toEllipse _ _ _ = Nothing

showError :: Maybe a -> String
showError Nothing = "invalid input"
showError _ = ""

reflect45 pts  =  pts ++ fmap (\(x,y) -> ( y,  x)) (reverse pts)
rotate90  pts  =  pts ++ fmap (\(x,y) -> ( y, -x)) pts
rotate180 pts  =  pts ++ fmap (\(x,y) -> (-x, -y)) pts
scale a b      =  fmap (\(x,y) -> ( a*x, b*y ))
segments  pts  =  zip pts $ tail pts

toLineMap :: Maybe Ellipse -> Map Int ((Float,Float),(Float,Float))
toLineMap (Just (Ellipse a b n)) =
    let f p = (1 - p**n)**(1/n)
        dp = iterate (*0.9) 1.0
        ip = map (\p -> 1.0 -p) dp
        points s =
            if n > 1.0
            then (\p -> zip p (map f p)) ip
            else (\p -> zip (map f p) p) dp

    in fromList $  -- changes list to map (for listWithKey)
       zip [0..] $ -- annotates segments with index
       segments $  -- changes points to line segments
       scale a b $
       rotate180 $ -- doubles the point count
       rotate90 $  -- doubles the point count
       reflect45 $ -- doubles the point count
       takeWhile (\(x,y) -> x < y ) $ -- stop at 45 degree line
       points 0.9

toLineMap Nothing = empty

lineAttrs :: Segment -> Map Text Text
lineAttrs ((x1,y1), (x2,y2)) =
    fromList [ ( "x1",    pack $ show (width/2+x1))
             , ( "y1",    pack $ show (height/2+y1))
             , ( "x2",    pack $ show (width/2+x2))
             , ( "y2",    pack $ show (height/2+y2))
             , ( "style", "stroke:brown;stroke-width:2")
             ]

showLine :: MonadWidget t m => Int -> Dynamic t Segment -> m ()
showLine _ dSegment = do
    elSvgns "line" (lineAttrs <$> dSegment) $ return ()
    return ()

main = mainWidget $ do
    elAttr "h1" ("style" =: "color:brown") $ text "Superellipse"
    ta <- el "div" $ do
        text "a: "
        textInput def { _textInputConfig_initialValue = "200"}

    tb <- el "div" $ do
        text "b: "
        textInput def { _textInputConfig_initialValue = "200"}

    tn <- el "div" $ do
        text "n: "
        textInput def { _textInputConfig_initialValue = "2.5"}
    let
        ab = zipDynWith toEllipse (toFloat <$> value ta) (toFloat <$> value tb)
        dEllipse = zipDynWith ($) ab (toFloat <$> value tn)
        dLines = fmap toLineMap dEllipse

        dAttrs = constDyn $ fromList
                     [ ("width" , pack $ show width)
                     , ("height", pack $ show height)
                     ]
    elAttr "div" ("style" =: "color:red") $ dynText $ fmap (pack.showError) dEllipse
    el "div" $ elSvgns "svg" dAttrs $ listWithKey dLines showLine
    return ()

-- At end to avoid Rosetta Code unmatched quotes problem.
elSvgns :: forall t m a. MonadWidget t m => Text -> Dynamic t (Map Text Text) -> m a -> m (El t, a)
elSvgns = elDynAttrNS' (Just "http://www.w3.org/2000/svg")