module Wumpus.Basic.Kernel.Base.BaseDefs
(
quarter_pi
, half_pi
, two_pi
, ang180
, ang150
, ang120
, ang90
, ang60
, ang45
, ang30
, ang15
, UNil(..)
, ureturn
, uvoid
, ScalarUnit(..)
, InterpretUnit(..)
, dinterpF
, normalizeF
, uconvert1
, uconvertF
, intraMapPoint
, intraMapFunctor
, KernChar
, PathMode(..)
, DrawMode(..)
, closedMode
, ZOrder(..)
, HAlign(..)
, VAlign(..)
, TextHeight(..)
, Cardinal(..)
, Direction(..)
, ClockDirection(..)
, clockDirection
, HDirection(..)
, horizontalDirection
, VDirection(..)
, verticalDirection
, Quadrant(..)
, quadrant
, bezierArcPoints
, bezierMinorArc
, both
, monPreRepeatPost
) where
import Wumpus.Core
import Data.AffineSpace
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
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
ureturn :: Monad m => m (UNil u)
ureturn = return UNil
uvoid :: Monad m => m a -> m (UNil u)
uvoid ma = ma >> return UNil
class ScalarUnit a where
fromPsPoint :: Double -> a
toPsPoint :: a -> Double
instance ScalarUnit Double where
fromPsPoint = id
toPsPoint = id
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
dinterpF :: (Functor t, InterpretUnit u) => FontSize -> t Double -> t u
dinterpF sz = fmap (dinterp sz)
normalizeF :: (Functor t, InterpretUnit u) => FontSize -> t u -> t Double
normalizeF sz = fmap (normalize sz)
uconvert1 :: (InterpretUnit u, InterpretUnit u1) => FontSize -> u -> u1
uconvert1 sz = dinterp sz . normalize sz
uconvertF :: (Functor t, InterpretUnit u, InterpretUnit u1)
=> FontSize -> t u -> t u1
uconvertF sz = fmap (uconvert1 sz)
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')
intraMapFunctor :: (Functor f, InterpretUnit u)
=> FontSize -> (f Double -> f Double) -> f u -> f u
intraMapFunctor sz fn ma = dinterpF sz $ fn $ normalizeF sz ma
type KernChar u = (u,EscapedChar)
data PathMode = OSTROKE | CSTROKE | CFILL | CFILL_STROKE
deriving (Bounded,Enum,Eq,Ord,Show)
data DrawMode = DRAW_STROKE | DRAW_FILL | DRAW_FILL_STROKE
deriving (Bounded,Enum,Eq,Ord,Show)
closedMode :: DrawMode -> PathMode
closedMode DRAW_STROKE = CSTROKE
closedMode DRAW_FILL = CFILL
closedMode DRAW_FILL_STROKE = CFILL_STROKE
data ZOrder = ZBELOW | ZABOVE
deriving (Bounded,Enum,Eq,Ord,Show)
data HAlign = HALIGN_TOP | HALIGN_CENTER | HALIGN_BASE
deriving (Enum,Eq,Ord,Show)
data VAlign = VALIGN_LEFT | VALIGN_CENTER | VALIGN_RIGHT
deriving (Enum,Eq,Ord,Show)
data TextHeight = JUST_CAP_HEIGHT | CAP_HEIGHT_PLUS_DESCENDER
deriving (Enum,Eq,Ord,Show)
data Cardinal = NORTH | NORTH_EAST | EAST | SOUTH_EAST
| SOUTH | SOUTH_WEST | WEST | NORTH_WEST
deriving (Enum,Eq,Ord,Show)
data Direction = UP | DOWN | LEFT | RIGHT
deriving (Enum,Eq,Ord,Show)
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
data VDirection = UPWARDS | DOWNWARDS
deriving (Enum,Eq,Ord,Show)
verticalDirection :: Radian -> VDirection
verticalDirection = fn . circularModulo
where
fn a | a <= pi = UPWARDS
| otherwise = DOWNWARDS
data ClockDirection = CW | CCW
deriving (Enum,Eq,Ord,Show)
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)
data Quadrant = QUAD_NE | QUAD_NW | QUAD_SW | QUAD_SE
deriving (Enum,Eq,Ord,Show)
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
kappa :: Floating u => u
kappa = 4 * ((sqrt 2 1) / 3)
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 :: 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
both :: Applicative f => f a -> f b -> f (a,b)
both fa fb = (,) <$> fa <*> fb
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)