module Wumpus.Drawing.Paths.PathBuilder
(
GenPathSpec
, PathSpec
, Vamp(..)
, runGenPathSpec
, execGenPathSpec
, evalGenPathSpec
, stripGenPathSpec
, runPathSpec
, runPathSpec_
, runPivot
, penline
, pencurve
, breakPath
, hpenline
, vpenline
, apenline
, penlines
, pathmoves
, vamp
, cycleSubPath
, updatePen
) where
import Wumpus.Drawing.Paths.Base
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.AffineSpace
import Data.VectorSpace
import Control.Applicative
import Control.Monad
import Data.Monoid
import Prelude hiding ( null, cycle, lines )
newtype GenPathSpec st u a = GenPathSpec {
getGenPathSpec :: DrawingContext -> PathSt st -> (a, PathSt st, CatPrim) }
type instance DUnit (GenPathSpec st u a) = u
type instance UState (GenPathSpec st u) = st
type PathSpec u a = GenPathSpec () u a
data PathSt st = PathSt
{ st_active_pen :: ActivePen
, st_pen_ctx :: DrawingContext
, st_cumulative_path :: AbsPath Double
, st_user_state :: st
}
data ActivePen = PEN_UP
| PEN_DOWN (AbsPath Double)
zeroActivePen :: DPoint2 -> ActivePen
zeroActivePen pt = PEN_DOWN (emptyPath pt)
data Vamp u = Vamp
{ vamp_move :: Vec2 u
, vamp_conn :: ConnectorGraphic u
}
type instance DUnit (Vamp u) = u
instance Functor (GenPathSpec st u) where
fmap f ma = GenPathSpec $ \ctx s ->
let (a,s1,w1) = getGenPathSpec ma ctx s
in (f a,s1,w1)
instance Applicative (GenPathSpec st u) where
pure a = GenPathSpec $ \_ s -> (a, s, mempty)
mf <*> ma = GenPathSpec $ \ctx s ->
let (f,s1,w1) = getGenPathSpec mf ctx s
(a,s2,w2) = getGenPathSpec ma ctx s1
in (f a, s2, w1 `mappend` w2)
instance Monad (GenPathSpec st u) where
return a = GenPathSpec $ \_ s -> (a, s, mempty)
ma >>= k = GenPathSpec $ \ctx s ->
let (a,s1,w1) = getGenPathSpec ma ctx s
(b,s2,w2) = (getGenPathSpec . k) a ctx s1
in (b, s2, w1 `mappend` w2)
instance Monoid a => Monoid (GenPathSpec st u a) where
mempty = GenPathSpec $ \_ s -> (mempty, s, mempty)
ma `mappend` mb = GenPathSpec $ \ctx s ->
let (a,s1,w1) = getGenPathSpec ma ctx s
(b,s2,w2) = getGenPathSpec mb ctx s1
in (a `mappend` b, s2, w1 `mappend` w2)
instance DrawingCtxM (GenPathSpec st u) where
askDC = GenPathSpec $ \ctx s -> (ctx, s, mempty)
asksDC f = GenPathSpec $ \ctx s -> (f ctx, s, mempty)
localize upd ma = GenPathSpec $ \ctx s ->
getGenPathSpec ma (upd ctx) s
instance UserStateM (GenPathSpec st u) where
getState = GenPathSpec $ \_ s ->
(st_user_state s, s, mempty)
setState ust = GenPathSpec $ \_ s ->
((), s {st_user_state = ust} , mempty)
updateState upd = GenPathSpec $ \_ s ->
let ust = st_user_state s
in ((), s {st_user_state = upd ust}, mempty)
instance InterpretUnit u => LocationM (GenPathSpec st u) where
location = locationImpl
instance InterpretUnit u => CursorM (GenPathSpec st u) where
moveby = movebyImpl
instance InterpretUnit u => InsertlM (GenPathSpec st u) where
insertl = insertlImpl
runGenPathSpec :: InterpretUnit u
=> st -> PathMode -> GenPathSpec st u a
-> LocImage u (a, st, AbsPath u)
runGenPathSpec st mode ma = promoteLoc $ \pt ->
askDC >>= \ctx ->
let P2 dx dy = normalizeF (dc_font_size ctx) pt
st_zero = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) st
(a,s1,w1) = getGenPathSpec ma ctx st_zero
dpath = translate dx dy $ st_cumulative_path s1
upath = dinterpF (dc_font_size ctx) dpath
pctx = st_pen_ctx s1
(_,w2) = runImage pctx (drawActivePen mode $ st_active_pen s1)
wfinal = cpmove (V2 dx dy) $ w1 `mappend` w2
in replaceAns (a, st_user_state s1, upath) $ primGraphic wfinal
evalGenPathSpec :: InterpretUnit u
=> st -> PathMode -> GenPathSpec st u a
-> LocImage u (a, AbsPath u)
evalGenPathSpec st mode ma =
(\(a,_,w) -> (a,w)) <$> runGenPathSpec st mode ma
execGenPathSpec :: InterpretUnit u
=> st -> PathMode -> GenPathSpec st u a
-> LocImage u (st, AbsPath u)
execGenPathSpec st mode ma =
(\(_,s,w) -> (s,w)) <$> runGenPathSpec st mode ma
stripGenPathSpec :: InterpretUnit u
=> st -> PathMode -> GenPathSpec st u a
-> LocQuery u (a, st, AbsPath u)
stripGenPathSpec st mode ma = stripLocImage $ runGenPathSpec st mode ma
runPathSpec :: InterpretUnit u
=> PathMode -> PathSpec u a -> LocImage u (a, AbsPath u)
runPathSpec mode ma = evalGenPathSpec () mode ma
runPathSpec_ :: InterpretUnit u
=> PathMode -> PathSpec u a -> LocGraphic u
runPathSpec_ mode ma = ignoreAns $ evalGenPathSpec () mode ma
drawActivePen :: PathMode -> ActivePen -> DGraphic
drawActivePen _ PEN_UP = mempty
drawActivePen mode (PEN_DOWN abs_path) = drawPath_ mode abs_path
runPivot :: (Floating u, InterpretUnit u)
=> PathSpec u a -> PathSpec u a -> LocGraphic u
runPivot ma mb = promoteLoc $ \pt ->
askDC >>= \ctx ->
let dpt = normalizeF (dc_font_size ctx) pt
st_zero = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) ()
(p1,s1,w1) = getGenPathSpec mz ctx st_zero
dp1 = normalizeF (dc_font_size ctx) p1
v1 = pvec dpt dp1
pctx = st_pen_ctx s1
(_,w2) = runImage pctx $ drawActivePen OSTROKE $ st_active_pen s1
wfinal = w1 `mappend` w2
in primGraphic $ cpmove (negateV v1) wfinal
where
mz = ma >> location >>= \pt -> mb >> return pt
locationImpl :: InterpretUnit u => GenPathSpec st u (Point2 u)
locationImpl = GenPathSpec $ \ctx s ->
let pt = tipR $ st_cumulative_path s
upt = dinterpF (dc_font_size ctx) pt
in (upt, s, mempty)
extendPaths :: DVec2 -> PathSt st -> PathSt st
extendPaths v1 s@(PathSt { st_cumulative_path = cp
, st_active_pen = pen} ) =
s { st_cumulative_path = snocLine cp v1, st_active_pen = upd pen }
where
upd PEN_UP = let pt = tipR cp in PEN_DOWN $ line1 pt (pt .+^ v1)
upd (PEN_DOWN absp) = PEN_DOWN $ snocLine absp v1
penline :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()
penline v1 = GenPathSpec $ \ctx s ->
let sz = dc_font_size ctx
dv1 = normalizeF sz v1
in ((), extendPaths dv1 s, mempty)
extendPathsC :: DVec2 -> DVec2 -> DVec2 -> PathSt st -> PathSt st
extendPathsC v1 v2 v3 s@(PathSt { st_cumulative_path = cp
, st_active_pen = pen} ) =
s { st_cumulative_path = snocCurve cp (v1,v2,v3), st_active_pen = upd pen }
where
upd PEN_UP = let p0 = tipR cp
p1 = p0 .+^ v1
p2 = p1 .+^ v2
p3 = p2 .+^ v3
in PEN_DOWN $ curve1 p0 p1 p2 p3
upd (PEN_DOWN absp) = PEN_DOWN $ snocCurve absp (v1,v2,v3)
pencurve :: InterpretUnit u
=> Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u ()
pencurve v1 v2 v3 = GenPathSpec $ \ctx s ->
let sz = dc_font_size ctx
dv1 = normalizeF sz v1
dv2 = normalizeF sz v2
dv3 = normalizeF sz v3
in ((), extendPathsC dv1 dv2 dv3 s, mempty)
movebyImpl :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()
movebyImpl v1 = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) ->
let sz = dc_font_size ctx
dv1 = normalizeF sz v1
(_,w1) = runImage pctx $ drawActivePen OSTROKE $ st_active_pen s
cpath = snocLine (st_cumulative_path s) dv1
in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath }, w1)
breakPath :: InterpretUnit u => GenPathSpec st u ()
breakPath = movebyImpl (V2 0 0)
hpenline :: InterpretUnit u => u -> GenPathSpec st u ()
hpenline dx = penline (hvec dx)
vpenline :: InterpretUnit u => u -> GenPathSpec st u ()
vpenline dy = penline (vvec dy)
apenline :: (Floating u, InterpretUnit u)
=> Radian -> u -> GenPathSpec st u ()
apenline ang d = penline (avec ang d)
penlines :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()
penlines = mapM_ penline
pathmoves :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u ()
pathmoves = mapM_ moveby
insertlImpl :: InterpretUnit u
=> LocImage u a -> GenPathSpec st u a
insertlImpl gf = GenPathSpec $ \ctx s ->
let upt = dinterpF (dc_font_size ctx) (tipR $ st_cumulative_path s)
(a,wcp) = runLocImage ctx upt gf
in (a, s, wcp)
vamp :: InterpretUnit u => Vamp u -> GenPathSpec st u ()
vamp (Vamp v1 conn) = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) ->
let sz = dc_font_size ctx
dv1 = normalizeF sz v1
(_,w1) = runImage pctx $ drawActivePen OSTROKE $ st_active_pen s
upt = dinterpF sz (tipR $ st_cumulative_path s)
(_,w2) = runConnectorImage ctx upt (upt .+^ v1) conn
cpath = snocLine (st_cumulative_path s) dv1
in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath }
, w1 `mappend` w2)
cycleSubPath :: DrawMode -> GenPathSpec st u ()
cycleSubPath mode = GenPathSpec $ \_ s@(PathSt {st_pen_ctx = pctx}) ->
let (_,w1) = runImage pctx $ drawActivePen (fn mode) (st_active_pen s)
in ((), s { st_active_pen = PEN_UP }, w1)
where
fn DRAW_STROKE = CSTROKE
fn DRAW_FILL = CFILL
fn DRAW_FILL_STROKE = CFILL_STROKE
updatePen :: DrawingContextF -> GenPathSpec st u ()
updatePen upd = GenPathSpec $ \_ s@(PathSt { st_pen_ctx = pctx}) ->
((), s { st_pen_ctx = upd pctx}, mempty )