GraphicsM.hs

module GraphicsM (
  drawPicture,
  Point(..),
  Vector(..),
  Line(..),
  Picture,
  Colour (..),
  LineStyle (..),
  FillStyle (..),
  PictureObject(..),
  white, black, blue, red, green, yellow, magenta, orange, darkGreen, brown, darkBrown
) where

  -- Rasterific
import Graphics.Rasterific hiding (Point, Vector, Line, Path)
import Graphics.Rasterific.Texture
import Graphics.Rasterific.Transformations



import Codec.Picture

data Colour
  = Colour
    { redC      :: Int
    , greenC    :: Int
    , blueC     :: Int
    , opacityC  :: Int
    }
  deriving (Show, Eq)

white      = Colour 255  255 255 255
black      = Colour   0    0   0 255
blue       = Colour   0    0 255 255
red        = Colour 255    0   0 255
brown      = Colour 114   53  14 200
darkBrown  = Colour  43   17   0 250
green      = Colour  57  175  24 235
darkGreen  = Colour  22   89   3 255
yellow     = Colour 255  255   0 235
magenta    = Colour 153    0 153 255
orange     = Colour 254  154  46 255


data Point
  = Point
    { xPoint :: Float
    , yPoint :: Float
    }

data Vector
  = Vector
    { xVector :: Float
    , yVector :: Float
    }

data Line
  = Line
    { startLine :: Point
    , endLine   :: Point
    }


data LineStyle
  = Solid
  | Dashed
  | Dotted

data FillStyle
  = NoFill
  | SolidFill
   deriving (Eq, Show)

data PictureObject
  = Path
    { pointsPO    :: [Point]
    , colourPO    :: Colour
    , lineStylePO :: LineStyle
    }
  | Circle
    { centerPO    :: Point
    , radiusPO    :: Float
    , colourPO    :: Colour
    , lineStylePO :: LineStyle
    , fillStylePO :: FillStyle
    }
  | Ellipse
    { centerPO    :: Point
    , widthPO     :: Float
    , heightPO    :: Float
    , rotationPO  :: Float
    , colourPO    :: Colour
    , lineStylePO :: LineStyle
    , fillStylePO :: FillStyle
    }
  | Polygon
    { pointsPO    :: [Point]
    , colourPO    :: Colour
    , lineStylePO :: LineStyle
    , fillStylePO :: FillStyle
    }

type Picture = [PictureObject]


drawPicture linewidth picture
  = renderDrawing  1920 1080 (toColour (Colour 255 255 255 150)) $ do
      { mapM drawObj picture
      ; return ()
      }
  where
    style SolidFill _ = fill
    style _ Solid     = stroke linewidth  JoinRound (CapRound, CapRound)
    style _ Dashed    = dashed linewidth  JoinRound (CapRound, CapRound)
    style _ Dotted    = dotted linewidth  JoinRound (CapRound, CapRound)

    dotted = dashedStroke [linewidth/12, 2 * linewidth]
    dashed = dashedStroke [3* linewidth, 6 * linewidth]

    texture colour = withTexture (uniformTexture $ toColour colour)
    textureG  (x1, y1) (x2, y2)
      = withTexture (linearGradientTexture
          [(0, PixelRGBA8 255 0 0 255), (1, PixelRGBA8 255 255 255 255)]
                (V2 x1 y1)(V2 x2 y2))
    drawObj (Path points colour lineStyle) =
      texture colour
         $ style NoFill lineStyle
         $ polyline
         $ map (\((Point x y)) -> V2 x y) points
    drawObj (Circle (Point px py) radius colour lineStyle fillStyle) =
      texture colour
         $ style fillStyle lineStyle
         $ circle (V2 px py) radius
    drawObj (Ellipse (Point px py) h w r colour lineStyle fillStyle) =
      texture colour
         $ style fillStyle lineStyle
           . transform (applyTransformation
                       $ rotateCenter r (V2 px py))
         $ ellipse (V2 px py) h w
    drawObj (Polygon points colour lineStyle fillStyle) =
      texture colour
         $ style fillStyle lineStyle
         $ polygon
         $ map (\((Point x y)) -> V2 x y) points


    toColour (Colour a b c d)
      = PixelRGBA8 (fromIntegral a) (fromIntegral b) (fromIntegral c) (fromIntegral d)