147 lines
4.4 KiB
Haskell
147 lines
4.4 KiB
Haskell
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 "style/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 layer2 RMin,
|
|
makeRect layer1 RMaj,
|
|
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
|
|
[use_ [makeAttribute "href" $ "#s-" <> layer2],
|
|
makeRect layer1 RMaj,
|
|
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
|