diff --git a/dot-to-dot b/dot-to-dot index 3715068..3d1157d 100755 Binary files a/dot-to-dot and b/dot-to-dot differ diff --git a/functional-core/app-type.sml b/functional-core/app-type.sml index a8070ae..a3dc87e 100644 --- a/functional-core/app-type.sml +++ b/functional-core/app-type.sml @@ -20,6 +20,16 @@ sig val initial: app_type val withTriangleStage: app_type * triangle_stage -> app_type + + val addTriangleAndResetStage : + app_type * + Real32.real * + Real32.real * + Real32.real * + Real32.real * + Real32.real * + Real32.real -> + app_type end structure AppType :> APP_TYPE = @@ -56,4 +66,15 @@ struct let val {triangles, triangleStage = _} = app in {triangles = triangles, triangleStage = newTriangleStage} end + + fun addTriangleAndResetStage (app: app_type, x1, y1, x2, y2, x3, y3) : + app_type = + let + val {triangles, triangleStage = _} = app + + val newTriangle = {x1 = x1, y1 = y1, x2 = x2, y2 = y2, x3 = x3, y3 = y3} + val newTriangles = newTriangle :: triangles + in + {triangles = newTriangles, triangleStage = NO_TRIANGLE} + end end diff --git a/functional-core/app-update.sml b/functional-core/app-update.sml index ac97e91..f4e111f 100644 --- a/functional-core/app-update.sml +++ b/functional-core/app-update.sml @@ -189,7 +189,8 @@ struct end | FIRST {x1, y1} => let - val drawVec = getFirstTriangleStageVector (x1, y1, buttonVec) + val drawVec = + getFirstTriangleStageVector (x1, y1, buttonVec) val drawMsg = DRAW_BUTTON drawVec val newTriangleStage = SECOND @@ -201,13 +202,12 @@ struct end | SECOND {x1, y1, x2, y2} => let - val drawVec = - getSecondTriangleStageVector (x1, y1, x2, y2, buttonVec) - val drawMsg = DRAW_BUTTON drawVec - - val newTriangleStage = NO_TRIANGLE val model = - AppType.withTriangleStage (model, newTriangleStage) + AppType.addTriangleAndResetStage + (model, x1, y1, x2, y2, hpos, vpos) + + val drawVec = getTrianglesVector model + val drawMsg = DRAW_TRIANGLES_AND_RESET_BUTTONS drawVec in (model, drawMsg, mouseX, mouseY) end) diff --git a/imperative-shell/app-draw.sml b/imperative-shell/app-draw.sml index 54019da..1657a1d 100644 --- a/imperative-shell/app-draw.sml +++ b/imperative-shell/app-draw.sml @@ -106,4 +106,45 @@ struct in () end + + fun initTriangles () = + let + val triangleDrawObject = initDrawObject + (Constants.graphVertexShaderString, Constants.graphFragmentShaderString) + val {vertexBuffer, program, ...} = triangleDrawObject + + val _ = Gles3.bindBuffer vertexBuffer + val _ = + Gles3.bufferData + ( #[] + , 0 + , Gles3.STATIC_DRAW () + ) + val _ = Gles3.vertexAttribPointer (0, 2, 2, 0) + val _ = Gles3.enableVertexAttribArray 0 + in + triangleDrawObject + end + + fun uploadTrianglesVector (triangleDrawObject: draw_object, vec) = + let + val {vertexBuffer, ...} = triangleDrawObject + val _ = Gles3.bindBuffer vertexBuffer + val _ = Gles3.bufferData (vec, Vector.length vec, Gles3.STATIC_DRAW ()) + in + () + end + + fun drawTriangles (triangleDrawObject: draw_object, triangleDrawLength) = + let + val {vertexBuffer, program, ...} = triangleDrawObject + val _ = Gles3.bindBuffer vertexBuffer + val _ = Gles3.vertexAttribPointer (0, 2, 2, 0) + val _ = Gles3.enableVertexAttribArray 0 + val _ = Gles3.useProgram program + val _ = Gles3.drawArrays + (Gles3.TRIANGLES (), 0, triangleDrawLength) + in + () + end end diff --git a/imperative-shell/event-loop.sml b/imperative-shell/event-loop.sml index a9f43b5..a63f41a 100644 --- a/imperative-shell/event-loop.sml +++ b/imperative-shell/event-loop.sml @@ -19,7 +19,14 @@ struct end fun draw - (drawMailbox, window, graphDrawObject, buttonDrawObject, buttonDrawLength) = + ( drawMailbox + , window + , graphDrawObject + , buttonDrawObject + , buttonDrawLength + , triangleDrawObject + , triangleDrawLength + ) = if not (Glfw.windowShouldClose window) then case Mailbox.recvPoll drawMailbox of NONE => @@ -28,6 +35,7 @@ struct val _ = Gles3.clear () val _ = AppDraw.drawGraphLines graphDrawObject + val _ = AppDraw.drawTriangles (triangleDrawObject, triangleDrawLength) val _ = AppDraw.drawButton (buttonDrawObject, buttonDrawLength) val _ = Glfw.pollEvents () @@ -39,6 +47,8 @@ struct , graphDrawObject , buttonDrawObject , buttonDrawLength + , triangleDrawObject + , triangleDrawLength ) end | SOME drawMsg => @@ -54,6 +64,24 @@ struct , graphDrawObject , buttonDrawObject , buttonDrawLength + , triangleDrawObject + , triangleDrawLength + ) + end + | DRAW_TRIANGLES_AND_RESET_BUTTONS triangleVec => + let + val _ = AppDraw.uploadTrianglesVector (triangleDrawObject, triangleVec) + val triangleDrawLength = Vector.length triangleVec div 2 + (* have to reset buttons too *) + in + draw + ( drawMailbox + , window + , graphDrawObject + , buttonDrawObject + , 0 + , triangleDrawObject + , triangleDrawLength ) end | NO_DRAW => @@ -63,6 +91,8 @@ struct , graphDrawObject , buttonDrawObject , buttonDrawLength + , triangleDrawObject + , triangleDrawLength )) else Glfw.terminate () diff --git a/imperative-shell/shell.sml b/imperative-shell/shell.sml index 9f957f1..13af0b2 100644 --- a/imperative-shell/shell.sml +++ b/imperative-shell/shell.sml @@ -9,13 +9,15 @@ struct val _ = Glfw.windowHint (Glfw.CONTEXT_VERSION_MAJOR (), 3) val _ = Glfw.windowHint (Glfw.DEPRECATED (), Glfw.FALSE ()) val _ = Glfw.windowHint (Glfw.SAMPLES (), 4) - val window = - Glfw.createWindow (Constants.windowWidth, Constants.windowHeight, "MLton - dot to dot") + val window = + Glfw.createWindow + (Constants.windowWidth, Constants.windowHeight, "MLton - dot to dot") val _ = Glfw.makeContextCurrent window val _ = Gles3.loadGlad () val graphDrawObject = AppDraw.initGraphLines () val buttonDrawObject = AppDraw.initButton () + val triangleDrawObject = AppDraw.initTriangles () val inputMailbox = Mailbox.mailbox () val drawMailbox = Mailbox.mailbox () @@ -25,7 +27,14 @@ struct val _ = CML.spawn (fn () => EventLoop.update (inputMailbox, drawMailbox)) val _ = CML.spawn (fn () => EventLoop.draw - (drawMailbox, window, graphDrawObject, buttonDrawObject, 0)) + ( drawMailbox + , window + , graphDrawObject + , buttonDrawObject + , 0 + , triangleDrawObject + , 0 + )) in () end diff --git a/message-types/draw-msg.sml b/message-types/draw-msg.sml index 290f211..63acb0d 100644 --- a/message-types/draw-msg.sml +++ b/message-types/draw-msg.sml @@ -1,11 +1,15 @@ signature DRAW_MESSAGE = sig - datatype t = DRAW_BUTTON of Real32.real vector - | NO_DRAW + datatype t = + DRAW_BUTTON of Real32.real vector + | DRAW_TRIANGLES_AND_RESET_BUTTONS of Real32.real vector + | NO_DRAW end structure DrawMessage :> DRAW_MESSAGE = -struct - datatype t = DRAW_BUTTON of Real32.real vector - | NO_DRAW +struct + datatype t = + DRAW_BUTTON of Real32.real vector + | DRAW_TRIANGLES_AND_RESET_BUTTONS of Real32.real vector + | NO_DRAW end