SVG Drag and Drop

Main.elm

module Main exposing (main)

import Array exposing (Array)
import Html exposing (Html)
import Json.Decode as Decode
import Svg
import Svg.Attributes as Attributes
import Svg.Events as Events


type alias CircleAttributes =
    { cx : Int
    , cy : Int
    , r : Int
    }


type Draggable = Circle CircleAttributes


type alias DragEvent =
    { index : Int
    , target : Draggable
    , dx : Int
    , dy : Int
    }
    

type alias Model =
    { dragEvent : Maybe DragEvent    
    , width : Int
    , height : Int
    , draggables : Array Draggable
    }
    

model = 
    { dragEvent = Nothing
    , width = 400
    , height = 400
    , draggables = 
        Array.fromList
            [ Circle <| CircleAttributes 50 50 40 
            , Circle <| CircleAttributes 250 250 20
            ]
    }
    

type Msg 
    = MouseDown Int Draggable Int Int 
    | MouseMove Int Int
    | MouseUp


update msg model = 
    case msg of
        MouseDown index target x y ->
            { model | dragEvent = Just <| DragEvent index target x y }
            
        MouseMove x y ->
            case model.dragEvent of
                Nothing ->
                    model
                
                Just { index, target, dx, dy } ->
                    case target of
                        Circle attributes ->
                            let
                                circle = Circle { attributes 
                                                | cx = x - dx + attributes.cx
                                                , cy = y - dy + attributes.cy
                                            }
                            in
                                { model 
                                    | draggables = Array.set index circle model.draggables 
                                    , dragEvent = Just <| DragEvent index circle x y
                                }
            
        MouseUp ->
            { model | dragEvent = Nothing }


draggableView index draggable =
    case draggable of
        Circle circle ->
            Svg.circle
                [ Attributes.cx 
                    <| toString circle.cx
                , Attributes.cy 
                    <| toString circle.cy
                , Attributes.r 
                    <| toString circle.r
                , Attributes.fill "yellow"
                , Attributes.stroke "green"
                , Attributes.strokeWidth "4"
                , onMouseDown <| MouseDown index draggable
                ]
                []


view model =
    Svg.svg 
        [ Attributes.width 
            <| toString model.width
        , Attributes.height 
            <| toString model.height
        , onMouseMove MouseMove
        , Events.onMouseUp MouseUp
        ]
        <| Array.toList 
        <| Array.indexedMap draggableView model.draggables
        
        
mousePositionDecoder msg =
    Decode.map2 msg 
        (Decode.field "clientX" Decode.int)
        (Decode.field "clientY" Decode.int)
        
        
onMouseDown msg =
    Events.on "mousedown" <| mousePositionDecoder msg
            
            
onMouseMove msg =
    Events.on "mousemove" <| mousePositionDecoder msg
        

main : Program Never Model Msg
main =
    Html.beginnerProgram
        { model = model
        , update = update
        , view = view
        }