読者です 読者をやめる 読者になる 読者になる

きくらげ観察日記

好きなことを、適当に。

Elmの型関連が弱すぎてつらい

Elm

inkar-us-i.hatenablog.com

ここでやたらElm推してるみたいな書き方をしてしまいましたが、僕自身はそんなにElm好きではありません。

型クラスがない

Elmには型クラスが無いため、まともに多相的な関数を書くことはできません。
例えば、Elmには至る所でモナディックな処理が出てきます。

-- Maybeモナド
Just 3
  |> Maybe.andThen (\x -> if x == 3 then Nothing else Just (x + 1))
-- Cmdモナド
Http.get string "http://hoge.com"
  |> Task.andThen (\url -> Http.get (list string) url)
-- Random.Generatorモナド
Random.int 0 10
  |> Random.andThen (\n -> Random.int n 100)

この andThen がモナドの >>= に相当するのですが、これらの3つのandThenは全て別々に実装されたものとなります。
この他にも、haskellのliftM, liftM2 に対応するmap, map2もそれぞれのライブラリで定義されているのですが、これらは全て「別々に」定義されています。
実際は、「a -> m b」なる関数returnと、このandThenの2つの関数さえ用意すれば、残りのmap2等の関数は全てそこから自動的に定義できるはずです。

また、例えば同じ生成器で乱数をn回生成するrepeatGenという関数を作ろうと思ったとします。
この関数は以下のように書くことができます。

repeatGen : Int -> Generator a -> Generator (List a)
repeatGen n gen =
    let return x = Random.map (\_ -> x) Random.bool -- return が無いので代用。厳密にはモナド則を満たさなくなるけど今は無視
    in if n <= 0 then return []
       else Random.map2 (::) gen (repeatGen (n - 1) gen)

この関数はだいたい思った通りに動作します。
この後、同じタスクをn回実行するrepeatTaskが欲しくなったとします。

repeatTask : Int -> Generator a -> Generator (List a)
repeatTask n task =
    let return x = Task.succeed x
    in if n <= 0 then return []
    else Task.map2 (::) task (repeatTask (n - 1) task)

この定義を見てください。ほとんどrepaetGenと同じです。
Haskellの場合は、一般のモナドについて以下のようにrepeatMを定義することができます。

repeatM :: Monad m => Int -> m a -> m [a]
repeatM n action =
    if n <= 0 then return []
    else liftM2 (:) action (repeatM (n - 1) action)

しかし、Elmは言語機能が貧弱なため、このような関数をElmで書くことはできません。
不便ではありますが、言語仕様なので我慢するしかありません。

高階多相やRankN多相が使えない

Haskellの場合、型クラスという言語機能がなかったとしても、以下のようにMonadを明示的に渡してしまうことによって、少し不便ではありますが似たような操作を行うことができます。

data Monad m = Monad {
    return :: a -> m a
    -- Elm 風に
  , andThen :: (a -> m b) -> m a -> m b
  }

-- Elm 風に
(|>) :: a -> (a -> b) -> b
a |> f = f a
infixl 1 |>

map2 :: Monad m -> (a -> b -> c) -> m a -> m b -> m c
map2 monad f ma mb =
  ma |> andThen monad (\a -> mb |> andThen monad (\b -> return monad (f a b)))

