Pixel Pedals of Tomakomai

北海道苫小牧市出身の初老の日常

自由モナドの定義であるところの Control.Monad.Free.Church.foldF

圏論勉強会の資料 によれば、 X と自由な構成 FXについて、 f :: X \to |Y| を与えると \overline{f} :: FX \to Y が得られるとある。

自由モナドの文脈でこれを考えると、関手 X からモナド Y (の構造を忘れて関手と思ったもの)への自然変換を定義すれば、自由モナド FX からモナド Y への自然変換(正確にはモナドモーフィズム)が得られるという意味となる。

free パッケージにこの対応関係に相当するものは入ってないのかなと探してみたら、 Control.Monad.Free.Church というモジュールで定義されていた。

foldF :: Monad m => (forall x. f x -> m x) -> F f a -> m a

The very definition of a free monad is that given a natural transformation you get a monad homomorphism.

https://www.stackage.org/haddock/lts-8.19/free-4.12.4/Control-Monad-Free-Church.html

あまり深く追ってないけど、このモジュールで定義されているのは内部表現が違う(チャーチエンコーディングされた)自由モナドらしい。後、モナド変換子版 FreeT ではだめでモナド Free じゃないと定義できないということもありそう。

これを使うと、 FunctorMonad としてどう解釈するかを定義するだけで、自由モナドから任意のモナドへの変換が得られる。

