module Wumpus.Basic.Kernel.Drawing.PosObject
(
GenPosObject
, GenPosGraphic
, PosObject
, DPosObject
, PosGraphic
, DPosGraphic
, runGenPosObject
, evalGenPosObject
, execGenPosObject
, runPosObject
, runPosObjectBBox
, makePosObject
, emptyPosObject
, elaboratePosObject
, decoratePosObject
, extendPosObject
, mapOrientation
, illustratePosObject
, posChar
, posEscChar
, posCharUpright
, posEscCharUpright
, posCharPrim
, posText
, posEscText
, posTextUpright
, posEscTextUpright
, posTextPrim
, multilinePosText
, multilinePosEscText
, rposText
, rposEscText
, rposChar
, rposEscChar
, posHKernText
, monospaceText
, monospaceEscText
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.QueryDC
import Wumpus.Basic.Kernel.Base.UpdateDC
import Wumpus.Basic.Kernel.Base.WrappedPrimitive
import Wumpus.Basic.Kernel.Drawing.Basis
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Basic.Kernel.Objects.Concat
import Wumpus.Basic.Kernel.Objects.DrawingPrimitives
import Wumpus.Basic.Kernel.Objects.Image
import Wumpus.Basic.Kernel.Objects.LocImage
import Wumpus.Basic.Kernel.Objects.LocThetaImage
import Wumpus.Basic.Kernel.Objects.Orientation
import Wumpus.Core
import Wumpus.Core.Colour ( red, blue )
import Data.AffineSpace
import Data.VectorSpace
import Control.Applicative
import Data.Monoid
type DOrt = Orientation Double
newtype GenPosObject st u a = GenPosObject {
getGenPosObject :: DrawingContext -> DPoint2 -> st -> (a, st, DOrt, CatPrim) }
type instance DUnit (GenPosObject st u a) = u
type instance UState (GenPosObject st u) = st
type GenPosGraphic st u = GenPosObject st u (UNil u)
type PosObject u a = GenPosObject () u a
type DPosObject a = PosObject Double a
type PosGraphic u = PosObject u (UNil u)
type DPosGraphic = PosGraphic Double
instance Functor (GenPosObject st u) where
fmap f mf = GenPosObject $ \ctx pt s ->
let (a,s1,o1,w1) = getGenPosObject mf ctx pt s in (f a,s1,o1,w1)
instance Applicative (GenPosObject st u) where
pure a = GenPosObject $ \_ _ s -> (a,s,mempty,mempty)
mf <*> ma = GenPosObject $ \ctx pt s ->
let (f,s1,o1,w1) = getGenPosObject mf ctx pt s
(a,s2,o2,w2) = getGenPosObject ma ctx pt s1
in (f a, s2, o1 `mappend` o2, w1 `mappend` w2)
instance Monad (GenPosObject st u) where
return a = GenPosObject $ \_ _ s -> (a, s, mempty, mempty)
mf >>= k = GenPosObject $ \ctx pt s ->
let (a,s1,o1,w1) = getGenPosObject mf ctx pt s
(b,s2,o2,w2) = getGenPosObject (k a) ctx pt s1
in (b, s2, o1 `mappend` o2, w1 `mappend` w2)
instance (Monoid a, InterpretUnit u) => Monoid (GenPosObject st u a) where
mempty = GenPosObject $ \_ _ s -> (mempty, s, mempty, mempty)
ma `mappend` mb = GenPosObject $ \ctx pt s ->
let (a,s1,o1,w1) = getGenPosObject ma ctx pt s
(b,s2,o2,w2) = getGenPosObject mb ctx pt s1
in (a `mappend` b, s2, o1 `mappend` o2, w1 `mappend` w2)
instance DrawingCtxM (GenPosObject st u) where
askDC = GenPosObject $ \ctx _ s -> (ctx, s, mempty, mempty)
asksDC fn = GenPosObject $ \ctx _ s -> (fn ctx, s, mempty, mempty)
localize upd ma = GenPosObject $ \ctx pt s ->
getGenPosObject ma (upd ctx) pt s
instance UserStateM (GenPosObject st u) where
getState = GenPosObject $ \_ _ s -> (s, s, mempty, mempty)
setState s = GenPosObject $ \_ _ _ -> ((), s, mempty, mempty)
updateState upd = GenPosObject $ \_ _ s -> ((), upd s, mempty, mempty)
runGenPosObject :: InterpretUnit u
=> RectAddress -> st -> GenPosObject st u a -> LocImage u (a,st)
runGenPosObject addr st ma = promoteLoc $ \ot ->
askDC >>= \ctx ->
let dot = normalizeF (dc_font_size ctx) ot
(a,s1,o1,ca) = getGenPosObject ma ctx dot st
v1 = vtoOrigin addr o1
in replaceAns (a,s1) $ primGraphic $ cpmove v1 ca
evalGenPosObject :: InterpretUnit u
=> RectAddress -> st -> GenPosObject st u a -> LocImage u a
evalGenPosObject addr st ma = fmap fst $ runGenPosObject addr st ma
execGenPosObject :: InterpretUnit u
=> RectAddress -> st -> GenPosObject st u a -> LocImage u st
execGenPosObject addr st ma = fmap snd $ runGenPosObject addr st ma
runPosObject :: InterpretUnit u
=> RectAddress -> PosObject u a -> LocImage u a
runPosObject addr ma = fmap fst $ runGenPosObject addr () ma
runPosObjectBBox :: InterpretUnit u
=> RectAddress -> PosObject u a -> LocImage u (BoundingBox u)
runPosObjectBBox addr ma = promoteLoc $ \pt ->
askDC >>= \ctx ->
let sz = dc_font_size ctx
dpt = normalizeF sz pt
(_,_,o1,w1) = getGenPosObject ma ctx dpt ()
v1 = vtoOrigin addr o1
bb = dinterpF sz $ orientationBounds o1 (dpt .+^ v1)
in replaceAns bb $ primGraphic $ cpmove v1 w1
makePosObject :: InterpretUnit u
=> Query u (Orientation u) -> LocImage u a -> GenPosObject st u a
makePosObject ma gf = GenPosObject $ \ctx pt s ->
let ort1 = runQuery ctx ma
dort1 = normalizeF (dc_font_size ctx) ort1
upt = dinterpF (dc_font_size ctx) pt
(a,w) = runLocImage ctx upt gf
in (a,s,dort1,w)
emptyPosObject :: (Monoid a, InterpretUnit u) => GenPosObject st u a
emptyPosObject = mempty
elaboratePosObject :: (Fractional u, Ord u, InterpretUnit u)
=> ZDeco -> RectAddress -> LocGraphic u -> GenPosObject st u a
-> GenPosObject st u a
elaboratePosObject zdec raddr gf ma = decoratePosObject zdec fn ma
where
fn ortt = moveStart (vtoRectAddress ortt raddr) gf
decoratePosObject :: InterpretUnit u
=> ZDeco -> (Orientation u -> LocGraphic u) -> GenPosObject st u a
-> GenPosObject st u a
decoratePosObject zdec fn ma = GenPosObject $ \ctx pt s ->
let (a,s1,o1,w1) = getGenPosObject ma ctx pt s
uortt = dinterpF (dc_font_size ctx) o1
upt = dinterpF (dc_font_size ctx) pt
(_,w2) = runLocImage ctx upt $ fn uortt
wout = case zdec of
ANTERIOR -> w2 `mappend` w1
SUPERIOR -> w1 `mappend` w2
in (a,s1,o1,wout)
extendPosObject :: InterpretUnit u
=> u -> u -> u -> u -> GenPosObject st u a
-> GenPosObject st u a
extendPosObject x0 x1 y0 y1 ma = GenPosObject $ \ctx pt s ->
let (a,s1,o1,w1) = getGenPosObject ma ctx pt s
sz = dc_font_size ctx
ux0 = normalize sz x0
ux1 = normalize sz x1
uy0 = normalize sz y0
uy1 = normalize sz y1
o2 = extendOrientation ux0 ux1 uy0 uy1 o1
in (a,s1,o2,w1)
mapOrientation :: InterpretUnit u
=> (Orientation u -> Orientation u)
-> GenPosObject st u a -> GenPosObject st u a
mapOrientation fn mf = GenPosObject $ \ctx pt s ->
let (a,s1,o1,w1) = getGenPosObject mf ctx pt s
uort = fn $ dinterpF (dc_font_size ctx) o1
o2 = normalizeF (dc_font_size ctx) uort
in (a,s1,o2,w1)
illustratePosObject :: InterpretUnit u
=> PosObject u a -> LocGraphic u
illustratePosObject mf = promoteLoc $ \pt ->
askDC >>= \ctx ->
let dpt = normalizeF (dc_font_size ctx) pt
(_,_,o1,w1) = getGenPosObject mf ctx dpt ()
uort = dinterpF (dc_font_size ctx) o1
in adecorate (primGraphic w1) (illustrateOrientation uort `at` pt)
illustrateOrientation :: InterpretUnit u
=> Orientation u -> LocGraphic u
illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteLoc $ \pt ->
dinterpCtx 3 >>= \radius ->
let upd = localize (fill_colour blue . dotted_line)
bl = pt .-^ V2 xmin ymin
dot = localize (fill_colour red) $ dcDisk DRAW_FILL radius `at` pt
hln = upd $ locStraightLine (hvec $ xmin+xmaj) `at` pt .-^ hvec xmin
vln = upd $ locStraightLine (vvec $ ymin+ymaj) `at` pt .-^ vvec ymin
bdr = upd $ dcRectangle DRAW_STROKE (xmin+xmaj) (ymin+ymaj) `at` bl
in mconcat [ bdr, hln, vln, dot ]
posChar :: InterpretUnit u
=> Char -> GenPosGraphic st u
posChar = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . CharLiteral
posEscChar :: InterpretUnit u
=> EscapedChar -> GenPosGraphic st u
posEscChar = makeCharPO CAP_HEIGHT_PLUS_DESCENDER
posCharUpright :: InterpretUnit u
=> Char -> GenPosGraphic st u
posCharUpright = makeCharPO JUST_CAP_HEIGHT . CharLiteral
posEscCharUpright :: InterpretUnit u
=> EscapedChar -> GenPosGraphic st u
posEscCharUpright = makeCharPO JUST_CAP_HEIGHT
posCharPrim :: InterpretUnit u
=> Either Char EscapedChar -> GenPosGraphic st u
posCharPrim = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . either CharLiteral id
makeCharPO :: InterpretUnit u
=> TextHeight -> EscapedChar -> GenPosGraphic st u
makeCharPO hspec esc =
makePosObject (charOrientation hspec esc)
(dcEscapedlabel $ wrapEscChar esc)
charOrientation :: (DrawingCtxM m, InterpretUnit u)
=> TextHeight -> EscapedChar -> m (Orientation u)
charOrientation hspec esc =
(\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj)
<$> escCharVector esc <*> heightSpan hspec
posText :: InterpretUnit u
=> String -> GenPosGraphic st u
posText = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER . escapeString
posEscText :: InterpretUnit u
=> EscapedText -> GenPosGraphic st u
posEscText = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER
posTextUpright :: InterpretUnit u
=> String -> GenPosGraphic st u
posTextUpright = addMargins . makeTextPO JUST_CAP_HEIGHT . escapeString
posEscTextUpright :: InterpretUnit u
=> EscapedText -> GenPosGraphic st u
posEscTextUpright = addMargins . makeTextPO JUST_CAP_HEIGHT
posTextPrim :: InterpretUnit u
=> Either String EscapedText -> GenPosGraphic st u
posTextPrim = makeTextPO CAP_HEIGHT_PLUS_DESCENDER . either escapeString id
multilinePosText :: (Fractional u, InterpretUnit u)
=> VAlign -> String -> PosGraphic u
multilinePosText vspec xs =
multilinePosEscText vspec $ map escapeString $ lines xs
multilinePosEscText :: (Fractional u, InterpretUnit u)
=> VAlign -> [EscapedText] -> GenPosGraphic st u
multilinePosEscText vspec xs = addMargins $ GenPosObject $ \ctx pt s ->
let sep = runQuery ctx textlineSpace
in getGenPosObject (body sep) ctx pt s
where
body sp = alignColumnSep vspec sp $
map (makeTextPO CAP_HEIGHT_PLUS_DESCENDER) xs
makeTextPO :: InterpretUnit u
=> TextHeight -> EscapedText -> GenPosGraphic st u
makeTextPO hspec esc =
makePosObject (textOrientationZero hspec esc) (dcEscapedlabel esc)
addMargins :: InterpretUnit u => GenPosObject st u a -> GenPosObject st u a
addMargins ma =
textMargin >>= \(xsep,ysep) -> extendPosObject xsep xsep ysep ysep ma
textOrientationZero :: (DrawingCtxM m, InterpretUnit u )
=> TextHeight -> EscapedText -> m (Orientation u)
textOrientationZero hspec esc =
(\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj)
<$> escTextVector esc <*> heightSpan hspec
rposText :: (Real u, Floating u, InterpretUnit u)
=> Radian -> String -> GenPosGraphic st u
rposText ang = addMargins . makeRotatedPO ang . escapeString
rposEscText :: (Real u, Floating u, InterpretUnit u)
=> Radian -> EscapedText -> GenPosGraphic st u
rposEscText ang = addMargins . makeRotatedPO ang
rposChar :: (Real u, Floating u, InterpretUnit u)
=> Radian -> Char -> GenPosGraphic st u
rposChar ang ch = rposEscText ang $ wrapEscChar $ CharLiteral ch
rposEscChar :: (Real u, Floating u, InterpretUnit u)
=> Radian -> EscapedChar -> GenPosGraphic st u
rposEscChar ang ch = rposEscText ang $ wrapEscChar ch
makeRotatedPO :: (Real u, Floating u, InterpretUnit u)
=> Radian -> EscapedText -> GenPosGraphic st u
makeRotatedPO ang esc = makePosObject qry body
where
qry = rotateOrientation ang <$>
textOrientationZero CAP_HEIGHT_PLUS_DESCENDER esc
body = incline (dcREscapedlabel esc) ang
posHKernText :: InterpretUnit u
=> [KernChar u] -> GenPosGraphic st u
posHKernText xs = makePosObject (hkernOrientationZero xs) (hkernLine xs)
monospaceText :: InterpretUnit u
=> Query u u -> String -> GenPosGraphic st u
monospaceText qry = monospaceEscText qry . escapeString
monospaceEscText :: InterpretUnit u
=> Query u u -> EscapedText -> GenPosGraphic st u
monospaceEscText qry esc = GenPosObject $ \ctx pt s ->
let upt = dinterpF (dc_font_size ctx) pt
uw = runQuery ctx qry
ks = monos uw $ destrEscapedText id esc
ortt = runQuery ctx $ hkernOrientationZero ks
dort = normalizeF (dc_font_size ctx) ortt
(_,w1) = runLocImage ctx upt $ hkernLine ks
in (UNil, s, dort, w1)
monos :: Num u => u -> [EscapedChar] -> [KernChar u]
monos w1 (c:cs) = (0,c) : map (\ch -> (w1,ch)) cs
monos _ [] = []
hkernOrientationZero :: (DrawingCtxM m, InterpretUnit u )
=> [KernChar u] -> m (Orientation u)
hkernOrientationZero xs =
(\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj)
<$> hkernVector xs <*> heightSpan CAP_HEIGHT_PLUS_DESCENDER
instance (Monoid a, InterpretUnit u) => ZConcat (GenPosObject st u a) where
superior = mappend
anterior = flip mappend
instance Monoid a => Concat (GenPosObject st u a) where
hconcat = genMoveAlign spinemoveH spineRight
vconcat = genMoveAlign spinemoveV spineBelow
instance (Monoid a, InterpretUnit u) => CatSpace (GenPosObject st u a) where
hspace = genMoveSepH spinemoveH spineRight
vspace = genMoveSepV spinemoveV spineBelow
instance Monoid a => Align (GenPosObject st u a) where
halign HALIGN_TOP = genMoveAlign binmoveHTop halignTopO
halign HALIGN_CENTER = genMoveAlign binmoveHCenter halignCenterO
halign HALIGN_BASE = genMoveAlign binmoveHBottom halignBottomO
valign VALIGN_LEFT = genMoveAlign binmoveVLeft valignLeftO
valign VALIGN_CENTER = genMoveAlign binmoveVCenter valignCenterO
valign VALIGN_RIGHT = genMoveAlign binmoveVRight valignRightO
genMoveAlign :: Monoid a
=> (Orientation Double -> Orientation Double -> Vec2 Double)
-> (Orientation Double -> Orientation Double -> Orientation Double)
-> GenPosObject st u a -> GenPosObject st u a -> GenPosObject st u a
genMoveAlign mkV mkO ma mb = GenPosObject $ \ctx pt s ->
let (a,s1,o1,w1) = getGenPosObject ma ctx pt s
(b,s2,o2,w2) = getGenPosObject mb ctx pt s1
v1 = mkV o1 o2
ortt = mkO o1 o2
w2' = cpmove v1 w2
in (a `mappend` b, s2, ortt, w1 `mappend` w2')
instance (Monoid a, InterpretUnit u) => AlignSpace (GenPosObject st u a) where
halignSpace HALIGN_TOP = genMoveSepH binmoveHTop halignTopO
halignSpace HALIGN_CENTER = genMoveSepH binmoveHCenter halignCenterO
halignSpace HALIGN_BASE = genMoveSepH binmoveHBottom halignBottomO
valignSpace VALIGN_LEFT = genMoveSepV binmoveVLeft valignLeftO
valignSpace VALIGN_CENTER = genMoveSepV binmoveVCenter valignCenterO
valignSpace VALIGN_RIGHT = genMoveSepV binmoveVRight valignRightO
genMoveSepH :: (Monoid a, InterpretUnit u)
=> (Orientation Double -> Orientation Double -> Vec2 Double)
-> (Orientation Double -> Orientation Double -> Orientation Double)
-> u
-> GenPosObject st u a -> GenPosObject st u a
-> GenPosObject st u a
genMoveSepH mkV mkO sep ma mb = GenPosObject $ \ctx pt s ->
let (a,s1,o1,w1) = getGenPosObject ma ctx pt s
(b,s2,o2,w2) = getGenPosObject mb ctx pt s1
dsep = normalize (dc_font_size ctx) sep
v1 = hvec dsep ^+^ mkV o1 o2
ortt = extendORight dsep $ mkO o1 o2
w2' = cpmove v1 w2
in (a `mappend` b, s2, ortt, w1 `mappend` w2')
genMoveSepV :: (Monoid a, InterpretUnit u)
=> (Orientation Double -> Orientation Double -> Vec2 Double)
-> (Orientation Double -> Orientation Double -> Orientation Double)
-> u
-> GenPosObject st u a -> GenPosObject st u a
-> GenPosObject st u a
genMoveSepV mkV mkO sep ma mb = GenPosObject $ \ctx pt s ->
let (a,s1,o1,w1) = getGenPosObject ma ctx pt s
(b,s2,o2,w2) = getGenPosObject mb ctx pt s1
dsep = normalize (dc_font_size ctx) sep
v1 = vvec (dsep) ^+^ mkV o1 o2
ortt = extendODown dsep $ mkO o1 o2
w2' = cpmove v1 w2
in (a `mappend` b, s2, ortt, w1 `mappend` w2')