Picture.hs

{-# LANGUAGE FlexibleInstances          #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Core.Picture
-- Copyright   :  (c) Stephen Tetley 2009
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  experimental
-- Portability :  GHC only
--
--
--------------------------------------------------------------------------------

module Wumpus.Core.Picture 
  (
  
   -- * Construction
    blankPicture
  , frame
  , frameWithin
  , frameMulti
  , multi


  , path
  , lineTo
  , curveTo
  , vertexPath  
  , curvedPath

  -- * Constructing primitives
  , Stroke(..)
  , zostroke
  , zcstroke

  , Fill(..)
  , zfill
  
  , clip

  , TextLabel(..)
  , ztextlabel
  , multilabel

  , Ellipse(..)
  , zellipse




  -- * Operations
  , extendBoundary

  ) where

import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicsState
import Wumpus.Core.PictureInternal
import Wumpus.Core.TextEncoding
import Wumpus.Core.Utils

import Data.Semigroup




--------------------------------------------------------------------------------

-- Default attributes

psBlack :: PSRgb
psBlack = RGB3 0 0 0
 
-- aka the standard frame
stdFrame :: Num u => Frame2 u 
stdFrame = ortho zeroPt

--------------------------------------------------------------------------------
-- OneList helper


-- | This module (Wumpus.Core.Picture) should be the only 
-- interface to the /outside world/ for creating 

--------------------------------------------------------------------------------
-- Construction



-- | Create a blank picture sized to the supplied bounding box.
-- This is useful for spacing rows or columns of pictures.
blankPicture :: Num u => BoundingBox u -> Picture u
blankPicture bb = PicBlank (stdFrame, bb)


-- | Lift a Primitive to a Picture, located in the standard frame.
frame :: (Fractional u, Ord u) => Primitive u -> Picture u
frame p = Single (stdFrame, boundary p) p 

-- | Frame a picture within the supplied bounding box
-- 
-- A text label uses the supplied bounding box as is - no 
-- clipping is performed if the bounding box is 
-- smaller than the boundary size of the text. This may 
-- cause strange overlap for subsequent composite pictures, and
-- incorrect bounding box annotations in the prologue of the 
-- generated EPS file. 
-- 
-- Paths and ellipses are bound within the union of the supplied 
-- bounding box and the inherent bounding box or the path or 
-- ellipse. Thus the bounding box will never reframed to a 
-- smaller size than the /natural/ bounding box.
--
frameWithin :: (Fractional u, Ord u) => Primitive u -> BoundingBox u -> Picture u
frameWithin p@(PLabel _ _) bb = Single (stdFrame,bb) p
frameWithin p              bb = Single (stdFrame,bb `append` boundary p) p




-- | Lift a list of Primitives to a composite Picture, all 
-- Primitives will be located within the standard frame.
-- The list of Primitives must be non-empty.
--
frameMulti :: (Fractional u, Ord u) => [Primitive u] -> Picture u
frameMulti [] = error "Wumpus.Core.Picture.frameMulti - empty list"
frameMulti xs = multi $ map frame xs


-- | Place multiple pictures within the same affine frame
-- This function throws an error when supplied the empty list.
multi :: (Fractional u, Ord u) => [Picture u] -> Picture u
multi ps = Picture (stdFrame, sconcat $ map boundary ps) ones
  where 
    sconcat []      = error err_msg
    sconcat (x:xs)  = foldr append x xs

    ones            = fromListErr err_msg ps

    err_msg         = "Wumpus.Core.Picture.multi - empty list"



-- | Create a Path from the start point and alist of PathSegments.
path :: Point2 u -> [PathSegment u] -> Path u
path = Path 

-- | Create a straight-line PathSegment.
lineTo :: Point2 u -> PathSegment u
lineTo = PLine

-- | Create a curved PathSegment.
curveTo :: Point2 u -> Point2 u -> Point2 u -> PathSegment u
curveTo = PCurve


-- | Convert the list of vertices to a path of straight line 
-- segments.
vertexPath :: [Point2 u] -> Path u
vertexPath []     = error "Picture.vertexPath - empty point list"
vertexPath (x:xs) = Path x (map PLine xs)


-- Not a paramorphism as you want to consume3 rather than 
-- look-ahead3...

-- | Convert a list of vertices to a path of curve segments.
-- The first point in the list makes the start point, each curve 
-- segment thereafter takes 3 points. /Spare/ points at the end 
-- are discarded. 
curvedPath :: [Point2 u] -> Path u
curvedPath []     = error "Picture.curvedPath - empty point list"
curvedPath (x:xs) = Path x (fn xs) where
  fn (a:b:c:ys) = PCurve a b c : fn ys 
  fn _          = []


  



--------------------------------------------------------------------------------
-- Take Paths to Primitives


ostrokePath :: (Num u, Ord u) 
            => PSRgb -> [StrokeAttr] -> Path u -> Primitive u
ostrokePath c attrs p = PPath (c, OStroke attrs) p

cstrokePath :: (Num u, Ord u) 
            => PSRgb -> [StrokeAttr] -> Path u -> Primitive u
cstrokePath c attrs p = PPath (c, CStroke attrs) p

class Stroke t where
  ostroke :: (Num u, Ord u) => t -> Path u -> Primitive u
  cstroke :: (Num u, Ord u) => t -> Path u -> Primitive u

instance Stroke () where
  ostroke () = ostrokePath psBlack []
  cstroke () = cstrokePath psBlack []

instance Stroke (RGB3 Double) where
  ostroke c = ostrokePath (psColour c) []
  cstroke c = cstrokePath (psColour c) []

instance Stroke (HSB3 Double) where
  ostroke c = ostrokePath (psColour c) []
  cstroke c = cstrokePath (psColour c) []

instance Stroke (Gray Double) where
  ostroke c = ostrokePath (psColour c) []
  cstroke c = cstrokePath (psColour c) []


instance Stroke StrokeAttr where
  ostroke x = ostrokePath psBlack [x]
  cstroke x = cstrokePath psBlack [x]

instance Stroke [StrokeAttr] where
  ostroke xs = ostrokePath psBlack xs
  cstroke xs = cstrokePath psBlack xs



instance Stroke (RGB3 Double,StrokeAttr) where
  ostroke (c,x) = ostrokePath (psColour c) [x]
  cstroke (c,x) = cstrokePath (psColour c) [x]

instance Stroke (HSB3 Double,StrokeAttr) where
  ostroke (c,x) = ostrokePath (psColour c) [x]
  cstroke (c,x) = cstrokePath (psColour c) [x]

instance Stroke (Gray Double,StrokeAttr) where
  ostroke (c,x) = ostrokePath (psColour c) [x]
  cstroke (c,x) = cstrokePath (psColour c) [x]

instance Stroke (RGB3 Double,[StrokeAttr]) where
  ostroke (c,xs) = ostrokePath (psColour c) xs
  cstroke (c,xs) = cstrokePath (psColour c) xs

instance Stroke (HSB3 Double,[StrokeAttr]) where
  ostroke (c,xs) = ostrokePath (psColour c) xs
  cstroke (c,xs) = cstrokePath (psColour c) xs

instance Stroke (Gray Double,[StrokeAttr]) where
  ostroke (c,xs) = ostrokePath (psColour c) xs
  cstroke (c,xs) = cstrokePath (psColour c) xs


-- | Create an open stoke coloured black.
zostroke :: (Num u, Ord u) => Path u -> Primitive u
zostroke = ostrokePath psBlack []
 
-- | Create a closed stroke coloured black.
zcstroke :: (Num u, Ord u) => Path u -> Primitive u
zcstroke = cstrokePath psBlack []




-- fills only have one property - colour
-- Having a fill class seems uniform as we have a stroke class 



fillPath :: (Num u, Ord u) => PSRgb -> Path u -> Primitive u
fillPath c p = PPath (c,CFill) p

class Fill t where
  fill :: (Num u, Ord u) => t -> Path u -> Primitive u
 

instance Fill ()                where fill () = fillPath psBlack 
instance Fill (RGB3 Double)     where fill = fillPath . psColour
instance Fill (HSB3 Double)     where fill = fillPath . psColour
instance Fill (Gray Double)     where fill = fillPath . psColour

-- | Create a filled path coloured black. 
zfill :: (Num u, Ord u) => Path u -> Primitive u
zfill = fillPath psBlack

--------------------------------------------------------------------------------
-- Clipping 

clip :: (Num u, Ord u) => Path u -> Picture u -> Picture u
clip cp p = Clip (ortho zeroPt, boundary cp) cp p


--------------------------------------------------------------------------------
-- Labels to primitive

mkTextLabel :: PSRgb -> FontAttr -> Point2 u -> String -> Primitive u
mkTextLabel c attr pt txt = PLabel (c,attr) (Label pt $ lexLabel txt)

-- SVG seems to have an issue with /Courier/ and needs /Courier New/.

default_font :: FontAttr
default_font = FontAttr "Courier" "Courier New" SVG_REGULAR 12

class TextLabel t where 
  textlabel :: t -> Point2 u -> String -> Primitive u


instance TextLabel () where textlabel () = mkTextLabel psBlack default_font

instance TextLabel (RGB3 Double) where
  textlabel c = mkTextLabel (psColour c) default_font

instance TextLabel (HSB3 Double) where
  textlabel c = mkTextLabel (psColour c) default_font

instance TextLabel (Gray Double) where
  textlabel c = mkTextLabel (psColour c) default_font

instance TextLabel FontAttr where
  textlabel a = mkTextLabel psBlack a

instance TextLabel (RGB3 Double,FontAttr) where
  textlabel (c,a) = mkTextLabel (psColour c) a

instance TextLabel (HSB3 Double,FontAttr) where
  textlabel (c,a) = mkTextLabel (psColour c) a

instance TextLabel (Gray Double,FontAttr) where
  textlabel (c,a) = mkTextLabel (psColour c) a

-- | Create a label where the font is @Courier@, text size is 10 
-- and colour is black.
ztextlabel :: Point2 u -> String -> Primitive u
ztextlabel = mkTextLabel psBlack default_font



-- (The implementation of this function needs attention).
--
multilabel :: (Fractional u, Ord u) 
           => [Label u] -> LabelProps -> BoundingBox u -> Picture u
multilabel ps props bb = 
    Picture (stdFrame, bb) $ fromListErr err_msg 
                           $ map frame
                           $ zipWith PLabel (repeat props) ps 
  where 
    err_msg = "Wumpus.Core.Picture.multilabel - empty list."

--------------------------------------------------------------------------------

mkEllipse :: Num u 
          => PSRgb -> DrawEllipse -> Point2 u -> u -> u -> Primitive u
mkEllipse c dp pt hw hh = PEllipse (c,dp) pt hw hh


ellipseDefault :: EllipseProps
ellipseDefault = (psBlack, EFill)


-- | Instances will create a filled ellipse unless the supplied 
-- element /implies/ a stoked ellipse, e.g.:
--
-- > ellipse (LineWidth 4) zeroPt 40 40 
-- > ellipse EFill zeroPt 40 40  
--
class Ellipse t where
  ellipse :: Fractional u => t -> Point2 u -> u -> u -> Primitive u

instance Ellipse ()             where ellipse () = zellipse
instance Ellipse DrawEllipse    where ellipse dp = mkEllipse psBlack dp

instance Ellipse StrokeAttr     where 
    ellipse = mkEllipse psBlack . EStroke . return

instance Ellipse [StrokeAttr]   where 
    ellipse = mkEllipse psBlack . EStroke

instance Ellipse (RGB3 Double) where 
    ellipse c = mkEllipse (psColour c) EFill

instance Ellipse (HSB3 Double) where 
    ellipse c = mkEllipse (psColour c) EFill

instance Ellipse (Gray Double) where 
    ellipse c = mkEllipse (psColour c) EFill


instance Ellipse (RGB3 Double,DrawEllipse) where 
    ellipse (c,dp) = mkEllipse (psColour c) dp

instance Ellipse (HSB3 Double,DrawEllipse) where 
    ellipse (c,dp) = mkEllipse (psColour c) dp

instance Ellipse (Gray Double,DrawEllipse) where 
    ellipse (c,dp) = mkEllipse (psColour c) dp


instance Ellipse (RGB3 Double,StrokeAttr) where 
    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])

