Swipeable Pages in Elm

swipepageselm.elm

import Html exposing (Html)
import Html.Attributes 
import Html.Events
import Mouse
import Signal exposing (Signal, Address)
import StartApp
import Json.Decode exposing ((:=))

import List


(=>) = (,)

decoder = 
  Json.Decode.object2 (,)
    ("pageX" := Json.Decode.int)
    ("pageY" := Json.Decode.int)
    
    
event string address constructor = 
  Html.Events.on string decoder (constructor >> Signal.message address)
  
onMouseDown : Address a -> ((Int, Int) -> a) -> Html.Attribute
onMouseDown = 
  event "mousedown"
  
onMouseUp = 
  event "mouseup"
  
onMouseMove = 
  event "mousemove"
  
onMouseOut = 
  event "mouseout"

  
  
viewTest color = 
  let 
      elemStyle = 
        [ "background-color" => color
        , "width" => "100%"
        , "height" => "100%"
        ]
        
  in 
      Html.div 
        [ Html.Attributes.style elemStyle ]
        []


type alias Container a = 
  { pages       : List a
  , pageWidth   : Int 
  , currentPage : Int 
  , threshold   : Float
  , isDragging  : Bool
  , startDragPosition : (Int, Int)
  , currentDragPosition : (Int, Int)
  }
  
container = 
  { pages = ["red", "green", "blue", "yellow", "gray", "violet", "black"]
  , pageWidth = 500
  , currentPage = 1
  , threshold = 0.3
  , isDragging = False
  , startDragPosition = (0,0)
  , currentDragPosition = (0,0)
  }
  


type DragAction 
  = Start (Int, Int)
  | Drag  (Int, Int)
  | End   (Int, Int)


main = 
  StartApp.start
    { model = container
    , view = view viewTest
    , update = update
    }

view : (a -> Html) -> Address DragAction -> Container a ->  Html
view renderPage address container = 
  let 
      getX n = 
        if not container.isDragging 
        then 
          (n - container.currentPage + 1) * container.pageWidth 
        else 
          let 
              (lx, ly) = container.startDragPosition
              (cx, cy) = container.currentDragPosition
              
              delta = toFloat (cx - lx)
              
              cantDrag = 
                (delta < 0 && (container.currentPage >= List.length container.pages)) ||
                (delta > 0 && (container.currentPage <= 1))
                
              ratio = 
                delta / (toFloat container.pageWidth)
          in 
            if cantDrag 
            then 
              (n - container.currentPage + 1) * container.pageWidth 
            else
              (n - container.currentPage + 1) * container.pageWidth + (floor (ratio * toFloat container.pageWidth))
  
      transition = 
        if container.isDragging 
        then
          ""
        else 
          "left 0.3s ease-out"
  
      pageStyle n = 
        [ "position" => "absolute"
        , "top" => "0px"
        , "left" => (toString (getX n) ++ "px")
        , "width" => (toString container.pageWidth ++ "px")
        , "height" => "500px"
        , "transition" => transition
        ]
        
      page n content = 
        Html.div 
            [ Html.Attributes.style (pageStyle n) ]
            [ renderPage content ]
        
      pageContainerStyle = 
        [ "position" => "absolute"
        , "width" => (toString container.pageWidth ++ "px")
        , "height" => "500px"
        , "cursor" => "pointer"
        , "overflow" => "hidden"
        ]
  in 
      Html.div 
         [ onMouseDown address Start 
         , onMouseMove address Drag
         , onMouseUp address End
         , onMouseOut address End
         , Html.Attributes.style pageContainerStyle
         ]
         ( List.indexedMap page container.pages )



update : DragAction -> Container a -> Container a
update action container = 
  case action of 
    Start (x,y) -> 
      { container | isDragging <- True 
                  , startDragPosition  <- (x,y)
                  , currentDragPosition <- (x,y)
      }
      
    Drag (x,y) -> 
      if not container.isDragging 
      then 
        container 
      else 
        { container | currentDragPosition <- (x,y)
        }
        
    End (x,y) -> 
      if not container.isDragging
      then 
        container
      else 
        let delta = 
              x - fst container.startDragPosition
            
            dirRight = 
              delta < 0
              
            cantDrag = 
              (delta < 0 && (container.currentPage >= List.length container.pages)) ||
              (delta > 0 && (container.currentPage <= 1))
              
            
            hasCrossedThreshold = 
              toFloat (abs delta) / (toFloat container.pageWidth) > container.threshold
              
            nextPage = 
              if not hasCrossedThreshold || cantDrag
              then 
                container.currentPage
              else 
                if dirRight 
                then 
                  container.currentPage + 1  
                else 
                  container.currentPage - 1
        in 
          { container | currentDragPosition <- (x,y)
                      , isDragging <- False
                      , currentPage <- nextPage
          }

0.17 version maybe?