Zenn
🦥

HaskellからGPUを使う - 拡大した画像をウィンドウに表示する

2025/02/26に公開
Haskell
GPU
Vulkan
GLFW
tech

はじめに

この記事は以下の記事の続編だ。

https://zenn.dev/yoshikuni_jujo/articles/gpu-vulkan-bicubic-refactoring

ここまでやってきた「画像を拡大する」話の集大成になる。今回は拡大した画像をウィンドウに表示する。表示するだけでは面白くないのでキー入力によって

  • 拡大率
  • 拡大する場所
  • 3種の補間方法
  • 双三次補間のパラメーター

を変化させることができるようにする。この記事は次の3つの部分に分けられる。

  • ウィンドウを作成する
  • ウィンドウに画像を表示する
  • キー入力によって表示を変化させる

2番目の部分が今回の本題になる。

今回最終的に完成するソースコードは以下から入手できる。

https://github.com/YoshikuniJujo/test_haskell/tree/master/tribial/zenn/vulkan_bicubic_swapchain/zenn-vulkan-bicubic-swapchain-v0

例題の仕様

  • 前回までと同様コマンドライン引数で入出力用の画像ファイルとパラメーターを指定する
    • パラメーターは、これが初期値になる
  • プログラム終了時のパラメーターで画像をファイルに保存する
  • キー入力毎に画像をウィンドウに表示する
  • それぞれのキーに次のような機能を割り当てる
    • 'd': 画像の縮小
    • 'f': 画像の拡大
    • 'h': 1つ右に移動
    • 'j': 1つ下に移動
    • 'k': 1つ上に移動
    • 'l': 1つ左に移動
    • 'n': 最近傍補間とする
    • ';': 双線形補間とする
    • 'u': 双三次補間とし、パラメーターを0.01減算する
    • 'i': 双三次補間とし、パラメーターを0.01加算する
    • 'm': 双三次補間とし、パラメーターを-0.75にする
    • ',': 双三次補間とし、パラメーターを-0.5にする
  • 双三次補間のパラメーターの取る範囲は-1.0から-0.25とする
  • キー'u'を押し続けた場合-0.75で一度、値が固定される
  • キー'i'を押し続けた場合-0.5で一度、値が固定される

GLFWのインストール

ウィンドウを表示するのにGLFWを使う。

https://www.glfw.org

GLFWのインストールについては、ここでは詳述しない。Windowsユーザーならばpacmanで次のようにインストールすれば良い。

$ pacman -S mingw-w64-x86_64-glfw

前回からの続きのコードを使用する場合

最新のパッケージを使うようにする。

stack.yaml
...

snapshot: nightly-2025-02-26

...

extra-deps:
  - gpu-vulkan-0.1.0.170
  - gpu-vulkan-middle-0.1.0.75
  - gpu-vulkan-core-0.1.0.21
  - shaderc-0.1.0.7
  - language-spir-v-0.1.0.3

...

直接使うパッケージにglfw-groupを追加する。

package.yaml
...

dependencies:
- base >= 4.7 && < 5
- array
- bytestring
- data-default
- JuicyPixels
- gpu-vulkan
- shaderc
- language-spir-v
- glfw-group
- hetero-parameter-list
- tools-yj
- typelevel-tools-yj

...

ウィンドウを作成するに進む。

新たにコードを用意する場合

プロジェクトを作成する。

% stack new zenn-vulkan-bicubic-swapchain
% cd zenn-vulkan-bicubic-swapchain

stack.yamlのsnapshotを変更し、extra-depsを追加する。

stack.yaml
...

snapshot: nightly-2025-02-26

...

extra-deps:
  - gpu-vulkan-0.1.0.170
  - gpu-vulkan-middle-0.1.0.75
  - gpu-vulkan-core-0.1.0.21
  - shaderc-0.1.0.7
  - language-spir-v-0.1.0.3

...

package.yamlのdependenciesにパッケージ名を追加する。また、フィールドdata-filesを追加する。

package.yaml
...

dependencies:
- base >= 4.7 && < 5
- array
- bytestring
- data-default
- JuicyPixels
- gpu-vulkan
- shaderc
- language-spir-v
- glfw-group
- hetero-parameter-list
- tools-yj
- typelevel-tools-yj

...

library:
  source-dirs: src

data-files:
  - shader/expandWidth.comp
  - shader/expandHeight.comp
  - shader/interpolate.comp

...

Mainファイルとシェーダーをコピーする。

https://github.com/YoshikuniJujo/test_haskell/blob/master/tribial/zenn/vulkan_bicubic_refactoring/zenn-vulkan-bicubic-refactoring-v1/app/Main.hs

https://github.com/YoshikuniJujo/test_haskell/blob/master/tribial/zenn/vulkan_bicubic_refactoring/zenn-vulkan-bicubic-refactoring-v1/shader/expandWidth.comp

https://github.com/YoshikuniJujo/test_haskell/blob/master/tribial/zenn/vulkan_bicubic_refactoring/zenn-vulkan-bicubic-refactoring-v1/shader/expandHeight.comp

https://github.com/YoshikuniJujo/test_haskell/blob/master/tribial/zenn/vulkan_bicubic_refactoring/zenn-vulkan-bicubic-refactoring-v1/shader/interpolate.comp

% cp DOWNLOAD/Main.hs app/Main.hs
% mkdir shader
% cp DOWNLOAD/expandWidth.comp shader/
% cp DOWNLOAD/expandHeight.comp shader/
% cp DOWNLOAD/interpolate.comp shader/

app/Main.hsのimport Paths_zenn_vulkan_...をプロジェクト名に応じて適切な名前に修正する。

app/Main.hs
...
import Gpu.Vulkan.PipelineLayout qualified sa Vk.PplLyt
import Gpu.Vulkan.PushConstant qualified as Vk.PshCnst

import Gpu.Vulkan.Semaphore qualified as Vk.Smph

import Paths_zenn_vulkan_bicubic_swapchain

---------------------------------------------------------------------------
--
-- * DATA TYPE IMAGE RGBA8
...

ビルドを試す。

% stack build

ウィンドウを作成する

必要なモジュールを導入する。次のモジュールを追加する。

  • Control.Monad
  • Control.Monad.Fix
  • Graphics.UI.GlfwG
  • Graphics.UI.GlfwG.Window
app/Main.hs
...

import Foreign.Ptr
import Foreign.Marshal.Array
import Foreign.Storable
import Control.Monad
import Control.Monad.Fix
import Data.TypeLevel.Tuple.Uncurry
...
import System.Environment
import Code.Picture

...
import Gpu.Vulkan.PipelineLayout qualified as Vk.PplLyt
import Gpu.Vulkan.PushConstant qualified as Vk.PshCnst

import Gpu.Vulkan.Semaphore qualified as Vk.Smph

import Graphics.UI.GlfwG qualified as GlfwG
import Graphics.UI.GlfwG.Window qualified as GlfwG.Win

import Paths_zenn_vulkan_bicubic_swapchain

...

ここまででは、いろいろなコマンドを一度にキューに提出していた。この段階ではまだウィンドウに画像を表示はしないが、この先で必要になるのでキューに送るコマンドを次の3つの部分に分ける。

  • 拡大前の画像を用意する部分
  • 画像を拡大して「拡大後の画像」に書き込む
  • 拡大された画像をファイルに書き込む

2番目のコマンド群は最終的にはキー入力毎に実行されることになる。これを関数drawとして定義する。

関数draw

allocateCmdBffrの行の最後にdoを追加する。tr cb imgd' Vk.Img.LayoutUndefined Vk.Img.LayoutGeneralの行は関数drawに含めるので削除する。3つ目のVk.Cmd.bindPipelineComputeからtr cb imgd' Vk.Img.LayoutGeneral ...の行までを削除して、draw gq cb ...の行を追加する。その後のtr cb imgdの行の前にrunCmds gq cb ...の行を追加する。関数drawを定義する。

app/Main.hs
...
body pd dv gq cp img flt a (fromIntegral -> n) i =
	resultBffr @img pd dv w h \rb ->
	...
	createDscPl dv \dp -> createDscSt dv dp imgvws' imgvwd' dsl \ds ->

	allocateCmdBffr dv cp \cb -> do
	runCmds gq cb HPList.Nil HPList.Nil do
		tr cb imgs
			Vk.Img.LayoutUndefined Vk.Img.LayoutTransferDstOptimal
		...
		copyImgToImg cb imgs imgs' w h 1 1
		tr cb imgs' Vk.Img.LayoutTransferDstOptimal Vk.Img.LayoutGeneral
		Vk.Cmd.BindPipelineCompute
				cb Vk.Ppl.BindPointCompute wppl \ccb -> do
			Vk.Cmd.bikndDescriptorSetsCompute
				ccb wpl (HPList.Singleton $ U2 wds) def
			Vk.Cmd.dispatch ccb 1 ((h + 2) `div'` 16) 1
		Vk.Cmd.bindPipelineCompute
				cb Vk.Ppl.BindPointCompute hppl \ccb -> do
			Vk.Cmd.bindDescriptorSetsCompute
				ccb hpl (HPList.Singleton $ U2 hds) def
			Vk.Cmd.dispatch ccb ((w + 2) `div'` 16) 1 1

	draw gq cb ppl pl ds w h imgd' flt a n ix iy

	runCmds gq cb HPList.Nil HPList.Nil do
		tr cb imgd
			Vk.Img.LayoutUndefined Vk.Img.LayoutTransferDstOptimal
		copyImgToImg cb imgd' imgd w h 0 0
		tr cb imgd
			Vk.Img.LayoutTransferDstOptimal
			Vk.Img.LayoutTransferSrcOPtimal
		copyImgToBffr cb imgd rb
	where
	trsd = Vk.Img.UsageTransferSrcBit .|. Vk.Img.UsageTransferDstBit
	...

...

strgImgBinding :: Vk.DscStLyt.Binding ('Vk.DscStLyt.Image iargs)
strgImgBinding = Vk.DscStLyt.BindingImage {
	Vk.DscStLyt.bindingImageDescriptorType = Vk.Dsc.TypeStorageImage,
	Vk.DscStLyt.bindingImageStageFlags = Vk.ShaderStageComputeBit }

draw :: Vk.Q.Q -> Vk.CBffr.C scb ->
	Vk.Ppl.Cp.C scp '(sl, '[ '(sdsl, '[SrcImg, DstImg])], PshCnsts) ->
	Vk.PplLyt.P sl '[ '(sdsl, '[SrcImg, DstImg])] PshCnsts ->
	Vk.DscSt.D sds '(sdsl, '[SrcImg, DstImg]) ->
	(forall n . Integral n => n) -> (forall n . Integral n => n) ->
	Vk.Img.Binded smd sid nmd fmtd ->
	Filter -> Float -> Word32 -> Word32 -> Word32 -> IO ()
