Chanomic Blog

Elmメモ ドラッグ移動の実現(2) - elm-draggableの利用

(last modified:
)

tags:

categories:

前回はBrowsertやSvgなどの標準的なパッケージを利用してドラッグ機能を実現した。今回はelm-draggableというパッケージを使ってドラッグ機能を実現してみる。

準備

Elmのプロジェクトを作成して、src/Main.elmとsrc/Circle.elmを作成。

Circle.elm

前回と同じなのでコードだけ載せる。

module Circle exposing (..)


type alias Id =
    Int


type alias Circle =
    { id : Id
    , x : Float
    , y : Float
    , r : Float
    }


type alias Circles =
    { all : List Circle
    , nextId : Id
    }


empty : Circles
empty =
    { all = []
    , nextId = 0
    }


type alias CircleNoId =
    { x : Float
    , y : Float
    , r : Float
    }


add : CircleNoId -> Circles -> Circles
add c circles =
    let
        circle =
            { id = circles.nextId
            , x = c.x
            , y = c.y
            , r = c.r
            }
    in
    { circles
        | all = circle :: circles.all
        , nextId = circles.nextId + 1
    }


fromList : List CircleNoId -> Circles
fromList list =
    { all = List.indexedMap (\i c -> { id = i, x = c.x, y = c.y, r = c.r }) list
    , nextId = List.length list
    }


toList : Circles -> List Circle
toList circles =
    circles.all


update : Id -> (Circle -> Circle) -> Circles -> Circles
update id f circles =
    let
        new =
            List.foldr
                (\c acc ->
                    if c.id == id then
                        f c :: acc

                    else
                        c :: acc
                )
                []
                circles.all
    in
    { circles | all = new }

Main.elm

Circlesを描画するところまで書く。

module Main exposing (..)

import Browser
import Circle as C exposing (Circle, CircleNoId, Circles, Id)
import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events exposing (..)
import Json.Decode as JD
import Svg as S exposing (Svg)
import Svg.Attributes as SA
import Svg.Events as SE


main =
    Browser.element
        { init = init
        , update = update
        , view = view
        , subscriptions = subscriptions
        }


type alias Model =
    { circles : Circles
    }


init : () -> ( Model, Cmd Msg )
init _ =
    ( { circles =
            C.fromList
                [ CircleNoId 10 10 10
                , CircleNoId 20 100 20
                , CircleNoId 250 250 30
                ]
      }
    , Cmd.none
    )


type Msg
    = Dummy


update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
    ( model, Cmd.none )


view : Model -> Html Msg
view model =
    div []
        [ viewSvg model
        ]


viewSvg : Model -> Svg Msg
viewSvg model =
    S.svg
        [ style "width" "500px"
        , style "height" "500px"
        , style "border" "1px solid #000"
        ]
        [ viewCircles model
        ]


viewCircles : Model -> Svg Msg
viewCircles model =
    S.g []
        (List.map (viewCircle model) (C.toList model.circles))


viewCircle : Model -> Circle -> Svg Msg
viewCircle model circle =
    S.g [ SA.transform (translate circle.x circle.y) ]
        [ S.circle
            [ SA.r (String.fromFloat circle.r)
            , SA.fill "#fff"
            , SA.stroke "#000"
            ]
            []
        ]


translate : Float -> Float -> String
translate x y =
    "translate(" ++ String.fromFloat x ++ "," ++ String.fromFloat y ++ ")"


subscriptions : Model -> Sub Msg
subscriptions model =
    Sub.none

elm-draggableのインストール

$ elm install zaboco/elm-draggable

src/Main.elmにて、DraggableとDraggable.Eventsをimportする。

import Draggable as D
import Draggable.Events as DE

elm-draggableの仕組み

Usageを読むと、次のような仕組みでドラッグを管理しているとわかる。

Modelの追加

dragを追加する。ついでにドラッグ中のCircleのidをholdとして持たせておく。dragはDraggable.initで初期化しなければいけないようなのでその通りにする。

type alias Model =
    { ...
    , hold : Maybe Id
    , drag : D.State Id
    }


init : () -> ( Model, Cmd Msg )
init _ =
    ( { ...
      , hold = Nothing
      , drag = D.init
      }
    , Cmd.none
    )

ドラッグイベントの指定

Draggable.mouseTriggerをcircle要素に指定する。第1引数には、ドラッグの対象となる要素の識別子を指定する。今回はCircleのIdを指定する。

type Msg
    = DragMsg (D.Msg Id)

...

