dragMultipleCircles.elm

import Html exposing (Html)
import Html.Events exposing (..)
import Html.App as App
import Svg exposing (..)
import Svg.Attributes exposing (..)
import Mouse exposing (Position)
import Json.Decode as Json exposing((:=))

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

type alias Drag = {
    start : Position, 
    current : Position
}

type alias Circ = {
    pos : Position,
    drag : Maybe Drag
}

type alias Model = {
    circs : List Circ
}

makeCircs : Int -> (List Circ)
makeCircs i =
    if i == 0 then
        []
    else
        Circ (Position (i*10) (i*10)) Nothing :: (makeCircs (i-1))

init : (Model, Cmd Msg)
init = 
    (Model (makeCircs 1000), Cmd.none)

type Msg =
    DragStart Circ Position
    | DragAt Circ Position
    | DragEnd Circ Position

subCirc : Circ -> Maybe (Sub Msg) -> Maybe (Sub Msg)
subCirc n s =
    case s of 
        Nothing ->
            case n.drag of 
                Nothing ->
                    Nothing
                Just {start,current} ->
                    Just (Sub.batch [Mouse.moves (DragAt n), Mouse.ups (DragEnd n)])
        Just _ ->
            s

subscriptions : Model -> Sub Msg
subscriptions m = 
    let 
        s = List.foldr subCirc Nothing m.circs 
    in 
        case s of
            Nothing ->
                Sub.none
            Just s ->
                s

updateCirc : Msg -> Circ -> Circ
updateCirc msg circ =
   case msg of
        DragStart n p ->
            if n == circ then
                { circ | drag = Just (Drag p p)}
            else 
                circ
        DragAt n p ->
            { circ | drag = (Maybe.map (\s -> Drag s.start p) circ.drag) }
        DragEnd n p ->
            Circ (getPos circ) Nothing

update : Msg -> Model -> (Model, Cmd Msg)
update msg model =
    (Model (List.map (updateCirc msg) model.circs), Cmd.none)

view : Model -> Html Msg
view model = 
    Html.div [] [
            svg [ viewBox "0 0 1000 1000", width "1000px" ] 
                (List.map viewCirc model.circs)
        ]

viewCirc : Circ -> Svg.Svg Msg
viewCirc circ = 
    let 
        pos = getPos circ
        px = (toString pos.x)
        py = (toString pos.y)
    in 
        circle [ cx px, cy py, r "10", fill "#0B79CE", (onMouseDown circ) ] []

getPos : Circ -> Position
getPos {pos, drag} = 
    case drag of 
        Just {start, current} ->
            Position
                (pos.x + (current.x - start.x))
                (pos.y + (current.y - start.y))
        Nothing ->
            pos

onMouseDown : Circ -> Attribute Msg
onMouseDown circ =
  on "mousedown" (Json.map (DragStart circ) Mouse.position)