Haskellで図を作成してみましょう（その３） - 朝日ネット　技術者ブログ

開発部のgedokuです。

HaskellをeDSLのホスト言語として使うことの魅力を、作図を通じて伝えるシリーズの第二弾です。

第一弾はこちら。
第二弾はこちら。

前書き
図結合入門
今回使う図結合の仕方
目標に近づける
まとめ
次回予告

前書き

Haskellと lens の基礎知識がある上で第一弾と第二弾を読んだと想定します。

第一弾では以下の説明がありました:

それでは２つの図を作成しました：

楕円

テキスト

２つの図を一つに結合するには、定番のMonoidインスタンスを使います。目標図の全てのノードを揃えたらもっと詳しく図の結合の仕組みを説明しますが、とりあえず：

結合の仕組みを説明するときがやってまいりました。

Monoid インスタンスには結合的演算とそれに対して恒等要素とがあります。恒等要素は単に空図のことを指し、ある図を空図と結合しても何も変わらないという意味になります。

それでは、結合自体を見てみましょう。 Semigroup インスタンスによって結合的演算が決まりますので、結合的演算を Semigroup インスタンスとも呼びます。

図結合入門

複雑なものはより簡単な要素に分解することで解決できます。逆に、予測可能な動作と性質を持つシンプルな要素を組み合わせることによって、より強固で扱いやすい複合要素を作ることもできます。

diagrams (パッケージ名)を使って図を作ることも、問題を簡単な要素に分割して、それぞれの図を作って組合わせることになります。

Diagram (型名)の Semigroup インスタンスはすでに第一弾で触れていました。最小境界ボックスにテキストの Diagram を長方形の Diagram に重ね合せた例があります：

myDiagram :: Diagram B
myDiagram = myTextDia <> boundingRect myTextDia # lc red
 where
  myTextDia = textNF "Rendered text"

即ち、 Diagram の Semigroup インスタンスは 重ね合わせ です。同じ振る舞いが、インスタンス経由以外にも atop 関数で使えます。

Semigroup インスタンスは結合的(associative)ですが、可換的(commutative)ではありません。左の引数を右の引数に重ね合わせる振る舞いです。 a <> b より a `atop` b の方が a が b の上に重ね合わせると分かりやすいメリットが atop にあります。

重ね合わせは複数の図を一つの図に結合する一つの方法です。他にもあります。第一弾のtextEllSimple の実例に見かけた、 ||| と === を使った例:

myDiagram :: Diagram B
myDiagram =  (circ red  |||  circ blue)
                        ===
            (circ green ||| circ yellow)
 where
  circ color = circle 1 # fc color

(===) :: (InSpace V2 n a, Juxtaposable a, Semigroup a) => a -> a -> a
-- 'myDiagram'の'==='は
(|||) :: Diagram B -> Diagram B -> Diagram B

この演算子を使って、水平併置・垂直併置ができます。重ね合わせたら隣接するように、引数の一つの図の座標を変更してから重ね合わせるという仕組みです。

||| と === はより汎用な関数の特定な適用。その汎用な関数は beside です。縦横以外にもどの方向にも対応します。併置方向を決めるベクトルを引数でとります。このブログ記事には beside までは使う必要はないのですが、使用例は diagrams のドキュメンテーションをご参照ください。

３つ以上の図の結合は２つずつの結合の繰り返し適用で実現できます。このユースケースのヘルパー関数は、一個紹介させていただきます。

(図,座標)ペアのリストをとって、各図をその座標に移転させて、移転した全図を重ね合わせるのが position という関数です。

座標のコンポネントは二次元の場合は (横,縦) で、正の方向は横方向が右、縦方向が上です。

先の４つ丸の例を position で:

myDiagram :: Diagram B
myDiagram = position
  [ (p2 (0           ,0)            , circ red)
  , (p2 (radiusSize*2,0)            , circ blue)
  , (p2 (0           ,-radiusSize*2), circ green)
  , (p2 (radiusSize*2,-radiusSize*2), circ yellow)
  ]
 where
  circ color = circle radiusSize # fc color
  radiusSize = 1

他にも３つ以上の図の結合をサポートする関数があります:

cat は beside のリストをとるバージョン
hcat と vcat は ||| と === それぞれの、リストをとるバージョン
hsep と vsep は hcat と vcat それぞれの、元の振る舞いに加えて隣接する図の間に均一間隔を置く