draw gq cb ppl pl ds w h im flt a n ix iy =
	runCmds gq cb HPList.Nil HPList.Nil do
	tr cb im Vk.Img.LayoutUndefined Vk.Img.LayoutGeneral
	Vk.Cmd.bindPipelineCompute cb Vk.Ppl.BindPointCompute ppl \ccb -> do
		Vk.Cmd.bindDescriptorSetsCompute
			ccb pl (HPList.Singleton $ U2 ds) def
		Vk.Cmd.pushConstantsCompute @'[ 'Vk.T.ShaderStageComputeBit]
			ccb pl (flt :* a :* n :* ix :* iy :* HPList.Nil)
		Vk.Cmd.dispatch ccb (w `div'` 16) (h `div'` 16) 1
	tr cb im Vk.Img.LayoutGeneral Vk.Img.LayoutTransferSrcOptimal
	where tr = transitionImgLyt

-- BUFFER AND IMAGE

...

ビルドと実行を試す。以下の画像ファイルをダウンロードして設置する。

% cp DOWNLOAD/funenohito.png ./
% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388

次のような警告が表示される。

... Validation Error: ... VkCommandBuffer 0xfffffff[] attempts to implicity
reset cmdBuffer created from VkCommandPool 0xffff000000001[] that does NOT
have the VK_COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT bit set.

「VK_CMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BITが指定されていないコマンドプールから作られたコマンドバッファーが暗黙にリセットされてるよ」ということ。コマンドバッファーを複数回使うにはリセットが必要なのだけど、コマンドプールにコマンドバッファーをリセットする機能が指定されていないために警告が表示された。コマンドプールを作成するときのパラメーターに適切な値をセットすればいい。

app/Main.hs
...

createCmdPl :: Vk.QFam.Index ->
	Vk.Dvc.D sd -> (forall sc . Vk.CmdPl.C sc -> IO a) -> IO a
createCmdPl qfi dv = Vk.CmdPl.create dv info nil
	where info = Vk.CmdPl.CreateInfo {
		Vk.CmdPl.createInfoNext = TMaybe.N,
		Vk.CmdPl.createInfoFlags = Vk.CmdPl.CreateResetCommandBufferBit,
		Vk.CmdPl.createInfoQueueFamilyIndex = qfi }

...

ビルドして試してみよう。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388

関数withWindow

GLFWの機能を使うには、とにもかくにもinitが必要だ。

Hackage: Graphics.UI.GlfwG.init

GlfwG.init :: (ErrorMessage -> IO a) -> IO a -> IO a

GlfwG.initの第一引数は初期化に失敗した場合に実行される動作を指定し、第二引数には成功した場合の動作を指定する。関数realMainの先頭にこの関数を追加する。

app/Main.hs
...

realMain :: ImageRgba8 -> Filter -> Float -> Int32 -> Int32 -> IO ImageRgba8
realMain img flt a n i = GlfwG.init error $
	createIst \ist -> pickPhd ist >>= \(pd, qfi) ->
	createLgDvc pd qfi \dv -> Vk.Dvc.getQueue dv qfi 0 >>= \gq ->
	createCmdPl qfi dv \cp -> body pd dv gq cp img flt a n i

...

draw gq cb ...の行をwithWindow w h \win->で始まるブロックで置き換える。ウィンドウを作成したら「閉じる」ボタンを押すまで関数drawをくりかえすために関数fixを使う。関数withWindowを定義する。

app/Main.hs
...
body pd dv gq cp img flt a (fromIntegral -> n) i =
	resultBffr @img pd dv w h \rb ->
	...

	allocateCmdBffr dv cp \cb -> do
	runCmds gq cb HPList.Nil HPList.Nil do
		tr cb imgs
			Vk.Img.LayoutUndefined Vk.Img.LayoutTransferDstOptimal
		...

	withWindow w h \win ->
		fix \act -> do
			draw gq cb ppl pl ds w h imgd' flt a n ix iy
			GlfwG.waitEvents
			wsc <- GlfwG.Win.shouldClose win
			case wsc of
				True -> pure ()
				_ -> act

	runCmds gq cb HPList.NIl HPList.Nil do
		tr cb imgd
			Vk.Img.LayoutUndefined Vk.Img.LayoutTransferDstOptimal
		...

...

strgImgBinding :: Vk.DscStLyt.Binding ('Vk.DscLyt.Image iargs)
strgImgBinding = Vk.DscStLyt.BindingImage {
	Vk.DscStLyt.bindingImageDescriptorType = Vk.Dsc.TypeStorageImage,
	Vk.DscStLyt.bindingImageStageFlags = Vk.ShaderStageComputeBit }

withWindow :: Int -> Int -> (forall s . GlfwG.Win.W s -> IO a) -> IO a
withWindow w h a = do
	GlfwG.Win.hint `mapM_` [
		GlfwG.Win.WindowHint'ClientAPI GlfwG.Win.ClientAPI'NoAPI,
		GlfwG.Win.WindowHint'Resizable False ]
	GlfwG.Win.create w h "Bicubic Interpolation" Nothing Nothing \win -> do
		(ww, hw) <- GlfwG.Win.getSize win
		(wf, hf) <- GlfwG.Win.getFramebufferSize win
		GlfwG.Win.setSize win (w * ww `div` wf) (h * hw `div` hf)
		waitFramebufferSize win (== (w, h)) >> a win

waitFramebufferSize :: GlfwG.Win.W sw -> ((Int, Int) -> Bool) -> IO ()
waitFramebufferSize win p = GlfwG.Win.getFramebufferSize win >>= \sz ->
	when (not $ p sz) $ fix \go -> (`when` go) . not . p =<<
		GlfwG.waitEvents *> GlfwG.Win.getFramebufferSize win

draw :: Vk.Q.Q -> Vk.CBffr.C scb ->
	Vk.Ppl.Cp.C scp '(sl, '[ '(sdsl, '[SrcImg, DstImg])], PshCnsts) ->
	...
...

関数withWindowで生成したウィンドウについて、動作GlfwG.waitEventsでイベントの発生を待ち、関数GlfwG.Win.shouldCloseで終了ボタンが押されたかどうか調べる。押されていればpure ()でループを終了させ、押されていなければactで次のループに進む。関数withWindowの定義は次の2点の問題を解決するために複雑になっている。

  • 処理系によっては「ウィンドウの大きさ」と「フレームバッファの大きさ」が一致しない場合がある
  • 大きさを指定してウィンドウを開いてもウィンドウマネージャーがサイズを変更してしまう

これらの解決のためにウィンドウを開いた後に再度大きさを指定したうえで、指定した大きさになるまで待つというロジックになっている。ビルドして実行してみよう。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388

空のウィンドウが出現する。閉じるボタンを押すなど、ウィンドウを閉じる動作を行うとプログラムは終了する。

ウィンドウに画像を表示する

サーフェスとスワップチェーン

Vulkan APIでウィンドウに画像を表示する場合、さまざまな環境について統一的にあつかえるようにサーフェスという仕組みが使われる。そして、そのサーフェスに書き込むためにスワップチェーンという仕組みを使う。スワップチェーンは画面の表示のための複数のバッファを含む。複数のバッファのうち、どれか1つが画面に表示されていて、それ以外のバッファに描画が行われる。表示側はアプリケーション側からの依頼により、描画が終わったバッファで表示されているバッファを置き換える。

必要なパッケージ

stack.yamlに次のパッケージを追加する。

  • gpu-vulkan-khr-swapchain-0.1.0.1
  • gpu-vulkan-khr-surface-glfw-0.1.0.0
  • gpu-vulkan-khr-surface-0.1.0.0
  • gpu-vulkan-middle-khr-swapchain-0.1.0.0
  • gpu-vulkan-middle-khr-surface-glfw-0.1.0.1
  • gpu-vulkan-middle-khr-surface-0.1.0.0
  • gpu-vulkan-core-khr-swapchain-0.1.0.0
  • gpu-vulkan-core-khr-surface-0.1.0.0

gpu-vulkan-khr-swapchainとgpu-vulkan-middle-khr-surfa-glfwだけバージョンが0.1.0.1になっているので注意する。

stack.yaml
...

extra-deps:
  - gpu-vulkan-0.1.0.170
  - gpu-vulkan-khr-swapchain-0.1.0.1
  - gpu-vulkan-khr-surface-glfw-0.1.0.0
  - gpu-vulkan-khr-surface-0.1.0.0
  - gpu-vulkna-middle-0.1.0.75
  - gpu-vulkan-middle-khr-swapchain-0.1.0.0
  - gpu-vulkan-middle-khr-surface-glfw-0.1.0.1
  - gpu-vulkan-middle-khr-surface-0.1.0.0
  - gpu-vulkan-core-0.1.0.21
  - gpu-vulkan-core-khr-swapchain-0.1.0.0
  - gpu-vulkan-core-khr-surface-0.1.0.0
  - shaderc-0.1.0.7
  - language-spir-v-0.1.0.3

...

package.yamlに次のパッケージを追加する。

  • gpu-vulkan-khr-swapchain
  • gpu-vulkan-khr-surface-glfw
  • gpu-vulkan-khr-surface
package.yaml
...

dependencies:
- base >= 4.7 && < 5
- array
- bytestring
- data-default
- JuicyPixels
- gpu-vulkan
- gpu-vulkan-khr-swapchain
- gpu-vulkan-khr-surface-glfw
- gpu-vulkan-khr-surface
- shaderc
- language-spir-v
- glfw-group
- hetero-parameter-list
- tools-yj
- typelevel-tools-yj

...

必要なモジュール

以下に示す必要なモジュールを追加する。

  • Data.Ord.ToolsYj
  • Data.HeteroParList.Constrained
  • Data.Bool.ToolsYj
  • Gpu.Vulkan.Khr.Swapchain
  • Gpu.Vulkan.Khr.Surface
  • Gpu.Vulkan.Khr.Surface.PhysicalDevice
  • Gpu.Vulkan.Khr.Surface.Glfw.Window
app/Main.hs
...
import Data.TypeLevel.Maybe qualified as TMaybe
import Data.TypeLevel.ParMaybe (nil)
import Data.Ord.ToolsYj
import Data.Bits
...
import Data.List qualified as L
import Data.HeteroParList (patter (:**), pattern (:*), pattern (:*.))
import Data.HeteroParList qualified as HPList
import Data.HeteroParList.Constrained (pattern (:^*))
import Data.Array
import Data.Bool.ToolsYj
import Data.Word
...
import Gpu.Vulkan.PipelineLayout qualified as Vk.PplLyt
import Gpu.Vulkan.PushConstant qualified as Vk.PshCnst

import Gpu.Vulkan.Semaphore qualified as Vk.Smph

import Gpu.Vulkan.Khr.Swapchain qualified as Vk.Swpch
import Gpu.Vulkan.Khr.Surface qualified as Vk.Sfc
import Gpu.Vulkan.Khr.Surface.PhysicalDevice qualified as Vk.Sfc.Phd
import Gpu.Vulkan.Khr.Surface.Glfw.Window qualified as Vk.Sfc.Glfw.Win

