Main.elm

module Main where

import Effects exposing (Never)
import StartApp
import Task
import Signal exposing (Signal)
import Task exposing (Task)
import Keyboard
import Char
import String
import Window
import VirtualDom as VD
import Json.Decode as JD exposing ((:=))
import Json.Encode as JE 
import Html
import Svg exposing (Svg, svg, rect, g, text, text', Attribute)
import Svg.Attributes exposing (..)
import Svg.Events exposing (onClick, onMouseUp, onMouseMove, onMouseDown, onMouseOut)

type alias Rect = 
  { x: Int  
  , y: Int
  , w: Int
  , h: Int
  }

type alias SRect = 
  { x: String  
  , y: String
  , w: String
  , h: String
  }

type alias Spec = 
  { name: String
  }

jsSpec : JD.Decoder Spec
jsSpec = JD.object1 Spec ("name" := JD.string)

-- MODEL

type alias Model =
  { name : String
  , rect: Rect
  , srect: SRect
  , pressed: Bool
  , location: Float
  }

init : Spec -> Rect 
  -> (Model, Effects.Effects Action)
init spec rect =
  ( Model (spec.name) 
          rect
          (SRect (toString (rect.x + 5)) 
                 (toString (rect.y + 5))
                 (toString (rect.w - 5))
                 (toString (rect.h - 5)))
          False 0.5 
  , Effects.none
  )

buttColor: Bool -> String
buttColor pressed = 
  case pressed of 
    True -> "#f000f0"
    False -> "#60B5CC"

-- UPDATE

type Action
    = SvgPress 
    | SvgUnpress 
    | Reply String 
    | ArbJson JE.Value

getY : JD.Decoder Int
getY = "offsetY" := JD.int 

update : Action -> Model -> (Model, Effects.Effects Action)
update action model =
  case action of
    SvgPress -> ({ model | pressed <- True}, Effects.none)
    SvgUnpress -> ({ model | pressed <- False}, Effects.none)
    Reply s -> ({model | name <- s}, Effects.none)
    ArbJson v -> 
      case (JD.decodeValue getY v) of 
        Ok i ->  
          ({model | location <- (toFloat (i - model.rect.y)) / toFloat model.rect.h }, Effects.none)
        Err e -> 
          ({model | name <- (JE.encode 2 v)}, Effects.none)

-- VIEW

(=>) = (,)

-- try VD.onWithOptions for preventing scrolling on touchscreens and 
-- etc. See virtualdom docs.

onClick : Signal.Address Action -> VD.Property
onClick address =
    VD.onWithOptions "click" (VD.Options True True) JD.value (\v -> Signal.message address (ArbJson v))

view : Signal.Address Action -> Model -> Html.Html
view address model =
  let ly = (floor (model.location * toFloat (model.rect.h)))
      sly = toString ly
   in
  Html.div [] (
    [Html.text "click on the rectangle below to see the problem", 
     Html.br [] [],
     Html.text "the line is supposed to be drawn at the click location.",
     Html.br [] [], 
     Html.text "in chromium this works, but not in firefox.",
     Html.br [] []] 
    ++ 
    [Svg.svg
      [ width model.srect.w
        , height model.srect.h
        , viewBox (model.srect.x ++ " " 
                 ++ model.srect.y ++ " " 
                 ++ model.srect.w ++ " "
                 ++ model.srect.h)
      ]
      [g [ onMouseDown (Signal.message address SvgPress)
         , onMouseMove (Signal.message address SvgPress)
         , onMouseUp (Signal.message address SvgUnpress)
         , onMouseOut (Signal.message address SvgUnpress)
         , onClick address
         ]
         [ rect
             [ x model.srect.x
             , y model.srect.y 
             , width model.srect.w
             , height model.srect.h
             , rx "2"
             , ry "2"
             , style "fill: #F1F1F1;"
             ]
             []
         , rect
             [ x model.srect.x
             , y sly 
             , width model.srect.w
             , height "3"
             , rx "2"
             , ry "2"
             , style ("fill: " ++ buttColor(model.pressed) ++ ";")
             ]
             []
         ]
       ]
    ])

----------------------------------------------------------------

app =
  StartApp.start
    { init = init 
        (Spec "nayme")
        (Rect 0 0 500 300)    
    , update = update
    , view = view
    , inputs = [ ]
    }

main =
  app.html

port tasks : Signal (Task.Task Never ())
port tasks =
  app.tasks

module Main where

import Effects exposing (Never)
import StartApp
import Task
import Signal exposing (Signal)
import Task exposing (Task)
import Keyboard
import Char
import String
import Window
import VirtualDom as VD
import Json.Decode as JD exposing ((:=))
import Json.Encode as JE 
import Html
import Svg exposing (Svg, svg, rect, g, text, text', Attribute)
import Svg.Attributes exposing (..)
import Svg.Events exposing (onClick, onMouseUp, onMouseMove, onMouseDown, onMouseOut)

type alias Rect = 
  { x: Int  
  , y: Int
  , w: Int
  , h: Int
  }

type alias SRect = 
  { x: String  
  , y: String
  , w: String
  , h: String
  }

type alias Spec = 
  { name: String
  }

jsSpec : JD.Decoder Spec
jsSpec = JD.object1 Spec ("name" := JD.string)

-- MODEL

type alias Model =
  { name : String
  , rect: Rect
  , srect: SRect
  , pressed: Bool
  , location: Float
  }

init : Spec -> Rect 
  -> (Model, Effects.Effects Action)
init spec rect =
  ( Model (spec.name) 
          rect
          (SRect (toString (rect.x + 5)) 
                 (toString (rect.y + 5))
                 (toString (rect.w - 5))
                 (toString (rect.h - 5)))
          False 0.5 
  , Effects.none
  )

buttColor: Bool -> String
buttColor pressed = 
  case pressed of 
    True -> "#f000f0"
    False -> "#60B5CC"

-- UPDATE

type Action
    = SvgPress 
    | SvgUnpress 
    | Reply String 
    | ArbJson JE.Value

getY : JD.Decoder Int
getY = "offsetY" := JD.int 

update : Action -> Model -> (Model, Effects.Effects Action)
update action model =
  case action of
    SvgPress -> ({ model | pressed <- True}, Effects.none)
    SvgUnpress -> ({ model | pressed <- False}, Effects.none)
    Reply s -> ({model | name <- s}, Effects.none)
    ArbJson v -> 
      case (JD.decodeValue getY v) of 
        Ok i ->  
          ({model | location <- (toFloat (i - model.rect.y)) / toFloat model.rect.h }, Effects.none)
        Err e -> 
          ({model | name <- (JE.encode 2 v)}, Effects.none)

-- VIEW

(=>) = (,)

-- try VD.onWithOptions for preventing scrolling on touchscreens and 
-- etc. See virtualdom docs.

onClick : Signal.Address Action -> VD.Property
onClick address =
    VD.onWithOptions "click" (VD.Options True True) JD.value (\v -> Signal.message address (ArbJson v))

view : Signal.Address Action -> Model -> Html.Html
view address model =
  let ly = (floor (model.location * toFloat (model.rect.h)))
      sly = toString ly
   in
  Html.div [] (
    [Html.text "click on the rectangle below to see the problem", 
     Html.br [] [],
     Html.text "the line is supposed to be drawn at the click location.",
     Html.br [] [], 
     Html.text "in chromium this works, but not in firefox.",
     Html.br [] []] 
    ++ 
    [Svg.svg
      [ width model.srect.w
        , height model.srect.h
        , viewBox (model.srect.x ++ " " 
                 ++ model.srect.y ++ " " 
                 ++ model.srect.w ++ " "
                 ++ model.srect.h)
      ]
      [g [ onMouseDown (Signal.message address SvgPress)
         , onMouseMove (Signal.message address SvgPress)
         , onMouseUp (Signal.message address SvgUnpress)
         , onMouseOut (Signal.message address SvgUnpress)
         , onClick address
         ]
         [ rect
             [ x model.srect.x
             , y model.srect.y 
             , width model.srect.w
             , height model.srect.h
             , rx "2"
             , ry "2"
             , style "fill: #F1F1F1;"
             ]
             []
         , rect
             [ x model.srect.x
             , y sly 
             , width model.srect.w
             , height "3"
             , rx "2"
             , ry "2"
             , style ("fill: " ++ buttColor(model.pressed) ++ ";")
             ]
             []
         ]
       ]
    ])

----------------------------------------------------------------

app =
  StartApp.start
    { init = init 
        (Spec "nayme")
        (Rect 0 0 500 300)    
    , update = update
    , view = view
    , inputs = [ ]
    }

main =
  app.html

port tasks : Signal (Task.Task Never ())
port tasks =
  app.tasks