content: {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE TypeSynonymInstances #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE TypeFamilies #-}
  module Graphics.Rasterific.Command ( Drawing
                                     , DrawCommand( .. )
                                     , DrawContext
                                     , TextRange( .. )
                                     , dumpDrawing
                                     , Texture( .. )
                                     , Gradient
                                     , ShaderFunction
                                     , ImageTransformer
                                     , dumpTexture
                                     ) where
  
  import Data.Kind ( Type )
  
  import Control.Monad.ST( ST )
  import Control.Monad.State( StateT )
  import Control.Monad.Primitive( PrimState )
  import Control.Monad.Free( Free( .. ), liftF )
  import Control.Monad.Free.Church( F, fromF )
  import Codec.Picture.Types( Image, Pixel( .. ), Pixel8 )
  
  import Codec.Picture.Types( MutableImage )
  import Graphics.Rasterific.Types
  import Graphics.Rasterific.Transformations
  import Graphics.Rasterific.PatchTypes
  
  import Graphics.Text.TrueType( Font, PointSize )
  
  -- | Monad used to record the drawing actions.
  type Drawing px = F (DrawCommand px)
  
  -- | Monad used to describe the drawing context.
  type DrawContext m px =
      StateT (MutableImage (PrimState m) px) m
  
  -- | Structure defining how to render a text range
  data TextRange px = TextRange
      { _textFont    :: Font      -- ^ Font used during the rendering
      , _textSize    :: PointSize -- ^ Size of the text (in pixels)
      , _text        :: String    -- ^ Text to draw
        -- | Texture to use for drawing, if Nothing, the currently
        -- active texture is used.
      , _textTexture :: Maybe (Texture px)
      }
  
  type ShaderFunction px = Float -> Float -> px
  
  type ImageTransformer px = Int -> Int -> px -> px
  
  -- | A gradient definition is just a list of stop
  -- and pixel values. For instance for a simple gradient
  -- of black to white, the finition would be :
  --
  -- > [(0, PixelRGBA8 0 0 0 255), (1, PixelRGBA8 255 255 255 255)]
  -- 
  -- the first stop value must be zero and the last, one.
  --
  type Gradient px = [(Float, px)]
  
  -- | Reification of texture type
  data Texture (px :: Type)
    = SolidTexture !px
    | LinearGradientTexture !(Gradient px) !Line 
    | RadialGradientTexture !(Gradient px) !Point !Float
    | RadialGradientWithFocusTexture !(Gradient px) !Point !Float !Point
    | WithSampler    !SamplerRepeat (Texture px)
    | WithTextureTransform !Transformation (Texture px)
    | SampledTexture !(Image px)
    | RawTexture     !(Image px)
    | ShaderTexture  !(ShaderFunction px)
    | ModulateTexture (Texture px) (Texture (PixelBaseComponent px))
    | AlphaModulateTexture (Texture px) (Texture (PixelBaseComponent px))
    | PatternTexture !Int !Int !px (Drawing px ()) (Image px)
    | MeshPatchTexture !PatchInterpolation !(MeshPatch px)
  
  
  data DrawCommand px next
    = Fill FillMethod [Primitive] next
    | CustomRender (forall s. DrawContext (ST s) px ()) next
    | MeshPatchRender !PatchInterpolation (MeshPatch px) next
    | Stroke Float Join (Cap, Cap) [Primitive] next
    | DashedStroke Float DashPattern Float Join (Cap, Cap) [Primitive] next
    | TextFill Point [TextRange px] next
    | SetTexture (Texture px)
                 (Drawing px ()) next
    | WithGlobalOpacity (PixelBaseComponent px) (Drawing px ()) next
    | WithImageEffect (Image px -> ImageTransformer px) (Drawing px ()) next
    | WithCliping (forall innerPixel. Drawing innerPixel ())
                  (Drawing px ()) next
    | WithTransform Transformation (Drawing px ()) next
    | WithPathOrientation Path Float (Drawing px ()) next
  
  -- | This function will spit out drawing instructions to
  -- help debugging.
  --
  -- The outputted code looks like Haskell, but there is no
  -- guarantee that it is compilable.
  dumpDrawing :: ( Show px
                 , Show (PixelBaseComponent px)
                 , PixelBaseComponent (PixelBaseComponent px)
                      ~ (PixelBaseComponent px)
  
                 ) => Drawing px () -> String
  dumpDrawing = go . fromF where
    go ::
          ( Show px
          , Show (PixelBaseComponent px)
          , PixelBaseComponent (PixelBaseComponent px)
                      ~ (PixelBaseComponent px)
  
          ) => Free (DrawCommand px) () -> String
    go (Pure ()) = "return ()"
    go (Free (MeshPatchRender i m next)) =
      "renderMeshPatch (" ++ show i ++ ") (" ++ show m ++ ") >>= " ++ go next
    go (Free (CustomRender _r next)) =
      "customRender _ >>= " ++ go next
    go (Free (WithImageEffect _effect sub next)) =
      "withImageEffect ({- fun -}) (" ++ go (fromF sub) ++ ") >>= " ++ go next
    go (Free (WithGlobalOpacity opa sub next)) =
      "withGlobalOpacity " ++ show opa ++ " (" ++ go (fromF sub) ++ ") >>= " ++ go next
    go (Free (WithPathOrientation path point drawing next)) =
      "withPathOrientation (" ++ show path ++ ") ("
                              ++ show point ++ ") ("
                              ++ go (fromF drawing) ++ ") >>= "
                              ++ go next
    go (Free (Fill _ prims next)) =
      "fill " ++ show prims ++ " >>=\n" ++   go next
    go (Free (TextFill _ texts next)) =
     concat  ["-- Text : " ++ _text t ++ "\n" | t <- texts] ++ go next
    go (Free (SetTexture tx drawing next)) =
      "withTexture (" ++ dumpTexture tx ++ ") (" ++
                go (fromF drawing) ++ ") >>=\n" ++ go next
    go (Free (DashedStroke o pat w j cap prims next)) =
      "dashedStrokeWithOffset "
                ++ show o ++ " "
                ++ show pat ++ " "
                ++ show w ++ " ("
                ++ show j ++ ") "
                ++ show cap ++ " "
                ++ show prims ++ " >>=\n" ++   go next
    go (Free (Stroke w j cap prims next)) =
      "stroke " ++ show w ++ " ("
                ++ show j ++ ") "
                ++ show cap ++ " "
                ++ show prims ++ " >>=\n" ++   go next
    go (Free (WithTransform trans sub next)) =
      "withTransform (" ++ show trans ++ ") ("
                        ++ go (fromF sub) ++ ") >>=\n "
                        ++ go next
    go (Free (WithCliping clipping draw next)) =
      "withClipping (" ++ go (fromF $ withTexture clipTexture clipping)
                       ++ ")\n" ++
          "         (" ++ go (fromF draw) ++ ")\n >>= " ++
                go next
          where clipTexture = SolidTexture (0xFF :: Pixel8)
                withTexture texture subActions =
                   liftF $ SetTexture texture subActions ()
  
  dumpTexture :: ( Show px
                 , Show (PixelBaseComponent px)
                 , PixelBaseComponent (PixelBaseComponent px)
                      ~ (PixelBaseComponent px)
                 ) => Texture px -> String
  dumpTexture (SolidTexture px) = "uniformTexture (" ++ show px ++ ")"
  dumpTexture (MeshPatchTexture i mpx) = "meshTexture (" ++ show i ++ ") (" ++ show mpx ++ ")"
  dumpTexture (LinearGradientTexture grad (Line a b)) =
      "linearGradientTexture " ++ show grad ++ " (" ++ show a ++ ") (" ++ show b ++ ")"
  dumpTexture (RadialGradientTexture grad p rad) =
      "radialGradientTexture " ++ show grad ++ " (" ++ show p ++ ") " ++ show rad
  dumpTexture (RadialGradientWithFocusTexture grad center rad focus) =
      "radialGradientWithFocusTexture " ++ show grad ++ " (" ++ show center 
                                        ++ ") " ++ show rad ++ " (" ++ show focus ++ ")"
  dumpTexture (WithSampler sampler sub) =
      "withSampler " ++ show sampler ++ " (" ++ dumpTexture sub ++ ")"
  dumpTexture (WithTextureTransform trans sub) =
      "transformTexture (" ++ show trans ++ ") (" ++ dumpTexture sub ++ ")"
  dumpTexture (SampledTexture _) = "sampledImageTexture <IMG>"
  dumpTexture (RawTexture _) = "<RAWTEXTURE>"
  dumpTexture (ShaderTexture _) = "shaderFunction <FUNCTION>"
  dumpTexture (ModulateTexture sub mask) =
      "modulateTexture (" ++ dumpTexture sub ++ ") ("
                          ++ dumpTexture mask ++ ")"
  dumpTexture (AlphaModulateTexture sub mask) =
      "alphaModulate (" ++ dumpTexture sub ++ ") ("
                        ++ dumpTexture mask ++ ")"
  dumpTexture (PatternTexture w h px sub _) =
      "patternTexture " ++ show w ++ " " ++ show h ++ " " ++ show px
                        ++ " (" ++ dumpDrawing sub ++ ")"
  
  
  instance Functor (DrawCommand px) where
      fmap f (WithImageEffect effect sub next) =
          WithImageEffect effect sub $ f next
      fmap f (TextFill pos texts next) =
          TextFill pos texts $ f next
      fmap f (CustomRender m next) =
          CustomRender m $ f next
      fmap f (WithGlobalOpacity opa sub next) =
          WithGlobalOpacity opa sub $ f next
      fmap f (Fill method  prims next) = Fill method prims $ f next
      fmap f (SetTexture t sub next) = SetTexture t sub $ f next
      fmap f (WithCliping sub com next) =
          WithCliping sub com $ f next
      fmap f (Stroke w j caps prims next) =
          Stroke w j caps prims $ f next
      fmap f (DashedStroke st pat w j caps prims next) =
          DashedStroke st pat w j caps prims $ f next
      fmap f (WithTransform trans draw next) =
          WithTransform trans draw $ f next
      fmap f (WithPathOrientation path point draw next) =
          WithPathOrientation path point draw $ f next
      fmap f (MeshPatchRender i mesh next) =
          MeshPatchRender i mesh $ f next
  
  instance Semigroup (Drawing px ()) where
      (<>) a b = a >> b
  
  instance Monoid (Drawing px ()) where
      mempty = return ()
      mappend = (<>)
  
  