subtree(users/wpcarro): docking briefcase at '24f5a642' r/3226

git-subtree-dir: users/wpcarro
git-subtree-mainline: 464bbcb15c09813172c79820bcf526bb10cf4208
git-subtree-split: 24f5a642af3aa1627bbff977f0a101907a02c69f
Change-Id: I6105b3762b79126b3488359c95978cadb3efa789

1 files changed, 194 insertions, 0 deletions

diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/Piano.elm b/users/wpcarro/website/sandbox/learnpianochords/src/Piano.elm
new file mode 100644
index 000000000000..d231f1467438
--- /dev/null
+++ b/users/wpcarro/website/sandbox/learnpianochords/src/Piano.elm
@@ -0,0 +1,194 @@
+module Piano exposing (render)
+
+import Browser
+import Html exposing (..)
+import Html.Attributes exposing (..)
+import Html.Events exposing (..)
+import List.Extra
+import Theory
+import UI
+
+
+type alias KeyMarkup a =
+    { offset : Int
+    , isHighlit : Bool
+    , note : Theory.Note
+    , isRootNote : Bool
+    }
+    -> Html a
+
+
+type alias Props =
+    { chord : Maybe Theory.Chord
+    , firstNote : Theory.Note
+    , lastNote : Theory.Note
+    }
+
+
+naturalThickness : Int
+naturalThickness =
+    105
+
+
+accidentalThickness : Int
+accidentalThickness =
+    round (toFloat naturalThickness / 2.0)
+
+
+{-| Convert an integer into its pixel representation for CSS.
+-}
+pixelate : Int -> String
+pixelate x =
+    String.fromInt x ++ "px"
+
+
+{-| Return the markup for either a white or a black key.
+-}
+pianoKey : KeyMarkup a
+pianoKey { offset, isHighlit, note, isRootNote } =
+    let
+        { natColor, accColor, hiColor, rootColor } =
+            { natColor = "bg-white"
+            , accColor = "bg-black"
+            , hiColor = "bg-red-400"
+            , rootColor = "bg-red-600"
+            }
+
+        sharedClasses =
+            [ "box-border"
+            , "absolute"
+            , "border"
+            , "border-black"
+            ]
+
+        { keyLength, keyThickness, keyColor, offsetEdge, extraClasses } =
+            case Theory.keyClass note of
+                Theory.Natural ->
+                    { keyLength = "w-screen"
+                    , keyThickness = naturalThickness
+                    , keyColor = natColor
+                    , offsetEdge = "top"
+                    , extraClasses = []
+                    }
+
+                Theory.Accidental ->
+                    { keyLength = "w-2/3"
+                    , keyThickness = accidentalThickness
+                    , keyColor = accColor
+                    , offsetEdge = "top"
+                    , extraClasses = [ "z-10" ]
+                    }
+    in
+    div
+        [ class
+            (case ( isHighlit, isRootNote ) of
+                ( False, _ ) ->
+                    keyColor
+
+                ( True, True ) ->
+                    rootColor
+
+                ( True, False ) ->
+                    hiColor
+            )
+        , class keyLength
+        , style "height" (pixelate keyThickness)
+        , style offsetEdge (String.fromInt offset ++ "px")
+        , class <| String.join " " (List.concat [ sharedClasses, extraClasses ])
+        ]
+        []
+
+
+{-| A section of the piano consisting of all twelve notes.
+-}
+keys :
+    { start : Theory.Note
+    , end : Theory.Note
+    , highlitNotes : List Theory.Note
+    , rootNote : Maybe Theory.Note
+    }
+    -> List (Html a)
+keys { start, end, highlitNotes, rootNote } =
+    let
+        isHighlit note =
+            List.member note highlitNotes
+
+        spacing prevOffset prev curr =
+            case ( Theory.keyClass prev, Theory.keyClass curr ) of
+                ( Theory.Natural, Theory.Accidental ) ->
+                    prevOffset + naturalThickness - round (toFloat accidentalThickness / 2)
+
+                ( Theory.Accidental, Theory.Natural ) ->
+                    prevOffset + round (toFloat accidentalThickness / 2)
+
+                ( Theory.Natural, Theory.Natural ) ->
+                    prevOffset + naturalThickness
+
+                -- This pattern should never hit.
+                _ ->
+                    prevOffset
+
+        ( _, _, notes ) =
+            Theory.notesFromRange start end
+                |> List.reverse
+                |> List.foldl
+                    (\curr ( prevOffset, prev, result ) ->
+                        case ( prevOffset, prev ) of
+                            ( Nothing, Nothing ) ->
+                                ( Just 0
+                                , Just curr
+                                , pianoKey
+                                    { offset = 0
+                                    , isHighlit = List.member curr highlitNotes
+                                    , note = curr
+                                    , isRootNote =
+                                        rootNote
+                                            |> Maybe.map (\x -> x == curr)
+                                            |> Maybe.withDefault False
+                                    }
+                                    :: result
+                                )
+
+                            ( Just po, Just p ) ->
+                                let
+                                    offset =
+                                        spacing po p curr
+                                in
+                                ( Just offset
+                                , Just curr
+                                , pianoKey
+                                    { offset = offset
+                                    , isHighlit = List.member curr highlitNotes
+                                    , note = curr
+                                    , isRootNote =
+                                        rootNote
+                                            |> Maybe.map (\x -> x == curr)
+                                            |> Maybe.withDefault False
+                                    }
+                                    :: result
+                                )
+
+                            -- This pattern should never hit.
+                            _ ->
+                                ( Nothing, Nothing, [] )
+                    )
+                    ( Nothing, Nothing, [] )
+    in
+    notes
+
+
+{-| Return the HTML that renders a piano representation.
+-}
+render : Props -> Html a
+render { chord } =
+    div [ style "display" "flex" ]
+        (keys
+            { start = Theory.G3
+            , end = Theory.C6
+            , rootNote = chord |> Maybe.map .note
+            , highlitNotes =
+                chord
+                    |> Maybe.andThen Theory.notesForChord
+                    |> Maybe.withDefault []
+            }
+        )