refactor a little bit, making signature of app-update.sml simpler to use by storing mouseX and mouseY inside the app_type

2024-08-08 21:58:50 +01:00
parent 89f4ae3b13
commit 4243e4c679
6 changed files with 109 additions and 31 deletions
--- a/BIN
+++ b/BIN
--- a/functional-core/app-init.sml
+++ b/functional-core/app-init.sml
@@ -8,7 +8,7 @@ struct
  open AppType

  fun helpFromWidthAndHeight
-    (windowWidth, windowHeight, wStart, wFinish, hStart, hFinish) =
+    (windowWidth, windowHeight, wStart, wFinish, hStart, hFinish) : app_type =
    let
      val xClickPoints = ClickPoints.generate (wStart, wFinish)
      val yClickPoints = ClickPoints.generate (hStart, hFinish)
@@ -24,6 +24,8 @@ struct
      , yClickPoints = yClickPoints
      , graphLines = graphLines
      , undo = []
+      , mouseX = 0.0
+      , mouseY = 0.0
      }
    end

--- a/functional-core/app-type.sml
+++ b/functional-core/app-type.sml
@@ -24,6 +24,8 @@ sig
    , yClickPoints: Real32.real vector
    , graphLines: Real32.real vector
    , undo: (Real32.real * Real32.real) list
+    , mouseX: Real32.real
+    , mouseY: Real32.real
    }
 end

@@ -61,5 +63,7 @@ struct
    , yClickPoints: Real32.real vector
    , graphLines: Real32.real vector
    , undo: (Real32.real * Real32.real) list
+    , mouseX: Real32.real
+    , mouseY: Real32.real
    }
 end
--- a/functional-core/app-update.sml
+++ b/functional-core/app-update.sml
@@ -1,7 +1,7 @@
 signature APP_UPDATE =
 sig
-  val update: AppType.app_type * Real32.real * Real32.real * InputMessage.t
-              -> AppType.app_type * DrawMessage.t * Real32.real * Real32.real
+  val update: AppType.app_type *  InputMessage.t
+              -> AppType.app_type * DrawMessage.t
 end

 structure AppUpdate :> APP_UPDATE =
@@ -10,9 +10,18 @@ struct
  open DrawMessage
  open InputMessage

-  fun mouseMoveOrRelease (model: app_type, mouseX, mouseY) =
+  fun mouseMoveOrRelease (model: app_type) =
    let
