{-# 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
    { TextRange px -> Font
_textFont    :: Font      -- ^ Font used during the rendering

    , TextRange px -> PointSize
_textSize    :: PointSize -- ^ Size of the text (in pixels)

    , TextRange px -> String
_text        :: String    -- ^ Text to draw

      -- | Texture to use for drawing, if Nothing, the currently

      -- active texture is used.

    , TextRange px -> Maybe (Texture px)
_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 :: Drawing px () -> String
dumpDrawing = Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go (Free (DrawCommand px) () -> String)
-> (Drawing px () -> Free (DrawCommand px) ())
-> Drawing px ()
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF where
  go ::
        ( Show px
        , Show (PixelBaseComponent px)
        , PixelBaseComponent (PixelBaseComponent px)
                    ~ (PixelBaseComponent px)

        ) => Free (DrawCommand px) () -> String
  go :: Free (DrawCommand px) () -> String
go (Pure ()) = String
"return ()"
  go (Free (MeshPatchRender PatchInterpolation
i MeshPatch px
m Free (DrawCommand px) ()
next)) =
    String
"renderMeshPatch (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInterpolation -> String
forall a. Show a => a -> String
show PatchInterpolation
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ MeshPatch px -> String
forall a. Show a => a -> String
show MeshPatch px
m String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
  go (Free (CustomRender forall s. DrawContext (ST s) px ()
_r Free (DrawCommand px) ()
next)) =
    String
"customRender _ >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
  go (Free (WithImageEffect Image px -> ImageTransformer px
_effect Drawing px ()
sub Free (DrawCommand px) ()
next)) =
    String
"withImageEffect ({- fun -}) (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
sub) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
  go (Free (WithGlobalOpacity PixelBaseComponent px
opa Drawing px ()
sub Free (DrawCommand px) ()
next)) =
    String
"withGlobalOpacity " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PixelBaseComponent px -> String
forall a. Show a => a -> String
show PixelBaseComponent px
opa String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
sub) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
  go (Free (WithPathOrientation Path
path Float
point Drawing px ()
drawing Free (DrawCommand px) ()
next)) =
    String
"withPathOrientation (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Path -> String
forall a. Show a => a -> String
show Path
path String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ("
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Float -> String
forall a. Show a => a -> String
show Float
point String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ("
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
drawing) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") >>= "
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
  go (Free (Fill FillMethod
_ [Primitive]
prims Free (DrawCommand px) ()
next)) =
    String
"fill " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Primitive] -> String
forall a. Show a => a -> String
show [Primitive]
prims String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" >>=\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++   Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
  go (Free (TextFill Point
_ [TextRange px]
texts Free (DrawCommand px) ()
next)) =
   [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat  [String
"-- Text : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TextRange px -> String
forall px. TextRange px -> String
_text TextRange px
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" | TextRange px
t <- [TextRange px]
texts] String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
  go (Free (SetTexture Texture px
tx Drawing px ()
drawing Free (DrawCommand px) ()
next)) =
    String
"withTexture (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Texture px -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Texture px -> String
dumpTexture Texture px
tx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") (" String -> String -> String
forall a. [a] -> [a] -> [a]
++
              Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
drawing) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") >>=\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
  go (Free (DashedStroke Float
o DashPattern
pat Float
w Join
j (Cap, Cap)
cap [Primitive]
prims Free (DrawCommand px) ()
next)) =
    String
"dashedStrokeWithOffset "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Float -> String
forall a. Show a => a -> String
show Float
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ DashPattern -> String
forall a. Show a => a -> String
show DashPattern
pat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Float -> String
forall a. Show a => a -> String
show Float
w String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ("
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Join -> String
forall a. Show a => a -> String
show Join
j String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Cap, Cap) -> String
forall a. Show a => a -> String
show (Cap, Cap)
cap String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Primitive] -> String
forall a. Show a => a -> String
show [Primitive]
prims String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" >>=\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++   Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
  go (Free (Stroke Float
w Join
j (Cap, Cap)
cap [Primitive]
prims Free (DrawCommand px) ()
next)) =
    String
