From f6f53d565c20a694fdc3e5ce380661ce1f99cef1 Mon Sep 17 00:00:00 2001 From: h7x4 Date: Mon, 11 Oct 2021 22:32:48 +0200 Subject: [PATCH] Initial commit --- .gitignore | 5 ++ Makefile | 4 ++ dist/app.html | 20 +++++++ dist/style.css | 86 ++++++++++++++++++++++++++ elm.json | 31 ++++++++++ src/Api.elm | 130 ++++++++++++++++++++++++++++++++++++++++ src/DrawingBoard.elm | 119 ++++++++++++++++++++++++++++++++++++ src/Main.elm | 116 +++++++++++++++++++++++++++++++++++ src/ResultFiltering.elm | 66 ++++++++++++++++++++ 9 files changed, 577 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile create mode 100644 dist/app.html create mode 100644 dist/style.css create mode 100644 elm.json create mode 100644 src/Api.elm create mode 100644 src/DrawingBoard.elm create mode 100644 src/Main.elm create mode 100644 src/ResultFiltering.elm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b0b94d2 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +elm-stuff +node_modules +dist/app.js +yarn.lock +package-lock.json \ No newline at end of file diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..d0e18cc --- /dev/null +++ b/Makefile @@ -0,0 +1,4 @@ +default: app.js + +app.js: src + elm make src/Main.elm --output=dist/app.js \ No newline at end of file diff --git a/dist/app.html b/dist/app.html new file mode 100644 index 0000000..02e49e7 --- /dev/null +++ b/dist/app.html @@ -0,0 +1,20 @@ + + + + + + Test + + + + + + + + diff --git a/dist/style.css b/dist/style.css new file mode 100644 index 0000000..279821c --- /dev/null +++ b/dist/style.css @@ -0,0 +1,86 @@ +body { + text-align: center; +} + +#canvas * { + border: solid black 2px; + border-radius: 10px; + background-color: wheat; + margin: 2em; +} + +#toggleButtons { + margin-bottom: 2em; +} + +#toggleButtons * { + padding: 0.2em 0.4em; + margin: 0em 0.2em; + border-radius: 10px; + color: white; + font-size: 2em; +} + +#response { + font-size: 2em; + margin-bottom: 1em; +} + +#clear { + font-size: 1.4em; + padding: 0.5em 1em; + border-radius: 10px; + color: white; + background-color: #222222; +} + +#clear:hover { + background-color: #464646; +} + +.activatedButton { + background-color: #4d9e2a; +} + +.activatedButton:hover { + background-color: #2d5e19; +} + +.deactivatedButton { + background-color: #fa2b2b; +} + +.deactivatedButton:hover { + background-color: #a11d1d; +} + +@media screen and (max-width: 600px) { + body { + margin: 0; + } + + #canvas { + border: solid black 2px; + border-radius: 10px; + background-color: wheat; + margin: 1em 0; + width: 80%; + } + + #toggleButtons { + margin-bottom: 1em; + } + + #toggleButtons * { + font-size: 1em; + } + + #response { + font-size: 1em; + margin-bottom: 0.5em; + } + + #clear{ + font-size: 0.7em; + } +} diff --git a/elm.json b/elm.json new file mode 100644 index 0000000..081fdce --- /dev/null +++ b/elm.json @@ -0,0 +1,31 @@ +{ + "type": "application", + "source-directories": [ + "src" + ], + "elm-version": "0.19.1", + "dependencies": { + "direct": { + "avh4/elm-color": "1.0.0", + "elm/browser": "1.0.2", + "elm/core": "1.0.5", + "elm/html": "1.0.0", + "elm/http": "2.0.0", + "elm/json": "1.1.3", + "elm/regex": "1.0.0", + "elm/time": "1.0.0", + "joakin/elm-canvas": "4.2.1", + "mpizenberg/elm-pointer-events": "4.0.2" + }, + "indirect": { + "elm/bytes": "1.0.8", + "elm/file": "1.0.5", + "elm/url": "1.0.0", + "elm/virtual-dom": "1.0.2" + } + }, + "test-dependencies": { + "direct": {}, + "indirect": {} + } +} diff --git a/src/Api.elm b/src/Api.elm new file mode 100644 index 0000000..15bdff6 --- /dev/null +++ b/src/Api.elm @@ -0,0 +1,130 @@ +module Api exposing (Msg(..), update) + +import Http exposing (expectJson) +import List exposing (map) +import Json.Decode as D exposing (Value) +import Json.Encode as E + +import DrawingBoard exposing (Stroke) + +api : String +api = "https://inputtools.google.com/request?itc=ja-t-i0-handwrit&app=translate" + +type alias APIRequest = { + app_version : Float + , api_level : String + , device : String + , input_type : Int + , options : String + , requests : List Request + } + +apiRequestEncoder : APIRequest -> Value +apiRequestEncoder request = + E.object + [ ("app_version", E.float request.app_version) + , ("api_level", E.string request.api_level) + , ("device", E.string request.device) + , ("input_type", E.int request.input_type) + , ("options", E.string request.options) + , ("requests", E.list requestEncoder request.requests) + ] + +type alias Request = { + writing_guide: WritingGuide + , pre_context: String + , max_num_results: Int + , max_completions: Int + , language: String + , ink: List RealStroke + } + +strokeEncoder : RealStroke -> Value +strokeEncoder = E.list(E.list(E.float)) + +requestEncoder : Request -> Value +requestEncoder request = + E.object + [ ("writing_guide", writingGuideEncoder request.writing_guide) + , ("pre_context", E.string request.pre_context) + , ("max_num_results", E.int request.max_num_results) + , ("max_completions", E.int request.max_completions) + , ("language", E.string request.language) + , ("ink", E.list strokeEncoder request.ink) + ] + +type alias WritingGuide = { + writing_area_width: Int + , writing_area_height: Int + } + +writingGuideEncoder : WritingGuide -> Value +writingGuideEncoder writingGuide= + E.object + [ ("writing_area_width", E.int writingGuide.writing_area_width) + , ("writing_area_height", E.int writingGuide.writing_area_height) + ] + +type Msg = SendRequest + | GotResponse (Result Http.Error (List String)) + +update : Msg -> List Stroke -> String -> (List String, Cmd Msg) +update msg strokes userAgent = + case msg of + SendRequest -> ([], sendKanjiRequest strokes userAgent) + GotResponse result -> + case result of + Ok kanji -> Debug.log "OK: " (kanji, Cmd.none) + Err e -> Tuple.second (Debug.log "ERR: " e, ([], Cmd.none)) + +kanjiDecoder : D.Decoder (List String) +kanjiDecoder = D.index 1 + <| D.index 0 + <| D.index 1 + <| D.list + <| D.oneOf [D.string] + +sendKanjiRequest : List Stroke -> String -> Cmd Msg +sendKanjiRequest strokes userAgent = Http.post + { body = generateRequestData strokes userAgent + |> apiRequestEncoder + |> Http.jsonBody + , expect = expectJson GotResponse kanjiDecoder + , url = api + } + +type alias RealStroke = List (List Float) + +convertStrokeToRealStroke : Stroke -> RealStroke +convertStrokeToRealStroke stroke = [ stroke.xs + , stroke.ys + , (map (\t -> t - stroke.startTime) stroke.times) + ] + +mockWritingGuide : WritingGuide +mockWritingGuide = + { writing_area_width = 500 + , writing_area_height = 500 + } + +max_results : Int +max_results = 10 + +generateRequestData : List Stroke -> String -> APIRequest +generateRequestData strokes userAgent = + { app_version = 0.4 + , api_level = "537.36" + , device = userAgent + , input_type = 0 + , options = "enable_pre_space" + , requests = + [ + { writing_guide = mockWritingGuide + , pre_context = "" + , max_num_results = max_results + , max_completions = 0 + , language = "ja" + , ink = (map convertStrokeToRealStroke strokes) + } + ] + } \ No newline at end of file diff --git a/src/DrawingBoard.elm b/src/DrawingBoard.elm new file mode 100644 index 0000000..2b35fbf --- /dev/null +++ b/src/DrawingBoard.elm @@ -0,0 +1,119 @@ +module DrawingBoard exposing (Point, Stroke, Msg(..), update, viewCanvas, addPendingPointToStrokes) + +import Html exposing (Html) +import Html.Attributes exposing (id) +import Html.Events.Extra.Mouse as Mouse +import Canvas exposing (..) +import Canvas.Settings as CS +import Canvas.Settings.Line as CS +import Color +import List exposing (map, map2, head, tail, reverse) +import Tuple exposing (pair) +import Maybe as M +import Time +import Task + +type alias Point = (Float, Float) + +type alias Stroke = { + xs : List Float + , ys : List Float + , times : List Float + , startTime : Float + } + +emptyStroke : Stroke +emptyStroke = {xs = [], ys = [], times = [], startTime = 0} + +type Msg = AddStroke Point + | UpdatePending Point + | EndStroke + | GotStartTime Time.Posix Stroke + | GotPendingPointTime Time.Posix Point + +{-| Update the stroke list based on mouse/touch events -} +update : Msg -> List Stroke -> Maybe Point -> ((List Stroke, Maybe Point), Cmd Msg) +update msg strokes pendingPoint = + case msg of + AddStroke point -> addEmptyStroke point strokes + UpdatePending point -> + case pendingPoint of + Just _ -> ((strokes, Just point), Cmd.none) + Nothing -> ((strokes, Nothing), Cmd.none) + EndStroke -> ((strokes, Nothing), Cmd.none) + GotStartTime time stroke -> ((strokes ++ [addStartTimeToStroke time stroke], pendingPoint), Cmd.none) + GotPendingPointTime time point -> ((updateStrokeWithTime strokes point time, pendingPoint), Cmd.none) + +applyToLastStroke : (Stroke -> Stroke) -> List Stroke -> List Stroke +applyToLastStroke func strokes = + let + reverseStrokes = reverse strokes + lastStroke = head reverseStrokes + strokesWithoutLastStroke = Maybe.map reverse <| tail reverseStrokes + in + (M.withDefault [] strokesWithoutLastStroke) ++ [func (M.withDefault emptyStroke lastStroke)] + +addEmptyStroke : Point -> List Stroke -> ((List Stroke, Maybe Point), Cmd Msg) +addEmptyStroke point strokes = + ((strokes, Just point), Task.perform (\t -> GotStartTime t emptyStroke) Time.now) + +processTime : Time.Posix -> Float +processTime time = toFloat <| (Time.posixToMillis time) // 1000 + +addStartTimeToStroke : Time.Posix -> Stroke -> Stroke +addStartTimeToStroke time stroke = {stroke | startTime = processTime time} + +updateStrokeWithTime : List Stroke -> Point -> Time.Posix -> List Stroke +updateStrokeWithTime strokes (x,y) time = + let + updateLastStroke stroke = + { stroke | + xs = stroke.xs ++ [x] + , ys = stroke.ys ++ [y] + , times = stroke.times ++ [processTime time] + } + + in + applyToLastStroke updateLastStroke strokes + +addPendingPointToStrokes : Maybe Point -> Cmd Msg +addPendingPointToStrokes point = + case point of + (Nothing) -> Cmd.none + (Just (x,y)) -> Task.perform (\t -> GotPendingPointTime t (x,y)) Time.now + +{-| Convert a stroke into a viewable shape for the canvas -} +strokeToPath : Stroke -> Shape +strokeToPath {xs, ys} = + let + start : Point + start = M.map2 pair (head xs) (head ys) + |> M.withDefault (0, 0) + + rest : List PathSegment + rest = M.map2 pair (tail xs) (tail ys) + |> M.map (\(list1, list2) -> map2 pair list1 list2) + |> M.withDefault [] + |> map lineTo + in + path start rest + +{-| Settings for all strokes to be drawn on the canvas -} +strokeStyle : List CS.Setting +strokeStyle = [ CS.stroke Color.black + , CS.lineWidth 2.0 + , CS.lineCap CS.RoundCap + , CS.lineJoin CS.RoundJoin + ] + +{-| Generate a canvas based on the current strokes -} +viewCanvas : List Stroke -> Html Msg +viewCanvas strokes = Canvas.toHtml (500, 500) + [ id "canvas" + , Mouse.onDown (\e -> AddStroke e.offsetPos) + , Mouse.onMove (\e -> UpdatePending e.offsetPos) + , Mouse.onUp (\_ -> EndStroke) + ] + [ clear (0,0) 500 500 + , shapes strokeStyle (map strokeToPath strokes) + ] \ No newline at end of file diff --git a/src/Main.elm b/src/Main.elm new file mode 100644 index 0000000..fbc7623 --- /dev/null +++ b/src/Main.elm @@ -0,0 +1,116 @@ +module Main exposing (Flags, Model, Msg, main, init, update, view) + +import Browser exposing (Document, document) +import Browser.Events exposing (onAnimationFrameDelta) -- https://github.com/joakin/elm-canvas/blob/master/examples/Drawing.elm#L27 +import Html exposing (Html, div, button, text) +import Html.Events exposing (onClick) +import Html.Attributes exposing (id, class) +import String exposing (String, join) + +import Api +import DrawingBoard exposing (Point, Stroke, Msg(..), viewCanvas, addPendingPointToStrokes) +import ResultFiltering as Filtering exposing (FilterState, Filter, filterUpdate, initFilterState) + +type alias Flags = + { userAgent : String + } + +main : Program Flags Model Msg +main = + document { + init = init + , update = update + , view = view + , subscriptions = subscriptions + } + +type alias Model = { + pendingPoint : Maybe Point + , strokes : List Stroke + , kanji : List String + , filters : FilterState + , userAgent : String + } + +type Msg = AnimationFrame Float + | StrokeUpdate DrawingBoard.Msg + | FilterUpdate Filtering.Msg + | ApiUpdate Api.Msg + | Clear + +init : Flags -> ( Model, Cmd Msg ) +init flags = ( + { pendingPoint = Nothing + , strokes = [] + , filters = initFilterState + , kanji = [] + , userAgent = flags.userAgent + } + , Cmd.none) + +update : Msg -> Model -> (Model, Cmd Msg) +update msg model = + case msg of + AnimationFrame _ -> + (model, Cmd.map StrokeUpdate <| addPendingPointToStrokes model.pendingPoint) + + StrokeUpdate EndStroke -> + update (ApiUpdate Api.SendRequest) {model | strokes = model.strokes, pendingPoint = Nothing} + + StrokeUpdate subMsg -> + DrawingBoard.update subMsg model.strokes model.pendingPoint + |> updateWith (\(strokes, pendingPoint) m -> {m | strokes = strokes, pendingPoint = pendingPoint}) StrokeUpdate model + + FilterUpdate subMsg -> + ({model | filters = filterUpdate subMsg model.filters}, Cmd.none) + + ApiUpdate subMsg -> + Api.update subMsg model.strokes model.userAgent + |> updateWith (\kanji m -> {m | kanji = kanji}) ApiUpdate model + + Clear -> ({model | strokes = [], pendingPoint = Nothing, kanji = []}, Cmd.none) + +{-| Update with methods to encapsulate the results into a new model and a new msg -} +updateWith : (subModel -> Model -> Model) -> (subMsg -> Msg) -> Model -> (subModel, Cmd subMsg) -> (Model, Cmd Msg) +updateWith toModel toMsg model (subModel, subCmd) = (toModel subModel model, Cmd.map toMsg subCmd) + +{-| Helper function to determine class name based on filter -} +buttonColor : Filter -> String +buttonColor (state, _) = if state then "activatedButton" else "deactivatedButton" + +{-| Helper function to generate a filter button -} +filterButton : String -> String -> Filter -> Filtering.Msg -> Html Msg +filterButton idText titleText filter filterMsg = + button [ id idText + , class <| buttonColor filter + , onClick <| FilterUpdate filterMsg + ] [text titleText] + +{-| Helper function to turn a list of kanji into a string -} +formatKanji : List String -> String +formatKanji kanji = + case kanji of + [] -> "None ¯\\_(ツ)_/¯" + _ -> join ", " kanji + +view : Model -> Document Msg +view model = + { title = "Google Handwriting Api" + , body = [ + div [] + [ (viewCanvas model.strokes |> (\subMsg -> Html.map StrokeUpdate subMsg)) + , div [id "toggleButtons"] + [ filterButton "toggleKanji" "Kanji" model.filters.kanji Filtering.Kanji + , filterButton "toggleHiragana" "Hiragana" model.filters.hiragana Filtering.Hiragana + , filterButton "toggleKatakana" "Katakana" model.filters.katakana Filtering.Katakana + , filterButton "toggleAll" "All" model.filters.all Filtering.All + ] + , div [id "response"] [text (formatKanji <| Filtering.postProcess model.kanji model.filters)] + , button [id "clear", onClick Clear] [text "Clear"] + ] + ] + } + +subscriptions : Model -> Sub Msg +subscriptions _ = + onAnimationFrameDelta AnimationFrame \ No newline at end of file diff --git a/src/ResultFiltering.elm b/src/ResultFiltering.elm new file mode 100644 index 0000000..2e37e44 --- /dev/null +++ b/src/ResultFiltering.elm @@ -0,0 +1,66 @@ +module ResultFiltering exposing (FilterState, Filter, Msg(..), initFilterState, filterUpdate, postProcess) + +import Regex as R +import Tuple exposing (first, second) +import List exposing (filter, head) +import Maybe as M +import List exposing (foldl) + +type alias CharRange = String +type alias Filter = (Bool, CharRange) + +type alias FilterState = { + kanji : Filter + , hiragana : Filter + , katakana : Filter + , all : Filter + } + +initFilterState : FilterState +initFilterState = { + kanji = (True, "一-龯") + , hiragana = (True, "ぁ–ゟ") + , katakana = (True, "゠-ヿ") + , all = (False, ".+") + } + +toggleFilterState : Filter -> Filter +toggleFilterState (b, r) = (not b, r) + +type Msg = Kanji + | Hiragana + | Katakana + | All + | Reset + +{-| Handle updates regarding the filter -} +filterUpdate : Msg -> FilterState -> FilterState +filterUpdate msg filters= + case msg of + Kanji -> { filters | kanji = toggleFilterState filters.kanji } + Hiragana -> { filters | hiragana = toggleFilterState filters.hiragana } + Katakana -> { filters | katakana = toggleFilterState filters.katakana } + All -> { filters | all = toggleFilterState filters.all } + Reset -> initFilterState + +{-| Filter out different kanji based on the current filters -} +postProcess : List String -> FilterState -> List String +postProcess xs filterState = + let + regex = + (if first filterState.all + then second filterState.all + else [ filterState.kanji, filterState.hiragana, filterState.katakana ] + |> List.map (\(b,r) -> if b then r else "") + |> foldl (++) "" + |> \s -> "^[" ++ s ++ "]*$") + |> R.fromString + |> M.withDefault R.never + + matchesRegex : String -> Bool + matchesRegex x = head (R.find regex x) + |> Maybe.map .match + |> Maybe.withDefault "" + |> (==) x + in + filter matchesRegex xs