-      val {xClickPoints, yClickPoints, windowWidth, windowHeight, ...} = model
+      val
+        { xClickPoints
+        , yClickPoints
+        , windowWidth
+        , windowHeight
+        , mouseX
+        , mouseY
+        , ...
+        } = model
+
      val (drawVec, _, _) = ClickPoints.getClickPosition
        ( mouseX
        , mouseY
@@ -27,12 +36,21 @@ struct
      val drawVec = TriangleStage.toVector (model, drawVec)
      val drawMsg = DRAW_BUTTON drawVec
    in
-      (model, drawMsg, mouseX, mouseY)
+      (model, drawMsg)
    end

-  fun mouseLeftClick (model: app_type, mouseX, mouseY) =
+  fun mouseLeftClick (model: app_type) =
    let
-      val {xClickPoints, yClickPoints, windowWidth, windowHeight, ...} = model
+      val
+        { xClickPoints
+        , yClickPoints
+        , windowWidth
+        , windowHeight
+        , mouseX
+        , mouseY
+        , ...
+        } = model
+
      val (buttonVec, hpos, vpos) = ClickPoints.getClickPosition
        ( mouseX
        , mouseY
@@ -57,7 +75,7 @@ struct
              val model =
                AppWith.newTriangleStage (model, newTriangleStage, newUndoTuple)
            in
-              (model, drawMsg, mouseX, mouseY)
+              (model, drawMsg)
            end
        | FIRST {x1, y1} =>
            let
@@ -70,7 +88,7 @@ struct
              val model =
                AppWith.newTriangleStage (model, newTriangleStage, newUndoTuple)
            in
-              (model, drawMsg, mouseX, mouseY)
+              (model, drawMsg)
            end
        | SECOND {x1, y1, x2, y2} =>
            let
@@ -80,13 +98,13 @@ struct
              val drawVec = Triangles.toVector model
              val drawMsg = DRAW_TRIANGLES_AND_RESET_BUTTONS drawVec
            in
-              (model, drawMsg, mouseX, mouseY)
+              (model, drawMsg)
            end
      else
-        (model, NO_DRAW, mouseX, mouseY)
+        (model, NO_DRAW)
    end

-  fun resizeWindow (model, mouseX, mouseY, width, height) =
+  fun resizeWindow (model, width, height) =
    let
      val model = AppWith.windowResize (model, width, height)
      val triangles = Triangles.toVector model
@@ -95,15 +113,15 @@ struct
        RESIZE_TRIANGLES_BUTTONS_AND_GRAPH
          {triangles = triangles, graphLines = graphLines}
    in
-      (model, drawMsg, mouseX, mouseY)
+      (model, drawMsg)
    end

-  fun undoAction (model, mouseX, mouseY) =
+  fun undoAction model =
    case #triangleStage model of
      FIRST {x1, y1} =>
        (* Change FIRST to NO_TRIANGLE and clear buttons. *)
        let val model = AppWith.replaceTriangleStage (model, NO_TRIANGLE)
-        in (model, CLEAR_BUTTONS, mouseX, mouseY)
+        in (model, CLEAR_BUTTONS)
        end
    | SECOND {x1, y1, x2, y2} =>
        (* Change FIRST to SECOND and redraw buttons. *)
@@ -115,7 +133,7 @@ struct
            TriangleStage.firstToVector (x1, y1, Vector.fromList [], model)
          val drawMsg = DRAW_BUTTON drawVec
        in
-          (model, drawMsg, mouseX, mouseY)
+          (model, drawMsg)
        end
    | NO_TRIANGLE =>
        (case #triangles model of
@@ -135,19 +153,21 @@ struct
                 DRAW_TRIANGLES_AND_BUTTONS
                   {triangles = newTriangleVec, buttons = drawVec}
             in
-               (model, drawMsg, mouseX, mouseY)
+               (model, drawMsg)
             end
         | [] =>
             (* Can't undo, because there are no actions to undo. *)
-             (model, NO_DRAW, mouseX, mouseY))
+             (model, NO_DRAW))

-  fun update (model: app_type, mouseX, mouseY, inputMsg) =
+  fun update (model: app_type, inputMsg) =
    case inputMsg of
      MOUSE_MOVE {x = mouseX, y = mouseY} =>
-        mouseMoveOrRelease (model, mouseX, mouseY)
-    | MOUSE_LEFT_RELEASE => mouseMoveOrRelease (model, mouseX, mouseY)
-    | MOUSE_LEFT_CLICK => mouseLeftClick (model, mouseX, mouseY)
+        let val model = AppWith.mousePosition (model, mouseX, mouseY)
+        in mouseMoveOrRelease model
+        end
+    | MOUSE_LEFT_RELEASE => mouseMoveOrRelease model
+    | MOUSE_LEFT_CLICK => mouseLeftClick model
    | RESIZE_WINDOW {width, height} =>
-        resizeWindow (model, mouseX, mouseY, width, height)
-    | UNDO_ACTION => undoAction (model, mouseX, mouseY)
+        resizeWindow (model, width, height)
+    | UNDO_ACTION => undoAction model
 end
--- a/functional-core/app-with.sml
+++ b/functional-core/app-with.sml
@@ -22,6 +22,9 @@ sig
    * Real32.real
    * (Real32.real * Real32.real)
    -> AppType.app_type
+
+  val mousePosition: AppType.app_type * Real32.real * Real32.real
+                     -> AppType.app_type
 end

 structure AppWith :> APP_WITH =
@@ -40,7 +43,10 @@ struct
        , windowHeight
        , graphLines
        , undo
+        , mouseX
+        , mouseY
        } = app
+
      val newUndo = xyTuple :: undo
    in
      { triangleStage = newTriangleStage
@@ -51,6 +57,8 @@ struct
      , windowHeight = windowHeight
      , graphLines = graphLines
      , undo = newUndo
+      , mouseX = mouseX
+      , mouseY = mouseY
      }
    end

@@ -65,6 +73,8 @@ struct
        , windowHeight
        , graphLines
        , undo
+        , mouseX
+        , mouseY
        } = app
    in
      { triangleStage = newTriangleStage
@@ -75,6 +85,8 @@ struct
      , windowHeight = windowHeight
      , graphLines = graphLines
      , undo = undo
+      , mouseX = mouseX
+      , mouseY = mouseY
      }
    end