"stroke " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Float -> String
forall a. Show a => a -> String
show Float
w String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ("
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Join -> String
forall a. Show a => a -> String
show Join
j String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Cap, Cap) -> String
forall a. Show a => a -> String
show (Cap, Cap)
cap String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Primitive] -> String
forall a. Show a => a -> String
show [Primitive]
prims String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" >>=\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++   Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
  go (Free (WithTransform Transformation
trans Drawing px ()
sub Free (DrawCommand px) ()
next)) =
    String
"withTransform (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Transformation -> String
forall a. Show a => a -> String
show Transformation
trans String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ("
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
sub) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") >>=\n "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
  go (Free (WithCliping forall innerPixel. Drawing innerPixel ()
clipping Drawing px ()
draw Free (DrawCommand px) ()
next)) =
    String
"withClipping (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand Pixel8) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go (F (DrawCommand Pixel8) () -> Free (DrawCommand Pixel8) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF (F (DrawCommand Pixel8) () -> Free (DrawCommand Pixel8) ())
-> F (DrawCommand Pixel8) () -> Free (DrawCommand Pixel8) ()
forall a b. (a -> b) -> a -> b
$ Texture Pixel8
-> F (DrawCommand Pixel8) () -> F (DrawCommand Pixel8) ()
forall px (m :: * -> *).
MonadFree (DrawCommand px) m =>
Texture px -> Drawing px () -> m ()
withTexture Texture Pixel8
clipTexture F (DrawCommand Pixel8) ()
forall innerPixel. Drawing innerPixel ()
clipping)
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
        String
"         (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go (Drawing px () -> Free (DrawCommand px) ()
forall (f :: * -> *) (m :: * -> *) a. MonadFree f m => F f a -> m a
fromF Drawing px ()
draw) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")\n >>= " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              Free (DrawCommand px) () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Free (DrawCommand px) () -> String
go Free (DrawCommand px) ()
next
        where clipTexture :: Texture Pixel8
clipTexture = Pixel8 -> Texture Pixel8
forall px. px -> Texture px
SolidTexture (Pixel8
0xFF :: Pixel8)
              withTexture :: Texture px -> Drawing px () -> m ()
withTexture Texture px
texture Drawing px ()
subActions =
                 DrawCommand px () -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (DrawCommand px () -> m ()) -> DrawCommand px () -> m ()
forall a b. (a -> b) -> a -> b
$ Texture px -> Drawing px () -> () -> DrawCommand px ()
forall px next.
Texture px -> Drawing px () -> next -> DrawCommand px next
SetTexture Texture px
texture Drawing px ()
subActions ()

dumpTexture :: ( Show px
               , Show (PixelBaseComponent px)
               , PixelBaseComponent (PixelBaseComponent px)
                    ~ (PixelBaseComponent px)
               ) => Texture px -> String
dumpTexture :: Texture px -> String
dumpTexture (SolidTexture px
px) = String
"uniformTexture (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ px -> String
forall a. Show a => a -> String
show px
px String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
dumpTexture (MeshPatchTexture PatchInterpolation
i MeshPatch px
mpx) = String
"meshTexture (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PatchInterpolation -> String
forall a. Show a => a -> String
show PatchInterpolation
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ MeshPatch px -> String
forall a. Show a => a -> String
show MeshPatch px
mpx String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
dumpTexture (LinearGradientTexture Gradient px
grad (Line Point
a Point
b)) =
    String
"linearGradientTexture " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Gradient px -> String
forall a. Show a => a -> String
show Gradient px
grad String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
b String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
dumpTexture (RadialGradientTexture Gradient px
grad Point
p Float
rad) =
    String
