scaffolding in preparation for implementing undo

ffi/export.h

@@ -160,6 +160,7 @@ extern "C" {
 MLLIB_PUBLIC(void mltonMouseMoveCallback (Real32 x0, Real32 x1);)
 MLLIB_PUBLIC(void mltonMouseClickCallback (Int32 x0, Int32 x1);)
 MLLIB_PUBLIC(void mltonFramebufferSizeCallback (Int32 x0, Int32 x1);)
+MLLIB_PUBLIC(void mltonKeyCallback (Int32 x0, Int32 x1, Int32 x2, Int32 x3);)
 
 #undef MLLIB_PRIVATE
 #undef MLLIB_PUBLIC

ffi/glfw-input.c

@@ -1,9 +1,10 @@
 #include "export.h"
 #include <GLFW/glfw3.h>
 
-int MOUSE_PRESSED = GLFW_PRESS;
-int MOUSE_RELEASED = GLFW_RELEASE;
+int PRESS = GLFW_PRESS;
+int RELEASE = GLFW_RELEASE;
 int LEFT_MOUSE_BUTTON = GLFW_MOUSE_BUTTON_1;
+int KEY_Z = GLFW_KEY_Z;
 
 // Calls function exported from SML 
 void mouseMoveCallback(GLFWwindow *window, double xpos, double ypos) {
@@ -28,3 +29,10 @@ void framebufferSizeCallback(GLFWwindow *window, int width, int height) {
 void setFramebufferSizeCallback(GLFWwindow *window, int width, int height) {
   glfwSetFramebufferSizeCallback(window, framebufferSizeCallback);
 }
+
+void keyCallback(GLFWwindow *window, int key, int scancode, int action, int mods) {
+  mltonKeyCallback(key, scancode, action, mods);
+}
+void setKeyCallback(GLFWwindow *window) {
+  glfwSetKeyCallback(window, keyCallback);
+}

ffi/glfw-input.sml

@@ -19,10 +19,18 @@ struct
     _import "setFramebufferSizeCallback" public reentrant : window -> unit;
 
   (* Constants for mouse input. *)
-  val (MOUSE_PRESSED, _) =
-    _symbol "MOUSE_PRESSED" public : ( unit -> int ) * ( int -> unit );
-  val (MOUSE_RELEASED, _) =
-    _symbol "MOUSE_RELEASED" public : ( unit -> int ) * ( int -> unit );
+  val (PRESS, _) =
+    _symbol "PRESS" public : ( unit -> int ) * ( int -> unit );
+  val (RELEASE, _) =
+    _symbol "RELEASE" public : ( unit -> int ) * ( int -> unit );
   val (LEFT_MOUSE_BUTTON, _) =
     _symbol "LEFT_MOUSE_BUTTON" public : ( unit -> int ) * ( int -> unit );
+
+  (* Key input *)
+  val exportKeyCallback =
+    _export "mltonKeyCallback" public : (int * int * int * int -> unit) -> unit;
+  val setKeyCallback = _import "setKeyCallback" public reentrant : window -> unit;
+
+  val (KEY_Z, _) =
+    _symbol "KEY_Z" public : ( unit -> int ) * ( int -> unit );
 end

functional-core/app-init.sml

@@ -23,6 +23,7 @@ struct
       , xClickPoints = xClickPoints
       , yClickPoints = yClickPoints
       , graphLines = graphLines
+      , undo = []
       }
     end
 

functional-core/app-type.sml

@@ -23,6 +23,7 @@ sig
     , xClickPoints: Real32.real vector
     , yClickPoints: Real32.real vector
     , graphLines: Real32.real vector
+    , undo: (int * int) list
     }
 end
 
@@ -59,5 +60,6 @@ struct
     , xClickPoints: Real32.real vector
     , yClickPoints: Real32.real vector
     , graphLines: Real32.real vector
+    , undo: (int * int) list
     }
 end

functional-core/app-update.sml

