Type inference regression

[NCrashed]

After #4 there is some type inference regressions:

Source:

type Position = Vec 3 Float 
type PositionHomo = Vec 4 Float 
type Normal = Vec 3 Float
type UV = Vec 2 Float
type Color = Vec 4 Float 
type Direction = Vec 3 Float 

homonize :: Vec 3 Float -> Vec 4 Float 
homonize v = V4 v%x v%y v%z 1 

unhomonize :: Vec 4 Float -> Vec 3 Float 
unhomonize v = V3 (v%x / v%w) (v%y / v%w) (v%z / v%w)

makeFrame (modelMat :: Mat 4 4 Float)
          (viewMat :: Mat 4 4 Float)
          (projMat :: Mat 4 4 Float)
          (texture :: Texture)
          (lightPos :: Vec 3 Float) -- world space
          (prims :: PrimitiveStream Triangle (Vec 3 Float, Vec 3 Float, Vec 2 Float))

    = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1))
  `overlay`
      prims
    & mapPrimitives transform
    & rasterizePrimitives (TriangleCtx CullNone PolygonFill NoOffset LastVertex) (Smooth, Smooth, Smooth, Smooth, Smooth)
    & mapFragments enlight
    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
  where
    mv = modelMat .*. viewMat
    mvp = transpose $ mv .*. projMat -- loaded matricies are in OpenGL format, need transpose
    viewmatInvT = inv mv

    transform :: (Position, Normal, UV) -> (PositionHomo, Position, Normal, UV, Direction, Direction)
    transform (p,n,uv) = (pproj, pworld, normalCamspace, uv, eyeDirCamspace, lightDirCamspace)
      where pproj = mvp *. homonize p
            pworld = unhomonize $ transpose modelMat *. homonize p
            pcam = unhomonize $ (transpose $ modelMat .*. viewMat) *. homonize p
            eyeDirCamspace = pcam *! (-1)
            lightPosCamspace = unhomonize $ transpose viewMat *. homonize lightPos
            lightDirCamspace = lightPosCamspace + eyeDirCamspace
            normalCamspace = unhomonize $ viewmatInvT *. homonize n

    enlight :: (Position, Normal, UV, Direction, Direction) -> ((Color))
    enlight (pworld, normalCamspace, uv, eyeDirCamspace, lightDir) = ((homonize colorLinear))
      where 
        diffuseColor = texture2D (Sampler PointFilter MirroredRepeat texture) uv
        ambientColor = diffuseColor%xyz *! 0.1
        specColor = V3 1 1 1
        shininess = 64.0

        lightPower = 40
        linearFade = 3
        squareFade = 3

        n = normalize normalCamspace
        l = normalize lightDir 
        lightDist = length $ lightPos - pworld
        lightFade = lightPower / (linearFade * lightDist + squareFade * lightDist * lightDist)

        lambertian = min (max (n `dot` l) 0) 1
        e = normalize eyeDirCamspace 
        r = reflect (l *! (-1)) n 
        cosAlpha = max 0 (min 1 $ e `dot` r) 
        specular = if lambertian <= 0 then 0 else pow cosAlpha shininess

        colorLinear = ambientColor + diffuseColor%xyz *! (lambertian * lightFade) + specColor *! (specular * lightFade)

main :: Output
main = renderFrame $
   makeFrame (Uniform "modelMat")
             (Uniform "viewMat")
             (Uniform "projMat")
             (Texture2DSlot "diffuseTexture")
             (Uniform "lightPos")
             (fetch_ "objects" (Attribute "position", Attribute "normal", Attribute "uv"))

The problem is specColor = V3 1 1 1, without :: Vec 3 Float there is following runtime errror:

GLSL codegen - unsupported expression: (\a:Type b:Type -> V3 (fromInt a b 1) (fromInt a b 1) (fromInt a b 1) ,{a} -> {b : 'Num a} -> 'VecS a 3)

Another example:

type Position = Vec 3 Float 
type PositionHomo = Vec 4 Float 
type Normal = Vec 3 Float
type UV = Vec 2 Float
type Color = Vec 4 Float 
type ShadowCoord = Vec 4 Float 
type Direction = Vec 3 Float 

homonize :: Vec 3 Float -> Vec 4 Float 
homonize v = V4 v%x v%y v%z 1 

unhomonize :: Vec 4 Float -> Vec 3 Float 
unhomonize v = V3 (v%x / v%w) (v%y / v%w) (v%z / v%w)

-- | Transforms [-1 .. 1] range to [0 .. 1]
biasMatrix :: Mat 4 4 Float 
biasMatrix = M44F 
  (V4 0.5 0.0 0.0 0.0)
  (V4 0.0 0.5 0.0 0.0)
  (V4 0.0 0.0 1.0 0.0)
  (V4 0.5 0.5 0.0 1.0) 

-- | Raster objects from view of directed light and save depth
makeShadowMap (depthMVP :: Mat 4 4 Float)
              (prims :: PrimitiveStream Triangle (Vec 3 Float, Vec 3 Float, Vec 2 Float))

    = imageFrame (emptyDepthImage 1, emptyColorImage (V4 1 1 1 1.0))
    `overlay`
      prims 
    & mapPrimitives (\(v, n, _) -> let v' = depthMVP *. homonize v in (v', v'))
    & rasterizePrimitives (TriangleCtx CullFront PolygonFill NoOffset LastVertex) ((Smooth))
    & mapFragments (\((v)) -> ((v%zzzw)) )
    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))

-- | Save diffuse info into buffer 
diffuseBuffer (modelMat :: Mat 4 4 Float)
              (viewMat :: Mat 4 4 Float)
              (projMat :: Mat 4 4 Float)
              (texture :: Texture)
              (prims :: PrimitiveStream Triangle (Vec 3 Float, Vec 3 Float, Vec 2 Float))
  = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0 1.0))
  `overlay`
      prims 
    & mapPrimitives (\(v, _, uv) -> (transpose (modelMat .*. viewMat .*. projMat) *. homonize v, uv))
    & rasterizePrimitives (TriangleCtx CullFront PolygonFill NoOffset LastVertex) ((Smooth))
    & mapFragments (\((uv)) -> ((texture2D (Sampler PointFilter MirroredRepeat texture) uv)) )
    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))