instance Ellipse (HSB3 Double,StrokeAttr) where 
    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])

instance Ellipse (Gray Double,StrokeAttr) where 
    ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])

instance Ellipse (RGB3 Double,[StrokeAttr]) where 
    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)

instance Ellipse (HSB3 Double,[StrokeAttr]) where 
    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)

instance Ellipse (Gray Double,[StrokeAttr]) where 
    ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)


-- | Create a black, filled ellipse. 
zellipse :: Num u => Point2 u -> u -> u -> Primitive u
zellipse = uncurry mkEllipse ellipseDefault


--------------------------------------------------------------------------------

-- Operations on pictures and paths




-- | Extend the bounding box of a picture. 
--
-- The bounding box is both horizontal directions by @x@ and 
-- both vertical directions by @y@. @x@ and @y@ must be positive
-- This function cannot be used to shrink a boundary.
--
extendBoundary :: (Num u, Ord u) => u -> u -> Picture u -> Picture u
extendBoundary x y = mapLocale (\(fr,bb) -> (fr, extBB (posve x) (posve y) bb)) 
  where
    extBB x' y' (BBox (P2 x0 y0) (P2 x1 y1)) = BBox pt1 pt2 where 
        pt1 = P2 (x0-x') (y0-y')
        pt2 = P2 (x1+x') (y1+y')
    
    posve n | n < 0     = 0
            | otherwise = n