not-glossでお手軽3Dグラフィック描画


こんにちは、趣味でHaskellを勉強している者です。

#はじめに
Haskellで超絶手軽にグラフィック描画ができる[gloss](http://hackage.haskell.org/package/gloss)、いいですよね。
glossについては、超絶わかりやく解説されている記事があるので、そちらを！[glossではじめるグラフィック描画 :: Haskell入門の次に読む記事](https://qiita.com/lotz/items/eb73e62a64bc208c2dd6)
glossは超絶使いやすい神ライブラリなのですが、二次元波動方程式のシミュレーションをしようとして、僕はふと思ってしまったんです。
「glossじゃ3D描画無理くない?」
それで、Hackageで色々探していると[not-gloss](http://hackage.haskell.org/package/not-gloss)というパッケージがありまして...
このnot-gloss、glossをそのまま3D描画に対応させたって感じで使いやすかったんですよね。中身はgolssとほぼ同じ使い方ができるOpenGLのラッパーです。
そして、なぜか日本語で解説されてる記事がなかったので、頑張って書きました。

#not-glossをインストールしよう
適当にプロジェクトを作って、次のコマンドを打つだけです。

```
$ stack install not-gloss
$ stack build
```
ちょっと時間がかかるかもしれません、辛抱しましょう。
終わったら、`package.yaml`に依存関係として`not-gloss`と`linear`を追加しておきましょう。`linear`は三次元座標を扱うのに用います。
こんな感じです。

```
dependencies:
- base >= 4.7 && < 5
- not-gloss
- linear
```

#立方体を表示する
せっかくなので、何か表示しましょう。Main.hsで次のように記述して、

```haskell
module Main where

import Vis
import Linear.V3

main :: IO ()
main = display defaultOpts (Cube 0.5 Solid blue)
```
`stack run`するだけでOK

![Screenshot from 2020-01-19 23-28-51.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/489648/338e8f69-b9e7-1f58-48e6-e62950938c36.png)
いい感じに立方体君が表示されましたね。めでたしめでたし。

#not-glossの基本
not-glossには`display`,`animate`,`simulate`,`play`という描画の目的別に関数が用意されています。ここでは、これらの関数の簡単な使い方をご紹介します。

##display
`display`関数は、動かないオブジェクトを描画するだけの単純明快な関数です。

```haskell
display :: Real b 
        => Options     -- ^ 設定
        -> VisObject b -- ^ オブジェクト
        -> IO ()
```
glossと違うポイントは、`Options`型にウィンドウサイズや背景色、初期カメラ位置などの情報が格納されている点です。`Real b => VisObject b`は、描画されるオブジェクトのことであり、立方体や球、3Dテキストなど色々ありますが、後述します。
`Options`型には、`defaultOpts`というデフォルト設定があらかじめ用意されています。`Options`型はレコードになっているので、次のようにすることで部分的に変更することができます。

```haskell
main :: IO ()
main = display myOpts (Cube 0.5 Solid blue)

myOpts = defaultOpts { optBackgroundColor = Just white }
```
このように、部分的に`optBackgroundColor`の値を変更することで、背景の色を変えることができます！

![Screenshot from 2020-01-19 23-45-03.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/489648/286610e9-2cc3-f294-dd8d-065b3b078515.png)
こんな感じ。真っ白だぜ。

`Options`と`VisObject`については記事後半を参照してください！

##animate
`animate`関数はオブジェクトの時間変化によるシンプルな描画を行う関数です。

```haskell
animate :: Real b
        => Options                -- ^ オプション
        -> (Float -> VisObject b) -- ^ 時刻を受け取って、オブジェクトを生成する関数
        -> IO ()
```

試しに、立方体をどんどん大きくする描画をしてみましょう。

```haskell
main :: IO ()
main = animate defaultOpts (\t -> Cube t Solid white)
```

`animate`の第二引数に時刻tを受け取って`VisObject`を返す関数を渡してあげます。これを実行すると、次のようになります。![simplescreenrecorder-2020-01-26_15.02.47.gif](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/489648/67b10c1e-854d-d500-5671-f7c6ec4c1158.gif)

簡単に3Dアニメーションの描画ができます。

##simulate
`simulate`関数は`初期状態`、`状態を引数にしてオブジェクトを描画する関数`、`状態を更新する関数`から状態の時間発展を描画する関数です。ここで登場する`状態`は既存の型でもいいですし、自作の代数的データ型でもなんでもOKです。

```haskell
simulate :: Real b
         => Options
         -> Double                    -- ^ サンプルレート
         -> world                     -- ^ 初期状態
         -> (world -> VisObject b)    -- ^ 状態を描画する関数
         -> (Float -> world -> world) -- ^ 前ステップからの経過時間、前の状態から次の状態を作る関数
         -> IO ()
```

シミュレーションの例としてN体運動もどきを作ってみます。
状態を、質量・位置・速度を持つデータ型の集まりとします。

```haskell
import qualified Data.Vector as V

data Body = Body 
    {
        position :: V3 Float -- 位置
    ,   velocity :: V3 Float -- 速度
    } deriving Show

type Bodies = V.Vector Body -- データ型の集まり
```

ここで、初期状態を用意しておきましょう。

```haskell
initBodies :: Bodies
initBodies = V.fromList
    [
        Body (V3 (-1) 0 0) (V3 0 0 0)
    ,   Body (V3    0 0 1) (V3 0 0 0)
    ,   Body (V3    0 0 0) (V3 0 0 0)
    ,   Body (V3    0 1 0) (V3 0 0 0)
    ]
```

次に、この状態を描画する関数を作ります。

```haskell
drawBodies :: Bodies -> VisObject Float
drawBodies bodies =
    let
        drawBody body = Trans (position body) $ Sphere 0.1 Solid white
    in
        VisObjects $ V.toList $ V.map drawBody bodies
```
ここで、`Trans`は`Linear.V3`型の位置とオブジェクトを引数に、オブジェクトをその位置に移動させる関数です。glossの`translate`と同じです。
位置を参照してその場所に球体を表示させているだけです！

そして、最後に状態を更新する関数を用意。

```haskell
nextBodies :: Float -> Bodies -> Bodies
nextBodies dt bodies = (`V.imap` bodies) $ \i _ ->
    let
        _G = 6.67408E-11            -- 万有引力定数
        ε = 0.15                    -- ソフトニングパラメータ
        scalar x = V3 x x x         -- スカラー値をベクトルにする関数

        xᵢ = position (bodies V.! i) -- i番目の質点の位置
        vᵢ = velocity (bodies V.! i) -- i番目の質点の速度

        exceptme = V.ifilter (\j _ -> j /= i) bodies

        vᵢ' = vᵢ + scalar (dt * _G) * V.sum ( V.map (\body -> (position body - xᵢ) / scalar ( (norm (position body - xᵢ)^2 + ε^2)**1.5 ) ) $ exceptme )
        xᵢ' = xᵢ + scalar dt * vᵢ'
    in
        Body mᵢ xᵢ' vᵢ'
```

あとはできあがったパーツをはめるだけ。

```haskell
main :: IO ()
main = simulate defaultOpts (1/60) initBodies drawBodies nextBodies
```

実行結果はこんな感じ
![simplescreenrecorder-2020-01-27_18.46.18.gif](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/489648/dd2f8e25-8285-3422-43cf-5777b3ecad4a.gif)


`simulate`関数を使えば手軽に3次元シミュレーションができます。

##play
キーボードやマウスによって発生するイベントで描画をコントロールできる関数です。

```haskell
play :: Real b	 
     => Options                                                            -- ^ オプション
     -> Double	                                                           -- ^ サンプル時間
     -> world                                                              -- ^ 初期状態
     -> (world -> (VisObject b, Maybe Cursor))	                           -- ^ 状態の描画
     -> (Float -> world -> world)                                          -- ^ 状態の更新
     -> (world -> IO ())	                                           -- ^ カメラのセット
     -> Maybe (world -> Key -> KeyState -> Modifiers -> Position -> world) -- ^ キーボード/マウスのボタンのコールバック
     -> Maybe (world -> Position -> world)                                 -- ^ マウスドラッグのコールバック
     -> Maybe (world -> Position -> world)                                 -- ^ マウスを動かしたときのコールバック
     -> IO ()
```
not-gloss開発者のexampleを載せておきます。
<details><div>

```haskell
{-# OPTIONS_GHC -Wall #-}

module Main ( main
            ) where

import Linear ( V3(..), (*^) )
import qualified Data.Set as Set
import Graphics.X11 ( initThreads )
import Graphics.UI.GLUT ( Cursor(..), Key(..), KeyState(..), Modifiers(..), Position(..)
                        , Size(..), Vector3(..), Vertex3(..)
                        , GLint
                        , ($=)
                        )
import qualified Graphics.UI.GLUT as GLUT

import SpatialMath ( Euler(..), rotateXyzAboutZ, rotVecByEulerB2A )
import Vis

import Control.Monad ( when )

ts :: Double
ts = 0.01

faceHeight :: Double
faceHeight = 1.5

data PlayerState = Running (V3 Double) (V3 Double) (Euler Double)

data GameState = GameState { playerState :: PlayerState
                           , keySet :: Set.Set Key
                           , lastMousePos :: Maybe (GLint,GLint)
                           }

toVertex :: (Real a, Fractional b) => V3 a -> Vertex3 b
toVertex xyz = (\(V3 x y z) -> Vertex3 x y z) $ fmap realToFrac xyz

setCamera :: PlayerState -> IO ()
setCamera (Running (V3 x y z) _ euler) =
  GLUT.lookAt (toVertex xyz0) (toVertex target) (Vector3 0 0 (-1))
  where
    xyz0 = V3 x y (z-faceHeight)
    target = xyz0 + rotVecByEulerB2A euler (V3 1 0 0)

simfun :: Float -> GameState -> IO GameState
simfun _ (GameState (Running pos _ euler0@(Euler yaw _ _)) keys lmp) = do
  Size x y <- GLUT.get GLUT.windowSize
  let x' = (fromIntegral x) `div` 2
      y' = (fromIntegral y) `div` 2

  when (Just (x',y') /= lmp) (GLUT.pointerPosition $= (Position x' y'))
  return $ GameState (Running (pos + (ts *^ v)) v euler0) keys (Just (x',y'))
  where
    v = rotateXyzAboutZ (V3 (w-s) (d-a) 0) yaw
      where
        w = if Set.member (Char 'w') keys then 3 else 0
        a = if Set.member (Char 'a') keys then 3 else 0
        s = if Set.member (Char 's') keys then 3 else 0
        d = if Set.member (Char 'd') keys then 3 else 0

keyMouseCallback :: GameState -> Key -> KeyState -> Modifiers -> Position -> GameState
keyMouseCallback state0 key keystate _ _
  | keystate == Down = state0 {keySet = Set.insert key (keySet state0)}
  | keystate == Up   = state0 {keySet = Set.delete key (keySet state0)}
  | otherwise        = state0

motionCallback :: Bool -> GameState -> Position -> GameState
motionCallback _ state0@(GameState (Running pos v (Euler yaw0 pitch0 _)) _ lmp) (Position x y) =
  state0 {playerState = newPlayerState, lastMousePos = Just (x,y)}
  where
    (x0,y0) = case lmp of Nothing -> (x,y)
                          Just (x0',y0') -> (x0',y0')
    newPlayerState = Running pos v (Euler yaw pitch 0)
    dx = 0.002*realToFrac (x - x0)
    dy = 0.002*realToFrac (y - y0)
    yaw = yaw0 + dx
    pitch = bound (-89) 89 (pitch0 - dy)
    bound min' max' val
      | val < min' = min'
      | val > max' = max'
      | otherwise  = val
    

drawfun :: GameState -> VisObject Double
drawfun (GameState (Running _ _ _) _ _) =
  VisObjects $ [axes,box,ellipsoid,sphere] ++ (map text [-5..5]) ++ [boxText, plane] 
  where
    x' = -1
    axes = Axes (0.5, 15)
    sphere = Trans (V3 0 x' (-1)) $ Sphere 0.15 Wireframe (makeColor 0.2 0.3 0.8 1)
    ellipsoid = Trans (V3 x' 0 (-1)) $ Ellipsoid (0.2, 0.3, 0.4) Solid (makeColor 1 0.3 0.5 1)
    box = Trans (V3 0 0 x') $ Box (0.2, 0.2, 0.2) Wireframe (makeColor 0 1 1 1)
    plane = Plane (V3 0 0 1) (makeColor 1 1 1 1) (makeColor 0.4 0.6 0.65 0.4)
    text k = Text2d "OLOLOLOLOLO" (100,500 - k*100*x') TimesRoman24 (makeColor 0 (0.5 + x''/2) (0.5 - x''/2) 1)
      where
        x'' = realToFrac $ (x' + 1)/0.4*k/5
    boxText = Text3d "trololololo" (V3 0 0 (x'-0.2)) TimesRoman24 (makeColor 1 0 0 1)

main :: IO ()
main = do
  let state0 = GameState (Running (V3 (-2) 0 0) 0 (Euler 0 0 0)) (Set.empty) Nothing
      setCam (GameState x _ _) = setCamera x
      drawfun' x = return (drawfun x, Just None)
  _ <- initThreads
  playIO (defaultOpts {optWindowName = "play test"}) ts state0 drawfun' simfun setCam
    (Just keyMouseCallback) (Just (motionCallback True)) (Just (motionCallback False))
```
</div></details>
![Screenshot from 2020-01-26 18-53-03.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/489648/15af10bd-68c2-85f4-0810-59b66f11ccba.png)
wasdで移動、マウスで視点移動という簡単な一人称視点を描画するプログラムです。

`play`を使えば簡単にインタラクティブな描画を実現できます。

#Options
`Options`型は次のように定義されています。

```haskell
Options = Options
    {
        optBackgroundColor :: Maybe Color      -- ^ 背景色
    ,   optWindowSize      :: Maybe (Int, Int) -- ^ ウィンドウサイズ, Just (横のピクセル, 縦のピクセル) で指定
    ,   optWindowPosition  :: Maybe (Int, Int) -- ^ ウィンドウを表示する位置, Just (横のピクセル, 縦のピクセル) で指定
    ,   optWindowName      :: String           -- ^ ウィンドウ名, 文字列を与えて指定
    ,   optInitialCamera   :: Maybe Camera0    -- ^ カメラの初期位置, Camera0型の値を与えて指定
    ,   optAnitialiasing   :: Antialiasing     -- ^ アンチエイリアスをどうするか, Anitialiasing型の値で指定
    }
```
なぜ、`Maybe`で包まれてるかはよくわからないのですが、とりあえず`Just`でくるんで渡せば大丈夫です。(`Nothing`はデフォルト値を返すっぽい?)

###Camera0
`Camera0`は描画のスタートにおけるカメラの向きの情報を持ちます。

```haskell
data Camera0 =
    {
        phi0   :: GLDouble
    ,   theta0 :: GLDouble
    ,   rho0   :: GLDouble
    }
```
ここで、`GLDouble`は`Double`のエイリアスなので、そのまま数値を指定すれば大丈夫です。

3つの角度$\phi,\theta,\rho$をそれぞれ指定してあげることで、初期のカメラ向きを決定できます。

```haskell
main = display myOpts (Cube 0.5 Solid white)
    where
        myOpts = defaultOpts { optInitialCamera = Camera0 { phi0 = pi/2 } }
```

###Antialiasing
アンチエイリアスをどうするかを決定できるパラメータです。(アンチエイリアスは、デジタルで描画する時に発生するジャギジャギをなめらかにすることで、違和感を抑える処理だと思ってください。)

```haskell
data Antialiasing = Aliased          -- ^ エイリアスを除かない
                  | Smoothed         -- ^ スムージングする
                  | Multisampled Int -- ^ マルチサンプリングする
```

こんな感じで指定します。

```haskell
main = display myOpts (Cube 0.5 Solid white)
    where
        myOpts = defaultOpts { optAnitialiasing = Smoothed }
```


#VisObject
`VisObject`は描画できるオブジェクトと、オブジェクトへの作用からなり、様々なものが用意されています。

```haskell
data VisObject a =
    -- 作用系
    VisObjects [VisObject a]               -- ^ 複数のオブジェクトをひとつにする
    Trans (V3 a) (VisObject a)             -- ^ オブジェクトを移動させる
    RotQuot (Quaternion a ) (VisObject a)  -- ^ クォータニオンによる回転作用
    RotDcm (M33 a) (VisObject a )          -- ^ 回転行列による回転作用
    RotEulerDeg (Euler a) (VisObject a)    -- ^ オイラー角による回転作用 (度)
    RotEulerRad (Euler a) (VisObject a)    -- ^ オイラー角による回転作用 (ラジアン)
    Scale (a, a, a) (VisObject a)          -- ^ オブジェクトを拡大

    -- オブジェクト
    Cylinder (a, a) Color                  -- ^ 円筒
    Box (a, a, a) Flavour Color            -- ^ 直方体
    Cube a Flavour Color                   -- ^ 立方体
    Sphere a Flavour Color                 -- ^ 球
    Ellipsoid (a, a, a) Flavour Color      -- ^ 楕円体
    Line Maybe a [V3 a] Color              -- ^ 線
    Line' Maybe a [(V3 a, Color)]          -- ^ 線
    Arrow (a, a) (V3 a) Color              -- ^ 矢印
    Axes (a, a)                            -- ^ 軸
    Plane (V3 a) Color Color               -- ^ 平面
    Triangle (V3 a) (V3 a) (V3 a) Color    -- ^ 三角形
    Quad (V3 a) (V3 a) (V3 a) (V3 a) Color -- ^ 四角形
    Text2d String (a, a) BitmapFont Color  -- ^ 2dテキスト
    Text3d String (V3 a) BitmapFont Color  -- ^ 3dテキスト
    Points [V3 a] (Maybe GLfloat) Color      -- ^ 点群
```
オブジェクトの`Flavour`には描画方法(メッシュor塗りつぶし)を指定、`Color`には色を指定します。
`GLfloat`は`float`のエイリアスです。

###Flavour
`Flavour`は2値からなる型で、オブジェクトをどのように描画するか指定します。

```haskell
Flavour = Solid     -- ^ 塗りつぶし
        | Wireframe -- ^ メッシュ
```

違いはこんな感じ
![Screenshot from 2020-01-26 17-49-05.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/489648/e9b12961-7d4b-618a-55dd-42d97e40ee52.png)
上が`Wireframe`で下が`Solid`です。お好みな方を使いましょう。

###Color
色を作る関数が用意されています。

```haskell
makeColor :: Float -- ^ R 
          -> Float -- ^ G
          -> Float -- ^ B
          -> Float -- ^ α
          -> Color
```
R,G,B,αの値は`[0..1]`の範囲で指定します。

`makeColor8`関数を使えば`[0..255]`の`Int`値でも指定できます。
また、定義済みの色は次の通り。
<dl>
  <dt>基本</dt>
  <dd>`black`, `white`</dd>
  <dt>主要な色</dt>
  <dd>`red`, `green`, `blue`</dd>
  <dt>二次的な色</dt>
  <dd>`yellow`, `cyan`, `magenta`</dd>
  <dt>より複合的な色</dt>
  <dd>`rose`, `violet`, `azure`, `aquamarine`, `chartreuse`, `orange`</dd>
</dl>

また、`mixColors`関数を使えば色を混ぜることができます。

```haskell
mixColors :: Float -- ^ 1つ目の色の比率
          -> Float -- ^ 2つ目の色の比率
          -> Color -- ^ 1つ目の色
          -> Color -- ^ 2つ目の色
          -> Color
```
`light`関数や`dark`関数を使うことで色を明るくしたり暗くしたりすることも可能です。詳しくは[ココ](https://hackage.haskell.org/package/not-gloss-0.7.7.0/docs/Vis-GlossColor.html#t:Color)を参考にしてください。

###BitmapFont
`Text2D`や`Text3D`を描画する際に、フォントを指定することができます。

```haskell
data BitmapFont = Fixed8By13
                | Fixed9By15
                | TimesRoman10
                | TimesRoman24
                | Helvetica10
                | Helvetica12
                | Helvetica18
```
後ろの数字はポイントサイズです。僕はTimesRomanが好きです。

```haskell
main = display defaultOpts (Text3D "Hello, Haskeller!" (V3 1 1 1) TimesRoman10 rose)
```

#おわりに
not-glossを使えば、OpenGLを使いこなせるように修行せずとも簡単に3Dグラフィック描画が可能です。
「頭使わずに可視化したいな...」、「ちょっとした3Dゲームを作ってみたいな...」という願望がある方はすぐに試してみましょう！

ここまで見てくださった方、ありがとうございました〜