{-# LANGUAGE TypeFamilies #-}{-# OPTIONS -Wall #-}---------------------------------------------------------------------------------- |-- Module : Wumpus.Basic.Kernel.Objects.AdvObject-- Copyright : (c) Stephen Tetley 2010-2011-- License : BSD3---- Maintainer : stephen.tetley@gmail.com-- Stability : highly unstable-- Portability : GHC ---- Extended Graphic object - an AdvanceGraphic is a Graphic -- twinned with and advance vector.----------------------------------------------------------------------------------moduleWumpus.Basic.Kernel.Objects.AdvObject(-- * Advance vectorAdvanceVec,advanceH,advanceV-- * Advance-vector object and graphic,AdvObject,DAdvObject,AdvGraphic,DAdvGraphic,runAdvObject,makeAdvObject,emptyAdvObject,blankAdvObject-- * Composition,advance,advances,advspace,evenspace,advrepeat,punctuate,advfill)whereimportWumpus.Basic.Kernel.Base.BaseDefsimportWumpus.Basic.Kernel.Base.DrawingContextimportWumpus.Basic.Kernel.Base.WrappedPrimitiveimportWumpus.Basic.Kernel.Objects.BasisimportWumpus.Basic.Kernel.Objects.LocImageimportWumpus.Core-- package: wumpus-coreimportData.VectorSpace-- package: vector-spaceimportControl.ApplicativeimportData.Monoid---------------------------------------------------------------------------------- | Advance vectors provide an idiom for drawing consecutive-- graphics. PostScript uses them to draw left-to-right text - -- each character has an advance vector for the width and -- as characters are drawn they successively displace the start-- point for the next character with their advance vector.---- Type alias for Vec2.--typeAdvanceVecu=Vec2u-- | Extract the horizontal component of an advance vector.---- For left-to-right latin text, the vertical component of an-- advance vector is expected to be 0. Ingoring it seems -- permissible when drawing text.--advanceH::AdvanceVecu->uadvanceH(V2w_)=w-- | Extract the verticall component of an advance vector.--advanceV::AdvanceVecu->uadvanceV(V2_h)=h---------------------------------------------------------------------------------- AdvObject-- | Internal newtype wrapper so we can have a monoid instance -- with vector plus (^+^) for mappend.--newtypeDAV=DAV{getDAV::AdvanceVecDouble}instanceMonoidDAVwheremempty=DAV$V200DAVv1`mappend`DAVv2=DAV$v1^+^v2-- | /Advance vector/ graphic - this partially models the -- PostScript @show@ command which moves the /current point/ by the-- advance (width) vector as each character is drawn.--newtypeAdvObjectua=AdvObject{getAdvObject::DrawingContext->DPoint2->(a,DAV,CatPrim)}typeinstanceDUnit(AdvObjectua)=utypeDAdvObjecta=AdvObjectDoubleatypeAdvGraphicu=AdvObjectu(UNilu)typeDAdvGraphic=AdvGraphicDoubleinstanceFunctor(AdvObjectu)wherefmapfmf=AdvObject$\ctxpt->let(a,v1,w1)=getAdvObjectmfctxptin(fa,v1,w1)instanceApplicative(AdvObjectu)wherepurea=AdvObject$\__->(a,mempty,mempty)mf<*>ma=AdvObject$\ctxpt->let(f,v1,w1)=getAdvObjectmfctxpt(a,v2,w2)=getAdvObjectmactxptin(fa,v1`mappend`v2,w1`mappend`w2)instanceMonad(AdvObjectu)wherereturna=AdvObject$\__->(a,mempty,mempty)mf>>=k=AdvObject$\ctxpt->let(a,v1,w1)=getAdvObjectmfctxpt(b,v2,w2)=getAdvObject(ka)ctxptin(b,v1`mappend`v2,w1`mappend`w2)instanceDrawingCtxM(AdvObjectu)whereaskDC=AdvObject$\ctx_->(ctx,mempty,mempty)asksDCfn=AdvObject$\ctx_->(fnctx,mempty,mempty)localizeupdma=AdvObject$\ctxpt->getAdvObjectma(updctx)ptinstance(Monoida,InterpretUnitu)=>Monoid(AdvObjectua)wheremempty=AdvObject$\__->(mempty,mempty,mempty)ma`mappend`mb=AdvObject$\ctxpt->let(a,v1,w1)=getAdvObjectmactxpt(b,v2,w2)=getAdvObjectmbctxptw2r=cpmove(getDAVv1)w2in(a`mappend`b,v1`mappend`v2,w1`mappend`w2r)-- | Running an AdvObject produces a LocImage.--runAdvObject::InterpretUnitu=>AdvObjectua->LocImageuarunAdvObjectma=promoteLoc$\ot->askDC>>=\ctx->letdot=normalizeF(dc_font_sizectx)ot(a,_,ca)=getAdvObjectmactxdotinreplaceAnsa$primGraphicca---------------------------------------------------------------------------------- | 'makeAdvObject' : @ loc_context_function * image -> AdvObject @---- Build an 'AdvObject' from a context function ('CF') that -- generates the answer displacement vector and a 'LocGraphic' -- that draws the 'AdvObject'.--makeAdvObject::InterpretUnitu=>Queryu(Vec2u)->LocImageua->AdvObjectuamakeAdvObjectmagf=AdvObject$\ctxpt->letv1=runQuerymactxdav1=DAV$normalizeF(dc_font_sizectx)v1upt=dinterpF(dc_font_sizectx)pt(a,w)=runLocImagegfctxuptin(a,dav1,w)-- | 'emptyAdvObjectAU' : @ AdvObject @---- Build an empty 'AdvObject'.-- -- The 'emptyAdvObject' is treated as a /null primitive/ by -- @Wumpus-Core@ and is not drawn, the answer vector generated is-- the zero vector @(V2 0 0)@.-- emptyAdvObject::(Monoida,InterpretUnitu)=>AdvObjectuaemptyAdvObject=memptyblankAdvObject::(Monoida,InterpretUnitu)=>Vec2u->AdvObjectuablankAdvObjectv1=AdvObject$\ctx_->letdav1=DAV$normalizeF(dc_font_sizectx)v1in(mempty,dav1,mempty)---------------------------------------------------------------------------------- Combining AdvObjects-- Helper for list concatenation.-- listcat::(Monoida,InterpretUnitu)=>(AdvObjectua->AdvObjectua->AdvObjectua)->[AdvObjectua]->AdvObjectualistcat_[]=memptylistcatop(x:xs)=goxxswheregoacc[]=accgoacc(b:bs)=go(acc`op`b)bs-- AdvObject does not have the same ability to be concatenated-- as PosObject - all the advance vector says is \"where to go -- next\". Nothing in the AdvObject tracks the boundary so we-- cannot implement the Concat classes.infixr6`advance`-- | Draw the first AdvObject and use the advance vector to -- displace the second AdvObject.---- The final answer is the sum of both advance vectors.--advance::(Monoida,InterpretUnitu)=>AdvObjectua->AdvObjectua->AdvObjectuaadvance=mappend-- | Concatenate the list of AdvObjects with 'advance'.--advances::(Monoida,InterpretUnitu)=>[AdvObjectua]->AdvObjectuaadvances=mconcat-- | Combine the AdvObjects using the answer vector of the -- first object plus the separator to move the start of the second-- object. --advspace::(Monoida,InterpretUnitu)=>Vec2u->AdvObjectua->AdvObjectua->AdvObjectuaadvspacesepab=a`mappend`blank`mappend`bwhereblank=blankAdvObjectsep-- | List version of 'nextSpace'.--evenspace::(Monoida,InterpretUnitu)=>Vec2u->[AdvObjectua]->AdvObjectuaevenspacev=listcat(advspacev)-- | Repeat the AdvObject @n@ times, moving each time with -- 'advance'.--advrepeat::(Monoida,InterpretUnitu)=>Int->AdvObjectua->AdvObjectuaadvrepeatn=advances.replicaten-- | Concatenate the list of AdvObjects, going next and adding-- the separator at each step.--punctuate::(Monoida,InterpretUnitu)=>AdvObjectua->[AdvObjectua]->AdvObjectuapunctuatesep=listcat(\ab->a`advance`sep`advance`b)-- | Render the supplied AdvObject, but swap the result advance-- for the supplied vector. This function has behaviour analogue -- to @fill@ in the @wl-pprint@ library.-- advfill::InterpretUnitu=>Vec2u->AdvObjectua->AdvObjectuaadvfillsvmf=AdvObject$\ctxpt->let(a,_,ca)=getAdvObjectmfctxptdav1=DAV$normalizeF(dc_font_sizectx)svin(a,dav1,ca)