使用 gpipe 在 Haskell 中绘制彩色四边形

Posted 2023-02-22

【中文标题】使用 gpipe 在 Haskell 中绘制彩色四边形

【英文标题】：Drawing colored quads in Haskell with gpipe

【发布时间】：2016-02-21 09:46:41

【问题描述】：

我正在尝试使用 gpipe 包在 Haskell 屏幕上的随机位置绘制四边形。由于四边形将位于 2D 中，我还想设置一个正交投影。我似乎没有为光栅化找到正确的类型。这是我的代码（使用 gpipe 教程拼凑而成）：

-# LANGUAGE ScopedTypeVariables, PackageImports, FlexibleContexts, TypeFamilies #-
module Main where

import Graphics.GPipe
import qualified "GPipe-GLFW" Graphics.GPipe.Context.GLFW as GLFW
import Control.Monad (unless)

import System.Random

-- Generate random points in 2d
getRandomPoints2D :: (Float, Float) -> StdGen -> [V4 Float]
getRandomPoints2D range sg = zipWith createPoint x y
    where createPoint x y = V4 x y 0 1
          (sg1, sg2) = split sg
          x = randomRs range sg1
          y = randomRs range sg2

getPoints :: Int -> StdGen -> [V4 Float]
getPoints n sg = take n $ getRandomPoints2D (-1,1) sg

examplePoints :: Int -> IO [V4 Float]
examplePoints n = newStdGen >>= return . getPoints n

-- Quads from point
quadFromPoint :: V4 Float -> [V4 Float]
quadFromPoint p = map (p +) [ v4 (-off) (-off), v4 (-off) off
                            , v4 off (-off), v4 off (-off)
                            , v4 off off, v4 (-off) off
                            ]
    where off = 0.1
          v4 x y = V4 x y 0 0

main = do
    let width = 720
        height = 540
        windowConf = GLFW.WindowConf width height "hs-visu"
        context = GLFW.newContext' [] windowConf
    let numPoints = 6
    points <- examplePoints numPoints
    let quadPoints = concatMap quadFromPoint points
        pointsWithColor = zip quadPoints $ repeat (V3 1 0 0)
    runContextT context (ContextFormatColor RGB8) $ do

        -- Create buffers for the vertices
        vertexBuffer :: Buffer os (B4 Float, B3 Float) <- newBuffer (length pointsWithColor)
        writeBuffer vertexBuffer 0 pointsWithColor

        -- Create a buffer for the uniform values
        uniformBuffer :: Buffer os (Uniform (V4 (B4 Float))) <- newBuffer 1

        shader <- compileShader $ do
            -- Vertex shader
            primitiveStream <- toPrimitiveStream primitives
            modelViewProj <- getUniform (const (uniformBuffer, 0))
            let projPrimitiveStream = proj modelViewProj <$> primitiveStream

            -- Fragment shader
            fragmentStream <- rasterize rasterOptions projPrimitiveStream
            let colorOption = ContextColorOption NoBlending (pure True)
            drawContextColor (const colorOption) fragmentStream

        -- Run the loop
        loop vertexBuffer shader uniformBuffer

loop vertexBuffer shader uniformBuffer = do
    -- Construct the ModelViewProjection matrix
    size@(V2 w h) <- getContextBuffersSize
    let halfWidth = (fromIntegral w)/2.0
        halfHeight = (fromIntegral h)/2.0
        projMat = ortho (-halfWidth) halfWidth halfHeight (-halfHeight) -1.0 1.0

    writeBuffer uniformBuffer 0 [projMat]

    render $ do
        clearContextColor 1 -- White background
        clearContextDepth 1 -- Far plane
        vertexArray <- newVertexArray vertexBuffer
        let primitiveArray = toPrimitiveArray TriangleList vertexArray
        shader $ ShaderEnvironment primitiveArray (FrontAndBack, ViewPort 0 size, DepthRange 0 1)
    swapContextBuffers

    closeRequested <- GLFW.windowShouldClose
    unless closeRequested $ loop vertexBuffer shader uniformBuffer

data ShaderEnvironment = ShaderEnvironment
     primitives :: PrimitiveArray Triangles (B4 Float, B3 Float)
    , rasterOptions :: (Side, ViewPort, DepthRange)
    

-- Projects the position of the vertices with the ModelViewProjection matrix
proj :: (V4 (V4 VFloat)) -> (V4 VFloat, V3 VFloat) -> (V4 VFloat, V3 VFloat)
proj modelViewProj (p,c) = (modelViewProj !* p, c)

但是，如果我尝试编译我的代码，我会收到以下错误消息：