{-# LANGUAGE TypeApplications #-}
module Main (main) where
import qualified Control.Monad.Free.Church as F

data HelloProgram a = HPGetLine (String -> a) | HPPrint !String a

instance Functor HelloProgram where
  fmap f (HPGetLine g) = HPGetLine (f . g)
  fmap f (HPPrint s x) = HPPrint s (f x)

helloApp :: F.F HelloProgram ()
helloApp = do
  line <- hellGetLine
  hellPrint line
  where
    liftF' = F.liftF @HelloProgram @(F.F HelloProgram)
    hellGetLine = liftF' $ HPGetLine id
    hellPrint s = liftF' $ HPPrint s ()

toIO :: HelloProgram a -> IO a
toIO (HPGetLine f) = f <$> getLine
toIO (HPPrint ss x) = putStrLn ss >> return x

main :: IO ()
main = F.foldF toIO helloApp

よくある自由モナドの使い方では、変換規則は自由モナド F.F HelloProgram に対して直接用意するが、このコード例では関手 HelloProgram の自然変換のみを変換規則として定義している。この方法では自由モナドの構造が使えないので、関手側に Done のようなデータを用意してそこで処理を打ち切る、といったような解釈の仕方を定義することはできない。そのようなことが必要であれば、 MaybeT IO モナドなど、それ相応の機能を持つモナドへ変換する必要がある。

IOモナドで使うときだけログを吐く関数を定義する

純粋な関数として定義できるんだけど内部でやってることが複雑な場合、何が起きてるかわからないと心配だからとログを吐く機能をつけると、その時点でそいつは IO アクションになってしまう。ログを吐くという副作用を持つのだから IO になるのは当たり前でそれを避けるべきではないのだけど、ログを吐かなくていいいシチュエーションでは、その計算を純粋な関数として使えたほうが理想的ではある。

そんなことを Identity型クラス 使えば簡単にできるんじゃねと思いついたんだけど、 monad-loggerそもそも機能が提供されてた。

runLoggingTrunNoLoggingTモナドclass MonadLogger が持つロギング用のアクションを追加できるのだけど、前者はモナドclass MonadIO のとき、後者は任意の class Monad について使えるようインスタンスが定義されている。

以下の例で addM は足し算するだけのアクションだが、引数をロギングするようになっている。 addaddMIdentity モナドを代入してそれを純粋な関数にしたもの1

{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad.Logger
import Criterion
import Criterion.Main
import Data.Monoid ((<>))
import qualified Data.Text as TX
import Data.Functor.Identity

showT :: Show a => a -> TX.Text
showT = TX.pack . show

addM :: (MonadLogger m, Num a, Show a) => a -> a -> m a
addM x y = do
  logDebugN $ "x=" <> showT x <> ", y=" <> showT y
  return $ x + y

add :: (Num a, Show a) => a -> a -> a
add x y = runIdentity . runNoLoggingT $ addM x y

main :: IO ()
main = do
  runStdoutLoggingT $ do
    n <- addM 1 2
    logDebugN $ showT (n :: Int)
  
  defaultMain
    [ bgroup "add" 
      [ bench "add" $ whnf (add 1) (2 :: Int)
      , bench "(+)" $ whnf (1 +) (2 :: Int)
      ]
    ]

素の足し算と比べるとオーバヘッドはある。

$ stack ghc -- -o pure-logger pure-logger.hs
[1 of 1] Compiling Main             ( pure-logger.hs, pure-logger.o )
Linking pure-logger ...
$ ./pure-logger
[Debug] x=1, y=2
[Debug] 3
benchmarking add/add
time                 87.08 ns   (83.77 ns .. 91.27 ns)
                     0.988 R²   (0.975 R² .. 0.999 R²)
mean                 84.59 ns   (82.95 ns .. 87.74 ns)
std dev              7.355 ns   (4.199 ns .. 12.95 ns)
variance introduced by outliers: 88% (severely inflated)

benchmarking add/(+)
time                 22.31 ns   (20.54 ns .. 23.96 ns)
                     0.970 R²   (0.964 R² .. 0.980 R²)
mean                 21.62 ns   (20.51 ns .. 22.97 ns)
std dev              3.736 ns   (3.185 ns .. 4.343 ns)
variance introduced by outliers: 97% (severely inflated)

が、 -Oコンパイルしたところ、オーバヘッドはきれいに消え去った。やはり最適化がきちんと効くとGHCは強い。

$ stack ghc -- -O -o pure-logger pure-logger.hs
[1 of 1] Compiling Main             ( pure-logger.hs, pure-logger.o )
Linking pure-logger ...
$ ./pure-logger
[Debug] x=1, y=2
[Debug] 3
benchmarking add/add
time                 5.809 ns   (5.663 ns .. 5.981 ns)
                     0.997 R²   (0.995 R² .. 0.999 R²)
mean                 5.728 ns   (5.662 ns .. 5.835 ns)
std dev              277.3 ps   (193.9 ps .. 404.2 ps)
variance introduced by outliers: 74% (severely inflated)

benchmarking add/(+)
time                 6.036 ns   (5.986 ns .. 6.096 ns)
                     0.999 R²   (0.998 R² .. 0.999 R²)
mean                 6.163 ns   (6.090 ns .. 6.334 ns)
std dev              367.0 ps   (221.5 ps .. 643.8 ps)
variance introduced by outliers: 81% (severely inflated)

これでログを吐きつつ計算するI/Oアクションと純粋な関数が、一切のオーバヘッドなしに同時に手に入った。


  1. Show 制約がはずれないのは悲しいが、ロギングするための項が入ってしまっているので仕方ないだろう。あるいは、この項が型ごと差し替えられるようになれば可能なのかな?

C言語の多次元配列の型はどう読むのか

int a[2][3] って、「整数2個の配列( int a[2] )を 3個の配列( [3] )にした、と読めるけどどうなのか1http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf と比べて確認。

116ページのArray declaratorsの節によると、 T D[n] という形式のときは「… array of T」となると書かれている。ここで T は int で D は a[2]n3 なので、「整数3個の配列… 」となる。 … の部分は仕様上で “derived-declarator-type-list” と呼ばれている部分で、 T D がどういう型かによって定められる。 int a[2] は「2-array of int」だけど、 … は最後の int は除くことになっているので、まとめると「2-array of 3-array of int」であって、「整数3個の配列の2個の配列」という意味になる。

なんとも歯切れの悪い定義だけど、 int の何かを定義しているってことでこうなっているのだろうか。考え方としては、 「int D[3]」 みたいな定義があるともうこれは整数3個からなる配列であり、Dをどう書くかでそいつをどう調理するかが決まるってだけ。 a[2] と書けばそれを 2 個の配列にするし、 *a って書けばそいつへのポインタになる。


  1. 添字でのアクセスを考えると違うだろってのはすぐ想像つくけど。

man introとcalコマンド

月末って何曜日だっけとかってときいつもgoogleカレンダー開いてたんだけど、これでいいじゃん。知らなかった・・・。

ubuntu:~$ cal
      May 2017
Su Mo Tu We Th Fr Sa
    1  2  3  4  5  6
 7  8  9 10 11 12 13
14 15 16 17 18 19 20
21 22 23 24 25 26 27
28 29 30 31

man 1 intro したら書いてあった。 man intro なんて初めて使ったし、そもそも man の基本的な使い方もわかってないよね。適切な情報を得る術を知らずに何年も費やしても、まともな知識は得られないってことだね。

VMWareのインストール

最近ずっとVirtualBoxを使っていたのだけど、3Dアクセラレーションを有効にするとOpenGLがまともに動かなかったので、代わりとして久々にVMWareを入れてみた。

Ubuntu 17.04 を入れたんだけど、 Install VMWare tools が動かなかったので、 /media/ユーザ名/VMWare\ Tools 以下のファイルを /tmp へ展開し、手で ./vmware-install.pl を叩いて入れた。途中 ifconfig がなくて怒られたので、 sudo apt-get update sudo apt install net-tools した上で /sbin/ifconfig を手で指定したら動いたっぽい。

目的だったOpenGLは、すんなりと動いてくれた。後、VirtualBoxディスプレイが大き過ぎるとゲストOSのディスプレイサイズがバグる というしょーもない問題も起きなくなった。このまま乗り換えたほうがいいんじゃないかってくらい快適。

もう少し弄って満足したらそのまま乗り換える。

monadiusを動かす

12年前に書かれた http://www.geocities.jp/takascience/haskell/monadius_ja.html を手元で動かした。と言っても、ほぼ手を加えずにそのまま動いた。

$ diff -ur monadius.BK/ monadius
diff -ur monadius.BK/src/Main.hs monadius/src/Main.hs
--- monadius.BK/src/Main.hs     2017-05-16 08:02:04.566956400 +0900
+++ monadius/src/Main.hs        2017-05-16 08:08:18.524217900 +0900
@@ -49,7 +49,8 @@
 loadReplay::String-> IO ReplayInfo
 loadReplay filename = readFile filename >>= (return.read)

-main = withMusic $ do
+main = withMusic $ do
+  getArgsAndInitialize
   args <-getArgs
   putDebugStrLn $ show args

@@ -109,7 +110,7 @@
   mainLoop
   destroyWindow curwnd

-  `catch` (\exc -> return ())
+  `catch` (\exc -> print (exc :: SomeException))

   where
   getReplayFilename args = if length candidates == 0 then Nothing else Just (head candidates) where
@@ -119,7 +120,7 @@
   removesuffix str = if '.' `elem` str then (removesuffix.init) str else str

 exitLoop = do
-  throwIO $ ExitException ExitSuccess
+  exitWith ExitSuccess

 initMatrix = do
   viewport $= (Position 0 0,Size 640 480)
@@ -375,9 +376,9 @@

 closeProc = do
   putDebugStrLn "closed"
-  throwIO $ ExitException ExitSuccess
+  exitWith ExitSuccess


 savePoints = [0,1280,3000,6080]

-
\ No newline at end of file
+

diff -ur monadius.BK/src/Monadius.hs monadius/src/Monadius.hs
--- monadius.BK/src/Monadius.hs 2017-05-16 08:02:04.582583000 +0900
+++ monadius/src/Monadius.hs    2017-05-16 08:02:24.097737300 +0900
@@ -5,7 +5,7 @@
   shotButton,missileButton,powerUpButton,upButton,downButton,leftButton,rightButton,selfDestructButton
 )where

-import Graphics.UI.GLUT hiding (position)
+import Graphics.UI.GLUT hiding (position, DebugMessage)
 import Graphics.Rendering.OpenGL.GLU
 import Control.Exception
 import Control.Monad

freeglut導入済みのmingw64でビルド。Windows上でビルドしたので音も出る。Cのコードも入っているので注意。

$ cd src
$ stack exec makefile.bat

と、これで動いたのだけど、5年前に自分で作ったパッチ を見ると、 (_, args) <- getArgsAndInitialize とするのが正しいらしい。まあいいや。

ちなみに、 Surface Book 上で動かしているのだけど、微妙に動きに引っかかりを感じる。引っかかる程度でほぼなめらかには動いているのだけど。

2017/5/18追記: hackageにも上がってた

shu-thing (シューティングもどき) を動かす

12年前にhaskellで書かれた shu-thing を手元で動かした。と言っても、ほとんど何もせずに動いてしまった。

@@ -10,6 +10,7 @@
 import System.Process

 main = do
+  getArgsAndInitialize
   keystate <- newIORef []
   cp       <- newIORef (openingProc keystate)
   initialWindowSize $= Size 640 480
@@ -44,9 +45,9 @@
   mainLoop
   destroyWindow wnd

-  `catch` (\exc -> return ())
+  `catch` (\exc -> print (exc :: SomeException))

-exitLoop = throwIO $ ExitException ExitSuccess
+exitLoop = exitWith ExitSuccess

 initMatrix = do
   viewport $= (Position 0 0,Size 640 480)
@@ -184,7 +185,7 @@

 closeProc = do
   putStrLn "closed"
-  throwIO $ ExitException ExitSuccess
+  exitWith ExitSuccess

 bosstime=6600
 bosstime2=7200
$ stack ghc -- -o shu-thing.exe gl.hs
[1 of 1] Compiling Main             ( gl.hs, gl.o )
Linking shu-thing.exe ...

freeglut 入りの mingw64 でビルド、実行している。

2017/5/18追記: hackageにも上がってた