🌐
[F#]手軽なGraphicsモジュールをつくってみた
OCamlは標準でGraphicsモジュールがあり、自分の用途ではとても便利でした。
F#では標準モジュールとして同等のものはないようなので、SVG出力をベースに作ってみることにしました。
実装方針
2次元で簡単に線、矩形、円、ポリゴンなどが直感的に描画できるようにしたかったというのがそもそものスタートでした。
いま持っている知識だと、SVGを利用するのが最も簡単と考えたのでSVGを生成するコードを書くことにしました。
インターフェースは基本はOCamlのGraphicsモジュールをベースにしつつ、クローンを作るわけではなく適度に端折ってアレンジしました。
ソースコード
以下のように実装しました。
html形式としたため、イベント系の処理がJavaScript丸投げになっています。
module Graphics
type EntityAttribute =
| Id of string
| Class of string list
| Title of string
type Command =
| Plot of float * float * EntityAttribute list
| Plots of (float * float) array * EntityAttribute list
| MoveTo of float * float
| RMoveTo of float * float
| LineTo of float * float * EntityAttribute list
| RLineTo of float * float * EntityAttribute list
| DrawRect of float * float * float * float * EntityAttribute list
| DrawPolyLine of (float * float) array * EntityAttribute list
| DrawPoly of (float * float) array * EntityAttribute list
| FillPoly of (float * float) array * EntityAttribute list
| DrawCircle of float * float * float * EntityAttribute list
| FillRect of float * float * float * float * EntityAttribute list
| FillCircle of float * float * float * EntityAttribute list
| DrawString of string * EntityAttribute list
| SetLineWidth of int
| SetTextSize of int
| SetColor of int * int * int
with
member this.WithId (id : string) =
match this with
| Plot (x, y, attrs) -> Plot (x, y, Id(id) :: attrs)
| Plots (points, attrs) -> Plots (points, Id(id) :: attrs)
| LineTo (x, y, attrs) -> LineTo (x, y, Id(id) :: attrs)
| RLineTo (dx, dy, attrs) -> RLineTo (dx, dy, Id(id) :: attrs)
| DrawRect (x, y, w, h, attrs) -> DrawRect (x, y, w, h, Id(id) :: attrs)
| DrawPolyLine (points, attrs) -> DrawPolyLine (points, Id(id) :: attrs)
| DrawPoly (points, attrs) -> DrawPoly (points, Id(id) :: attrs)
| FillPoly (points, attrs) -> FillPoly (points, Id(id) :: attrs)
| DrawCircle (cx, cy, r, attrs) -> DrawCircle (cx, cy, r, Id(id) :: attrs)
| FillRect (x, y, w, h, attrs) -> FillRect (x, y, w, h, Id(id) :: attrs)
| FillCircle (cx, cy, r, attrs) -> FillCircle (cx, cy, r, Id(id) :: attrs)
| DrawString (s, attrs) -> DrawString (s, Id(id) :: attrs)
| _ as org -> org
member this.WithClass (className : string) =
match this with
| Plot (x, y, attrs) -> Plot (x, y, Class([className]) :: attrs)
| Plots (points, attrs) -> Plots (points, Class([className]) :: attrs)
| LineTo (x, y, attrs) -> LineTo (x, y, Class([className]) :: attrs)
| RLineTo (dx, dy, attrs) -> RLineTo (dx, dy, Class([className]) :: attrs)
| DrawRect (x, y, w, h, attrs) -> DrawRect (x, y, w, h, Class([className]) :: attrs)
| DrawPolyLine (points, attrs) -> DrawPolyLine (points, Class([className]) :: attrs)
| DrawPoly (points, attrs) -> DrawPoly (points, Class([className]) :: attrs)
| FillPoly (points, attrs) -> FillPoly (points, Class([className]) :: attrs)
| DrawCircle (cx, cy, r, attrs) -> DrawCircle (cx, cy, r, Class([className]) :: attrs)
| FillRect (x, y, w, h, attrs) -> FillRect (x, y, w, h, Class([className]) :: attrs)
| FillCircle (cx, cy, r, attrs) -> FillCircle (cx, cy, r, Class([className]) :: attrs)
| DrawString (s, attrs) -> DrawString (s, Class([className]) :: attrs)
| _ as org -> org
member this.WithTitle (title : string) =
match this with
| Plot (x, y, attrs) -> Plot (x, y, Title(title) :: attrs)
| Plots (points, attrs) -> Plots (points, Title(title) :: attrs)
| LineTo (x, y, attrs) -> LineTo (x, y, Title(title) :: attrs)
| RLineTo (dx, dy, attrs) -> RLineTo (dx, dy, Title(title) :: attrs)
| DrawRect (x, y, w, h, attrs) -> DrawRect (x, y, w, h, Title(title) :: attrs)
| DrawPolyLine (points, attrs) -> DrawPolyLine (points, Title(title) :: attrs)
| DrawPoly (points, attrs) -> DrawPoly (points, Title(title) :: attrs)
| FillPoly (points, attrs) -> FillPoly (points, Title(title) :: attrs)
| DrawCircle (cx, cy, r, attrs) -> DrawCircle (cx, cy, r, Title(title) :: attrs)
| FillRect (x, y, w, h, attrs) -> FillRect (x, y, w, h, Title(title) :: attrs)
| FillCircle (cx, cy, r, attrs) -> FillCircle (cx, cy, r, Title(title) :: attrs)
| DrawString (s, attrs) -> DrawString (s, Title(title) :: attrs)
| _ as org -> org
type GraphicsEvent =
{
Selector : string
EventName : string
Callback : string
}
let mutable m_mouseoverStyle : (string * string) list =
[
("stroke-width", "5")
("stroke", "blue")
("fill", "blue")
("fill-opacity", "0.5")
]
let mutable m_currentX = 0.0
let mutable m_currentY = 0.0
let mutable m_lineWidth = 1
let mutable m_textSize = 8
let mutable m_color = (0, 0, 0)
let mutable m_commandBuffer : Command list = []
let mutable m_events : GraphicsEvent list = []
let private attrText = function
| Id (s) -> sprintf " id='%s' " s
| Class (classes) -> System.String.Join (" ", classes)
|> sprintf " class='%s' "
| _ -> ""
let private titleText (attrs : EntityAttribute list) =
attrs
|> List.tryFind (fun x -> match x with | Title _ -> true | _ -> false)
|> function
| Some (Title (title)) -> sprintf "<title>%s</title>" title
| _ -> ""
let attrTextLine (attrs : EntityAttribute list) =
let mergeClass (target : EntityAttribute list) =
let classes =
target
|> List.choose (fun x -> match x with | Class classes -> Some (classes) | _ -> None)
|> List.concat
let others =
target
|> List.filter (fun x -> match x with | Class _ -> false | _ -> true)
List.concat [ others; [ Class (classes) ] ]
attrs
|> mergeClass
|> List.map attrText
|> fun x -> System.String.Join ("", x)
let setMouseoverStyle (kvPairs : (string * string) list) =
m_mouseoverStyle <- kvPairs
let svgPoint (attrs : EntityAttribute list) =
let (r, g, b) = m_color
sprintf "<circle %s cx='%.1f' cy='%.1f' r='2' fill='rgb(%d,%d,%d)'>%s</circle>"
(attrTextLine attrs)
m_currentX m_currentY r g b
(titleText attrs)
let svgLine (toX : float, toY : float) (attrs : EntityAttribute list) =
let (r, g, b) = m_color
sprintf "<line %s x1='%.1f' y1='%.1f' x2='%.1f' y2='%.1f' stroke='rgb(%d,%d,%d)' stroke-width='%d'>%s</line>"
(attrTextLine attrs)
m_currentX m_currentY toX toY r g b m_lineWidth
(titleText attrs)
let svgDrawRect (x : float, y : float, w : float, h : float) (attrs : EntityAttribute list) =
let (r, g, b) = m_color
sprintf "<rect %s x='%.1f' y='%.1f' width='%.1f' height='%.1f' stroke='rgb(%d,%d,%d)' fill='transparent' stroke-width='%d'>%s</rect>"
(attrTextLine attrs)
x y w h r g b
m_lineWidth
(titleText attrs)
let svgDrawCircle (cx : float, cy : float, radius : float) (attrs : EntityAttribute list) =
let (r, g, b) = m_color
sprintf "<circle %s cx='%.1f' cy='%.1f' r='%.1f' stroke='rgb(%d,%d,%d)' fill='transparent' stroke-width='%d'>%s</circle>"
(attrTextLine attrs)
cx cy radius r g b
m_lineWidth
(titleText attrs)
let svgFillRect (x : float, y : float, w : float, h : float) (attrs : EntityAttribute list) =
let (r, g, b) = m_color
sprintf "<rect %s x='%.1f' y='%.1f' width='%.1f' height='%.1f' fill='rgb(%d,%d,%d)' stroke-width='%d'>%s</rect>"
(attrTextLine attrs)
x y w h r g b
m_lineWidth
(titleText attrs)
let svgFillCircle (cx : float, cy : float, radius : float) (attrs : EntityAttribute list) =
let (r, g, b) = m_color
sprintf "<circle %s cx='%.1f' cy='%.1f' r='%.1f' fill='rgb(%d,%d,%d)' stroke-width='%d'>%s</circle>"
(attrTextLine attrs)
cx cy radius r g b
m_lineWidth
(titleText attrs)
let svgDrawPolygon (points : (float * float) array) (attrs : EntityAttribute list) =
let (r, g, b) = m_color
sprintf "<polygon %s points='%s' stroke='rgb(%d,%d,%d)' fill='transparent' stroke-width='%d'>%s</polygon>"
(attrTextLine attrs)
(points |> Array.map (fun (x, y) -> sprintf "%.1f,%.1f" x y)
|> fun vs -> System.String.Join (" ", vs))
r g b
m_lineWidth
(titleText attrs)
let svgDrawPolyLine (points : (float * float) array) (attrs : EntityAttribute list) =
let (r, g, b) = m_color
sprintf "<polyline %s points='%s' stroke='rgb(%d,%d,%d)' stroke-width='%d'>%s</polyline>"
(attrTextLine attrs)
(points |> Array.map (fun (x, y) -> sprintf "%.1f,%.1f" x y)
|> fun vs -> System.String.Join (" ", vs))
r g b
m_lineWidth
(titleText attrs)
let svgFillPolygon (points : (float * float) array) (attrs : EntityAttribute list) =
let (r, g, b) = m_color
sprintf "<polygon %s points='%s' fill='rgb(%d,%d,%d)' stroke-width='%d'>%s</polygon>"
(attrTextLine attrs)
(points |> Array.map (fun (x, y) -> sprintf "%.1f,%.1f" x y)
|> fun vs -> System.String.Join (" ", vs))
r g b
m_lineWidth
(titleText attrs)
let svgText (s : string) (attrs : EntityAttribute list) =
let (r, g, b) = m_color
sprintf "<text %s font-size='%d' stroke='rgb(%d,%d,%d)' fill='rgb(%d,%d,%d)' >%s</text>"
(attrTextLine attrs)
m_textSize
r g b
r g b
s
let doCommand = function
| Plot (x, y, attrs) -> let s = svgPoint attrs
m_currentX <- x
m_currentY <- y
s
| Plots (points, attrs) -> points |> Array.map (fun (x, y) ->
m_currentX <- x
m_currentY <- y
svgPoint attrs
)
|> fun x -> System.String.Join ("\n", x)
| MoveTo (x, y) -> m_currentX <- x
m_currentY <- y
""
| RMoveTo (dx, dy) -> m_currentX <- m_currentX + dx
m_currentY <- m_currentY + dy
""
| LineTo (x, y, attrs) -> let s = svgLine (x, y) attrs
m_currentX <- x
m_currentY <- y
s
| RLineTo (dx, dy, attrs) -> let (x, y) = (m_currentX + dx, m_currentY + dy)
let s = svgLine (x, y) attrs
m_currentX <- x
m_currentY <- y
s
| DrawRect (x, y, w, h, attrs) -> svgDrawRect (x, y, w, h) attrs
| DrawPolyLine (points, attrs) -> svgDrawPolyLine (points) attrs
| DrawPoly (points, attrs) -> svgDrawPolygon (points) attrs
| FillPoly (points, attrs) -> svgFillPolygon (points) attrs
| DrawCircle (cx, cy, r, attrs) -> svgDrawCircle (cx, cy, r) attrs
| FillRect (x, y, w, h, attrs) -> svgFillRect (x, y, w, h) attrs
| FillCircle (cx, cy, r, attrs) -> svgFillCircle (cx, cy, r) attrs
| DrawString (s, attrs) -> svgText (s) attrs
| SetLineWidth (width) -> m_lineWidth <- width
""
| SetTextSize (size) -> m_textSize <- size
""
| SetColor (r, g, b) -> m_color <- (r, g, b)
""
let private generateScript (event : GraphicsEvent) =
let selector = event.Selector
let eventName = event.EventName
let callback = event.Callback
[|
sprintf "document.querySelectorAll('%s').forEach(element => {" selector;
sprintf " element.addEventListener('%s', eve => {" eventName;
sprintf " %s" (callback.Replace("\n", "\n "));
" });";
"});"
|]
|> fun x -> System.String.Join("\n", x)
let private generateStyles () =
m_mouseoverStyle
|> List.map (fun (key, value) -> sprintf "%s : %s;" key value)
|> fun x -> System.String.Join (" ", x)
|> sprintf ".mouseover { %s }"
let private generateHtml (w, h) =
let scripts =
m_events
|> List.rev
|> List.map generateScript
|> fun x -> System.String.Join ("\n\n", x)
let svgContent =
m_commandBuffer
|> List.rev
|> List.map doCommand
|> fun x -> System.String.Join("\n", x)
sprintf """
<html>
<style>
%s
</style>
<body>
<svg width='%dpx' height='%dpx' viewbox='0,0,%d,%d' >
%s
</svg>
<script>
%s
</script>
</body>
</html>
"""
(generateStyles ())
w
h
w
h
svgContent
scripts
let saveHtml (w, h) =
let dst = @".\canvas.html"
generateHtml (w, h)
|> fun content -> System.IO.File.WriteAllText(dst, content)
dst
let openGraph(w, h) =
let dst = saveHtml (w, h)
System.Diagnostics.Process.Start(dst)
let closeGraph() = ()
let clearGraph() = ()
let sizeX() = ()
let sizeY() = ()
let private addBuffer (command) =
m_commandBuffer <- command :: m_commandBuffer
let defaultEntityAttributes =
[ Class (["entity"]) ]
let plot (x : float) (y : float) =
addBuffer <| Plot(x, y, defaultEntityAttributes)
let plots (pairs : (float * float) array) =
addBuffer <| Plots (pairs, defaultEntityAttributes)
let moveTo (x : float) (y : float) =
addBuffer <| MoveTo(x, y)
let rmoveTo (dx : float) (dy : float) =
addBuffer <| RMoveTo(dx, dy)
let currentX () = m_currentX
let currentY () = m_currentY
let lineTo (x : float) (y : float) =
addBuffer <| LineTo (x, y, defaultEntityAttributes)
let rlineTo (dx : float) (dy : float) =
addBuffer <| RLineTo (dx, dy, defaultEntityAttributes)
let drawRect (x : float) (y : float) (w : float) (h : float) =
addBuffer <| DrawRect (x, y, w, h, defaultEntityAttributes)
let drawPolyLine (pairs : (float * float) array) =
addBuffer <| DrawPolyLine (pairs, defaultEntityAttributes)
let drawPoly (pairs : (float * float) array) =
addBuffer <| DrawPoly (pairs, defaultEntityAttributes)
let fillPoly (pairs : (float * float) array) =
addBuffer <| FillPoly (pairs, defaultEntityAttributes)
let drawCircle (x : float) (y : float) (r : float) =
addBuffer <| DrawCircle (x, y, r, defaultEntityAttributes)
let setLineWidth (width : int) =
addBuffer <| SetLineWidth (width)
let setColor (r, g, b) =
addBuffer <| SetColor (r, g, b)
let drawString (s : string) =
addBuffer <| DrawString (s, defaultEntityAttributes)
let setTextSize (size : int) =
addBuffer <| SetTextSize (size)
let fillRect (x : float) (y : float) (w : float) (h : float) =
addBuffer <| FillRect (x, y, w, h, defaultEntityAttributes)
let fillCircle (x : float) (y : float) (r : float) =
addBuffer <| FillCircle (x, y, r, defaultEntityAttributes)
let withId (id : string) =
match m_commandBuffer with
| [] -> ()
| hd :: tl -> m_commandBuffer <- hd.WithId(id) :: tl
let withClass (className : string) =
match m_commandBuffer with
| [] -> ()
| hd :: tl -> m_commandBuffer <- hd.WithClass(className) :: tl
let withTitle (title : string) =
match m_commandBuffer with
| [] -> ()
| hd :: tl -> m_commandBuffer <- hd.WithTitle(title) :: tl
let addEventListener (selector : string) (eventName : string) (callback : string) =
m_events <- { Selector = selector
EventName = eventName
Callback = callback }
:: m_events
let addDefaultEventListener () =
addEventListener ".entity" "mouseover" "element.classList.add('mouseover');"
addEventListener ".entity" "mouseleave" "element.classList.remove('mouseover');"
使い方
こんな感じのスクリプトを書きます。
#load "Graphics.fs"
open Graphics
let test () =
let gridPoints =
[| for i in 0 .. 2 ->
[|
for j in 0 .. 2 -> (float ((i + 1) * 100), float ((j + 1) * 100))
|]
|]
|> Array.concat
let gridLines =
[|
(gridPoints.[0], gridPoints.[1])
(gridPoints.[1], gridPoints.[2])
(gridPoints.[3], gridPoints.[4])
(gridPoints.[4], gridPoints.[5])
(gridPoints.[6], gridPoints.[7])
(gridPoints.[7], gridPoints.[8])
(gridPoints.[0], gridPoints.[3])
(gridPoints.[1], gridPoints.[4])
(gridPoints.[2], gridPoints.[5])
(gridPoints.[3], gridPoints.[6])
(gridPoints.[4], gridPoints.[7])
(gridPoints.[5], gridPoints.[8])
|]
setColor (200, 200, 200)
fillPoly [| gridPoints.[0]; gridPoints.[1]; gridPoints.[4]; gridPoints.[3] |]
withTitle "rect1"
fillPoly [| gridPoints.[1]; gridPoints.[2]; gridPoints.[5]; gridPoints.[4] |]
withTitle "rect2"
setLineWidth 5
setColor (100, 100, 100)
gridLines
|> Array.iteri (fun i ((x1, y1), (x2, y2)) ->
moveTo x1 y1
lineTo x2 y2
withTitle <| sprintf "line%d" (i + 1)
)
gridPoints
|> Array.iteri (fun i (x, y) ->
fillCircle x y 10.0
withTitle <| sprintf "point%d" (i + 1)
)
addDefaultEventListener()
saveHtml (600, 600)
let path = test()
printfn "%s" path
でてくる出力はこんな感じです。
まとめ
- 出力がHTMLベースなのでつぶしが効いて便利。
- Event周りは強引だが、個人的には十分使える。
Discussion