{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Shapes.Derived -- Copyright : (c) Stephen Tetley 2010 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- -- -------------------------------------------------------------------------------- module Wumpus.Basic.Shapes.Derived ( Rectangle , DRectangle , rectangle , lrectangle , Circle , DCircle , circle , lcircle , Coordinate , DCoordinate , coordinate , Diamond , DDiamond , diamond , ldiamond , Ellipse , DEllipse , ellipse , lellipse , FreeLabel , DFreeLabel , freelabel ) where import Wumpus.Basic.Anchors import Wumpus.Basic.Graphic import Wumpus.Basic.Shapes.Base import Wumpus.Basic.Utils.Intersection import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space import Data.Monoid -------------------------------------------------------------------------------- -- Rectangle data Rectangle u = Rectangle { rect_ctm :: ShapeCTM u , rect_hw :: !u , rect_hh :: !u } deriving (Eq,Show) type DRectangle = Rectangle Double type instance DUnit (Rectangle u) = u instance (Real u, Floating u) => CenterAnchor (Rectangle u) where center = ctmCenter . rect_ctm calcRectPoint :: (Real u, Floating u) => (u -> u -> Point2 u) -> Rectangle u -> Point2 u calcRectPoint f (Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }) = let pt = f hw hh in ctmDisplace pt ctm instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where north = calcRectPoint $ \ _ hh -> P2 0 hh south = calcRectPoint $ \ _ hh -> P2 0 (-hh) east = calcRectPoint $ \ hw _ -> P2 hw 0 west = calcRectPoint $ \ hw _ -> P2 (-hw) 0 instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where northeast = calcRectPoint $ \ hw hh -> P2 hw hh southeast = calcRectPoint $ \ hw hh -> P2 hw (-hh) southwest = calcRectPoint $ \ hw hh -> P2 (-hw) (-hh) northwest = calcRectPoint $ \ hw hh -> P2 (-hw) hh instance (Real u, Floating u) => RadialAnchor (Rectangle u) where radialAnchor theta rect@(Rectangle { rect_hw=hw, rect_hh=hh }) = maybe ctr id $ findIntersect ctr theta $ rectangleLines ctr hw hh where ctr = ctmCenter $ rect_ctm rect rectangle :: (Real u, Floating u) => u -> u -> Shape u (Rectangle u) rectangle w h = Shape { src_ctm = identityCTM , out_fun = outputRect (0.5*w) (0.5*h) nolabel } lrectangle :: (Real u, Floating u, FromPtSize u) => u -> u -> String -> Shape u (Rectangle u) lrectangle w h ss = Shape { src_ctm = identityCTM , out_fun = outputRect (0.5*w) (0.5*h) (shapelabel ss) } outputRect :: (Real u, Floating u) => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Rectangle u) outputRect hw hh shl ctm = intoImage (pureDF a) (drawRect a `mappend` label) where a = Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh } label = runShapeLabel ctm shl drawRect :: (Real u, Floating u) => Rectangle u -> Graphic u drawRect = borderedPath . rectPath rectPath :: (Real u, Floating u) => Rectangle u -> PrimPath u rectPath rect = vertexPath [ southwest rect , southeast rect , northeast rect , northwest rect ] -------------------------------------------------------------------------------- -- Circle data Circle u = Circle { circ_ctm :: ShapeCTM u , circ_radius :: !u } deriving (Eq,Show) type DCircle = Circle Double type instance DUnit (Circle u) = u instance (Real u, Floating u) => CenterAnchor (Circle u) where center = ctmCenter . circ_ctm calcCircPoint :: (Real u, Floating u) => (u -> Point2 u) -> Circle u -> Point2 u calcCircPoint f (Circle { circ_ctm = ctm, circ_radius = rad }) = let pt = f rad in ctmDisplace pt ctm instance (Real u, Floating u) => CardinalAnchor (Circle u) where north = calcCircPoint $ \ r -> P2 0 r south = calcCircPoint $ \ r -> P2 0 (-r) east = calcCircPoint $ \ r -> P2 r 0 west = calcCircPoint $ \ r -> P2 (-r) 0 instance (Real u, Floating u) => RadialAnchor (Circle u) where radialAnchor theta = calcCircPoint $ \r -> zeroPt .+^ avec theta r instance (Real u, Floating u) => CardinalAnchor2 (Circle u) where northeast = radialAnchor (0.25*pi) southeast = radialAnchor (1.75*pi) southwest = radialAnchor (1.25*pi) northwest = radialAnchor (0.75*pi) circle :: (Real u, Floating u) => u -> Shape u (Circle u) circle radius = Shape { src_ctm = identityCTM , out_fun = outputCirc radius nolabel } lcircle :: (Real u, Floating u, FromPtSize u) => u -> String -> Shape u (Circle u) lcircle radius ss = Shape { src_ctm = identityCTM , out_fun = outputCirc radius (shapelabel ss) } outputCirc :: (Real u, Floating u) => u -> ShapeLabel u -> ShapeCTM u -> Image u (Circle u) outputCirc rad shl ctm = intoImage (pureDF a) (drawCirc a `mappend` label) where a = Circle { circ_ctm = ctm, circ_radius = rad } label = runShapeLabel ctm shl drawCirc :: (Real u, Floating u) => Circle u -> Graphic u drawCirc = borderedPath . circlePath circlePath :: (Real u, Floating u) => Circle u -> PrimPath u circlePath = curvedPath . circlePoints circlePoints :: (Real u, Floating u) => Circle u -> [Point2 u] circlePoints (Circle { circ_ctm=ctm, circ_radius=radius }) = map fn all_points where fn pt = ctmDisplace pt ctm all_points = bezierCircle 2 radius zeroPt -------------------------------------------------------------------------------- -- | Coordinate data Coordinate u = Coordinate { coord_ctm :: ShapeCTM u } type DCoordinate = Coordinate Double type instance DUnit (Coordinate u) = u instance (Real u, Floating u) => CenterAnchor (Coordinate u) where center = ctmCenter . coord_ctm coordinate :: (Real u, Floating u) => Shape u (Coordinate u) coordinate = Shape { src_ctm = identityCTM , out_fun = outputCoord } outputCoord :: (Real u, Floating u) => ShapeCTM u -> Image u (Coordinate u) outputCoord ctm = intoImage (pureDF a) (drawCoord a) where a = Coordinate { coord_ctm = ctm } drawCoord :: (Real u, Floating u) => Coordinate u -> Graphic u drawCoord coord = localDF swapColours $ filledEllipse 2 2 (center coord) -------------------------------------------------------------------------------- -- Diamond data Diamond u = Diamond { dia_ctm :: ShapeCTM u , dia_hw :: !u , dia_hh :: !u } type DDiamond = Diamond Double type instance DUnit (Diamond u) = u instance (Real u, Floating u) => CenterAnchor (Diamond u) where center = ctmCenter . dia_ctm calcDiaPoint :: (Real u, Floating u) => (u -> u -> Point2 u) -> Diamond u -> Point2 u calcDiaPoint f (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = let pt = f hw hh in ctmDisplace pt ctm instance (Real u, Floating u) => CardinalAnchor (Diamond u) where north = calcDiaPoint $ \ _ hh -> P2 0 hh south = calcDiaPoint $ \ _ hh -> P2 0 (-hh) east = calcDiaPoint $ \ hw _ -> P2 hw 0 west = calcDiaPoint $ \ hw _ -> P2 (-hw) 0 diamond :: (Real u, Floating u) => u -> u -> Shape u (Diamond u) diamond hw hh = Shape { src_ctm = identityCTM , out_fun = outputDia hw hh nolabel } ldiamond :: (Real u, Floating u, FromPtSize u) => u -> u -> String -> Shape u (Diamond u) ldiamond hw hh ss = Shape { src_ctm = identityCTM , out_fun = outputDia hw hh (shapelabel ss) } outputDia :: (Real u, Floating u) => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Diamond u) outputDia hw hh shl ctm = intoImage (pureDF a) (drawDia a `mappend` label) where a = Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh } label = runShapeLabel ctm shl drawDia :: (Real u, Floating u) => Diamond u -> Graphic u drawDia = borderedPath . diamondPath diamondPath :: (Real u, Floating u) => Diamond u -> PrimPath u diamondPath dia = vertexPath [ south dia, east dia, north dia, west dia ] -------------------------------------------------------------------------------- -- Ellipse data Ellipse u = Ellipse { ell_ctm :: ShapeCTM u , ell_rx :: !u , ell_ry :: !u } type DEllipse = Ellipse Double type instance DUnit (Ellipse u) = u instance (Real u, Floating u) => CenterAnchor (Ellipse u) where center = ctmCenter . ell_ctm ellipse :: (Real u, Floating u) => u -> u -> Shape u (Ellipse u) ellipse rx ry = Shape { src_ctm = identityCTM , out_fun = outputEll rx ry nolabel } lellipse :: (Real u, Floating u, FromPtSize u) => u -> u -> String -> Shape u (Ellipse u) lellipse rx ry ss = Shape { src_ctm = identityCTM , out_fun = outputEll rx ry (shapelabel ss) } outputEll :: (Real u, Floating u) => u -> u -> ShapeLabel u -> ShapeCTM u -> Image u (Ellipse u) outputEll rx ry shl ctm = intoImage (pureDF a) (drawEll a `mappend` label) where a = Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry } label = runShapeLabel ctm shl drawEll :: (Real u, Floating u) => Ellipse u -> Graphic u drawEll = borderedPath . ellipsePath ellipsePath :: (Real u, Floating u) => Ellipse u -> PrimPath u ellipsePath = curvedPath . ellipsePoints ellipsePoints :: (Real u, Floating u) => Ellipse u -> [Point2 u] ellipsePoints (Ellipse { ell_ctm=ctm, ell_rx=rx, ell_ry=ry }) = map (ctmDisplace `flip` ctm) all_points where all_points = map (rescale rx ry) $ bezierCircle 2 rx zeroPt -- | x_radius is the unit length. -- rescale :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t rescale rx ry = scale 1 (ry/rx) -------------------------------------------------------------------------------- -- Free label -- Free label is a rectangle that /is not drawn/, the -- constructor should always create some text. newtype FreeLabel u = FreeLabel { getFreeLabel :: Rectangle u } type DFreeLabel = FreeLabel Double type instance DUnit (FreeLabel u) = u instance (Real u, Floating u) => CenterAnchor (FreeLabel u) where center = center . getFreeLabel instance (Real u, Floating u) => CardinalAnchor (FreeLabel u) where north = north . getFreeLabel south = south . getFreeLabel east = east . getFreeLabel west = west . getFreeLabel instance (Real u, Floating u) => CardinalAnchor2 (FreeLabel u) where northeast = northeast . getFreeLabel southeast = southeast . getFreeLabel southwest = southwest . getFreeLabel northwest = northwest . getFreeLabel instance (Real u, Floating u) => RadialAnchor (FreeLabel u) where radialAnchor theta = radialAnchor theta . getFreeLabel freelabel :: (Real u, Floating u, FromPtSize u) => String -> Shape u (FreeLabel u) freelabel ss = Shape { src_ctm = identityCTM , out_fun = outputStringLbl ss } outputStringLbl :: (Real u, Floating u, FromPtSize u) => String -> ShapeCTM u -> Image u (FreeLabel u) outputStringLbl ss ctm = intoImage (monoTextDimensions ss >>= \(w,h) -> return (mkrect w h)) label where mkrect w h = FreeLabel $ Rectangle { rect_ctm = ctm , rect_hw = 0.5*w , rect_hh = 0.5*h } label = runShapeLabel ctm (shapelabel ss)