import Graphics.UI.GlfwG qualified as GlfwG
...

サーフェスを作成する

関数bodyのなかでサーフェスを作成する。サーフェスの作成にはVulkanのインスタンスが必要なので、関数bodyにインスタンスを渡すようにコードを修正する。また、表示機能がサポートされているかを調べるためにキューファミリーインデックスが必要になるので、それも関数bodyに渡す。

関数realMainで関数bodyを呼んでいる部分で関数bodyに第一引数としてistを追加し、第三引数としてqfiを追加する。関数bodyの型宣言で型変数siを追加し第一引数にVk.Ist.I siを追加し、第三引数にVk.QFam.Indexを追加する。 関数定義に引数istとqfiを追加する。

app/Main.hs
...
realMain img flt a n i = GlfwG.init error $
	createIst \ist -> pickPhd ist >>= \(pd, qfi) ->
	createLgDvc pd qfi \dv -> Vk.Dvc.getQueue dv qfi 0 >>= \gq ->
	createCmdPl qfi dv \cp -> body ist pd qfi dv gq cp img flt a n i

...

body :: forall si sd sc img . Vk.ObjB.IsImage img =>
	Vk.Ist.I si -> Vk.Phd.P -> Vk.QFam.Index -> Vk.Dvc.D sd -> Vk.Q.Q ->
	Vk.CmdPl.C sc -> img -> Filter -> Float -> Int32 -> Int32 -> IO img
body ist pd qfi dv gq cp img flt a (fromIntegral -> n) i =
	resultBffr @img pd dv w h \rb ->
	...

サーフェスを作成する。withWindow w h ...の行にVk.Sfc.Glfw.Win.create ...を追加する。また、表示機能をサポートしているかどうかのチェックする2行も追加する。

app/Main.hs
body ist pd dv gq cp img flt a (fromIntegral -> n) i =
	resultBffr @img pd dv w h \rb ->
	...
	Vk.Cmd.bindPipelineCompute
			cb Vk.Ppl.BindPointCompute hppl \ccb -> do
		Vk.Cmd.bindDescriptorSetsCompute
			ccb hpl (HPList.Singleton $ U2 hds) def
		Vk.Cmd.dispatch ccb ((w + 2) `div'` 16) 1 1

	withWindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		when (not ps) (error "Presentation is not supported!") >>
		fix \act -> do
			draw gq cb ppl pl ds w h imgd' flt a n ix iy
			...

ビルドして試してみる。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388
zenn-vulkan-bicubic-swapchain-exe: ErroerExtensionNotPresent
...

エラーが出る。サーフェスを使うには拡張機能を有効にする必要がある。インスタンスを作成する部分と、論理デバイスを作成する部分に拡張機能のためのパラメーターを指定する。

関数createIstにGlfwG.getRequiredInstanceExtensionsで必要な拡張を入手してパラメーターとして作成のときに渡すコードを追加する。(Vk.Ist.ExtensionName <$>) <$>の部分は型を合わせているだけだ。関数createLgDvcのwhere節のinfoのメンバーVk.Dvc.createInfoEnabledExtensionNamesに[Vk.Swpch.extensionName]を指定する。

