progress towards supporting arrow input

functional-core/app/app-update.sml

@@ -13,17 +13,19 @@ struct
   open InputMessage
   open UpdateMessage
 
-  fun mouseMoveOrRelease (model: app_type) =
-    let
-      val drawVec =
-        case ClickPoints.getClickPositionFromMouse model of
-          SOME (hIdx, vIdx) =>
+  fun getDotVecFromIndices (model, hIdx, vIdx) =
     let
       val xpos = Vector.sub (#xClickPoints model, hIdx)
       val ypos = Vector.sub (#yClickPoints model, vIdx)
     in
       ClickPoints.getDrawDot (xpos, ypos, 1.0, 0.0, 0.0, model)
     end
+
+  fun mouseMoveOrRelease (model: app_type) =
+    let
+      val drawVec =
+        case ClickPoints.getClickPositionFromMouse model of
+          SOME (hIdx, vIdx) => getDotVecFromIndices (model, hIdx, vIdx)
         | NONE => Vector.fromList []
       val drawVec = TriangleStage.toVector (model, drawVec)
 
@@ -32,12 +34,102 @@ struct
       (model, DRAW drawMsg)
     end
 
-  fun mouseLeftClick (model: app_type) =
-    case ClickPoints.getClickPositionFromMouse model of
-      SOME (hIdx, vIdx) =>
+  fun getDrawDotMsgWhenArrowIsAtBoundary model =
     let
-          val {windowWidth, windowHeight, xClickPoints, yClickPoints, ...} =
-            model
+      val {arrowX, arrowY, ...} = model
+      val dotVec = getDotVecFromIndices (model, arrowX, arrowY)
+      val dotVec = TriangleStage.toVector (model, dotVec)
+      val drawMsg = DRAW_DOT dotVec
+    in
+      (model, DRAW drawMsg)
+    end
+
+  fun moveArrowUp (model: app_type) =
+    let
+      val {arrowX, arrowY, ...} = model
+    in
+      if arrowY > 0 then
+        let
+          val newArrowY = arrowY - 1
+          val model = AppWith.arrowY (model, newArrowY)
+
+          val dotVec = getDotVecFromIndices (model, arrowX, newArrowY)
+          val dotVec = TriangleStage.toVector (model, dotVec)
+          val drawMsg = DRAW_DOT dotVec
+        in
+          (model, DRAW drawMsg)
+        end
+      else
+        getDrawDotMsgWhenArrowIsAtBoundary model
+    end
+
+  fun moveArrowLeft (model: app_type) =
+    let
+      val {arrowX, arrowY, ...} = model
+    in
+      if arrowX > 0 then
+        let
+          val newArrowX = arrowX - 1
+          val model = AppWith.arrowX (model, newArrowX)
+
+          val dotVec = getDotVecFromIndices (model, newArrowX, arrowY)
+          val dotVec = TriangleStage.toVector (model, dotVec)
+          val drawMsg = DRAW_DOT dotVec
+        in
+          (model, DRAW drawMsg)
+        end
+      else
+        getDrawDotMsgWhenArrowIsAtBoundary model
+    end
+
+  fun moveArrowRight (model: app_type) =
+    let
+      val {arrowX, arrowY, xClickPoints, ...} = model
+    in
+      if arrowX < Vector.length xClickPoints - 1 then
+        let
+          val newArrowX = arrowX + 1
+          val model = AppWith.arrowX (model, newArrowX)
+
+          val dotVec = getDotVecFromIndices (model, newArrowX, arrowY)
+          val dotVec = TriangleStage.toVector (model, dotVec)
+          val drawMsg = DRAW_DOT dotVec
+        in
+          (model, DRAW drawMsg)
+        end
+      else
+        getDrawDotMsgWhenArrowIsAtBoundary model
+    end
+
+  fun moveArrowDown (model: app_type) =
+    let
+      val {arrowX, arrowY, yClickPoints, ...} = model
+    in
+      if arrowY < Vector.length yClickPoints - 1 then
+        let
+          val newArrowY = arrowY + 1
+          val model = AppWith.arrowY (model, newArrowY)
+
+          val dotVec = getDotVecFromIndices (model, arrowX, newArrowY)
+          val dotVec = TriangleStage.toVector (model, dotVec)
+          val drawMsg = DRAW_DOT dotVec
+        in
+          (model, DRAW drawMsg)
+        end
+      else
+        getDrawDotMsgWhenArrowIsAtBoundary model
+    end
+
+  fun addCoordinates (model: app_type, hIdx, vIdx) =
+    let
+      val
+        { windowWidth
+        , windowHeight
+        , xClickPoints
+        , yClickPoints
+        , triangleStage
+        , ...
+        } = model
 
       val xpos = Vector.sub (xClickPoints, hIdx)
       val ypos = Vector.sub (yClickPoints, vIdx)
@@ -52,7 +144,7 @@ struct
 
       val newUndoTuple = (hpos, vpos)
     in
-          (case #triangleStage model of
+      case triangleStage of
         NO_TRIANGLE =>
           let
             val drawVec = TriangleStage.toVector (model, dotVec)
@@ -66,8 +158,7 @@ struct
           end
       | FIRST {x1, y1} =>
           let
-                 val drawVec =
-                   TriangleStage.firstToVector (x1, y1, dotVec, model)
+            val drawVec = TriangleStage.firstToVector (x1, y1, dotVec, model)
             val drawMsg = DRAW_DOT drawVec
 
             val newTriangleStage = SECOND
@@ -85,8 +176,12 @@ struct
             val drawMsg = DRAW_TRIANGLES_AND_RESET_DOTS drawVec
           in
             (model, DRAW drawMsg)
-               end)
           end
+    end
+
+  fun mouseLeftClick model =
+    case ClickPoints.getClickPositionFromMouse model of
+      SOME (hIdx, vIdx) => addCoordinates (model, hIdx, vIdx)
     | NONE => (model, NO_MAILBOX)
 
   fun resizeWindow (model, width, height) =
@@ -267,6 +362,10 @@ struct
     | KEY_CTRL_S => getSaveTrianglesMsg model
     | KEY_CTRL_L => getLoadTrianglesMsg model
     | KEY_CTRL_E => getExportTrianglesMsg model
+    | ARROW_UP => moveArrowUp model
+    | ARROW_LEFT => moveArrowLeft model
+    | ARROW_RIGHT => moveArrowRight model
+    | ARROW_DOWN => moveArrowDown model
     | USE_TRIANGLES triangles => useTriangles (model, triangles)
     | TRIANGLES_LOAD_ERROR => trianglesLoadError model
 end

functional-core/app/app-with.sml

@@ -7,6 +7,9 @@ sig
   val mousePosition: AppType.app_type * Real32.real * Real32.real
                      -> AppType.app_type
 
+  val arrowX: AppType.app_type * int -> AppType.app_type
+  val arrowY: AppType.app_type * int -> AppType.app_type
+
   val undo:
     AppType.app_type
     * AppType.triangle_stage
@@ -133,6 +136,74 @@ struct
       }
     end
 
+  fun arrowX (app: app_type, arrowX) =
+    let
+      val
+        { xClickPoints
+        , yClickPoints
+        , windowWidth
+        , windowHeight
+        , triangles
+        , triangleStage
+        , undo
+        , redo
+        , showGraph
+        , mouseX
+        , mouseY
+        , arrowX = _
+        , arrowY
+        } = app
+    in
+      { xClickPoints = xClickPoints
+      , yClickPoints = yClickPoints
+      , triangles = triangles
+      , triangleStage = triangleStage
+      , windowWidth = windowWidth
+      , windowHeight = windowHeight
+      , undo = undo
+      , redo = redo
+      , showGraph = showGraph
+      , mouseX = mouseX
+      , mouseY = mouseY
+      , arrowX = arrowX
+      , arrowY = arrowY
+      }
+    end
+
+  fun arrowY (app: app_type, arrowY) =
+    let
+      val
+        { xClickPoints
+        , yClickPoints
+        , windowWidth
+        , windowHeight
+        , triangles
+        , triangleStage
+        , undo
+        , redo
+        , showGraph
+        , mouseX
+        , mouseY
+        , arrowX
+        , arrowY = _
+        } = app
+    in
+      { xClickPoints = xClickPoints
+      , yClickPoints = yClickPoints
+      , triangles = triangles
+      , triangleStage = triangleStage
+      , windowWidth = windowWidth
+      , windowHeight = windowHeight
+      , undo = undo
+      , redo = redo
+      , showGraph = showGraph
+      , mouseX = mouseX
+      , mouseY = mouseY
+      , arrowX = arrowX
+      , arrowY = arrowY
+      }
+    end
+
   fun helpWindowResize
     (app: app_type, windowWidth, windowHeight, wStart, wFinish, hStart, hFinish) :
     app_type =

message-types/input-msg.sml

@@ -11,6 +11,10 @@ sig
   | KEY_CTRL_S
   | KEY_CTRL_L
   | KEY_CTRL_E
+  | ARROW_UP
+  | ARROW_LEFT
+  | ARROW_RIGHT
+  | ARROW_DOWN
   | USE_TRIANGLES of AppType.triangle list
   | TRIANGLES_LOAD_ERROR
 end
@@ -28,6 +32,10 @@ struct
   | KEY_CTRL_S
   | KEY_CTRL_L
   | KEY_CTRL_E
+  | ARROW_UP
+  | ARROW_LEFT
+  | ARROW_RIGHT
+  | ARROW_DOWN
   | USE_TRIANGLES of AppType.triangle list
   | TRIANGLES_LOAD_ERROR
 end