CounterPair in Sync

CounterSync.elm

import Html exposing (Html, div, button, text)
import Html.App as App exposing (beginnerProgram)
import Html.Events exposing (onClick)
import Html.Attributes exposing (style)

main : Program Never
main =
  beginnerProgram { model = init (0,0) (0,0), view = view, update = update }

-- MODEL 

type alias Model = Int


type alias PairModel = 
  { left : Model
  , right : Model 
  }


type alias HighLvlModel = 
  { top : PairModel
  , bottom : PairModel
  }


initPair : Int -> Int -> PairModel
initPair left right = 
  PairModel left right


init : (Int, Int) -> (Int, Int) -> HighLvlModel
init (topleft, topRight) (bottomLeft, bottomRight) =
  HighLvlModel 
    (PairModel topleft topRight) 
    (PairModel bottomLeft bottomRight)

initFromPair : ( PairModel, PairModel ) -> HighLvlModel
initFromPair (top, bottom) = HighLvlModel top bottom

-- UPDATE 

type CounterMsg
  = Increment 
  | Decrement


type PairMsg 
  = Left CounterMsg
  | Right CounterMsg


type Msg 
  = Top PairMsg
  | Bottom PairMsg

counterUpdate : CounterMsg -> Model -> Model
counterUpdate msg model =
  case msg of 
    Increment -> model + 1
    Decrement -> model - 1

pairUpdate : PairMsg -> PairModel -> PairModel
pairUpdate msg {left, right} =
  case msg of
    Left counterMsg -> 
      PairModel (counterUpdate counterMsg left) right
    Right counterMsg -> 
      PairModel left (counterUpdate counterMsg right)

pairSyncUpdate : PairMsg -> PairModel -> PairModel-> (PairModel, PairModel)
pairSyncUpdate msg first second =
  case msg of
    Left counterMsg -> 
      (PairModel (counterUpdate counterMsg first.left) first.right
      , second)
    Right counterMsg -> 
      let 
        newRight = (counterUpdate counterMsg first.right)
      in
        (PairModel first.left newRight, PairModel second.left newRight)

update : Msg -> HighLvlModel -> HighLvlModel
update msg {top, bottom} =
  case msg of
    Top pairMsg -> 
      pairSyncUpdate pairMsg top bottom
      |> initFromPair

    Bottom pairMsg -> 
      pairSyncUpdate pairMsg bottom top
      |> (\(a,b)->(b,a)) 
      |> initFromPair 
      

-- VIEW 

counterView : String -> Model -> Html CounterMsg
counterView color model = 
  div [ style [("color", color), ("display", "inline-block")] ]
    [ button [ onClick Decrement ] [ text "-" ]
    , div [] [ text (toString model) ]
    , button [ onClick Increment ] [ text "+" ]
    ]

pairView : PairModel -> Html PairMsg
pairView model =
  div 
    [ style 
        [ ("background-color", "lightgray")
        , ("margin-bottom", "1rem")
        ]
    ]
    [ App.map Left (counterView "green" model.left)
    , App.map Right (counterView "red" model.right)
    ]

view : HighLvlModel -> Html Msg
view model = 
  div []
    [ App.map Top (pairView model.top) 
    , App.map Bottom (pairView model.bottom)
    ]