position 以外は当ブログ記事に使いませんが、これら関数の使用例は diagrams のドキュメンテーションをご参照ください:

今回使う図結合の仕方

第一弾で意図した構文を振り返ってみましょう。

宣言型言語の定義に書いたのは:

### ノードを指定 (pseudocode)

client   = anywhere         person "Client"
lb       = (below client)   server "Load Balancer"
srvA     = (below lb)       server "Server A"
srvB     = (below right lb) server "Server B"
dbSrv    = (below srvB)     server "DB Server"
db       = (rightOf dbSrv)  disk   "DB"
nfs      = (below srvA)     disk   "NFS"
srvC     = (below nfs)      server "Server C"
otherSys = (below srvC)     server "Other Systems"

この例を目標にします。

目標に近づける

ノード二つを配置

まず、簡単のために二つのノードの場合を考えます。

# ノードを指定 (pseudocode)

client   = anywhere         person "Client"
lb       = (below client)   server "Load Balancer"

Haskellコードにおいて、この定義は let 句もしくは where 句にきます。配置せずにノード作成から始めます:

# ノードを指定
myDiagram :: Diagram B
myDiagram = undefined
 where
  -- Nodes
client   = person "Client"
lb       = server "Load Balancer"

person と server はそれぞれ、人とサーバーを表すノードの描き方を指定する関数です。人を楕円で、サーバーをボックスで、という風にします:

person :: String -> Diagram
person = textEll

server :: String -> Diagram
server = textBox

textEll と textBox は第一弾の「楕円でテキストを囲む関数」で見た、文字列をとってそれを囲む形状の図を返す関数です。

textEll と textBox は最低の幅(boxW)と高さ(boxH)の値を使って、ノードに(テキストが長いものを除き)均一なサイズを与えます。その定義は今回のブログ記事の範囲外ですが、第一弾の textEllSimple との入れ替えができます。

textEll, textBox :: String -> Diagram
textEll = ... -- Uses boxW/boxH
textBox = ... -- Uses boxW/boxH

boxW, boxH :: Double
boxW = boxH * 1.7
boxH = 2

サイズをなるべく相対的な大きさで定義するために、一つのサイズ(boxH)だけを数値で指定して、他のサイズ (boxW 、全ノードサイズ、ノード間距離)は相対比を使って定義します。

最終的に表示するのは一つの図だけなので、その二つのノード、 client と lb は一つの図に結合しないといけません。Semigroup インスタンスの結合をそのまま使ったら同じ位置に重なり合ってしまいます。

# ノードを指定
myDiagram :: Diagram B
myDiagram = client <> lb
 where
  -- Nodes
client   = person "Client"
lb       = server "Load Balancer"

並べて(また十個ぐらいのノードにもスケールするやりかたで)配置したいです。

[先程見た](id:c10745ab-3958-48cf-b0fd-3b43cb3bee48) position という関数を早速使ってみましょう。

-- position :: [(P2 Double, Diagram B)] -> Diagram B
myDiagram :: Diagram B
myDiagram = position [client, lb]
 where
  -- Nodes
  client = (p2 (0     ,0), person "Client")
  lb     = (p2 (boxW*2,0), server "Load Balancer")

  -- Components
  person :: String -> Diagram B
  person = textEll

  server :: String -> Diagram B
  server = textBox

position を使って二つのノードを別々の位置に配置しました。

position によって lb の原点が (0,0) から (boxW*2,0) に移されて、 client の原点は (0,0) のままで、両図は重ね合わせられました。

ノードの塗りつぶし(寄り道)

配置に続く前に、ノードを塗りつぶして、目標図に近づけましょう:

Pastel色セットにします。そういうセットは palette パッケージに定義されています。セットの色数を設定できます。この記事においては重要な選択ではありませんが、一応9つの色にします。

colors :: [Brewer.Kolor]
colors = brewerSet Brewer.Pastel1 9 -- Can choose between 3 to 9 colors

diagrams には fc (fillColor の同義語)という図を、指定された色で塗りつぶす関数があります。色の指数をとってセットの色を返すヘルパー関数を定義します。不正インデックスの場合は明らかにPastelでない、強い赤を返すようにします。

