Add drag/drop for slots.

client/elm.json

@@ -24,6 +24,7 @@
             "lattyware/elm-fontawesome": "4.0.0",
             "lattyware/elm-json-diff": "1.0.0",
             "myrho/elm-round": "1.0.4",
+            "norpan/elm-html5-drag-drop": "3.1.4",
             "norpan/elm-json-patch": "1.0.1",
             "pablohirafuji/elm-qrcode": "3.1.1",
             "truqu/elm-base64": "2.0.4"

client/src/elm/MassiveDecks/Card/Call.elm

@@ -36,9 +36,9 @@ view shared config side attributes call =
 
 {-| Render the call to HTML, with the slots filled with the given values.
 -}
-viewFilled : Shared -> Config -> Side -> List (Html.Attribute msg) -> Dict Int String -> Call -> Html msg
-viewFilled shared config side attributes fillWith call =
-    viewInternal shared config side attributes (Parts.viewFilled fillWith) call
+viewFilled : Shared -> Config -> Side -> List (Html.Attribute msg) -> Parts.SlotAttrs msg -> Dict Int String -> Call -> Html msg
+viewFilled shared config side attributes slotAttrs fillWith call =
+    viewInternal shared config side attributes (Parts.viewFilled slotAttrs fillWith) call
 
 
 {-| Render an unknown response to HTML, face-down.

client/src/elm/MassiveDecks/Card/Parts.elm

@@ -2,12 +2,13 @@ module MassiveDecks.Card.Parts exposing
     ( Fills
     , Part(..)
     , Parts
+    , SlotAttrs
     , Style(..)
     , Transform(..)
     , fillsFromPlay
     , fromList
-    , isSlot
     , missingSlotIndices
+    , nonObviousSlotIndices
     , slotCount
     , unsafeFromList
     , view
@@ -57,22 +58,16 @@ type alias Fills =
     Dict Int String
 
 
-{-| A collection of `Line`s. It is guaranteed to have at least one `Slot`.
+{-| A function to get attributes for a given slot index.
 -}
-type Parts
-    = Parts (List Line)
+type alias SlotAttrs msg =
+    Int -> List (Html.Attribute msg)
 
 
-{-| A predicate checking if a part is a slot.
+{-| A collection of `Line`s. It is guaranteed to have at least one `Slot`.
 -}
-isSlot : Part -> Bool
-isSlot part =
-    case part of
-        Slot _ _ _ ->
-            True
-
-        _ ->
-            False
+type Parts
+    = Parts (List Line)
 
 
 {-| Construct a `Parts` from a `List` of `Line`s. This will fail if there is not at least one `Slot`.
@@ -130,7 +125,7 @@ slotCount (Parts lines) =
 -}
 view : Parts -> List (Html msg)
 view parts =
-    viewFilled Dict.empty parts
+    viewFilled (always []) Dict.empty parts
 
 
 {-| Render the `Parts` to a string.
@@ -142,9 +137,9 @@ viewFilledString blankString play (Parts lines) =
 
 {-| Render the `Parts` with slots filled with the given values.
 -}
-viewFilled : Fills -> Parts -> List (Html msg)
-viewFilled play (Parts lines) =
-    viewLines play lines
+viewFilled : SlotAttrs msg -> Fills -> Parts -> List (Html msg)
+viewFilled slotAttrs play (Parts lines) =
+    viewLines slotAttrs play lines
 
 
 {-| Render lines to a string without needing a complete parts.
@@ -187,6 +182,17 @@ missingSlotIndices fills (Parts lines) =
     Set.diff expect filled
 
 
+{-| Returns true if slot indices aren't obvious (i.e: at least one is repeated).
+-}
+nonObviousSlotIndices : Parts -> Bool
+nonObviousSlotIndices (Parts lines) =
+    let
+        indices =
+            lines |> List.concat |> List.filterMap slotIndex
+    in
+    (indices |> List.length) /= (indices |> Set.fromList |> Set.size)
+
+
 
 {- Private -}
 
@@ -283,8 +289,8 @@ cluster parts =
     parts |> List.concatMap explode |> List.groupWhile isCluster |> List.map ((\( h, t ) -> h :: t) >> minimise)
 
 
-viewPart : Fills -> Part -> Html msg
-viewPart fills part =
+viewPart : SlotAttrs msg -> Fills -> Part -> Html msg
+viewPart slotAttrs fills part =
     let
         styleToElement style =
             case style of
@@ -314,28 +320,34 @@ viewPart fills part =
                 ( fillState, fill ) =
                     case fills |> Dict.get index of
                         Just text ->
-                            ( HtmlA.class "filled", [ Text text NoStyle ] |> cluster |> List.concatMap (viewCluster fills) )
+                            ( HtmlA.class "filled"
+                            , [ Text text NoStyle ] |> cluster |> List.concatMap (viewCluster slotAttrs fills)
+                            )
 
                         Nothing ->
                             ( HtmlA.class "empty", [] )
 
                 attrs =
                     List.concat
-                        [ [ HtmlA.class "slot", fillState, HtmlA.attribute "data-slot-index" (index + 1 |> String.fromInt) ]
+                        [ [ HtmlA.class "slot"
+                          , fillState
+                          , HtmlA.attribute "data-slot-index" (index + 1 |> String.fromInt)
+                          ]
+                        , slotAttrs index
                         , transformToAttrs transform
                         ]
             in
             styleToElement style attrs fill
 
 
-viewCluster : Fills -> List Part -> List (Html msg)
-viewCluster fills c =
+viewCluster : SlotAttrs msg -> Fills -> List Part -> List (Html msg)
+viewCluster slotAttrs fills c =
     case c of
         [] ->
             []
 
         first :: [] ->
-            [ viewPart fills first ]
+            [ viewPart slotAttrs fills first ]
 
         many ->
             let
@@ -354,14 +366,14 @@ viewCluster fills c =
                     else
                         []
             in
-            [ Html.span (HtmlA.class "cluster" :: growthAttrs) (many |> List.map (viewPart fills)) ]
+            [ Html.span (HtmlA.class "cluster" :: growthAttrs) (many |> List.map (viewPart slotAttrs fills)) ]
 
 
-viewLine : Fills -> List Part -> Html msg
-viewLine fills line =
-    Html.p [] (line |> cluster |> List.concatMap (viewCluster fills))
+viewLine : SlotAttrs msg -> Fills -> List Part -> Html msg
+viewLine slotAttrs fills line =
+    Html.p [] (line |> cluster |> List.concatMap (viewCluster slotAttrs fills))
 
 
-viewLines : Fills -> List (List Part) -> List (Html msg)
-viewLines fills =
-    List.map (viewLine fills)
+viewLines : SlotAttrs msg -> Fills -> List (List Part) -> List (Html msg)
+viewLines slotAttrs fills =
+    List.map (viewLine slotAttrs fills)

client/src/elm/MassiveDecks/Game.elm

@@ -17,6 +17,7 @@ import FontAwesome.Solid as Icon
 import Html exposing (Html)
 import Html.Attributes as HtmlA
 import Html.Events as HtmlE
+import Html5.DragDrop as DragDrop
 import MassiveDecks.Card.Call as Call
 import MassiveDecks.Card.Model as Card exposing (Call)
 import MassiveDecks.Card.Parts as Parts
@@ -138,6 +139,53 @@ update wrap shared msg model =
                 _ ->
                     ( model, Cmd.none )
 
+        Unpick slotId ->
+            case game.round of
+                Round.P playingRound ->
+                    let
+                        picks =
+                            playingRound.pick
+
+                        picked =
+                            picks.cards |> Dict.remove slotId
+
+                        newRound =
+                            Round.P { playingRound | pick = { picks | cards = picked } }
+                    in
+                    ( { model | game = { game | round = newRound } }, Cmd.none )
+
+                _ ->
+                    ( model, Cmd.none )
+
+        Drag dragDropMsg ->
+            let
+                ( dragDrop, result ) =
+                    DragDrop.update dragDropMsg model.dragDrop
+
+                newRound =
+                    case game.round of
+                        Round.P playingRound ->
+                            let
+                                picks =
+                                    playingRound.pick
+
+                                picked =
+                                    case result of
+                                        Just ( card, slotIndex, _ ) ->
+                                            picks.cards
+                                                |> Dict.filter (\_ p -> p /= card)
+                                                |> Dict.insert slotIndex card
+
+                                        Nothing ->
+                                            picks.cards
+                            in
+                            Round.P { playingRound | pick = { picks | cards = picked } }
+
+                        _ ->
+                            game.round
+            in
+            ( { model | game = { game | round = newRound }, dragDrop = dragDrop }, Cmd.none )
+
         EditBlank id text ->
             case game.round of
                 Round.P playingRound ->
@@ -945,7 +993,7 @@ viewWinnerListItem shared users user =
 viewRound : (Msg -> msg) -> Shared -> Lobby.Auth -> Time.Anchor -> Config -> Dict User.Id User -> Model -> List (Html msg)
 viewRound wrap shared auth timeAnchor config users model =
     let
-        ( call, { instruction, action, content, fillCallWith } ) =
+        ( call, { instruction, action, content, slotAttrs, fillCallWith, roundAttrs } ) =
             case model.completeRound of
                 Just completeRound ->
                     ( completeRound.call, Complete.view shared True config users completeRound )
@@ -968,7 +1016,7 @@ viewRound wrap shared auth timeAnchor config users model =
             model.game
 
         renderedCall =
-            call |> Call.viewFilled shared config Card.Front [] fillCallWith
+            call |> Call.viewFilled shared config Card.Front [] slotAttrs fillCallWith
     in
     [ Html.div [ HtmlA.id "top-content" ]
         [ case instruction |> Maybe.andThen (Maybe.justIf model.helpVisible) of
@@ -980,7 +1028,7 @@ viewRound wrap shared auth timeAnchor config users model =
         , timer timeAnchor model
         , Html.div [ HtmlA.class "top-row" ] [ minorActions wrap shared auth game model.helpVisible ]
         ]
-    , Html.div [ HtmlA.class "round" ] [ renderedCall, viewAction wrap shared action ]
+    , Html.div (HtmlA.class "round" :: roundAttrs) [ renderedCall, viewAction wrap shared action ]
     , content
     , Html.div [ HtmlA.class "scroll-top-spacer" ] []
 

client/src/elm/MassiveDecks/Game/History.elm

@@ -66,7 +66,7 @@ viewRound shared config users round =
         [ Html.div [ HtmlA.class "spacer" ]
             [ Html.div [ HtmlA.class "historic-call with-byline" ]
                 [ Plays.byLine shared users round.czar (Just ( "czar", Icon.gavel )) Nothing
-                , Call.viewFilled shared config Card.Front [] winningBody round.call
+                , Call.viewFilled shared config Card.Front [] (always []) winningBody round.call
                 ]
             ]
         , HtmlK.ul [ HtmlA.class "plays cards" ]

client/src/elm/MassiveDecks/Game/Messages.elm

@@ -1,5 +1,6 @@
 module MassiveDecks.Game.Messages exposing (Msg(..))
 
+import Html5.DragDrop as DragDrop
 import MassiveDecks.Card.Model as Card
 import MassiveDecks.Card.Play as Play
 import MassiveDecks.Game.Model exposing (..)
@@ -10,6 +11,8 @@ import MassiveDecks.User as User
 
 type Msg
     = Pick (Maybe Int) Card.Id
+    | Unpick Int
+    | Drag (DragDrop.Msg Card.Id Int)
     | EditBlank Card.Id String
     | Fill Card.Id String
     | Submit

client/src/elm/MassiveDecks/Game/Model.elm

@@ -10,7 +10,9 @@ module MassiveDecks.Game.Model exposing
 
 import Dict exposing (Dict)
 import Html exposing (Html)
+import Html5.DragDrop as DragDrop
 import MassiveDecks.Card.Model as Card
+import MassiveDecks.Card.Parts as Parts
 import MassiveDecks.Game.Action.Model exposing (Action)
 import MassiveDecks.Game.Player exposing (Player)
 import MassiveDecks.Game.Round as Round exposing (Round)
@@ -34,6 +36,7 @@ type alias Model =
     , helpVisible : Bool
     , confetti : Bool
     , discarded : List ( User.Id, Card.Response )
+    , dragDrop : DragDrop.Model Card.Id Int
     }
 
 
@@ -51,6 +54,7 @@ emptyModel game =
     , helpVisible = False
     , confetti = False
     , discarded = []
+    , dragDrop = DragDrop.init
     }
 
 
@@ -73,7 +77,9 @@ type alias RoundView msg =
     { instruction : Maybe MdString
     , action : Maybe Action
     , content : Html msg
+    , slotAttrs : Parts.SlotAttrs msg
     , fillCallWith : Dict Int String
+    , roundAttrs : List (Html.Attribute msg)
     }
 
 

client/src/elm/MassiveDecks/Game/Round/Complete.elm

@@ -34,7 +34,9 @@ view shared nextRoundReady config users round =
                 |> List.map (\u -> ( u, Dict.get u round.plays ))
                 |> List.map (viewPlay shared config users round.winner)
             )
+    , slotAttrs = always []
     , fillCallWith = winning |> Maybe.map (.play >> Parts.fillsFromPlay) |> Maybe.withDefault Dict.empty
+    , roundAttrs = []
     }
 
 

client/src/elm/MassiveDecks/Game/Round/Judging.elm

@@ -59,7 +59,9 @@ view wrap auth shared config round =
     { instruction = Just instruction
     , action = action
     , content = details |> Plays.view [ ( "judging", True ), ( "is-czar", isCzar ) ] round.pick
+    , slotAttrs = always []
     , fillCallWith = picked
+    , roundAttrs = []
     }