🌐

[F#]手軽なGraphicsモジュールをつくってみた

2021/05/02に公開

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