nodeStyle :: Int -> Diagram B -> Diagram B
nodeStyle ix = fc $ fromMaybe invalidIxColor mChosenColor
 where
  mChosenColor :: Maybe Brewer.Kolor
  mChosenColor = colors ^? element ix
  invalidIxColor :: Colour Double
  invalidIxColor = red

先の図を塗りつぶしました:

-- position :: [(P2 Double, Diagram B)] -> Diagram B
myDiagram :: Diagram B
myDiagram = position [client, lb]
 where
  -- Nodes
  client = (p2 (0     ,0), person "Client")
  lb     = (p2 (boxW*2,0), server "Load Balancer")

  -- Components
  person :: String -> Diagram B
  person s = nodeStyle 2 $ textEll s

  server :: String -> Diagram B
  server s = nodeStyle 1 $ textBox s

３つ以上のノードの配置

上記と同様に３つ以上のノードを配置しようとしたら、次のような図定義になります:

-- position :: [(P2 Double, Diagram B)] -> Diagram B
myDiagram :: Diagram B
myDiagram = position [n1,n2,n3,n4,n5]
 where
  -- Nodes
  n1 = (p2 (0     , 0)      , server "Node1")
  n2 = (p2 (0     , -2*boxH), server "Node2")
  n3 = (p2 (2*boxW, -2*boxH), server "Node3")
  n4 = (p2 (4*boxW, -2*boxH), server "Node4")
  n5 = (p2 (4*boxW, -4*boxH), server "Node5")

この書き方では全座標は独立しています。互いに相対的な配置をすることが意図だったとすると、一つのノードの変更が他のノードの変更に波及しかねません。

例えば、上の図は下記のようにノードを配置したいという意図だったとします。

ノード2がノード1の下に
ノード3がノード4の右に
ノード4がノード3の右に
ノード5がノード4の下に

そして、ノード2の配置をノード1の下から、ノードの1の右に変更したいとします。ノード2〜5の相対位置は変わっていないのに、ノード2〜5の絶対位置を変更しないといけません。

myDiagram :: Diagram B
myDiagram = position [n1,n2,n3,n4,n5]
 where
  -- Nodes
    n1 = (p2 (0     , 0)      , server "Node1")
  --n2 = (p2 (0     , -2*boxH), server "Node2")
    n2 = (p2 (2*boxW, 0)      , server "Node2") -- Changed
  --n3 = (p2 (2*boxW, -2*boxH), server "Node3")
    n3 = (p2 (4*boxW, 0)      , server "Node3") -- Changed
  --n4 = (p2 (4*boxW, -2*boxH), server "Node4")
    n4 = (p2 (6*boxW, 0)      , server "Node4") -- Changed
  --n5 = (p2 (4*boxW, -4*boxH), server "Node5")
    n5 = (p2 (6*boxW, -2*boxH), server "Node5") -- Changed

このメンテを手間を省く一つの方法は各ノードの座標を名前付きで定義して、座標同士が互いを参照することです。例えば、こういう風に(簡単のため、二つだけのノードの例):

-- position :: [(P2 Double, Diagram B)] -> Diagram B
myDiagram :: Diagram B
myDiagram = position [client, lb]
 where
  -- Nodes
  n1 = (p2 (x1, y1), server "Node1")
  n2 = (p2 (x2, y2), server "Node2")

  x1 = 0
  y1 = 0
  x2 = x1
  y2 = y1+2*boxH

しかし、目標の[ノード指定の例](id:4e337ef7-057f-4efe-9fb8-042ace53e7ea)ほどの抽象度ではありません。

ノード配置の相対的な指定

前項のコードを変更していきます:

-- Nodes
client = (p2 (0     ,0), person "Client")
lb     = (p2 (boxW*2,0), server "Load Balancer")

まずは原点のノード、これは相対的に指定しません。このノードの原点はそのまま (0,0) にしますが origin という定義を使うことでそれを明示的にします。

-- p2 (0,0) -> origin
client = (origin       , person "Client")
lb     = (p2 (boxW*2,0), server "Load Balancer")

origin は linear という、 diagrams-core が使っているLinear Algebra package に定義されています。何次元でも原点の意味を持っています。

次は lb を client に対して相対的に配置してみます。次のように:

client = (origin        , person "Client")
lb     = (rightOf client, server "Load Balancer")

rightOf :: ???
rightOf = undefined

Typed holeを使って rightOf の型をコンパイラーに聞いてみます:

(P2 Double, Diagram B) -> P2 Double

シグネチャーに合う、Xの座標(ペアの左のコンポネント)を 2*boxW でシフトする関数は以下の通りに書けます:

rightOf :: (P2 Double, Diagram B) -> P2 Double
rightOf (p, _) = p & _x %~ (+ 2*boxW)

改善できるところが二か所あります。一つは合成可能性にあって、もう一つは実装にあります。

このままの rightOf は関数合成に対応していないのです。「ノードの右に」は rightOf client でできましたが、「ノードの右下に」あるいは別の方向・効果と合成したいとしたら? 「右下」の場合は belowOf . rightOf $ client のような合成は、現在表現できません。 rightOf のような (a,b) -> a のような、入力型と出力型が違うシグネチャーは同型式を関数合成 (.) で合成できません。
シフトサイズの 2*boxW はハードコードされています。それを別の値にも変更する場合がありますし、そのつど leftOf のシフトのサイズと統一する方がいいです。

合成可能性 (1) の修正

少なくとも３つの選択肢が考えられます:

合成しない。ユースケースごとにad hocの関数を使う。例えば: bottomRightOf 、 topLeftOf 等
(.) とは別の演算子で合成する。適する演算子がなければ、実装する
関数合成で合成できるように rightOf のシグネチャーを変更する

このブログ記事では(3)にしてみましょう:

次のような式が使えるようにしたい belowOf . rightOf $ client 。 Of の繰り返しは冗長ですので省きます。 rightOf の名前を right に変更して below . right $ client を目指します。 below, above, left, right また、まだ考えていない将来のそういう式をお互いどの順番でも合成可能にしたいので、関数の出力型と入力型を合わせて P2 Double -> P2 Double というシグネチャーにします。 P2 Double は二つの Double のコンポネントを持つ座標です。 Point V2 Double のtype synonymなのです。

これで right の実装は次のようになりました:

right :: P2 Double -> P2 Double
right = _x %~ (+ (2*boxW))

このシグネチャーで合成可能です: below . right :: P2 Double -> P2 Double 。ただこのまま、ノード(client :: (P2 Double, Diagram B))には適用できません。まずペアの左のコンポネントにある座標を抽出する(fst :: (a,b) -> a を使って)必要があります。

これを書くには複数の方法があります:

単に fst をinlineに使う: below . right $ fst client
(1 とほとんど変わらない) $ の変わりに fst の機能を含む、この場合だけに使うカスタム演算子を使う。例えば a .$ b = a $ fst b という風に (.$) を定義すれば below . right .$ client が使えるようになります。
fst だけでなく座標変換後の、 position がとる型((P2 Double, Diagram B))にするために結果を包む。おまけに引数をタプルでとることで、これが使われる where 句をより表のような形にする (引数を括弧で囲まなくて済む)。例を見た方が分かりやすいです。

(3)にして、 mkNode と名づけます。

mkNode ::
  ( P2 Double -> P2 Double    -- ^ Function to apply on the relative node coordinates
  , (P2 Double, Diagram B)    -- ^ The relative node
  , Diagram B                 -- ^ The diagram to position
  ) -> (P2 Double, Diagram B) -- ^ The input diagram and its coordinates to be passed to 'position', can also be passed as a relative node
                              --   To other 'mkNode's
mkNode (coordFunc, relNode, diagram) = (coordFunc $ fst relNode, diagram)

Load balancer が client の右下(right . below)に配置するという例に使ったら:

myDiagram :: Diagram B
myDiagram = position [client, lb]
 where
  -- Nodes
  client = (origin, person "Client")
  lb     = mkNode (right . below, client, server "Load Balancer")

where 句の定義数が増えたら、原点である client だけが mkNode のものではないというのが目立ちます。外見のためだけでも見た目を統一してみましょう。

import           Diagrams.Prelude        hiding ( origin
                                                )
import qualified Diagrams.Prelude as DG

...

myDiagram :: Diagram B
myDiagram = position [client, lb]
 where
  -- Nodes
  client   = mkNode (at   , origin, person  "Client"      )
  lb       = mkNode (below, client, server "Load Balancer")

  at = id
  origin = (DG.origin, mempty)

origin は原点にある空図として定義して、 client はそこ(at)にあるという風に定義しました。 at は単に恒等関数 id に別の名前をつけたものです。相対ノードと同じ位置を明示します。

