From acacc8a5aadfa3040df10c61f2641fd5be2ca34d Mon Sep 17 00:00:00 2001 From: Andor Penzes Date: Wed, 13 Jan 2016 15:20:55 +0100 Subject: install lambdacube prelude as package data --- lc/Builtins.lc | 572 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ lc/Internals.lc | 62 ++++++ lc/Prelude.lc | 362 +++++++++++++++++++++++++++++++++++ 3 files changed, 996 insertions(+) create mode 100644 lc/Builtins.lc create mode 100644 lc/Internals.lc create mode 100644 lc/Prelude.lc (limited to 'lc') diff --git a/lc/Builtins.lc b/lc/Builtins.lc new file mode 100644 index 00000000..674335cb --- /dev/null +++ b/lc/Builtins.lc @@ -0,0 +1,572 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Builtins + ( module Internals + , module Builtins + ) where + +import Internals + +id x = x + +--------------------------------------- + +data Nat = Zero | Succ Nat + +data List a = Nil | Cons a (List a) + +type family JoinTupleType t1 t2 where + -- TODO + JoinTupleType () a = a + JoinTupleType a () = a + JoinTupleType (a, b) c = (a, b, c) + JoinTupleType a (b, c) = (a, b, c) + JoinTupleType a (b, c, d) = (a, b, c, d) + JoinTupleType a (b, c, d, e) = (a, b, c, d, e) + JoinTupleType a b = (a, b) + +class AttributeTuple a +instance AttributeTuple a -- TODO +class ValidOutput a +instance ValidOutput a -- TODO +class ValidFrameBuffer a +instance ValidFrameBuffer a -- TODO + +data VecS (a :: Type) :: Nat -> Type where + V2 :: a -> a -> VecS a 2 + V3 :: a -> a -> a -> VecS a 3 + V4 :: a -> a -> a -> a -> VecS a 4 + +type family Vec (n :: Nat) t where Vec n t = VecS t n + +type family VecScalar (n :: Nat) a where + VecScalar 1 a = a + VecScalar ('Succ ('Succ n)) a = Vec ('Succ ('Succ n)) a + +-- may be a data family? +type family TFVec (n :: Nat) a where + TFVec n a = Vec n a -- TODO: check range: n = 2,3,4; a is Float, Int, Word, Bool + +-- todo: use less constructors with more parameters +data Mat :: Nat -> Nat -> Type -> Type where + M22F :: Vec 2 Float -> Vec 2 Float -> Mat 2 2 Float + M32F :: Vec 3 Float -> Vec 3 Float -> Mat 3 2 Float + M42F :: Vec 4 Float -> Vec 4 Float -> Mat 4 2 Float + M23F :: Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Mat 2 3 Float + M33F :: Vec 3 Float -> Vec 3 Float -> Vec 3 Float -> Mat 3 3 Float + M43F :: Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Mat 4 3 Float + M24F :: Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Mat 2 4 Float + M34F :: Vec 3 Float -> Vec 3 Float -> Vec 3 Float -> Vec 3 Float -> Mat 3 4 Float + M44F :: Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Mat 4 4 Float + +type family MatVecElem a where + MatVecElem (VecS a n) = a + MatVecElem (Mat i j a) = a + +type family MatVecScalarElem a where + MatVecScalarElem Float = Float + MatVecScalarElem Bool = Bool + MatVecScalarElem Int = Int + MatVecScalarElem (VecS a n) = a + MatVecScalarElem (Mat i j a) = a + +-- may be a data family? +type family TFMat i j where + TFMat (VecS a i) (VecS a' j) = T2 (a ~ a') (Mat i j a) + +--------------------------------------- swizzling + +data Swizz = Sx | Sy | Sz | Sw + +-- todo: use pattern matching +mapVec :: forall a b m . (a -> b) -> Vec m a -> Vec m b +mapVec @a @b @m f v = 'VecSCase (\m _ -> 'Vec m b) + (\x y -> V2 (f x) (f y)) + (\x y z -> V3 (f x) (f y) (f z)) + (\x y z w -> V4 (f x) (f y) (f z) (f w)) + @m + v + +-- todo: make it more type safe +swizzscalar :: forall n . Vec n a -> Swizz -> a +swizzscalar (V2 x y) Sx = x +swizzscalar (V2 x y) Sy = y +swizzscalar (V3 x y z) Sx = x +swizzscalar (V3 x y z) Sy = y +swizzscalar (V3 x y z) Sz = z +swizzscalar (V4 x y z w) Sx = x +swizzscalar (V4 x y z w) Sy = y +swizzscalar (V4 x y z w) Sz = z +swizzscalar (V4 x y z w) Sw = w + +-- used to prevent unfolding of swizzvector on variables (behind GPU lambda) +definedVec :: forall a m . Vec m a -> Bool +definedVec (V2 _ _) = True +definedVec (V3 _ _ _) = True +definedVec (V4 _ _ _ _) = True + +swizzvector :: forall n . forall m . Vec n a -> Vec m Swizz -> Vec m a +swizzvector v w | definedVec v = mapVec (swizzscalar v) w + + +--------------------------------------- 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 + +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 :: Int -- todo + oneComp = 1 :: Int -- todo + +instance Component Word where + vec2 = V2 + vec3 = V3 + vec4 = V4 + zeroComp = 0 :: Word + oneComp = 1 :: Word + +instance Component Float where + vec2 = V2 + vec3 = V3 + vec4 = V4 + zeroComp = 0.0 -- todo: 0 + oneComp = 1.0 -- todo: 1 +instance Component (VecS Float 2) where + vec2 = V2 + vec3 = V3 + vec4 = V4 + zeroComp = V2 0.0 0.0 + oneComp = V2 1.0 1.0 +instance Component (VecS Float 3) 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 (VecS Float 4) 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 (VecS Bool 2) {-where-} +instance Component (VecS Bool 3) {-where-} +instance Component (VecS Bool 4) 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 (VecS Float 2) +instance NumComponent (VecS Float 3) +instance NumComponent (VecS Float 4) + +class Floating a + +instance Floating Float +instance Floating (VecS Float 2) -- todo: use Vec +instance Floating (VecS Float 3) +instance Floating (VecS Float 4) +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' --- FIXME: modified + | 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 + +type family ColorRepr a where + ColorRepr () = () + ColorRepr (a, b) = (Color a, Color b) + ColorRepr (a, b, c) = (Color a, Color b, Color c) + ColorRepr (a, b, c, d) = (Color a, Color b, Color c, Color d) + ColorRepr (a, b, c, d, e) = (Color a, Color b, Color c, Color d, Color e) + ColorRepr a = Color a -- TODO + +data PrimitiveType + = Triangle + | Line + | Point + | TriangleAdjacency + | LineAdjacency + +-- builtin +primTexture :: () -> Vec 2 Float -> Vec 4 Float + +-- builtins +Uniform :: String -> t +Attribute :: String -> t + +data FragmentShader :: Type -> Type where + FragmentShader :: (a ~ ColorRepr t) => (b -> t) -> FragmentShader (b -> a) + FragmentShaderDepth :: (x ~ ColorRepr t, a ~ JoinTupleType (Depth Float) x) => (b -> (Float, t)) + -> FragmentShader (b -> a) + FragmentShaderRastDepth :: (x ~ ColorRepr t, a ~ JoinTupleType (Depth Float) x) => (b -> t) + -> FragmentShader (b -> a) + +data RasterContext :: PrimitiveType -> Type where + TriangleCtx :: CullMode -> PolygonMode -> PolygonOffset -> ProvokingVertex -> RasterContext Triangle + PointCtx :: PointSize -> Float -> PointSpriteCoordOrigin -> RasterContext Point + LineCtx :: Float -> ProvokingVertex -> RasterContext Line + +data Interpolated t where + Smooth, NoPerspective + :: (Floating t) => t -> Interpolated t + Flat :: t -> Interpolated t + +type family FTRepr' a where + -- TODO + FTRepr' [a] = a + FTRepr' ([a], [b]) = (a, b) + FTRepr' (Interpolated a) = a + FTRepr' (Interpolated a, Interpolated b) = (a, b) + FTRepr' (Interpolated a, Interpolated b, Interpolated c) = (a, b, c) + +data VertexOut a where + VertexOut :: (a ~ FTRepr' x) => Vec 4 Float -> Float -> (){-TODO-} -> x -> VertexOut a + +data Blending :: Type -> Type 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 StencilTests +data StencilOps +data Int32 + +data FragmentOperation :: Type -> Type 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) + +type family FragOps a where + FragOps (FragmentOperation t) = t + FragOps (FragmentOperation t1, FragmentOperation t2) = (t1, t2) + FragOps (FragmentOperation t1, FragmentOperation t2, FragmentOperation t3) = (t1, t2, t3) + FragOps (FragmentOperation t1, FragmentOperation t2, FragmentOperation t3, FragmentOperation t4) = (t1, t2, t3, t4) + FragOps (FragmentOperation t1, FragmentOperation t2, FragmentOperation t3, FragmentOperation t4, FragmentOperation t5) = (t1, t2, t3, t4, t5) + +data AccumulationContext a where + AccumulationContext :: (a ~ FragOps t) => t -> AccumulationContext a + +data FragmentFilter t where + PassAll :: FragmentFilter t + Filter :: (t -> Bool) -> FragmentFilter t + +data VertexStream (a :: PrimitiveType) t where + Fetch :: (AttributeTuple t) => String -> t -> VertexStream a t + FetchArrays :: (AttributeTuple t, t ~ FTRepr' t') => t' -> VertexStream a t + +fetch s a t = Fetch @a s t +fetchArrays a t = FetchArrays @a t + +data PrimitiveStream (p :: PrimitiveType) :: Nat -> Type -> Type where + Transform :: (a -> VertexOut b) -> VertexStream p a -> PrimitiveStream p 1 b + + -- Render Operations +data FragmentStream (n :: Nat) a where + Rasterize :: RasterContext x -> PrimitiveStream x n a -> FragmentStream n a + +data FilteredFragmentStream (n :: Nat) a where + FilteredFragmentStream + :: FragmentFilter a -> FragmentStream n a -> FilteredFragmentStream n a + +data Fragments (n :: Nat) b where + Fragments :: ValidOutput b => FragmentShader (a -> b) -> FilteredFragmentStream n a -> Fragments n b + +-- todo: mutually defined with FrameBuffer and Image +type family TFFrameBuffer a {-where + TFFrameBuffer (Image n t) = FrameBuffer n t + TFFrameBuffer (Image n1 t1, Image n2 t2) {- TODO | n1 == n2 -} = FrameBuffer n1 (t1, t2) + TFFrameBuffer (Image n1 t1, Image n2 t2, Image n2 t3) {- TODO | n1 == n2 && n2 == n3 -} = FrameBuffer n1 (t1, t2, t3) +-} +data FrameBuffer (n :: Nat) b where + Accumulate :: AccumulationContext b -> Fragments n b -> FrameBuffer n b -> FrameBuffer n b + FrameBuffer :: (ValidFrameBuffer b, FrameBuffer n b ~ TFFrameBuffer a) => a -> FrameBuffer n b + +accumulate ctx ffilt fshader fstr fb = Accumulate ctx (Fragments fshader (FilteredFragmentStream ffilt fstr)) fb + +data Image :: Nat -> Type -> Type where + ColorImage :: forall a d t color . (Num t, color ~ VecScalar d t) + => color -> Image a (Color color) + DepthImage :: forall a . Float -> Image a (Depth Float) + StencilImage :: forall a . Int -> Image a (Stencil Int) + + -- texture support + PrjImage :: FrameBuffer 1 a -> Image 1 a + PrjImageColor :: FrameBuffer 1 (Depth Float, Color (Vec 4 Float)) -> Image 1 (Color (Vec 4 Float)) + +data Output where + ScreenOut :: FrameBuffer a b -> Output + +------------------------------------------------------------------- +-- * Builtin Primitive Functions * +-- Arithmetic Functions (componentwise) + +PrimAdd, PrimSub, PrimMul :: Num (MatVecElem a) => 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 :: Signed (MatVecScalarElem a) => 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 :: VecScalar d Bool -> 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 +-- Common 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 :: VecScalar d Float -> VecScalar d Int +PrimFloatBitsToUInt :: VecScalar d Float -> VecScalar d Word +PrimIntBitsToFloat :: VecScalar d Int -> VecScalar d Float +PrimUIntBitsToFloat :: VecScalar d Word -> VecScalar d Float +-- 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 :: TFMat h w -> TFMat w h +PrimDeterminant :: TFMat s s -> Float +PrimInverse :: TFMat s s -> TFMat s s +PrimOuterProduct :: w -> h -> TFMat h w +PrimMulMatVec :: TFMat h w -> w -> h +PrimMulVecMat :: h -> TFMat h w -> w +PrimMulMatMat :: TFMat i j -> TFMat j k -> TFMat i k +-- 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 :: VecScalar d Float -> Float +PrimNoise2 :: VecScalar d Float -> Vec 2 Float +PrimNoise3 :: VecScalar d Float -> Vec 3 Float +PrimNoise4 :: VecScalar d Float -> Vec 4 Float + +{- +-- 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 + +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 + +-- builtin +texture2D :: Sampler -> Vec 2 Float -> Vec 4 Float + diff --git a/lc/Internals.lc b/lc/Internals.lc new file mode 100644 index 00000000..b64d5a41 --- /dev/null +++ b/lc/Internals.lc @@ -0,0 +1,62 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- declarations of builtin functions and data types used by the compiler +module Internals where + +undefined :: forall (a :: Type) . a + +data Unit = TT +data String +data Empty (a :: String) + +-- TODO: generate? +data Tuple0 = Tuple0 +data Tuple1 a = Tuple1 a +data Tuple2 a b = Tuple2 a b +data Tuple3 a b c = Tuple3 a b c +data Tuple4 a b c d = Tuple4 a b c d +data Tuple5 a b c d e = Tuple5 a b c d e + + +-- ... TODO + +-- builtin used for overlapping instances +parEval :: forall a -> a -> a -> a + +type family EqC a b -- equality constraints +type family T2 a b -- conjuction of constraints + +-- builtin conjuction of constraint witnesses +t2C :: Unit -> Unit -> Unit + +-- builtin type constructors +data Int +data Word +data Float +data Char + +data Bool = False | True + +data Ordering = LT | EQ | GT + +-- builtin primitives +primIntToWord :: Int -> Word +primIntToFloat :: Int -> Float +primCompareInt :: Int -> Int -> Ordering +primCompareWord :: Word -> Word -> Ordering +primCompareFloat :: Float -> Float -> Ordering +primCompareString :: String -> String -> Ordering +primNegateInt :: Int -> Int +primNegateWord :: Word -> Word +primNegateFloat :: Float -> Float +primAddInt :: Int -> Int -> Int +primSubInt :: Int -> Int -> Int +primModInt :: Int -> Int -> Int +primSqrtFloat :: Float -> Float +primRound :: Float -> Int + + +primIfThenElse :: Bool -> a -> a -> a +primIfThenElse True a b = a +primIfThenElse False a b = b + + diff --git a/lc/Prelude.lc b/lc/Prelude.lc new file mode 100644 index 00000000..6ab787d1 --- /dev/null +++ b/lc/Prelude.lc @@ -0,0 +1,362 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module Prelude + ( module Prelude + , module Builtins + ) where + +import Builtins + +infixr 9 . +infixl 7 `PrimMulMatVec`, `PrimDot` +infixr 3 *** +infixr 5 : +infixr 0 $ +--infixl 0 & + +const x y = x + +otherwise = True + +x & f = f x + +($) = \f x -> f x +(.) = \f g x -> f (g x) + +uncurry f (x, y) = f x y + +(***) f g (x, y) = (f x, g y) + +pi = 3.14 + +zip :: [a] -> [b] -> [(a,b)] +zip [] xs = [] +zip xs [] = [] +zip (a: as) (b: bs) = (a,b): zip as bs + +unzip :: [(a,b)] -> ([a],[b]) +unzip [] = ([],[]) +unzip ((a,b):xs) = (a:as,b:bs) + where (as,bs) = unzip xs + +filter pred [] = [] +filter pred (x:xs) = case pred x of + True -> (x : filter pred xs) + False -> (filter pred xs) + +head :: [a] -> a +head (a: _) = a + +tail :: [a] -> [a] +tail (_: xs) = xs + +pairs :: [a] -> [(a, a)] +pairs v = zip v (tail v) + +foldl' f e [] = e +foldl' f e (x: xs) = foldl' f (f e x) xs + +singleton a = [a] + +append [] ys = ys +append (x:xs) ys = x : append xs ys + +concat = foldl' append [] + +map _ [] = [] +map f (x:xs) = f x : map f xs + +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f x = concat (map f x) + +split [] = ([], []) +split (x: xs) = (x: bs, as) where (as, bs) = split xs + +mergeBy f (x:xs) (y:ys) = case f x y of + LT -> x: mergeBy f xs (y:ys) + _ -> y: mergeBy f (x:xs) ys +mergeBy f [] xs = xs +mergeBy f xs [] = xs + +sortBy f [] = [] +sortBy f [x] = [x] +sortBy f xs = uncurry (mergeBy f) ((sortBy f *** sortBy f) (split xs)) + +data Maybe a + = Nothing + | Just a +-- deriving (Eq, Ord, Show) + + +fst (a, b) = a +snd (a, b) = b + +tuptype :: [Type] -> Type +tuptype [] = '() +tuptype (x:xs) = '(x, tuptype xs) + +data RecordC (xs :: [(String, Type)]) + = RecordCons (tuptype (map snd xs)) + +foldr1 f [x] = x +foldr1 f (x: xs) = f x (foldr1 f xs) + +isEQ EQ = True +isEQ _ = False + +False ||| x = x +True ||| x = True + +infixr 2 ||| + +True &&& x = x +False &&& x = False + +infixr 3 &&& + +class Eq a where + (===) :: a -> a -> Bool -- todo: use (==) sign + +infix 4 === + +instance Eq String where + a === b = isEQ (primCompareString a b) + +------------------------------------ Row polymorphism +-- todo: sorted field names (more efficient & easier to use) + +isKey _ [] = False +isKey s ((s', _): ss) = s === s' ||| isKey s ss + +isKeyC _ _ [] = 'Empty "" +isKeyC s t ((s', t'): ss) = if s === s' then t ~ t' else isKeyC s t ss + +subList [] _ = [] +subList ((s, t): xs) ys = if isKey s ys then subList xs ys else (s, t): subList xs ys + +addList [] ys = ys +addList ((s, t): xs) ys = if isKey s ys then addList xs ys else (s, t): addList xs ys + +findEq x [] = 'Unit +findEq (s, t) ((s', t'):xs) = if s === s' then 'T2 (t ~ t') (findEq (s, t) xs) else findEq (s, t) xs + +sameEq [] _ = 'Unit +sameEq (x: xs) ys = 'T2 (findEq x ys) (sameEq xs ys) + +defined [] = True +defined (x: xs) = defined xs + +type family Split a b c +type instance Split (RecordC xs) (RecordC ys) z | defined xs &&& defined ys = T2 (sameEq xs ys) (z ~ RecordC (subList xs ys)) +type instance Split (RecordC xs) z (RecordC ys) | defined xs &&& defined ys = T2 (sameEq xs ys) (z ~ RecordC (subList xs ys)) +type instance Split z (RecordC xs) (RecordC ys) | defined xs &&& defined ys = T2 (sameEq xs ys) (z ~ RecordC (addList xs ys)) + +-- builtin +-- TODO +record :: [(String, Type)] -> Type +--record xs = RecordCons ({- TODO: sortBy fst-} xs) + +-- builtin +unsafeCoerce :: forall a b . a -> b + +-- todo: don't use unsafeCoerce +project :: forall a (xs :: [(String, Type)]) . forall (s :: String) -> 'isKeyC s a xs => RecordC xs -> a +project @a @((s', a'): xs) s @_ (RecordCons ts) | s === s' = fst (unsafeCoerce @_ @(a, tuptype (map snd xs)) ts) +project @a @((s', a'): xs) s @_ (RecordCons ts) = project @a @xs s @undefined (RecordCons (snd (unsafeCoerce @_ @(a, tuptype (map snd xs)) ts))) + +--------------------------------------- HTML colors + +rgb r g b = V4 r g b 1.0 + +black = rgb 0.0 0.0 0.0 +gray = rgb 0.5 0.5 0.5 +silver = rgb 0.75 0.75 0.75 +white = rgb 1.0 1.0 1.0 +maroon = rgb 0.5 0.0 0.0 +red = rgb 1.0 0.0 0.0 +olive = rgb 0.5 0.5 0.0 +yellow = rgb 1.0 1.0 0.0 +green = rgb 0.0 0.5 0.0 +lime = rgb 0.0 1.0 0.0 +teal = rgb 0.0 0.5 0.5 +aqua = rgb 0.0 1.0 1.0 +navy = rgb 0.0 0.0 0.5 +blue = rgb 0.0 0.0 1.0 +purple = rgb 0.5 0.0 0.5 +fuchsia = rgb 1.0 0.0 1.0 + +colorImage1 = ColorImage @1 +colorImage2 = ColorImage @2 + +depthImage1 = DepthImage @1 + +v3FToV4F :: Vec 3 Float -> Vec 4 Float +v3FToV4F v = V4 0.0 0.0 0.0 1.0 --- todo! -- V4 v%x v%y v%z 1 + +------------ +-- * WebGL 1 +------------ + +-- angle and trigonometric +radians = PrimRadians +degrees = PrimDegrees +sin = PrimSin +cos = PrimCos +tan = PrimTan +asin = PrimASin +acos = PrimACos +atan = PrimATan +atan2 = PrimATan2 + +-- exponential functions +pow = PrimPow +exp = PrimExp +log = PrimLog +exp2 = PrimExp2 +log2 = PrimLog2 +sqrt = PrimSqrt +inversesqrt = PrimInvSqrt + +-- common functions +abs = PrimAbs +sign = PrimSign +floor = PrimFloor +ceil = PrimCeil +fract = PrimFract +mod = PrimMod +min = PrimMin +max = PrimMax +clamp = PrimClamp +clampS = PrimClampS +mix = PrimMix +step = PrimStep +smoothstep = PrimSmoothStep + +-- geometric functions +length = PrimLength +distance = PrimDistance +dot = PrimDot +cross = PrimCross +normalize = PrimNormalize +faceforward = PrimFaceForward +reflect = PrimReflect +refract = PrimRefract + +-- operators +infixl 7 *, /, % +infixl 6 +, - +infix 4 ==, /=, <, <=, >=, > + +infixr 3 && +infixr 2 || + +infix 7 `dot` -- dot +infix 7 `cross` -- cross + +infixr 7 *. -- mulmv +infixl 7 .* -- mulvm +infixl 7 .*. -- mulmm + +-- arithemtic +a + b = PrimAdd a b +a - b = PrimSub a b +a * b = PrimMul a b +a / b = PrimDiv a b +a % b = PrimMod a b + +neg a = PrimNeg a + +-- comparison +a == b = PrimEqual a b +a /= b = PrimNotEqual a b +a < b = PrimLessThan a b +a <= b = PrimLessThanEqual a b +a >= b = PrimGreaterThanEqual a b +a > b = PrimGreaterThan a b + +-- logical +a && b = PrimAnd a b +a || b = PrimOr a b +not a = PrimNot a +any a = PrimAny a +all a = PrimAll a + +-- matrix functions +a .*. b = PrimMulMatMat a b +a *. b = PrimMulMatVec a b +a .* b = PrimMulVecMat a b + +dFdx = PrimDFdx +dFdy = PrimDFdy + +-- extra +round = PrimRound + + +-- temp hack for vector <---> scalar operators +infixl 7 *!, /!, %! +infixl 6 +!, -! + +-- arithemtic +a +! b = PrimAddS a b +a -! b = PrimSubS a b +a *! b = PrimMulS a b +a /! b = PrimDivS a b +a %! b = PrimModS a b + +------------------ +-- common matrices +------------------ +{- +-- | Perspective transformation matrix in row major order. +perspective :: Float -- ^ Near plane clipping distance (always positive). + -> Float -- ^ Far plane clipping distance (always positive). + -> Float -- ^ Field of view of the y axis, in radians. + -> Float -- ^ Aspect ratio, i.e. screen's width\/height. + -> Mat 4 4 Float +perspective n f fovy aspect = --transpose $ + M44F (V4F (2*n/(r-l)) 0 (-(r+l)/(r-l)) 0) + (V4F 0 (2*n/(t-b)) ((t+b)/(t-b)) 0) + (V4F 0 0 (-(f+n)/(f-n)) (-2*f*n/(f-n))) + (V4F 0 0 (-1) 0) + where + t = n*tan(fovy/2) + b = -t + r = aspect*t + l = -r +-} +rotMatrixZ a = M44F (V4 c s 0 0) (V4 (-s) c 0 0) (V4 0 0 1 0) (V4 0 0 0 1) + where + c = cos a + s = sin a + +rotMatrixY a = M44F (V4 c 0 (-s) 0) (V4 0 1 0 0) (V4 s 0 c 0) (V4 0 0 0 1) + where + c = cos a + s = sin a + +rotMatrixX a = M44F (V4 1 0 0 0) (V4 0 c s 0) (V4 0 (-s) c 0) (V4 0 0 0 1) + where + c = cos a + s = sin a + +rotationEuler a b c = rotMatrixY a .*. rotMatrixX b .*. rotMatrixZ c + +{- +-- | Camera transformation matrix. +lookat :: Vec 3 Float -- ^ Camera position. + -> Vec 3 Float -- ^ Target position. + -> Vec 3 Float -- ^ Upward direction. + -> M44F +lookat pos target up = translateBefore4 (neg pos) (orthogonal $ toOrthoUnsafe r) + where + w = normalize $ pos - target + u = normalize $ up `cross` w + v = w `cross` u + r = transpose $ Mat3 u v w +-} + +scale t v = v * V4 t t t 1.0 + +fromTo :: Float -> Float -> [Float] +fromTo a b = if a > b then [] else a: fromTo (a +! 1.0) b + -- cgit v1.2.3