app/Main.hs
...
createIst a = do
	es <- (Vk.Ist.ExtensionName <$>) <$> GlfwG.getReqiuredInstanceExtensions
	Vk.Ist.create (info es) nil a
	where
	info :: [Vk.Ist.ExtensionName] -> Vk.Ist.CreateInfo 'Nothing 'Nothing
	info es = def {
		Vk.Ist.createInfoApplicationInfo = Just ainfo,
		Vk.Ist.createInfoEnabledLayerNames = vldLayers,
		Vk.Ist.createInfoEnabledExtensionNames = es }
	ainfo = Vk.ApplicatiojnInfo {
		Vk.appplicationInfoNext = TMaybe.N,
		...

...
createLgDvc pd qfi = Vk.Dvc.create pd info nil where
	info = Vk.Dvc.CreateInfo {
		Vk.Dvc.CreateInfoNext =
			TMaybe.J (Vk.Phd.vulkan13FeaturesZero TMaybe.N) {
				Vk.Phd.vulkan13FeaturesSynchronization2 = True
				},
		Vk.Dvc.createInfoFlags = zeroBits,
		Vk.Dvc.createInfoQueueCreateInfos = HPList.Singleton qinfo,
		Vk.Dvc.createInfoEnabledLayerNames = vldLayers,
		Vk.Dvc.createInfoEnabledExtensionNames =
			[Vk.Swpch.extensionName],
		Vk.Dvc.createInfoEnabledFeatures = Just def }
	qinfo = Vk.Dvc.QueueCreateInfo {
		Vk.Dvc.queueCreateInfoNext = TMaybe.N,
		...

ビルドして試してみよう。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388

スワップチェーンの作成のためのパラメーターを指定する

それぞれの物理装置やサーフェスに対応するスワップチェーンを作る。物理装置に許される値の範囲を問い合わせて、その範囲内で好ましいパラメーターを設定する。設定する値には次のようなものがある。

  • 画像のフォーマット
  • カラースペース
  • バッファの表示のタイミングを決めるアルゴリズム
  • 最小のイメージの数
  • 表示するときの反転や回転などの設定
  • バッファの画像としての大きさ

これらのパラメーターを格納するデータ型を定義する。「目次」のところに-- * SWAP CHAINと前回忘れていた-- * TOOLSを追加する。ソースコード本体の-- TOOLSの前に-- SWAP CHAINから始まる10行を追加する。

app/Main.hs
...
-- * COMMANDS
-- * PIPELINE AND DESCRIPTOR SET
-- * SWAP CHAIN
-- * TOOLS
--
---------------------------------------------------------------------------

-- DATA TYPE IMAGE RGBA8

newtype ImageRgba8 = ImageRgba8 (Image PixelRGBA8)
newtype PixelRgba8 = PixelRgba8 PixelRGBA8 deriving Show

...

compileShader :: FilePath -> IO (SpirV.S GlslComputeShader)
compileShader fp = do
	cd <- BS.readFile =<< getDataFileName fp
	Shader.compile @() cd (BSC.pack fp) "main" def

-- SWAP CHAIN

data SwpchSettings fmt = SwpchSettings {
	swpchSettingsFormat :: Vk.Sfc.Format fmt,
	swpchSettingsPresentMode :: Vk.Sfc.PresentMode,
	swpchSettingsMinImageCount :: Word32,
	swpchSettingsTransform :: Vk.Sfc.TransformFlagBits,
	swpchSettingsImageExtent :: Vk.Extent2d }
	deriving Show

-- TOOLS

div' :: Integral n => n -> n -> n
x `div'` y = case x `divMod` y of (d, 0) -> d; (d, _) -> d + 1

フォーマットとカラースペース

関数Gpu.Vulkan.Khr.Surface.PhysicalDevice.getFormatでフォーマットとカラースペースの問い合わせができる。

getFormats :: Vk.Phd.P -> Vk.Sfc.S ss -> (forall fmts .
	HPListC.PL Vk.FormatToValue Vk.Sfc.Format fmts -> IO a) -> IO a

getFormatsFiltered :: forall fmt ss .
	FormatToValue fmt => Vk.Phd.P -> Vk.Sfc.S ss -> IO [Vk.Sfc.Format fmt]

data Vk.Sfc.Format (fmt :: Vk.T.Format) =
	Vk.Sfc.Format { formatColorSpace :: Vk.Sfc.ColorSpace }

Vk.Sfc.Format型の値は画像のフォーマットを型引数として格納し、カラースペースを値として格納する。関数getFormatsは物理装置とサーフェスとから許されるフォーマットとカラースペースの組をヘテロリストで返す。関数getFormatsFilteredのほうは指定したフォーマットのものだけを取り出して返す。これらを使って、次のような基準で使用するフォーマットとカラースペースを選ぶ関数を作る。

  • VK_FORMAT_B8G8R8A8_SRGBとVK_COLOR_SPACE_SRGB_NONLINEAR_KHRの組があればそれを選び
  • なければ、問い合わせの結果のうち先頭の組を選ぶ

関数swpchFmtを定義する。

app/Main.hs
...

-- SWAP CHAIN

swpchFmt :: Vk.Phd.P -> Vk.Sfc.S ss -> (forall fmt .
	Vk.T.FormatToValue fmt => Vk.Sfc.Format fmt -> IO a) -> IO a
swpchFmt pd sf f = Vk.Sfc.Phd.getFormats pd sf \case
	fmt0 :^* _ -> maybe (f fmt0) f . L.find ckcs =<< prffmts pd sf
	_ -> error "swpchFmt: no formats"
	where
	prffmts = Vk.Sfc.Phd.getFormatsFiltered @Vk.T.FormatB8g8r8a8Srgb
	ckcs = (== Vk.Sfc.ColorSpaceSrgbNonlinear) . Vk.Sfc.formatColorSpace

data SwpchSettings fmt = SwpchSettings {
	swpchSettingsFormat :: Vk.Sfc.Format fmt,
	...

補助関数prffmtsでVK_FORMAT_B8G8R8A8_SRGBのものだけを取り出して、ckcsでVK_COLOR_SPACE_SRGB_NONLINEAR_KHRのものにしぼる。関数maybeによって「それが存在すればそれを選び、そうでなければヘテロリストの先頭のものを選ぶ」というロジックを実装している。

VkSurfaceCapabilitiesKHR

関数Gpu.Vulkan.Khr.Surface.PhysicalDevice.getCapabilitiesで物理装置とサーフェスからサーフェスの能力を問い合わせることができる。結果は次のような構造体に格納される。

https://registry.khronos.org/vulkan/specs/latest/man/html/VkSurfaceCapabilitiesKHR.html

Gpu.Vulkan.Khr.Surface.Capabilities

data Capabilities = Capabilities {
	capabilitiesMinImageCount :: Word32,
	capabilitiesMaxImageCount :: Word32,
	capabilitiesCurrentExtent :: Extent2d,
	capabilitiesMinImageExtent :: Extent2d,
	capabilitiesMaxImageExtent :: Extent2d,
	capabilitiesMaxImageArrayLayers :: Word32,
	capabilitiesSupportedTransforms :: Vk.Sfc.TransformFlags,
	capabilitiesCurerntTransform :: Vk.Sfc.TransformFlagBits,
	capabiliteisSupportedCompositeAlpha :: Vk.Sfc.CompositeAlphaFlags,
	capabilitiesSupportedUsageFlags :: Vk.Img.UsageFlags }

それぞれのフィールドはスワップチェーンを作成するときに、どのような値を設定できるかを示している。

画像としての大きさ

スワップチェーンは複数の描画用のバッファを持つが、そのバッファの画像としての大きさ(つまり高さと幅)を指定する必要がある。上記のサーフェスの能力を示す値のフィールドcapabilitiesCurrentExtentを参照して、それが実際の大きさを示すようであれば、その大きさを採用する。もし、そのフィールドの値が実際の大きさを示さない特殊な値であれば、ウィンドウマネージャー側にフレームバッファの大きさを問い合わせる。関数swpchExtentを定義する。

app/Main.hs
	...
	where
	prffmts = Vk.Sfc.Phd.getFormatFiltered @Vk.T.FormatB8g8r8a8Srgb
	ckcs = (== Vk.Sfc.ColorSpaceSrgbNonlinear) . Vk.Sfc.formatColorSpace

swpchExtent :: GlfwG.Win.W sw -> Vk.Sfc.Capabilities -> IO Vk.Extent2d
swpchExtent win cps
	| Vk.extent2dWdith cr /= maxBound = pure cr
	| otherwise = (<$> GlfwG.Win.getFramebufferSize win)
			\(fromIntegral -> w, fromIntegral -> h) ->
		Vk.Extent2d
			(clamp (Vk.extent2dWidth n) (Vk.extent2dWidth x) w)
			(clamp (Vk.extent2dHeight n) (Vk.extent2dHeight x) h)
	where
	cr = Vk.Sfc.capabilitiesCurrentExtent cps
	n = Vk.Sfc.capabilitiesMinImageExtent cps
	x = Vk.Sfc.capabilitiesMaxImageExtent cps

data SwpchSettings fmt = SwpchSettings {
	swpchSettingsFormat :: Vk.Sfc.Format fmt,
	...

フィールドcapabilitiesCurrentExtentの値がmaxBoundでなければ、それをスワップチェーンの描画用のバッファの大きさとすればいい。そうでないなら、関数GlfwG.Win.getFramebufferSizeで問い合わせた大きさを、サーフェスがあつかえる画像の大きさの最小と最大の間になるように調整した値を採用する。

ビルドを試しておこう。

% stack build

プレゼンテーションモード

バッファを画面に表示するタイミングについて複数のモードがあり、それをプレゼンテーションモードと呼ぶ。以下のモードがある。

  • PresentModeImmediate
  • PresentModeFifo
  • PresentModeFifoRelaxed
  • PresentModeMailbox

昔のコンピューターのディスプレイを見たことがあるだろうか。液晶ディスプレイのような板みたいな形ではなく、立方体のような存在感のあるディスプレイだ。仕組みとしては後方から電子を飛ばしその電子が当たったところが光るというもので、左から右へ、上から下へ電子を当てる場所を移動させていくことで画像を表示していた。左上から始めて、左から右へ移動し、一番右まで行ったら、すこし下に移動して一番左にもどりというのをくりかえし、右下まで描画する。で右下まで移動したら、次のフレームを表示するために左上にもどる。それをくりかえす。

そういう仕組みなので、もしひとつのフレームを描画している途中で描画の内容が変化すると上下で異なる画像が表示されてしまい、場合によっては上下で「切れた」ような表示になってしまう。それをtearingと呼ぶ。それを避けるために描画内容の更新は、電子を当てる位置を右下から左上にもどしている間にやらなくちゃならない。この「右下から左上にもどる間の時間」をvertical blankと呼ぶ。

今はブラウン管モニターは骨董品になったが、コンピューターとディスプレイの間のやりとりとしては、同様の仕組みを使っていて、つまり液晶ディスプレイがブラウン管モニターをエミュレートしているような状況になっている。

PresentModeImmediate

「すぐに」モード。用意ができたバッファをすぐに表示する。当然tearingは起こり放題になる。

PresentModeFifo

「先入れ先出し」モード。用意ができたバッファをすぐには表示せずにvertical blankまで待つ。アプリケーション側の処理が速い場合には、表示待ちの依頼がたまっていくことになるが、これは「先に入れたものが先に取り出される」キューに保存される。キューがいっぱいになってしまった場合、次の表示のタイミングまでアプリケーション側が待つ必要がある。tearingは起こらない。

PresentModeFifoRelaxed

「緩和された先入れ先出し」モード。バッファの表示をvertical blankまで待つのは同じだけど、前回の表示依頼からその時までに一度vertical blankがあった場合には、次のvertical blankを待たずに表示する。これはアプリケーション側の表示依頼が「だいたいは次のvertical blankに間に合う」けど、ときどきすこし遅れるようなときに有用だ。もし、このような時に「次のvertical blank」まで待つようにすると「カクッ」とした動きになってしまう。時々tearingが起きるとしてもカクつきのほうが気になるような場合には、こちらを選ぶ。

PresentModeMailbox

「メールボックス」モード。どうして「メールボックス」なのかはよくわからない。表示はvertical blankを待つのでtearingは起きない。表示依頼はキューにためておく。もしキューがいっぱいだったときは、新しい表示依頼で古い依頼を置き換える。tearingが起きないしアプリケーション側の「待ち」も起きない。

パラメーターを作成する

物理装置とサーフェスを指定して、それぞれの値を問い合わせて、それをSwpchSettings型の値にまとめる。確認のために表示もする。when (not ps) ...の行の下にcreateSwpchSettings win sf ...からの2行を追加する。また関数createSwpchSettingsとswpchSettingsとを定義する。

app/Main.hs
...
body ist pd dv gq cp img flt a (fromIntegral -> n) i =
	resultBffr @img pd dv w h \rb ->
	...

	withWindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		when (not ps) (error "Presentation is not supported!") >>
		createSwpchSettings win sf pd \stts ->
		print stts >>
		fix \act -> do
			draw gq cb ppl pl ds w h imgd' flt a n ix iy
			...
...

-- SWAP CHAIN

createSwpchSettings :: GlfwG.Win.W sw -> Vk.Sfc.S ssf -> Vk.Phd.P ->
	(forall scfmt .
		Vk.T.FormatToValue scfmt => SwpchSettings scfmt -> IO a) -> IO a
createSwpchSettings win sf pd f = swpchFmt pd sf \fmt -> do
	pm <- findDefault Vk.Sfc.PresentModeFifo (== Vk.Sfc.PresentModeMailbox)
		<$> Vk.Sfc.Phd.getPresentModes pd sf
	cps <- Vk.Sfc.Phd.getCapabilities pd sf
	ex <- swpchExtent win cps
	f $ swpchSettings cps fmt pm ex

swpchSettings :: Vk.Sfc.Capabilities -> Vk.Sfc.Format fmt ->
	Vk.Sfc.PresentMode -> Vk.Extent2d -> SwpchSettings fmt
swpchSettings cps fmt pm ex = SwpchSettings {
	swpchSettingsFormat = fmt,
	swpchSettingsPresentMode = pm,
	swpchSettingsMinImageCount = imgc,
	swpchSettingsTransform = Vk.Sfc.capabilitiesCurrentTransform cps,
	swpchSettingsImageExtent = ex }
	where
	imgc = clamp 0 imgcx (Vk.Sfc.capabilitiesMinImageCount cps + 1)
	imgcx = fromMaybe maxBound
		. onlyIf (> 0) $ Vk.Sfc.capabilitiesMaxImageCount cps

...

関数createSwpchSettingsでは次の値を問い合わせて、それらの値から関数swpchSettingsでSwpchSettings型の値を組み立てている。

  • フォーマット
  • カラースペース
  • プレゼンテーションモード
  • 能力(capabilities)
  • スワップチェーンのバッファの画像としての大きさ

プレゼンテーションモードはPresentModeMailboxがあればそれを選び、無ければPresentModeFifoを選ぶようにしてある。PresentModeFifoは存在が保証されているので、デフォルト値として使える。

関数swpchSettingsはだいたいは与えられた値をそのまま使っているが、フィールドswpchSettingsMinImageCountについては次のような計算をしている。

  • 問い合わせの結果である最小限、必要なバッファ数に1加算する
  • もしもその最大値が指定されていれば、0から最大値までの間になるように値を調整する
    • 最大値が0となっている場合は最大値が指定されていないということ

ビルドして試してみよう。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388
SwpchSettings {swpchSettingsFormat = (Format {- FormatB8g8r8a8Srgb -} ColorSpaceSrgbNonlinear),
swpchSettingsPresentMode = PresentModeMailbox, swpchSettingsMinImageCount = 4,
swpchSettingsTransform = TransformIdentityBit,
swpchSettingsImageExtent = Extent2d {extent2dWidth = 799, extent2dHeight = 1000}}

僕の環境ではこのような結果になった。

  • フォーマット: B8G8R8A8 SRGB
  • カラースペース: SRGB NONLINEAR
  • プレゼンテーションモード: Mailbox
  • 画像数の最小値: 4
  • 変換の種類: Identity
  • バッファの画像としての大きさ: 幅 799, 高さ 1000

スワップチェーンの作成のためのパラメーター

パラメーターが決まったので実際にスワップチェーンを作成する。関数Gpu.Vulkan.Khr.Swapchain.createを使う。この関数のパラメーターはGpu.Vulkan.Khr.Swapchain.CreateInfo型の値で指定する。

data Vk.Swpch.CreateInfo mn ssf fmt mosas = Vk.Swpch.CreateInfo {
	creteInfoNext :: TMaybe.M mn,
	createInfoFlags :: Vk.Swpch.CreateFlags,
	createInfoSurface :: Vk.Sfc.S ssf,
	createInfoMinImageCount :: Word32,
	createInfoImageColorSpace :: Vk.Sfc.ColorSpace,
	createInfoImageExtent :: Vk.Extent2d,
	createInfoImageArrayLayers :: Word32,
	createInfoImageUsage :: Vk.Img.UsageFlags,
	createInfoImageSharingMode :: Vk.SharingMode,
	createInfoQueueFamilyIndices :: [Vk.QFam.Index],
	createInfoPreTransform :: Vk.Sfc.TransformFlagBits,
	createInfoCompositeAlpha :: Vk.Sfc.CompositeAlphaFlagBits,
	createInfoPresentMode :: Vk.Sfc.PresentMode,
	createInfoClipped :: Bool,
	createInfoOldSwapchain :: TPMaybe.M (U2 Vk.Swpch.S) mosas }

SwpchSettings型の値からVk.Swpch.CreateInfo型の値を組み立てる関数を定義する。

app/Main.hs
...

-- SWAP CHAIN

swpchInfo :: forall fmt ss . Vk.Sfc.S ss ->
	SwpchSettings fmt -> Vk.Swpch.CreateInfo 'Nothing ss fmt 'Nothing
swpchInfo sf stts = Vk.Swpch.CreateInfo {
	Vk.Swpch.createInfoNext = TMaybe.N, Vk.Swpch.createInfoFlags = zeroBits,
	Vk.Swpch.createInfoSurface = sf,
	Vk.Swpch.createInfoMinImageCount = swpchSettingsMinImageCount stts,
	Vk.Swpch.createInfoImageColorSpace =
		Vk.Sfc.formatColorSpace $ swpchSettingsFormat stts,
	Vk.Swpch.createInfoImageExtent = swpchSettingsImageExtent stts,
	Vk.Swpch.createInfoImageArrayLayers = 1,
	Vk.Swpch.createInfoImageUsage = Vk.Img.UsageTransferDstBit,
	Vk.Swpch.createInfoImageSharingMode = Vk.SharingModeExclusive,
	Vk.Swpch.createInfoQueueFamilyIndices = [],
	Vk.Swpch.createInfoPreTransform = swpchSettingsTransform stts,
	Vk.Swpch.createInfoCompositeAlpha = Vk.Sfc.CompositeAlphaOpaqueBit,
	Vk.Swpch.createInfoPresentMode = swpchSettingsPresentMode stts,
	Vk.Swpch.createInfoClipped = True,
	Vk.Swpch.createInfoOldSwapchain = nil }

createSwpchSettings :: GlfwG.Win.W sw -> Vk.Sfc.S ssf -> Vk.Phd.P ->
	(forall scfmt .
		Vk.T.FormatToValue scfmt => SwpchSettings scfmt -> IO a) -> IO a
...

createInfoImageArrayLayers

立体視のために複数の画像を用意する場合以外では、これは1にする。

createInfoImageUsage

スワップチェーンが用意するイメージをどう使うかを指定する。ここでは拡大された画像をコピーするコピー先になるのでVk.Img.UsageTransferDstBitを指定する。

createInfoImageSharingModeとcreateInfoQueueFamilyIndices

スワップチェーンが用意するイメージが複数のキューファミリーで共有されるかどうかと、もし共有するなら共有するキューファミリーのリストを指定する。今回は共有しないのでVk.SharingModeExclusiveを指定する。

createInfoCompositeAlpha

アルファチャンネルをどう扱うかを指定する。たぶん透過ウィンドウとか、そういう機能に関する話だと思う。ここではアルファチャンネルを無視(つまり、すべて1であるものと)するのでVk.Sfc.CompositeAlphaOpqaueBitを指定する。

createInfoClipped

この値が真であるということは、他のウィンドウに隠されているなどで、表示されない部分についてピクセルの値を計算しなくてもいいということ。

createInfoOldSwapchain

この値に「古いスワップチェーン」を指定した場合、その一部を再利用できるかもしれない。

スワップチェーンを作成する

スワップチェーンを作成する。まずは関数bodyのcreateSwpchSettings win sf ...の行の下のprint stts >>という行をcreateSwpch sf dv stts \sc ->に置き換える。また、createSwpchを定義する。

app/Main.hs
...
body ist pd qfi dv gq cp img flt a (fromIntegral -> n) i =
	resultBffr @img pd dv w h \rb ->
	...

	withWindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		when (not ps) (error "Presentation is not supported!") >>
		createSwpchSettings win sf pd \stts ->
		createSwpch sf dv stts \sc ->
		fix \act -> do
			draw gq cb ppl pl ds w h imgd' flt a n ix iy
            ...

...

-- SWAP CHAIN

createSwpch :: forall scfmt ssf sd a . Vk.T.FormatToValue scfmt =>
	Vk.Sfc.S ssf -> Vk.Dvc.D sd -> SwpchSettings scfmt ->
	(forall ss . Vk.Swpch.S scfmt ss -> IO a) -> IO a
createSwpch sf dv stts = Vk.Swpch.create @_ @scfmt dv (swpchInfo sf stts) nil

swpchInfo :: forall fmt ss . Vk.Sfc.S ss ->
	SwpchSettings fmt -> Vk.Swpch.CreateInfo 'Nothing ss fmt 'Nothing
...

ビルドして試してみよう。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388

セマフォ

Vulkanではアプリケーション側で明示的に指定しない限り、受け取った命令の実行の順序がどうなるかは処理系依存ということになっている。つまり先に送った命令より、後から送った命令のほうが先に実行される可能性もあるし、それらが同時に実行される可能性もある。今回は拡大した画像をウィンドウに表示するわけだけど、「拡大する」処理と「表示する」処理とは順に実行されてほしい。そのような場合に「セマフォ」を使う。命令Aがセマフォのロックを解除し、命令Bがセマファのロックの解除を待つという形で、1つの命令と別の命令との間の順番や依存関係を指定することができる。例題コードでは次の3つの処理が順番通りに実行されるようにしたい。

  • スワップチェーンから描画用のイメージを取得する
  • 描画用のイメージに拡大した画像を描画する
  • 描画したイメージを表示する

なので、セマフォを2つ使うことになる。これらはGPUのなかでの命令の依存関係を指定するものだ。CPU - GPUの間での同期にはフェンスという別の仕組みを使う。次のフレームの実行の前に、前のフレームの実行が終わっていることを確認する必要がある。これにはフェンスを使うのが適切なのだけど、一度にたくさんの項目を説明するとわかりにくくなるので、ここではより簡便な関数Vk.Q.waitIdleを使うことにする。これはキューに送られた全てのコマンドの実行の終了を待つということなので、実行効率的にはもっと細やかな調整のほうが望ましくはある。

例題コードにセマフォを作成するコードであるVk.Smph.createから始まる2行を追加する。

app/Main.hs
...

	withWindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		when (not ps) (error "Presentation is not supported!") >>
		createSwpchSettings win sf pd \stts ->
		createSwpch sf dv stts \sc ->
		Vk.Smph.create @'Nothing dv def nil \ias ->
		Vk.Smph.create @'Nothing dv def nil \rfs -> do
		fix \act -> do
			...

...

ビルドして試してみる。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388

Vk.Smph.SubmitInfo

関数runCmdsの引数にするためのVk.Smph.SubmitInfo型の値を組み立てる関数smphInfoを定義する。

app/Main.hs
...
	where cbi = Vk.CBffr.SubmitInfo {
		Vk.CBffr.submitInfoNext = TMaybe.N,
		Vk.CBffr.submitInfoCommandBuffer = cb,
		Vk.CBffr.submitInfoDeviceMask = def }

smphInfo :: Vk.Smph.S ss -> Vk.Ppl.StageFlags2 ->
	HPList.PL (U2 Vk.Smph.SubmitInfo) '[ '( 'Nothing, ss)]
smphInfo smph sm = HPList.Singleton $ U2 Vk.Smph.SubmitInfo {
	Vk.Smph.submitInfoNext = TMaybe.N,
	Vk.Smph.submitInfoSemaphore = smph, Vk.Smph.submitInfoValue = 0,
	Vk.Smph.submitInfoStageMask = sm, Vk.Smph.submitInfoDeviceIndex = 0 }

-- COMMANDS

フィールドsubmitInfoNextは拡張のためのフィールド。submitInfoSemaphoreにはセマフォを指定。submitInfoStageMaskは「どのステージでセマフォを待つ/に信号を送るか」を指定する。フィールドsubmitInfoValueはtimeline semaphoreという特別なセマフォに関係するパラメーターなので、今回は使わない。submitInfoDeviceIndexはdevice groupという機能を使う場合に関係があるパラメーターで、やはり今回は使わない。

関数drawにセマフォを渡すための引数を追加する

コマンドの提出のときにセマフォを指定したい。関数bodyの中のセマフォを作成しているVk.Smph.createで始まる2行の後に値wiとsiとを定義している2行を追加する。関数drawの呼び出しに引数wiとsiとを追加する。関数drawの定義の型宣言にVk.Smph.SubmitInfoListToMiddleで始まる型制約を2つ追加する。同じく型宣言にHPList.PL (U2 Vk.Smph...で始まる2行を追加する。関数定義の左辺にセマフォを指定する引数wiとsiを追加する。関数定義の右辺のrunCmdsの引数である2つのHPList.Nilをそれぞれwiとsiで置き換える。

app/Main.hs
...
body ist pd qfi dv gq cp img flt a (fromIntegral -> n) i =
	resultBffr @img pd dv w h \rb ->
	...

	withWindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		when (not ps) (error "Presentation is not supported!") >>
		createSwpchSettings win sf pd \stts ->
		createSwpch sf dv stts \sc ->
		Vk.Smph.create @'Nothing dv def nil \ias ->
		Vk.Smph.create @'Nothing dv def nil \rfs -> do
		let	wi = smphInfo ias Vk.Ppl.Stage2ColorAttachmentOutputBit
			si = smphInfo rfs Vk.Ppl.Stage2AllGraphicsBit
		fix \act -> do
			draw gq cb wi si ppl pl ds w h imgd' flt a n ix iy
			GlfwG.waitEvents
			wsc <- GlfwG.Win.shouldClose win
			case wsc of
				True -> pure ()
				_ -> act

		runCmds gq cb HPList.Nil HPList.Nil do
			...

...
waitFramebufferSize win p = GlfwG.Win.getFramebufferSize win >>= \sz ->
	when (not $ p sz) $ fix \go -> (`when` go) . not . p =<<
		GlfwG.waitEvents *> GlfwG.Win.getFramebufferSize win

draw :: (
	Vk.Smph.SubmitInfoListToMiddle wss,
	Vk.Smph.SubmitInfoListToMiddle sss ) => Vk.Q.Q -> Vk.CBffr.C scb ->
	HPList.PL (U2 Vk.Smph.SubmitInfo) wss ->
	HPList.PL (U2 Vk.Smph.SubmitInfo) sss ->
	Vk.Ppl.Cp.C scp '(sl, '[ '(sdsl, '[SrcImg, DstImg])], PshCnsts) ->
	Vk.PplLyt.P sl '[ '(sdsl, '[SrcImg, DstImg])] PshCnsts ->
	Vk.DscSt.D sds '(sdsl, '[SrcImg, DstImg]) ->
	(forall n . Integral n => n) -> (forall n . Integral n => n) ->
	Vk.Img.Binded smd sid nmd fmtd ->
	Filter -> Float -> Word32 -> Word32 -> Word32 -> IO ()
draw gq cb wi si ppl pl ds w h im flt a n ix iy = runCmds gq cb wi si do
	tr cb im Vk.Img.LayoutUndefined Vk.Img.LayoutGeneral
	...

これで関数drawでGPUに提出されるコマンドについて、それを待つセマフォと、それに信号を送るセマフォとを指定することができる。この段階でビルド - 実行すると「待つセマフォ」に信号が送られることがないので、アプリケーションは止まってしまう。動かすには関数drawが提出するコマンドが「待つセマフォ」に信号を送る必要がある。

拡大した結果をウィンドウに表示する

結果をウィンドウに表示するには、まずスワップチェーンから複数のイメージを取り出す。次にループの中で次の順に処理を実行する。

  • スワップチェーンに何番目のイメージが描画可能かを問い合わせる
  • そのイメージに拡大された結果をコピーする
  • イメージを表示するように依頼する

スワップチェーンから複数のイメージを取り出す

スワップチェーンは「描画 - 表示」用のバッファとして複数のイメージを持っている。その複数のイメージを取り出すのにVk.Swpch.getImagesを使う。

getImages ::
	Vk.Dvc.D sd -> Vk.Khr.Swpch.S fmt ss -> IO [Vk.Img.Binded ss ss nm fmt]

例題コードにスワップチェーンから複数のイメージを取り出す。scis <- ...で始まる一行を追加する。

app/Main.hs
...
body ist pd qfi dv gq cp img flt a (fromIntegral -> n) i =
	resultBffr @img pd dv w h \rb ->
	...

	withWindow w h \win -> Vk
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		when (not ps) (error "Presentation is not supported!") >>
		createSwpchSettings win sf pd \stts ->
		createSwpch sf dv stts \sc ->
		Vk.Smph.create @'Nothing dv def nil \ias ->
		Vk.Smph.create @'Nothing dv def nil \rfs -> do
		let	wi = smphInfo ias Vk.Ppl.Stage2ColorAttachmentOutputBit
			si = smphInfo rfs Vk.Ppl.Stage2AllGraphicsBit
		scis <- Vk.Swpch.getImages dv sc
		fix \act -> do
			draw gq cb wi si ppl pl ds w h imgd' flt a n ix iy
			GlfwG.waitEvents
			...

描画可能なイメージの問い合わせ

スワップチェーンから取り出した複数のイメージのなかで、「今、描画可能なイメージのインデックス」の問い合わせにはGpu.Vulkan.Khr.Swapchain.acquireNextImageを使う。

acquireNextImage :: Vk.Dvc.D sd -> Vk.Khr.Swpch.S scfmt ssc -> Maybe Vk.Sec ->
	Maybe (Vk.Smph.S ss) -> Maybe (Vk.Fnc.F sf) -> IO Word32

デバイスとスワップチェーンを指定し、省略可能なタイムアウトまでの時間、セマフォ、フェンスを指定する。現在描画可能なイメージのインデックスが取得できる。例題コードに追加する。

app/Main.hs
	...
	let	wi = smphInfo ias Vk.Ppl.Stage2ColorAttachmentOutputBit
		si = smphInfo rfs Vk.Ppl.Stage2AllGraphicsBit
	scis <- Vk.Swpch.getImages dv sc
	fix \act -> do
		ii <- Vk.Swpch.acquireNextImage
			dv sc Nothing (Just ias) Nothing
		draw gq cb wi si ppl pl ds w h imgd' flt a n ix iy
		...

結果のコピー

関数drawにスワップチェーンの持つ複数のイメージと描画可能なイメージのインデックスを渡す。関数bodyの中で関数drawを呼び出しているところで引数にscisとiiとを追加する。関数drawの型宣言に[Vk.Img.Binded sm si inm fmt] -> Word32 ->の1行を追加する。同じく関数定義の引数としてscisとiiを追加する。

app/Main.hs
...
body ist pd qfi dv gq cp img flt a (fromIntegral -> n) i =
	resultBffr @img pd dv w h \rb ->
	...

	withWindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.getSupport pd qfi sf >>= \ps ->
		...
		scis <- Vk.Swpch.getImages dv sc
		fix \act -> do
			ii <- Vk.Swpch.acquireNextImage
				dv sc Nothing (Just ias) Nothing
			draw gq cb wi si
				ppl pl ds w h imgd' scis ii flt a n ix iy
			GlfwG.waitEvents
			...
...

draw :: (
	Vk.Smph.SubmitInfoListToMiddle wss,
	Vk.Smph.SubmitInfoLIstToMiddle sss ) => Vk.Q.Q -> Vk.CBffr.C scb ->
	HPList.PL (U2 Vk.Smph.SubmitInfo) wss ->
	HPList.PL (U2 Vk.Smph.SubmitInfo) sss ->
	Vk.Ppl.Cp.C scp '(sl, '[ '(sdsl, '[SrcImg, DstImg])], PshCnsts) ->
	Vk.PplLyt.P sl '[ '(sdsl, '[SrcImg, DstImg])] PshCnsts ->
	Vk.DscSt.D sds '(sdsl, '[SrcImg, DstImg]) ->
	(forall n . Integral n -> n) -> (forall n . Integral n -> n) ->
	Vk.Img.Binded smd sid nmd fmtd ->
	[Vk.Img.Binded sm si inm fmt] -> Word32 ->
	Filter -> Float -> Word32 -> Word32 -> Word32 -> IO ()
draw gq cb wi si ppl pl ds w h im scis ii flt a n ix iy = runCmds gq cb wi si do
	tr cb im Vk.Img.LayoutUndefined Vk.Img.LayoutGeneral
	Vk.Cmd.bindPipelineCompute cb Vk.Ppl.BindPointCompute ppl \cbb -> do
		Vk.Cmd.bindDescriptorSetsCompute
			ccb pl (HPList.Singleton $ U2 ds) def
		...

拡大されたイメージをスワップチェーンから取り出した描画用のバッファにコピーする。その前後でバッファのレイアウトの変換もする。

  • バッファのレイアウトをGpu.Vulkan.Image.LayoutTransferDstOptimalに変換する
  • 拡大された画像をバッファにコピーする
  • バッファのレイアウトをGpu.Vulkan.Image.LayoutPresentSrcKhrに変換する

この流れを関数drawの最後に追加する。tr cb sci ...から始まる3行を追加し、where節にsciの定義を追加する。

app/Main.hs
...
draw gq cb wi si ppl pl ds w h im scis ii flt a n ix iy = runCmds gq cb wi si do
	tr cb im Vk.Img.LayoutUndefined Vk.Img.LayoutGeneral
	...
	tr cb im Vk.Img.LayoutGeneral Vk.Img.LayoutTransferSrcOptimal
	tr cb sci Vk.Img.LayoutUndefined Vk.Img.LayoutTransferDstOptimal
	copyImgToImg cb im sci w h 0 0
	tr cb sci Vk.Img.LayoutTransferDstOptimal Vk.Img.LayoutPresentSrcKhr
	where tr = transitionImgLyt; sci = scis !! fromIntegral ii

イメージの表示

関数Gpu.Vulkan.Khr.Swapchain.queuePresentでインデックスを指定して対応するバッファの内容をウィンドウに表示する。

Vk.Khr.Swpch.queuePresent ::
	Vk.Q.Q -> Vk.Khr.Swpch.PresentInfo mn swss fmt sscs -> IO ()

data Vk.Khr.Swpch.PresentInfo mn swss fmt sscs =
	Vk.Khr.Swpch.PresentInfo {
		presentInfoNext :: TMaybe.M mn,
		presentInfoWaitSemaphores :: HPList.PL Vk.Semaphore.S swss,
		presentInfoSwapchainImageIndices ::
			HPList.PL (Vk.Khr.Swpch.SwapchainImageIndex fmt) sscs }

関数Vk.Khr.Swpch.queuePresentはコマンドキューとVk.Khr.Swpch.PresentInfo型の値を引数として取る。Vk.Khr.Swpch.PresentInfo型の値で「表示の処理が待つセマフォ」「スワップチェーン」「表示するバッファのインデックス」を指定する。

関数bodyに関数drawの呼び出しの後にバッファの内容を表示する1行と処理の終了を待つためのVk.Q.waitIdle gqとを追加する。where節にpinfoの定義を追加する。

app/Main.hs
...
body ist pd qfi dv gq cp img flt a (fromIntegral -> n) i =
	resultBffr @img pd dv w h \rb ->
	...

	withWindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		...
		fix \act -> do
			ii <- Vk.Swpch.acquireNextImage
				dv sc Nothing (Just ias) Nothing
			draw gq cb wi si
				ppl pl ds w h imgd' scis ii flt a n ix iy
			Vk.Swpch.queuePresent @'Nothing gq $ pinfo sc ii rfs
			Vk.Q.waitIdle gq
			Glfw.WaitEvents
			...

	runCmds gq cb HPList.NIl HPList.Nil do
		tr cb imgd
			Vk.Img.LayoutUndefined Vk.Img.LayoutTransferDstOptimal
		...
	where
	trsd = Vk.Img.UsageTransferSrcBit .|. Vk.Img.UsageTransferDstBit
	...
	ix = fromIntegral i `mod` n
	iy = fromIntegral i `div` n
	pinfo sc ii drs = Vk.Swpch.PresentInfo {
		Vk.Swpch.presentInfoNext = TMaybe.N,
		Vk.Swpch.presentInfoWaitSemaphores = HPList.Singleton drs,
		Vk.Swpch.presentInfoSwapchainImageIndices = HPList.Singleton
			$ Vk.Swpch.SwapchainImageIndex sc ii }

ビルドして試してみる。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388

funenohito-cubic-screenshot.png

「ウィンドウに拡大した画像が表示された」と喜ぶのもつかのまで、「なんか色が薄くないか」と思う。これは実は初めのところで「まちがえ」があったという話だ。ImageMagickがインストールされている環境であれば次のように実行してみる。

% identify funenohito.png
funenohito.png PNG 799x1000 799x1000+0+0 8-bit sRGB 1.01278MiB 0.000u 0:00.000

これを見るとわかるが、この画像のカラースペースはsRGBだったということ。sRGB空間では光の強度に比例した値ではなく、暗い部分がより細かく区別されるような値として表現されている。初めの読み込みの例階でまちがったフォーマットを指定してしまったことで、「やけに色の薄い画像」が表示されてしまった。これを修正しよう。本当ならば画像から色空間を読み込んでそれに合わせたフォーマットを適用するべきだが、今回は簡単のため決め打ちとする。型ImageRgba8を型クラスGpu.Vulkan.Object.Base.IsImageのインスタンスにしているコードのtype ImageFormatの定義を修正する。

app/Main.hs
...

-- DATA TYPE IMAGE RGBA8

newtype ImageRgba8 = ImageRgba8 (Image PixelRGBA8)
newtype PixelRgba8 = PixelRgba8 PixelRGBA8 deriving Show

instance Vk.ObjB.IsImage ImageRgba8 where
	type ImagePixel ImageRgba8 = PixelRgba8
	type ImageFormat ImageRgba8 = 'Vk.T.FormatR8g8b8a8Srgb
	imageRow = Vk.ObjB.imageWidth
	...

ビルドして実行する。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388

funenohito-cubic-screenshot-srgb.png

色はだいたい良さそうだ。

キー入力によって表示を変化させる

ここまでで、ライブラリの説明としては完成しているが、ただ拡大した画像をウィンドウに表示するだけでは面白くない。ウィンドウに表示できるということは、インタラクティブに画像を変化させられるということだ。キー入力によってリアルタイムにいくつかのパラメーターを変化させられるようにしよう。

追加で導入するモジュール

追加で以下のパッケージを追加する。

  • stm
package.yaml
...

dependencies:
- base >= 4.7 && < 5
- stm
- array
...

追加で以下のモジュールを導入する。

  • Control.Concurrent.STM
  • Data.Bool
  • Graphics.UI.GlfwG.Key
app/Main.hs
...
import Control.Monad
import Control.Monad.Fix
import Control.Concurrent.STM
import Data.TypeLevel.Type.Uncurry
...
import Data.HeteroParList.Constrained (pattern (:^*))
import Data.Array
import Data.Bool
import Data.Bool.ToolsYj
import Data.Word
...

import Graphics.UI.GlfwG qualified as GlfwG
import Graphics.UI.GlfwG.Window qualified as GlfwG.Win
import Graphics.UI.GlfwG.Key qualified as GlfwG.K

import Paths_zenn_vulkan_bicubic_swapchain

---------------------------------------------------------------------------
--
-- * Data TYPE IMAGE RGBA8
...

キー入力を取得する

キーボードからの入力を取得する。ここではSTM(software transactional memory)の枠組で使えるチャンネルであるTChan型の値を利用する。

専用のデータ型の作成

使用するキーだけにしぼったデータ型と押下とリピートを表現するデータ型を定義する。目次にKEY EVENTSの項目を追加。データ型KとPRの定義を追加。

app/Main.hs
...

import Paths_zenn_vulkan_bicubic_swapchain

---------------------------------------------------------------------------
--
-- * DATA TYPE IMAGE RGBA8
-- * MAIN
-- * KEY EVENTS
-- * BUFFER AND IMAGE
...

...
draw gq cb wi si ppl pl ds w h im scis ii flt a n ix iy = runCmds gq cb wi si do
	tr cb im Vk.Img.LayoutUndefined Vk.Img.LayoutGeneral
	...
	tr cb sci Vk.Img.LayoutTransferDstOptimal Vk.Img.LayoutPresentSrcKhr
	where tr = transitionImgLyt; sci = scis !! fromIntegral ii

-- KEY EVENTS

data K = Q | N | Semicolon | H | J | K | L | U | I | M | Comma | D | F
	deriving Show

data PR = Pr | Rp deriving Show

-- BUFFER AND IMAGE

...

GLFWのキー入力を取得する関数から得られる値から、ここで定義した値への変換関数を定義する。関数keyToKとkeyStateToPRを定義する。

app/Main.hs
...

-- KEY EVENTS

data K = Q | N | Semicolon | H | J | K | L | U | I | M | Comma | D | F
	deriving Show

keyToK :: GlfwG.K.Key -> Maybe K
keyToK = \case
	GlfwG.K.Key'Q -> Just Q
	GlfwG.K.Key'N -> Just N; GlfwG.K.Key'Semicolon -> Just Semicolon
	GlfwG.K.Key'H -> Just H; GlfwG.K.Key'J -> Just J
	GlfwG.K.Key'K -> Just K; GlfwG.K.Key'L -> Just L
	GlfwG.K.Key'U -> Just U; GlfwG.K.Key'I -> Just I
	GlfwG.K.Key'M -> Just M; GlfwG.K.Key'Comma -> Just Comma
	GlfwG.K.Key'D -> Just D; GlfwG.K.Key'F -> Just F; _ -> Nothing

data PR = Pr | Rp deriving Show

keyStateToPR :: GlfwG.K.KeyState -> Maybe PR
keyStateToPR = \case
	GlfwG.K.KeyState'Pressed -> Just Pr
	GlfwG.K.KeyState'Repeating -> Just Rp; _ -> Nothing

-- BUFFER AND IMAGE

...

どちらも、それぞれの値について対応するものを返しているだけだ。対応する値がないものについてはNothingを返す。

キー入力を取得する

キーボードの入力を取得するには関数GlfwG.Win.setKeyCallbackを使う。

GlfwG.Win.setKeyCallback ::
	GlfwG.Win.W s -> Maybe (GlfwG.Win.KeyCallback s) -> IO ()

type GlfwG.Win.KeyCallback s =
	GlfwG.Win.W s ->
	GlfwG.K.Key -> Int -> GlfwG.K.KeyState -> GlfwG.K.ModifierKeys -> IO ()

関数GlfwG.Win.setKeyCallbackに、「入力されたキーの種類などの情報を処理する関数」をセットする形でキー入力を取得する。そのようなコールバック関数kCllbckを定義して使ってみよう。関数bodyの定義の中にコールバック関数を指定する処理を追加する。このコールバック関数は入力されたキーをチャンネルに押し込むという処理をする。チャンネルからの取り出しには関数tryReadTChanを使う。

関数bodyのscis <- ...で始まる行の前に「チャンネルckyの作成」と「GlfwG.Win.setKeyCallbackによるコールバック関数の指定」のそれぞれの処理を行う2行を追加する。チャンネルから取り出した値を表示する処理である2行をcase文の前に追加する。また、関数kCllbckの定義を追加する。

app/Main.hs
...
body ist pd qfi dv gq cp img flt a (fromIntegral -> n) i =
	resultBffr @img pd dv w h \rb ->
	...

	withWindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		...
		let	wi = smphInfo ias Vk.Ppl.Stage2ColorAttachmentOutputBit
			si = smphInfo rfs Vk.Ppl.Stage2AllGraphicsBit
		cky <- atomically newTChan
		GlfwG.Win.setKeyCallback win . Just $ kCllbck cky
		scis <- Vk.Swpch.getImages dv sc
		fix \act -> do
			ii <- Vk.Swpch.acquireNextImage
				dv sc Nothing (Just ias) Nothing
			draw gq cb wi si
				ppl pl ds w h imgd' scis ii flt a n ix iy
			Vk.Swpch.queuePresent @'Nothing gq $ pinfo sc ii rfs
			Vk.Q.waitIdle gq
			GlfwG.waitEvents
			wsc <- GlfwG.Win.shouldClose win
			mk <- atomically $ tryReadTChan cky
			maybe (pure ()) print mk
			case wsc of
				True -> pure ()
				_ -> act

	...
...


-- KEY EVENTS

kCllbck :: TChan (K, PR) -> GlfwG.Win.KeyCallback sw
kCllbck cky _ ky _ ks _ = atomically case (keyToK ky, keyStateToPR ks) of
	(Just k, Just pr) -> writeTChan cky (k, pr); _ -> pure ()

data K = Q | N | Semicolon | H | J | K | L | U | I | M | Comma | D | F
	deriving Show

keyToK :: GlfwG.K.Key -> Maybe K
...

ビルドして試してみる。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388
(適当にキーを入力してみる)
(J,Pr)
(K,Pr)
(L,Pr)
(J,Pr)
(J.Rp)
(J.Rp)
(J.Rp)
(J.Rp)

変数名を付け替える

キー入力によって値を変化させていくので、ループのなかで変化していく値を示す変数と、その初期値としての変数の名前を分ける必要がある。その準備として初期値の名前を付け替えておく。関数draw内の変数名を次のように付け替える。

  • flt -> f0
  • a -> a0
  • n -> n0
  • ix -> x0
  • iy -> y0

関数bodyの引数とwhere節と関数drawの呼び出しのときの引数とを修正する。

app/Main.hs
...

body :: forall si sd sc img . Vk.ObjB.IsImage img =>
	Vk.Ist.I si -> Vk.Phd.P -> Vk.QFam.Index -> Vk.Dvc.D sd -> Vk.Q.Q ->
	Vk.CmdPl.C sc -> Img -> Filter -> Float -> Int32 -> Int32 -> IO img
body ist pd qfi dv gq cp img f0 a0 (fromIntegral -> n0) i =
	resultBffr @img pd dv w h \rb ->
	...

	withwindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		...
		scis <- Vk.Swpch.getImages dv sc
		fix \act -> do
			ii <- Vk.Swpch.acquireNextImage
				dv sc Nothing (Just ias) Nothing
			draw gq cb wi si
				ppl pl ds w h imgd' scis ii f0 a0 n0 x0 y0
			Vk.Swpch.queuePresent @'Nothing gq $ pinfo sc ii rfs
			...

	runCmds gq cb HPList.Nil HPList.Nil do
		tr cb imgd
			Vk.Img.LayoutUndefined Vk.Img.LayoutTransferDstOptimal
		...
	where
	trsd = Vk.Img.UsageTransferSrcBit .|. Vk.Img.UsageTransferDstBit
	...
	tr = transitionImgLyt
	x0, y0 :: Word32
	x0 = fromIntegral i `mod` n0
	y0 = fromIntegral i `div` n0
	pinfo sc ii drs = Vk.Swpch.PresentInfo {
		Vk.Swpch.presentInfoNext = TMaybe.N,
		...
	...

ループごとに変化させる値

ループごとに変化させる値を関数fixの引数として追加する。また、それに初期値をあたえる。関数bodyの関数fixの行と関数actを呼び出す行とを修正する。関数drawの呼び出しのところの引数を修正する。また補助関数として関数unc5を定義する。

app/Main.hs
...
body ist pd qfi dv gq cp img f0 a0 (fromIntegral -> n0) i =
	resultBffr @img pd dv w h \rb ->
	...

	withWindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		...
		scis <- Vk.Swpch.getImages dv sc
		($ (f0, a0, n0, x0, y0)) . unc5 $ fix \act f a n ix iy -> do
			ii <- Vk.Swp[ch.acquireNextImage
				dv sc Nothing (Just ias) Nothing
			draw gq cb wi si ppl pl ds w h imgd' scis ii f a n ix iy
			Vk.Swpch.queuePresent @'Nothing gq $ pinfo sc ii rfs
			...
			maybe (pure ()) print mk
			case wsc of
				True -> pure ()
				_ -> act f a n ix iy

	runCmds gq cb HPList.Nil HPList.Nil do
		tr cb imgd
			Vk.Img.LayoutUndefined Vk.Img.LayoutTransferDstOptimal
		...

...

-- TOOLS

unc5 :: (a -> b -> c -> d -> e -> r) -> (a, b, c, d, e) -> r
unc5 f (x, y, z, w, v) = f x y z w v

div' :: Integral n => n -> n -> n
x `div'` y = case x `divMod` y of (d, 0) -> d; (d, _) -> d + 1

ビルドを試す。

stack build

キー入力による値の変化を定義

キーボードからの入力によって、それぞれの値がどう変化するかを表す関数procKeyを定義する。補助関数sub'も定義する。

app/Main.hs
...
keyStateToPR = \case
	GlfwG.K.KeyState'Pressed -> Just Pr
	GlfwG.K.KeyState'Repeating -> Just Rp; _ -> Nothing

procKey :: Word32 -> Word32 -> Filter -> Float -> Word32 -> Word32 -> Word32 ->
	K -> PR -> Maybe (Filter, Float, Word32, Word32, Word32)
procKey _ _ _ _ _ _ _ Q _ = Nothing
procKey _ _ _ a n ix iy N _ = Just (Nearest, a, n, ix, iy)
procKey _ _ _ a n ix iy Semicolon _ = Just (Linear, a, n, ix, iy)
procKey _ _ _ _ n ix iy M _ = Just (Cubic, - 0.75, n, ix, iy)
procKey _ _ _ _ n ix iy Comma _ = Just (Cubic, - 0.5, n, ix, iy)
procKey _ _ _ (clamp (- 1) (- 0.25) . subtract 0.01 -> a') n ix iy U Pr =
	Just (Cubic, a', n, ix, iy)
procKey _ _ _ a@(clamp (- 1) (- 0.25) . subtract 0.01 -> a') n ix iy U Rp =
	Just (Cubic, bool a' (- 0.75) (a' < - 0.75 && - 0.75 <= a), n, ix, iy)
procKey _ _ _ (clamp (- 1) (- 0.25) . (+ 0.01) -> a') n ix iy I Pr =
	Just (Cubic, a', n, ix, iy)
procKey _ _ _ a@(clamp (- 1) (- 0.25) . (+ 0.01) -> a') n ix iy I Rp =
	Just (Cubic, bool a' (- 0.5) (a <= - 0.5 && - 0.5 < a'), n, ix, iy)
procKey _ _ f a n ix iy H _ = Just (f, a, n, ix `sub'` 1, iy)
procKey _ _ f a n ix iy J _ = Just (f, a, n, ix, clamp 0 (n - 1) $ iy + 1)
procKey _ _ f a n ix iy K _ = Just (f, a, n, ix, iy `sub'` 1)
procKey _ _ f a n ix iy L _ = Just (f, a, n, clamp 0 (n - 1) $ ix + 1, iy)
procKey w h f a (clamp 1 (max w h) . (`sub'` 1) -> n) ix iy D _ =
	Just (f, a, n, clamp 0 (n - 1) ix, clamp 0 (n - 1) iy)
procKey w h f a (clamp 1 (max w h) . (+ 1) -> n) ix iy F _ =
	Just (f, a, n, ix, iy)

-- BUFFER AND IMAGE

...

-- TOOLS

unc5 :: (a -> b -> c -> d -> e -> r) -> (a, b, c, d, e) -> r
unc5 f (x, y, z, w, v) = f x y z w v

sub' :: (Ord n, Num n) => n -> n -> n
x `sub'` y | x >= y = x - y | otherwise = 0

div' :: Integral n => n -> n -> n
x `div'` y = case x `divMod` y of (d, 0) -> d; (d, _) -> d + 1

それぞれのキーに対する処理は次のようになる。

  • Q: ループを終了する。終了はNothingで表す
  • N: フィルターをNearest、つまり最近傍補間にする
  • Semicolon: フィルターをLinear、つまり双線形補間にする
  • M: フィルターをCubic、つまり双三次補間とし、パラメーターaを- 0.75にする
  • Cooma: フィルターをCubicにし、パラメーター'a'を- 0.5にする
  • U: フィルターをCubicにし、パラメーターaを0.01だけ減らす
    • 関数clampで値が- 1.0未満にならないようにしている
    • キーの押下を続けると減算を続けるが- 0.75で一度止まるようにしてある
  • I: フィルターをCubicにし、パラメーターaを0.01だけ増やす
    • 関数clampで値が- 0.25を超えないようにしている
    • キーの押下を続けると加算を続けるが- 0.5で一度止まるようにしてある
  • H: 拡大する場所を1マス左に移動する
  • J: 拡大する場所を1マス下に移動する
  • K: 拡大する場所を1マス上に移動する
  • L: 拡大する場所を1マス右に移動する
  • D: 分割の数を減らす。つまり縮小する
  • F: 分割の数を増やす。つまり拡大する

関数bodyの中の関数fixによるループの「次」の呼び出しのための引数を関数procKeyで処理する。case式を修正する。

app/Main.hs
		...
		mk <- atomically $ tryReadTChan cky
		maybe (pure ()) print mk
		case (wsc, uncurry (procKey w h f a n ix iy) <$> mk) of
			(True, _) -> pure ()
			(_, Nothing) -> act f a n ix iy
			(_, Just Nothing) -> pure ()
			(_, Just (Just args)) -> unc5 act args

	runCmds gq cb HPList.Nil HPList.Nil do
		tr cb imgd
			Vk.Img.LayoutUndefined Vk.Img.LayoutTransferDstOptimal
		...

ビルドして試してみる。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388

次のようにキーを押してみよう。

hjkln;m,ffddq

双三次補間の変数aをバーで表示

双三次補間の変数aの値を標準出力にバーの形で表示する。

関数bodyの中のcase式を修正する。関数barStringを定義する。また、where節にこれを利用した関数barを定義し、変数aの値が変化したときに表示するようにする。maybe (pure ()) print mkは削除する。

app/Main.hs
...
body ist pd qfi dv gq cp img f0 a0 (fromIntegral -> n0) i =
	resultBffr @img pd dv w h \rb ->
	...

	withWindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		...
		($ (f0, a0, n0, x0, y0)) . unc5 $ fix \act f a n ix iy -> do
			ii <- Vk.Swpch.acquireNextImage
				dv sc Nothing (Just ias) Nothing
			...
			wsc <- GlfwG.Win.shouldClose win
			mk <- atomically $ tryReadTChan cky
			case (wsc, uncurry (procKey w h f a n ix iy) <$> mk) of
				(True, _) -> pure ()
				(_, Nothing) -> act f a n ix iy
				(_, Just Nothing) -> pure ()
				(_, Just (Just args@(_, a', _, _, _))) ->
					when (a /= a') (bar a') >> unc5 act args

	runCmds gq cb HPList.Nil HPList.Nil do
		tr cb imgd
			Vk.Img..LayoutUndefined Vk.Img.LayoutTransferDstOptimal
		...
	where
	trsd = Vk.Img.UsageTransferSrcBit .|. Vk.Img.UsageTransferDstBit
	...
	pinfo sc ii drs = Vk.Swpch.PresentInfo {
		Vk.Swpch.presentInfoNext = TMaybe.N,
		...
	bar a' = do putStrLn ""; putStrLn $ barString a'; print a'

resultBffr :: Vk.ObjB.IsImage img =>
	Vk.Phd.P -> Vk.Dvc.D sd -> Vk.Dvc.Size -> Vk.Dvc.Size -> (forall sm sb .
	...

...
draw gq cb wi si ppl pl ds w  h im scis ii flt a n ix iy = runCmds gq cb wi si do
	tr cb im Vk.Img.LayoutUndefined Vk.Img.LayoutGeneral
	...
	where tr = transitionImgLyt; sci = scis !! fromIntegral ii

barString :: Float -> String
barString a = "-1 " ++ take x ('|' : repeat '*') ++ "*" ++
	replicate y ' ' ++ "| 0\n" ++
	"   |" ++ replicate z ' ' ++ "|" ++ replicate w ' ' ++ "|" ++
	replicate v ' ' ++ "|"
	where
	ln :: Num n => n; ln = 70
	x = tr a; y = ln - x
	z = tr (- 0.75) - 1; w = tr (- 0.5) - z - 2; v = tr (- 0.25) - w - z - 3
	tr = round . (ln +) . (ln *)

-- KEY EVENTS

...

細かい話だけど最後に分割数と位置を示す値を表示すると便利だ。関数bodyの中のcase式とwhere節を修正する。

app/Main.hs
	...

	withWindow w h \win -> Vk.Sfc.Glfw.Win.create ist win nil \sf ->
		Vk.Sfc.Phd.getSupport pd qfi sf >>= \ps ->
		...
		($ (f0, a0, n0, x0, y0)) . unc5 $ fix \act f a n ix iy -> do
			ii <- Vk.Swpch.acquireNextImage
				dv sc Nothing (Just ias) Nothing
			...
			case (wsc, uncurry (procKey w h f a n ix iy) <$> mk) of
				(True, _) -> end n ix iy
				(_, Nothing) -> act f a n ix iy
				(_, Just Nothing) -> end n ix iy
				(_, Just (Just args@(_, a', _, _, _))) ->
					when (a /= a') (bar a') >> unc5 act args

	runCmds gq cb HPList.Nil HPList.Nil do
		tr cb imgd
			Vk.Img.LayoutUndefined Vk.Img.LayoutTransferDstOptimal
		...
	where
	trsd = Vk.Img.UsageTransferSrcBit .|. Vk.Img.UsageTransferDstBit
	...
	bar a' = do putStrLn ""; putStrLn (barString a'); print a'
	end n ix iy = print (n, n * iy + ix)

resultBffr :: Vk.ObjB.IsImage img =>
...

ビルドして試してみよう。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-cubic.png cubic -0.5 25 388

hjklで上下左右に移動して、fdで拡大率を変える。n;で最近傍補間や双線形補間に切り替える。m,で双三次補間のそれぞれパラメーターaを-0.75, -0.5にしたものに切り替える。uiでパラメーター`a'をより細かく変えていくことができる。

シェーダーのバグを修正する

いろいろといじっていたらシェーダーのバグがあった。環境によって出る場合と出ない場合とがある。次のパラメーターで立ち上げてみよう。

% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-nearest.png nearest -0.5 218 0

funenohito-bug.png

元画像には存在しない1pxの白い線が入ってしまっている。これは浮動小数点数の計算で僕の環境では

vec4 c = vec4(0.0);
float v = 41;
if (v / 82 < 0.5 && 1 - v / 82 <= 0.5) c = vec4(0, 0, 1, 1);

としたときにc == vec4(0, 0, 1, 1)になる。つまり値によってはx < 0.5 && 1 - x <= 0.5が成り立ってしまう。これは計算すると1 < 1ということになる。浮動小数点数の罠だ。シェーダーの最近傍補間のコードで1 - dが0.5以下かどうかをチェックしている部分について、dが0.5以上であることを確認するロジックに変えればいい。

関数formula_n_を修正する。関数coefficientsのswitch文のNearestにマッチした部分を修正する。

shader/interpolate.comp
...

float
formula_n(float x)
{
	if (x < 0.5) return 1; else return 0;
}

float
formula_n_(float x)
{
	if (x >= 0.5) return 1; else return 0;
}

float
formula_l (float x)
{
	return 1 - x;
}

float[4]
coefficients(float x)
{
	float co[4];
	float d = fract(x);
	switch (p.fltr) {
		case Nearest:
			co[0] = 0; co[3] = 0;
			co[1] = formula_n(d); co[2] = formula_n_(d);
			break;
		case Linear:
		...

ビルドして試してみよう。白い線はなくなったはずだ。

% stack build
% stack exec -- zenn-vulkan-bicubic-swapchain-exe funenohito.png funenohito-nearest.png nearest -0.5 218 0

まとめ

コンピュートシェーダーで計算した結果の画像をウィンドウに表示してみた。ウィンドウに表示できると対話的にいろいろできるから楽しい。「画像の一部を拡大する」というネタでずいぶんと引っぱってきたけれど、正直あんまり面白くはないかもしれない。次回は比較的計算は簡単なわりに、見た目に派手で面白いものの代表である「マンデルブロー集合」を表示してみよう。マウスの操作で好きな場所を拡大、縮小できるようなインターフェースにしたいと思っている。

Discussion