HaskellからGPUを使う - 拡大した画像をウィンドウに表示する
はじめに
この記事は以下の記事の続編だ。
ここまでやってきた「画像を拡大する」話の集大成になる。今回は拡大した画像をウィンドウに表示する。表示するだけでは面白くないのでキー入力によって
- 拡大率
- 拡大する場所
- 3種の補間方法
- 双三次補間のパラメーター
を変化させることができるようにする。この記事は次の3つの部分に分けられる。
- ウィンドウを作成する
- ウィンドウに画像を表示する
- キー入力によって表示を変化させる
2番目の部分が今回の本題になる。
今回最終的に完成するソースコードは以下から入手できる。
例題の仕様
- 前回までと同様コマンドライン引数で入出力用の画像ファイルとパラメーターを指定する
- パラメーターは、これが初期値になる
- プログラム終了時のパラメーターで画像をファイルに保存する
- キー入力毎に画像をウィンドウに表示する
- それぞれのキーに次のような機能を割り当てる
- '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を使う。
GLFWのインストールについては、ここでは詳述しない。Windowsユーザーならばpacmanで次のようにインストールすれば良い。
$ pacman -S mingw-w64-x86_64-glfw
前回からの続きのコードを使用する場合
最新のパッケージを使うようにする。
...
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
を追加する。
...
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
を追加する。
...
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
を追加する。
...
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
ファイルとシェーダーをコピーする。
% 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_...
をプロジェクト名に応じて適切な名前に修正する。
...
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
...
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
を定義する。
...
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が指定されていないコマンドプールから作られたコマンドバッファーが暗黙にリセットされてるよ」ということ。コマンドバッファーを複数回使うにはリセットが必要なのだけど、コマンドプールにコマンドバッファーをリセットする機能が指定されていないために警告が表示された。コマンドプールを作成するときのパラメーターに適切な値をセットすればいい。
...
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
の先頭にこの関数を追加する。
...
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
を定義する。
...
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
になっているので注意する。
...
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
...
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
...
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
を追加する。
...
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行も追加する。
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]
を指定する。
...
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行を追加する。
...
-- * 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
を定義する。
...
-- 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
で物理装置とサーフェスからサーフェスの能力を問い合わせることができる。結果は次のような構造体に格納される。
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
を定義する。
...
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
とを定義する。
...
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
型の値を組み立てる関数を定義する。
...
-- 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
を定義する。
...
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行を追加する。
...
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
を定義する。
...
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
で置き換える。
...
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 <- ...
で始まる一行を追加する。
...
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
デバイスとスワップチェーンを指定し、省略可能なタイムアウトまでの時間、セマフォ、フェンスを指定する。現在描画可能なイメージのインデックスが取得できる。例題コードに追加する。
...
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
を追加する。
...
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
の定義を追加する。
...
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
の定義を追加する。
...
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
「ウィンドウに拡大した画像が表示された」と喜ぶのもつかのまで、「なんか色が薄くないか」と思う。これは実は初めのところで「まちがえ」があったという話だ。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
の定義を修正する。
...
-- 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
色はだいたい良さそうだ。
キー入力によって表示を変化させる
ここまでで、ライブラリの説明としては完成しているが、ただ拡大した画像をウィンドウに表示するだけでは面白くない。ウィンドウに表示できるということは、インタラクティブに画像を変化させられるということだ。キー入力によってリアルタイムにいくつかのパラメーターを変化させられるようにしよう。
追加で導入するモジュール
追加で以下のパッケージを追加する。
- stm
...
dependencies:
- base >= 4.7 && < 5
- stm
- array
...
追加で以下のモジュールを導入する。
Control.Concurrent.STM
Data.Bool
Graphics.UI.GlfwG.Key
...
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
の定義を追加。
...
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
を定義する。
...
-- 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
の定義を追加する。
...
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
の呼び出しのときの引数とを修正する。
...
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
を定義する。
...
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'
も定義する。
...
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
式を修正する。
...
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
は削除する。
...
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
節を修正する。
...
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
元画像には存在しない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
にマッチした部分を修正する。
...
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