目標図の他のノードをそういう風に追加していけば下記のようになります:

myDiagram :: Diagram B
myDiagram = position [client, lb, srvA, srvB, dbSrv, db, nfs, srvC, otherSys]
 where
  -- Nodes
  client   = mkNode (at           , origin, person  "Client"      )
  lb       = mkNode (below        , client, server "Load Balancer")
  srvA     = mkNode (below        , lb    , server "Server A"     )
  srvB     = mkNode (below . right, lb    , server "Server B"     )
  dbSrv    = mkNode (below        , srvB  , server "DB Server"    )
  db       = mkNode (right        , dbSrv , disk   "DB"           )
  nfs      = mkNode (below        , srvA  , disk   "NFS"          )
  srvC     = mkNode (below        , nfs   , server "Server C"     )
  otherSys = mkNode (below        , srvC  , server "Other Systems")

NFS と DB の disk ノードは第二弾で定義した円筒図を使っています。

シフトのハードコード (2) の修正

right, left, above and below のシフトを設定可能にします。そして、 right と left 、また above and below それぞれのペアの関数が同シフトサイズを使うようにします。その二つの条件を達成する一つの方法は複数のシフト関数を同時に作ることです。ペアずつ作れば十分ですが、今回の例は４つとも同時に返すようにしました:

data Shifters = Shifters
  { left :: P2 Double -> P2 Double
  , right :: P2 Double -> P2 Double
  , below :: P2 Double -> P2 Double
  , above :: P2 Double -> P2 Double
  }

getShifters
  :: Double
  -> Double
  -> Shifters
getShifters dx dy = Shifters { .. }
 where
  left  = _x %~ subtract dx
  right = _x %~ (+ dx)
  below = _y %~ subtract dy
  above = _y %~ (+ dy)

(- dx) ではなく subtract dx にする必要があるのはコンパイラーがハイフンを特別に扱っているからです。ハイフンは単なる引き算の演算子だけでなく、符号を逆にする単行演算子という役割も担っているのです。

そして getShifters を使ったら下記のようになります:

myDiagram :: Diagram B
myDiagram = position [client, lb, srvA, srvB, dbSrv, db, nfs, srvC, otherSys]
 where
  -- Nodes
  client   = mkNode (const origin , client, person  "Client"       )
  lb       = mkNode (below        , client, server "Load Balancer")
  srvA     = mkNode (below        , lb    , server "Server A"     )
  srvB     = mkNode (below . right, lb    , server "Server B"     )
  dbSrv    = mkNode (below        , srvB  , server "DB Server"    )
  db       = mkNode (right        , dbSrv , disk   "DB"           )
  nfs      = mkNode (below        , srvA  , disk   "NFS"          )
  srvC     = mkNode (below        , nfs   , server "Server C"     )
  otherSys = mkNode (below        , srvC  , server "Other Systems")

  Shifters {left, right, above, below} =
    getShifters (boxW * 2) (boxH * 2)

Records を使うことで多少冗長になりましたが、 Recordsなしでも実装できます (またRecordWildCardsでちょっと緩和できます)。 Recordsを使うメリットは単にシフトの関数をちょっと間違いにくくすることです。

さらなる改善？

これでグラフのノードとその配置を望ましい抽象度で定義できるようになりました。ノードという概念があって、そのノートごとに指定するのは:

どのノードを使う (サーバー・ユーザー・DB・等、何を代表するノード)
ノードのラベル
他のノードに対する相対的な位置

まだ加えられる改善としては:

mkNode というノイズの省略
全ノードの二重指定しなくてもよい
1. position のリスト引数
2. where 句

これらは Template Haskell か Monad インタフェース (do-notation で一回だけ指定して、リファレンス用の値を返す) で解決できるかと思いますが、今回のブログ記事の対象外となります。

まとめ

この第三弾にもまた目標図に向けて一歩進んだかと思います。

図の組み合わせは何か、どういう風に組合わせられるのか、目標図のユースケースに適したものを選択しました。
目標の抽象化レベルに向けて、すこしづつコードを変更していって進みました。

次回も、目標図の完成に向けて、矢印回りに挑んでみます。

次回予告

矢印について学んで追加して、それらのラベルと位置を決めるロジックについて考えて実装します。