path: root/tests/accept/Builtins.lc

{-# LANGUAGE NoImplicitPrelude #-}
module Builtins where

id x = x

data Bool = False | True

data Ordering = LT | EQ | GT

builtins
  PrimIfThenElse :: Bool -> a -> a -> a

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

data Nat where
data Int where
data Word where
data Float where
data Char where
data String where

type family TFVec (n :: Nat) a                  -- may be a data family
type family VecScalar (n :: Nat) a
type family TFMat i j                           -- may be a data family
type family MatVecElem a
type family MatVecScalarElem a
type family FTRepr' a
type family ColorRepr a
type family TFFrameBuffer a
type family FragOps a
type family JoinTupleType t1 t2
class AttributeTuple a
class ValidOutput a
class ValidFrameBuffer a

data Vec (n :: Nat) a where
  V2 :: a -> a -> Vec 2 a
  V3 :: a -> a -> a -> Vec 3 a
  V4 :: a -> a -> a -> a -> Vec 4 a

-- builtins
--  V1 :: a -> Vec 2 a            -- TODO: eliminate

data Mat (i :: Nat) (j :: Nat) a where
  M22F :: Vec 2 Float -> Vec 2 Float -> Mat 2 2 Float
  M23F :: Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Mat 2 3 Float
  M24F :: Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Mat 2 4 Float
  M32F :: Vec 3 Float -> Vec 3 Float -> Mat 3 2 Float
  M33F :: Vec 3 Float -> Vec 3 Float -> Vec 3 Float -> Mat 3 3 Float
  M34F :: Vec 3 Float -> Vec 3 Float -> Vec 3 Float -> Vec 3 Float -> Mat 3 4 Float
  M42F :: Vec 4 Float -> Vec 4 Float -> Mat 4 2 Float
  M43F :: Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Mat 4 3 Float
  M44F :: Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Mat 4 4 Float

--------------------------------------- type classes

class CNum a

instance CNum           Int
instance CNum           Float

class Signed a

instance Signed         Int
instance Signed         Float

class Num a where
  fromInt :: Int -> a
  compare :: a -> a -> Ordering
  negate :: a -> a

builtins
  primIntToWord  :: Int -> Word
  primIntToFloat :: Int -> Float
  primCompareInt   :: Int   -> Int   -> Ordering
  primCompareWord  :: Word  -> Word  -> Ordering
  primCompareFloat :: Float -> Float -> Ordering
  primNegateInt   :: Int   -> Int
  primNegateWord  :: Word  -> Word
  primNegateFloat :: Float -> Float

instance Num Int where
  fromInt = id
  compare = primCompareInt
  negate = primNegateInt
instance Num Word where
  fromInt = primIntToWord
  compare = primCompareWord
  negate = primNegateWord
instance Num Float where
  fromInt = primIntToFloat
  compare = primCompareFloat
  negate = primNegateFloat

class Component a where
  vec2 :: a -> a -> Vec 2 a
  vec3 :: a -> a -> a -> Vec 3 a
  vec4 :: a -> a -> a -> a -> Vec 4 a
  zeroComp :: a
  oneComp :: a
--  PrimZero, PrimOne :: {- (Component a) => -- TODO -} a


instance Component Bool where
  vec2 = V2
  vec3 = V3
  vec4 = V4
  zeroComp = False
  oneComp = True

instance Component Int where
  vec2 = V2
  vec3 = V3
  vec4 = V4
  zeroComp = 0
  oneComp = 1

instance Component Word where
  vec2 = V2
  vec3 = V3
  vec4 = V4
  zeroComp = 0
  oneComp = 1

instance Component Float where
  vec2 = V2
  vec3 = V3
  vec4 = V4
  zeroComp = 0
  oneComp = 1

instance Component (Vec 2 Float) where
  vec2 = V2
  vec3 = V3
  vec4 = V4
  zeroComp = V2 0.0 0.0
  oneComp = V2 1.0 1.0
instance Component (Vec 3 Float) where
  vec2 = V2
  vec3 = V3
  vec4 = V4
  zeroComp = V3 0.0 0.0 0.0
  oneComp = V3 1.0 1.0 1.0
instance Component (Vec 4 Float) where
  vec2 = V2
  vec3 = V3
  vec4 = V4
  zeroComp = V4 0.0 0.0 0.0 0.0
  oneComp = V4 1.0 1.0 1.0 1.0

--instance Component (Vec 2 Bool) where
--instance Component (Vec 3 Bool) where

instance Component (Vec 4 Bool) where
  vec2 = V2
  vec3 = V3
  vec4 = V4
  zeroComp = V4 False False False False
  oneComp = V4 True True True True


class Integral a

instance Integral       Int
instance Integral       Word

class NumComponent a

instance NumComponent   Int
instance NumComponent   Word
instance NumComponent   Float
instance NumComponent   (Vec 2 Float)
instance NumComponent   (Vec 3 Float)
instance NumComponent   (Vec 4 Float)

class Floating a

instance Floating       Float
instance Floating       (Vec 2 Float)
instance Floating       (Vec 3 Float)
instance Floating       (Vec 4 Float)
instance Floating       (Mat 2 2 Float)
instance Floating       (Mat 2 3 Float)
instance Floating       (Mat 2 4 Float)
instance Floating       (Mat 3 2 Float)
instance Floating       (Mat 3 3 Float)
instance Floating       (Mat 3 4 Float)
instance Floating       (Mat 4 2 Float)
instance Floating       (Mat 4 3 Float)
instance Floating       (Mat 4 4 Float)


data BlendingFactor
    = Zero'
    | One
    | SrcColor
    | OneMinusSrcColor
    | DstColor
    | OneMinusDstColor
    | SrcAlpha
    | OneMinusSrcAlpha
    | DstAlpha
    | OneMinusDstAlpha
    | ConstantColor
    | OneMinusConstantColor
    | ConstantAlpha
    | OneMinusConstantAlpha
    | SrcAlphaSaturate

data BlendEquation
    = FuncAdd
    | FuncSubtract
    | FuncReverseSubtract
    | Min
    | Max

data LogicOperation
    = Clear
    | And
    | AndReverse
    | Copy
    | AndInverted
    | Noop
    | Xor
    | Or
    | Nor
    | Equiv
    | Invert
    | OrReverse
    | CopyInverted
    | OrInverted
    | Nand
    | Set

data StencilOperation
    = OpZero
    | OpKeep
    | OpReplace
    | OpIncr
    | OpIncrWrap
    | OpDecr
    | OpDecrWrap
    | OpInvert

data ComparisonFunction
    = Never
    | Less
    | Equal
    | Lequal
    | Greater
    | Notequal
    | Gequal
    | Always

data ProvokingVertex
    = LastVertex
    | FirstVertex

data FrontFace
    = CW
    | CCW

data CullMode
    = CullFront FrontFace
    | CullBack FrontFace
    | CullNone

data PointSize
    = PointSize Float
    | ProgramPointSize

data PolygonMode
    = PolygonFill
    | PolygonPoint PointSize
    | PolygonLine Float

data PolygonOffset
    = NoOffset
    | Offset Float Float

data PointSpriteCoordOrigin
    = LowerLeft
    | UpperLeft


data Depth a where
data Stencil a where
data Color a where

data PrimitiveType
    = Triangle
    | Line
    | Point
    | TriangleAdjacency
    | LineAdjacency

builtins
  PrimTexture :: () -> Vec 2 Float -> Vec 4 Float

builtins
  Uniform   :: String -> t
  Attribute :: String -> t

data FragmentOut a where
  FragmentOut         :: (a ~ ColorRepr t) => t                 -> FragmentOut a
  FragmentOutDepth    :: (a ~ ColorRepr t, b ~ JoinTupleType (Depth Float) a) => Float -> t
                                                                -> FragmentOut b
  FragmentOutRastDepth :: (a ~ ColorRepr t, b ~ JoinTupleType (Depth Float) a) => t
                                                                -> FragmentOut b

data VertexOut a where
  VertexOut           :: (t ~ FTRepr' a) => Vec 4 Float -> Float -> (){-TODO-} -> a -> VertexOut t

data RasterContext (a :: PrimitiveType) where
  TriangleCtx         :: CullMode -> PolygonMode -> PolygonOffset -> ProvokingVertex -> RasterContext Triangle
  PointCtx            :: PointSize -> Float -> PointSpriteCoordOrigin                -> RasterContext Point
  LineCtx             :: Float -> ProvokingVertex                                    -> RasterContext Line

data FetchPrimitive (a :: PrimitiveType) where
   Points              :: FetchPrimitive Point
   Lines               :: FetchPrimitive Line
   Triangles           :: FetchPrimitive Triangle
   LinesAdjacency      :: FetchPrimitive LineAdjacency
   TrianglesAdjacency  :: FetchPrimitive TriangleAdjacency

data AccumulationContext a where
  AccumulationContext :: (t' ~ FragOps t) => t -> AccumulationContext t'

data Image (a :: Nat) b{-Semantic-} where
  ColorImage          :: (Num t, color ~ VecScalar d t)
                      => forall (a :: Nat) . color  -> Image a (Color color)
  DepthImage          :: forall (a :: Nat) . Float  -> Image a (Depth Float)
  StencilImage        :: forall (a :: Nat) . Int    -> Image a (Stencil Int)

data Interpolated t where
  Smooth, NoPerspective
                      :: (Floating t) => t -> Interpolated t
  Flat                ::                 t -> Interpolated t

data Blending a where
  NoBlending          ::                                   Blending t
  BlendLogicOp        :: (Integral t) => LogicOperation -> Blending t
  Blend               :: (BlendEquation, BlendEquation)
                         -> ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor))
                         -> Vec 4 Float ->                 Blending Float

{- TODO: more precise kinds
  FragmentOperation    :: Semantic -> *
  FragmentOut          :: Semantic -> *
  VertexOut            :: ???
-}
data FragmentOperation a where
  ColorOp             :: (mask ~ VecScalar d Bool, color ~ VecScalar d c, Num c) => Blending c -> mask
                                                                   -> FragmentOperation (Color color)
  DepthOp             :: ComparisonFunction -> Bool                -> FragmentOperation (Depth Float)
    -- StencilOp       :: StencilTests -> StencilOps -> StencilOps -> FragmentOperation (Stencil Int32)

data FragmentFilter t where
  PassAll             ::                FragmentFilter t
  Filter              :: (t -> Bool) -> FragmentFilter t

data VertexStream (a :: PrimitiveType) b where
  Fetch               :: (AttributeTuple t) => String -> FetchPrimitive a -> t -> VertexStream a t
  FetchArrays         :: (AttributeTuple t, t ~ FTRepr' t') => FetchPrimitive a -> t' -> VertexStream a t

data PrimitiveStream (p :: PrimitiveType) (n :: Nat) b where
  Transform           :: (a -> VertexOut b) -> VertexStream p a -> PrimitiveStream p 1 b

  -- Render Operations
data FragmentStream (n :: Nat) a where
  Rasterize           :: RasterContext a -> PrimitiveStream a b c -> FragmentStream b c

data FrameBuffer (n :: Nat) a where
  Accumulate          :: (ValidOutput b) =>
                           AccumulationContext b
                        -> FragmentFilter a
                        -> (a -> FragmentOut b)
                        -> FragmentStream n a
                        -> FrameBuffer n b
                        -> FrameBuffer n b
  FrameBuffer         :: (ValidFrameBuffer t, FrameBuffer n t ~ TFFrameBuffer a)
                        => a -> FrameBuffer n t

data Output where
  ScreenOut           :: FrameBuffer a b -> Output

builtins
  -- * Primitive Functions *
  -- Arithmetic Functions (componentwise)

  PrimAdd, PrimSub, PrimMul :: (t ~ MatVecElem a, Num t) => a -> a -> a
  PrimAddS, PrimSubS, PrimMulS  :: (t ~ MatVecScalarElem a, Num t) => a -> t -> a
  PrimDiv, PrimMod                :: (Num t, a ~ VecScalar d t) => a -> a -> a
  PrimDivS, PrimModS              :: (Num t, a ~ VecScalar d t) => a -> t -> a
  PrimNeg                           :: (t ~ MatVecScalarElem a, Signed t) => a -> a
  -- Bit-wise Functions
  PrimBAnd, PrimBOr, PrimBXor   :: (Integral t, a ~ VecScalar d t) => a -> a -> a
  PrimBAndS, PrimBOrS, PrimBXorS:: (Integral t, a ~ VecScalar d t) => a -> t -> a
  PrimBNot                          :: (Integral t, a ~ VecScalar d t) => a -> a
  PrimBShiftL, PrimBShiftR        :: (Integral t, a ~ VecScalar d t, b ~ VecScalar d Word) => a -> b -> a
  PrimBShiftLS, PrimBShiftRS      :: (Integral t, a ~ VecScalar d t) => a -> Word -> a
  -- Logic Functions
  PrimAnd, PrimOr, PrimXor      :: Bool -> Bool -> Bool
  PrimNot                           :: (a ~ VecScalar d Bool) => a -> a
  PrimAny, PrimAll                :: (a ~ VecScalar d Bool) => a -> Bool

  -- Angle, Trigonometry and Exponential Functions
  PrimACos, PrimACosH, PrimASin, PrimASinH, PrimATan, PrimATanH, PrimCos, PrimCosH, PrimDegrees, PrimRadians, PrimSin, PrimSinH, PrimTan, PrimTanH, PrimExp, PrimLog, PrimExp2, PrimLog2, PrimSqrt, PrimInvSqrt
                                        :: (a ~ VecScalar d Float) => a -> a
  PrimPow, PrimATan2              :: (a ~ VecScalar d Float) => a -> a -> a
  --ommon Functions
  PrimFloor, PrimTrunc, PrimRound, PrimRoundEven, PrimCeil, PrimFract
                                        :: (a ~ VecScalar d Float) => a -> a
  PrimMin, PrimMax                :: (Num t, a ~ VecScalar d t) => a -> a -> a
  PrimMinS, PrimMaxS              :: (Num t, a ~ VecScalar d t) => a -> t -> a
  PrimIsNan, PrimIsInf            :: (a ~ VecScalar d Float, b ~ VecScalar d Bool) => a -> b
  PrimAbs, PrimSign               :: (Signed t, a ~ VecScalar d t) => a -> a
  PrimModF            :: (a ~ VecScalar d Float) => a -> (a, a)
  PrimClamp           :: (Num t, a ~ VecScalar d t) => a -> a -> a -> a
  PrimClampS          :: (Num t, a ~ VecScalar d t) => a -> t -> t -> a
  PrimMix             :: (a ~ VecScalar d Float) => a -> a -> a -> a
  PrimMixS            :: (a ~ VecScalar d Float) => a -> a -> Float -> a
  PrimMixB            :: (a ~ VecScalar d Float, b ~ VecScalar d Bool) => a -> a -> b -> a
  PrimStep            :: (a ~ TFVec d Float) => a -> a -> a
  PrimStepS           :: (a ~ VecScalar d Float) => Float -> a -> a
  PrimSmoothStep      :: (a ~ TFVec d Float) => a -> a -> a -> a
  PrimSmoothStepS     :: (a ~ VecScalar d Float) => Float -> Float -> a -> a

  -- Integer/Floatonversion Functions
  PrimFloatBitsToInt  :: (fv ~ VecScalar d Float, iv ~ VecScalar d Int)  => fv -> iv
  PrimFloatBitsToUInt :: (fv ~ VecScalar d Float, uv ~ VecScalar d Word) => fv -> uv
  PrimIntBitsToFloat  :: (fv ~ VecScalar d Float, iv ~ VecScalar d Int)  => iv -> fv
  PrimUIntBitsToFloat :: (fv ~ VecScalar d Float, uv ~ VecScalar d Word) => uv -> fv
  -- Geometric Functions
  PrimLength          :: (a ~ VecScalar d Float) => a -> Float
  PrimDistance, PrimDot
                        :: (a ~ VecScalar d Float) => a -> a -> Float
  PrimCross           :: (a ~ VecScalar 3 Float) => a -> a -> a
  PrimNormalize       :: (a ~ VecScalar d Float) => a -> a
  PrimFaceForward, PrimRefract
                        :: (a ~ VecScalar d Float) => a -> a -> a -> a
  PrimReflect         :: (a ~ VecScalar d Float) => a -> a -> a
  -- Matrix Functions
  PrimTranspose       :: (a ~ TFMat h w, b ~ TFMat w h) => a -> b
  PrimDeterminant     :: (m ~ TFMat s s) => m -> Float
  PrimInverse         :: (m ~ TFMat s s) => m -> m
  PrimOuterProduct    :: (m ~ TFMat h w) => w -> h -> m
  PrimMulMatVec       :: (m ~ TFMat h w) => m -> w -> h
  PrimMulVecMat       :: (m ~ TFMat h w) => h -> m -> w
  PrimMulMatMat       :: (a ~ TFMat i j, b ~ TFMat j k, c ~ TFMat i k) => a -> b -> c
  -- Vector and Scalar Relational Functions
  PrimLessThan, PrimLessThanEqual, PrimGreaterThan, PrimGreaterThanEqual, PrimEqualV, PrimNotEqualV
                        :: (Num t, a ~ VecScalar d t, b ~ VecScalar d Bool) => a -> a -> b
  PrimEqual, PrimNotEqual
                        :: (t ~ MatVecScalarElem a) => a -> a -> Bool
  -- Fragment Processing Functions
  PrimDFdx, PrimDFdy, PrimFWidth
                        :: (a ~ VecScalar d Float) => a -> a
  -- Noise Functions
  PrimNoise1          :: (a ~ VecScalar d Float) => a -> Float
  PrimNoise2          :: (a ~ VecScalar d Float, b ~ VecScalar 2 Float) => a -> b
  PrimNoise3          :: (a ~ VecScalar d Float, b ~ VecScalar 3 Float) => a -> b
  PrimNoise4          :: (a ~ VecScalar d Float, b ~ VecScalar 4 Float) => a -> b

{-
    -- Vec/Mat (de)construction
    PrimTupToV2             :: Component a                            => PrimFun stage ((a,a)     -> V2 a)
    PrimTupToV3             :: Component a                            => PrimFun stage ((a,a,a)   -> V3 a)
    PrimTupToV4             :: Component a                            => PrimFun stage ((a,a,a,a) -> V4 a)
    PrimV2ToTup             :: Component a                            => PrimFun stage (V2 a     -> (a,a))
    PrimV3ToTup             :: Component a                            => PrimFun stage (V3 a   -> (a,a,a))
    PrimV4ToTup             :: Component a                            => PrimFun stage (V4 a -> (a,a,a,a))
-}

--------------------
-- * Texture support
-- FIXME: currently only Float RGBA 2D texture is supported

builtins
  PrjImage      :: FrameBuffer 1 a -> Image 1 a
  PrjImageColor :: FrameBuffer 1 (Depth Float, Color (Vec 4 Float)) -> Image 1 (Color (Vec 4 Float))

data Texture where
  Texture2DSlot :: String -- texture slot name
                -> Texture

  Texture2D     :: Vec 2 Int -- FIXME: use Word here
                -> Image 1 (Color (Vec 4 Float))
                -> Texture

data Filter
  = PointFilter
  | LinearFilter

data EdgeMode
  = Repeat
  | MirroredRepeat
  | ClampToEdge

data Sampler = Sampler Filter EdgeMode Texture

builtins
  texture2D :: Sampler -> Vec 2 Float -> Vec 4 Float