{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Dots.SimpleDots -- Copyright : (c) Stephen Tetley 2011-2012 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Simple dots - no anchor handles. -- -- Use these where you just want to draw Dots, and do not need -- connectors between them. -- -- The text and char marks need loaded glyph metrics for proper -- centering. -- -- \*\* WARNING \*\* - names are expected to change - filled and -- background-filled marks need a naming convention. -- -------------------------------------------------------------------------------- module Wumpus.Drawing.Dots.SimpleDots ( -- * Unit for marks (0.75 the font size) MarkSize , smallDisk , largeDisk , smallCirc , largeCirc -- * Dots , 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.ShapeTrails import Wumpus.Drawing.Basis.Symbols import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core import Data.VectorSpace -- package: vector-space import Data.Monoid -- Marks should be the height of a lower-case letter... -- NOTES -- -- TikZ has both stroked and bordered (filled and outline-stroked) -- marks e.g. square and square* -- -- Cap height is a good size for Dots. -- | MarkUnit is a contextual unit like 'Em' and 'En'. -- -- It is 3\/4 of the current font size. -- 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 -- | Filled disk - radius 0.25 MarkSize. -- smallDisk :: InterpretUnit u => LocGraphic u smallDisk = umark $ dcDisk DRAW_FILL 0.25 -- | Filled disk - radius 1.0 MarkSize. -- largeDisk :: InterpretUnit u => LocGraphic u largeDisk = umark $ dcDisk DRAW_FILL 1 -- | Stroked disk (circle) - radius 0.25 MarkSize. -- smallCirc :: InterpretUnit u => LocGraphic u smallCirc = umark $ scircle 0.25 -- | Stroked disk (circle) - radius 1.0 MarkSize. -- largeCirc :: InterpretUnit u => LocGraphic u largeCirc = umark $ scircle 1 -- possibly: -- szCirc :: u -> LocGraphic u 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 -- TODO - need Upright versions of dots... -- | Supplied point is the center. -- 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 $ renderAnaTrail CSTROKE (diamondTrail 0.5 0.66) dotFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u dotFDiamond = umark $ renderAnaTrail CFILL (diamondTrail 0.5 0.66) dotBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u dotBDiamond = umark $ renderAnaTrail CFILL_STROKE (diamondTrail 0.5 0.66) -- | Note disk is filled. -- dotDisk :: (Fractional u, InterpretUnit u) => LocGraphic u dotDisk = umark $ dcDisk DRAW_FILL 0.5 dotSquare :: (Fractional u, InterpretUnit u) => LocGraphic u dotSquare = umark $ renderAnaTrail CSTROKE (rectangleTrail 1 1) dotCircle :: (Fractional u, InterpretUnit u) => LocGraphic u dotCircle = umark $ scircle 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 $ renderAnaTrail 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 (anaTrailPoints 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 -- bkCircle :: (Fractional u, InterpretUnit u) => LocGraphic u -- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) dotTriangle :: (Floating u, InterpretUnit u) => LocGraphic u dotTriangle = umark $ renderAnaTrail CSTROKE $ isosceles_triangle_trail 1 1