Skip to content

Instantly share code, notes, and snippets.

@pboyer
Created September 26, 2016 03:25
Show Gist options
  • Save pboyer/5e31934b5f33e3ca10edef54cad4ac31 to your computer and use it in GitHub Desktop.
Save pboyer/5e31934b5f33e3ca10edef54cad4ac31 to your computer and use it in GitHub Desktop.
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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment