Skip to content

Instantly share code, notes, and snippets.

@pdamoc
Created June 21, 2016 09:15
Show Gist options
  • Save pdamoc/a6c259b417d15e933fa10c9b3716e0c3 to your computer and use it in GitHub Desktop.
Save pdamoc/a6c259b417d15e933fa10c9b3716e0c3 to your computer and use it in GitHub Desktop.
update to valid data
import Html exposing (..)
import Html.App as App
import Html.Events exposing (on, onClick)
import Html.Attributes exposing (style)
import Mouse exposing (Position)
import Json.Decode as Json
-- MODEL
type alias Rectangle =
{ from : Position
, to : Position
, complete : Bool
}
type alias Model =
Maybe Rectangle
init : Model
init =
Nothing
-- UPDATE
type Msg
= Down Position
| Move Position
| Up Position
updateToMax200 : Position -> Rectangle -> Rectangle
updateToMax200 { x, y } rect =
let
newX =
rect.from.x + (min 200 (x - rect.from.x))
in
{ rect | to = { x = newX, y = y } }
updateComplete : Bool -> Rectangle -> Rectangle
updateComplete complete rect =
{ rect | complete = complete }
present : Msg -> Model -> Model
present msg model =
case (Debug.log "msg" msg) of
Down pos ->
Just (Rectangle pos pos False)
Move pos ->
Maybe.map (updateToMax200 pos) model
Up pos ->
Maybe.map (updateToMax200 pos >> updateComplete True) model
-- VIEW
px : number -> String
px n =
(toString n) ++ "px"
representation : Rectangle -> Html a
representation rect =
let
w =
rect.to.x - rect.from.x
h =
rect.to.y - rect.from.y
in
div
[ style
[ ( "width", px w )
, ( "height", px h )
, ( "top", px rect.from.y )
, ( "left", px rect.from.x )
, ( "border", "1px solid black" )
, ( "position", "relative" )
, ( "backgroundColor"
, if rect.complete then
"green"
else
"red"
)
]
]
[]
render : Model -> Html Msg
render model =
let
rect =
case model of
Nothing ->
text ""
Just rect ->
representation rect
in
div
[ style [ ( "width", "100vw" ), ( "height", "100vh" ), ( "background", "lightgrey" ) ]
, onMouseDown
]
[ rect
]
onMouseDown : Attribute Msg
onMouseDown =
on "mousedown" (Json.map Down Mouse.position)
-- WIRING
subscriptions : Model -> Sub Msg
subscriptions model =
case model of
Nothing ->
Sub.none
Just rect ->
if rect.complete then
Sub.none
else
Sub.batch [ Mouse.moves Move, Mouse.ups Up ]
main : Program Never
main =
App.program
{ init = init ! []
, update = \msg model -> present msg model ! []
, view = render
, subscriptions = subscriptions
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment