module Wumpus.Basic.Kernel.Objects.PosObject
(
PosObject
, DPosObject
, PosGraphic
, DPosGraphic
, runPosObject
, runPosObjectBBox
, makePosObject
, emptyPosObject
, elaboratePosObject
, decoratePosObject
, extendPosObject
, mapOrientation
, illustratePosObject
, posChar
, posEscChar
, posCharUpright
, posEscCharUpright
, posCharPrim
, posText
, posEscText
, posTextUpright
, posEscTextUpright
, posTextPrim
, multilinePosText
, multilinePosEscText
, rposText
, rposEscText
, 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.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 PosObject u a = PosObject
{ getPosObject :: DrawingContext -> DPoint2 -> (a, DOrt, CatPrim) }
type instance DUnit (PosObject u a) = u
type DPosObject a = PosObject Double a
type PosGraphic u = PosObject u (UNil u)
type DPosGraphic = PosGraphic Double
instance Functor (PosObject u) where
fmap f mf = PosObject $ \ctx pt ->
let (a,o1,w1) = getPosObject mf ctx pt in (f a,o1,w1)
instance Applicative (PosObject u) where
pure a = PosObject $ \_ _ -> (a,mempty,mempty)
mf <*> ma = PosObject $ \ctx pt ->
let (f,o1,w1) = getPosObject mf ctx pt
(a,o2,w2) = getPosObject ma ctx pt
in (f a, o1 `mappend` o2, w1 `mappend` w2)
instance Monad (PosObject u) where
return a = PosObject $ \_ _ -> (a,mempty,mempty)
mf >>= k = PosObject $ \ctx pt ->
let (a,o1,w1) = getPosObject mf ctx pt
(b,o2,w2) = getPosObject (k a) ctx pt
in (b, o1 `mappend` o2, w1 `mappend` w2)
instance DrawingCtxM (PosObject u) where
askDC = PosObject $ \ctx _ -> (ctx, mempty, mempty)
asksDC fn = PosObject $ \ctx _ -> (fn ctx, mempty, mempty)
localize upd ma = PosObject $ \ctx pt -> getPosObject ma (upd ctx) pt
instance (Monoid a, InterpretUnit u) => Monoid (PosObject u a) where
mempty = PosObject $ \_ _ -> (mempty, mempty, mempty)
ma `mappend` mb = PosObject $ \ctx pt ->
let (a,o1,w1) = getPosObject ma ctx pt
(b,o2,w2) = getPosObject mb ctx pt
in (a `mappend` b, o1 `mappend` o2, w1 `mappend` w2)
runPosObject :: InterpretUnit u
=> PosObject u a -> RectAddress -> LocImage u a
runPosObject ma addr = promoteLoc $ \ot ->
askDC >>= \ctx ->
let dot = normalizeF (dc_font_size ctx) ot
(a,o1,ca) = getPosObject ma ctx dot
v1 = vtoOrigin addr o1
in replaceAns a $ primGraphic $ cpmove v1 ca
runPosObjectBBox :: InterpretUnit u
=> PosObject u a -> RectAddress -> LocImage u (BoundingBox u)
runPosObjectBBox ma addr = promoteLoc $ \pt ->
askDC >>= \ctx ->
let sz = dc_font_size ctx
dpt = normalizeF sz pt
(_,o1,w1) = getPosObject 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 -> PosObject u a
makePosObject ma gf = PosObject $ \ctx pt ->
let ort1 = runQuery ma ctx
dort1 = normalizeF (dc_font_size ctx) ort1
upt = dinterpF (dc_font_size ctx) pt
(a,w) = runLocImage gf ctx upt
in (a,dort1,w)
emptyPosObject :: (Monoid a, InterpretUnit u) => PosObject u a
emptyPosObject = PosObject $ \_ _ -> (mempty, mempty, mempty)
elaboratePosObject :: (Fractional u, Ord u, InterpretUnit u)
=> ZDeco -> RectAddress -> LocGraphic u -> PosObject u a
-> PosObject 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) -> PosObject u a
-> PosObject u a
decoratePosObject zdec fn ma = PosObject $ \ctx pt ->
let (a,o1,w1) = getPosObject ma ctx pt
uortt = dinterpF (dc_font_size ctx) o1
upt = dinterpF (dc_font_size ctx) pt
(_,w2) = runLocImage (fn uortt) ctx upt
wout = case zdec of
ANTERIOR -> w2 `mappend` w1
SUPERIOR -> w1 `mappend` w2
in (a,o1,wout)
extendPosObject :: InterpretUnit u
=> u -> u -> u -> u -> PosObject u a -> PosObject u a
extendPosObject x0 x1 y0 y1 ma = PosObject $ \ctx pt ->
let (a,o1,w1) = getPosObject ma ctx pt
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,o2,w1)
mapOrientation :: InterpretUnit u
=> (Orientation u -> Orientation u)
-> PosObject u a -> PosObject u a
mapOrientation fn mf = PosObject $ \ctx pt ->
let (a,o1,w1) = getPosObject mf ctx pt
uort = fn $ dinterpF (dc_font_size ctx) o1
o2 = normalizeF (dc_font_size ctx) uort
in (a,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) = getPosObject 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 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 STROKE (xmin+xmaj) (ymin+ymaj) `at` bl
in mconcat [ bdr, hln, vln, dot ]
posChar :: InterpretUnit u => Char -> PosGraphic u
posChar = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . CharLiteral
posEscChar :: InterpretUnit u => EscapedChar -> PosGraphic u
posEscChar = makeCharPO CAP_HEIGHT_PLUS_DESCENDER
posCharUpright :: InterpretUnit u => Char -> PosGraphic u
posCharUpright = makeCharPO JUST_CAP_HEIGHT . CharLiteral
posEscCharUpright :: InterpretUnit u => EscapedChar -> PosGraphic u
posEscCharUpright = makeCharPO JUST_CAP_HEIGHT
posCharPrim :: InterpretUnit u
=> Either Char EscapedChar -> PosGraphic u
posCharPrim = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . either CharLiteral id
makeCharPO :: InterpretUnit u
=> TextHeight -> EscapedChar -> PosGraphic 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 -> PosGraphic u
posText = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER . escapeString
posEscText :: InterpretUnit u => EscapedText -> PosGraphic u
posEscText = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER
posTextUpright :: InterpretUnit u => String -> PosGraphic u
posTextUpright = addMargins . makeTextPO JUST_CAP_HEIGHT . escapeString
posEscTextUpright :: InterpretUnit u => EscapedText -> PosGraphic u
posEscTextUpright = addMargins . makeTextPO JUST_CAP_HEIGHT
posTextPrim :: InterpretUnit u
=> Either String EscapedText -> PosGraphic 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] -> PosGraphic u
multilinePosEscText vspec xs =
addMargins $ PosObject $ \ctx pt ->
let sep = runQuery textlineSpace ctx
in getPosObject (body sep) ctx pt
where
body sp = alignColumnSep vspec sp $
map (makeTextPO CAP_HEIGHT_PLUS_DESCENDER) xs
makeTextPO :: InterpretUnit u
=> TextHeight -> EscapedText -> PosGraphic u
makeTextPO hspec esc =
makePosObject (textOrientationZero hspec esc) (dcEscapedlabel esc)
addMargins :: InterpretUnit u => PosObject u a -> PosObject 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 -> PosGraphic u
rposText ang = addMargins . makeRotatedPO ang . escapeString
rposEscText :: (Real u, Floating u, InterpretUnit u)
=> Radian -> EscapedText -> PosGraphic u
rposEscText ang = addMargins . makeRotatedPO ang
makeRotatedPO :: (Real u, Floating u, InterpretUnit u)
=> Radian -> EscapedText -> PosGraphic 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] -> PosGraphic u
posHKernText xs = makePosObject (hkernOrientationZero xs) (hkernLine xs)
monospaceText :: InterpretUnit u
=> Query u u -> String -> PosGraphic u
monospaceText qry = monospaceEscText qry . escapeString
monospaceEscText :: InterpretUnit u
=> Query u u -> EscapedText -> PosGraphic u
monospaceEscText qry esc = PosObject $ \ctx pt ->
let upt = dinterpF (dc_font_size ctx) pt
uw = runQuery qry ctx
ks = monos uw $ destrEscapedText id esc
ortt = runQuery (hkernOrientationZero ks) ctx
dort = normalizeF (dc_font_size ctx) ortt
(_,w1) = runLocImage (hkernLine ks) ctx upt
in (UNil, 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 (PosObject u a) where
superior = mappend
anterior = flip mappend
instance Monoid a => Concat (PosObject u a) where
hconcat = genMoveAlign spinemoveH spineRight
vconcat = genMoveAlign spinemoveV spineBelow
instance (Monoid a, InterpretUnit u) => CatSpace (PosObject u a) where
hspace = genMoveSepH spinemoveH spineRight
vspace = genMoveSepV spinemoveV spineBelow
instance Monoid a => Align (PosObject 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)
-> PosObject u a -> PosObject u a -> PosObject u a
genMoveAlign mkV mkO ma mb = PosObject $ \ctx pt ->
let (a,o1,w1) = getPosObject ma ctx pt
(b,o2,w2) = getPosObject mb ctx pt
v1 = mkV o1 o2
ortt = mkO o1 o2
w2' = cpmove v1 w2
in (a `mappend` b, ortt, w1 `mappend` w2')
instance (Monoid a, InterpretUnit u) => AlignSpace (PosObject 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
-> PosObject u a -> PosObject u a -> PosObject u a
genMoveSepH mkV mkO sep ma mb = PosObject $ \ctx pt ->
let (a,o1,w1) = getPosObject ma ctx pt
(b,o2,w2) = getPosObject mb ctx pt
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, ortt, w1 `mappend` w2')
genMoveSepV :: (Monoid a, InterpretUnit u)
=> (Orientation Double -> Orientation Double -> Vec2 Double)
-> (Orientation Double -> Orientation Double -> Orientation Double)
-> u
-> PosObject u a -> PosObject u a -> PosObject u a
genMoveSepV mkV mkO sep ma mb = PosObject $ \ctx pt ->
let (a,o1,w1) = getPosObject ma ctx pt
(b,o2,w2) = getPosObject mb ctx pt
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, ortt, w1 `mappend` w2')