{-# LANGUAGE TypeFamilies #-}{-# OPTIONS -Wall #-}---------------------------------------------------------------------------------- |-- Module : Wumpus.Basic.Kernel.Objects.TraceDrawing-- Copyright : (c) Stephen Tetley 2010-2011-- License : BSD3---- Maintainer : stephen.tetley@gmail.com-- Stability : unstable-- Portability : GHC ---- Drawing with /trace/ - a Writer like monad collecting -- intermediate graphics - and /drawing context/ - a reader monad-- of attributes - font_face, fill_colour etc.----------------------------------------------------------------------------------moduleWumpus.Basic.Kernel.Objects.TraceDrawing(-- * Collect primitives (writer-like monad) GenTraceDrawing,TraceDrawing,DTraceDrawing,runTraceDrawing,execTraceDrawing,evalTraceDrawing,runGenTraceDrawing,liftToPictureU,liftToPictureMb,mbPictureU,trace,fontDelta,evalQuery,draw,drawi,drawl,drawli,drawc,drawci,node,nodei,drawrc,drawrci)whereimportWumpus.Basic.Kernel.Base.BaseDefsimportWumpus.Basic.Kernel.Base.DrawingContextimportWumpus.Basic.Kernel.Base.QueryDCimportWumpus.Basic.Kernel.Base.UserStateimportWumpus.Basic.Kernel.Base.WrappedPrimitiveimportWumpus.Basic.Kernel.Objects.AnchorsimportWumpus.Basic.Kernel.Objects.BasisimportWumpus.Basic.Kernel.Objects.ConnectorimportWumpus.Basic.Kernel.Objects.LocImageimportWumpus.Core-- package: wumpus-coreimportControl.ApplicativeimportControl.MonadimportData.Monoid---------------------------------------------------------------------------------- Note - TraceDrawing run \once\ - it is supplied with the starting-- environment (DrawingContext) and returns a Picture.---- Other Wumpus monads (e.g. Turtle) will typically be run inside-- the TraceDrawing monad as a local effect, rather than built into a -- transformer stack.--newtypeGenTraceDrawingstua=GenTraceDrawing{getGenTraceDrawing::DrawingContext->st->(a,st,HPrimu)}typeinstanceMonUnit(GenTraceDrawingstua)=utypeinstanceUState(GenTraceDrawingstu)=sttypeTraceDrawingua=GenTraceDrawing()uatypeDTraceDrawinga=TraceDrawingDoublea-- FunctorinstanceFunctor(GenTraceDrawingstu)wherefmapfma=GenTraceDrawing$\ctxs->let(a,s1,w1)=getGenTraceDrawingmactxsin(fa,s1,w1)-- ApplicativeinstanceApplicative(GenTraceDrawingstu)wherepurea=GenTraceDrawing$\_s->(a,s,mempty)mf<*>ma=GenTraceDrawing$\ctxs->let(f,s1,w1)=getGenTraceDrawingmfctxs(a,s2,w2)=getGenTraceDrawingmactxs1in(fa,s2,w1`mappend`w2)-- MonadinstanceMonad(GenTraceDrawingstu)wherereturna=GenTraceDrawing$\_s->(a,s,mempty)ma>>=k=GenTraceDrawing$\ctxs->let(a,s1,w1)=getGenTraceDrawingmactxs(b,s2,w2)=(getGenTraceDrawing.k)actxs1in(b,s2,w1`mappend`w2)-- DrawingCtxMinstanceDrawingCtxM(GenTraceDrawingstu)whereaskDC=GenTraceDrawing$\ctxs->(ctx,s,mempty)asksDCf=GenTraceDrawing$\ctxs->(fctx,s,mempty)localizeupdma=GenTraceDrawing$\ctxs->getGenTraceDrawingma(updctx)s-- UserStateM instanceUserStateM(GenTraceDrawingstu)wheregetState=GenTraceDrawing$\_s->(s,s,mempty)setStates=GenTraceDrawing$\__->((),s,mempty)updateStateupd=GenTraceDrawing$\_s->((),upds,mempty)runTraceDrawing::TraceDrawingua->DrawingContext->(a,HPrimu)runTraceDrawingmactx=post$getGenTraceDrawingmactx()wherepost(a,_,w1)=(a,w1)-- | Run the drawing returning only the output it produces, drop-- any answer from the monadic computation.--execTraceDrawing::TraceDrawingua->DrawingContext->HPrimuexecTraceDrawingmactx=snd$runTraceDrawingmactx-- | Run the drawing ignoring the output it produces, return the -- answer from the monadic computation.---- Note - this useful for testing, generally one would want the -- opposite behaviour (return the drawing, ignore than the -- answer).-- evalTraceDrawing::TraceDrawingua->DrawingContext->aevalTraceDrawingmactx=fst$runTraceDrawingmactxrunGenTraceDrawing::GenTraceDrawingstua->DrawingContext->st->(a,st,HPrimu)runGenTraceDrawing=getGenTraceDrawing-- | /Unsafe/ promotion of @HPrim@ to @Picture@.---- If the HPrim is empty, a run-time error is thrown.-- liftToPictureU::HPrimu->PictureliftToPictureUhf=letprims=hprimToListhfinifnullprimsthenerrKelseframeprimswhereerrK=error"toPictureU - empty prims list."-- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@.---- If the HPrim is empty, then @Nothing@ is returned.-- liftToPictureMb::HPrimu->MaybePictureliftToPictureMbhf=letprims=hprimToListhfinifnullprimsthenNothingelseJust(frameprims)-- | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@.---- This is equivalent to:---- > fromMaybe (error "empty") $ pic---- This function is solely a convenience, using it saves one -- import and a few characters.---- If the supplied value is @Nothing@ a run-time error is thrown.-- mbPictureU::MaybePicture->PicturembPictureUNothing=error"mbPictureU - empty picture."mbPictureU(Justa)=a-- Note - need an equivalent to Parsec\`s parseTest that provides-- a very simple way to run graphics without concern for return -- type or initial drawing context.---------------------------------------------------------------------------------- TraceM ---- Note - @ state `mappend` a @ means the first expression in a -- monadic drawing is the first element in the output file. It is-- also \*\* at the back \*\* in the the Z-Order.---- Some control over the Z-Order, possibly by adding /layers/ to -- the drawing model would be valuable. -- -- | Primitive operation - cf. tell in Reader monad.--trace::HPrimu->GenTraceDrawingstu()tracea=GenTraceDrawing$\_s->((),s,a)fontDelta::GenTraceDrawingstua->GenTraceDrawingstuafontDeltamf=GenTraceDrawing$\ctxs->let(_,font_attrs)=runQuerytextAttrctx(a,s1,w1)=getGenTraceDrawingmfctxsprim=fontDeltaContextfont_attrs$primGroup$hprimToListw1in(a,s1,singleH$prim1$prim)-- Note - this function is in the wrong module....--evalQuery::DrawingCtxMm=>Queryua->maevalQuerydf=askDC>>=\ctx->return$runQuerydfctx-- | Draw a Graphic taking the drawing style from the -- /drawing context/. ---- This function is the /forgetful/ version of 'drawi'. -- Commonly, it is used to draw 'Graphic' objects which -- have no /answer/.-- draw::Imageua->GenTraceDrawingstu()drawgf=askDC>>=\ctx->let(_,w)=runImagegfctxintrace(singleHw)>>return()-- | Draw an Image taking the drawing style from the -- /drawing context/. ---- The graphic representation of the Image is drawn in the Trace -- monad, and the result is returned.-- drawi::Imageua->GenTraceDrawingstuadrawigf=askDC>>=\ctx->let(a,w)=runImagegfctxintrace(singleHw)>>returna-- | Draw a LocImage at the supplied Anchor taking the drawing -- style from the /drawing context/. ---- This function is the /forgetful/ version of 'drawli'. -- Commonly, it is used to draw 'LocGraphic' objects which -- have no /answer/.-- drawl::InterpretUnitu=>Anchoru->LocImageua->GenTraceDrawingstu()drawlancrimg=drawliancrimg>>return()-- | Draw a LocImage at the supplied Point taking the drawing -- style from the /drawing context/. ---- The graphic representation of the Image is drawn in the Trace -- monad, and the result is returned.-- drawli::InterpretUnitu=>Anchoru->LocImageua->GenTraceDrawingstuadrawliptgf=askDC>>=\ctx->let(a,w)=runLocImagegfctxptintrace(singleHw)>>returna-- Design note - having @drawlti@ for LocThetaImage does not seem -- compelling (at the moment). The thinking is that LocTheta-- objects should be downcast to Loc objects before drawing. ---- Connectors however are be different. -- -- PosImages would seem to be the same as LocThetaImages.---- | Draw a ConnectorGraphic with the supplied Anchors taking the -- drawing style from the /drawing context/. ---- This function is the /forgetful/ version of 'drawci'. -- Commonly, it is used to draw 'ConnectorGraphic' objects which -- have no /answer/.-- drawc::InterpretUnitu=>Anchoru->Anchoru->ConnectorImageua->GenTraceDrawingstu()drawcan0an1img=drawcian0an1img>>return()-- | Draw a ConnectorImage with the supplied Points taking the -- drawing style from the /drawing context/. ---- The graphic representation of the Image is drawn in the Trace -- monad, and the result is returned.-- drawci::InterpretUnitu=>Anchoru->Anchoru->ConnectorImageua->GenTraceDrawingstuadrawcip0p1img=drawi(connectp0p1img)-- | Draw the object with the supplied grid coordinate. The -- actual position is scaled according to the -- @snap_grid_factors@ in the /drawing context/.-- -- This function is the /forgetful/ version of 'nodei'. -- Commonly, it is used to draw 'LocGraphic' objects which -- have no /answer/.-- node::(Fractionalu,InterpretUnitu)=>(Int,Int)->LocImageua->GenTraceDrawingstu()nodecoordgf=nodeicoordgf>>return()-- | Draw the object with the supplied grid coordinate. The -- actual position is scaled according to the -- @snap_grid_factors@ in the /drawing context/.-- nodei::(Fractionalu,InterpretUnitu)=>(Int,Int)->LocImageua->GenTraceDrawingstuanodeicoordgf=askDC>>=\ctx->positioncoord>>=\pt->let(a,w)=runLocImagegfctxptintrace(singleHw)>>returna-- | Draw a connector between two objects. The projection of the-- connector line is drawn on the line from center to center of -- the objects, the actual start and end points of the drawn line-- are the radial points on the objects borders that cross the -- projected line.-- -- This function is the /forgetful/ version of 'drawrci'. -- Commonly, it is used to draw 'LocGraphic' objects which -- have no /answer/.-- drawrc::(Realu,Floatingu,InterpretUnitu,CenterAnchora1,RadialAnchora1,CenterAnchora2,RadialAnchora2,u~DUnita1,u~DUnita2)=>a1->a2->ConnectorImageua->GenTraceDrawingstu()drawrcabgf=drawrciabgf>>return()-- | Draw a connector between two objects. The projection of the-- connector line is drawn on the line from center to center of -- the objects, the actual start and end points of the drawn line-- are the radial points on the objects borders that cross the -- projected line.-- drawrci::(Realu,Floatingu,InterpretUnitu,CenterAnchora1,RadialAnchora1,CenterAnchora2,RadialAnchora2,u~DUnita1,u~DUnita2)=>a1->a2->ConnectorImageua->GenTraceDrawingstuadrawrciabgf=let(p0,p1)=radialConnectorPointsabindrawi(connectp0p1gf)