repeatM' :: Monad m -> Int -> m a -> m [a]
repeatM' monad n action =
  if n <= 0 then return monad []
  else map2 monad (:) action (repeatM' monad (n - 1) action)

しかし、これをElmでやろうとした場合、forallに相当する機能が無いため、このような関数を書くことはできません。
また、そもそも高階多相が無いため、

return : a -> f a

のような関数を定義することすらできません。

Functorもない

「いや、OCamlだって高階多相やRankN多相は無いし、それだけでじゃディスる理由にならないだろ」と言う方もいるかもしれません。それはたしかにその通りです。しかし、OCamlにはその代わりにFunctorという素晴らしい機能があります。

module type MONAD =
  sig
    type 'a t
    val return : 'a -> 'a t
    val and_then : ('a -> 'b t) -> 'a t -> 'b t
  end

module Make (M : MONAD) =
  struct
    let map2 (f : 'a -> 'b -> 'c) (ma : 'a M.t) (mb : 'b M.t) : 'c M.t =
      ma |> M.and_then (fun a -> mb |> M.and_then (fun b -> M.return (f a b)))
    let rec repeat (n : int) (action : 'a M.t) : 'a list M.t =
      if n <= 0 then M.return []
      else map2 (fun x y -> x :: y) action (repeat (n - 1) action)
  end

Functorを使うことによって、使用方法は少し異なりますがモナドを書くことができます。
重要なのは、一度このFunctor Makeを書いてしまえば、Random.GeneratorだろうがTaskだろうが同じように使うことができることです。

しかし、ElmにはFunctorもありません。したがって、この方法でも多相的な関数を書くことはできません。

その代わりにある謎機能

しかし、組み込み関数の(+)はIntだろうがFloatだろうが使えますし、(++)はListだろうがStringだろうが連結できてしまいます。これらは一体どのように定義されているのでしょうか?

> 3.0 + 2.0
5 : Float
> [1, 2, 3] ++ [4, 5, 7]
[1,2,3,4,5,7] : List number
> "hoge" ++ "fuga"
"hogefuga" : String
> (+)
<function> : number -> number -> number
> (++)
<function> : appendable -> appendable -> appendable

それぞれnumber, appendableという型変数名になっています。
実はこれは処理系による例外的な機能で、変数名の頭が「number」「appendable」である型変数は特別扱いされ、numberなら数値、appendableならリストや文字列などの連結できる任意の型を受け取ることができるようになっています。この他に、比較可能な型を表すcomparableなどもあります。

しかし、これらはあくまで「例外」的な機能です。新しく作った型をnumberやappendableのメンバーとして登録することもできませんし、これらの「型クラスのようなもの」を新たに作ることもできません。


このようにElmは型に関する機能が十分ではないため、どんな場合にも使用できるような高度に抽象化された関数を書くことはできません。
出来合いのライブラリを使って何かするだけなら便利かもしれませんが、ライブラリを作る側に回った時には非常に不便な言語です。

Elm始めてみました。

Elm

Elmという言語を一ヶ月ほど触ってみたので、この言語の特徴などを紹介したいと思います。

Elmとは

http://elm-lang.org/

この言語はざっくりと言うと、「JavaScriptコンパイルされる、純粋関数型でHaskellっぽい文法の言語」です。

純粋関数型

ElmはHaskellと同様に純粋関数型(と通常はみなすことができる)言語です。基本的に、Elmの中ではどのような副作用も起こすことはできませんが、後述するThe Elm Architectureにより外界との通信などを行うことができます。

Elmは関数型言語に特徴的な機能のほとんどを持っています。

-- 代数的データ型
type Hoge = Hoge | Fuga

-- レコード型
type alias Person =
    { name : String
    , age : Int
    , address : String
    }

-- パターンマッチ
toStr : Hoge -> String
toStr hoge =
    case hoge of
        Hoge -> "hoge"
        Fuga -> "fuga"

また、MaybeやResult(Eitherに相当)など、関数型的プログラミングをするために必要な型も一通りそろっています。
文法はかなりHaskellに近いですが、正格評価だったり型クラスがなかったりするので中身はあまりHaskellっぽくありません。むしろOCamlに近いかもしれません。

The Elm ArchitectureによるIOの実現

Elmは純粋関数型言語ですが、モナドも一意型もありません。それではどのようにして副作用を実現しているのかというと、FRPの概念を元にして作られたThe Elm Architectureというフレームワークを利用します。基本的に、全てのプログラムはModel, Msg, view, update, subscriptionsの5つからなります。

type Model = (アプリケーションの状態管理に使用するデータ型)
type Msg = (外界との通信に必要な型)
init : (Model, Cmd Msg) -- 初期状態
view : Model -> Html msg -- 表示
update : Msg -> Model -> (Model, Cmd Msg)
subscriptions : Model -> Sub Msg

Model, viewについての説明は不要だと思いますが。Elmには見慣れないupdate, subscriptionsという2つの関数があります。
The Elm Architectureの考え方の根本はFRPなので、外界で発生するイベントは時系列に並んだリストのようなものと考えることができます。updateはこれらを畳み込んでModelを変化させていく関数です。

update (マウスクリックを表すイベント) model = (イベント処理の終わったmodel, cmd)

updateは更新後のmodelの値の他にCmd Msgという謎の値も返していますが、これは外界への命令を表します。外界への命令というのは、例えば「hogehoge.comにGETリクエスト送っといて」とか「ランダムに整数生成しといて」といったIOの絡むものを表します。これらを表すCmd Msg型の値を返すと、その結果がMsg型となって後のupdateの引数に渡されていきます。

もうひとつの関数subscriptionsは、マウスのクリックや時間の経過等無数にあるイベントのうち、どのイベントをupdateの引数として通知して欲しいかを表します。

これらの関数を利用して、IOの必要な処理をCmdとして外界に送信し、返ってきた値をupdateの引数として受け取り、さらに処理を続けていく…といったループが、Elmのプログラムの基本的な書き方となります。

Taskによる非同期処理

Elmではhttpリクエストの送信などの非同期で行いたい処理をTaskという概念を用いて行います。
TaskはTask.attemptという関数によりCmdに変換され、それをupdateで送信することによって実行後にMsgとなって返ってきます。

type Msg = Users (List String) | ...

-- api.example.com/users にリクエストを送るタスク
getUsers : Task Http.Error (List String)
getUsers = Http.get (list string) "http://api.example.com/users"

こうしてできたタスクは、Task.performという関数によりCmdに変換され、updateを使って送信されます。
そして、返ってきた値がMsgとなってupdateに渡されるという流れになっています。

portによるJSとの連携

JSで書かれたコードとのやり取りは、portという機能を介して行われます。
ポートには入力ポートと出力ポートの2種類があり、それぞれ次のように定義します。

-- 出力ポート
port outPort : String -> Cmd msg
-- 入力ポート。引数を使ってポートからの値をmsgに変換する。
port inPort : (String -> msg) -> Sub msg

Stringの部分はJSとのやり取りに指定したい型です。別にStringじゃなくても構いません。
このようにして定義したportを、先ほど説明したupdateにより外界に渡し、subscriptionsにより受け取ることができます。
Elmとやり取りするためのJSのコードは以下のようになります。

var app = Elm.Main.fullscreen();
// 出力ポートからの値の受け取り
app.ports.outPort.subscribe((str) => {
    (適当な処理);
    app.ports.inPort.send('何らかのメッセージ')
});

これだけです。簡単ですね。
この機能により、容易にJavaScriptで書かれたコードとの連携を取ることができます。そのため、JSで書かれたアプリケーションの一部にElmを使ったり、その逆を行うことも可能です。


以上がElmの主な特徴になります。
FRPを前提とした言語というのは他では聞いたことがありませんし、一度やってみるのも面白いのではないでしょうか?

次回はElmに関する愚痴とかを書きます。

ムシャクシャしたのでテトリスを作った

Elm Products

試験の出来が悪かったので、ムシャクシャして2時間くらいキーボードを叩いていたらテトリスができていました。

完成品は以下のURLに上げています。

http://monamonamonad.github.io/tetris/

Elmはこれくらいの小規模なアプリケーションを書くのに便利ですね。

追記: よくよく考えたら横一列そろったブロック消すの忘れてた。
テトリス下手だから気づかなかった

さらに追記: ↑さすがに直しました。

以下ソースコード
適当に書きなぐったやつなので<table>タグでレイアウトしてたりコード汚かったりしますが直すつもりはありません。

module Main exposing (..)

import Html exposing (..)
import Html.Events exposing (..)
import Html.Attributes exposing (..)

import Array exposing (Array)
import Random
import Time
import Json.Decode
import Keyboard exposing (KeyCode)


-- テトリスの操作に関するAPI
type Color
    = Red
    | Blue
    | Green
    | Yellow
    | Purple
    | Skyblue
    | Orange

type alias Point =
    { x : Int
    , y : Int
    }

type alias Direction = Point

type alias Block =
    { base : Point
    , points : List Point
    , color : Color
    }

type alias Tetris =
    { width : Int
    , height : Int
    , movingBlock : Maybe Block
    , points : Array (Array (Maybe Color))
    , gameOver : Bool
    }

direction =
    { left = { x = -1, y =  0 }
    , right = { x = 1, y = 0 }
    , up = { x = 0, y = -1 }
    , down = { x = 0, y = 1 }
    }

initialTetris : Int -> Int -> Tetris
initialTetris width height =
    { width = width
    , height = height
    , movingBlock = Nothing
    , points = Array.repeat height (Array.repeat width Nothing)
    , gameOver = False
    }

-- 位置 (x, y) のブロックの色を取得
-- Nothing -> 範囲外
-- Just Nothing -> 範囲内だけどブロックが無い
-- Just (Just c) -> 色 c のブロックがある
colorAt : Int -> Int -> Tetris -> Maybe (Maybe Color)
colorAt x y tetris =
    Array.get y tetris.points
        |> Maybe.andThen (Array.get x)

-- topY <= y を満たすエリアを実際に使える
-- それより上 (y 座標が小さいエリア) は初期ブロック出現場所
topY : Int
topY = 2

-- topY より上にブロックが来てたらアウト
isGameOver : Tetris -> Bool
isGameOver tetris =
    let colors = List.concat
                 <| List.map (\y -> List.map (\x -> colorAt x y tetris)
                                  <| List.range 0 (tetris.width - 1))
                 <| List.range 0 (topY - 1)
        pred color =
            case color of
                Just (Just _) -> True
                _ -> False
    in List.any pred colors

movePoint : Point -> Direction -> Point
movePoint point dir =
    { x = point.x + dir.x
    , y = point.y + dir.y
    }

toPoints : Block -> List Point
toPoints b = List.map (movePoint b.base) b.points

moveBlock : Block -> Direction -> Block
moveBlock block dir =
    { block |
          base = { x = block.base.x + dir.x
                 , y = block.base.y + dir.y }
    }

canPointPut : Point -> Tetris -> Bool
canPointPut p tetris =
    case colorAt p.x p.y tetris of
        Nothing -> False
        Just Nothing -> True
        Just (Just c) -> False

canBlockPut : Block -> Tetris -> Bool
canBlockPut block tetris = List.all (\p -> canPointPut p tetris) <| toPoints block

doesBlockHavePoint : Block -> Point -> Bool
doesBlockHavePoint block point =
    List.member point <| toPoints block

-- ブロックの回転、反転用

-- 行列 a = (a11 a12)
--          (a21 a22)
-- を表す
type alias Mat =
    { a11 : Int, a12 : Int
    , a21 : Int, a22 : Int
    }

apply : Mat -> Point -> Point
apply mat point =
    { x = mat.a11 * point.x + mat.a12 * point.y
    , y = mat.a21 * point.x + mat.a22 * point.y
    }

applyToBlock : Mat -> Block -> Block
applyToBlock mat block =
    { block | points = List.map (apply mat) block.points }

rotate : Mat
rotate =
    { a11 = 0,  a12 = 1
    , a21 = -1, a22 = 0 }

-- ゲーム内で使用するブロック
-- ブロックの形
blocks : List Block
blocks =
    let base = { x = 0, y = 0 } -- ダミー
    in  [{ base = base -- I
         , color = Purple
         , points = [ { x = -1, y = 0 }
                    , { x = -0, y = 0 }
                    , { x =  1, y = 0 }
                    , { x =  2, y = 0 }
                    ]
         }
        , { base = base -- Z
          , color = Red
          , points = [ { x = -1, y = -1 }
                     , { x =  0, y = -1 }
                     , { x =  0, y =  0 }
                     , { x =  1, y =  0 }]
          }
        , { base = base -- S
          , color = Skyblue
          , points = [ { x =  1, y = -1 }
                     , { x =  0, y = -1 }
                     , { x =  0, y =  0 }
                     , { x = -1, y =  0 }]
          }
        , { base = base -- T
          , color = Green
          , points = [ { x =  0, y = -1 }
                     , { x = -1, y =  0 }
                     , { x =  0, y =  0 }
                     , { x =  1, y =  0 }]
          }
        , { base = base -- J
          , color = Yellow
          , points = [ { x = -1, y = -1 }
                     , { x = -1, y =  0 }
                     , { x =  0, y =  0 }
                     , { x =  1, y =  0 }]
          }
        , { base = base -- L
          , color = Orange
          , points = [ { x =  1, y = -1 }
                     , { x =  1, y =  0 }
                     , { x =  0, y =  0 }
                     , { x = -1, y =  0 }]
          }
        , { base = base -- O
          , color = Blue
          , points = [ { x = -1, y = -1 }
                     , { x =  0, y = -1 }
                     , { x = -1, y =  0 }
                     , { x =  0, y =  0 }]
          }
        ]

-- 次のブロックをランダムに生成する
generateBlock : Tetris -> Random.Generator Block
generateBlock tetris =
    let base = { x = tetris.width // 2
               , y = 1
               }
    in randomChoose blocks
        |> Random.map (\b -> { b | base = base })

randomChoose : List a -> Random.Generator a
randomChoose xs =
    let len = List.length xs
        get i = xs |> List.drop i |> List.head |> fromJust
    in Random.int 0 (len - 1)
        |> Random.map get

-- ゲーム本体のロジック

-- キーコード
keys =
    { left = 37
    , up = 38
    , right = 39
    , down = 40
    , space = 32
    }

putBlock : Tetris -> Tetris
putBlock tetris =
    case tetris.movingBlock of
        Nothing -> tetris
        Just block ->
            let points = tetris.points
                cell x y default =
                    if doesBlockHavePoint block { x = x, y = y }
                    then Just block.color
                    else default
                newPoints = Array.indexedMap
                            (\y row -> Array.indexedMap
                                 (\x d -> cell x y d) row) points
                -- TODO: 以下の2つの処理はここで行うべきではない
                newTetris = clearRows { tetris |
                                        points = newPoints
                                      , movingBlock = Nothing
                                      }
            in { newTetris | gameOver = isGameOver tetris }

moveBlockIfCan : Direction -> Tetris -> Tetris
moveBlockIfCan dir tetris =
    case tetris.movingBlock of
        Nothing -> tetris
        Just block ->
            let moved = moveBlock block dir
            in if canBlockPut moved tetris
               then { tetris | movingBlock = Just moved }
               else tetris

rotateMovingBlock : Tetris -> Tetris
rotateMovingBlock tetris =
    case tetris.movingBlock of
        Nothing -> tetris
        Just block ->
            let newBlock = applyToBlock rotate block
            in if canBlockPut newBlock tetris
               then { tetris | movingBlock = Just newBlock }
               else tetris

fallOrPut : Tetris -> Tetris
fallOrPut tetris =
    case tetris.movingBlock of
        Nothing -> tetris
        Just block ->
            let fallen = moveBlock block direction.down
            in if canBlockPut fallen tetris
               then { tetris | movingBlock = Just fallen }
               else putBlock tetris

-- ユーザーの入力
userInput : KeyCode -> Tetris -> Tetris
userInput code tetris =
    switch
    [ (code == keys.left, moveBlockIfCan direction.left tetris)
    , (code == keys.right, moveBlockIfCan direction.right tetris)
    , (code == keys.down, moveBlockIfCan direction.down tetris)
    , (code == keys.space, rotateMovingBlock tetris)
    , (otherwise, tetris)
    ]

shouldRowClear : Array (Maybe Color) -> Bool
shouldRowClear row =
    let isNotEmpty c = Maybe.map (\_ -> True) c
                     |> Maybe.withDefault False
    in List.all isNotEmpty <| Array.toList row

remainingRows : Tetris -> Array (Array (Maybe Color))
remainingRows tetris =
    Array.filter (\row -> not (shouldRowClear row)) tetris.points

clearRows : Tetris -> Tetris
clearRows tetris =
    let rows = remainingRows tetris
        numRows = Array.length rows
        emptyRows = Array.repeat (tetris.height - numRows)
                    <| Array.repeat tetris.width Nothing
        newPoints = Array.append emptyRows rows
    in { tetris | points = newPoints }

-- モデル
type alias Model = Tetris

type Msg
    = KeyPress Int
    | Fall
    | NewBlock Block

initialModel : Model
initialModel = initialTetris 10 22

init : (Model, Cmd Msg)
init = ( initialModel
       , Random.generate NewBlock (generateBlock initialModel)
       )

update : Msg -> Model -> (Model, Cmd Msg)
update msg model =
    case msg of
        NewBlock block ->
            if model.gameOver
            then (model, Cmd.none)
            else ( { model | movingBlock = Just block }
                 , Cmd.none)
        KeyPress code ->
            ( userInput code model
            , Cmd.none)
        Fall -> nextTurn model

nextTurn : Tetris -> (Tetris, Cmd Msg)
nextTurn tetris =
    case tetris.movingBlock of
        Nothing -> (tetris, Random.generate NewBlock (generateBlock initialModel))
        Just _ -> (fallOrPut tetris, Cmd.none)

subscriptions : Model -> Sub Msg
subscriptions model =
    if model.gameOver
    then Sub.none
    else Sub.batch
        [ Time.every (Time.second) (\_ -> Fall)
        , Keyboard.downs KeyPress
        ]

view : Model -> Html Msg
view model =
    div []
        [ tetrisView model
        , buttons
        , message model
        ]

buttons : Html Msg
buttons =
    div []
        [ button [ style buttonStyle, onClick (KeyPress keys.left) ]
              [ text "<-" ]
        , button [ style buttonStyle, onClick ( KeyPress keys.space) ]
              [ text "O" ]
        , button [ style buttonStyle, onClick (KeyPress keys.right) ]
              [ text "->" ]
        ]

buttonStyle : List (String, String)
buttonStyle =
    [ ("width", "80px")
    ]

message : Model -> Html Msg
message model =
    div [ style messageStyle ]
        [ if model.gameOver
          then text "Game Over"
          else text ""
        ]

messageStyle : List (String, String)
messageStyle =
    [ ("font-size", "x-large")
    , ("font-weight", "bold")
    , ("color", "red")
    ]

tetrisView : Tetris -> Html Msg
tetrisView tetris =
    table [] <| List.map (\y -> tetrisRowView y tetris)
        <| List.range 0 (tetris.height - 1)

tetrisRowView : Int -> Tetris -> Html Msg
tetrisRowView y tetris  =
    tr [] <| List.map (\x -> tetrisCellView x y tetris)
        <| List.range 0 (tetris.width - 1)

tetrisCellView : Int -> Int -> Tetris -> Html Msg
tetrisCellView x y tetris =
    td [ style (cellStyle x y tetris) ] []

cellStyle : Int -> Int -> Tetris -> List (String, String)
cellStyle x y tetris =
    [ ("background-color", cellColor x y tetris)
    , ("width", "20px")
    , ("height", "20px")
    , ("border-radius", "2px")
    ]

cellColor : Int -> Int -> Tetris -> String
cellColor x y tetris =
    let point = colorAt x y tetris
        defaultColor =
            case point of
                Just (Just c) -> colorToString c
                _ -> "burlywood"
    in case tetris.movingBlock of
           Just b -> if doesBlockHavePoint b { x = x, y = y }
                     then colorToString b.color
                     else defaultColor
           Nothing -> defaultColor

colorToString : Color -> String
colorToString c =
    case c of
        Red -> "red"
        Blue -> "blue"
        Green -> "green"
        Yellow -> "yellow"
        Purple -> "purple"
        Skyblue -> "deepskyblue"
        Orange -> "orangered"

main =
    Html.program
        { init = init
        , view = view
        , update = update
        , subscriptions = subscriptions
        }

-- その他
fromJust : Maybe a -> a
fromJust a = case a of
                 Just x -> x
                 Nothing -> Debug.crash "Nothing"

-- lisp でいう cond みたいなやつ
switch : List (Bool, a) -> a
switch xs =
    case xs of
        [] -> Debug.crash "switch: no option"
        (cond, val) :: xs -> if cond then val
                             else switch xs

otherwise : Bool
otherwise = True

標準ライブラリの他に elm-lang/keyboard も使っています。

型クラスのインスタンスが複数ある場合の話(Haskell編)

Haskell

inkar-us-i.hatenablog.com

こちらで出した例はScalaでしたが、Haskellでも同様の問題は起こりえます。

-- TreeSet.hs
module TreeSet (
    Cmp(..)
  , TreeSet()
  , empty
  , insert
  , fromList
  , elem
  ) where

import Prelude hiding (elem)

class Cmp a where
  eq :: a -> a -> Bool
  lt :: a -> a -> Bool

data TreeSet a
  = Branch a (TreeSet a) (TreeSet a)
  | Leaf

empty :: TreeSet a
empty = Leaf

insert :: Cmp a => a -> TreeSet a -> TreeSet a
insert x Leaf = Branch x Leaf Leaf
insert x t@(Branch y left right)
  | eq x y    = t
  | lt x y    = Branch y (insert x left) right
  | otherwise = Branch y left (insert x right)

fromList :: Cmp a => [a] -> TreeSet a
fromList xs = foldl (flip insert) Leaf xs

elem :: Cmp a => a -> TreeSet a -> Bool
elem _ Leaf = False
elem x (Branch y left right)
  | eq x y    = True
  | lt x y    = elem x left
  | otherwise = elem x right
-- ModA.hs
module ModA (someSet) where

import qualified TreeSet as TS

-- 通常の順序
instance TS.Cmp Int where
  eq = (==)
  lt = (<)

someSet :: TS.TreeSet Int
someSet = TS.fromList [5, 3, 7, 1, 6]
-- ModB.hs
module ModB (is7InSet) where

import qualified TreeSet as TS

-- 逆順
instance TS.Cmp Int where
  eq = (==)
  lt = (>)

is7InSet :: TS.TreeSet Int -> Bool
is7InSet set = TS.elem 7 set
-- ModC.hs
module ModC where

import qualified ModA
import qualified ModB
import qualified TreeSet as TS

main = do
  if ModB.is7InSet ModA.someSet
    then putStrLn "7 is in someSet"
    else putStrLn "7 is not in someSet"

実行結果:

$ runghc ModC.hs
7 is not in someSet

Orphan instanceの危険性が分かってきました。

implicit parameterによる型クラスの罠

Scala

Scalaの型クラスは暗黙引数の受け渡しにより行われるため、スコープごとに同一な型クラスの別なインスタンス実装を使うことができます。
例えば、以下のような比較を行う型クラス、Cmpを考えてみましょう。

trait Cmp[A] {
  def eq(x : A, y : A) : Boolean
  def lt(x : A, y : A) : Boolean
}

これに対して、例えばIntであれば少なくとも以下の2種類のインスタンスが考えられます。

// 昇順
object IntCmp extends Cmp[Int] {
  def eq(x : Int, y : Int) : Boolean = x == y
  def lt(x : Int, y : Int) : Boolean = x < y
}

// 降順
object IntRevCmp extends Cmp[Int] {
  def eq(x : Int, y : Int) : Boolean = x == y
  def lt(x : Int, y : Int) : Boolean = x > y
}

この時点では特に問題はありません。
しかし、以下のようなデータ構造を考えてみましょう。

sealed trait TreeSet[+A]
case class Branch[A](x : A, left : TreeSet[A], right : TreeSet[A]) extends TreeSet[A]
case object Leaf extends TreeSet[Nothing]

object TreeSet {

  def empty[A] : TreeSet[A] = Leaf

  def insert[A](x : A, tree : TreeSet[A])(implicit C : Cmp[A]) : TreeSet[A] =
    tree match {
      case Leaf => Branch(x, Leaf, Leaf)
      case Branch(y, left, right) =>
        if (C.eq(x, y))
          tree
        else if (C.lt(x, y))
          Branch(y, insert(x, left), right)
        else
          Branch(y, left, insert(x, right))
    }

  def fromSeq[A](xs : Seq[A])(implicit C : Cmp[A]) : TreeSet[A] =
    xs.foldLeft(Leaf : TreeSet[A]){ (tr, x) => insert(x, tr) }

  def apply[A](elems : A*)(implicit C : Cmp[A]) : TreeSet[A] =
    TreeSet.fromSeq(elems)

  def elem[A](x : A, tree : TreeSet[A])(implicit C : Cmp[A]) : Boolean =
    tree match {
      case Leaf => false
      case Branch(y, left, right) =>
        if (C.eq(x, y))
          true
        else if (C.lt(x, y))
          elem(x, left)
        else
          elem(x, right)
    }
}

これは、Cmp[A]で与えられた順序を元にした2分木によるツリーセットです(平衡をとったりはしていませんが、あくまで例なのでご了承ください)。

これを使うライブラリを考えてみましょう。

object Hoge {
  implicit val C : Cmp[Int] = IntCmp
  val someSet = TreeSet(5, 3, 7, 1, 6)
}

Hogeライブラリでは、昇順のCmpを利用したツリーセット、someSetを定義しています。

object Fuga {
  implicit val C : Cmp[Int] = IntRevCmp
  def is7InSet(set : TreeSet[Int]) : Boolean =
    TreeSet.elem(7, set)
}

一方こちらのFugaライブラリでは、与えられたツリーセットに7が含まれているかどうかを判定する関数を定義しています。

これらのモジュールを使用するプログラムを考えてみましょう。

object Main extends App {
  println("Hoge.someSet = " + Hoge.someSet.toString)
  if (Fuga.is7InSet(Hoge.someSet))
    println("7 is in someSet")
  else
    println("7 is not in someSet")
}

この実行結果はどうなるでしょうか?

$ scala Main
Hoge.someSet = Branch(5,Branch(3,Branch(1,Leaf,Leaf),Leaf),Branch(7,Branch(6,Leaf,Leaf),Leaf))
7 is not in someSet

someSetには7が含まれているにも関わらず、"7 is not in someSet"と表示されてしまいました。
これはHoge.someSetがIntCmpを使っているのに対し、Fuga.is7InSetがIntRevCmpを使っていることが原因になります。

一つの型クラスに対して複数のインスタンスが定義できるのは便利ではありますが、場合によってはこういった落とし穴もあるんですね。
実用上このような問題が起こることはあまりないとは思いますが。

Smith-Waterman法で配列の局所アラインメントを求める

OCaml Algorithm

今度は局所アラインメントを求めます。
前回の大域アラインメントと違って、今度は最も一致度の高い部分文字列を求めるアルゴリズムになります。

type alignment = char option list

let maximums_by (key : 'a -> 'b) (lst : 'a list) : 'a list =
  let rec loop max_val maxs xs =
    match xs with
    | [] -> maxs
    | x :: xs' ->
       let x_val = key x
       in if max_val < x_val then loop x_val [x] xs'
          else if max_val = x_val then loop max_val (x :: maxs) xs'
          else loop max_val maxs xs'
  in match lst with
     | [] -> raise (Failure "maximums_by: empty list")
     | max :: xs -> loop (key max) [max] xs

let maximum (lst : 'a list) : 'a =
  List.hd (maximums_by (fun x -> x) lst)

let fromto (from : int) (to_ : int) : int list =
  let rec loop i acc =
    if i < from then acc
    else loop (i - 1) (i :: acc)
  in loop to_ []

let prod (xs : 'a list) (ys : 'b list) : ('a * 'b) list =
  List.flatten (List.map (fun x -> List.map (fun y -> (x, y)) ys) xs)

module type ALIGNMENT =
  sig
    val align : string -> string -> (alignment * alignment) list
  end

module type WEIGHT =
  sig
    val weight : char -> char -> int
    val gap_penalty : int
  end

module Alignment (W : WEIGHT) : ALIGNMENT =
  struct
    let path s t m n calc : alignment * alignment =
      let rec loop i j acc =
        match i, j with
        | 0, 0 -> List.split acc
        | _, _ ->
           let dp_val = calc i j
           in if dp_val = 0 then
                List.split acc
              else if dp_val = calc (i - 1) j - W.gap_penalty then
                loop (i - 1) j ((Some s.[i - 1], None) :: acc)
              else if dp_val = calc i (j - 1) - W.gap_penalty then
                loop i (j - 1) ((None, Some t.[j - 1]) :: acc)
              else loop (i - 1) (j - 1) ((Some s.[i - 1], Some t.[j - 1]) :: acc)
         in loop m n []

    let align s t =
      let s_len = String.length s in
      let t_len = String.length t in
      let dp = Array.make_matrix (s_len + 1) (t_len + 1) None in
      let rec calc i j =
        let value = dp.(i).(j) in
        match value with
        | Some (v) -> v
        | None ->
           let new_value =
             match i, j with
             | 0, _ -> i * -W.gap_penalty
             | _, 0 -> j * -W.gap_penalty
             | _, _ -> maximum [
                           0
                         ; calc (i - 1) j - W.gap_penalty
                         ; calc i (j - 1) - W.gap_penalty
                         ; calc (i - 1) (j - 1) + W.weight s.[i - 1] t.[j - 1]
                         ]
           in dp.(i).(j) <- Some(new_value);
              new_value in
      let indices = maximums_by (fun (i, j) -> calc i j)
                                (prod (fromto 0 s_len) (fromto 0 t_len)) in
      List.map (fun (m, n) -> path s t m n calc) indices
  end

module Default_weight : WEIGHT =
  struct
    let weight c d = if c = d then 5 else -3
    let gap_penalty = 4
  end

module Default_alignment = Alignment(Default_weight)

Default_weightのweightとgap_penaltyの値は、以下のサイトを参考にしました。
vlab.amrita.edu


実行結果:

# Default_alignment.align "GACTTAC" "CGTGAATTCAT";;
- : (alignment * alignment) list =
[([Some 'G'; Some 'A'; Some 'C'; Some 'T'; Some 'T'; Some 'A'; Some 'C'],
  [Some 'G'; Some 'A'; Some 'A'; Some 'T'; Some 'T'; None; Some 'C']);
 ([Some 'G'; Some 'A'; Some 'C'; Some 'T'; Some 'T'; None; Some 'A'],
  [Some 'G'; Some 'A'; Some 'A'; Some 'T'; Some 'T'; Some 'C'; Some 'A'])]

得られた局所アラインメントは、

GACTTAC
GAATT-C

GACTT-A
GAATTCA

の2つです。先ほどのサイトの結果と一致しているので、アルゴリズムは正しく動いているようです。

余談ですが、このアルゴリズムにおけるweight, gap_penaltyのような、引数にするほどでもないけど自由に設定したい値を渡すのにFunctorを使うと便利です。他のオブジェクト指向言語ならインスタンスのメンバに割り当てたり、Schemeならparameterを使ったりするのでしょうが、Haskellだとなかなかこういうことができなくて少し不便です。

Needleman-Wunsch法により配列の大域アラインメントを求める

Algorithm Gauche

アラインメントとは、2つの配列s, tに欠損記号「-」を挿入して、出来る限り2つの一致度が高くなるように並べたものです。
例えば、2つの文字列"ABCD"と"ACDE"があったとき、これは1つめの文字列から'B'を削除して末尾に'E'を挿入たものだと考えるのが自然でしょう。この時の2つの文字列のアラインメントは、それぞれ"ABCD-"と"A-CDE"となります。

アルゴリズム自体の説明は「Needleman-Wunsch」とかでググれば出てくるので割愛します。
Gaucheによる実装がこちら。
alignment関数は2つの文字列s, tとパラメータweight, gap-penaltyを受け取り、sとtの類似度の最大値と、類似度を最大値にするようなsとtのアラインメントをそれぞれ返します。なお、アラインメントはリストで表され、各要素は文字か欠損値#fで表されます。

(use util.match)
(use gauche.array)
(use gauche.parameter)

(define weight
  (make-parameter
   (^(x y) (if (eqv? x y) 1 -1))))

(define gap-penalty
  (make-parameter 1))

(define arr~ array-ref)

(define (alignment s t)
  (define w (weight))
  (define d (gap-penalty))
  (define s-len (string-length s))
  (define t-len (string-length t))
  (define s-arr (apply array (shape 0 s-len) (string->list s)))
  (define t-arr (apply array (shape 0 t-len) (string->list t)))
  (letrec ((calc
            (^(i j)
              (lazy
               (match (cons i j)
                 ((_ . 0) (* i (- d)))
                 ((0 . _) (* j (- d)))
                 ((_ . _) (max (- (force (arr~ dp (- i 1) j)) d)
                               (- (force (arr~ dp i (- j 1))) d)
                               (+ (force (arr~ dp (- i 1) (- j 1)))
                                  (w (arr~ s-arr (- i 1))
                                     (arr~ t-arr (- j 1))))))
                 ))))
           (dp
            (tabulate-array
             (shape 0 (+ s-len 1) 0 (+ t-len 1)) calc)))
    (receive (s-align t-align) (split (path s-arr t-arr dp))
      (values
       (force (arr~ dp s-len t-len))
       s-align t-align)
      )))

(define (path s-arr t-arr dp)
  (define w (weight))
  (define d (gap-penalty))
  (let loop ((i (array-length s-arr 0))
             (j (array-length t-arr 0))
             (result ()))
    (if (and (= i 0) (= j 0))
        result
        (let1 dp-val (force (arr~ dp i j))
          (cond
           ((= dp-val (- (force (arr~ dp (- i 1) j)) d))
            (loop (- i 1) j
                  (cons (cons (arr~ s-arr (- i 1)) #f)
                        result)))
           ((= dp-val (- (force (arr~ dp i (- j 1))) d))
            (loop i (- j 1)
                  (cons (cons #f (arr~ t-arr (- j 1)))
                        result)))
           (else
            (loop (- i 1) (- j 1)
                  (cons (cons (arr~ s-arr (- i 1)) (arr~ t-arr (- j 1)))
                        result)))
           )))))

(define (split lst)
  (match lst
    (() (values () ()))
    (((x . y) . rest) (receive (xs ys) (split rest)
                        (values (cons x xs) (cons y ys))))))

実行結果:

gosh> (alignment "ABCD" "ACDE")
1
(#\A #\B #\C #\D #f)
(#\A #f #\C #\D #\E)

動的計画法は遅延評価のある言語だと漸化式を書くだけで綺麗に解ける、ということを示したかったのですが、Schemeだとそこまで綺麗になりませんでした。HaskellだとSTモナドを使ってdpテーブルを破壊的に更新するよりも100倍綺麗に書けます。

なお、普通の書き方をするとalignment関数は以下のようになります。

(define (alignment-destructive s t)
  (define w (weight))
  (define d (gap-penalty))
  (define s-len (string-length s))
  (define t-len (string-length t))
  (define s-arr (apply array (shape 0 s-len) (string->list s)))
  (define t-arr (apply array (shape 0 t-len) (string->list t)))
  (define dp
    (make-array
     (shape 0 (+ s-len 1) 0 (+ t-len 1)) #f))
  (define (calc! i j)
    (define val (arr~ dp i j))
    (or val
        (let1 x (match (cons i j)
                  ((_ . 0) (* i (- d)))
                  ((0 . _) (* j (- d)))
                  ((_ . _) (max (- (calc! (- i 1) j) d)
                                (- (calc! i (- j 1)) d)
                                (+ (calc! (- i 1) (- j 1))
                                   (w (arr~ s-arr (- i 1))
                                      (arr~ t-arr (- j 1))))))
                  )
          (array-set! dp i j x)
          x
          )))
  (calc! s-len t-len)
  (receive (s-align t-align) (split (path s-arr t-arr dp))
    (values
     (arr~ dp s-len t-len)
     s-align t-align)
    ))