"radialGradientTexture " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Gradient px -> String
forall a. Show a => a -> String
show Gradient px
grad String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Float -> String
forall a. Show a => a -> String
show Float
rad
dumpTexture (RadialGradientWithFocusTexture Gradient px
grad Point
center Float
rad Point
focus) =
    String
"radialGradientWithFocusTexture " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Gradient px -> String
forall a. Show a => a -> String
show Gradient px
grad String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
center 
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Float -> String
forall a. Show a => a -> String
show Float
rad String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point -> String
forall a. Show a => a -> String
show Point
focus String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
dumpTexture (WithSampler SamplerRepeat
sampler Texture px
sub) =
    String
"withSampler " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SamplerRepeat -> String
forall a. Show a => a -> String
show SamplerRepeat
sampler String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Texture px -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Texture px -> String
dumpTexture Texture px
sub String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
dumpTexture (WithTextureTransform Transformation
trans Texture px
sub) =
    String
"transformTexture (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Transformation -> String
forall a. Show a => a -> String
show Transformation
trans String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Texture px -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Texture px -> String
dumpTexture Texture px
sub String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
dumpTexture (SampledTexture Image px
_) = String
"sampledImageTexture <IMG>"
dumpTexture (RawTexture Image px
_) = String
"<RAWTEXTURE>"
dumpTexture (ShaderTexture ShaderFunction px
_) = String
"shaderFunction <FUNCTION>"
dumpTexture (ModulateTexture Texture px
sub Texture (PixelBaseComponent px)
mask) =
    String
