{-# LANGUAGE TypeFamilies #-}{-# OPTIONS -Wall #-}---------------------------------------------------------------------------------- |-- Module : Wumpus.Drawing.Dots.AnchorDots-- Copyright : (c) Stephen Tetley 2010-2011-- License : BSD3---- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>-- Stability : highly unstable-- Portability : GHC---- Dots with anchors.---- In many cases a surrounding circle is used to locate anchor-- points - this could be improved to use the actual dot border -- at some point.----------------------------------------------------------------------------------moduleWumpus.Drawing.Dots.AnchorDots(-- * Existential anchor typeDotAnchor,DotLocImage,DDotLocImage-- * Dots with anchor points,smallDisk,largeDisk,smallCirc,largeCirc,dotNone,dotChar,dotText,dotHLine,dotVLine,dotX,dotPlus,dotCross,dotDiamond,dotFDiamond,dotDisk,dotSquare,dotCircle,dotPentagon,dotStar,dotAsterisk,dotOPlus,dotOCross,dotFOCross,dotTriangle)whereimportWumpus.Drawing.Dots.SimpleDots(MarkSize)importqualifiedWumpus.Drawing.Dots.SimpleDotsasSDimportWumpus.Drawing.Text.Base.RotTextZeroimportWumpus.Basic.Geometry-- package: wumpus-basicimportWumpus.Basic.KernelimportWumpus.Core-- package: wumpus-coreimportData.AffineSpace-- package: vector-spaceimportControl.Applicative-- | All dots return the same thing a 'DotAnchor' which supports -- the same (limited) see of anchors.--dataDotAnchoru=DotAnchor{center_anchor::Point2u,radial_anchor::Radian->Point2u,cardinal_anchor::Cardinal->Point2u}typeinstanceDUnit(DotAnchoru)=uinstanceCenterAnchor(DotAnchoru)wherecenter(DotAnchorca__)=cainstanceRadialAnchor(DotAnchoru)whereradialAnchortheta(DotAnchor_ra_)=rathetainstanceCardinalAnchor(DotAnchoru)wherenorth(DotAnchor__c1)=c1NORTHsouth(DotAnchor__c1)=c1SOUTHeast(DotAnchor__c1)=c1EASTwest(DotAnchor__c1)=c1WESTinstanceCardinalAnchor2(DotAnchoru)wherenortheast(DotAnchor__c1)=c1NORTH_EASTsoutheast(DotAnchor__c1)=c1SOUTH_EASTsouthwest(DotAnchor__c1)=c1SOUTH_WESTnorthwest(DotAnchor__c1)=c1NORTH_WESTradialCardinal::Floatingu=>u->Point2u->Cardinal->Point2uradialCardinalradctrNORTH=ctr.+^(avec(pi/2)rad)radialCardinalradctrNORTH_EAST=ctr.+^(avec(pi/4)rad)radialCardinalradctrEAST=ctr.+^(avec0rad)radialCardinalradctrSOUTH_EAST=ctr.+^(avec(7/4*pi)rad)radialCardinalradctrSOUTH=ctr.+^(avec(6/4*pi)rad)radialCardinalradctrSOUTH_WEST=ctr.+^(avec(5/4*pi)rad)radialCardinalradctrWEST=ctr.+^(avecpirad)radialCardinalradctrNORTH_WEST=ctr.+^(avec(3/4*pi)rad)-- Rectangle cardinal points are at \"middles and corners\".--rectCardinal::Floatingu=>u->u->Point2u->Cardinal->Point2urectCardinal_hhctrNORTH=ctr.+^(vvechh)rectCardinalhwhhctrNORTH_EAST=ctr.+^(vechwhh)rectCardinalhw_ctrEAST=ctr.+^(hvechw)rectCardinalhwhhctrSOUTH_EAST=ctr.+^(vechw(-hh))rectCardinal_hhctrSOUTH=ctr.+^(vvec(-hh))rectCardinalhwhhctrSOUTH_WEST=ctr.+^(vec(-hw)(-hh))rectCardinalhw_ctrWEST=ctr.+^(hvec(-hw))rectCardinalhwhhctrNORTH_WEST=ctr.+^(vec(-hw)hh)polyCardinal::Floatingu=>(Radian->Point2u)->Cardinal->Point2upolyCardinalfNORTH=f(0.5*pi)polyCardinalfNORTH_EAST=f(0.25*pi)polyCardinalfEAST=f0polyCardinalfSOUTH_EAST=f(1.75*pi)polyCardinalfSOUTH=f(1.5*pi)polyCardinalfSOUTH_WEST=f(1.25*pi)polyCardinalfWEST=fpipolyCardinalfNORTH_WEST=f(0.75*pi)-- | All anchors are the center!--zeroAnchor::Point2u->DotAnchoruzeroAnchorctr=DotAnchor{center_anchor=ctr,radial_anchor=constctr,cardinal_anchor=constctr}rectangleAnchor::(Realu,Floatingu)=>u->u->Point2u->DotAnchorurectangleAnchorhwhhctr=DotAnchor{center_anchor=ctr,radial_anchor=fn,cardinal_anchor=rectCardinalhwhhctr}wherefntheta=displace(rectRadialVectorhwhhtheta)ctrcircleAnchor::Floatingu=>u->Point2u->DotAnchorucircleAnchorradctr=DotAnchor{center_anchor=ctr,radial_anchor=fn,cardinal_anchor=radialCardinalradctr}wherefntheta=displace(avecthetarad)ctrpolygonAnchor::(Realu,Floatingu,InterpretUnitu,Toleranceu)=>[Point2u]->Point2u->DotAnchorupolygonAnchorpsctr=DotAnchor{center_anchor=ctr,radial_anchor=fn,cardinal_anchor=polyCardinalfn}wherefntheta=maybectrid$findIntersectctrtheta$polygonLineSegmentspsbboxRectAnchor::(Realu,Floatingu)=>BoundingBoxu->DotAnchorubboxRectAnchor(BBoxbl@(P2x1y1)(P2x2y2))=lethw=0.5*(x2-x1)hh=0.5*(y2-y1)inrectangleAnchorhwhh(bl.+^vechwhh)zeroLDO::LocQueryu(DotAnchoru)zeroLDO=qpromoteLoc$\pt->return$zeroAnchorptrectangleLDO::(Realu,Floatingu,InterpretUnitu)=>MarkSize->MarkSize->LocQueryu(DotAnchoru)rectangleLDOwh=qpromoteLoc$\pt->(\uwuh->rectangleAnchor(uw*0.5)(uh*0.5)pt)<$>uconvertCtx1w<*>uconvertCtx1hcircleLDO::(Floatingu,InterpretUnitu)=>MarkSize->LocQueryu(DotAnchoru)circleLDOrad=qpromoteLoc$\pt->uconvertCtx1rad>>=\urad->pure$circleAnchoruradpt-- Probably better just using bounding circle for polygons -- If you really care about anchors use shapes-- -- Triangle probably benefits proper calculation...triangleLDO::(Realu,Floatingu,Toleranceu,InterpretUnitu)=>MarkSize->LocQueryu(DotAnchoru)triangleLDOh=qpromoteLoc$\pt->uconvertCtx1h>>=\uh->letalg=pathIterateLocus$fn3$equilateralTriangleVerticesuhps=runPathAlgPointptalginreturn$polygonAnchorpsptwherefn3(a,b,c)=[a,b,c]--------------------------------------------------------------------------------typeDotLocImageu=LocImageu(DotAnchoru)typeDDotLocImage=DotLocImageDoubledotNone::InterpretUnitu=>DotLocImageudotNone=intoLocImagezeroLDOSD.dotNonesmallDisk::(Floatingu,Realu,InterpretUnitu)=>DotLocImageusmallDisk=intoLocImage(circleLDO0.25)SD.smallDisklargeDisk::(Floatingu,Realu,InterpretUnitu)=>DotLocImageulargeDisk=intoLocImage(circleLDO1.00)SD.largeDisksmallCirc::(Floatingu,Realu,InterpretUnitu)=>DotLocImageusmallCirc=intoLocImage(circleLDO0.25)SD.smallCirclargeCirc::(Floatingu,Realu,InterpretUnitu)=>DotLocImageulargeCirc=intoLocImage(circleLDO1.00)SD.largeCircdotChar::(Floatingu,Realu,InterpretUnitu)=>Char->DotLocImageudotCharch=dotText[ch]-- Note - dotText now uses font metrics, the generated BBox is -- fine for dots (if they are all the same text) but not good for -- tree nodes (for example). Wumpus-Tree should really be using a-- different graphic object for labelled trees.--dotText::(Floatingu,Realu,InterpretUnitu)=>String->DotLocImageudotTextss=fmapbboxRectAnchor$ccTextliness-- Note - maybe Wumpus-Basic should have a @swapAns@ function?dotHLine::(Floatingu,InterpretUnitu)=>DotLocImageudotHLine=intoLocImage(circleLDO0.5)SD.dotHLinedotVLine::(Floatingu,InterpretUnitu)=>DotLocImageudotVLine=intoLocImage(circleLDO0.5)SD.dotVLinedotX::(Floatingu,InterpretUnitu)=>DotLocImageudotX=intoLocImage(circleLDO0.5)SD.dotXdotPlus::(Floatingu,InterpretUnitu)=>DotLocImageudotPlus=intoLocImage(circleLDO0.5)SD.dotPlusdotCross::(Floatingu,InterpretUnitu)=>DotLocImageudotCross=intoLocImage(circleLDO0.5)SD.dotCrossdotDiamond::(Floatingu,InterpretUnitu)=>DotLocImageudotDiamond=intoLocImage(circleLDO0.5)SD.dotDiamonddotFDiamond::(Floatingu,InterpretUnitu)=>DotLocImageudotFDiamond=intoLocImage(circleLDO0.5)SD.dotFDiamonddotDisk::(Floatingu,InterpretUnitu)=>DotLocImageudotDisk=intoLocImage(circleLDO0.5)SD.dotDiskdotSquare::(Floatingu,Realu,InterpretUnitu)=>DotLocImageudotSquare=intoLocImage(rectangleLDO11)SD.dotSquaredotCircle::(Floatingu,InterpretUnitu)=>DotLocImageudotCircle=intoLocImage(circleLDO0.5)SD.dotCircledotPentagon::(Floatingu,InterpretUnitu)=>DotLocImageudotPentagon=intoLocImage(circleLDO0.5)SD.dotPentagondotStar::(Floatingu,InterpretUnitu)=>DotLocImageudotStar=intoLocImage(circleLDO0.5)SD.dotStardotAsterisk::(Floatingu,InterpretUnitu)=>DotLocImageudotAsterisk=intoLocImage(circleLDO0.5)SD.dotAsteriskdotOPlus::(Floatingu,InterpretUnitu)=>DotLocImageudotOPlus=intoLocImage(circleLDO0.5)SD.dotOPlusdotOCross::(Floatingu,InterpretUnitu)=>DotLocImageudotOCross=intoLocImage(circleLDO0.5)SD.dotOCrossdotFOCross::(Floatingu,InterpretUnitu)=>DotLocImageudotFOCross=intoLocImage(circleLDO0.5)SD.dotFOCrossdotTriangle::(Realu,Floatingu,InterpretUnitu,Toleranceu)=>DotLocImageudotTriangle=intoLocImage(triangleLDO1)SD.dotTriangleintoLocImage::LocQueryua->LocImageuz->LocImageuaintoLocImagemqgf=promoteLoc$\pt->askDC>>=\ctx->letans=runLocQueryptctxmqinreplaceAnsans$applyLocgfpt