{-# LANGUAGE TypeFamilies #-}{-# OPTIONS -Wall #-}---------------------------------------------------------------------------------- |-- Module : Wumpus.Drawing.Paths.PathBuilder-- Copyright : (c) Stephen Tetley 2011-- License : BSD3---- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>-- Stability : highly unstable-- Portability : GHC---- Build relative paths monadically.---- \*\* WARNING \*\* this module is an experiment, and may -- change significantly or even be dropped from future revisions.-- --------------------------------------------------------------------------------moduleWumpus.Drawing.Paths.PathBuilder(GenPathSpec,PathSpec,Vamp(..),runGenPathSpec,execGenPathSpec,evalGenPathSpec,stripGenPathSpec,runPathSpec,runPathSpec_,runPivot,penline,pencurve,breakPath,hpenline,vpenline,apenline,penlines,pathmoves,vamp,cycleSubPath,updatePen)whereimportWumpus.Drawing.Paths.BaseimportWumpus.Basic.Kernel-- package: wumpus-basicimportWumpus.Core-- package: wumpus-coreimportData.AffineSpace-- package: vector-spaceimportData.VectorSpaceimportControl.ApplicativeimportControl.MonadimportData.MonoidimportPreludehiding(null,cycle,lines)-- -- TODO - possibly we need two drawing contexts one for the pen -- and one for the decoration trace.-- -- Alternatively PathSt should have a local DrawingContext for the -- pen.---- | Note - a path spec has an immutable start point like -- @LocDrawing@.---- Effectively a path is draw in a local coordinate system with -- @(0,0)@ as the origin.--newtypeGenPathSpecstua=GenPathSpec{getGenPathSpec::DrawingContext->PathStst->(a,PathStst,CatPrim)}typeinstanceDUnit(GenPathSpecstua)=utypeinstanceUState(GenPathSpecstu)=sttypePathSpecua=GenPathSpec()uadataPathStst=PathSt{st_active_pen::ActivePen,st_pen_ctx::DrawingContext,st_cumulative_path::AbsPathDouble,st_user_state::st}-- | Note - this formulation doesn\'t support monoidal append.-- -- Information gets lost for this one (we really would want to -- draw the left-hand-side):---- > PEN_DOWN _ _ `mappend` PEN_UP---- So it has to be part of the state not the writer.-- dataActivePen=PEN_UP|PEN_DOWN(AbsPathDouble)zeroActivePen::DPoint2->ActivePenzeroActivePenpt=PEN_DOWN(emptyPathpt)dataVampu=Vamp{vamp_move::Vec2u,vamp_conn::ConnectorGraphicu}typeinstanceDUnit(Vampu)=u---------------------------------------------------------------------------------- Instances-- FunctorinstanceFunctor(GenPathSpecstu)wherefmapfma=GenPathSpec$\ctxs->let(a,s1,w1)=getGenPathSpecmactxsin(fa,s1,w1)-- ApplicativeinstanceApplicative(GenPathSpecstu)wherepurea=GenPathSpec$\_s->(a,s,mempty)mf<*>ma=GenPathSpec$\ctxs->let(f,s1,w1)=getGenPathSpecmfctxs(a,s2,w2)=getGenPathSpecmactxs1in(fa,s2,w1`mappend`w2)-- MonadinstanceMonad(GenPathSpecstu)wherereturna=GenPathSpec$\_s->(a,s,mempty)ma>>=k=GenPathSpec$\ctxs->let(a,s1,w1)=getGenPathSpecmactxs(b,s2,w2)=(getGenPathSpec.k)actxs1in(b,s2,w1`mappend`w2)-- Monoid instanceMonoida=>Monoid(GenPathSpecstua)wheremempty=GenPathSpec$\_s->(mempty,s,mempty)ma`mappend`mb=GenPathSpec$\ctxs->let(a,s1,w1)=getGenPathSpecmactxs(b,s2,w2)=getGenPathSpecmbctxs1in(a`mappend`b,s2,w1`mappend`w2)-- DrawingCtxMinstanceDrawingCtxM(GenPathSpecstu)whereaskDC=GenPathSpec$\ctxs->(ctx,s,mempty)asksDCf=GenPathSpec$\ctxs->(fctx,s,mempty)localizeupdma=GenPathSpec$\ctxs->getGenPathSpecma(updctx)s-- UserStateM instanceUserStateM(GenPathSpecstu)wheregetState=GenPathSpec$\_s->(st_user_states,s,mempty)setStateust=GenPathSpec$\_s->((),s{st_user_state=ust},mempty)updateStateupd=GenPathSpec$\_s->letust=st_user_statesin((),s{st_user_state=updust},mempty)-- Note - all these need to peek at the cumulative path-- LocationMinstanceInterpretUnitu=>LocationM(GenPathSpecstu)wherelocation=locationImpl-- CursorM instanceInterpretUnitu=>CursorM(GenPathSpecstu)wheremoveby=movebyImpl-- InsertlMinstanceInterpretUnitu=>InsertlM(GenPathSpecstu)whereinsertl=insertlImpl---------------------------------------------------------------------------------- Run functionsrunGenPathSpec::InterpretUnitu=>st->PathMode->GenPathSpecstua->LocImageu(a,st,AbsPathu)runGenPathSpecstmodema=promoteLoc$\pt->askDC>>=\ctx->letP2dxdy=normalizeF(dc_font_sizectx)ptst_zero=PathSt(zeroActivePenzeroPt)ctx(emptyPathzeroPt)st(a,s1,w1)=getGenPathSpecmactxst_zerodpath=translatedxdy$st_cumulative_paths1upath=dinterpF(dc_font_sizectx)dpathpctx=st_pen_ctxs1(_,w2)=runImagepctx(drawActivePenmode$st_active_pens1)wfinal=cpmove(V2dxdy)$w1`mappend`w2inreplaceAns(a,st_user_states1,upath)$primGraphicwfinal-- Note - eval and exec return the AbsPath this is as-per RWS-- which returns @w@ for execRWS (s,w) and evalRWS (a,w)--evalGenPathSpec::InterpretUnitu=>st->PathMode->GenPathSpecstua->LocImageu(a,AbsPathu)evalGenPathSpecstmodema=(\(a,_,w)->(a,w))<$>runGenPathSpecstmodemaexecGenPathSpec::InterpretUnitu=>st->PathMode->GenPathSpecstua->LocImageu(st,AbsPathu)execGenPathSpecstmodema=(\(_,s,w)->(s,w))<$>runGenPathSpecstmodemastripGenPathSpec::InterpretUnitu=>st->PathMode->GenPathSpecstua->LocQueryu(a,st,AbsPathu)stripGenPathSpecstmodema=stripLocImage$runGenPathSpecstmodemarunPathSpec::InterpretUnitu=>PathMode->PathSpecua->LocImageu(a,AbsPathu)runPathSpecmodema=evalGenPathSpec()modemarunPathSpec_::InterpretUnitu=>PathMode->PathSpecua->LocGraphicurunPathSpec_modema=ignoreAns$evalGenPathSpec()modema-- Monad run function nomenclature:---- > run - both-- > eval - answer (no state)-- > exec - state (no answer)-- -- Note RWS always returns the @w@.---- For Wumpus:-- -- > run - monadic answer, and the writer /construction/-- > eval - just the monadic answer-- > exec - just the writer /construction/.---- In all case the CatPrim inside the LocImage may contain -- additional graphics.---- Client code can use @ignoreAns@ to generate a @LocGraphic@-- from the @LocImage@.-- | Helper.--drawActivePen::PathMode->ActivePen->DGraphicdrawActivePen_PEN_UP=memptydrawActivePenmode(PEN_DOWNabs_path)=drawPath_modeabs_path-- | Form a \"pivot path\" drawing from two path specifications.-- The start point of the drawing is the pivot formed by joining-- the paths.--runPivot::(Floatingu,InterpretUnitu)=>PathSpecua->PathSpecua->LocGraphicurunPivotmamb=promoteLoc$\pt->askDC>>=\ctx->letdpt=normalizeF(dc_font_sizectx)ptst_zero=PathSt(zeroActivePenzeroPt)ctx(emptyPathzeroPt)()(p1,s1,w1)=getGenPathSpecmzctxst_zerodp1=normalizeF(dc_font_sizectx)p1v1=pvecdptdp1pctx=st_pen_ctxs1(_,w2)=runImagepctx$drawActivePenOSTROKE$st_active_pens1wfinal=w1`mappend`w2inprimGraphic$cpmove(negateVv1)wfinalwheremz=ma>>location>>=\pt->mb>>returnpt---------------------------------------------------------------------------------- operationslocationImpl::InterpretUnitu=>GenPathSpecstu(Point2u)locationImpl=GenPathSpec$\ctxs->letpt=tipR$st_cumulative_pathsupt=dinterpF(dc_font_sizectx)ptin(upt,s,mempty)-- | 'extendPaths' extends both the @cumulative_path@ and the -- @active_pen@. If the pen is up it, changes to a pendown.--extendPaths::DVec2->PathStst->PathStstextendPathsv1s@(PathSt{st_cumulative_path=cp,st_active_pen=pen})=s{st_cumulative_path=snocLinecpv1,st_active_pen=updpen}whereupdPEN_UP=letpt=tipRcpinPEN_DOWN$line1pt(pt.+^v1)upd(PEN_DOWNabsp)=PEN_DOWN$snocLineabspv1-- | Extend the path with a line, drawn by the pen.-- penline::InterpretUnitu=>Vec2u->GenPathSpecstu()penlinev1=GenPathSpec$\ctxs->letsz=dc_font_sizectxdv1=normalizeFszv1in((),extendPathsdv1s,mempty)-- | @extendPenC@ causes a pendown.--extendPathsC::DVec2->DVec2->DVec2->PathStst->PathStstextendPathsCv1v2v3s@(PathSt{st_cumulative_path=cp,st_active_pen=pen})=s{st_cumulative_path=snocCurvecp(v1,v2,v3),st_active_pen=updpen}whereupdPEN_UP=letp0=tipRcpp1=p0.+^v1p2=p1.+^v2p3=p2.+^v3inPEN_DOWN$curve1p0p1p2p3upd(PEN_DOWNabsp)=PEN_DOWN$snocCurveabsp(v1,v2,v3)-- | Extend the path with a curve, drawn by the pen.-- pencurve::InterpretUnitu=>Vec2u->Vec2u->Vec2u->GenPathSpecstu()pencurvev1v2v3=GenPathSpec$\ctxs->letsz=dc_font_sizectxdv1=normalizeFszv1dv2=normalizeFszv2dv3=normalizeFszv3in((),extendPathsCdv1dv2dv3s,mempty)-- | @moveby@ causes a pen up.--movebyImpl::InterpretUnitu=>Vec2u->GenPathSpecstu()movebyImplv1=GenPathSpec$\ctxs@(PathSt{st_pen_ctx=pctx})->letsz=dc_font_sizectxdv1=normalizeFszv1(_,w1)=runImagepctx$drawActivePenOSTROKE$st_active_penscpath=snocLine(st_cumulative_paths)dv1in((),s{st_active_pen=PEN_UP,st_cumulative_path=cpath},w1)breakPath::InterpretUnitu=>GenPathSpecstu()breakPath=movebyImpl(V200)hpenline::InterpretUnitu=>u->GenPathSpecstu()hpenlinedx=penline(hvecdx)vpenline::InterpretUnitu=>u->GenPathSpecstu()vpenlinedy=penline(vvecdy)apenline::(Floatingu,InterpretUnitu)=>Radian->u->GenPathSpecstu()apenlineangd=penline(avecangd)penlines::InterpretUnitu=>[Vec2u]->GenPathSpecstu()penlines=mapM_penlinepathmoves::InterpretUnitu=>[Vec2u]->GenPathSpecstu()pathmoves=mapM_movebyinsertlImpl::InterpretUnitu=>LocImageua->GenPathSpecstuainsertlImplgf=GenPathSpec$\ctxs->letupt=dinterpF(dc_font_sizectx)(tipR$st_cumulative_paths)(a,wcp)=runLocImagectxuptgfin(a,s,wcp)vamp::InterpretUnitu=>Vampu->GenPathSpecstu()vamp(Vampv1conn)=GenPathSpec$\ctxs@(PathSt{st_pen_ctx=pctx})->letsz=dc_font_sizectxdv1=normalizeFszv1(_,w1)=runImagepctx$drawActivePenOSTROKE$st_active_pensupt=dinterpFsz(tipR$st_cumulative_paths)(_,w2)=runConnectorImagectxupt(upt.+^v1)conncpath=snocLine(st_cumulative_paths)dv1in((),s{st_active_pen=PEN_UP,st_cumulative_path=cpath},w1`mappend`w2)cycleSubPath::DrawMode->GenPathSpecstu()cycleSubPathmode=GenPathSpec$\_s@(PathSt{st_pen_ctx=pctx})->let(_,w1)=runImagepctx$drawActivePen(fnmode)(st_active_pens)in((),s{st_active_pen=PEN_UP},w1)wherefnDRAW_STROKE=CSTROKEfnDRAW_FILL=CFILLfnDRAW_FILL_STROKE=CFILL_STROKE-- Design note ---- Should pen changing be @local@ style vis the Reader monad or a -- state change with the State monad?-- -- Now switched to state change.---- | Note - updates the pen but doesn\'t draw, the final path-- will be drawing with the last updated context.--updatePen::DrawingContextF->GenPathSpecstu()updatePenupd=GenPathSpec$\_s@(PathSt{st_pen_ctx=pctx})->((),s{st_pen_ctx=updpctx},mempty)