import Graphics.Svg
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Maybe
import System.Environment
import Data.String (IsString (..))

main :: IO ()
main = do
  [out] <- getArgs
  renderToFile out document


document :: Element
document =
  svg11_ (stylesheet "palette.css" <> foldMap makeItem (zip [0..] items))
    `with` [Width_ <<- width, Height_ <<- "179",
            ViewBox_ <<- viewBox]
  where
    width = tshow $ 53 + 100 * length items
    viewBox = "-53 -1 " <> width <> " 179"


items :: [Swatch]
items =
  ["outer"                `WithMinor` "vitiligo1",
   "spines"               `WithUse`   "vitiligo1",
   "stripes" `As` "socks" `WithMinor` "cuffs",
   "belly1"               `WithMinor` "vitiligo3",
   "belly2"               `WithMinor` "vitiligo2",
   "fins1"                `WithMinor` "vitiligo4",
   "fins2"                `WithUse`   "vitiligo4",
   "fins3"                `WithUse`   "vitiligo4",
   Only "masks", Only "claws", Only "eyes"
  ]

data Layer = Layer Text (Maybe Text)
instance IsString Layer where fromString l = Layer (fromString l) Nothing
pattern As :: Text -> Text -> Layer
pattern txt `As` disp = Layer txt (Just disp)

data Swatch =
    Only      Layer
  | WithMinor Layer Layer
  | WithUse   Layer Text

makeItem :: (Int, Swatch) -> Element
makeItem (i, swatch) = case swatch of
  Only (Layer l d) -> makeOnly l d i
  WithMinor (Layer l1 d1) (Layer l2 d2) -> makeMinor l1 d1 l2 d2 i
  WithUse (Layer l1 d1) l2 -> makeUse l1 d1 l2 i

data SwatchCount = One | Two

data SwatchPos = SOnly | SFirst | SSecond

data RectType = RMaj | RMin | ROnly


stylesheet :: Text -> Element
stylesheet path =
  makeElementNoEnd "link" `with`
    [makeAttribute "xmlns" "http://www.w3.org/1999/xhtml",
     makeAttribute "rel" "stylesheet",
     makeAttribute "href" path,
     Type_ <<- "text/css"]

makeOnly :: Text -> Maybe Text -> Int -> Element
makeOnly layer display index =
  itemGroup layer index
    [makeRect layer ROnly,
     makeTextBg layer,
     makeName (fromMaybe layer display) One,
     makeHex layer SOnly]

makeMinor :: Text -> Maybe Text -> Text -> Maybe Text -> Int -> Element
makeMinor layer1 display1 layer2 _display2 index =
  itemGroup layer1 index
    [makeRect layer1 RMaj,
     makeRect layer2 RMin,
     makeTextBg layer1,
     makeName (fromMaybe layer1 display1) Two,
     makeHex layer1 SFirst,
     makeHex layer2 SSecond]

makeUse :: Text -> Maybe Text -> Text -> Int -> Element
makeUse layer1 display1 layer2 index =
  itemGroup layer1 index
    [makeRect layer1 RMaj,
     use_ [makeAttribute "href" $ "#s-" <> layer2],
     makeTextBg layer1,
     makeName (fromMaybe layer1 display1) Two,
     makeHex layer1 SFirst,
     use_ [makeAttribute "href" $ "#c-" <> layer2]]

itemGroup :: Text -> Int -> [Element] -> Element
itemGroup layer index elt =
  g_ [Class_ <<- "item", Id_ <<- "i-" <> layer,
      Transform_ <<- itemTranslate index]
    (mconcat elt)

makeRect :: Text -> RectType -> Element
makeRect layer typ =
  rect_ [Class_ <<- classes, Id_ <<- "s-" <> layer,
         Fill_ <<- "pink",
         X_ <<- "0", Y_ <<- y,
         Width_ <<- "80", Height_ <<- height]
 where
  classes = "swatch " <>
    case typ of RMaj -> "maj"; RMin -> "min"; ROnly -> "only"
  height = case typ of RMaj -> "50"; RMin -> "25"; ROnly -> "80"
  y = case typ of RMaj -> "30"; RMin -> "0"; ROnly -> "0"

makeTextBg :: Text -> Element
makeTextBg layer =
  polygon_ [Class_ <<- "text-bg", Id_ <<- "p-" <> layer,
            Fill_ <<- "pink",
            points [(0,85), (80,85), (28,175), (-52,175)]]

makeName :: Text -> SwatchCount -> Element
makeName display count =
  text_ [Class_ <<- "name", Text_anchor_ <<- "end",
         X_ <<- tshow x, Y_ <<- "100", textTransform x] $
    toElement display
  where x = case count of One -> 22; Two -> 18

makeHex :: Text -> SwatchPos -> Element
makeHex layer count =
  text_ [Class_ <<- "hex", Id_ <<- "c-" <> layer, Text_anchor_ <<- "end",
         X_ <<- tshow x, Y_ <<- "100", textTransform x] $
    "#000000"
  where x = case count of SOnly -> 51; SFirst -> 42; SSecond -> 64

textTransform :: Int -> Attribute
textTransform x =
  Transform_ <<- rotateAround @Double (-60) (fromIntegral x) 100


itemTranslate :: Int -> Text
itemTranslate i = translate @Double (fromIntegral $ i * 100) 0

points :: [(Int, Int)] -> Attribute
points = (Points_ <<-) . Text.unwords .
         map (\(x, y) -> Text.intercalate "," [tshow x, tshow y])

tshow :: Show a => a -> Text
tshow = Text.pack . show