@@ -90,6 +102,8 @@ struct
        , windowHeight
        , graphLines
        , undo
+        , mouseX
+        , mouseY
        } = app
    in
      { triangleStage = newTriangleStage
@@ -100,6 +114,8 @@ struct
      , windowHeight = windowHeight
      , graphLines = graphLines
      , undo = undo
+      , mouseX = mouseX
+      , mouseY = mouseY
      }
    end

@@ -115,6 +131,8 @@ struct
        , windowHeight
        , graphLines
        , undo
+        , mouseX
+        , mouseY
        } = app

      val newTriangle = {x1 = x1, y1 = y1, x2 = x2, y2 = y2, x3 = x3, y3 = y3}
@@ -123,12 +141,14 @@ struct
    in
      { triangleStage = NO_TRIANGLE
      , triangles = newTriangles
+      , undo = newUndo
      , xClickPoints = xClickPoints
      , yClickPoints = yClickPoints
      , windowWidth = windowWidth
      , windowHeight = windowHeight
      , graphLines = graphLines
-      , undo = newUndo
+      , mouseX = mouseX
+      , mouseY = mouseY
      }
    end

@@ -145,6 +165,8 @@ struct
        , triangles
        , triangleStage
        , undo
+        , mouseX
+        , mouseY
        } = app
      val xClickPoints = ClickPoints.generate (wStart, wFinish)
      val yClickPoints = ClickPoints.generate (hStart, hFinish)
@@ -160,6 +182,8 @@ struct
      , windowWidth = windowWidth
      , windowHeight = windowHeight
      , undo = undo
+      , mouseX = mouseX
+      , mouseY = mouseY
      }
    end

@@ -185,4 +209,33 @@ struct
        helpWindowResize
          (app, windowWidth, windowHeight, 0, windowWidth, hStart, hFinish)
      end
+
+  fun mousePosition (app: app_type, mouseX, mouseY) =
+    let
+      val
+        { mouseX = _
+        , mouseY = _
+        , triangles
+        , triangleStage
+        , xClickPoints
+        , yClickPoints
+        , windowWidth
+        , windowHeight
+        , graphLines
+        , undo
+        } = app
+
+    in
+      { mouseX = mouseX
+      , mouseY = mouseY
+      , triangles = triangles
+      , triangleStage = triangleStage
+      , xClickPoints = xClickPoints
+      , yClickPoints = yClickPoints
+      , windowWidth = windowWidth
+      , windowHeight = windowHeight
+      , graphLines = graphLines
+      , undo = undo
+      }
+    end
 end
--- a/imperative-shell/event-loop.sml
+++ b/imperative-shell/event-loop.sml
@@ -4,18 +4,17 @@ struct
  open DrawMessage

  local
-    fun loop (inputMailbox, drawMailbox, mouseX, mouseY, model) =
+    fun loop (inputMailbox, drawMailbox, model) =
      let
        val inputMsg = Mailbox.recv inputMailbox
-        val (model, drawMsg, mouseX, mouseY) =
-          AppUpdate.update (model, mouseX, mouseY, inputMsg)
+        val (model, drawMsg) = AppUpdate.update (model, inputMsg)
        val _ = Mailbox.send (drawMailbox, drawMsg)
      in
-        loop (inputMailbox, drawMailbox, mouseX, mouseY, model)
+        loop (inputMailbox, drawMailbox, model)
      end
  in
    fun update (inputMailbox, drawMailbox, initial) =
-      loop (inputMailbox, drawMailbox, 0.0, 0.0, initial)
+      loop (inputMailbox, drawMailbox, initial)
  end

  fun draw