elm-mdl/Material/Ripple.elm

module Material.Ripple where

import Html exposing (..)
import Html.Attributes exposing (..)
import Html.Events
import Json.Decode as Json exposing ((:=), at)
import Effects exposing (Effects, tick, none)

import Material.Aux exposing (Rectangle, rectangleDecoder, effect)


-- MODEL


type alias Metrics =
  { rect : Rectangle
  , x : Float
  , y : Float
  }


type Animation
  = Frame Int -- There is only 0 and 1.
  | Inert


type alias Model =
  { animation : Animation
  , metrics : Maybe Metrics
  }


model : Model
model =
  { animation = Inert
  , metrics = Nothing
  }


-- ACTION, UPDATE


type alias Geometry =
  { rect : Rectangle
  , clientX : Maybe Float
  , clientY : Maybe Float
  , touchX : Maybe Float
  , touchY : Maybe Float
  }


geometryDecoder : Json.Decoder Geometry
geometryDecoder =
  Json.object5 Geometry
    rectangleDecoder
    (Json.maybe ("clientX" := Json.float))
    (Json.maybe ("clientY" := Json.float))
    (Json.maybe (at ["touches", "0", "clientX"] Json.float))
    (Json.maybe (at ["touches", "0", "clientY"] Json.float))


computeMetrics : Geometry -> Metrics
computeMetrics g =
  let
    rect = g.rect
    set x y = (x - rect.left, y - rect.top)
    (x,y) = case (g.clientX, g.clientY, g.touchX, g.touchY) of
      (Just 0.0, Just 0.0, _, _) ->
        (rect.width / 2.0, rect.height / 2.0)

      (Just x, Just y, _, _) ->
        set x y

      (_, _, Just x, Just y) ->
        set x y

      _ ->
        Debug.crash "Impossible value from geometryDecoder"
  in
    { rect = rect
    , x = x
    , y = y
    }


type Action
  = Down Geometry
  | Up
  | Tick


update : Action -> Model -> (Model, Effects Action)
update action model =
  case action of
    Down geometry ->
      { model
      | animation = Frame 0
      , metrics = computeMetrics geometry |> Just
      }
      |> effect (tick <| \_ -> Tick)

    Up ->
      { model
      | animation = Inert
      }
      |> effect none

    Tick ->
      { model
      | animation = Frame 1
      }
      |> effect none



-- VIEW


downOn : String -> Signal.Address Action -> Attribute
downOn name addr =
  Material.Aux.on
    name
    { preventDefault = False
    , stopPropagation = False
    , withGeometry = True
    }
    geometryDecoder
    (Down >> Signal.message addr)


upOn : String -> Signal.Address Action -> Attribute
upOn name addr =
  Html.Events.on
    name
    (Json.succeed ())
    ((\_ -> Up) >> Signal.message addr)


styles : Metrics -> Int -> List (String, String)
styles m frame =
  let
    scale = if frame == 0 then "scale(0.0001, 0.0001)" else ""
    toPx k = (toString (round k))  ++ "px"
    offset = "translate(" ++ toPx m.x ++ ", " ++ toPx m.y ++ ")"
    transformString = "translate(-50%, -50%) " ++ offset ++ scale
    r = m.rect
    rippleSize = sqrt (r.width * r.width + r.height * r.height) * 2 + 2 |> toPx
  in
    [ ("width", rippleSize)
    , ("height", rippleSize)
    , ("-webkit-transform", transformString)
    , ("-ms-transform", transformString)
    , ("transform", transformString)
    ]


view : Signal.Address Action -> List Attribute -> Model -> Html
view addr attrs model =
  let
    styling =
      case (model.metrics, model.animation) of
        (Just metrics, Frame frame) -> styles metrics frame
        (Just metrics, Inert) -> styles metrics 1 -- Hack.
        _ -> []
  in
    span
      (  downOn "mousedown" addr
      :: downOn "touchstart" addr
      :: upOn "mouseup" addr
      :: upOn "mouseleave" addr
      :: upOn "touchend" addr
      :: upOn "blur" addr
      :: attrs
      )
      [ span
          [ classList
              [ ("mdl-ripple", True)
              , ("is-animating", model.animation /= Frame 0)
              , ("is-visible", model.animation /= Inert)
              ]
          , style styling
          ]
          []
      ]