module Wumpus.Drawing.Paths.Base.RelBuilder
(
RelBuild
, runRelBuild
, execRelBuild
, evalRelBuild
, execPivot
, tip
, line
, curve
, move
, insert
, vamp
, cycle
, setIncline
, pivot
, pen_colour
, pen_width
, hline
, vline
, aline
, hmove
, vmove
, amove
, line_up
, line_down
, line_left
, line_right
, line_up_left
, line_up_right
, line_down_left
, line_down_right
, line_north
, line_south
, line_east
, line_west
, line_northeast
, line_northwest
, line_southeast
, line_southwest
, move_up
, move_down
, move_left
, move_right
, move_up_left
, move_up_right
, move_down_left
, move_down_right
, move_north
, move_south
, move_east
, move_west
, move_northeast
, move_northwest
, move_southeast
, move_southwest
) where
import Wumpus.Drawing.Paths.Base.BuildCommon
import Wumpus.Drawing.Paths.Base.RelPath
import qualified Wumpus.Drawing.Paths.Base.RelPath as R
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.VectorSpace
import Control.Applicative
import Data.Monoid
import Prelude hiding ( null, log, cycle )
data St u = St
{ cumulative_disp :: Vec2 u
, cumulative_path :: RelPath u
, current_incline :: Radian
, active_path :: (Vec2 u, RelPath u)
, pen_dc_modifier :: DrawingContextF
, pivot_position :: Vec2 u
}
type instance DUnit (St u) = u
type Log u = BuildLog (LocGraphic u)
data RelBuild u a = RelBuild { getRelBuild :: St u -> (a, St u, Log u) }
type instance DUnit (RelBuild u a) = u
instance Functor (RelBuild u) where
fmap f mf = RelBuild $ \s0 -> let (a, s1, w) = getRelBuild mf s0
in (f a, s1, w)
instance Applicative (RelBuild u) where
pure a = RelBuild $ \s0 -> (a, s0, mempty)
mf <*> ma = RelBuild $ \s0 ->
let (f,s1,w1) = getRelBuild mf s0
(a,s2,w2) = getRelBuild ma s1
in (f a, s2, w1 `mappend` w2)
instance Monad (RelBuild u) where
return a = RelBuild $ \s0 -> (a, s0, mempty)
ma >>= k = RelBuild $ \s0 ->
let (a,s1,w1) = getRelBuild ma s0
(b,s2,w2) = (getRelBuild . k) a s1
in (b, s2, w1 `mappend` w2)
zeroSt :: Num u => St u
zeroSt = St { cumulative_disp = V2 0 0
, cumulative_path = mempty
, current_incline = 0
, active_path = (V2 0 0, mempty)
, pen_dc_modifier = id
, pivot_position = V2 0 0
}
runBuildMonad :: (Floating u, InterpretUnit u)
=> RelBuild u a -> (a, St u, LocGraphic u)
runBuildMonad mf = post $ getRelBuild mf zeroSt
where
post (a,st,log) = (a, st, pen `oplus` ins)
where
(v1,sub_last) = active_path st
cf = pen_dc_modifier st
log_last = logSubPath PATH_OPEN cf v1 sub_last
log2 = log `mappend` log_last
(pen,ins) = extractTrace emptyLocGraphic log2
runRelBuild :: (Floating u, InterpretUnit u)
=> RelBuild u a -> (RelPath u, LocGraphic u)
runRelBuild mf = post $ runBuildMonad mf
where
post (_,st,gf) = (cumulative_path st,gf)
execRelBuild :: (Floating u, InterpretUnit u)
=> RelBuild u a -> LocGraphic u
execRelBuild mf = snd $ runRelBuild mf
evalRelBuild :: (Floating u, InterpretUnit u)
=> RelBuild u a -> RelPath u
evalRelBuild mf = fst $ runRelBuild mf
execPivot :: (Floating u, InterpretUnit u)
=> RelBuild u a -> LocGraphic u
execPivot mf = post $ runBuildMonad mf
where
post (_,st,gf) = let v1 = pivot_position st
in moveStart (displaceVec $ vreverse v1) gf
logSubPath :: InterpretUnit u
=> PathEnd -> DrawingContextF -> Vec2 u -> RelPath u -> Log u
logSubPath spe upd v1 subp
| R.null subp = mempty
| otherwise = pen1 gf
where
drawF = if spe == PATH_OPEN then openStroke else closedStroke
gf = promoteR1 $ \pt ->
toPrimPath (displaceVec v1 pt) subp >>= \pp ->
localize upd (drawF pp)
tellSubClosed :: InterpretUnit u
=> DrawingContextF -> Vec2 u -> RelPath u -> RelBuild u ()
tellSubClosed upd v1 subp =
RelBuild $ \s0 -> ((), s0, logSubPath PATH_CLOSED upd v1 subp)
tellSubOpen :: InterpretUnit u
=> DrawingContextF -> Vec2 u -> RelPath u -> RelBuild u ()
tellSubOpen upd v1 subp =
RelBuild $ \s0 -> ((), s0, logSubPath PATH_OPEN upd v1 subp)
tellInsert :: LocGraphic u -> RelBuild u ()
tellInsert g1 =
RelBuild $ \s0 -> ((),s0, insert1 g1)
sets_ :: (St u -> St u) -> RelBuild u ()
sets_ f = RelBuild $ \s0 -> ((), f s0, mempty)
gets :: (St u -> a) -> RelBuild u a
gets f = RelBuild $ \s0 -> (f s0, s0, mempty)
tip :: RelBuild u (Vec2 u)
tip = gets cumulative_disp
extendPath :: Num u
=> (Vec2 u -> RelPath u -> RelPath u) -> Vec2 u -> RelBuild u ()
extendPath fn v1 = sets_ upd
where
upd = (\s v0 i j -> s { cumulative_disp = v0 ^+^ v1
, cumulative_path = fn v0 i
, active_path = bimapR (fn v0) j })
<*> cumulative_disp <*> cumulative_path <*> active_path
line :: Floating u => Vec2 u -> RelBuild u ()
line v1 = extendPath (\_ acc -> snocLineTo acc v1) v1
curve :: Floating u => Vec2 u -> Vec2 u -> Vec2 u -> RelBuild u ()
curve v1 v2 v3 = extendPath (\_ acc -> snocCurveTo acc v1 v2 v3) v3
move :: (Floating u, InterpretUnit u) => Vec2 u -> RelBuild u ()
move v1 =
gets active_path >>= \(v0,ans) ->
gets pen_dc_modifier >>= \cf ->
tellSubOpen cf v0 ans >> sets_ upd
where
upd = (\s v0 i -> s { cumulative_disp = v0 ^+^ v1
, cumulative_path = snocLineTo i v1
, active_path = (v0 ^+^ v1, mempty) })
<*> cumulative_disp <*> cumulative_path
insert :: Num u => LocGraphic u -> RelBuild u ()
insert gf = gets cumulative_disp >>= \v ->
tellInsert (moveStart (displaceVec v) gf)
penCtxUpdate :: (Floating u, InterpretUnit u)
=> DrawingContextF -> RelBuild u ()
penCtxUpdate cf = move (V2 0 0) >> sets_ upd
where
upd = (\s f -> s { pen_dc_modifier = cf . f }) <*> pen_dc_modifier
vamp :: (Floating u, Ord u, Tolerance u, InterpretUnit u)
=> Vamp u -> RelBuild u ()
vamp (Vamp vnext vstart upd relp path_end) =
gets cumulative_disp >>= \v0 ->
gets pen_dc_modifier >>= \cf ->
move vnext >> drawF (upd . cf) (v0 ^+^ vstart) relp
where
drawF = if path_end == PATH_OPEN then tellSubOpen else tellSubClosed
cycle :: (Floating u, InterpretUnit u) => RelBuild u ()
cycle =
gets cumulative_disp >>= \v1 ->
gets pen_dc_modifier >>= \cf ->
gets active_path >>= \(start,acc) ->
tellSubClosed cf start (snocLineTo acc start) >>
sets_ (\s -> s { active_path = (v1, mempty)})
setIncline :: Radian -> RelBuild u ()
setIncline ang = sets_ upd
where
upd = (\s -> s { current_incline = ang })
pivot :: RelBuild u ()
pivot = sets_ upd
where
upd = (\s i -> s { pivot_position = i }) <*> cumulative_disp
pen_colour :: (Floating u, InterpretUnit u)
=> RGBi -> RelBuild u ()
pen_colour rgb = penCtxUpdate (stroke_colour rgb)
pen_width :: (Floating u, InterpretUnit u)
=> Double -> RelBuild u ()
pen_width d = penCtxUpdate (set_line_width d)
hline :: Floating u => u -> RelBuild u ()
hline dx = line (hvec dx)
vline :: Floating u => u -> RelBuild u ()
vline dy = line (vvec dy)
aline :: Floating u => Radian -> u -> RelBuild u ()
aline ang u = line (avec ang u)
hmove :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
hmove dx = move (hvec dx)
vmove :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
vmove dy = move (vvec dy)
amove :: (Floating u, InterpretUnit u) => Radian -> u -> RelBuild u ()
amove ang u = move (avec ang u)
line_up :: Floating u => u -> RelBuild u ()
line_up u = line (vvec u)
line_down :: Floating u => u -> RelBuild u ()
line_down u = line (vvec $ negate u)
line_left :: Floating u => u -> RelBuild u ()
line_left u = line (hvec $ negate u)
line_right :: Floating u => u -> RelBuild u ()
line_right u = line (hvec u)
line_up_left :: Floating u => u -> RelBuild u ()
line_up_left u = line (vec (u) u)
line_up_right :: Floating u => u -> RelBuild u ()
line_up_right u = line (vec u u)
line_down_left :: Floating u => u -> RelBuild u ()
line_down_left u = line (vec (u) (u))
line_down_right :: Floating u => u -> RelBuild u ()
line_down_right u = line (vec u (u))
line_north :: Floating u => u -> RelBuild u ()
line_north = vline
line_south :: Floating u => u -> RelBuild u ()
line_south = vline . negate
line_east :: Floating u => u -> RelBuild u ()
line_east = hline
line_west :: Floating u => u -> RelBuild u ()
line_west = hline . negate
line_northeast :: Floating u => u -> RelBuild u ()
line_northeast = line . avec (0.25 * pi)
line_northwest :: Floating u => u -> RelBuild u ()
line_northwest = line . avec (0.75 * pi)
line_southeast :: Floating u => u -> RelBuild u ()
line_southeast = line . avec (1.75 * pi)
line_southwest :: Floating u => u -> RelBuild u ()
line_southwest = line . avec (1.25 * pi)
move_up :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_up u = move (vvec u)
move_down :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_down u = move (vvec $ negate u)
move_left :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_left u = move (hvec $ negate u)
move_right :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_right u = move (hvec u)
move_up_left :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_up_left u = move (vec (u) u)
move_up_right :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_up_right u = move (vec u u)
move_down_left :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_down_left u = move (vec (u) (u))
move_down_right :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_down_right u = move (vec u (u))
move_north :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_north = vmove
move_south :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_south = vmove . negate
move_east :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_east = hmove
move_west :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_west = hmove . negate
move_northeast :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_northeast = move . avec (0.25 * pi)
move_northwest :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_northwest = move . avec (0.75 * pi)
move_southeast :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_southeast = move . avec (1.75 * pi)
move_southwest :: (Floating u, InterpretUnit u) => u -> RelBuild u ()
move_southwest = move . avec (1.25 * pi)