{-# LANGUAGE NoMonomorphismRestriction #-}

import Diagrams.Prelude
import Diagrams.Backend.Cairo.CmdLine

main = mainWith $ pad 1.05 . centerXY $ connDiag

baseDiag = hsep 0.5 . fmap centerY $
    [ anAmper # named "amp"
    , anArrow "total" # named "sum" # centerX
        ===
    strutY 1
        ===
    (aFunction "const 1" # named "one" |||
        strutX 1 |||
        anArrow "total" # named "count") # named "path2" # centerX
    , aFunction "/" # named "divide"
    ]

connDiag = baseDiag
    # connectPerim' baseConnOpts
        "amp" "sum" (1/8 @@ turn) (1/2 @@ turn)
    # connectPerim' baseConnOpts
        "amp" "one" (7/8 @@ turn) (1/2 @@ turn)
    # connectPerim' baseConnOpts
        "one" "count" (0 @@ turn) (1/2 @@ turn)
    # connectPerim' baseConnOpts
        "sum" "divide" (0 @@ turn) (3/8 @@ turn)
    # connectPerim' baseConnOpts
        "count" "divide" (0 @@ turn) (5/8 @@ turn)
    where
    baseConnOpts = with & lengths .~ large
        & shaftStyle %~ lc baseColour . lw veryThick
        & headStyle %~ fc (darken 0.2 baseColour)

aFunction :: String -> Diagram B
aFunction s = roundedRect 1.6 1.2 0.4 # applyStyle initStyle
    <> nudgedText s
        # fc baseColour

anArrow :: String -> Diagram B
anArrow s = rect 1.6 1.2 # applyStyle initStyle
    <> nudgedText s

anAmper :: Diagram B
anAmper = circle 0.5 # applyStyle initStyle
    <> nudgedText "&&&"

initStyle :: Style V2 Double
initStyle = mempty # lc baseColour # lwL 0.1

baseColour = mediumorchid

nudgedText :: String -> Diagram B
nudgedText s = alignedText 0.5 0.5 s
    # font "monospace" # fontSize (local 0.25) # bold # fc baseColour