{-# LANGUAGE OverloadedStrings, FlexibleInstances, FlexibleContexts,
             StandaloneDeriving, DeriveFunctor, DeriveFoldable,
             DeriveTraversable #-}
-----------------------------------------------------------------------------
-- |
-- Module      : Hasmin.Types.BasicShape
-- Copyright   : (c) 2017 Cristian Adrián Ontivero
-- License     : BSD3
-- Stability   : experimental
-- Portability : unknown
--
-----------------------------------------------------------------------------
module Hasmin.Types.BasicShape
    ( BasicShape(..)
    , ShapeRadius(..)
    , AtMost2(..)
    , FillRule(..)
    ) where

import Control.Monad.Reader (Reader)
import Data.Monoid ((<>), mempty)
import Data.Bitraversable (bitraverse)
import Data.Maybe (isJust)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NE
import Data.Text.Lazy.Builder (Builder)

import Hasmin.Types.Position
import Hasmin.Types.BorderRadius
import Hasmin.Types.Dimension
import Hasmin.Types.PercentageLength
import Hasmin.Types.Numeric
import Hasmin.Config
import Hasmin.Class
import Hasmin.Utils

type ShapeArg = PercentageLength

-- | CSS <https://drafts.csswg.org/css-shapes/#basic-shape-functions \<basic-shape\>> data type.
data BasicShape
       -- inset( <shape-arg>{1,4} [round <border-radius>]? )
        = Inset (NonEmpty ShapeArg) (Maybe BorderRadius)
       -- circle( [<shape-radius>]? [at <position>]? )
        | Circle (Maybe ShapeRadius) (Maybe Position)
       -- ellipse( [<shape-radius>{2}]? [at <position>]? )
        | Ellipse (AtMost2 ShapeRadius) (Maybe Position)
       -- polygon( [<fill-rule>,]? [<shape-arg> <shape-arg>]# )
        | Polygon (Maybe FillRule) (NonEmpty (ShapeArg, ShapeArg))
  deriving Show

instance Eq BasicShape where
    Inset sas1 mbr1 == Inset sas2 mbr2     = eqUsing sasEq sas1 sas2 && mbrEq mbr1 mbr2
    Circle msr1 mp1 == Circle msr2 mp2     = msrEq msr1 msr2 && mpEq mp1 mp2
    Ellipse sr2 mp1 == Ellipse sr2' mp2    = sr2Eq sr2 sr2' && mpEq mp1 mp2
    Polygon mfr1 sas1 == Polygon mfr2 sas2 = mfrEq mfr1 mfr2 && eqUsing pairEq sas1 sas2
    _ == _                                 = False

eqUsing :: (a -> a -> Bool) -> NonEmpty a -> NonEmpty a -> Bool
eqUsing f (x:|xs) (y:|ys) = f x y && go xs ys
  where go [] []    = True
        go (_:_) [] = False
        go [] (_:_) = False
        go (c:cs) (d:ds) = f c d && go cs ds

pairEq :: (Num a, Eq a) => (Either a Length, Either a Length)
                        -> (Either a Length, Either a Length) -> Bool
pairEq (a1, a2) (b1, b2) = a1 `sasEq` b1 && a2 `sasEq` b2

sasEq :: (Num a, Eq a) => Either a Length -> Either a Length -> Bool
sasEq a b = isZero a && isZero b || a == b

mfrEq :: Maybe FillRule -> Maybe FillRule -> Bool
mfrEq Nothing (Just NonZero) = True
mfrEq (Just NonZero) Nothing = True
mfrEq x y                    = x == y

sr2Eq :: AtMost2 ShapeRadius -> AtMost2 ShapeRadius -> Bool
sr2Eq None x =
    case x of
      One SRClosestSide               -> True
      Two SRClosestSide SRClosestSide -> True
      None                            -> True
      _                               -> False
sr2Eq (One SRClosestSide) None               = True
sr2Eq (One x) (Two y SRClosestSide)          = x == y
sr2Eq (One x) (One y)                        = x == y
sr2Eq One{} _                                = False
sr2Eq (Two x SRClosestSide) (One y)          = x == y
sr2Eq (Two SRClosestSide SRClosestSide) None = True
sr2Eq (Two a b) (Two c d)                    = a == c && b == d
sr2Eq Two{} _                                = False

msrEq :: Maybe ShapeRadius -> Maybe ShapeRadius -> Bool
msrEq Nothing (Just SRClosestSide) = True
msrEq (Just SRClosestSide) Nothing = True
msrEq x y                          = x == y

mbrEq :: Maybe BorderRadius -> Maybe BorderRadius -> Bool
mbrEq Nothing y = maybe True isZeroBR y
mbrEq x Nothing = mbrEq Nothing x
mbrEq x y       = x == y

mpEq :: Maybe Position -> Maybe Position -> Bool
mpEq Nothing (Just x) = x == centerpos
mpEq (Just x) Nothing = x == centerpos
mpEq x y              = x == y

data ShapeRadius = SRLength Length
                 | SRPercentage Percentage
                 | SRClosestSide
                 | SRFarthestSide
  deriving (Show, Eq)

instance ToText ShapeRadius where
  toBuilder (SRLength l)     = toBuilder l
  toBuilder (SRPercentage p) = toBuilder p
  toBuilder SRClosestSide    = "closest-side"
  toBuilder SRFarthestSide   = "farthest-side"

minifySR :: ShapeRadius -> Reader Config ShapeRadius
minifySR (SRLength l) = SRLength <$> minify l
minifySR sr           = pure sr

data FillRule = NonZero | EvenOdd
  deriving (Show, Eq)

data AtMost2 a = None | One a | Two a a
  deriving (Functor, Foldable, Traversable)

deriving instance Show a => Show (AtMost2 a)
deriving instance Eq a => Eq (AtMost2 a)

instance ToText FillRule where
  toBuilder NonZero = "nonzero"
  toBuilder EvenOdd = "evenodd"

instance Minifiable BasicShape where
  minify (Inset xs Nothing) = pure $ Inset (reduceTRBL xs) Nothing
  minify (Inset xs (Just br)) = Inset (reduceTRBL xs) <$> br'
    where br' = do
              x <- minify br
              pure $ if isZeroBR x
                        then Nothing
                        else Just x
  minify (Circle msr mp) = do
      mp' <- traverse minify mp
      let newPos = if mp' == Just centerpos then Nothing else mp'
      Circle <$> minifyMSR msr <*> pure newPos
    where minifyMSR :: Maybe ShapeRadius -> Reader Config (Maybe ShapeRadius)
          minifyMSR Nothing   = pure Nothing
          minifyMSR (Just sr) =
              case sr of
                SRLength l    -> (Just . SRLength) <$> minify l
                SRClosestSide -> pure Nothing
                _             -> pure (Just sr)
  minify (Ellipse sr2 mp) = do
      sr' <- minifySR2 sr2
      mp' <- traverse minify mp
      let newPos = if mp' == Just centerpos
                      then Nothing
                      else mp'
      pure $ Ellipse sr' newPos
    where minifySR2 (One x) =
              case x of
                SRClosestSide -> pure None
                SRLength l    -> (One . SRLength) <$> minify l
                _             -> pure (One x)
          minifySR2 (Two x SRClosestSide) = minifySR2 (One x)
          minifySR2 t@Two{}               = traverse minifySR t
          minifySR2 None                  = pure None
  minify (Polygon mfr mp) =
      case mfr of
        Just NonZero -> Polygon Nothing <$> mp'
        _            -> Polygon mfr <$> mp'
    where mp' = traverse (bitraverse minifyPL minifyPL) mp

instance ToText BasicShape where
  toBuilder (Inset xs mys) = surround "inset" $ mconcatIntersperse toBuilder " " (NE.toList xs) <> mys'
    where mys' = maybe mempty (\x -> " round " <> toBuilder x) mys
  toBuilder (Circle msr mp) = surround "circle" $ msr' <> ms <> mp'
    where msr' = maybe mempty toBuilder msr
          mp'  = maybe mempty (\x -> "at " <> toBuilder x) mp
          ms   = if isJust msr && isJust mp then " " else mempty
  toBuilder (Ellipse m2sr mp) = surround "ellipse" $ bsr2 <> ms <> mp'
    where ms   = if bsr2 == mempty || mp' == mempty then mempty else " "
          mp'  = maybe mempty (\x -> "at " <> toBuilder x) mp
          bsr2 =
              case m2sr of
                One rx    -> toBuilder rx
                Two rx ry -> toBuilder rx <> " " <> toBuilder ry
                None      -> mempty
  toBuilder (Polygon mfr xys) = surround "polygon" $ f mfr xys
    where f Nothing xys'   = mconcatIntersperse g "," (NE.toList xys')
          f (Just fr) xys' = toBuilder fr <> "," <> mconcatIntersperse g "," (NE.toList xys')
          g (x, y) = toBuilder x <> " " <> toBuilder y

surround :: Builder -> Builder -> Builder
surround func x = func <> "(" <> x <> ")"