"modulateTexture (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Texture px -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Texture px -> String
dumpTexture Texture px
sub String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ("
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Texture (PixelBaseComponent px) -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Texture px -> String
dumpTexture Texture (PixelBaseComponent px)
mask String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
dumpTexture (AlphaModulateTexture Texture px
sub Texture (PixelBaseComponent px)
mask) =
    String
"alphaModulate (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Texture px -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Texture px -> String
dumpTexture Texture px
sub String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ("
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Texture (PixelBaseComponent px) -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Texture px -> String
dumpTexture Texture (PixelBaseComponent px)
mask String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
dumpTexture (PatternTexture Int
w Int
h px
px Drawing px ()
sub Image px
_) =
    String
"patternTexture " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
w String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ px -> String
forall a. Show a => a -> String
show px
px
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Drawing px () -> String
forall px.
(Show px, Show (PixelBaseComponent px),
 PixelBaseComponent (PixelBaseComponent px)
 ~ PixelBaseComponent px) =>
Drawing px () -> String
dumpDrawing Drawing px ()
sub String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"


instance Functor (DrawCommand px) where
    fmap :: (a -> b) -> DrawCommand px a -> DrawCommand px b
fmap a -> b
f (WithImageEffect Image px -> ImageTransformer px
effect Drawing px ()
sub a
next) =
        (Image px -> ImageTransformer px)
-> Drawing px () -> b -> DrawCommand px b
forall px next.
(Image px -> ImageTransformer px)
-> Drawing px () -> next -> DrawCommand px next
WithImageEffect Image px -> ImageTransformer px
effect Drawing px ()
sub (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next
    fmap a -> b
f (TextFill Point
pos [TextRange px]
texts a
next) =
        Point -> [TextRange px] -> b -> DrawCommand px b
forall px next.
Point -> [TextRange px] -> next -> DrawCommand px next
TextFill Point
pos [TextRange px]
texts (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next
    fmap a -> b
f (CustomRender forall s. DrawContext (ST s) px ()
m a
next) =
        (forall s. DrawContext (ST s) px ()) -> b -> DrawCommand px b
forall px next.
(forall s. DrawContext (ST s) px ()) -> next -> DrawCommand px next
CustomRender forall s. DrawContext (ST s) px ()
m (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next
    fmap a -> b
f (WithGlobalOpacity PixelBaseComponent px
opa Drawing px ()
sub a
next) =
        PixelBaseComponent px -> Drawing px () -> b -> DrawCommand px b
forall px next.
PixelBaseComponent px
-> Drawing px () -> next -> DrawCommand px next
WithGlobalOpacity PixelBaseComponent px
opa Drawing px ()
sub (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next
    fmap a -> b
f (Fill FillMethod
method  [Primitive]
prims a
next) = FillMethod -> [Primitive] -> b -> DrawCommand px b
forall px next.
FillMethod -> [Primitive] -> next -> DrawCommand px next
Fill FillMethod
method [Primitive]
prims (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next
    fmap a -> b
f (SetTexture Texture px
t Drawing px ()
sub a
next) = Texture px -> Drawing px () -> b -> DrawCommand px b
forall px next.
Texture px -> Drawing px () -> next -> DrawCommand px next
SetTexture Texture px
t Drawing px ()
sub (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next
    fmap a -> b
f (WithCliping forall innerPixel. Drawing innerPixel ()
sub Drawing px ()
com a
next) =
        (forall innerPixel. Drawing innerPixel ())
-> Drawing px () -> b -> DrawCommand px b
forall px next.
(forall innerPixel. Drawing innerPixel ())
-> Drawing px () -> next -> DrawCommand px next
WithCliping forall innerPixel. Drawing innerPixel ()
sub Drawing px ()
com (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next
    fmap a -> b
f (Stroke Float
w Join
j (Cap, Cap)
caps [Primitive]
prims a
next) =
        Float -> Join -> (Cap, Cap) -> [Primitive] -> b -> DrawCommand px b
forall px next.
Float
-> Join -> (Cap, Cap) -> [Primitive] -> next -> DrawCommand px next
Stroke Float
w Join
j (Cap, Cap)
caps [Primitive]
prims (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next
    fmap a -> b
f (DashedStroke Float
st DashPattern
pat Float
w Join
j (Cap, Cap)
caps [Primitive]
prims a
next) =
        Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> b
-> DrawCommand px b
forall px next.
Float
-> DashPattern
-> Float
-> Join
-> (Cap, Cap)
-> [Primitive]
-> next
-> DrawCommand px next
DashedStroke Float
st DashPattern
pat Float
w Join
j (Cap, Cap)
caps [Primitive]
prims (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next
    fmap a -> b
f (WithTransform Transformation
trans Drawing px ()
draw a
next) =
        Transformation -> Drawing px () -> b -> DrawCommand px b
forall px next.
Transformation -> Drawing px () -> next -> DrawCommand px next
WithTransform Transformation
trans Drawing px ()
draw (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next
    fmap a -> b
f (WithPathOrientation Path
path Float
point Drawing px ()
draw a
next) =
        Path -> Float -> Drawing px () -> b -> DrawCommand px b
forall px next.
Path -> Float -> Drawing px () -> next -> DrawCommand px next
WithPathOrientation Path
path Float
point Drawing px ()
draw (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next
    fmap a -> b
f (MeshPatchRender PatchInterpolation
i MeshPatch px
mesh a
next) =
        PatchInterpolation -> MeshPatch px -> b -> DrawCommand px b
forall px next.
PatchInterpolation -> MeshPatch px -> next -> DrawCommand px next
MeshPatchRender PatchInterpolation
i MeshPatch px
mesh (b -> DrawCommand px b) -> b -> DrawCommand px b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
next

instance Semigroup (Drawing px ()) where
    <> :: Drawing px () -> Drawing px () -> Drawing px ()
(<>) Drawing px ()
a Drawing px ()
b = Drawing px ()
a Drawing px () -> Drawing px () -> Drawing px ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Drawing px ()
b

instance Monoid (Drawing px ()) where
    mempty :: Drawing px ()
mempty = () -> Drawing px ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    mappend :: Drawing px () -> Drawing px () -> Drawing px ()
mappend = Drawing px () -> Drawing px () -> Drawing px ()
forall a. Semigroup a => a -> a -> a
(<>)