module Wumpus.Drawing.Dots.SimpleDots
(
MarkSize
, smallDisk
, largeDisk
, smallCirc
, largeCirc
, dotNone
, dotChar
, dotText
, dotEscChar
, dotEscText
, dotHBar
, dotVBar
, dotX
, dotPlus
, dotCross
, dotDiamond
, dotFDiamond
, dotBDiamond
, dotDisk
, dotSquare
, dotCircle
, dotPentagon
, dotStar
, dotAsterisk
, dotOPlus
, dotOCross
, dotFOCross
, dotTriangle
) where
import Wumpus.Drawing.Basis.Symbols
import Wumpus.Basic.Geometry
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.VectorSpace
import Data.Monoid
newtype MarkSize = MarkSize { getMarkSize :: Double }
deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)
instance Show MarkSize where
showsPrec p d = showsPrec p (getMarkSize d)
instance InterpretUnit MarkSize where
normalize sz a = (realToFrac a) * 0.75 * fromIntegral sz
dinterp sz d = (4/3) * (realToFrac d) / (fromIntegral sz)
instance Tolerance MarkSize where
eq_tolerance = 0.001
length_tolerance = 0.01
umark :: InterpretUnit u => LocGraphic MarkSize -> LocGraphic u
umark = uconvF
smallDisk :: InterpretUnit u => LocGraphic u
smallDisk = umark $ dcDisk DRAW_FILL 0.25
largeDisk :: InterpretUnit u => LocGraphic u
largeDisk = umark $ dcDisk DRAW_FILL 1
smallCirc :: InterpretUnit u => LocGraphic u
smallCirc = umark $ ocircle 0.25
largeCirc :: InterpretUnit u => LocGraphic u
largeCirc = umark $ ocircle 1
dotNone :: InterpretUnit u => LocGraphic u
dotNone = emptyLocImage
dotChar :: (Real u, Floating u, InterpretUnit u) => Char -> LocGraphic u
dotChar ch = dotText [ch]
dotText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u
dotText ss = ignoreAns $ runPosObject CENTER $ posText ss
dotEscChar :: (Real u, Floating u, InterpretUnit u)
=> EscapedChar -> LocGraphic u
dotEscChar = dotEscText . wrapEscChar
dotEscText :: (Real u, Floating u, InterpretUnit u)
=> EscapedText -> LocGraphic u
dotEscText esc = ignoreAns $ runPosObject CENTER $ posEscText esc
axialLine :: (Fractional u, InterpretUnit u) => Vec2 u -> LocGraphic u
axialLine v = moveStart (negateV (0.5 *^ v)) (locStraightLine v)
dotHBar :: (Fractional u, InterpretUnit u) => LocGraphic u
dotHBar = umark $ hbar 1
dotVBar :: (Fractional u, InterpretUnit u) => LocGraphic u
dotVBar = umark $ vbar 1
dotX :: (Fractional u, InterpretUnit u) => LocGraphic u
dotX = umark $ axialLine (vec 0.75 1) `mappend` axialLine (vec (0.75) 1)
dotPlus :: (Fractional u, InterpretUnit u) => LocGraphic u
dotPlus = dotVBar `mappend` dotHBar
dotCross :: (Floating u, InterpretUnit u) => LocGraphic u
dotCross =
umark $ axialLine (avec ang 1) `mappend` axialLine (avec (ang) 1)
where
ang = pi*0.25
dotDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u
dotDiamond = umark $ drawPlacedTrail CSTROKE (diamondTrail 0.5 0.66)
dotFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u
dotFDiamond = umark $ drawPlacedTrail CFILL (diamondTrail 0.5 0.66)
dotBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u
dotBDiamond = umark $ drawPlacedTrail CFILL_STROKE (diamondTrail 0.5 0.66)
dotDisk :: (Fractional u, InterpretUnit u) => LocGraphic u
dotDisk = umark $ dcDisk DRAW_FILL 0.5
dotSquare :: (Fractional u, InterpretUnit u) => LocGraphic u
dotSquare = umark $ drawPlacedTrail CSTROKE (rectangleTrail 1 1)
dotCircle :: (Fractional u, InterpretUnit u) => LocGraphic u
dotCircle = umark $ ocircle 0.5
dotBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u
dotBCircle = umark $ dcDisk DRAW_FILL_STROKE 0.5
dotPentagon :: (Floating u, InterpretUnit u) => LocGraphic u
dotPentagon = umark $ drawPlacedTrail CSTROKE (polygonTrail 5 0.5)
dotStar :: (Floating u, Ord u, InterpretUnit u, Tolerance u)
=> LocGraphic u
dotStar = umark $ starLines 0.5
starLines :: (Floating u, Ord u, InterpretUnit u, Tolerance u)
=> u -> LocGraphic u
starLines hh = promoteLoc $ \ctr ->
let alg = polygonTrail 5 hh
in liftQuery (qapplyLoc (placedTrailPoints alg) ctr) >>= \ps ->
step $ map (fn ctr) ps
where
fn p0 p1 = straightLine p0 p1
step (x:xs) = mconcat $ x:xs
step _ = error "starLines - unreachable"
dotAsterisk :: (Floating u, InterpretUnit u) => LocGraphic u
dotAsterisk = umark $ asteriskLines 1
asteriskLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u
asteriskLines h = lineF1 `mappend` lineF2 `mappend` 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)
dotOPlus :: (Fractional u, InterpretUnit u) => LocGraphic u
dotOPlus = dotCircle `mappend` dotPlus
dotOCross :: (Floating u, InterpretUnit u) => LocGraphic u
dotOCross = dotCircle `mappend` dotCross
dotFOCross :: (Floating u, InterpretUnit u) => LocGraphic u
dotFOCross = dotBCircle `mappend` dotCross
dotTriangle :: (Floating u, InterpretUnit u) => LocGraphic u
dotTriangle = umark $ drawPlacedTrail CSTROKE alg
where
alg = trailIterateLocus $ fn3 $ equilateralTriangleVertices 1
fn3 = \(a,b,c) -> [a,b,c]