{-# OPTIONS_GHC -Wall #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} import Protolude import NumHask.Space import Chart import Control.Category (id) import Control.Lens import qualified Data.Map.Strict as Map import Data.Generics.Labels () import qualified Data.Text as Text import qualified Data.Text.Lazy as Lazy import Lucid.Svg hiding (z) xs :: Map.Map Text (Point Double) xs = Map.fromList [ ("origin", Point 0 0) -- origin , ("circle1", Point 0.5 (-0.5 + cos (pi/6))) -- center of circle 1 , ("circle2", Point 0 (-0.5)) -- center of circle 2 , ("circle3", Point (-0.5) ((-0.5) + cos (pi/6))) -- center of circle 3 , ("corner1", Point 0 ((-0.5) + 2 * cos (pi/6))) -- corner 1 , ("corner2", Point 1 (-0.5)) -- corner 2 , ("corner3", Point (-1) (-0.5)) -- corner 3 ] vennps :: Text -> (Double, Double) vennps k = let (Point x y) = xs Map.! k in (x, -y) moveA :: Double -> Double -> Text moveA x y = "M" <> show x <> "," <> show y data Arc = Arc { arcXr :: Double, arcYr :: Double, arcRot :: Double, arcLargeArcFlag :: Bool, arcSweepFlag :: Bool, arcX :: Double, arcY :: Double} deriving (Eq, Show, Generic) arcA_ :: Arc -> Text arcA_ a = show (view #arcXr a) <> " " <> show (view #arcYr a) <> " " <> show (view #arcRot a) <> " " <> bool "0" "1" (view #arcLargeArcFlag a) <> " " <> bool "0" "1" (view #arcSweepFlag a) <> " " <> show (view #arcX a) <> "," <> show (view #arcY a) arcA :: [Arc] -> Text arcA as = "A" <> Text.intercalate " " (arcA_ <$> as) outerseg1 :: Text outerseg1 = Text.intercalate " " [ uncurry moveA (vennps "corner1") , arcA [ uncurry (Arc 0.5 0.5 0 True True) (vennps "corner2") , uncurry (Arc 1 1 0 False False) (vennps "circle1") , uncurry (Arc 1 1 0 False False) (vennps "corner1") ] , "Z" ] outerseg2 :: Text outerseg2 = Text.intercalate " " [ uncurry moveA (vennps "corner3") , arcA [ uncurry (Arc 0.5 0.5 0 True False) (vennps "corner2") , uncurry (Arc 1 1 0 False True) (vennps "circle2") , uncurry (Arc 1 1 0 False True) (vennps "corner3") ] , "Z" ] outerseg3 :: Text outerseg3 = Text.intercalate " " [ uncurry moveA (vennps "corner3") , arcA [ uncurry (Arc 0.5 0.5 0 True True) (vennps "corner1") , uncurry (Arc 1 1 0 False False) (vennps "circle3") , uncurry (Arc 1 1 0 False False) (vennps "corner3") ] , "Z" ] innerseg :: Text innerseg = Text.intercalate " " [ uncurry moveA (vennps "circle1") , arcA [ uncurry (Arc 1 1 0 False True) (vennps "circle2") , uncurry (Arc 1 1 0 False True) (vennps "circle3") , uncurry (Arc 1 1 0 False True) (vennps "circle1") ] , "Z" ] midseg1 :: Text midseg1 = Text.intercalate " " [ uncurry moveA (vennps "corner1") , arcA [ uncurry (Arc 1 1 0 False True) (vennps "circle1") , uncurry (Arc 1 1 0 False False) (vennps "circle3") , uncurry (Arc 1 1 0 False True) (vennps "corner1") ] , "Z" ] midseg2 :: Text midseg2 = Text.intercalate " " [ uncurry moveA (vennps "circle1") , arcA [ uncurry (Arc 1 1 0 False True) (vennps "corner2") , uncurry (Arc 1 1 0 False True) (vennps "circle2") , uncurry (Arc 1 1 0 False False) (vennps "circle1") ] , "Z" ] midseg3 :: Text midseg3 = Text.intercalate " " [ uncurry moveA (vennps "circle2") , arcA [ uncurry (Arc 1 1 0 False True) (vennps "corner3") , uncurry (Arc 1 1 0 False True) (vennps "circle3") , uncurry (Arc 1 1 0 False False) (vennps "circle2") ] , "Z" ] vennGlyphs :: [Text] vennGlyphs = [outerseg1, outerseg2, outerseg3, midseg1, midseg2, midseg3, innerseg] seg :: Text -> PixelRGB8 -> Double -> GlyphStyle seg p c o = defaultGlyphStyle & set #shape (PathGlyph p) & set #color c & set #borderColor white & set #borderSize 0.06 & set #borderOpacity 1 & set #opacity o venns :: [Chart Double] venns = zipWith (\p c -> Chart (GlyphA $ seg p c 0.8) [SP 0.0 0.0]) vennGlyphs chartPalette phrases :: [Chart Double] phrases = phraseChart <$> mainPhrases data Phrase = Phrase { phraseText :: Text , phrasePosition :: Point Double , phraseSize :: Double , phraseRotation :: Double , phraseColor :: PixelRGB8 , phraseOpacity :: Double , phraseTag :: Text , phraseLevel :: Int } deriving (Eq, Show, Generic) phraseChart :: Phrase -> Chart Double phraseChart p = Chart (TextA a [view #phraseText p]) [SpotPoint (view #phrasePosition p)] where a = defaultTextStyle & set #size (view #phraseSize p) & set #rotation (Just $ view #phraseRotation p) & set #color (view #phraseColor p) & set #opacity (view #phraseOpacity p) mainPhrases :: [Phrase] mainPhrases = [ Phrase "Composable" (Point 0.9 0.7) 0.16 60 c 1 "composable" 1 , Phrase "Functional" (Point 0 (-1)) 0.16 0 c 1 "functional" 1 , Phrase "Open" (Point (-1) 0.55) 0.16 (-60) c 1 "open" 1 , Phrase "Accurate" (Point 0.6 (-0.4)) 0.16 0 c 1 "accurate" 1 , Phrase "Dynamic" (Point (-0.6) (-0.4)) 0.16 0 c 1 "dynamic" 1 , Phrase "Modern" (Point 0 0.7) 0.16 0 c 1 "modern" 1 , Phrase "chart-svg" (Point 0 0) 0.2 0 c 1 "chart-svg" 1 ] where c = black renderToSvgt :: CssOptions -> Point Double -> Rect Double -> [Chart Double] -> [(TextStyle, Text)] -> Svg () renderToSvgt csso (Point w' h') (Rect x z y w) cs tts = with (svg2_ (bool id (cssCrisp<>) (csso == UseCssCrisp) $ chartDefs cs <> mconcat (zipWith svgt cs tts ))) [width_ (show w'), height_ (show h'), viewBox_ (show x <> " " <> show (-w) <> " " <> show (z - x) <> " " <> show (w - y))] writeVennWords :: IO () writeVennWords = writeFile "other/venn2.svg" $ Lazy.toStrict $ prettyText $ renderToSvgt NoCssOptions (Point 300 300) (Rect (-2) 2 (-2) 2) (phrases <> venns <> [Chart BlankA [SR (-2.0) 2.0 (-2.0) 2.0]]) $ (defaultTextStyle & set #color white,) <$> (replicate 7 "" <> (phraseText <$> mainPhrases) <> [""]) writeVenn :: [PixelRGB8] -> Double -> IO () writeVenn cs o = writeChartsWith "other/venn.svg" (defaultSvgOptions & set #scaleCharts' NoScaleCharts & set #svgAspect ChartAspect & set #svgHeight 100) ([phraseChart (Phrase "λ" (Point 0 (-0.2)) 0.8 0 (PixelRGB8 27 1 72) 1 "chart-svg" 1)] <> (zipWith (\p c -> Chart (GlyphA $ seg p c o) [SP 0.0 0.0]) [outerseg1, outerseg2, outerseg3, midseg1, midseg2, midseg3] cs) <> [Chart BlankA [SR (-1.5) 1.5 (-1.5) 1.5]]) main :: IO () main = do writeVennWords writeVenn chartPalette 0.8