{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernal.Base.BaseDefs -- Copyright : (c) Stephen Tetley 2010-2012 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com -- Stability : highly unstable -- Portability : GHC -- -- The elementary base types and classes. -- -- -------------------------------------------------------------------------------- module Wumpus.Basic.Kernel.Base.BaseDefs ( -- * Constants quarter_pi , half_pi , two_pi , ang180 , ang150 , ang120 , ang90 , ang60 , ang45 , ang30 , ang15 -- * Unit phantom type , UNil(..) , ureturn , uvoid -- * Non-contextual unit conversion. , ScalarUnit(..) -- * Unit interpretation with respect to the current Point size , InterpretUnit(..) , dinterpF , normalizeF , uconvert1 , uconvertF , intraMapPoint , intraMapFunctor -- * KernChar , KernChar -- * Drawing paths and shapes (closed paths) , PathMode(..) , DrawMode(..) , closedMode -- * Drawing layers , ZOrder(..) -- * Alignment , HAlign(..) , VAlign(..) -- * Text height , TextHeight(..) -- * Cardinal (compass) positions , Cardinal(..) -- * Direction enumeration , Direction(..) , ClockDirection(..) , clockDirection , HDirection(..) , horizontalDirection , VDirection(..) , verticalDirection -- * Quadrant enumeration , Quadrant(..) , quadrant -- * Beziers , bezierArcPoints , bezierMinorArc -- * Misc , both , monPreRepeatPost ) where import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space import Data.VectorSpace import Control.Applicative import Data.Monoid quarter_pi :: Radian quarter_pi = 0.25 * pi half_pi :: Radian half_pi = 0.5 * pi two_pi :: Radian two_pi = 2.0 * pi ang180 :: Radian ang180 = pi ang150 :: Radian ang150 = 5 * ang30 ang120 :: Radian ang120 = 2 * ang60 ang90 :: Radian ang90 = pi / 2 ang60 :: Radian ang60 = pi / 3 ang45 :: Radian ang45 = pi / 4 ang30 :: Radian ang30 = pi / 6 ang15 :: Radian ang15 = pi / 12 -------------------------------------------------------------------------------- -- Simple objects wrapped with unit phatom type -- | The empty data type - i.e. @()@ - wrapped with a phantom unit -- parameter. -- data UNil u = UNil deriving (Eq,Ord,Read,Show) type instance DUnit (UNil u) = u instance Functor UNil where fmap _ UNil= UNil instance Monoid (UNil u) where mempty = UNil _ `mappend` _ = UNil instance Rotate (UNil u) where rotate _ = id instance RotateAbout (UNil u) where rotateAbout _ _ = id instance Scale (UNil u) where scale _ _ = id instance Translate (UNil u) where translate _ _ = id -- | Return a 'UNil' rather than @()@ at the end of sequence of -- monadic commands. -- -- Many Wumpus objects are usefully constructed in the -- @do-notation@, but because Wumpus has to expose the type of -- the @unit@ to the type checker we must finish the do-block -- with: -- -- > ureturn -- -- or: -- -- > return UNil -- -- rather than: -- -- > return () -- -- ureturn :: Monad m => m (UNil u) ureturn = return UNil -- | 'uvoid' runs a monadic computation and returns @UNil@. -- uvoid :: Monad m => m a -> m (UNil u) uvoid ma = ma >> return UNil -------------------------------------------------------------------------------- -- Non-contextual units class ScalarUnit a where fromPsPoint :: Double -> a toPsPoint :: a -> Double instance ScalarUnit Double where fromPsPoint = id toPsPoint = id -------------------------------------------------------------------------------- -- Interpreting units -- Units may or may not depend on current font size -- class (Eq u, Num u) => InterpretUnit u where normalize :: FontSize -> u -> Double dinterp :: FontSize -> Double -> u instance InterpretUnit Double where normalize _ = id dinterp _ = id instance InterpretUnit AfmUnit where normalize sz = afmValue sz dinterp sz = afmUnit sz -- | 'dinterp' an object that gives access to its unit at the -- functor position. -- dinterpF :: (Functor t, InterpretUnit u) => FontSize -> t Double -> t u dinterpF sz = fmap (dinterp sz) -- | 'normalize' an object that gives access to its unit at the -- functor position. -- normalizeF :: (Functor t, InterpretUnit u) => FontSize -> t u -> t Double normalizeF sz = fmap (normalize sz) -- | Convert a scalar value from one unit to another. -- uconvert1 :: (InterpretUnit u, InterpretUnit u1) => FontSize -> u -> u1 uconvert1 sz = dinterp sz . normalize sz -- | Unit convert an object that gives access to its unit at the -- Functor position. -- -- In practive this will be \*all\* Image answers. -- uconvertF :: (Functor t, InterpretUnit u, InterpretUnit u1) => FontSize -> t u -> t u1 uconvertF sz = fmap (uconvert1 sz) -- Helper for defining Affine instances. This function allows -- scaling etc to be applied on a Point coerced to a Double then -- converted back to the original unit. Thus transformations can -- work in contextual units. -- intraMapPoint :: InterpretUnit u => FontSize -> (DPoint2 -> DPoint2) -> Point2 u -> Point2 u intraMapPoint sz fn (P2 x y) = let P2 x' y' = fn $ P2 (normalize sz x) (normalize sz y) in P2 (dinterp sz x') (dinterp sz y') -- Helper for defining Affine instances. This function allows -- scaling etc to be applied on a Point coerced to a Double then -- converted back to the original unit. Thus transformations can -- work in contextual units. -- intraMapFunctor :: (Functor f, InterpretUnit u) => FontSize -> (f Double -> f Double) -> f u -> f u intraMapFunctor sz fn ma = dinterpF sz $ fn $ normalizeF sz ma -------------------------------------------------------------------------------- -- KernChar -- | Unit parametric version of KerningChar from Wumpus-Core. -- type KernChar u = (u,EscapedChar) -------------------------------------------------------------------------------- -- Drawing closed paths -- | Draw closed paths. -- -- > OSTROKE - open and stroked -- -- > CSTROKE - closed and stroke -- -- > CFILL - closed and filled -- -- > CFILL_STROKE - closed, the path is filled, its edge is stroked. -- data PathMode = OSTROKE | CSTROKE | CFILL | CFILL_STROKE deriving (Bounded,Enum,Eq,Ord,Show) -- | Draw closed paths and shapes. -- -- > DRAW_STROKE - closed and stroked -- -- > DRAW_FILL - closed and filled -- -- > DRAW_FILL_STROKE - the path is filled, its edge is stroked. -- data DrawMode = DRAW_STROKE | DRAW_FILL | DRAW_FILL_STROKE deriving (Bounded,Enum,Eq,Ord,Show) -- | Interpret a 'DrawMode' for a closed path. -- closedMode :: DrawMode -> PathMode closedMode DRAW_STROKE = CSTROKE closedMode DRAW_FILL = CFILL closedMode DRAW_FILL_STROKE = CFILL_STROKE -- | Enumerated type for drawing with respect to the z-order. -- data ZOrder = ZBELOW | ZABOVE deriving (Bounded,Enum,Eq,Ord,Show) -------------------------------------------------------------------------------- -- Alignment -- | Horizontal alignment - align to the top, center or bottom. -- data HAlign = HALIGN_TOP | HALIGN_CENTER | HALIGN_BASE deriving (Enum,Eq,Ord,Show) -- | Vertical alignment - align to the left, center or bottom. -- data VAlign = VALIGN_LEFT | VALIGN_CENTER | VALIGN_RIGHT deriving (Enum,Eq,Ord,Show) -------------------------------------------------------------------------------- -- Text height -- | Wumpus distinguishes two use-cases for displaying vertically -- centered text. -- -- Arbitrary text that is expected to contain lower case letters -- with descenders, show take the vertical center as the mid-point -- between the cap height and the descender depth. -- -- Unfortunately, including the descender depth can produce -- unbalanced results for text which is not expected to have -- descenders (e.g. numbers within a bordered box), visually this -- makes the center too high. -- data TextHeight = JUST_CAP_HEIGHT | CAP_HEIGHT_PLUS_DESCENDER deriving (Enum,Eq,Ord,Show) -------------------------------------------------------------------------------- -- Compass positions -- | An enumeratied type representing the compass positions. -- data Cardinal = NORTH | NORTH_EAST | EAST | SOUTH_EAST | SOUTH | SOUTH_WEST | WEST | NORTH_WEST deriving (Enum,Eq,Ord,Show) -- | An enumerated type representing horizontal and vertical -- directions. -- data Direction = UP | DOWN | LEFT | RIGHT deriving (Enum,Eq,Ord,Show) -- | An enumerated type representing horizontal direction. -- data HDirection = LEFTWARDS | RIGHTWARDS deriving (Enum,Eq,Ord,Show) horizontalDirection :: Radian -> HDirection horizontalDirection = fn . circularModulo where fn a | a <= 0.5*pi || a > 1.5*pi = RIGHTWARDS | otherwise = LEFTWARDS -- | An enumerated type representing vertical direction. -- data VDirection = UPWARDS | DOWNWARDS deriving (Enum,Eq,Ord,Show) verticalDirection :: Radian -> VDirection verticalDirection = fn . circularModulo where fn a | a <= pi = UPWARDS | otherwise = DOWNWARDS -- | An enumerated type representing /clock/ directions. -- data ClockDirection = CW | CCW deriving (Enum,Eq,Ord,Show) -- | Note - behaviour at the continuity (0 deg, 180 deg, ...) is -- unspecified. -- clockDirection :: (Real u, Floating u) => Vec2 u -> Vec2 u -> ClockDirection clockDirection v1 v2 = if a1 < asum then CW else CCW where a1 = r2d $ vdirection v1 asum = r2d $ vdirection (v1 ^+^ v2) -- | An enumerated type representing quadrants. -- data Quadrant = QUAD_NE | QUAD_NW | QUAD_SW | QUAD_SE deriving (Enum,Eq,Ord,Show) -- | 'quadrant' : @ ang -> Quadrant @ -- -- Get the quadrant of an angle. -- quadrant :: Radian -> Quadrant quadrant = fn . circularModulo where fn a | a < 0.5*pi = QUAD_NE | a < pi = QUAD_NW | a < 1.5*pi = QUAD_SW | otherwise = QUAD_SE -------------------------------------------------------------------------------- -- Beziers kappa :: Floating u => u kappa = 4 * ((sqrt 2 - 1) / 3) -- | 'bezierArcPoints' : @ apex_angle * radius * inclination * center -> [Point] @ -- -- > ang should be in the range 0 < ang < 360deg. -- -- > if 0 < ang <= 90 returns 4 points -- > if 90 < ang <= 180 returns 7 points -- > if 180 < ang <= 270 returns 10 points -- > if 270 < ang < 360 returns 13 points -- bezierArcPoints :: Floating u => Radian -> u -> Radian -> Point2 u -> [Point2 u] bezierArcPoints ang radius theta pt = go (circularModulo ang) where go a | a <= half_pi = wedge1 a | a <= pi = wedge2 (a/2) | a <= 1.5*pi = wedge3 (a/3) | otherwise = wedge4 (a/4) wedge1 a = let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt in [p0,p1,p2,p3] wedge2 a = let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt (_ ,p4,p5,p6) = bezierMinorArc a radius (theta+a) pt in [ p0,p1,p2,p3, p4,p5,p6 ] wedge3 a = let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt (_ ,p4,p5,p6) = bezierMinorArc a radius (theta+a) pt (_ ,p7,p8,p9) = bezierMinorArc a radius (theta+a+a) pt in [ p0,p1,p2,p3, p4,p5,p6, p7, p8, p9 ] wedge4 a = let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt (_ ,p4,p5,p6) = bezierMinorArc a radius (theta+a) pt (_ ,p7,p8,p9) = bezierMinorArc a radius (theta+a+a) pt (_ ,p10,p11,p12) = bezierMinorArc a radius (theta+a+a+a) pt in [ p0,p1,p2,p3, p4,p5,p6, p7,p8,p9, p10,p11, p12 ] -- | 'bezierMinorArc' : @ apex_angle * radius * rotation * center -> BezierCurve @ -- -- > ang should be in the range 0 < ang <= 90deg. -- bezierMinorArc :: Floating u => Radian -> u -> Radian -> Point2 u -> (Point2 u, Point2 u, Point2 u, Point2 u) bezierMinorArc ang radius theta pt = (p0,p1,p2,p3) where kfactor = fromRadian $ ang / (0.5*pi) rl = kfactor * radius * kappa totang = circularModulo $ ang + theta p0 = pt .+^ orthoVec radius 0 theta p1 = p0 .+^ orthoVec 0 rl theta p2 = p3 .+^ orthoVec 0 (-rl) totang p3 = pt .+^ orthoVec radius 0 totang -------------------------------------------------------------------------------- -- | Applicative /both/ - run both computations return the pair -- of the the answers. -- both :: Applicative f => f a -> f b -> f (a,b) both fa fb = (,) <$> fa <*> fb -- | Monodial scheme - prefix, repeat body n times, suffix. -- monPreRepeatPost :: Monoid a => a -> (Int, a) -> a -> a monPreRepeatPost pre (n,body1) post = step pre n where step ac i | i < 1 = ac `mappend` post | otherwise = step (ac `mappend` body1) (i - 1)