@@ -103,4 +103,10 @@ struct
     | MOUSE_LEFT_CLICK => mouseLeftClick (model, mouseX, mouseY)
     | RESIZE_WINDOW {width, height} =>
         resizeWindow (model, mouseX, mouseY, width, height)
+    | UNDO_ACTION =>
+        let
+          val _ = print "undo action\n"
+        in
+          (model, NO_DRAW, mouseX, mouseY)
+        end
 end

functional-core/app-with.sml

@@ -28,6 +28,7 @@ struct
         , windowWidth
         , windowHeight
         , graphLines
+        , undo
         } = app
     in
       { triangleStage = newTriangleStage
@@ -37,6 +38,7 @@ struct
       , windowWidth = windowWidth
       , windowHeight = windowHeight
       , graphLines = graphLines
+      , undo = undo
       }
     end
 
@@ -50,6 +52,7 @@ struct
         , windowWidth
         , windowHeight
         , graphLines
+        , undo
         } = app
 
       val newTriangle = {x1 = x1, y1 = y1, x2 = x2, y2 = y2, x3 = x3, y3 = y3}
@@ -62,6 +65,7 @@ struct
       , windowWidth = windowWidth
       , windowHeight = windowHeight
       , graphLines = graphLines
+      , undo = undo
       }
     end
 
@@ -77,6 +81,7 @@ struct
         , graphLines = _
         , triangles
         , triangleStage
+        , undo
         } = app
       val xClickPoints = ClickPoints.generate (wStart, wFinish)
       val yClickPoints = ClickPoints.generate (hStart, hFinish)
@@ -91,6 +96,7 @@ struct
       , triangleStage = triangleStage
       , windowWidth = windowWidth
       , windowHeight = windowHeight
+      , undo = undo
       }
     end
 

imperative-shell/input-callbacks.sml

@@ -8,10 +8,8 @@ struct
 
   fun mouseClickCallback mailbox (button, action) =
     if button = Input.LEFT_MOUSE_BUTTON () then
-      if action = Input.MOUSE_PRESSED () then
-        Mailbox.send (mailbox, MOUSE_LEFT_CLICK)
-      else
-        Mailbox.send (mailbox, MOUSE_LEFT_RELEASE)
+      if action = Input.PRESS () then Mailbox.send (mailbox, MOUSE_LEFT_CLICK)
+      else Mailbox.send (mailbox, MOUSE_LEFT_RELEASE)
     else
       ()
 
@@ -20,6 +18,13 @@ struct
     in Mailbox.send (mailbox, RESIZE_WINDOW {width = width, height = height})
     end
 
+  fun keyActionCallback mailbox (key, scancode, action, mods) =
+    if
+      key = Input.KEY_Z () andalso action <> Input.RELEASE ()
+      andalso mods = 0x0002
+    then Mailbox.send (mailbox, UNDO_ACTION)
+    else ()
+
   fun registerCallbacks (window, inputMailbox) =
     let
       val mouseMoveCallback = mouseMoveCallback inputMailbox
@@ -33,6 +38,10 @@ struct
       val resizeCallback = framebufferSizeCallback inputMailbox
       val _ = Input.exportFramebufferSizeCallback resizeCallback
       val _ = Input.setFramebufferSizeCallback window
+
+      val keyCallback = keyActionCallback inputMailbox
+      val _ = Input.exportKeyCallback keyCallback
+      val _ = Input.setKeyCallback window
     in
       ()
     end

message-types/input-msg.sml

@@ -5,6 +5,7 @@ sig
   | MOUSE_LEFT_CLICK
   | MOUSE_LEFT_RELEASE
   | RESIZE_WINDOW of {width: int, height: int}
+  | UNDO_ACTION
 end
 
 structure InputMessage :> INPUT_MESSAGE =
@@ -14,4 +15,5 @@ struct
   | MOUSE_LEFT_CLICK
   | MOUSE_LEFT_RELEASE
   | RESIZE_WINDOW of {width: int, height: int}
+  | UNDO_ACTION
 end