四角をドラングアンドドロップするプログラム

Main.elm

module Main exposing (main)

import Browser exposing (Document)
import Browser.Events
import Json.Decode as Dec exposing (Decoder)
import Svg exposing (Svg)
import Svg.Attributes as Attr
import Svg.Events



-- MAIN


main : Program Flags Model Msg
main =
    Browser.document
        { init = init
        , subscriptions = subscriptions
        , update = update
        , view = view
        }



-- MODEL


type alias Flags =
    { winWidth : Float
    , winHeight : Float
    }


type alias Model =
    { winSize : Size
    , mousePos : Pos
    , draggingStatus : DraggingStatus
    , rect : Rect
    }


type DraggingStatus
    = NotDragging
    | Dragging Offset


type alias Rect =
    { pos : Pos
    , size : Size
    }


type alias Pos =
    { x : Float
    , y : Float
    }


type alias Size =
    { width : Float
    , height : Float
    }


type alias Offset =
    { offsetX : Float
    , offsetY : Float
    }


init : Flags -> ( Model, Cmd Msg )
init { winWidth, winHeight } =
    withCmdNone
        { winSize = { width = winWidth, height = winHeight }
        , mousePos = { x = 0, y = 0 }
        , draggingStatus = NotDragging
        , rect = { pos = { x = 50, y = 50 }, size = { width = 100, height = 100 } }
        }



-- UPDATE


type Msg
    = BrowserResize Size
    | MouseMove Pos
    | MouseUp Pos
    | StartDragging Offset


subscriptions : Model -> Sub Msg
subscriptions _ =
    let
        resizeMsg : (Size -> a) -> Int -> Int -> a
        resizeMsg f width height =
            f { width = toFloat width, height = toFloat height }

        mousePosDecoder : (Pos -> a) -> Decoder a
        mousePosDecoder f =
            Dec.map2 (\x y -> f { x = x, y = y })
                (Dec.field "offsetX" Dec.float)
                (Dec.field "offsetY" Dec.float)
    in
    Sub.batch
        [ Browser.Events.onResize (resizeMsg BrowserResize)
        , Browser.Events.onMouseMove (mousePosDecoder MouseMove)
        , Browser.Events.onMouseUp (mousePosDecoder MouseUp)
        ]


update : Msg -> Model -> ( Model, Cmd Msg )
update msg model =
    case msg of
        BrowserResize winSize ->
            withCmdNone { model | winSize = winSize }

        MouseMove mousePos ->
            withCmdNone <| mouseMoveEvent { model | mousePos = mousePos }

        MouseUp _ ->
            withCmdNone { model | draggingStatus = NotDragging }

        StartDragging offset ->
            withCmdNone { model | draggingStatus = Dragging offset }


mouseMoveEvent : Model -> Model
mouseMoveEvent model0 =
    case model0.draggingStatus of
        NotDragging ->
            model0

        Dragging offset ->
            let
                prevRect : Rect
                prevRect =
                    model0.rect

                rect : Rect
                rect =
                    { prevRect | pos = addPos model0.mousePos (negOffset offset) }
            in
            { model0 | rect = rect }


withCmdNone : a -> ( a, Cmd msg )
withCmdNone value =
    ( value, Cmd.none )


addPos : Pos -> Offset -> Pos
addPos { x, y } { offsetX, offsetY } =
    { x = x + offsetX
    , y = y + offsetY
    }


subPos : Pos -> Pos -> Offset
subPos pos1 pos2 =
    { offsetX = pos1.x - pos2.x
    , offsetY = pos1.y - pos2.y
    }


negOffset : Offset -> Offset
negOffset { offsetX, offsetY } =
    { offsetX = negate offsetX
    , offsetY = negate offsetY
    }



-- VIEW


view : Model -> Document Msg
view model =
    let
        fStr : Float -> String
        fStr =
            String.fromFloat

        sizeString { width, height } =
            fStr width ++ " " ++ fStr height

        rectSvg : Rect -> Svg Msg
        rectSvg { pos, size } =
            Svg.rect
                [ Attr.x <| fStr pos.x
                , Attr.y <| fStr pos.y
                , Attr.width <| fStr size.width
                , Attr.height <| fStr size.height
                , Attr.fill "red"
                , Svg.Events.onMouseDown <|
                    StartDragging (subPos model.mousePos model.rect.pos)
                ]
                []

        body =
            [ Svg.svg
                [ Attr.viewBox ("0 0 " ++ sizeString model.winSize) ]
                [ rectSvg model.rect ]
            ]
    in
    { title = "Drag and Drop"
    , body = body
    }