Model.hs

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Model
-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Tools for visualizing diagrams' internal model: local origins,
-- envelopes, /etc./
--
-----------------------------------------------------------------------------
module Diagrams.TwoD.Model
       ( -- * Showing the local origin
         showOrigin
       , showOrigin'
       , OriginOpts(..)
       , showLabels
       ) where

import           Diagrams.Core
import           Diagrams.Core.Names

import           Diagrams.Path

import           Diagrams.Attributes
import           Diagrams.TwoD.Ellipse
import           Diagrams.TwoD.Path
import           Diagrams.TwoD.Size    (size2D)
import           Diagrams.TwoD.Text
import           Diagrams.TwoD.Types
import           Diagrams.Util

import           Control.Arrow         (second)
import           Data.AffineSpace      ((.-.))
import           Data.Default.Class
import           Data.Semigroup
import           Data.VectorSpace      ((^*))

import qualified Data.Map              as M

import           Data.Colour           (Colour)
import           Data.Colour.Names

------------------------------------------------------------
-- Marking the origin
------------------------------------------------------------

-- | Mark the origin of a diagram by placing a red dot 1/50th its size.
showOrigin :: (Renderable (Path R2) b, Backend b R2, Monoid' m)
           => QDiagram b R2 m -> QDiagram b R2 m
showOrigin = showOrigin' def

-- | Mark the origin of a diagram, with control over colour and scale
-- of marker dot.
showOrigin' :: (Renderable (Path R2) b, Backend b R2, Monoid' m)
           => OriginOpts -> QDiagram b R2 m -> QDiagram b R2 m
showOrigin' oo d = o <> d
  where o     = stroke (circle sz)
                # fc (oColor oo)
                # lw 0
                # fmap (const mempty)
        (w,h) = size2D d ^* oScale oo
        sz = maximum [w, h, oMinSize oo]

data OriginOpts = OriginOpts { oColor   :: Colour Double
                             , oScale   :: Double
                             , oMinSize :: Double
                             }

instance Default OriginOpts where
  def = OriginOpts red (1/50) 0.001


------------------------------------------------------------
-- Labeling named points
------------------------------------------------------------

showLabels :: (Renderable Text b, Backend b R2)
           => QDiagram b R2 m -> QDiagram b R2 Any
showLabels d =
             ( mconcat
             . map (\(n,p) -> text (show n) # translate (p .-. origin))
             . concatMap (\(n,ps) -> zip (repeat n) ps)
             . (map . second . map) location
             . M.assocs
             $ m
             ) <>
             fmap (const (Any False)) d
  where
    SubMap m = subMap d