loadCharacter (into atlas)

loadCharacter

-- | Loads a character into our atlas.
-- It does so by rendering a glyph to a texture then draws the original
-- atlas and the glyph texture into a framebuffer that is used as the new
-- atlas.
loadCharacter :: TextShaderProgram -> Atlas -> Char -> IO Atlas
loadCharacter tsp a char = do
    let fp       = _atlasFontFilePath a
        px       = _atlasPxSize a
        (aW, aH) = _atlasTextureSize a
        aTex     = _atlasTextureObject a

    -- Render the glyph into a seperate texture.
    (charTex, (FontChar (gW, gH) gOffset gMtrx)) <- texturizeGlyphOfEnum fp px char

    let w  = aW + gW
        h  = max aH gH
        w' = fromIntegral w
        h' = fromIntegral h

    -- Create the destination texture, and attach it to the framebuffer’s
    -- color attachment point.
    tex <- genObjectName
    activeTexture $= TextureUnit 0
    textureBinding Texture2D $= Just tex
    texture Texture2D $= Enabled
    rowAlignment Unpack $= 1
    textureFilter Texture2D $= ((Nearest, Nothing), Nearest)
    textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
    textureWrapMode Texture2D T $= (Repeated, ClampToEdge)

    texImage2D
        Texture2D
        NoProxy
        0
        R8
        (TextureSize2D w' h')
        0
        (PixelData Red UnsignedByte nullPtr)

    -- Create a framebuffer render target.
    fb <- genObjectName
    bindFramebuffer Framebuffer $= fb
    framebufferTexture2D Framebuffer (ColorAttachment 0) Texture2D tex 0

    -- Test for completeness.
    status <- glCheckFramebufferStatus gl_FRAMEBUFFER

    unless (status == gl_FRAMEBUFFER_COMPLETE) $
        print $ if status == gl_FRAMEBUFFER_INCOMPLETE_ATTACHMENT
                  then "incomplete attachment"
                  else show status

    printError

    activeTexture $= TextureUnit 0
    -- Draw the two textures next to each other to form our new
    -- atlas.
    let vs x y ww hh = [ x, y
                       , x + ww, y
                       , x + ww, y + hh
                       , x, y + hh
                       ]
        aW'  = fromIntegral aW :: GLfloat
        aH'  = fromIntegral aH
        avs  = vs 0 0 aW' aH'
        gvs  = vs aW' 0 aW' aH'
        auvs = vs 0 0 1 1 :: [GLfloat]
        guvs = auvs
        w''  = fromIntegral w'
        h''  = fromIntegral h'
        pj   = orthoMatrix 0 w'' 0 h'' 0 1
        mv   = identityN 4
        scl  = scaleMatrix3d w'' h'' 1

    bindFramebuffer Framebuffer $= fb

    depthClamp $= Disabled
    depthMask $= Disabled

    clear [ColorBuffer]
    viewport $= (Position 0 0, Size w' h')
    currentProgram $= (Just $ tsp^.tShader.program)
    tsp^.setSampler $ Index1 0
    tsp^.setTextColor $ Color4 1 0 0 1
    tsp^.tShader.setProjection $ concat pj
    tsp^.tShader.setModelview $ concat $ mv `multiply` scl

    -- Buffer and draw verts and uvs
    forM_ [(avs,auvs,aTex),(gvs,guvs,charTex)] $ \(verts,uvs,t) -> do
        -- Bind and buffer verts.
        [i,j] <- genObjectNames 2
        bindVBO i vertDescriptor $ AttribLocation 0
        withArray avs $ \ptr ->
            bufferData ArrayBuffer $= (fromIntegral $ length verts, ptr, StaticDraw)
        -- Bind and buffer uvs.
        bindVBO j uvDescriptor $ AttribLocation 1
        withArray uvs $ \ptr ->
            bufferData ArrayBuffer $= (fromIntegral $ length uvs, ptr, StaticDraw)

        bindVBO i vertDescriptor $ AttribLocation 0
        bindVBO j vertDescriptor $ AttribLocation 1

        -- Bind our texture.
        activeTexture $= TextureUnit 0
        texture Texture2D $= Enabled
        textureBinding Texture2D $= Just t
        drawArrays TriangleFan 0 4
        bindBuffer ArrayBuffer $= Nothing
        deleteObjectNames [i,j]
        printError

    currentProgram $= Nothing
    bindFramebuffer Framebuffer $= defaultFramebufferObject

    deleteObjectName fb
    deleteObjectNames [aTex,charTex]

    printError

    -- Update our atlas.
    return $ flip execState a $ do
        atlasMap %= IM.insert (fromEnum char) (FontChar (gW,gH) gOffset gMtrx)
        atlasTextureObject .= tex
        atlasTextureSize .= (w,h)