-- | Final render of object using shadow map generated at previous pass
makeFrame (modelMat :: Mat 4 4 Float)
          (viewMat :: Mat 4 4 Float)
          (projMat :: Mat 4 4 Float)
          (texture :: Texture)
          (lightDirWorld :: Vec 3 Float) -- world space
          (shadowMap :: Texture)
          (depthMVP :: Mat 4 4 Float)
          (prims :: PrimitiveStream Triangle (Vec 3 Float, Vec 3 Float, Vec 2 Float))

    = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1))
  `overlay`
      prims
    & mapPrimitives transform
    & rasterizePrimitives (TriangleCtx CullFront PolygonFill NoOffset LastVertex) (Smooth, Smooth, Smooth, Smooth, Smooth)
    & mapFragments enlight
    & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
  where
    transform :: (Position, Normal, UV) -> (PositionHomo, PositionHomo, Normal, Direction, Direction, ShadowCoord)
    transform (p,n,uv) = (pproj, biasMatrix *. pproj, normalCamspace, eyeDirCamspace, lightDirCamspace, shadowCoord)
      where pproj = transpose (modelMat .*. viewMat .*. projMat) *. homonize p
            pcam = unhomonize $ (transpose $ modelMat .*. viewMat) *. homonize p
            eyeDirCamspace = pcam *! (-1)
            lightPosCamspace = unhomonize $ transpose viewMat *. homonize (lightDirWorld *! (-1000))
            lightDirCamspace = lightPosCamspace + eyeDirCamspace
            viewmatInvT = inv $ modelMat .*. viewMat
            normalCamspace = unhomonize $ viewmatInvT *. homonize n
            shadowCoord = (biasMatrix .*. depthMVP) *. homonize p

    enlight :: (PositionHomo, Normal, Direction, Direction, ShadowCoord) -> ((Color))
    enlight (pproj, normalCamspace, eyeDirCamspace, lightDir, shadowCoord) = ((homonize colorLinear))
      where 
        diffusePos = unhomonize pproj -- /! 2 +! 0.5
        diffuseColor = texture2D (Sampler PointFilter MirroredRepeat texture) diffusePos%xy
        ambientColor = diffuseColor%xyz *! 0.1
        specColor = V3 1 1 1 :: Vec 3 Float
        shininess = 64.0

        n = normalize normalCamspace
        l = normalize lightDir
        lambertian = min 1 (max 0 $ n `dot` l)

        shadowSample = texture2D (Sampler LinearFilter MirroredRepeat shadowMap) shadowCoord%xy
        bias' = 0.05 * (tan $ acos lambertian)
        bias = max (min bias' 0.1) 0.0 
        inshade = shadowSample%z < shadowCoord%z - bias

        e = normalize eyeDirCamspace 
        r = reflect (l *! (-1)) n 
        cosAlpha = max 0 (min 1 $ e `dot` r) 
        specular = if lambertian <= 0 then 0 else pow cosAlpha shininess
        visibility = if inshade then 0.1 else 1.0
        colorLinear = ambientColor + diffuseColor%xyz *! (lambertian * visibility) + specColor *! (specular * visibility)

main :: Output
main = renderFrame $
  let shadowMap = Texture2D shadowMapSize . PrjImageColor $ makeShadowMap depthMVP objects
      diffuseMap = Texture2D windowSize . PrjImageColor $ diffuseBuffer modelMap viewMat projMat diffuseTex objects
  in makeFrame modelMap viewMat projMat diffuseMap lightDir shadowMap depthMVP objects
  where
    depthMVP = Uniform "depthMVP"
    objects = fetch_ "objects" (Attribute "position", Attribute "normal", Attribute "uv")
    modelMap = Uniform "modelMat"
    viewMat = Uniform "viewMat"
    projMat = Uniform "projMat" 
    lightDir = Uniform "lightDir"
    diffuseTex = Texture2DSlot "diffuseTexture"
    windowWidth = Uniform "windowWidth" :: Int
    windowHeight = Uniform "windowHeight" :: Int
    windowSize = V2 640 640
    shadowMapSize = V2 640 640

The problem are uniforms in where at the end, without explicit type annotations I got:

GLSL codegen - unsupported expression: (\a:Type -> Uniform a "depthMVP", {a}->a)

And others (after adding annotation for previous):

GLSL codegen - unsupported expression: (\a:Type -> Uniform a "lightDir", {a}->a)

GLSL codegen - unsupported expression: (\a:Type -> Uniform a "modelMat", {a}->a)

[divipp]

Thanks, I will look at these.

[divipp]

Is the type signature an acceptable workaround at the moment?

[NCrashed]

Yep

[divipp]

I think the issue is fixed, please check!

[NCrashed]

Got following when removed annotation from specColor at first gist:

focus checkMetas: \a -> (\b:Type -> primFix a b) (\c:a (a := {d} -> {e} -> 'List (d, e) -> ('List d, 'List e)) -> typeAnn ({g} -> {h} -> 'List (g, h) -> ('List g, 'List h)) (\{j} (l : 'Unit->Type) (n : 'Unit->Type) (p : 'Unit->Type) (r : 'Unit->Type) (t : 'Unit->Type) (v : 'Unit->Type) (w : t TT ~ v TT) (x : r TT ~ t TT) -> \{y}-><<HERE>>))
\(a : V3 TT ~ 'List V0) (c : 'Unit->Type) (e : 'Unit->Type) (g : 'Unit->Type) (h : e TT ~ g TT) (i : c TT ~ e TT) (j : g TT ~ 'List V15) (k : 'List V16 ~ c TT) (l : 'List V8 ~ V13 TT) (m : V15 TT ~ ('List V18, 'List V9)) (n : V17 TT ~ V16 TT) (o : V19 TT ~ V18 TT) (p : ('List V21, 'List V12) ~ V20 TT) q:Type -> 'ListCase (\r:Type -> ('List V24, 'List V15)) (labend (Nil, Nil)) (\s:Type t:Type -> hlistConsCase V25 (Cons V16 Nil) V24 (\u:Type v:Type -> hlistConsCase V18 Nil V25 (\w:Type x:Type -> hlistNilCase V26 (labend (Cons u as, Cons w bs)) x) v) s) q

[NCrashed]

P.S. Also the same failure with annotation

[divipp]

I can't reproduce the last error, works for me.

[divipp]

Maybe you have to copy the following modules to the install directory: Internals.lc, Builtins.lc, Prelude.lc This is done automatically by cabal install BTW.

[NCrashed]

Sorry, my fault to forget to copy the files. I need to copy them manually as I use the package as dependency via stack:

packages:
- '.'
- location:
    git: git@github.com:lambdacube3d/lambdacube-gl.git
    commit: 33e873f2b5d6b9c6b31b8679df1625eb88f8a39d
- location:
    git: git@github.com:lambdacube3d/lambdacube-ir.git
    commit: 54cc12e4d6f10bc33811713286a1931bf96f64f3
  subdirs:
  - lambdacube-ir.haskell
- location:
    git: git@github.com:lambdacube3d/lambdacube-compiler.git
    commit: 596ce93cd64d80e13649d179720365b8571235db

[NCrashed]

Thanks, it works now!