Initial commit

2021-10-11 22:32:48 +02:00 · 2021-10-11 22:32:48 +02:00 · f6f53d565c
commit f6f53d565c
9 changed files with 577 additions and 0 deletions
--- a/.gitignore
+++ b/.gitignore
@ -0,0 +1,5 @@
+elm-stuff
+node_modules
+dist/app.js
+yarn.lock
+package-lock.json
--- a/4
+++ b/4
@ -0,0 +1,4 @@
+default: app.js
+
+app.js: src
+	elm make src/Main.elm --output=dist/app.js
--- a/dist/app.html
+++ b/dist/app.html
@ -0,0 +1,20 @@
+<!DOCTYPE html>
+<html lang="en">
+<head>
+  <meta charset="UTF-8">
+  <meta name="viewport" content="width=device-width, initial-scale=1.0">
+  <title>Test</title>
+  <link rel="stylesheet" href="style.css">
+  <script src="app.js"></script>
+</head>
+<body>
+	<script src="https://unpkg.com/elm-canvas/elm-canvas.js"></script>
+  <script>
+  var app = Elm.Main.init({
+    flags: {
+      userAgent: navigator.userAgent
+    }
+  });
+  </script>
+</body>
+</html>
--- a/dist/style.css
+++ 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;
+  }
+}
--- a/elm.json
+++ 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": {}
+    }
+}
--- a/src/Api.elm
+++ 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)
+      }
+    ]
+  }
--- a/src/DrawingBoard.elm
+++ 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)
+                   ]
--- a/src/Main.elm
+++ 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
--- a/src/ResultFiltering.elm
+++ 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