diff --git a/dot-to-dot b/dot-to-dot index 84ecf9d..10c8fdc 100755 Binary files a/dot-to-dot and b/dot-to-dot differ diff --git a/dot-to-dot.mlb b/dot-to-dot.mlb index f91b646..f763b46 100644 --- a/dot-to-dot.mlb +++ b/dot-to-dot.mlb @@ -11,6 +11,7 @@ in end message-types/input-msg.sml +message-types/draw-msg.sml functional-core/app-type.sml ann diff --git a/functional-core/app-type.sml b/functional-core/app-type.sml index 1cf2e9f..0a6c5da 100644 --- a/functional-core/app-type.sml +++ b/functional-core/app-type.sml @@ -1,4 +1,26 @@ -structure AppType = +signature APP_TYPE = +sig + datatype triangle_stage = + FIRST of {x1: Real32.real, y1: Real32.real} + | NO_TRIANGLE + | SECOND of + {x1: Real32.real, x2: Real32.real, y1: Real32.real, y2: Real32.real} + + type triangle = + { x1: Real32.real + , x2: Real32.real + , x3: Real32.real + , y1: Real32.real + , y2: Real32.real + , y3: Real32.real + } + + type app_type = {triangleStage: triangle_stage, triangles: triangle list} + + val initial: app_type +end + +structure AppType :> APP_TYPE = struct type triangle = { x1: Real32.real @@ -25,18 +47,5 @@ struct type app_type = {triangles: triangle list, triangleStage: triangle_stage} - local - fun helpGetTrianglesVector (lst, acc) = - case lst of - {x1, y1, x2, y2, x3, y3} :: tl => - let val vec = Vector.fromList [x1, y1, x2, y2, x3, y3] - in helpGetTrianglesVector (tl, vec :: acc) - end - | [] => acc - in - fun getTrianglesVector (app: app_type) = - let val lst = helpGetTrianglesVector (#triangles app, []) - in Vector.concat lst - end - end + val initial = {triangles = [], triangleStage = NO_TRIANGLE} end diff --git a/functional-core/app-update.sml b/functional-core/app-update.sml index ddc9431..5f7cd5a 100644 --- a/functional-core/app-update.sml +++ b/functional-core/app-update.sml @@ -1,28 +1,31 @@ structure AppUpdate = struct - val clickPoints = - #[ 25 - , 50 - , 75 - , 100 - , 125 - , 150 - , 175 - , 200 - , 225 - , 250 - , 275 - , 300 - , 325 - , 350 - , 375 - , 400 - , 425 - , 450 - , 475 - ] + open AppType local + fun helpGetTrianglesVector (lst, acc) = + case lst of + {x1, y1, x2, y2, x3, y3} :: tl => + let val vec = Vector.fromList [x1, y1, x2, y2, x3, y3] + in helpGetTrianglesVector (tl, vec :: acc) + end + | [] => acc + in + fun getTrianglesVector (app: app_type) = + let val lst = helpGetTrianglesVector (#triangles app, []) + in Vector.concat lst + end + end + + local + val clickPoints = + #[ 25, 50, 75, 100 + , 125, 150, 175, 200 + , 225, 250, 275, 300 + , 325, 350, 375, 400 + , 425, 450, 475 + ] + fun getVerticalClickPos (idx, horizontalPos, mouseX, mouseY, r, g, b) = if idx = Vector.length clickPoints then #[] @@ -40,14 +43,14 @@ struct val bottom = Real32.fromInt (curVerticalPos - 10) / 500.0 val top = Real32.fromInt (curVerticalPos + 10) / 500.0 in - #[ left, bottom, r, g, b, - right, bottom, r, g, b, - left, top, r, g, b, + #[ left, bottom, r, g, b + , right, bottom, r, g, b + , left, top, r, g, b - left, top, r, g, b, - right, bottom, r, g, b, - right, top, r, g, b - ] + , left, top, r, g, b + , right, bottom, r, g, b + , right, top, r, g, b + ] end end @@ -73,4 +76,36 @@ struct fun getClickPos (mouseX, mouseY, r, g, b) = getHorizontalClickPos (0, mouseX, mouseY, r, g, b) end + + fun update (model, mouseX, mouseY, inputMsg) = + let + open DrawMessage + open InputMessage + in + case inputMsg of + MOUSE_MOVE {x = mouseX, y = mouseY} => + let + val _ = print "mouse moved\n" + val drawMsg = + DRAW_BUTTON (getClickPos (mouseX, mouseY, 1.0, 0.0, 0.0)) + in + (model, drawMsg, mouseX, mouseY) + end + | MOUSE_LEFT_RELEASE => + let + val _ = print "mouse released\n" + val drawMsg = DRAW_BUTTON + (getClickPos (mouseX, mouseY, 1.0, 0.0, 0.0)) + in + (model, drawMsg, mouseX, mouseY) + end + | MUSE_LEFT_CLICK => + let + val _ = print "mouse clicked\n" + val buttonVec = getClickPos (mouseX, mouseY, 1.0, 0.0, 0.0) + val drawMsg = DRAW_BUTTON buttonVec + in + (model, drawMsg, mouseX, mouseY) + end + end end diff --git a/imperative-shell/event-loop.sml b/imperative-shell/event-loop.sml index 81d0257..647ffa7 100644 --- a/imperative-shell/event-loop.sml +++ b/imperative-shell/event-loop.sml @@ -3,18 +3,19 @@ struct open CML open InputMessage - fun update inputMailbox = + local + fun loop (inputMailbox, drawMailbox, mouseX, mouseY, model) = let - val _ = - case Mailbox.recv inputMailbox of - MOUSE_MOVE {x, y} => - print (String.concat - ["x pos: ", Int.toString x, ", y pos: ", Int.toString y, "\n"]) - | MOUSE_LEFT_CLICK => print "clicked mouse\n" - | MOUSE_LEFT_RELEASE => print "released mouse\n" + val inputMsg = Mailbox.recv inputMailbox + val (model, drawMsg, mouseX, mouseY) = AppUpdate.update (model, mouseX, mouseY, inputMsg) + val _ = Mailbox.send (drawMailbox, drawMsg) in - update inputMailbox + loop (inputMailbox, drawMailbox, mouseX, mouseY, model) end + in + fun update (inputMailbox, drawMailbox) = + loop (inputMailbox, drawMailbox, 0, 0, AppType.initial) + end fun draw (window, graphDrawObject, buttonDrawObject, buttonDrawLength) = if not (Glfw.windowShouldClose window) then diff --git a/imperative-shell/input-callbacks.sml b/imperative-shell/input-callbacks.sml index 252560d..ca66251 100644 --- a/imperative-shell/input-callbacks.sml +++ b/imperative-shell/input-callbacks.sml @@ -14,4 +14,18 @@ struct Mailbox.send (mailbox, MOUSE_LEFT_RELEASE) else () + + fun registerCallbacks (window, inputMailbox) = + let + val mouseMoveCallback = mouseMoveCallback inputMailbox + val _ = Input.exportMouseMoveCallback mouseMoveCallback + val _ = Input.setMouseMoveCallback window + + val mouseClickCallback = + mouseClickCallback inputMailbox + val _ = Input.exportMouseClickCallback mouseClickCallback + val _ = Input.setMouseClickCallback window + in + () + end end diff --git a/imperative-shell/shell.sml b/imperative-shell/shell.sml index 9cda3f9..0fe5d03 100644 --- a/imperative-shell/shell.sml +++ b/imperative-shell/shell.sml @@ -17,24 +17,13 @@ struct val buttonDrawObject = AppDraw.initButton () val inputMailbox = Mailbox.mailbox () - (* Set callback sender *) - val _ = CML.spawn (fn () => - let - val mouseMoveCallback = InputCallbacks.mouseMoveCallback inputMailbox - val _ = Input.exportMouseMoveCallback mouseMoveCallback - val _ = Input.setMouseMoveCallback window + val drawMailbox = Mailbox.mailbox () - val mouseClickCallback = - InputCallbacks.mouseClickCallback inputMailbox - val _ = Input.exportMouseClickCallback mouseClickCallback - val _ = Input.setMouseClickCallback window - in - () - end) - (* Set callback listener *) - val _ = CML.spawn (fn () => EventLoop.update inputMailbox) + val _ = CML.spawn (fn () => InputCallbacks.registerCallbacks (window, inputMailbox)) + val _ = CML.spawn (fn () => EventLoop.update (inputMailbox, drawMailbox)) + val _ = CML.spawn (fn () => EventLoop.draw (window, graphDrawObject, buttonDrawObject, 0)) in - EventLoop.draw (window, graphDrawObject, buttonDrawObject, 0) + () end end diff --git a/message-types/draw-msg.sml b/message-types/draw-msg.sml index d6adc1e..ab88301 100644 --- a/message-types/draw-msg.sml +++ b/message-types/draw-msg.sml @@ -1,9 +1,11 @@ signature DRAW_MESSAGE = sig - + datatype t = + DRAW_BUTTON of Real32.real vector end structure DrawMessage :> DRAW_MESSAGE = struct - + datatype t = + DRAW_BUTTON of Real32.real vector end diff --git a/test.sml b/test.sml deleted file mode 100644 index e69de29..0000000