viewCircle : Model -> Circle -> Svg Msg
viewCircle model circle =
    S.g [ ... ]
        [ S.circle
            [ ...
            , D.mouseTrigger circle.id DragMsg
            ]
            []
        ]

ドキュメントに明言はされていないが、おそらくmouseTriggerはマウスが押下されたときに起こるイベント。ドラッグ中はDraggable.subscriptionsで監視する。

subscriptions : Model -> Sub Msg
subscriptions model =
    D.subscriptions DragMsg model.drag

ドラッグイベントを受け取る

Modelが持つdragはドラッグ状態(ドラッグ開始/中/終了など)を持っている。ただし、この状態を直接のぞくことはできない。ドラッグ状態はMsgとして取得する。具体的には、以下のようにする。

まず、どんな状態が欲しいのかをMsgとして定義する。D.Deltaとはマウスの移動量を表す型で、(Float, Float)のエイリアス。

type Msg
    = DragMsg (D.Msg Id)
    | OnDragStart Id
    | OnDragBy D.Delta
    | OnDragEnd

どのMsgにどの状態を対応させるのかを、D.customConfigに定義する。Draggable.Event.onDragStartはドラッグ開始を意味する。Draggable.Event.onDragByはドラッグ中を意味する。Draggable.Event.onDragStartはドラッグ終了を意味する。それぞれの状態がどんな情報を持っているのかについてはドキュメントを読むと分かる。

dragConfig : D.Config Id Msg
dragConfig =
    D.customConfig
        [ DE.onDragStart OnDragStart
        , DE.onDragBy OnDragBy
        , DE.onDragEnd OnDragEnd
        ]

DragMsgを受け取ったとき、Draggable.upateを用いてdragを更新する。この際に、上で定義したdragConfigを利用する。恐らくこのときに、OnDragStart Id、OnDragBy D.Delta、OnDragEndのいずれかを発生させるようなコマンドが作られる。

update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
    case msg of
        DragMsg dragMsg ->
            D.update dragConfig dragMsg model

そこで、各ドラッグ状態に対応したMsgについて、Modelの更新処理を書く。

update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
    case msg of
        ...

        OnDragStart id ->
            ( { model | hold = Just id }
            , Cmd.none
            )

        OnDragBy ( dx, dy ) ->
            ( { model
                | circles = updateCircles model dx dy
              }
            , Cmd.none
            )

        OnDragEnd ->
            ( { model | hold = Nothing }
            , Cmd.none
            )


updateCircles : Model -> Float -> Float -> Circles
updateCircles model dx dy =
    case model.hold of
        Nothing ->
            model.circles

        Just id ->
            C.update id
                (\c -> { c | x = c.x + dx, y = c.y + dy })
                model.circles

これで円をドラッグして移動できるようになった。「ドラッグ中は円の色を変える」処理については、前回とまったく同じなので省略。

補足: Msgを発行するコマンド

OnDragStartやOnDragByはどこから発行されているのか、についてはUsageの最初の段落で述べられている。

どうやら、任意のMsgを作るコマンドは、Taskを用いて作ることができるようだ。例えば以下のようにすると、Fooを発行するコマンドを作成することができる。

Task.perform identity (Task.succeed Foo)

Task.succeed Fooで、常にFooという値を返すTaskを作成する。Task.performは、第2引数のTaskを実行して、その結果を第1引数に適用してMsgを発行する。identityは恒等関数なので、結局FooそのものをMsgとして発行する。

この手法についてはElm-CommunityのFAQにも載っている。しかしそこにも書かれているが、わざわざコマンドを作成して非同期処理にするよりも、単にupdateを再帰呼び出しすれば十分なことが多い。

つまり、

update : Msg -> Model -> Cmd Msg
update msg model =
    Foo ->
      ...

    Bar ->
      (model
      , Task.perform identity (Task.succeed Foo)
      )

とするより、

update : Msg -> Model -> Cmd Msg
update msg model =
    Foo ->
      ...

    Bar ->
      update Foo model

とすれば十分なことが多い。

ただ前者を用いた良いケースもあるようで、FAQでは、

The former option may be attractive when recursive calls to update could cause an infinite loop, or for authors of reusable components interested in creating a clean encapsulation of their library’s internal behavior.

意訳: 前者の選択肢は、updateを再帰呼び出しすると無限ループを引き起こしたり、また再利用可能なコンポーネントの作者が、ライブラリの内部状態をきれいにカプセル化することに関心がある場合に魅力的かもしれない。

とある。

参考