vibe coding [WIP]

bonbons.hs

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE OverloadedRecordDot       #-}

import Data.List.NonEmpty (NonEmpty(..))

import Diagrams.Prelude
import qualified Diagrams.Color.XKCD as CX
import Diagrams.Backend.SVG.CmdLine

type Ingredient = (String, AlphaColour Double)

data ChocolateType
  = MilkChocolate
  | WhiteChocolate
  | DarkChocolate

data BonBon =
  BonBon { coating :: AlphaColour Double
         , shell :: ChocolateType
         , fillings :: NonEmpty Ingredient
         }

chocolateColor :: ChocolateType -> AlphaColour Double
chocolateColor MilkChocolate = CX.lightBrown
chocolateColor WhiteChocolate = CX.beige
chocolateColor DarkChocolate = CX.darkBrown

example :: BonBon
example = BonBon { coating = CX.green
                 , shell = MilkChocolate
                 , fillings = ("pistachio", CX.green) :|
                              [ ("orange jello", CX.orangePink)
                              , ("crude oil", CX.darkBrown)
                              ]
                 }

draw :: BonBon -> Diagram B
draw b =
  drawCoating b.coating <>
  drawShell b.shell <>
  drawFillings b.fillings
  where
    drawCoating c = wedge 1 xDir (1/2 @@ turn)
      # lineWidth 2
      # lineColor c
    drawShell s = annularWedge 0.9 1 xDir (1/2 @@ turn)
      # lineWidth 0
      # fillColor (chocolateColor s)
    drawFillings ((_, f):|rest) =
      let count = length rest + 1
       in mconcat (drawRestFilling count <$> reverse (zip rest [1..])) <>
            wedge 0.9 xDir (1/2 @@ turn)
                 # lineWidth 0
                 # fillColor f
    drawRestFilling n ((_, f), i) = wedge 0.9 xDir (1/2 @@ turn)
      # lineWidth 0
      # fillColor f
      # clipBy (square 1.8 # translateY (-(i * 0.9 / fromIntegral n)))


main :: IO ()
main = mainWith $ draw example