Add 'dotscape/' from commit 'f306501a68a51b634e895c5fdac70788ae899d75'
git-subtree-dir: dotscape git-subtree-mainline:6b91d64fc3git-subtree-split:f306501a68
This commit is contained in:
92
dotscape/fcore/app-init.sml
Normal file
92
dotscape/fcore/app-init.sml
Normal file
@@ -0,0 +1,92 @@
|
||||
signature APP_INIT =
|
||||
sig
|
||||
val fromWindowWidthAndHeight: int * int * int * int * string
|
||||
-> AppType.app_type
|
||||
end
|
||||
|
||||
structure AppInit :> APP_INIT =
|
||||
struct
|
||||
open AppType
|
||||
|
||||
fun helpFromWidthAndHeight
|
||||
( windowWidth
|
||||
, windowHeight
|
||||
, wStart
|
||||
, wFinish
|
||||
, hStart
|
||||
, hFinish
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, filepath
|
||||
) : app_type =
|
||||
let
|
||||
val (xClickPoints, yClickPoints) =
|
||||
ClickPoints.generate
|
||||
(windowWidth, windowHeight, canvasWidth, canvasHeight)
|
||||
|
||||
val maxPoints = Int.max (canvasWidth, canvasHeight)
|
||||
val layerTree = LayerTree.init maxPoints
|
||||
in
|
||||
{ mode = AppType.NORMAL_MODE
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, mouseX = 0.0
|
||||
, mouseY = 0.0
|
||||
, showGraph = true
|
||||
, arrowX = 0
|
||||
, arrowY = 0
|
||||
, openFilePath = filepath
|
||||
, r = 0
|
||||
, g = 0
|
||||
, b = 0
|
||||
, a = 1
|
||||
, layer = LayerTree.minKey
|
||||
, layerTree = layerTree
|
||||
, modalNum = 0
|
||||
}
|
||||
end
|
||||
|
||||
fun fromWindowWidthAndHeight
|
||||
(windowWidth, windowHeight, canvasWidth, canvasHeight, filepath) =
|
||||
if windowWidth > windowHeight then
|
||||
let
|
||||
val difference = windowWidth - windowHeight
|
||||
val wStart = difference div 2
|
||||
val wFinish = wStart + windowHeight
|
||||
in
|
||||
helpFromWidthAndHeight
|
||||
( windowWidth
|
||||
, windowHeight
|
||||
, wStart
|
||||
, wFinish
|
||||
, 0
|
||||
, windowHeight
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, filepath
|
||||
)
|
||||
end
|
||||
else
|
||||
let
|
||||
val difference = windowHeight - windowWidth
|
||||
val hStart = difference div 2
|
||||
val hFinish = hStart + windowWidth
|
||||
in
|
||||
helpFromWidthAndHeight
|
||||
( windowWidth
|
||||
, windowHeight
|
||||
, 0
|
||||
, windowWidth
|
||||
, hStart
|
||||
, hFinish
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, filepath
|
||||
)
|
||||
end
|
||||
end
|
||||
35
dotscape/fcore/app-type.sml
Normal file
35
dotscape/fcore/app-type.sml
Normal file
@@ -0,0 +1,35 @@
|
||||
structure AppType =
|
||||
struct
|
||||
datatype app_mode = NORMAL_MODE | MOVE_MODE
|
||||
|
||||
type square = {r: int, g: int, b: int, a: int}
|
||||
|
||||
type app_type =
|
||||
{ mode: app_mode
|
||||
, canvasWidth: int
|
||||
, canvasHeight: int
|
||||
, windowWidth: int
|
||||
, windowHeight: int
|
||||
, xClickPoints: Real32.real vector
|
||||
, yClickPoints: Real32.real vector
|
||||
|
||||
(* undo and redo commented out temporarily
|
||||
, undo: (Real32.real * Real32.real) list
|
||||
, redo: (Real32.real * Real32.real) list
|
||||
*)
|
||||
|
||||
, showGraph: bool
|
||||
, mouseX: Real32.real
|
||||
, mouseY: Real32.real
|
||||
, arrowX: int
|
||||
, arrowY: int
|
||||
, openFilePath: string
|
||||
, r: int
|
||||
, g: int
|
||||
, b: int
|
||||
, a: int
|
||||
, layer: int
|
||||
, layerTree: LayerTree.t
|
||||
, modalNum: int
|
||||
}
|
||||
end
|
||||
9
dotscape/fcore/app-update.sml
Normal file
9
dotscape/fcore/app-update.sml
Normal file
@@ -0,0 +1,9 @@
|
||||
structure AppUpdate =
|
||||
struct
|
||||
open AppType
|
||||
|
||||
fun update (model: app_type, inputMsg) =
|
||||
case #mode model of
|
||||
NORMAL_MODE => NormalMode.update (model, inputMsg)
|
||||
| MOVE_MODE => MoveMode.update (model, inputMsg)
|
||||
end
|
||||
889
dotscape/fcore/app-with.sml
Normal file
889
dotscape/fcore/app-with.sml
Normal file
@@ -0,0 +1,889 @@
|
||||
structure AppWith =
|
||||
struct
|
||||
open AppType
|
||||
|
||||
fun arrowX (app, arrowX) =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, arrowX = _
|
||||
, arrowY
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
|
||||
, showGraph
|
||||
, mouseX
|
||||
, mouseY
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
in
|
||||
{ mode = mode
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = modalNum
|
||||
}
|
||||
end
|
||||
|
||||
fun arrowY (app, arrowY) =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, arrowX
|
||||
, arrowY = _
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
|
||||
, showGraph
|
||||
, mouseX
|
||||
, mouseY
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
in
|
||||
{ mode = mode
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = modalNum
|
||||
}
|
||||
end
|
||||
|
||||
fun windowResize (app: app_type, windowWidth, windowHeight) : app_type =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, xClickPoints = _
|
||||
, yClickPoints = _
|
||||
, windowWidth = _
|
||||
, windowHeight = _
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
|
||||
, showGraph
|
||||
, mouseX
|
||||
, mouseY
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
|
||||
val (xClickPoints, yClickPoints) =
|
||||
ClickPoints.generate
|
||||
(windowWidth, windowHeight, canvasWidth, canvasHeight)
|
||||
in
|
||||
{ mode = mode
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = modalNum
|
||||
}
|
||||
end
|
||||
|
||||
fun mousePosition (app: app_type, mouseX, mouseY) =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, mouseX = _
|
||||
, mouseY = _
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
|
||||
, showGraph
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
in
|
||||
{ mode = mode
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = modalNum
|
||||
}
|
||||
end
|
||||
|
||||
fun graphVisibility (app: app_type, shouldShowGraph) =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, mouseX
|
||||
, mouseY
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
|
||||
, showGraph = _
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
in
|
||||
{ mode = mode
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = shouldShowGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = modalNum
|
||||
}
|
||||
end
|
||||
|
||||
fun mode (app: app_type, newMode) =
|
||||
let
|
||||
val
|
||||
{ mode = _
|
||||
, mouseX
|
||||
, mouseY
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
|
||||
, showGraph
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
in
|
||||
{ mode = newMode
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = modalNum
|
||||
}
|
||||
end
|
||||
|
||||
fun modalNum (app: app_type, newNum) : app_type =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, mouseX
|
||||
, mouseY
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
|
||||
, showGraph
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum = prevNum
|
||||
} = app
|
||||
|
||||
val newNum = (prevNum * 10) + newNum
|
||||
in
|
||||
{ mode = mode
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = newNum
|
||||
}
|
||||
end
|
||||
|
||||
fun r (app: app_type) : app_type =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, mouseX
|
||||
, mouseY
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
|
||||
, showGraph
|
||||
, openFilePath
|
||||
, r = _
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
|
||||
val r = Int.min (modalNum, 255)
|
||||
in
|
||||
{ mode = mode
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = 0
|
||||
}
|
||||
end
|
||||
|
||||
fun g (app: app_type) : app_type =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, mouseX
|
||||
, mouseY
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
|
||||
, showGraph
|
||||
, openFilePath
|
||||
, r
|
||||
, g = _
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
|
||||
val g = Int.min (modalNum, 255)
|
||||
in
|
||||
{ mode = mode
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = 0
|
||||
}
|
||||
end
|
||||
|
||||
fun b (app: app_type) : app_type =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, mouseX
|
||||
, mouseY
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
|
||||
, showGraph
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b = _
|
||||
, a
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
|
||||
val b = Int.min (modalNum, 255)
|
||||
in
|
||||
{ mode = mode
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = 0
|
||||
}
|
||||
end
|
||||
|
||||
fun a (app: app_type) : app_type =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, mouseX
|
||||
, mouseY
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
|
||||
, showGraph
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a = _
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
|
||||
val a = Int.min (modalNum, 255)
|
||||
in
|
||||
{ mode = mode
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = 0
|
||||
}
|
||||
end
|
||||
|
||||
fun layer (app: app_type) : app_type =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, mouseX
|
||||
, mouseY
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
|
||||
, showGraph
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer = _
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
|
||||
val layer = Int.max (modalNum, 1)
|
||||
in
|
||||
{ mode = mode
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = 0
|
||||
}
|
||||
end
|
||||
|
||||
fun layerTree (app: app_type, layerTree, arrowX, arrowY) : app_type =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, mouseX
|
||||
, mouseY
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, arrowX = _
|
||||
, arrowY = _
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
|
||||
, showGraph
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree = _
|
||||
, modalNum
|
||||
} = app
|
||||
in
|
||||
{ mode = mode
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = modalNum
|
||||
}
|
||||
end
|
||||
|
||||
fun canvasWidth (app: app_type, newCanvasWidth, newLayerTree) =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, canvasWidth = _
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasHeight
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
|
||||
, showGraph
|
||||
, mouseX
|
||||
, mouseY
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree = _
|
||||
, modalNum
|
||||
} = app
|
||||
|
||||
val arrowX = Int.min (arrowX, newCanvasWidth)
|
||||
val (xClickPoints, yClickPoints) =
|
||||
ClickPoints.generate
|
||||
(windowWidth, windowHeight, newCanvasWidth, canvasHeight)
|
||||
in
|
||||
{ mode = mode
|
||||
, canvasWidth = newCanvasWidth
|
||||
, arrowX = arrowX
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowY = arrowY
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = newLayerTree
|
||||
, modalNum = 0
|
||||
}
|
||||
end
|
||||
|
||||
fun canvasHeight (app: app_type, newCanvasHeight, newLayerTree) =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, canvasHeight = _
|
||||
, canvasWidth
|
||||
, arrowX
|
||||
, arrowY
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
|
||||
, showGraph
|
||||
, mouseX
|
||||
, mouseY
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree = _
|
||||
, modalNum
|
||||
} = app
|
||||
|
||||
val arrowY = Int.min (arrowY, newCanvasHeight)
|
||||
val (xClickPoints, yClickPoints) =
|
||||
ClickPoints.generate
|
||||
(windowWidth, windowHeight, canvasWidth, newCanvasHeight)
|
||||
in
|
||||
{ mode = mode
|
||||
, canvasHeight = newCanvasHeight
|
||||
, canvasWidth = canvasWidth
|
||||
, arrowX = arrowX
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowY = arrowY
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = newLayerTree
|
||||
, modalNum = 0
|
||||
}
|
||||
end
|
||||
|
||||
fun cursorColour (app, r, g, b, a) =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, canvasHeight
|
||||
, canvasWidth
|
||||
, arrowX
|
||||
, arrowY
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
|
||||
, showGraph
|
||||
, mouseX
|
||||
, mouseY
|
||||
, openFilePath
|
||||
, r = _
|
||||
, g = _
|
||||
, b = _
|
||||
, a = _
|
||||
, layer
|
||||
, layerTree
|
||||
, modalNum
|
||||
} = app
|
||||
in
|
||||
{ mode = mode
|
||||
, canvasHeight = canvasHeight
|
||||
, canvasWidth = canvasWidth
|
||||
, arrowX = arrowX
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowY = arrowY
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = 0
|
||||
}
|
||||
end
|
||||
|
||||
fun parsedLayerTree (app: app_type, layerTree, canvasWidth, canvasHeight) :
|
||||
app_type =
|
||||
let
|
||||
val
|
||||
{ mode
|
||||
, mouseX
|
||||
, mouseY
|
||||
, xClickPoints = _
|
||||
, yClickPoints = _
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, arrowX
|
||||
, arrowY
|
||||
, canvasWidth = _
|
||||
, canvasHeight = _
|
||||
|
||||
, showGraph
|
||||
, openFilePath
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, a
|
||||
, layer
|
||||
, layerTree = _
|
||||
, modalNum
|
||||
} = app
|
||||
|
||||
val arrowX =
|
||||
if canvasWidth = 0 then 0 else Int.min (canvasWidth - 1, arrowX)
|
||||
val arrowY =
|
||||
if canvasHeight = 0 then 0 else Int.min (canvasHeight - 1, arrowY)
|
||||
val (xClickPoints, yClickPoints) =
|
||||
ClickPoints.generate
|
||||
(windowWidth, windowHeight, canvasWidth, canvasHeight)
|
||||
in
|
||||
{ mode = mode
|
||||
, mouseX = mouseX
|
||||
, mouseY = mouseY
|
||||
, arrowX = arrowX
|
||||
, arrowY = arrowY
|
||||
, canvasWidth = canvasWidth
|
||||
, canvasHeight = canvasHeight
|
||||
, windowWidth = windowWidth
|
||||
, windowHeight = windowHeight
|
||||
, xClickPoints = xClickPoints
|
||||
, yClickPoints = yClickPoints
|
||||
|
||||
, showGraph = showGraph
|
||||
, openFilePath = openFilePath
|
||||
, r = r
|
||||
, g = g
|
||||
, b = b
|
||||
, a = a
|
||||
, layer = layer
|
||||
, layerTree = layerTree
|
||||
, modalNum = modalNum
|
||||
}
|
||||
end
|
||||
end
|
||||
88
dotscape/fcore/click-points.sml
Normal file
88
dotscape/fcore/click-points.sml
Normal file
@@ -0,0 +1,88 @@
|
||||
structure ClickPoints =
|
||||
struct
|
||||
fun generate (windowWidth, windowHeight, canvasWidth, canvasHeight) =
|
||||
let
|
||||
val realWindowWidth = Real32.fromInt windowWidth
|
||||
val realCanvasWidth = Real32.fromInt canvasWidth
|
||||
val realWindowHeight = Real32.fromInt windowHeight
|
||||
val realCanvasHeight = Real32.fromInt canvasHeight
|
||||
|
||||
val xPixelSize = realWindowWidth / realCanvasWidth
|
||||
val yPixelSize = realWindowHeight / realCanvasHeight
|
||||
|
||||
val pixelSize = Real32.min (xPixelSize, yPixelSize)
|
||||
|
||||
val actualWidth = pixelSize * realCanvasWidth
|
||||
val actualHeight = pixelSize * realCanvasHeight
|
||||
|
||||
val heightDifference = realWindowHeight - actualHeight
|
||||
val yOffset = heightDifference / 2.0
|
||||
val widthDifference = realWindowWidth - actualWidth
|
||||
val xOffset = widthDifference / 2.0
|
||||
|
||||
val xClickPoints = Vector.tabulate (canvasWidth + 1, fn i =>
|
||||
(Real32.fromInt i * pixelSize) + xOffset)
|
||||
val yClickPoints = Vector.tabulate (canvasHeight + 1, fn i =>
|
||||
(Real32.fromInt i * pixelSize) + yOffset)
|
||||
in
|
||||
(xClickPoints, yClickPoints)
|
||||
end
|
||||
|
||||
fun getClickPos (clickPoints, mousePos, idx) =
|
||||
let
|
||||
val nextIdx = idx + 1
|
||||
in
|
||||
if nextIdx >= Vector.length clickPoints then
|
||||
NONE
|
||||
else
|
||||
let
|
||||
val curPos = Vector.sub (clickPoints, idx)
|
||||
val nextPos = Vector.sub (clickPoints, nextIdx)
|
||||
in
|
||||
if mousePos >= curPos andalso mousePos <= nextPos then SOME idx
|
||||
else getClickPos (clickPoints, mousePos, idx + 1)
|
||||
end
|
||||
end
|
||||
|
||||
fun getClickPositionFromMouse (app: AppType.app_type) =
|
||||
case getClickPos (#xClickPoints app, #mouseX app, 0) of
|
||||
SOME hIdx =>
|
||||
(case getClickPos (#yClickPoints app, #mouseY app, 0) of
|
||||
SOME vIdx => SOME (hIdx, vIdx)
|
||||
| NONE => NONE)
|
||||
| NONE => NONE
|
||||
|
||||
fun getDrawDot (xpos, ypos, windowWidth, windowHeight) =
|
||||
let
|
||||
(* calculate normalised device coordinates *)
|
||||
val halfWidth = Real32.fromInt (windowWidth div 2)
|
||||
val halfHeight = Real32.fromInt (windowHeight div 2)
|
||||
val hpos = xpos - halfWidth
|
||||
val vpos = ~(ypos - halfHeight)
|
||||
|
||||
(* coordinates to form small box around clicked area *)
|
||||
val left = (hpos - 5.0) / halfWidth
|
||||
val right = (hpos + 5.0) / halfWidth
|
||||
val bottom = (vpos - 5.0) / halfHeight
|
||||
val top = (vpos + 5.0) / halfHeight
|
||||
in
|
||||
Ndc.ltrbToVertex (left, top, right, bottom)
|
||||
end
|
||||
|
||||
fun getDrawDotRgb (xpos, ypos, r, g, b, windowWidth, windowHeight) =
|
||||
let
|
||||
(* calculate normalised device coordinates *)
|
||||
val halfWidth = Real32.fromInt (windowWidth div 2)
|
||||
val halfHeight = Real32.fromInt (windowHeight div 2)
|
||||
val hpos = xpos - halfWidth
|
||||
val vpos = ~(ypos - halfHeight)
|
||||
|
||||
(* coordinates to form small box around clicked area *)
|
||||
val left = (hpos - 5.0) / halfWidth
|
||||
val right = (hpos + 5.0) / halfWidth
|
||||
val bottom = (vpos - 5.0) / halfHeight
|
||||
val top = (vpos + 5.0) / halfHeight
|
||||
in
|
||||
Ndc.ltrbToVertexRgb (left, top, right, bottom, r, g, b)
|
||||
end
|
||||
end
|
||||
103
dotscape/fcore/common-update.sml
Normal file
103
dotscape/fcore/common-update.sml
Normal file
@@ -0,0 +1,103 @@
|
||||
structure CommonUpdate =
|
||||
struct
|
||||
open AppType
|
||||
|
||||
open DrawMessage
|
||||
open FileMessage
|
||||
open InputMessage
|
||||
open UpdateMessage
|
||||
|
||||
fun resizeWindow (model, width, height, dots) =
|
||||
let
|
||||
val
|
||||
{ canvasWidth
|
||||
, canvasHeight
|
||||
, showGraph
|
||||
, arrowX
|
||||
, arrowY
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, layerTree
|
||||
, ...
|
||||
} = model
|
||||
|
||||
val maxSide = Int.max (canvasWidth, canvasHeight)
|
||||
val squares = LayerTree.flatten (maxSide, layerTree)
|
||||
|
||||
val squares = CollisionTree.toTriangles
|
||||
( width
|
||||
, height
|
||||
, squares
|
||||
, maxSide
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
)
|
||||
|
||||
val graphLines =
|
||||
if showGraph then GraphLines.generate model else Vector.fromList []
|
||||
|
||||
val drawMsg =
|
||||
RESIZE_SQUARES_DOTS_AND_GRAPH
|
||||
{squares = squares, graphLines = graphLines, dots = dots}
|
||||
val drawMsg = [DRAW drawMsg]
|
||||
in
|
||||
(model, drawMsg)
|
||||
end
|
||||
|
||||
fun getSaveSquaresMsg (model: app_type) =
|
||||
let
|
||||
val {layerTree, canvasWidth, canvasHeight, openFilePath, ...} = model
|
||||
val saveString =
|
||||
CollisionTree.toSaveString (layerTree, canvasWidth, canvasHeight)
|
||||
val msg = SAVE_SQUARES {output = saveString, filepath = openFilePath}
|
||||
in
|
||||
(model, [FILE msg])
|
||||
end
|
||||
|
||||
fun getLoadSquaresMsg (model: app_type) =
|
||||
let val msg = LOAD_SQUARES {filepath = #openFilePath model}
|
||||
in (model, [FILE msg])
|
||||
end
|
||||
|
||||
fun getExportSquaresMsg (model: app_type) =
|
||||
let
|
||||
val {layerTree, canvasWidth, canvasHeight, openFilePath, ...} = model
|
||||
|
||||
val maxSide = Int.max (canvasWidth, canvasHeight)
|
||||
val squares = LayerTree.flatten (maxSide, layerTree)
|
||||
|
||||
val exportString =
|
||||
CollisionTree.toExportString (squares, canvasWidth, canvasHeight, openFilePath)
|
||||
val msg = EXPORT_SQUARES {output = exportString, filepath = openFilePath}
|
||||
in
|
||||
(model, [FILE msg])
|
||||
end
|
||||
|
||||
fun getCollisionMsg (model: app_type) =
|
||||
let
|
||||
val {layerTree, canvasWidth, canvasHeight, modalNum, openFilePath, ...} =
|
||||
model
|
||||
|
||||
val maxSide = Int.max (canvasWidth, canvasHeight)
|
||||
val squares = LayerTree.flatten (maxSide, layerTree)
|
||||
|
||||
val exportString =
|
||||
CollisionTree.toCollisionString
|
||||
(squares, canvasWidth, canvasHeight, modalNum)
|
||||
|
||||
val exportFilePath = FileString.getCollisionFilename openFilePath
|
||||
val msg =
|
||||
EXPORT_COLLISIONS {output = exportString, filepath = exportFilePath}
|
||||
|
||||
val model = AppWith.modalNum (model, 0)
|
||||
in
|
||||
(model, [FILE msg])
|
||||
end
|
||||
|
||||
(* unimplemented *)
|
||||
fun useSquaresInNormalMode (model, squares) = (model, [])
|
||||
|
||||
fun squaresLoadError model = (model, [])
|
||||
end
|
||||
59
dotscape/fcore/file-string.sml
Normal file
59
dotscape/fcore/file-string.sml
Normal file
@@ -0,0 +1,59 @@
|
||||
structure FileString =
|
||||
struct
|
||||
fun findLastChr (str, pos, findChr) =
|
||||
if pos < 0 then ~1
|
||||
else if String.sub (str, pos) = findChr then pos
|
||||
else findLastChr (str, pos - 1, findChr)
|
||||
|
||||
fun extractFileName str =
|
||||
let
|
||||
val lastSlash = findLastChr (str, String.size str - 1, #"/")
|
||||
val strStart = lastSlash + 1
|
||||
in
|
||||
if lastSlash = ~1 then str
|
||||
else String.substring (str, strStart, String.size str - strStart)
|
||||
end
|
||||
|
||||
fun removeFileExtension str =
|
||||
let val lastDot = findLastChr (str, String.size str - 1, #".")
|
||||
in if lastDot = ~1 then str else String.substring (str, 0, lastDot)
|
||||
end
|
||||
|
||||
local
|
||||
fun finish acc =
|
||||
let val acc = List.rev acc
|
||||
in String.implode acc
|
||||
end
|
||||
|
||||
(* convert from kebab-case or snake_case to PascalCase *)
|
||||
fun loop (#"-" :: chr :: tl, acc) =
|
||||
let val acc = Char.toUpper chr :: acc
|
||||
in loop (tl, acc)
|
||||
end
|
||||
| loop (#"_" :: chr :: tl, acc) =
|
||||
let val acc = Char.toUpper chr :: acc
|
||||
in loop (tl, acc)
|
||||
end
|
||||
| loop ([#"-"], acc) = finish acc
|
||||
| loop ([#"_"], acc) = finish acc
|
||||
| loop (chr :: tl, acc) =
|
||||
loop (tl, chr :: acc)
|
||||
| loop ([], acc) = finish acc
|
||||
in
|
||||
fun filenameToStructureName str =
|
||||
let
|
||||
val str = removeFileExtension str
|
||||
val str = extractFileName str
|
||||
in
|
||||
(* capitalise first character in string *)
|
||||
case String.explode str of
|
||||
chr :: tl => let val chr = Char.toUpper chr in loop (tl, [chr]) end
|
||||
| [] => ""
|
||||
end
|
||||
end
|
||||
|
||||
fun getCollisionFilename str =
|
||||
let val str = removeFileExtension str
|
||||
in str ^ "-collisions.sml"
|
||||
end
|
||||
end
|
||||
69
dotscape/fcore/graph-lines.sml
Normal file
69
dotscape/fcore/graph-lines.sml
Normal file
@@ -0,0 +1,69 @@
|
||||
signature GRAPH_LINES =
|
||||
sig
|
||||
val generate: AppType.app_type -> Real32.real vector
|
||||
end
|
||||
|
||||
structure GraphLines :> GRAPH_LINES =
|
||||
struct
|
||||
fun helpGenGraphLinesX
|
||||
(pos, xClickPoints, yClickPoints, acc, windowWidth, windowHeight) =
|
||||
if pos = Vector.length xClickPoints then
|
||||
Vector.concat acc
|
||||
else
|
||||
let
|
||||
val halfWidth = Real32.fromInt windowWidth / 2.0
|
||||
val halfHeight = Real32.fromInt windowHeight / 2.0
|
||||
|
||||
val curX = Vector.sub (xClickPoints, pos)
|
||||
val minusX = Ndc.fromPixelX (curX - 1.0, windowWidth, windowHeight)
|
||||
val plusX = Ndc.fromPixelX (curX + 1.0, windowWidth, windowHeight)
|
||||
|
||||
val minY = Vector.sub (yClickPoints, 0)
|
||||
val maxY = Vector.sub (yClickPoints, Vector.length yClickPoints - 1)
|
||||
val minY = Ndc.fromPixelY (minY, windowWidth, windowHeight)
|
||||
val maxY = Ndc.fromPixelY (maxY, windowWidth, windowHeight)
|
||||
|
||||
val acc = Ndc.ltrbToVertex (minusX, maxY, plusX, minY) :: acc
|
||||
in
|
||||
helpGenGraphLinesX
|
||||
(pos + 1, xClickPoints, yClickPoints, acc, windowWidth, windowHeight)
|
||||
end
|
||||
|
||||
fun helpGenGraphLinesY
|
||||
(pos, yClickPoints, xClickPoints, acc, windowWidth, windowHeight) =
|
||||
if pos = Vector.length yClickPoints then
|
||||
acc
|
||||
else
|
||||
let
|
||||
val halfWidth = Real32.fromInt windowWidth / 2.0
|
||||
val halfHeight = Real32.fromInt windowHeight / 2.0
|
||||
|
||||
val curY = Vector.sub (yClickPoints, pos)
|
||||
val minusY = Ndc.fromPixelY (curY - 1.0, windowWidth, windowHeight)
|
||||
val plusY = Ndc.fromPixelY (curY + 1.0, windowWidth, windowHeight)
|
||||
|
||||
val minX = Vector.sub (xClickPoints, 0)
|
||||
val maxX = Vector.sub (xClickPoints, Vector.length xClickPoints - 1)
|
||||
val minX = Ndc.fromPixelX (minX, windowWidth, windowHeight)
|
||||
val maxX = Ndc.fromPixelX (maxX, windowWidth, windowHeight)
|
||||
|
||||
val acc = Ndc.ltrbToVertex (minX, plusY, maxX, minusY) :: acc
|
||||
in
|
||||
helpGenGraphLinesY
|
||||
(pos + 1, yClickPoints, xClickPoints, acc, windowWidth, windowHeight)
|
||||
end
|
||||
|
||||
fun helpGenerate (windowWidth, windowHeight, xClickPoints, yClickPoints) =
|
||||
let
|
||||
val acc = helpGenGraphLinesY
|
||||
(0, yClickPoints, xClickPoints, [], windowWidth, windowHeight)
|
||||
in
|
||||
helpGenGraphLinesX
|
||||
(0, xClickPoints, yClickPoints, acc, windowWidth, windowHeight)
|
||||
end
|
||||
|
||||
fun generate (app: AppType.app_type) =
|
||||
let val {windowWidth, windowHeight, xClickPoints, yClickPoints, ...} = app
|
||||
in helpGenerate (windowWidth, windowHeight, xClickPoints, yClickPoints)
|
||||
end
|
||||
end
|
||||
45
dotscape/fcore/grid.sml
Normal file
45
dotscape/fcore/grid.sml
Normal file
@@ -0,0 +1,45 @@
|
||||
structure Grid =
|
||||
struct
|
||||
type pixel = {r: int, g: int, b: int, a: int}
|
||||
|
||||
type t = pixel vector vector
|
||||
|
||||
val emptyPixel = {r = 0, g = 0, b = 0, a = 0}
|
||||
|
||||
fun isBlank ({a, ...}: pixel) = a = 0
|
||||
|
||||
fun changeGridSize maxSide grid =
|
||||
Vector.tabulate (maxSide, fn i =>
|
||||
if i < Vector.length grid then
|
||||
let
|
||||
val yAxis = Vector.sub (grid, i)
|
||||
in
|
||||
Vector.tabulate (maxSide, fn ii =>
|
||||
if ii < Vector.length yAxis then Vector.sub (yAxis, ii)
|
||||
else emptyPixel)
|
||||
end
|
||||
else
|
||||
Vector.tabulate (maxSide, fn _ => emptyPixel))
|
||||
|
||||
fun updateGrid (grid, newX, newY, pixel) =
|
||||
let
|
||||
val yAxis = Vector.sub (grid, newX)
|
||||
val yAxis = Vector.update (yAxis, newY, pixel)
|
||||
in
|
||||
Vector.update (grid, newX, yAxis)
|
||||
end
|
||||
|
||||
fun makeEmpty maxSide =
|
||||
Vector.tabulate (maxSide, fn _ =>
|
||||
Vector.tabulate (maxSide, fn _ => emptyPixel))
|
||||
|
||||
fun flipHorizontally (xAxis: t) =
|
||||
Vector.mapi
|
||||
(fn (xIdx, yAxis) =>
|
||||
let
|
||||
val flippedXIdx = Vector.length xAxis - 1 - xIdx
|
||||
val flippedYAxis = Vector.sub (xAxis, flippedXIdx)
|
||||
in
|
||||
Vector.mapi (fn (yIdx, _) => Vector.sub (flippedYAxis, yIdx)) yAxis
|
||||
end) xAxis
|
||||
end
|
||||
112
dotscape/fcore/layer-tree.sml
Normal file
112
dotscape/fcore/layer-tree.sml
Normal file
@@ -0,0 +1,112 @@
|
||||
structure LayerTree =
|
||||
struct
|
||||
datatype t = NODE of {key: int, value: Grid.t, left: t, right: t} | LEAF
|
||||
|
||||
val minKey = 1
|
||||
|
||||
fun init maxSide =
|
||||
let val grid = Grid.makeEmpty maxSide
|
||||
in NODE {key = minKey, value = grid, left = LEAF, right = LEAF}
|
||||
end
|
||||
|
||||
fun singleton grid =
|
||||
NODE {key = minKey, value = grid, left = LEAF, right = LEAF}
|
||||
|
||||
fun insert (newKey, newValue, tree) =
|
||||
case tree of
|
||||
LEAF => NODE {key = newKey, value = newValue, left = LEAF, right = LEAF}
|
||||
| NODE {key, value, left, right} =>
|
||||
if newKey < key then
|
||||
NODE
|
||||
{ key = key
|
||||
, value = value
|
||||
, left = insert (newKey, newValue, left)
|
||||
, right = right
|
||||
}
|
||||
else if newKey > key then
|
||||
NODE
|
||||
{ key = key
|
||||
, value = value
|
||||
, left = left
|
||||
, right = insert (newKey, newValue, right)
|
||||
}
|
||||
else
|
||||
NODE {key = key, value = newValue, left = left, right = right}
|
||||
|
||||
fun get (searchKey, tree) =
|
||||
case tree of
|
||||
LEAF => NONE
|
||||
| NODE {key, value, left, right} =>
|
||||
if searchKey < key then get (searchKey, left)
|
||||
else if searchKey > key then get (searchKey, right)
|
||||
else SOME value
|
||||
|
||||
fun foldl (f, tree, acc) =
|
||||
case tree of
|
||||
LEAF => acc
|
||||
| NODE {value, left, right, ...} =>
|
||||
let
|
||||
val acc = foldl (f, left, acc)
|
||||
val acc = f (value, acc)
|
||||
in
|
||||
foldl (f, right, acc)
|
||||
end
|
||||
|
||||
fun foldr (f, tree, acc) =
|
||||
case tree of
|
||||
LEAF => acc
|
||||
| NODE {value, left, right, ...} =>
|
||||
let
|
||||
val acc = foldr (f, right, acc)
|
||||
val acc = f (value, acc)
|
||||
in
|
||||
foldr (f, left, acc)
|
||||
end
|
||||
|
||||
fun map (f, tree) =
|
||||
case tree of
|
||||
LEAF => LEAF
|
||||
| NODE {key, value, left, right} =>
|
||||
let
|
||||
val left = map (f, left)
|
||||
val right = map (f, right)
|
||||
val newValue = f value
|
||||
in
|
||||
NODE {key = key, value = newValue, left = left, right = right}
|
||||
end
|
||||
|
||||
(* copies non-blank pixels in value vector into acc *)
|
||||
fun helpFlatten (value, acc) =
|
||||
Vector.mapi
|
||||
(fn (xIdx, valueYAxis) =>
|
||||
Vector.mapi
|
||||
(fn (yIdx, valuePixel) =>
|
||||
if Grid.isBlank valuePixel then
|
||||
let val accYAxis = Vector.sub (acc, xIdx)
|
||||
in Vector.sub (accYAxis, yIdx)
|
||||
end
|
||||
else
|
||||
valuePixel) valueYAxis) value
|
||||
|
||||
fun flatten (maxSide, tree) =
|
||||
foldl (helpFlatten, tree, Grid.makeEmpty maxSide)
|
||||
|
||||
fun changeGridSize (maxSide, tree) =
|
||||
let val f = Grid.changeGridSize maxSide
|
||||
in map (f, tree)
|
||||
end
|
||||
|
||||
fun addPixel (key, newX, newY, maxSide, pixel, tree) =
|
||||
let
|
||||
val grid =
|
||||
case get (key, tree) of
|
||||
SOME grid => grid
|
||||
| NONE => Grid.makeEmpty maxSide
|
||||
|
||||
val grid = Grid.updateGrid (grid, newX, newY, pixel)
|
||||
in
|
||||
insert (key, grid, tree)
|
||||
end
|
||||
|
||||
fun flipHorizontally tree = map (Grid.flipHorizontally, tree)
|
||||
end
|
||||
126
dotscape/fcore/move-mode.sml
Normal file
126
dotscape/fcore/move-mode.sml
Normal file
@@ -0,0 +1,126 @@
|
||||
structure MoveMode =
|
||||
struct
|
||||
open AppType
|
||||
open InputMessage
|
||||
open DrawMessage
|
||||
open UpdateMessage
|
||||
|
||||
fun resizeWindow (model, width, height) =
|
||||
let
|
||||
val model = AppWith.windowResize (model, width, height)
|
||||
val dots = Vector.fromList []
|
||||
in
|
||||
CommonUpdate.resizeWindow (model, width, height, dots)
|
||||
end
|
||||
|
||||
fun getDrawMsg (model: app_type) =
|
||||
let
|
||||
val
|
||||
{ canvasWidth
|
||||
, canvasHeight
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, layerTree
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, ...
|
||||
} = model
|
||||
|
||||
val maxSide = Int.max (canvasWidth, canvasHeight)
|
||||
val grid = LayerTree.flatten (maxSide, layerTree)
|
||||
|
||||
val squares = CollisionTree.toTriangles
|
||||
( windowWidth
|
||||
, windowHeight
|
||||
, grid
|
||||
, maxSide
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
)
|
||||
val drawMsg =
|
||||
DRAW_SQUARES_AND_DOTS {squares = squares, dots = Vector.fromList []}
|
||||
in
|
||||
(model, [DRAW drawMsg])
|
||||
end
|
||||
|
||||
val blankPixel = {r = 0, g = 0, b = 0, a = 0}
|
||||
|
||||
fun makeBlankYAxis length =
|
||||
Vector.tabulate (length, fn _ => blankPixel)
|
||||
|
||||
fun makeBlankXAxis length =
|
||||
Vector.tabulate (length, fn _ => makeBlankYAxis length)
|
||||
|
||||
fun finishMove (model: app_type, newGrid) =
|
||||
let
|
||||
val {layer, layerTree, arrowX, arrowY, ...} = model
|
||||
val layerTree = LayerTree.insert (layer, newGrid, layerTree)
|
||||
val model = AppWith.layerTree (model, layerTree, arrowX, arrowY)
|
||||
in
|
||||
getDrawMsg model
|
||||
end
|
||||
|
||||
fun moveImage (model: app_type, fMove) =
|
||||
let
|
||||
val {layer, layerTree, ...} = model
|
||||
in
|
||||
case LayerTree.get (layer, layerTree) of
|
||||
SOME grid => finishMove (model, fMove grid)
|
||||
| NONE => (model, [])
|
||||
end
|
||||
|
||||
fun helpMoveImageUp grid =
|
||||
Vector.mapi
|
||||
(fn (_, yAxis) =>
|
||||
Vector.mapi
|
||||
(fn (yIdx, pixel) =>
|
||||
if yIdx = Vector.length yAxis - 1 then blankPixel
|
||||
else Vector.sub (yAxis, yIdx + 1)) yAxis) grid
|
||||
|
||||
fun moveImageUp (model: app_type) = moveImage (model, helpMoveImageUp)
|
||||
|
||||
fun helpMoveImageDown grid =
|
||||
Vector.mapi
|
||||
(fn (_, yAxis) =>
|
||||
Vector.mapi
|
||||
(fn (yIdx, pixel) =>
|
||||
if yIdx = 0 then blankPixel else Vector.sub (yAxis, yIdx - 1))
|
||||
yAxis) grid
|
||||
|
||||
fun moveImageDown (model: app_type) = moveImage (model, helpMoveImageDown)
|
||||
|
||||
fun helpMoveImageLeft grid =
|
||||
Vector.mapi
|
||||
(fn (idx, yAxis) =>
|
||||
if idx + 1 = Vector.length grid then
|
||||
makeBlankYAxis (Vector.length grid)
|
||||
else
|
||||
Vector.sub (grid, idx + 1)) grid
|
||||
|
||||
fun moveImageLeft (model: app_type) = moveImage (model, helpMoveImageLeft)
|
||||
|
||||
fun helpMoveImageRight grid =
|
||||
Vector.mapi
|
||||
(fn (idx, yAxis) =>
|
||||
if idx = 0 then makeBlankYAxis (Vector.length grid)
|
||||
else Vector.sub (grid, idx - 1)) grid
|
||||
|
||||
fun moveImageRight (model: app_type) = moveImage (model, helpMoveImageRight)
|
||||
|
||||
fun enterNormalMode model =
|
||||
let val model = AppWith.mode (model, AppType.NORMAL_MODE)
|
||||
in (model, [])
|
||||
end
|
||||
|
||||
fun update (model, inputMsg) =
|
||||
case inputMsg of
|
||||
ARROW_UP => moveImageUp model
|
||||
| ARROW_DOWN => moveImageDown model
|
||||
| ARROW_LEFT => moveImageLeft model
|
||||
| ARROW_RIGHT => moveImageRight model
|
||||
| KEY_ESC => enterNormalMode model
|
||||
| RESIZE_WINDOW {width, height} => resizeWindow (model, width, height)
|
||||
| _ => (model, [])
|
||||
end
|
||||
38
dotscape/fcore/ndc.sml
Normal file
38
dotscape/fcore/ndc.sml
Normal file
@@ -0,0 +1,38 @@
|
||||
structure Ndc =
|
||||
struct
|
||||
(* ndc = normalised device coordinates *)
|
||||
|
||||
fun ltrbToVertex (left, top, right, bottom) =
|
||||
#[ left, bottom
|
||||
, right, bottom
|
||||
, left, top
|
||||
|
||||
, left, top
|
||||
, right, bottom
|
||||
, right, top
|
||||
]
|
||||
|
||||
fun ltrbToVertexRgb (startX, startY, endX, endY, r, g, b) =
|
||||
#[ startX, endY, r, g, b
|
||||
, endX, endY, r, g, b
|
||||
, startX, startY, r, g, b
|
||||
|
||||
, startX, startY, r, g, b
|
||||
, endX, endY, r, g, b
|
||||
, endX, startY, r, g, b
|
||||
]
|
||||
|
||||
fun fromPixelX (xpos, windowWidth, windowHeight) =
|
||||
let
|
||||
val halfWidth = Real32.fromInt windowWidth / 2.0
|
||||
in
|
||||
(xpos - halfWidth) / halfWidth
|
||||
end
|
||||
|
||||
fun fromPixelY (ypos, windowWidth, windowHeight) =
|
||||
let
|
||||
val halfHeight = Real32.fromInt windowHeight / 2.0
|
||||
in
|
||||
~((ypos - halfHeight) / halfHeight)
|
||||
end
|
||||
end
|
||||
404
dotscape/fcore/normal-mode.sml
Normal file
404
dotscape/fcore/normal-mode.sml
Normal file
@@ -0,0 +1,404 @@
|
||||
structure NormalMode =
|
||||
struct
|
||||
open AppType
|
||||
|
||||
open DrawMessage
|
||||
open FileMessage
|
||||
open InputMessage
|
||||
open UpdateMessage
|
||||
|
||||
fun getDotVecFromIndices (model: app_type, hIdx, vIdx) =
|
||||
let
|
||||
val {windowWidth, windowHeight, xClickPoints, yClickPoints, ...} = model
|
||||
val xpos = Vector.sub (xClickPoints, hIdx)
|
||||
val ypos = Vector.sub (yClickPoints, vIdx)
|
||||
|
||||
val endXpos =
|
||||
if hIdx + 1 = Vector.length xClickPoints then xpos
|
||||
else Vector.sub (xClickPoints, hIdx + 1)
|
||||
|
||||
val endYpos =
|
||||
if vIdx + 1 = Vector.length yClickPoints then ypos
|
||||
else Vector.sub (yClickPoints, vIdx + 1)
|
||||
|
||||
val tl = ClickPoints.getDrawDotRgb
|
||||
(xpos, ypos, 0.0, 0.0, 1.0, windowWidth, windowHeight)
|
||||
val tr = ClickPoints.getDrawDotRgb
|
||||
(endXpos, ypos, 0.0, 0.0, 1.0, windowWidth, windowHeight)
|
||||
val bl = ClickPoints.getDrawDotRgb
|
||||
(xpos, endYpos, 0.0, 0.0, 1.0, windowWidth, windowHeight)
|
||||
val br = ClickPoints.getDrawDotRgb
|
||||
(endXpos, endYpos, 0.0, 0.0, 1.0, windowWidth, windowHeight)
|
||||
in
|
||||
Vector.concat [tl, tr, bl, br]
|
||||
end
|
||||
|
||||
fun mouseMoveOrRelease (model: app_type) =
|
||||
let
|
||||
val drawVec =
|
||||
case ClickPoints.getClickPositionFromMouse model of
|
||||
SOME (hIdx, vIdx) => getDotVecFromIndices (model, hIdx, vIdx)
|
||||
| NONE => Vector.fromList []
|
||||
|
||||
val drawMsg = DRAW_DOT drawVec
|
||||
val drawMsg = [DRAW drawMsg]
|
||||
in
|
||||
(model, drawMsg)
|
||||
end
|
||||
|
||||
fun getDrawDotMsgWhenArrowIsAtBoundary model =
|
||||
let
|
||||
val {arrowX, arrowY, ...} = model
|
||||
val dotVec = getDotVecFromIndices (model, arrowX, arrowY)
|
||||
val drawMsg = DRAW_DOT dotVec
|
||||
val drawMsg = [DRAW drawMsg]
|
||||
in
|
||||
(model, drawMsg)
|
||||
end
|
||||
|
||||
fun moveArrowUp (model: app_type) =
|
||||
let
|
||||
val {arrowX, arrowY, ...} = model
|
||||
in
|
||||
if arrowY > 0 then
|
||||
let
|
||||
val newArrowY = arrowY - 1
|
||||
val model = AppWith.arrowY (model, newArrowY)
|
||||
|
||||
val dotVec = getDotVecFromIndices (model, arrowX, newArrowY)
|
||||
val drawMsg = DRAW_DOT dotVec
|
||||
val drawMsg = [DRAW drawMsg]
|
||||
in
|
||||
(model, drawMsg)
|
||||
end
|
||||
else
|
||||
getDrawDotMsgWhenArrowIsAtBoundary model
|
||||
end
|
||||
|
||||
fun moveArrowLeft (model: app_type) =
|
||||
let
|
||||
val {arrowX, arrowY, ...} = model
|
||||
in
|
||||
if arrowX > 0 then
|
||||
let
|
||||
val newArrowX = arrowX - 1
|
||||
val model = AppWith.arrowX (model, newArrowX)
|
||||
|
||||
val dotVec = getDotVecFromIndices (model, newArrowX, arrowY)
|
||||
val drawMsg = DRAW_DOT dotVec
|
||||
val drawMsg = [DRAW drawMsg]
|
||||
in
|
||||
(model, drawMsg)
|
||||
end
|
||||
else
|
||||
getDrawDotMsgWhenArrowIsAtBoundary model
|
||||
end
|
||||
|
||||
fun moveArrowRight (model: app_type) =
|
||||
let
|
||||
val {arrowX, arrowY, xClickPoints, ...} = model
|
||||
in
|
||||
if arrowX < Vector.length xClickPoints - 2 then
|
||||
let
|
||||
val newArrowX = arrowX + 1
|
||||
val model = AppWith.arrowX (model, newArrowX)
|
||||
|
||||
val dotVec = getDotVecFromIndices (model, newArrowX, arrowY)
|
||||
val drawMsg = DRAW_DOT dotVec
|
||||
val drawMsg = [DRAW drawMsg]
|
||||
in
|
||||
(model, drawMsg)
|
||||
end
|
||||
else
|
||||
getDrawDotMsgWhenArrowIsAtBoundary model
|
||||
end
|
||||
|
||||
fun moveArrowDown (model: app_type) =
|
||||
let
|
||||
val {arrowX, arrowY, yClickPoints, ...} = model
|
||||
in
|
||||
if arrowY < Vector.length yClickPoints - 2 then
|
||||
let
|
||||
val newArrowY = arrowY + 1
|
||||
val model = AppWith.arrowY (model, newArrowY)
|
||||
|
||||
val dotVec = getDotVecFromIndices (model, arrowX, newArrowY)
|
||||
val drawMsg = DRAW_DOT dotVec
|
||||
val drawMsg = [DRAW drawMsg]
|
||||
in
|
||||
(model, drawMsg)
|
||||
end
|
||||
else
|
||||
getDrawDotMsgWhenArrowIsAtBoundary model
|
||||
end
|
||||
|
||||
fun realToInt x = Real32.toInt IEEEReal.TO_NEAREST x
|
||||
|
||||
fun getDrawMessage (model: app_type, initialMsg) =
|
||||
let
|
||||
val
|
||||
{ canvasWidth
|
||||
, canvasHeight
|
||||
, layerTree
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, arrowX
|
||||
, arrowY
|
||||
, ...
|
||||
} = model
|
||||
|
||||
val maxSide = Int.max (canvasWidth, canvasHeight)
|
||||
val squares = LayerTree.flatten (maxSide, layerTree)
|
||||
|
||||
val dotVec = getDotVecFromIndices (model, arrowX, arrowY)
|
||||
|
||||
val squares = CollisionTree.toTriangles
|
||||
( windowWidth
|
||||
, windowHeight
|
||||
, squares
|
||||
, maxSide
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
)
|
||||
val drawMsg = DRAW_SQUARES_AND_DOTS {squares = squares, dots = dotVec}
|
||||
val drawMsg = DRAW (drawMsg) :: initialMsg
|
||||
in
|
||||
(model, drawMsg)
|
||||
end
|
||||
|
||||
fun changePixel (model: app_type, hIdx, vIdx, pixel) =
|
||||
let
|
||||
val {canvasWidth, canvasHeight, layer, layerTree, ...} = model
|
||||
|
||||
val maxSide = Int.max (canvasWidth, canvasHeight)
|
||||
|
||||
val layerTree = LayerTree.addPixel
|
||||
(layer, hIdx, vIdx, maxSide, pixel, layerTree)
|
||||
val model = AppWith.layerTree (model, layerTree, hIdx, vIdx)
|
||||
in
|
||||
getDrawMessage (model, [])
|
||||
end
|
||||
|
||||
fun addPixel (model: app_type, hIdx, vIdx) =
|
||||
let
|
||||
val {r, g, b, a, ...} = model
|
||||
val pixel = {r = r, g = g, b = b, a = a}
|
||||
in
|
||||
changePixel (model, hIdx, vIdx, pixel)
|
||||
end
|
||||
|
||||
fun deletePixel (model, hIdx, vIdx) =
|
||||
changePixel (model, hIdx, vIdx, Grid.emptyPixel)
|
||||
|
||||
fun mouseLeftClick model =
|
||||
case ClickPoints.getClickPositionFromMouse model of
|
||||
SOME (hIdx, vIdx) => addPixel (model, hIdx, vIdx)
|
||||
| NONE => (model, [])
|
||||
|
||||
fun enterOrSpaceCoordinates model =
|
||||
let val {arrowX, arrowY, ...} = model
|
||||
in addPixel (model, arrowX, arrowY)
|
||||
end
|
||||
|
||||
fun backspace model =
|
||||
let val {arrowX, arrowY, ...} = model
|
||||
in deletePixel (model, arrowX, arrowY)
|
||||
end
|
||||
|
||||
fun resizeWindow (model, width, height) =
|
||||
let
|
||||
val model = AppWith.windowResize (model, width, height)
|
||||
val {arrowX, arrowY, ...} = model
|
||||
val dots = getDotVecFromIndices (model, arrowX, arrowY)
|
||||
in
|
||||
CommonUpdate.resizeWindow (model, width, height, dots)
|
||||
end
|
||||
|
||||
fun undoAction model = (model, [])
|
||||
|
||||
fun redoAction model = (model, [])
|
||||
|
||||
fun toggleGraph (model: app_type) =
|
||||
if #showGraph model then
|
||||
let
|
||||
val model = AppWith.graphVisibility (model, false)
|
||||
val drawMsg = DRAW_GRAPH (Vector.fromList [])
|
||||
val drawMsg = [DRAW drawMsg]
|
||||
in
|
||||
(model, drawMsg)
|
||||
end
|
||||
else
|
||||
let
|
||||
val model = AppWith.graphVisibility (model, true)
|
||||
val graphLines = GraphLines.generate model
|
||||
val drawMsg = DRAW_GRAPH graphLines
|
||||
val drawMsg = [DRAW drawMsg]
|
||||
in
|
||||
(model, drawMsg)
|
||||
end
|
||||
|
||||
fun updateNum (model: app_type, newNum) =
|
||||
(AppWith.modalNum (model, newNum), [])
|
||||
|
||||
fun clearNum model = updateNum (model, 0)
|
||||
|
||||
fun updateRed model = (AppWith.r model, [])
|
||||
fun updateGreen model = (AppWith.g model, [])
|
||||
fun updateBlue model = (AppWith.b model, [])
|
||||
fun updateAlpha model = (AppWith.a model, [])
|
||||
fun changeLayer model = (AppWith.layer model, [])
|
||||
|
||||
fun selectCursorColour (model: app_type) =
|
||||
let
|
||||
val {layer, layerTree, arrowX, arrowY, ...} = model
|
||||
in
|
||||
case LayerTree.get (layer, layerTree) of
|
||||
SOME grid =>
|
||||
let
|
||||
val yAxis = Vector.sub (grid, arrowX)
|
||||
val {r, g, b, a} = Vector.sub (yAxis, arrowY)
|
||||
val model = AppWith.cursorColour (model, r, g, b, a)
|
||||
in
|
||||
(model, [])
|
||||
end
|
||||
| NONE => (model, [])
|
||||
end
|
||||
|
||||
fun updateCanvas (model, canvasWidth, canvasHeight) =
|
||||
let
|
||||
val
|
||||
{ arrowX
|
||||
, arrowY
|
||||
, windowWidth
|
||||
, windowHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
, showGraph
|
||||
, layerTree
|
||||
, ...
|
||||
} = model
|
||||
|
||||
val dotVec = getDotVecFromIndices (model, arrowX, arrowY)
|
||||
val graphLines =
|
||||
if showGraph then GraphLines.generate model else Vector.fromList []
|
||||
|
||||
val maxSide = Int.max (canvasWidth, canvasHeight)
|
||||
val squares = LayerTree.flatten (maxSide, layerTree)
|
||||
|
||||
val squares = CollisionTree.toTriangles
|
||||
( windowWidth
|
||||
, windowHeight
|
||||
, squares
|
||||
, maxSide
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
)
|
||||
|
||||
val msg =
|
||||
RESIZE_SQUARES_DOTS_AND_GRAPH
|
||||
{squares = squares, dots = dotVec, graphLines = graphLines}
|
||||
in
|
||||
(model, [DRAW msg])
|
||||
end
|
||||
|
||||
fun updateCanvasWidth model =
|
||||
let
|
||||
val {modalNum, layerTree, canvasHeight, ...} = model
|
||||
val newCanvasWidth = modalNum
|
||||
|
||||
val maxSide = Int.max (newCanvasWidth, canvasHeight)
|
||||
val layerTree = LayerTree.changeGridSize (maxSide, layerTree)
|
||||
|
||||
val model = AppWith.canvasWidth (model, newCanvasWidth, layerTree)
|
||||
val {canvasWidth, canvasHeight, ...} = model
|
||||
in
|
||||
updateCanvas (model, canvasWidth, canvasHeight)
|
||||
end
|
||||
|
||||
fun updateCanvasHeight model =
|
||||
let
|
||||
val {modalNum, layerTree, canvasWidth, ...} = model
|
||||
val newCanvasHeight = modalNum
|
||||
|
||||
val maxSide = Int.max (newCanvasHeight, canvasWidth)
|
||||
val layerTree = LayerTree.changeGridSize (maxSide, layerTree)
|
||||
|
||||
val model = AppWith.canvasHeight (model, newCanvasHeight, layerTree)
|
||||
val {canvasWidth, canvasHeight, ...} = model
|
||||
in
|
||||
updateCanvas (model, canvasWidth, canvasHeight)
|
||||
end
|
||||
|
||||
fun useLayers (model, layerTree, canvasWidth, canvasHeight) =
|
||||
let
|
||||
val model =
|
||||
AppWith.parsedLayerTree (model, layerTree, canvasWidth, canvasHeight)
|
||||
|
||||
val graphLines =
|
||||
if #showGraph model then GraphLines.generate model
|
||||
else Vector.fromList []
|
||||
val initialMsg = DRAW_GRAPH graphLines
|
||||
val initialMsg = [DRAW initialMsg]
|
||||
in
|
||||
getDrawMessage (model, initialMsg)
|
||||
end
|
||||
|
||||
fun enterMoveMode model =
|
||||
let val model = AppWith.mode (model, AppType.MOVE_MODE)
|
||||
in (model, [])
|
||||
end
|
||||
|
||||
fun flipHorizontally (model: app_type) =
|
||||
let
|
||||
val {layerTree, arrowX, arrowY, ...} = model
|
||||
val layerTree = LayerTree.flipHorizontally layerTree
|
||||
val model = AppWith.layerTree (model, layerTree, arrowX, arrowY)
|
||||
in
|
||||
getDrawMessage (model, [])
|
||||
end
|
||||
|
||||
fun update (model: app_type, inputMsg) =
|
||||
case inputMsg of
|
||||
MOUSE_MOVE {x = mouseX, y = mouseY} =>
|
||||
let val model = AppWith.mousePosition (model, mouseX, mouseY)
|
||||
in mouseMoveOrRelease model
|
||||
end
|
||||
| MOUSE_LEFT_RELEASE => mouseMoveOrRelease model
|
||||
| MOUSE_LEFT_CLICK => mouseLeftClick model
|
||||
| NUM num => updateNum (model, num)
|
||||
| KEY_ESC => clearNum model
|
||||
| KEY_R => updateRed model
|
||||
| KEY_G => updateGreen model
|
||||
| KEY_B => updateBlue model
|
||||
| KEY_A => updateAlpha model
|
||||
| KEY_L => changeLayer model
|
||||
| KEY_C => selectCursorColour model
|
||||
| KEY_W => updateCanvasWidth model
|
||||
| KEY_H => updateCanvasHeight model
|
||||
| KEY_M => enterMoveMode model
|
||||
| KEY_F => flipHorizontally model
|
||||
| RESIZE_WINDOW {width, height} => resizeWindow (model, width, height)
|
||||
| UNDO_ACTION => undoAction model
|
||||
| REDO_ACTION => redoAction model
|
||||
| KEY_T => toggleGraph model
|
||||
| KEY_CTRL_S => CommonUpdate.getSaveSquaresMsg model
|
||||
| KEY_CTRL_L => CommonUpdate.getLoadSquaresMsg model
|
||||
| KEY_CTRL_E => CommonUpdate.getExportSquaresMsg model
|
||||
| KEY_CTRL_C => CommonUpdate.getCollisionMsg model
|
||||
| USE_LAYERS {tree, canvasWidth, canvasHeight} =>
|
||||
useLayers (model, tree, canvasWidth, canvasHeight)
|
||||
| SQUARES_LOAD_ERROR => CommonUpdate.squaresLoadError model
|
||||
| ARROW_UP => moveArrowUp model
|
||||
| ARROW_LEFT => moveArrowLeft model
|
||||
| ARROW_RIGHT => moveArrowRight model
|
||||
| ARROW_DOWN => moveArrowDown model
|
||||
| KEY_BACKSPACE => backspace model
|
||||
| KEY_ENTER => enterOrSpaceCoordinates model
|
||||
| KEY_SPACE => enterOrSpaceCoordinates model
|
||||
end
|
||||
44
dotscape/fcore/parser/all-dfa.sml
Normal file
44
dotscape/fcore/parser/all-dfa.sml
Normal file
@@ -0,0 +1,44 @@
|
||||
structure AllDfa =
|
||||
struct
|
||||
type t =
|
||||
{ curInt: int
|
||||
, curSpace: int
|
||||
, curBrace: int
|
||||
, lastInt: int
|
||||
, lastSpace: int
|
||||
, lastBrace: int
|
||||
}
|
||||
|
||||
val initial: t =
|
||||
{ curInt = IntDfa.start
|
||||
, curSpace = SpaceDfa.start
|
||||
, curBrace = BraceDfa.start
|
||||
, lastInt = ~1
|
||||
, lastSpace = ~1
|
||||
, lastBrace = ~1
|
||||
}
|
||||
|
||||
fun areAllDead ({curInt, curSpace, curBrace, ...}: t) =
|
||||
curInt = 0 andalso curSpace = 0 andalso curBrace = 0
|
||||
|
||||
fun update (chr, dfa, pos) =
|
||||
let
|
||||
val {curInt, curSpace, curBrace, lastInt, lastBrace, lastSpace} = dfa
|
||||
|
||||
val curInt = IntDfa.next (curInt, chr)
|
||||
val curSpace = SpaceDfa.next (curSpace, chr)
|
||||
val curBrace = BraceDfa.next (curBrace, chr)
|
||||
|
||||
val lastInt = if IntDfa.isFinal curInt then pos else lastInt
|
||||
val lastSpace = if SpaceDfa.isFinal curSpace then pos else lastSpace
|
||||
val lastBrace = if BraceDfa.isFinal curBrace then pos else lastBrace
|
||||
in
|
||||
{ curInt = curInt
|
||||
, curSpace = curSpace
|
||||
, curBrace = curBrace
|
||||
, lastInt = lastInt
|
||||
, lastBrace = lastBrace
|
||||
, lastSpace = lastSpace
|
||||
}
|
||||
end
|
||||
end
|
||||
32
dotscape/fcore/parser/brace-dfa.sml
Normal file
32
dotscape/fcore/parser/brace-dfa.sml
Normal file
@@ -0,0 +1,32 @@
|
||||
structure BraceDfa =
|
||||
struct
|
||||
val dead = 0
|
||||
val start = 1
|
||||
val final = 2
|
||||
|
||||
fun makeStart i =
|
||||
let
|
||||
val chr = Char.chr i
|
||||
in
|
||||
if chr = #"{" orelse chr = #"}" orelse chr = #"[" orelse chr = #"]" then
|
||||
final
|
||||
else
|
||||
dead
|
||||
end
|
||||
|
||||
val deadTable = SpaceDfa.deadTable
|
||||
val startTable = Vector.tabulate (255, makeStart)
|
||||
val finalTable = deadTable
|
||||
|
||||
val tables = #[deadTable, startTable, finalTable]
|
||||
|
||||
fun isFinal state = state = final
|
||||
|
||||
fun next (state, chr) =
|
||||
let
|
||||
val table = Vector.sub (tables, state)
|
||||
val idx = Char.ord chr
|
||||
in
|
||||
Vector.sub (table, idx)
|
||||
end
|
||||
end
|
||||
27
dotscape/fcore/parser/int-dfa.sml
Normal file
27
dotscape/fcore/parser/int-dfa.sml
Normal file
@@ -0,0 +1,27 @@
|
||||
structure IntDfa =
|
||||
struct
|
||||
val dead = 0
|
||||
val start = 1
|
||||
val final = 2
|
||||
|
||||
fun makeStart i =
|
||||
let val chr = Char.chr i
|
||||
in if Char.isDigit chr then final else dead
|
||||
end
|
||||
|
||||
val deadTable = Vector.tabulate (255, fn _ => dead)
|
||||
val startTable = Vector.tabulate (255, makeStart)
|
||||
val finalTable = startTable
|
||||
|
||||
val tables = #[deadTable, startTable, finalTable]
|
||||
|
||||
fun isFinal state = state = final
|
||||
|
||||
fun next (state, chr) =
|
||||
let
|
||||
val table = Vector.sub (tables, state)
|
||||
val idx = Char.ord chr
|
||||
in
|
||||
Vector.sub (table, idx)
|
||||
end
|
||||
end
|
||||
59
dotscape/fcore/parser/lexer.sml
Normal file
59
dotscape/fcore/parser/lexer.sml
Normal file
@@ -0,0 +1,59 @@
|
||||
structure Lexer =
|
||||
struct
|
||||
structure T = Tokens
|
||||
|
||||
fun validMin (a, b) =
|
||||
if a = ~1 then b else if b = ~1 then a else Int.min (a, b)
|
||||
|
||||
fun addToken (acc, dfa: AllDfa.t, str, finish) =
|
||||
let
|
||||
val {lastInt, lastSpace, lastBrace, ...} = dfa
|
||||
val min = validMin (lastInt, lastSpace)
|
||||
val min = validMin (min, lastBrace)
|
||||
in
|
||||
if min = ~1 then
|
||||
NONE
|
||||
else if min = lastSpace then
|
||||
SOME (lastSpace, acc)
|
||||
else
|
||||
let
|
||||
val str = String.substring (str, min, finish - min + 1)
|
||||
in
|
||||
if min = lastInt then
|
||||
case Int.fromString str of
|
||||
SOME int => SOME (lastInt, T.INT int :: acc)
|
||||
| NONE => NONE
|
||||
else if min = lastBrace then
|
||||
if str = "{" then SOME (lastBrace, T.L_BRACE :: acc)
|
||||
else if str = "}" then SOME (lastBrace, T.R_BRACE :: acc)
|
||||
else if str = "[" then SOME (lastBrace, T.L_BRACKET :: acc)
|
||||
else if str = "]" then SOME (lastBrace, T.R_BRACKET :: acc)
|
||||
else NONE
|
||||
else
|
||||
NONE
|
||||
end
|
||||
end
|
||||
|
||||
fun scanStep (pos, str, acc, dfa, finish) =
|
||||
if pos < 0 orelse AllDfa.areAllDead dfa then
|
||||
addToken (acc, dfa, str, finish)
|
||||
else
|
||||
let
|
||||
val chr = String.sub (str, pos)
|
||||
val dfa = AllDfa.update (chr, dfa, pos)
|
||||
in
|
||||
if AllDfa.areAllDead dfa then addToken (acc, dfa, str, finish)
|
||||
else scanStep (pos - 1, str, acc, dfa, finish)
|
||||
end
|
||||
|
||||
fun scanLoop (pos, str, acc) =
|
||||
if pos < 0 then
|
||||
SOME acc
|
||||
else
|
||||
case scanStep (pos, str, acc, AllDfa.initial, pos) of
|
||||
SOME (pos, acc) => scanLoop (pos - 1, str, acc)
|
||||
| NONE => NONE
|
||||
|
||||
fun scan str =
|
||||
scanLoop (String.size str - 1, str, [])
|
||||
end
|
||||
36
dotscape/fcore/parser/parse-grid.sml
Normal file
36
dotscape/fcore/parser/parse-grid.sml
Normal file
@@ -0,0 +1,36 @@
|
||||
structure ParseGrid =
|
||||
struct
|
||||
fun make (canvasWidth, canvasHeight) =
|
||||
let
|
||||
val maxPoints = Int.max (canvasWidth, canvasHeight)
|
||||
val emptyYAxis = Vector.tabulate (maxPoints, fn _ =>
|
||||
{r = 0, g = 0, b = 0, a = 0})
|
||||
in
|
||||
Vector.tabulate (maxPoints, fn _ => emptyYAxis)
|
||||
end
|
||||
|
||||
local
|
||||
fun loopY (yAxis, x, ex, y, ey, colour) =
|
||||
if y > ey orelse y >= Vector.length yAxis then
|
||||
yAxis
|
||||
else
|
||||
let val yAxis = Vector.update (yAxis, y, colour)
|
||||
in loopY (yAxis, x, ex, y + 1, ey, colour)
|
||||
end
|
||||
|
||||
fun loopX (grid, x, ex, y, ey, colour) =
|
||||
if x > ex orelse x >= Vector.length grid then
|
||||
grid
|
||||
else
|
||||
let
|
||||
val yAxis = Vector.sub (grid, x)
|
||||
val yAxis = loopY (yAxis, x, ex, y, ey, colour)
|
||||
val grid = Vector.update (grid, x, yAxis)
|
||||
in
|
||||
loopX (grid, x + 1, ex, y, ey, colour)
|
||||
end
|
||||
in
|
||||
fun applyItem (grid, x, y, ex, ey, colour) =
|
||||
loopX (grid, x, ex, y, ey, colour)
|
||||
end
|
||||
end
|
||||
21
dotscape/fcore/parser/parser.md
Normal file
21
dotscape/fcore/parser/parser.md
Normal file
@@ -0,0 +1,21 @@
|
||||
# Parsing
|
||||
|
||||
The parsing functionality is for saving and loading from a custom file format.
|
||||
|
||||
The BNF for the custom file format is below.
|
||||
|
||||
Terminals are surrounded by `**` to the left and right. (rule)+ means "1 or more".
|
||||
|
||||
```
|
||||
int ::= (0-9)+
|
||||
|
||||
item ::= **{** int int int int int int int int **}**
|
||||
|
||||
layer ::= **[** item **]**
|
||||
|
||||
layer_tree ::= int int **{** (layer)* **}**
|
||||
```
|
||||
|
||||
The first two `int`s in the `layer_tree` always follow the order: `canvasWidth canvasHeight`.
|
||||
|
||||
The large number of `int`s in the `item` always follow the order: `x y ex ey r g b a`.
|
||||
82
dotscape/fcore/parser/parser.sml
Normal file
82
dotscape/fcore/parser/parser.sml
Normal file
@@ -0,0 +1,82 @@
|
||||
structure Parser =
|
||||
struct
|
||||
structure T = Tokens
|
||||
|
||||
fun parseItem (tokens, grid) =
|
||||
case tokens of
|
||||
T.L_BRACE ::
|
||||
T.INT x ::
|
||||
T.INT y ::
|
||||
T.INT ex ::
|
||||
T.INT ey ::
|
||||
T.INT r :: T.INT g :: T.INT b :: T.INT a :: T.R_BRACE :: tl =>
|
||||
let
|
||||
val colour = {r = r, g = g, b = b, a = a}
|
||||
val grid = ParseGrid.applyItem (grid, x, y, ex, ey, colour)
|
||||
in
|
||||
SOME (tl, grid)
|
||||
end
|
||||
| _ => NONE
|
||||
|
||||
(* note to be careful of:
|
||||
* - startParseItems returns NONE if there are no items found,
|
||||
* because we have not found a single item yet.
|
||||
*
|
||||
* - loopParseItems returns SOME if there are no items found,
|
||||
* because this function is called after we have parsed at least one item.
|
||||
* *)
|
||||
fun loopParseItems (tokens, grid) =
|
||||
case parseItem (tokens, grid) of
|
||||
SOME (tokens, grid) => loopParseItems (tokens, grid)
|
||||
| NONE => SOME (tokens, grid)
|
||||
|
||||
fun startParseItems (tokens, grid) =
|
||||
case parseItem (tokens, grid) of
|
||||
SOME (tokens, grid) => loopParseItems (tokens, grid)
|
||||
| NONE => NONE
|
||||
|
||||
fun parseLayer (tokens, canvasWidth, canvasHeight, tree, counter) =
|
||||
case tokens of
|
||||
T.L_BRACKET :: tl =>
|
||||
let
|
||||
val grid = ParseGrid.make (canvasWidth, canvasHeight)
|
||||
in
|
||||
case startParseItems (tl, grid) of
|
||||
SOME (T.R_BRACKET :: tl, grid) =>
|
||||
let val tree = LayerTree.insert (counter, grid, tree)
|
||||
in SOME (tl, tree)
|
||||
end
|
||||
| SOME _ => NONE
|
||||
| NONE => NONE
|
||||
end
|
||||
| _ => NONE
|
||||
|
||||
fun parseLayerLoop (tokens, canvasWidth, canvasHeight, tree, counter) =
|
||||
case parseLayer (tokens, canvasWidth, canvasHeight, tree, counter) of
|
||||
SOME (tl, tree) =>
|
||||
parseLayerLoop (tl, canvasWidth, canvasHeight, tree, counter + 1)
|
||||
| NONE => SOME (tokens, tree)
|
||||
|
||||
fun startParseLayer (tokens, canvasWidth, canvasHeight, tree) =
|
||||
case parseLayer (tokens, canvasWidth, canvasHeight, tree, 1) of
|
||||
SOME (tl, tree) => parseLayerLoop (tl, canvasWidth, canvasHeight, tree, 2)
|
||||
| NONE => NONE
|
||||
|
||||
fun parse string =
|
||||
case Lexer.scan string of
|
||||
SOME tokens =>
|
||||
(case tokens of
|
||||
T.INT canvasWidth :: T.INT canvasHeight :: T.L_BRACE :: tl =>
|
||||
let
|
||||
val maxSide = Int.max (canvasWidth, canvasHeight)
|
||||
val tree = LayerTree.init maxSide
|
||||
in
|
||||
case startParseLayer (tl, canvasWidth, canvasHeight, tree) of
|
||||
SOME ([T.R_BRACE], tree) =>
|
||||
SOME (canvasWidth, canvasHeight, tree)
|
||||
| SOME _ => NONE
|
||||
| NONE => NONE
|
||||
end
|
||||
| _ => NONE)
|
||||
| NONE => NONE
|
||||
end
|
||||
29
dotscape/fcore/parser/space-dfa.sml
Normal file
29
dotscape/fcore/parser/space-dfa.sml
Normal file
@@ -0,0 +1,29 @@
|
||||
structure SpaceDfa =
|
||||
struct
|
||||
val dead = 0
|
||||
val start = 1
|
||||
val final = 2
|
||||
|
||||
fun makeDead _ = 0
|
||||
|
||||
fun makeStart i =
|
||||
let val chr = Char.chr i
|
||||
in if Char.isSpace chr then final else dead
|
||||
end
|
||||
|
||||
val deadTable = Vector.tabulate (255, makeDead)
|
||||
val startTable = Vector.tabulate (255, makeStart)
|
||||
val finalTable = startTable
|
||||
|
||||
val tables = #[deadTable, startTable, finalTable]
|
||||
|
||||
fun isFinal state = state = final
|
||||
|
||||
fun next (state, chr) =
|
||||
let
|
||||
val table = Vector.sub (tables, state)
|
||||
val idx = Char.ord chr
|
||||
in
|
||||
Vector.sub (table, idx)
|
||||
end
|
||||
end
|
||||
2
dotscape/fcore/parser/tokens.sml
Normal file
2
dotscape/fcore/parser/tokens.sml
Normal file
@@ -0,0 +1,2 @@
|
||||
structure Tokens =
|
||||
struct datatype t = L_BRACE | R_BRACE | L_BRACKET | R_BRACKET | INT of int end
|
||||
678
dotscape/fcore/quad-tree.sml
Normal file
678
dotscape/fcore/quad-tree.sml
Normal file
@@ -0,0 +1,678 @@
|
||||
structure CollisionTree =
|
||||
struct
|
||||
structure BinTree =
|
||||
struct
|
||||
datatype 'a bintree =
|
||||
NODE of
|
||||
{ x: int
|
||||
, y: int
|
||||
, ex: int
|
||||
, ey: int
|
||||
, data: 'a
|
||||
, left: 'a bintree
|
||||
, right: 'a bintree
|
||||
}
|
||||
| LEAF
|
||||
|
||||
val empty = LEAF
|
||||
|
||||
fun insert (newItem as {x, y, ex, ey, data}, tree) =
|
||||
case tree of
|
||||
LEAF =>
|
||||
NODE
|
||||
{ x = x
|
||||
, y = y
|
||||
, ex = ex
|
||||
, ey = ey
|
||||
, data = data
|
||||
, left = LEAF
|
||||
, right = LEAF
|
||||
}
|
||||
| NODE {x = ox, y = oy, ex = oex, ey = oey, data = oldData, left, right} =>
|
||||
let
|
||||
val dir =
|
||||
if x < ox then
|
||||
LESS
|
||||
else if x > ox then
|
||||
GREATER
|
||||
else
|
||||
(if y < oy then
|
||||
LESS
|
||||
else if y > oy then
|
||||
GREATER
|
||||
else
|
||||
(if ex < oex then
|
||||
LESS
|
||||
else if ex > oex then
|
||||
GREATER
|
||||
else
|
||||
(if ey < oey then LESS
|
||||
else if ey > oey then GREATER
|
||||
else EQUAL)))
|
||||
in
|
||||
case dir of
|
||||
LESS =>
|
||||
NODE
|
||||
{ left = insert (newItem, left)
|
||||
, right = right
|
||||
, x = ox
|
||||
, y = oy
|
||||
, ex = oex
|
||||
, ey = oey
|
||||
, data = oldData
|
||||
}
|
||||
| GREATER =>
|
||||
NODE
|
||||
{ right = insert (newItem, right)
|
||||
, left = left
|
||||
, x = ox
|
||||
, y = oy
|
||||
, ex = oex
|
||||
, ey = oey
|
||||
, data = oldData
|
||||
}
|
||||
| EQUAL =>
|
||||
NODE
|
||||
{ left = left
|
||||
, right = right
|
||||
, x = x
|
||||
, y = y
|
||||
, ex = ex
|
||||
, ey = ey
|
||||
, data = data
|
||||
}
|
||||
end
|
||||
|
||||
fun foldr (f, tree, acc) =
|
||||
case tree of
|
||||
NODE {x, y, ex, ey, data, left, right} =>
|
||||
let
|
||||
val acc = foldr (f, right, acc)
|
||||
val item = {x = x, y = y, ex = ex, ey = ey, data = data}
|
||||
val acc = f (item, acc)
|
||||
in
|
||||
foldr (f, left, acc)
|
||||
end
|
||||
| LEAF => acc
|
||||
|
||||
fun toList tree =
|
||||
foldr (fn (item, acc) => item :: acc, tree, [])
|
||||
end
|
||||
|
||||
fun shouldIgnoreData {a, r = _, g = _, b = _} = a = 0
|
||||
|
||||
local
|
||||
fun loopYAxis (x, y, eX, eY, yAxis, col) =
|
||||
if y > eY orelse y >= Vector.length yAxis then
|
||||
true
|
||||
else
|
||||
let
|
||||
val newCol = Vector.sub (yAxis, y)
|
||||
in
|
||||
if col = newCol then loopYAxis (x, y + 1, eX, eY, yAxis, col)
|
||||
else false
|
||||
end
|
||||
|
||||
fun loopColour (x, y, eX, eY, grid, col) =
|
||||
if x > eX orelse x >= Vector.length grid then
|
||||
true
|
||||
else
|
||||
let
|
||||
val yAxis = Vector.sub (grid, x)
|
||||
in
|
||||
if loopYAxis (x, y, eX, eY, yAxis, col) then
|
||||
loopColour (x + 1, y, eX, eY, grid, col)
|
||||
else
|
||||
false
|
||||
end
|
||||
in
|
||||
fun quadHasSameColour (startX, startY, endX, endY, grid) =
|
||||
let
|
||||
val yAxis = Vector.sub (grid, startX)
|
||||
val col = Vector.sub (yAxis, startY)
|
||||
in
|
||||
loopColour (startX, startY, endX, endY, grid, col)
|
||||
end
|
||||
end
|
||||
|
||||
(* tree creation *)
|
||||
fun build (x, y, size, grid, bintree) =
|
||||
if x >= Vector.length grid orelse y >= Vector.length grid then
|
||||
bintree
|
||||
else if quadHasSameColour (x, y, x + size, y + size, grid) then
|
||||
let
|
||||
val yAxis = Vector.sub (grid, x)
|
||||
val data = Vector.sub (yAxis, y)
|
||||
in
|
||||
if shouldIgnoreData data then
|
||||
bintree
|
||||
else
|
||||
let
|
||||
val ex = x + size
|
||||
val ey = y + size
|
||||
val ex = Int.min (ex, Vector.length grid - 1)
|
||||
val ey = Int.min (ey, Vector.length grid - 1)
|
||||
val item = {x = x, y = y, ex = ex, ey = ey, data = data}
|
||||
in
|
||||
BinTree.insert (item, bintree)
|
||||
end
|
||||
end
|
||||
else
|
||||
(if size mod 2 = 0 orelse size = 1 then
|
||||
let
|
||||
val halfSize = size div 2
|
||||
val bintree = build (x, y, halfSize, grid, bintree)
|
||||
val bintree = build (x + halfSize, y, halfSize, grid, bintree)
|
||||
val bintree = build (x, y + halfSize, halfSize, grid, bintree)
|
||||
in
|
||||
build (x + halfSize, y + halfSize, halfSize, grid, bintree)
|
||||
end
|
||||
else
|
||||
(* handles odd-number divisions.
|
||||
* For example, `7 div 2` is 3 because of integer division.
|
||||
* We would not cover every pixel unless we handle odd numbers specially. *)
|
||||
let
|
||||
val halfSizeBefore = size div 2
|
||||
val halfSizeAfter = (size + 1) div 2
|
||||
val bintree = build (x, y, halfSizeAfter, grid, bintree)
|
||||
val bintree = build
|
||||
(x + halfSizeBefore, y, halfSizeAfter, grid, bintree)
|
||||
val bintree = build
|
||||
(x, y + halfSizeBefore, halfSizeAfter, grid, bintree)
|
||||
in
|
||||
build
|
||||
( x + halfSizeBefore
|
||||
, y + halfSizeBefore
|
||||
, halfSizeAfter
|
||||
, grid
|
||||
, bintree
|
||||
)
|
||||
end)
|
||||
|
||||
fun getClickPoint (clickPoints, pos) =
|
||||
let val idx = Int.min (pos, Vector.length clickPoints - 1)
|
||||
in Vector.sub (clickPoints, idx)
|
||||
end
|
||||
|
||||
fun folder
|
||||
( windowWidth
|
||||
, windowHeight
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
) ({x, ex, y, ey, data}, acc) =
|
||||
let
|
||||
val ex = if ex = x then x + 1 else ex + 1
|
||||
val ey = if ey = y then y + 1 else ey + 1
|
||||
|
||||
val x = getClickPoint (xClickPoints, x)
|
||||
val y = getClickPoint (yClickPoints, y)
|
||||
val ex = getClickPoint (xClickPoints, ex)
|
||||
val ey = getClickPoint (yClickPoints, ey)
|
||||
|
||||
val startX = Ndc.fromPixelX (x, windowWidth, windowHeight)
|
||||
val endX = Ndc.fromPixelX (ex, windowWidth, windowHeight)
|
||||
val startY = Ndc.fromPixelY (y, windowWidth, windowHeight)
|
||||
val endY = Ndc.fromPixelY (ey, windowWidth, windowHeight)
|
||||
|
||||
val {r, g, b, a} = data
|
||||
val r = Real32.fromInt r / 255.0
|
||||
val g = Real32.fromInt g / 255.0
|
||||
val b = Real32.fromInt b / 255.0
|
||||
val a = Real32.fromInt a / 255.0
|
||||
in
|
||||
Ndc.ltrbToVertexRgb (startX, startY, endX, endY, r, g, b) :: acc
|
||||
end
|
||||
|
||||
fun toTriangles
|
||||
( windowWidth
|
||||
, windowHeight
|
||||
, squares
|
||||
, size
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
) =
|
||||
let
|
||||
val bintree = build (0, 0, size, squares, BinTree.empty)
|
||||
|
||||
val f = folder
|
||||
( windowWidth
|
||||
, windowHeight
|
||||
, canvasWidth
|
||||
, canvasHeight
|
||||
, xClickPoints
|
||||
, yClickPoints
|
||||
)
|
||||
val vec = BinTree.foldr (f, bintree, [])
|
||||
in
|
||||
Vector.concat vec
|
||||
end
|
||||
|
||||
(* building and querying quad tree, plus compression *)
|
||||
datatype quad_tree =
|
||||
LEAF of {x: int, y: int, ex: int, ey: int, data: AppType.square}
|
||||
| NODE of {tl: quad_tree, tr: quad_tree, bl: quad_tree, br: quad_tree}
|
||||
| EMPTY
|
||||
|
||||
fun foldWithDuplicates (f, tree, acc) =
|
||||
case tree of
|
||||
EMPTY => acc
|
||||
| LEAF item => f (item, acc)
|
||||
| NODE {tl, tr, bl, br} =>
|
||||
let
|
||||
val acc = foldWithDuplicates (f, tl, acc)
|
||||
val acc = foldWithDuplicates (f, tr, acc)
|
||||
val acc = foldWithDuplicates (f, bl, acc)
|
||||
in
|
||||
foldWithDuplicates (f, br, acc)
|
||||
end
|
||||
|
||||
fun toBintree qtree =
|
||||
foldWithDuplicates (BinTree.insert, qtree, BinTree.empty)
|
||||
|
||||
fun buildTree (x, y, size, grid) =
|
||||
if x >= Vector.length grid orelse y >= Vector.length grid then
|
||||
EMPTY
|
||||
else if quadHasSameColour (x, y, x + size, y + size, grid) then
|
||||
let
|
||||
val yAxis = Vector.sub (grid, x)
|
||||
val data = Vector.sub (yAxis, y)
|
||||
in
|
||||
if shouldIgnoreData data then
|
||||
EMPTY
|
||||
else
|
||||
let
|
||||
val ex = x + size
|
||||
val ex = Int.min (ex, Vector.length grid - 1)
|
||||
val ey = y + size
|
||||
val ey = Int.min (ey, Vector.length grid - 1)
|
||||
in
|
||||
LEAF {x = x, y = y, ex = ex, ey = ey, data = data}
|
||||
end
|
||||
end
|
||||
else
|
||||
(if size mod 2 = 0 orelse size = 1 then
|
||||
let
|
||||
val halfSize = size div 2
|
||||
val tl = buildTree (x, y, halfSize, grid)
|
||||
val tr = buildTree (x + halfSize, y, halfSize, grid)
|
||||
val bl = buildTree (x, y + halfSize, halfSize, grid)
|
||||
val br = buildTree (x + halfSize, y + halfSize, halfSize, grid)
|
||||
in
|
||||
NODE {tl = tl, tr = tr, bl = bl, br = br}
|
||||
end
|
||||
else
|
||||
(* handles odd-number divisions.
|
||||
* For example, `7 div 2` is 3 because of integer division.
|
||||
* We would not cover every pixel unless we handle odd numbers specially. *)
|
||||
let
|
||||
val halfSizeBefore = size div 2
|
||||
val halfSizeAfter = (size + 1) div 2
|
||||
val tl = buildTree (x, y, halfSizeAfter, grid)
|
||||
val tr = buildTree (x + halfSizeBefore, y, halfSizeAfter, grid)
|
||||
val bl = buildTree (x, y + halfSizeBefore, halfSizeAfter, grid)
|
||||
val br =
|
||||
buildTree
|
||||
(x + halfSizeBefore, y + halfSizeBefore, halfSizeAfter, grid)
|
||||
in
|
||||
NODE {tl = tl, tr = tr, bl = bl, br = br}
|
||||
end)
|
||||
|
||||
local
|
||||
fun loop (x, y, ex, ey, grid) =
|
||||
if x < 0 then
|
||||
0
|
||||
else if quadHasSameColour (x, y, ex, ey, grid) then
|
||||
loop (x - 1, y, x, ey, grid)
|
||||
else
|
||||
ex
|
||||
in
|
||||
fun getLeftmostX ({x, y, ex, ey, data}, grid) =
|
||||
loop (x - 1, y, x, ey, grid)
|
||||
end
|
||||
|
||||
local
|
||||
fun loop (x, y, ex, ey, grid) =
|
||||
if x < Vector.length grid andalso ex < Vector.length grid then
|
||||
if quadHasSameColour (x, y, ex, ey, grid) then
|
||||
loop (ex, y, ex + 1, ey, grid)
|
||||
else
|
||||
x
|
||||
else
|
||||
Vector.length grid - 1
|
||||
in
|
||||
fun getRightmostX ({x, y, ex, ey, data}, grid) =
|
||||
loop (ex, y, ex + 1, ey, grid)
|
||||
end
|
||||
|
||||
local
|
||||
fun loop (x, y, ex, ey, grid) =
|
||||
if y < 0 then
|
||||
0
|
||||
else if quadHasSameColour (x, y, ex, ey, grid) then
|
||||
loop (x, y - 1, ex, y, grid)
|
||||
else
|
||||
ey
|
||||
in
|
||||
fun getTopmostY ({x, y, ex, ey, data}, grid) =
|
||||
if y < 0 orelse ey <= 0 then
|
||||
0
|
||||
else if quadHasSameColour (x, y, ex, ey, grid) then
|
||||
loop (x, y - 1, ex, y, grid)
|
||||
else
|
||||
y
|
||||
end
|
||||
|
||||
local
|
||||
fun loop (x, y, ex, ey, grid) =
|
||||
if y < Vector.length grid andalso ey < Vector.length grid then
|
||||
if quadHasSameColour (x, y, ex, ey, grid) then
|
||||
loop (x, ey, ex, ey + 1, grid)
|
||||
else
|
||||
y
|
||||
else
|
||||
Vector.length grid
|
||||
in
|
||||
fun getBottomY ({x, y, ex, ey, data}, grid) =
|
||||
if quadHasSameColour (x, y, ex, ey, grid) then loop (x, y, ex, ey, grid)
|
||||
else y
|
||||
end
|
||||
|
||||
local
|
||||
fun loop (tree, grid) =
|
||||
case tree of
|
||||
EMPTY => (EMPTY, false)
|
||||
| LEAF (oldItem as {x, y, ex, ey, data}) =>
|
||||
let
|
||||
val topY = getTopmostY (oldItem, grid)
|
||||
val bottomY = getBottomY (oldItem, grid)
|
||||
val newItem = {y = topY, ey = bottomY, x = x, ex = ex, data = data}
|
||||
val didItemChange = newItem <> oldItem
|
||||
in
|
||||
(LEAF newItem, didItemChange)
|
||||
end
|
||||
| NODE {tl, tr, bl, br} =>
|
||||
let
|
||||
val (tl, didTlChange) = loop (tl, grid)
|
||||
val (tr, didTrChange) = loop (tr, grid)
|
||||
val (bl, didBlChange) = loop (bl, grid)
|
||||
val (br, didBrChange) = loop (br, grid)
|
||||
|
||||
val node = NODE {tl = tl, tr = tr, bl = bl, br = br}
|
||||
val didChange =
|
||||
didTlChange orelse didTrChange orelse didBlChange
|
||||
orelse didBrChange
|
||||
in
|
||||
(node, false)
|
||||
end
|
||||
in
|
||||
fun mergeVertical (tree, grid) =
|
||||
let val (newTree, didChange) = loop (tree, grid)
|
||||
in if didChange then mergeVertical (newTree, grid) else newTree
|
||||
end
|
||||
end
|
||||
|
||||
local
|
||||
fun loop (tree, grid) =
|
||||
case tree of
|
||||
EMPTY => (EMPTY, false)
|
||||
| LEAF (oldItem as {x, y, ex, ey, data}) =>
|
||||
let
|
||||
val leftX = getLeftmostX (oldItem, grid)
|
||||
val rightX = getRightmostX (oldItem, grid)
|
||||
val newItem = {x = leftX, ex = rightX, y = y, ey = ey, data = data}
|
||||
val didItemChange = newItem <> oldItem
|
||||
in
|
||||
(LEAF newItem, didItemChange)
|
||||
end
|
||||
| NODE {tl, tr, bl, br} =>
|
||||
let
|
||||
val (tl, didTlChange) = loop (tl, grid)
|
||||
val (tr, didTrChange) = loop (tr, grid)
|
||||
val (bl, didBlChange) = loop (bl, grid)
|
||||
val (br, didBrChange) = loop (br, grid)
|
||||
|
||||
val node = NODE {tl = tl, tr = tr, bl = bl, br = br}
|
||||
val didChange =
|
||||
didTlChange orelse didTrChange orelse didBlChange
|
||||
orelse didBrChange
|
||||
in
|
||||
(node, didChange)
|
||||
end
|
||||
in
|
||||
fun mergeHorizontal (tree, grid) =
|
||||
let val (newTree, didChange) = loop (tree, grid)
|
||||
in if didChange then mergeHorizontal (newTree, grid) else newTree
|
||||
end
|
||||
end
|
||||
|
||||
fun merge (tree, grid) =
|
||||
let
|
||||
val tree = mergeVertical (tree, grid)
|
||||
val tree = mergeHorizontal (tree, grid)
|
||||
in
|
||||
toBintree tree
|
||||
end
|
||||
|
||||
fun toSaveStringFolder ({x, ex, y, ey, data = {r, g, b, a}}, acc) =
|
||||
let
|
||||
val item = String.concat
|
||||
[ " { "
|
||||
, Int.toString x
|
||||
, " "
|
||||
, Int.toString y
|
||||
, " "
|
||||
, Int.toString ex
|
||||
, " "
|
||||
, Int.toString ey
|
||||
, " "
|
||||
, Int.toString r
|
||||
, " "
|
||||
, Int.toString g
|
||||
, " "
|
||||
, Int.toString b
|
||||
, " "
|
||||
, Int.toString a
|
||||
, " } "
|
||||
]
|
||||
in
|
||||
item :: acc
|
||||
end
|
||||
|
||||
fun toSaveStringTreeFolder size (grid, acc) =
|
||||
let
|
||||
val qtree = buildTree (0, 0, size, grid)
|
||||
val bintree = merge (qtree, grid)
|
||||
val coords = BinTree.foldr (toSaveStringFolder, bintree, [])
|
||||
val coords = String.concat coords
|
||||
val str = "\n [ " ^ coords ^ " ]"
|
||||
in
|
||||
str :: acc
|
||||
end
|
||||
|
||||
fun toSaveString (layerTree, canvasWidth, canvasHeight) =
|
||||
let
|
||||
val size = Int.max (canvasWidth, canvasHeight)
|
||||
val f = toSaveStringTreeFolder size
|
||||
|
||||
val initial = ["\n}\n"]
|
||||
val acc = LayerTree.foldr (f, layerTree, initial)
|
||||
val acc =
|
||||
String.concat
|
||||
[Int.toString canvasWidth, " ", Int.toString canvasHeight, " { "]
|
||||
:: acc
|
||||
in
|
||||
String.concat acc
|
||||
end
|
||||
|
||||
fun intToRealString num =
|
||||
let
|
||||
val result = Real.fromInt num
|
||||
val result = Real.fmt (StringCvt.FIX (SOME 15)) result
|
||||
in
|
||||
if String.isSubstring "." result then result else result ^ ".0"
|
||||
end
|
||||
|
||||
fun colToRealString col =
|
||||
let
|
||||
val result = Real.fromInt col / 255.0
|
||||
val result = Real.fmt (StringCvt.FIX (SOME 15)) result
|
||||
in
|
||||
if String.isSubstring "." result then result else result ^ ".0"
|
||||
end
|
||||
|
||||
fun makeXString x =
|
||||
let val x = intToRealString x
|
||||
in "xToNdc (xOffset, " ^ x ^ ", scale, halfWidth)"
|
||||
end
|
||||
|
||||
fun makeYString y =
|
||||
let val y = intToRealString y
|
||||
in "yToNdc (yOffset, " ^ y ^ ", scale, halfHeight)"
|
||||
end
|
||||
|
||||
fun toExportStringFolder (maxWidth, maxHeight)
|
||||
({x, ex, y, ey, data = {r, g, b, a}}, acc) =
|
||||
let
|
||||
val ex = if ex < maxWidth then ex + 1 else ex
|
||||
val ey = if ey < maxHeight then ey + 1 else ey
|
||||
|
||||
val x = makeXString x
|
||||
val y = makeYString y
|
||||
val ex = makeXString ex
|
||||
val ey = makeYString ey
|
||||
val r = colToRealString r
|
||||
val g = colToRealString g
|
||||
val b = colToRealString b
|
||||
|
||||
(* based on triangle order formed by `Ndc.ltrbToVertexRgb` function *)
|
||||
val item = String.concatWith ",\n"
|
||||
[ x
|
||||
, ey
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, ex
|
||||
, ey
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, x
|
||||
, y
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, x
|
||||
, y
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, ex
|
||||
, ey
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
, ex
|
||||
, y
|
||||
, r
|
||||
, g
|
||||
, b
|
||||
]
|
||||
in
|
||||
item :: acc
|
||||
end
|
||||
|
||||
fun toExportString (squares, canvasWidth, canvasHeight, filepath) =
|
||||
let
|
||||
val size = Int.max (canvasWidth, canvasHeight)
|
||||
val qtree = buildTree (0, 0, size, squares)
|
||||
val bintree = merge (qtree, squares)
|
||||
|
||||
val f = toExportStringFolder (canvasWidth, canvasHeight)
|
||||
val coords = BinTree.foldr (f, bintree, [])
|
||||
val coords = String.concatWith ",\n" coords
|
||||
|
||||
val structureName = FileString.filenameToStructureName filepath
|
||||
val structureStart = String.concat ["structure ", structureName, " = struct\n"]
|
||||
in
|
||||
String.concat
|
||||
[ structureStart
|
||||
, " fun xToNdc (xOffset, xpos, scale, halfWidth) =\n"
|
||||
, " ((xpos * scale + xOffset) - halfWidth) / halfWidth\n\n"
|
||||
|
||||
, " fun yToNdc (yOffset, ypos, scale, halfHeight) =\n"
|
||||
, " ~(((ypos * scale + yOffset) - halfHeight) / halfHeight)\n\n"
|
||||
|
||||
, " fun lerp (xOffset, yOffset, scale, windowWidth, windowHeight) =\n"
|
||||
, " let\n"
|
||||
, " val windowWidth = Real32.fromInt windowWidth\n"
|
||||
, " val halfWidth = windowWidth / 2.0\n"
|
||||
, " val windowHeight = Real32.fromInt windowHeight\n"
|
||||
, " val halfHeight = windowHeight / 2.0\n"
|
||||
, " in\n"
|
||||
, " #[\n"
|
||||
, coords
|
||||
, "\n"
|
||||
, " ]\n"
|
||||
, " end\n"
|
||||
, "end\n"
|
||||
]
|
||||
end
|
||||
|
||||
(* functions for exporting a collision detection string *)
|
||||
fun mapItem (item as {r, g, b, a}) =
|
||||
if shouldIgnoreData item then item else {r = 1, g = 1, b = 1, a = 1}
|
||||
|
||||
fun mapYAxis yAxis = Vector.map mapItem yAxis
|
||||
|
||||
fun mapGrid grid = Vector.map mapYAxis grid
|
||||
|
||||
fun toCollisionStringFolder (scale, maxWidth, maxHeight)
|
||||
({x, ex, y, ey, data = _}, acc) =
|
||||
let
|
||||
val ex = if ex < maxWidth then ex + 1 else ex
|
||||
val ey = if ey < maxHeight then ey + 1 else ey
|
||||
|
||||
val width = ex - x
|
||||
val width = if width = 0 then width + 1 else width
|
||||
val height = ey - y
|
||||
val height = if height = 0 then height + 1 else height
|
||||
|
||||
val x = Int.toString (x * scale)
|
||||
val y = Int.toString (y * scale)
|
||||
val width = Int.toString (width * scale)
|
||||
val height = Int.toString (height * scale)
|
||||
|
||||
val item = String.concat
|
||||
[ "{x = "
|
||||
, x
|
||||
, ", y = "
|
||||
, y
|
||||
, ", width = "
|
||||
, width
|
||||
, ", height = "
|
||||
, height
|
||||
, " }"
|
||||
]
|
||||
in
|
||||
item :: acc
|
||||
end
|
||||
|
||||
fun toCollisionString (squares, canvasWidth, canvasHeight, scale) =
|
||||
let
|
||||
val squares = mapGrid squares
|
||||
val scale = if scale = 0 then 1 else scale
|
||||
val size = Int.max (canvasWidth, canvasHeight)
|
||||
val qtree = buildTree (0, 0, size, squares)
|
||||
val bintree = merge (qtree, squares)
|
||||
|
||||
val f = toCollisionStringFolder (scale, canvasWidth, canvasHeight)
|
||||
val collisions = BinTree.foldr (f, bintree, [])
|
||||
val collisions = String.concatWith ",\n" collisions
|
||||
in
|
||||
String.concat ["val collisions = #[", collisions, "]\n"]
|
||||
end
|
||||
end
|
||||
Reference in New Issue
Block a user