humza/sml-projects
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactoring and scaffolding

Browse Source
This commit is contained in:
Humza Shahid
2024-07-31 12:00:07 +01:00
parent 94611eceee
commit 29793cccbe
9 changed files with 121 additions and 70 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
dot-to-dot
View File

Binary file not shown.

1
dot-to-dot.mlb
View File

@@ -11,6 +11,7 @@ in
end
message-types/input-msg.sml
message-types/draw-msg.sml
functional-core/app-type.sml
ann

39
functional-core/app-type.sml
View File

@@ -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

91
functional-core/app-update.sml
View File

@@ -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

19
imperative-shell/event-loop.sml
View File

@@ -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

14
imperative-shell/input-callbacks.sml
View File

@@ -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

21
imperative-shell/shell.sml
View File

@@ -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

6
message-types/draw-msg.sml
View File

@@ -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

0
test.sml
View File