Main.hs:58:31:
    Couldn't match type ‘Color c0 (S F (ColorElement c0))’
                   with ‘V3 FFloat’
    The type variable ‘c0’ is ambiguous
    Expected type: Shader
                     os
                     (ContextFormat c0 ds0)
                     ShaderEnvironment
                     (FragmentStream (FragColor c0))
      Actual type: Shader
                     os
                     (ContextFormat c0 ds0)
                     ShaderEnvironment
                     (FragmentStream (FragmentFormat (V3 VFloat)))
    In a stmt of a 'do' block:
      fragmentStream <- rasterize rasterOptions projPrimitiveStream
    In the second argument of ‘($)’, namely
      ‘do  primitiveStream <- toPrimitiveStream primitives;
            modelViewProj <- getUniform (const (uniformBuffer, 0));
            let projPrimitiveStream = proj modelViewProj <$> primitiveStream;
            fragmentStream <- rasterize rasterOptions projPrimitiveStream;
            .... ’

Main.hs:59:62:
    Couldn't match type ‘Color c0 Bool’ with ‘f0 Bool’
    The type variables ‘f0’, ‘c0’ are ambiguous
    Expected type: ColorMask c0
      Actual type: f0 Bool
    Relevant bindings include
      colorOption :: ContextColorOption c0 (bound at Main.hs:59:17)
      fragmentStream :: FragmentStream (FragColor c0)
        (bound at Main.hs:58:13)
    In the second argument of ‘ContextColorOption’, namely
      ‘(pure True)’
    In the expression: ContextColorOption NoBlending (pure True)

Main.hs:65:1:
    Could not deduce (Fractional a0)
    from the context (Fractional a,
                      Fractional a1,
                      Fractional (a1 -> a -> a -> M44 a),
                      Num (Color c Float),
                      Num (a -> a -> M44 a),
                      DepthRenderable ds,
                      ContextColorFormat c,
                      Control.Monad.IO.Class.MonadIO m,
                      Control.Monad.Exception.MonadException m,
                      HostFormat b ~ (a -> a -> M44 a))
      bound by the inferred type for ‘loop’:
                 (Fractional a, Fractional a1, Fractional (a1 -> a -> a -> M44 a),
                  Num (Color c Float), Num (a -> a -> M44 a), DepthRenderable ds,
                  ContextColorFormat c, Control.Monad.IO.Class.MonadIO m,
                  Control.Monad.Exception.MonadException m,
                  HostFormat b ~ (a -> a -> M44 a)) =>
                 Buffer os (B4 Float, B3 Float)
                 -> (ShaderEnvironment -> Render os (ContextFormat c ds) ())
                 -> Buffer os b
                 -> ContextT GLFW.GLFWWindow os (ContextFormat c ds) m ()
      at Main.hs:(65,1)-(83,66)
    The type variable ‘a0’ is ambiguous
    When checking that ‘loop’ has the inferred type
      loop :: forall os (m :: * -> *) a a1 b c ds.
              (Fractional a, Fractional a1, Fractional (a1 -> a -> a -> M44 a),
               Num (Color c Float), Num (a -> a -> M44 a), DepthRenderable ds,
               ContextColorFormat c, Control.Monad.IO.Class.MonadIO m,
               Control.Monad.Exception.MonadException m,
               HostFormat b ~ (a -> a -> M44 a)) =>
              Buffer os (B4 Float, B3 Float)
              -> (ShaderEnvironment -> Render os (ContextFormat c ds) ())
              -> Buffer os b
              -> ContextT GLFW.GLFWWindow os (ContextFormat c ds) m ()
    Probable cause: the inferred type is ambiguous

我不明白为什么这些类型与 here 找到的 Hello World 教程不同。以及可以做些什么来解决这个问题。

【参考方案1】：

当您遇到此类错误时，最好先通过添加类型注释来限制类型错误。像loop 这样的***定义是很好的候选者，所以在你的情况下添加这个：

loop :: Buffer os (B4 Float, B3 Float) 
     -> CompiledShader os (ContextFormat RGBFloat ()) ShaderEnvironment 
     -> Buffer os (Uniform (V4 (B4 Float)))
     -> ContextT GLFW.GLFWWindow os (ContextFormat RGBFloat ()) IO ()

有了这个类型注释，真正的问题就出现了：

您忘记了 ortho 调用中 -1.0 周围的括号。 您尝试调用clearContextDepth 1，即使上下文是在没有深度缓冲区的情况下创建的。

修复这两个问题后，即使您删除了 loop 的类型注释，模块仍能正常编译（但我建议您保留它）。

【讨论】：

非常感谢，我什至没有在这个地方寻找。我会用类型注释来接受你的提示，这花了我很多时间。