diff --git a/.github/workflows/elm-to-gh-pages.yml b/.github/workflows/elm-to-gh-pages.yml index 08b7e9c..fd9fefc 100644 --- a/.github/workflows/elm-to-gh-pages.yml +++ b/.github/workflows/elm-to-gh-pages.yml @@ -4,7 +4,7 @@ name: Deploy an Elm app to GitHub Pages on: # Runs on pushes targeting the default branch push: - branches: ["main"] + # branches: ["main", "] # Allows you to run this workflow manually from the Actions tab workflow_dispatch: @@ -44,7 +44,7 @@ jobs: uses: actions/upload-pages-artifact@v1 with: path: '.' - + - name: Deploy to GitHub Pages id: deployment uses: actions/deploy-pages@v2 diff --git a/elm.json b/elm.json index d2ca61a..6c47605 100644 --- a/elm.json +++ b/elm.json @@ -9,12 +9,12 @@ "elm/browser": "1.0.2", "elm/core": "1.0.5", "elm/html": "1.0.0", + "elm/json": "1.1.3", "elm-explorations/test": "2.2.0", "mdgriffith/elm-ui": "1.1.8" }, "indirect": { "elm/bytes": "1.0.8", - "elm/json": "1.1.3", "elm/random": "1.0.0", "elm/time": "1.0.0", "elm/url": "1.0.0", diff --git a/notes.md b/notes.md index 1e961c8..4e331cf 100644 --- a/notes.md +++ b/notes.md @@ -17,5 +17,7 @@ implement logic - [x] new module word - [x] refactor word using suggestion from redInk style guide: https://github.com/NoRedInk/elm-style-guide?tab=readme-ov-file#identifiers - [x] test suite -- [ ] implement logic -- [ ] link with main \ No newline at end of file +- [x] implement logic +- [x] link with main + - [x] refactor word logic using algebric types "MatchLetter" + - [x] refactor model diff --git a/src/Main.elm b/src/Main.elm index 7dbd247..0c6e425 100644 --- a/src/Main.elm +++ b/src/Main.elm @@ -1,35 +1,38 @@ -module Main exposing (main, tileFontColor) +module Main exposing (main) import Array exposing (Array) import Browser +import Browser.Events import Element exposing (..) import Element.Background as Background import Element.Border as Border +import Element.Events as Ev import Element.Font as Font import Html exposing (Html) -import Html.Events exposing (onClick) +import Html.Events +import Json.Decode as Decode +import Word exposing (..) main = - Browser.sandbox { init = init, update = update, view = view } + Browser.element { init = init, update = update, view = view, subscriptions = subscriptions } type alias Model = - { guesses : List Word - , current : Word + { guesses : List (List MatchedChar) + , current : List Char , solution : List Char } -init : Model -init = - { guesses = - [ testGuess1 - , testGuess2 - ] - , current = testCurrent - , solution = testSolution - } +init : () -> ( Model, Cmd Msg ) +init _ = + ( { guesses = [] + , current = [] + , solution = testSolution + } + , Cmd.none + ) type Msg @@ -38,9 +41,85 @@ type Msg | Confirm -update : Msg -> Model -> Model +update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = - model + let + currentGuessLen = + List.length model.current + in + ( case msg of + KeyPressed c -> + -- Add to the current solution as long as it's shorter than 5, + -- then just ignore letters + if currentGuessLen < 5 then + Debug.log "Pressed" { model | current = model.current ++ [ Char.toUpper c ] } + + else + model + + Confirm -> + -- Confirmation can happen only if guess has length 5 + if currentGuessLen < 5 then + model + + else + confirmGuess model + + Backspace -> + -- Remove last character from current, as long as it's not empty + Debug.log "Chomped" { model | current = List.take (currentGuessLen - 1) model.current } + , Cmd.none + ) + + +confirmGuess : Model -> Model +confirmGuess model = + let + matched = + rematch model.current model.solution + in + { model | current = [], guesses = model.guesses ++ [ matched ] } + + + +--- SUBSCRIPTIONS + + +subscriptions : Model -> Sub Msg +subscriptions m = + -- Let's decode the `key` field as a string, then try to decode + -- the string and see if it is a valid character: if the character is invalid, + -- the decoding should fail and no message shall be send: only Enter, + -- Backspace and letters are valid. + Browser.Events.onKeyDown + (Decode.andThen decodeKey (Decode.field "key" Decode.string)) + + + +-- Take a string and returns a decoder: it will succeed for Enter, Backpace and +-- ASCII alphas, but fail for anything else + + +decodeKey : String -> Decode.Decoder Msg +decodeKey str = + case str of + "Enter" -> + Decode.succeed Confirm + + "Backspace" -> + Decode.succeed Backspace + + _ -> + case String.uncons str of + Just ( ch, "" ) -> + if Char.isAlpha ch then + Decode.succeed (KeyPressed ch) + + else + Decode.fail "Not alpha" + + _ -> + Decode.fail "Another control" @@ -53,7 +132,7 @@ view model = (column [ width (fill |> maximum 500), height fill, centerX, bgCyan ] [ viewHeader , viewGridArea model - , viewKeyboardArea + , viewKeyboardArea model ] ) @@ -83,31 +162,16 @@ viewHeaderButton = ---- GRID - - -type Match - = No --grey - | Exact --green - | Almost --yellow - | Unmatched --white - - -type alias Letter = - { char : Char - , match : Match - } +-- A tile in the game, it can be empty or contains a matched char type Tile = EmptyTile - | FilledTile Letter - - -type alias Word = - List Tile + | FilledTile MatchedChar + | UncheckedTile Char +viewGridArea : Model -> Element Msg viewGridArea model = el [ bgYell, width fill, height (fillPortion 2) ] (viewGrid model) @@ -116,69 +180,66 @@ emptyTile = EmptyTile -testWord : Word -testWord = - [ FilledTile { char = 'A', match = No } - , FilledTile { char = 'B', match = Exact } - , FilledTile { char = 'C', match = Almost } - , FilledTile { char = 'D', match = Unmatched } - , EmptyTile - ] +testSolution = + [ 'B', 'U', 'F', 'F', 'A' ] -testGuess1 = - [ FilledTile { char = 'P', match = No } - , FilledTile { char = 'O', match = No } - , FilledTile { char = 'S', match = No } - , FilledTile { char = 'T', match = No } - , FilledTile { char = 'A', match = Exact } - ] +emptyWord = + List.repeat 5 emptyTile -testGuess2 = - [ FilledTile { char = 'F', match = Almost } - , FilledTile { char = 'U', match = Exact } - , FilledTile { char = 'R', match = No } - , FilledTile { char = 'B', match = Almost } - , FilledTile { char = 'A', match = Exact } - ] +-- Given a list, it will take the first n element from it; if there are less, +-- they are filled with padFill. -testCurrent = - [ FilledTile { char = 'B', match = Unmatched } - , FilledTile { char = 'U', match = Unmatched } - , FilledTile { char = 'F', match = Unmatched } - ] +padRightTake : Int -> f -> List f -> List f +padRightTake n padFill aList = + List.take n (aList ++ List.repeat n padFill) -testSolution = - [ 'B', 'U', 'F', 'F', 'A' ] -emptyWord = - List.repeat 5 emptyTile +-- Convert a list matched chars into a list of (filled) tiles -padRightTake n padFill aList = - List.take n (aList ++ List.repeat n padFill) +tiledGuess : List MatchedChar -> List Tile +tiledGuess x = + List.map FilledTile x +getWords : Model -> List (List Tile) getWords model = + let + -- Convert previous guesses into tiles + tiledGuesses = + List.map tiledGuess model.guesses + + -- Convert current guess into tiles + tiledCurrent = + List.map (\c -> UncheckedTile c) model.current + + -- Pad current guess + paddedCurrent = + padRightTake 5 EmptyTile tiledCurrent + in padRightTake 6 emptyWord - (model.guesses ++ [ padRightTake 5 EmptyTile model.current ]) + (tiledGuesses ++ [ paddedCurrent ]) +viewGrid : Model -> Element Msg viewGrid model = + -- column [ centerX, centerY, spacing 5 ] (List.map viewTileRow (getWords model)) column [ centerX, centerY, spacing 5 ] (List.map viewTileRow (getWords model)) +viewTileRow : List Tile -> Element Msg viewTileRow word = row [ spacing 5 ] (List.map viewTile - (padRightTake 5 emptyTile word) + (padRightTake 5 EmptyTile word) ) @@ -187,19 +248,19 @@ tileBgColor tile = EmptyTile -> bgWhite - FilledTile { match } -> + FilledTile match -> case match of - No -> + Missing _ -> bgDarkGray - Exact -> + Exact _ -> bgGreen - Almost -> + Present _ -> bgYellow - Unmatched -> - bgWhite + UncheckedTile _ -> + bgWhite tileBorderColor tile = @@ -207,37 +268,48 @@ tileBorderColor tile = EmptyTile -> colorGray - FilledTile { match } -> + FilledTile match -> case match of - No -> + Missing _ -> colorDarkGray - Exact -> + Exact _ -> colorGreen - Almost -> + Present _ -> colorYellow - Unmatched -> - colorBlack + UncheckedTile _ -> + colorDarkGray -tileFontColor : Match -> Color +tileFontColor : MatchedChar -> Color tileFontColor match = case match of - No -> + Missing _ -> colorWhite - Exact -> + Exact _ -> colorWhite - Almost -> + Present _ -> colorWhite - Unmatched -> - colorBlack +tileChar : MatchedChar -> Char +tileChar match = + case match of + Missing c -> + c + + Exact c -> + c + Present c -> + c + + +viewTile : Tile -> Element Msg viewTile tile = el [ width (px 62) @@ -257,15 +329,26 @@ viewTileChar tile = EmptyTile -> el [ centerX, centerY ] (text (String.fromChar ' ')) - FilledTile ftile -> + FilledTile match -> el [ centerX , centerY - , Font.color (tileFontColor ftile.match) + , Font.color (tileFontColor match) , Font.size 32 , Font.bold ] - (text (String.fromChar ftile.char)) + (text (String.fromChar (tileChar match))) + + UncheckedTile ch -> + el + [ centerX + , centerY + + -- , Font.color (tileFontColor match) + , Font.size 32 + , Font.bold + ] + (text (String.fromChar ch)) @@ -278,15 +361,17 @@ type Keyboard | KeyEnter -viewKeyboardArea = - el [ bgPink, width fill, height (fillPortion 1) ] viewKeyboard +viewKeyboardArea : Model -> Element Msg +viewKeyboardArea model = + el [ bgPink, width fill, height (fillPortion 1) ] (viewKeyboard model) -viewKeyboard = +viewKeyboard : Model -> Element Msg +viewKeyboard model = column [ centerX, centerY, spacing 5 ] - [ viewKeyboardRow (List.map Key (String.toList "QWERTYUIOP")) - , viewKeyboardRow (List.map Key (String.toList "ASDFGHJKL")) - , viewKeyboardRow ((KeyEnter :: List.map Key (String.toList "ZXCVBNM")) ++ [ KeyBackspace ]) + [ viewKeyboardRow model (List.map Key (String.toList "QWERTYUIOP")) + , viewKeyboardRow model (List.map Key (String.toList "ASDFGHJKL")) + , viewKeyboardRow model ((KeyEnter :: List.map Key (String.toList "ZXCVBNM")) ++ [ KeyBackspace ]) ] @@ -311,16 +396,99 @@ viewKeyString k = "<-" -viewMakeButton : Keyboard -> Element msg -viewMakeButton k = - el [ bgCyan, height (px 58), width (px (viewKeyWidth k)) ] +viewKeyEvent k = + case k of + Key c -> + Ev.onClick (KeyPressed c) + + KeyBackspace -> + Ev.onClick Backspace + + KeyEnter -> + Ev.onClick Confirm + + + +-- bestLetterColor : Model -> Char -> Element.Attr d m + + +bestLetterColor model char = + let + improve : MatchedChar -> MatchedChar -> MatchedChar + improve ch st = + case ch of + Missing c -> + -- We cannot improve with another missing char, leave state as is + st + + Exact c -> + if c == char then + -- If we find an exact match, that's the best possible + Exact char + + else + -- The character is different, leave state as is + st + + Present c -> + if c == char then + case st of + Missing _ -> + Present char + + _ -> + st + + else + st + + -- Initially, we say that char is missing + initialState = + Missing char + in + -- bgYell + List.foldl improve initialState (List.concat model.guesses) + + + +-- Returns the color of a keyboard button depending on matching of past guesses + + +buttonColor model k = + -- TODO the color is the "best" match found so far for a letter: if C is + -- Present in the first guess (yellow) and Exact in the second guess (green) + -- the C key should be colored green. + case k of + Key ch -> + tileBgColor (FilledTile (bestLetterColor model ch)) + + KeyBackspace -> + bgCyan + + KeyEnter -> + bgCyan + + + +-- Creates the element for a keyboard button. It will highlight the element +-- depending on the current guesses. + + +viewMakeButton : Model -> Keyboard -> Element Msg +viewMakeButton model k = + el + [ buttonColor model k + , height (px 58) + , width (px (viewKeyWidth k)) + , viewKeyEvent k + ] (el [ centerX, centerY ] (text (viewKeyString k))) -viewKeyboardRow : List Keyboard -> Element msg -viewKeyboardRow keys = +viewKeyboardRow : Model -> List Keyboard -> Element Msg +viewKeyboardRow model keys = row [ spacing 5, centerX ] - (List.map viewMakeButton keys) + (List.map (viewMakeButton model) keys) diff --git a/src/Word.elm b/src/Word.elm index 57e76aa..7843a4e 100644 --- a/src/Word.elm +++ b/src/Word.elm @@ -1,60 +1,171 @@ -module Word exposing (..) -import Test exposing (Test, describe, test) +module Word exposing (MatchedChar(..), rematch, suite) + import Expect +import Test exposing (Test, describe, test) + + +type MatchedChar + = Missing Char --grey + | Exact Char --green + | Present Char --yellow + + +toMatched : List Char -> List Char -> List MatchedChar +toMatched matchStatus chars = + List.map2 + (\m c -> + case m of + 'e' -> + Exact c + + 'p' -> + Present c + + _ -> + Missing c + ) + matchStatus + chars + + + +-- Prepend element to second element of a tuple +-- (1, [9, 8, 7]) 10 -> (1, [10, 9, 8, 7]) + -type Match - = No --grey - | Exact --green - | Almost --yellow - | Unmatched --white +t2prepend : ( t, List t ) -> t -> ( t, List t ) +t2prepend ( a, y ) x = + ( a, x :: y ) -type alias Letter = - { char : Char - , match : Match - } +-- finder looks for a (guessed) character inside a list of previously matched chars; +-- returns the state of the match and a new list of matched chars. +-- E.g. 'F' in 'bUffA' -> 'bUFfA' (upper case is a match) -type Tile - = EmptyTile - | FilledTile Letter +finder : Char -> List MatchedChar -> List Char -> ( MatchedChar, List MatchedChar ) +finder g matchState solution = + case ( matchState, solution ) of + ( [], _ ) -> + ( Missing g, [] ) -type Word - = Word (List Tile) + ( _, [] ) -> + ( Missing g, [] ) -fromCharList : List Char -> Word -fromCharList chars = - Word (List.map (\char -> FilledTile { char = char, match = Unmatched }) chars) + ( (Missing c) :: ls, l :: ll ) -> + if g == l then + -- We found the char matching with a unassigned character + ( Present g, Present g :: ls ) + else + t2prepend (finder g ls ll) (Missing c) -zip a b = - List.map2 Tuple.pair a b + -- If it's Exact or Present, then we skip the letter and try the next one. + ( m :: ls, l :: ll ) -> + t2prepend (finder g ls ll) m -matchExactTile : (Letter, Letter) -> (Letter, Letter) -matchExactTile ( a, b ) = - if a.char == b.char then - ( { a | match = Exact }, { b | match = Exact } ) - -- default format with a blank line -> error when pasting in elm repl - else - ( a, b ) +-- Given a guess and a solution, returns a list of matched characters +-- Does not handle the case of guess longer than soludion -matchExact ( sol, guess ) = - List.unzip (List.map matchExactTile (zip sol guess)) + +rematch : List Char -> List Char -> List MatchedChar +rematch guess solution = + let + equalChars : List MatchedChar + equalChars = + List.map2 + (\g s -> + if g == s then + Exact g + + else + Missing g + ) + guess + solution + + matchGuessChars : Int -> List Char -> List MatchedChar -> List Char -> List MatchedChar + matchGuessChars i gue state target = + case ( gue, List.drop i state ) of + -- It's over when there are no more letters in the guess to match. + ( [], _ ) -> + [] + + -- If the state is empty, we cannot match anything + ( _, [] ) -> + [] + + ( g :: gs, (Exact _) :: ss ) -> + -- If a letter is an exact match, it means we found it already + -- so no need to find it. Let's proceed to the next letter. + Exact g :: matchGuessChars (i + 1) gs state target + + ( g :: gs, _ :: ss ) -> + -- Not sure if this letter is present: let's search for it + -- in the whole solution. This might update the state. + case finder g state target of + ( Exact _, newState ) -> + Exact g :: matchGuessChars (i + 1) gs newState target + + ( Missing _, newState ) -> + Missing g :: matchGuessChars (i + 1) gs newState target + + ( Present _, newState ) -> + Present g :: matchGuessChars (i + 1) gs newState target + in + matchGuessChars 0 guess equalChars solution suite : Test suite = + let + testMatch g s e = + let + guess = + String.toList g + + solution = + String.toList s + + expect = + String.toList e + in + test (g ++ "-" ++ s ++ "=" ++ e) <| + \_ -> + Expect.equal (rematch guess solution) (toMatched expect guess) + in describe "Wordle Match Logic" - [ describe "MatchExact" [ - test "FURBA -> BUFFA" <| + [ describe "MatchExact" + [ testMatch "FURBA" "BUFFA" "pe.pe" + , testMatch "BABBA" "CACCA" ".e..e" + , testMatch "BAA" "CCB" "p.." + , testMatch "SMAL" "Soooosoos" "e..." + , testMatch "LLxxx" "yyLLL" "pp..." + , testMatch "yyLLL" "LLxxx" "..pp." + , testMatch "AxyA" "zAAw" "p..p" + + -- Pattern longer than solution is not supported by rematch + -- , testMatch "longer" "smal" "p....." + -- , testMatch "ABB" "AA" "e.." + ] + , describe "finding" + [ test "B in FuRbBo" <| \_ -> - let - guess = "FURBA" - solution = "BUFFA" - in - Expect.equal guess solution - ] + Expect.equal + (finder 'B' [ Missing 'F', Exact 'U', Missing 'R', Exact 'B', Missing 'B', Missing 'O' ] [ 'F', 'U', 'R', 'B', 'B', 'O' ]) + ( Present 'B', [ Missing 'F', Exact 'U', Missing 'R', Exact 'B', Present 'B', Missing 'O' ] ) + , test "B in Rbbo" <| + \_ -> + Expect.equal + (finder 'B' [ Missing 'R', Exact 'B', Present 'B', Missing 'O' ] [ 'R', 'B', 'B', 'O' ]) + ( Missing 'B', [ Missing 'R', Exact 'B', Present 'B', Missing 'O' ] ) + , test "finding F(URBA) in (B)UFFA" <| + \_ -> + Expect.equal + (finder 'F' [ Exact 'U', Missing 'F', Missing 'F', Exact 'A' ] [ 'U', 'F', 'F', 'A' ]) + ( Present 'F', [ Exact 'U', Present 'F', Missing 'F', Exact 'A' ] ) + ] ]