module Wumpus.Basic.Kernel.Objects.AdvObject
(
AdvanceVec
, advanceH
, advanceV
, AdvObject
, DAdvObject
, AdvGraphic
, DAdvGraphic
, runAdvObject
, makeAdvObject
, emptyAdvObject
, blankAdvObject
, advance
, advances
, advspace
, evenspace
, advrepeat
, punctuate
, advfill
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.WrappedPrimitive
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Basic.Kernel.Objects.Image
import Wumpus.Basic.Kernel.Objects.LocImage
import Wumpus.Core
import Data.VectorSpace
import Control.Applicative
import Data.Monoid
type AdvanceVec u = Vec2 u
advanceH :: AdvanceVec u -> u
advanceH (V2 w _) = w
advanceV :: AdvanceVec u -> u
advanceV (V2 _ h) = h
newtype DAV = DAV { getDAV :: AdvanceVec Double }
instance Monoid DAV where
mempty = DAV $ V2 0 0
DAV v1 `mappend` DAV v2 = DAV $ v1 ^+^ v2
newtype AdvObject u a = AdvObject
{ getAdvObject :: DrawingContext -> DPoint2 -> (a, DAV, CatPrim) }
type instance DUnit (AdvObject u a) = u
type DAdvObject a = AdvObject Double a
type AdvGraphic u = AdvObject u (UNil u)
type DAdvGraphic = AdvGraphic Double
instance Functor (AdvObject u) where
fmap f mf = AdvObject $ \ctx pt ->
let (a,v1,w1) = getAdvObject mf ctx pt in (f a,v1,w1)
instance Applicative (AdvObject u) where
pure a = AdvObject $ \_ _ -> (a,mempty,mempty)
mf <*> ma = AdvObject $ \ctx pt ->
let (f,v1,w1) = getAdvObject mf ctx pt
(a,v2,w2) = getAdvObject ma ctx pt
in (f a, v1 `mappend` v2, w1 `mappend` w2)
instance Monad (AdvObject u) where
return a = AdvObject $ \_ _ -> (a,mempty,mempty)
mf >>= k = AdvObject $ \ctx pt ->
let (a,v1,w1) = getAdvObject mf ctx pt
(b,v2,w2) = getAdvObject (k a) ctx pt
in (b, v1 `mappend` v2, w1 `mappend` w2)
instance DrawingCtxM (AdvObject u) where
askDC = AdvObject $ \ctx _ -> (ctx, mempty, mempty)
asksDC fn = AdvObject $ \ctx _ -> (fn ctx, mempty, mempty)
localize upd ma = AdvObject $ \ctx pt -> getAdvObject ma (upd ctx) pt
instance (Monoid a, InterpretUnit u) => Monoid (AdvObject u a) where
mempty = AdvObject $ \_ _ -> (mempty, mempty, mempty)
ma `mappend` mb = AdvObject $ \ctx pt ->
let (a,v1,w1) = getAdvObject ma ctx pt
(b,v2,w2) = getAdvObject mb ctx pt
w2r = cpmove (getDAV v1) w2
in (a `mappend` b, v1 `mappend` v2, w1 `mappend` w2r)
runAdvObject :: InterpretUnit u
=> AdvObject u a -> LocImage u a
runAdvObject ma = promoteLoc $ \ot ->
askDC >>= \ctx ->
let dot = normalizeF (dc_font_size ctx) ot
(a,_,ca) = getAdvObject ma ctx dot
in replaceAns a $ primGraphic ca
makeAdvObject :: InterpretUnit u
=> Query u (Vec2 u) -> LocImage u a -> AdvObject u a
makeAdvObject ma gf = AdvObject $ \ctx pt ->
let v1 = runQuery ctx ma
dav1 = DAV $ normalizeF (dc_font_size ctx) v1
upt = dinterpF (dc_font_size ctx) pt
(a,w) = runLocImage ctx upt gf
in (a,dav1,w)
emptyAdvObject :: (Monoid a, InterpretUnit u) => AdvObject u a
emptyAdvObject = mempty
blankAdvObject :: (Monoid a, InterpretUnit u)
=> Vec2 u -> AdvObject u a
blankAdvObject v1 = AdvObject $ \ctx _ ->
let dav1 = DAV $ normalizeF (dc_font_size ctx) v1
in (mempty, dav1, mempty)
listcat :: (Monoid a, InterpretUnit u)
=> (AdvObject u a -> AdvObject u a -> AdvObject u a)
-> [AdvObject u a] -> AdvObject u a
listcat _ [] = mempty
listcat op (x:xs) = go x xs
where
go acc [] = acc
go acc (b:bs) = go (acc `op` b) bs
infixr 6 `advance`
advance :: (Monoid a, InterpretUnit u)
=> AdvObject u a -> AdvObject u a -> AdvObject u a
advance = mappend
advances :: (Monoid a, InterpretUnit u)
=> [AdvObject u a] -> AdvObject u a
advances = mconcat
advspace :: (Monoid a, InterpretUnit u)
=> Vec2 u -> AdvObject u a -> AdvObject u a -> AdvObject u a
advspace sep a b = a `mappend` blank `mappend` b
where
blank = blankAdvObject sep
evenspace :: (Monoid a, InterpretUnit u)
=> Vec2 u -> [AdvObject u a] -> AdvObject u a
evenspace v = listcat (advspace v)
advrepeat :: (Monoid a, InterpretUnit u)
=> Int -> AdvObject u a -> AdvObject u a
advrepeat n = advances . replicate n
punctuate :: (Monoid a, InterpretUnit u)
=> AdvObject u a -> [AdvObject u a] -> AdvObject u a
punctuate sep = listcat (\a b -> a `advance` sep `advance` b)
advfill :: InterpretUnit u
=> Vec2 u -> AdvObject u a -> AdvObject u a
advfill sv mf = AdvObject $ \ctx pt ->
let (a,_,ca) = getAdvObject mf ctx pt
dav1 = DAV $ normalizeF (dc_font_size ctx) sv
in (a,dav1,ca)