module Wumpus.Drawing.Dots.Marks
(
markChar
, markText
, markHLine
, markVLine
, markX
, markPlus
, markCross
, markDiamond
, markFDiamond
, markBDiamond
, markDisk
, markSquare
, markCircle
, markPentagon
, markStar
, markAsterisk
, markOPlus
, markOCross
, markFOCross
, markTriangle
) where
import Wumpus.Drawing.Geometry.Paths
import Wumpus.Drawing.Text.LRText
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.AffineSpace
import Data.VectorSpace
import Control.Applicative
infixr 9 `renderPathWith`
renderPathWith :: LocDrawingInfo u (PrimPath u)
-> (PrimPath u -> Graphic u)
-> LocGraphic u
renderPathWith m k = m >>= (lift0R1 . k)
markChar :: (Real u, Floating u, FromPtSize u) => Char -> LocGraphic u
markChar ch = markText [ch]
markText :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u
markText ss = fmap (replaceL uNil) $ ctrCenterLine ss
axialLine :: Fractional u => Vec2 u -> LocGraphic u
axialLine v = moveStartPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v)
markHLine :: (Fractional u, FromPtSize u) => LocGraphic u
markHLine = lift0R1 markHeight >>= \h -> axialLine (hvec h)
markVLine :: (Fractional u, FromPtSize u) => LocGraphic u
markVLine = lift0R1 markHeight >>= \h -> axialLine (vvec h)
markX :: (Fractional u, FromPtSize u) => LocGraphic u
markX = lift0R1 markHeight >>= mkX
where
mkX h = let w = 0.75 * h
in axialLine (vec w h) `oplus` axialLine (vec (w) h)
markPlus :: (Fractional u, FromPtSize u) => LocGraphic u
markPlus = markVLine `oplus` markHLine
markCross :: (Floating u, FromPtSize u) => LocGraphic u
markCross = markHeight >>= mkCross
where
mkCross h = axialLine (avec ang h) `oplus` axialLine (avec (ang) h)
ang = pi*0.25
pathDiamond :: (Fractional u, FromPtSize u)
=> LocDrawingInfo u (PrimPath u)
pathDiamond =
promoteR1 $ \pt ->
markHeight >>= \h -> let cp = diamondCoordPath (0.5*h) (0.66*h)
in return $ coordinatePrimPath pt cp
markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u
markDiamond = pathDiamond `renderPathWith` closedStroke
markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u
markFDiamond = pathDiamond `renderPathWith` filledPath
markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u
markBDiamond = pathDiamond `renderPathWith` borderedPath
markDisk :: (Fractional u, FromPtSize u) => LocGraphic u
markDisk = lift0R1 markHalfHeight >>= filledDisk
markSquare :: (Fractional u, FromPtSize u) => LocGraphic u
markSquare =
lift0R1 markHeight >>= \h ->
let d = 0.5*(h) in moveStartPoint (displace d d) $ strokedRectangle h h
markCircle :: (Fractional u, FromPtSize u) => LocGraphic u
markCircle = lift0R1 markHalfHeight >>= strokedDisk
markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u
markBCircle = lift0R1 markHalfHeight >>= borderedDisk
markPentagon :: (Floating u, FromPtSize u) => LocGraphic u
markPentagon =
promoteR1 $ \pt ->
markHeight >>= \h -> closedStroke $ pentagonPath pt (0.5*h)
where
pentagonPath pt hh = coordinatePrimPath pt $ polygonCoordPath 5 hh
markStar :: (Floating u, FromPtSize u) => LocGraphic u
markStar = lift0R1 markHeight >>= \h -> starLines (0.5*h)
starLines :: Floating u => u -> LocGraphic u
starLines hh =
promoteR1 $ \ctr -> let cp = polygonCoordPath 5 hh
in step $ map (fn ctr) $ cp ctr
where
fn p0 p1 = openStroke $ primPath p0 [lineTo p1]
step (x:xs) = oconcat x xs
step _ = error "starLines - unreachable"
markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u
markAsterisk = lift0R1 markHeight >>= asteriskLines
asteriskLines :: Floating u => u -> LocGraphic u
asteriskLines h = lineF1 `oplus` lineF2 `oplus` lineF3
where
ang = (pi*2) / 6
lineF1 = axialLine (vvec h)
lineF2 = axialLine (avec ((pi*0.5) + ang) h)
lineF3 = axialLine (avec ((pi*0.5) + ang + ang) h)
markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u
markOPlus = markCircle `oplus` markPlus
markOCross :: (Floating u, FromPtSize u) => LocGraphic u
markOCross = markCircle `oplus` markCross
markFOCross :: (Floating u, FromPtSize u) => LocGraphic u
markFOCross = markCross `oplus` markBCircle
markTriangle :: (Floating u, FromPtSize u) => LocGraphic u
markTriangle = tripath `renderPathWith` closedStroke
where
tripath = promoteR1 $ \pt ->
markHeight >>= \h -> let cp = equilateralTriangleCoordPath h
in pure $ coordinatePrimPath pt cp