前置き

Common Lisp（サブセット）をJavaScriptコードに変換するParenscriptを色々拡張しているps-experimentで以前パッケージもどきを追加したことがありました。

eshamster.hatenablog.com

単に use-package しているパッケージをたどっていって、その配下で定義したParenscript用関数をすべてJavaScriptに変換するという代物です。このときに、パッケージの出力順については「まあJavaScriptで出力順序が影響するケースも少ないだろうし、問題が起きた時に考えよう…」と思っていたのですが、とうとう問題が起きたので真面目に考えてみたというのが今回の発端です*1。

この出力順の問題は、一般化するとパッケージをノード、 use-package の関係をエッジ（useしている側が親、されている側が子）とした木構造として捉えられます。このノードを以下の条件を満たすように一列に並び替えます。

親ノードは子ノードよりも後ろに配置される

面倒なのは一つの子ノードが複数の親ノードを持つ可能性がある可能性や、循環参照が存在する可能性があるため、単なる深さ優先探索では不十分という点です。ひとまずは(1)親ノードは1つだけで循環参照も存在しないという条件から始めて、(2)循環参照はなしで親ノードを複数持てる場合、(3)循環参照をエラーにする場合、(4)循環参照を許可する場合*2と徐々に条件を厳しくして考えていきます。

たぶん世界中で100万人は考えたことのある問題です。

準備

コード込みで考えていきたいので、道具となる構造体や関数を定義しておきます。なおこの記事全般に言えることですが、コードは読み飛ばしてもだいたい意味は通る…はずです。

パッケージの依存関係処理に使いたいというのがそもそもの発端であったため、汎用に使えるようにgenericを定義しておきます。

( defgeneric get-node-name ( node )) ( defgeneric node-equalp ( node1 node2 )) ( defgeneric get-children ( node ))

単純な node 構造体とメソッドを作成します。

( defstruct node name children ) ( defmethod get-node-name (( node node )) ( node-name node )) ( defmethod node-equalp (( node1 node ) ( node2 node )) ( eq ( node-name node1 ) ( node-name node2 ))) ( defmethod get-children (( node node )) ( node-children node ))

単純な木

次に、実験用に木を簡単に構成するための補助関数を作成します。木の定義は ((:parentA :childA1 :childA2) (:parentB :childB1 :childB2) ...) のように簡単に書けるようにします。例えば、上図の木の場合は次のように書き下します。

( defparameter *simple-tree* '(( :a :b :c ) ( :c :d :e ) ( :d :f :g )))

これを、親子関係（ node-children ）を設定しながら node 構造体のリストにするのが make-tree です。なお aif や it はanaphoraライブラリのものです。

( defun make-tree ( parent-children-pair ) ( let (( node-pool ( make-hash-table )) ( result nil )) ( flet (( ensure-node ( name ) ( check-type name keyword ) ( aif ( gethash name node-pool ) it ( setf ( gethash name node-pool ) ( make-node :name name ))))) ( dolist ( pair parent-children-pair ) ( let (( parent ( ensure-node ( car pair )))) ( dolist ( child-name ( cdr pair )) ( push ( ensure-node child-name ) ( node-children parent ))) ( push parent result )))) ( dolist ( node result ) ( setf ( node-children node ) ( nreverse ( node-children node )))) result ))

また、与えられたノードのリストの子供をたどって、重複なしに全てのノードを一列に並べる関数 linearize-all-nodes を用意します*3。

( defun linearize-all-nodes ( node-list ) ( let (( result nil )) ( labels (( rec ( node ) ( unless ( some ( lambda ( target ) ( node-equalp target node )) result ) ( push node result ) ( dolist ( child ( get-children node )) ( rec child ))))) ( dolist ( node node-list ) ( rec node ))) result ))

本題

段階1：親ノードを一つしか持てず循環参照も存在しない木の場合

まずは1番単純な、親ノードを一つしか持てず循環参照も存在しない、下図のような木を考えます。

単純な木（再掲）

こうした木の場合は一番上のノードを取り出して、そこから深さ優先探索を行うだけで問題ありません。この制約下では、深さ優先探索で子ノードが親ノードよりも先に訪問されることはないためです。

( defun sort-tree-node-simply ( node-list ) ( let (( top-node ( find-if ( lambda ( target ) ( notany ( lambda ( parent ) ( some ( lambda ( child ) ( node-equalp target child )) ( get-children parent ))) node-list )) node-list ))) ( assert top-node ) ( linearize-all-nodes ( list top-node ))))

ソートした結果を表示するための関数（以降使いまわします）を作って結果を見てみると、正しくソートされていることが分かります。

( defun print-result ( tree sort-fn ) ( format t "~A~%" ( mapcar #'get-node-name ( funcall sort-fn ( make-tree tree ))))) ( print-result *simple-tree* #'sort-tree-node-simply )

次に、循環参照はないものの、ノードに複数の親を持つことを許した木を考えます。下図の例では、ノードFはAとDの2つの親を持ちます。

複数の親を許す木

( defparameter *duplicated-tree* ( make-tree '(( :a :b :f :c ) ( :c :d :e ) ( :d :f :g ) ( :f :h :i ))))

これを段階1の深さ優先ソートで出力してみると…

( print-result *duplicated-tree* #'sort-tree-node-simply ) ( E G D C I H F B A )

子であるFが出てくる前にDが出てきてしまっています。その親子関係まで見ると"DC"と"IHF"を入れ替えないと正しい結果にならないことが分かります。複数の親を許したために、A→Fというより早く探索されるパスができてしまったためにうまくいかなくなりました。

そこで、全ノードのリストからソート済みリストへ移すときに、既に子ノードがすべて後者の移されているかをチェックする機構を入れる必要があります。あとは、全ノードリストからチェックを通るものを一つずつピックアップしてソート済みリストに持っていくだけです。第1段階で仮定していたような、全ノードの取得部分 linearize-all-nodes が深さ優先探索であるという仮定もいらなくなります。

( defun all-children-are-processed ( node processed-node-list ) ( every ( lambda ( child ) ( or ( node-equalp node child ) ( find child processed-node-list :test #'node-equalp ))) ( get-children node ))) ( defun sort-tree-node-with-duplication ( node-list ) ( labels (( rec ( rest-nodes result ) ( aif ( find-if ( lambda ( node ) ( all-children-are-processed node result )) rest-nodes ) ( rec ( remove it rest-nodes :test #'node-equalp ) ( cons it result )) result ))) ( reverse ( rec ( linearize-all-nodes node-list ) nil ))))

結果を見ると、今度はノードDとCの前にI, H, Fが全て出てきており、正しい順番にソートされることが分かります。

( print-result *duplicated-tree* #'sort-tree-node-with-duplication )

段階3：循環参照を検知してエラーにする

次は循環参照の存在する木を考えます。下図は「F→G→D→F→G→D→…」の循環参照が存在する木です。

循環参照が存在する木

( defparameter *circular-tree1* '(( :a :b :f :c ) ( :f :h :g ) ( :g :d ) ( :d :f ) ( :c :d :e )))

循環参照部分は「親ノードは子ノードよりも後ろに配置される」という条件を決して満たせないため、検知してエラーにする必要があります。なお、試しに前節の sort-tree-node-with-duplication で並び替えてみると…循環参照を形成するF, G, Dの他、それらに依存するA, Cも巻き込まれて出力されません。

( print-result *circular-tree1* #'sort-tree-node-with-duplication )

さて、まずは循環参照を検出する関数 extract-circular-nodes を作成します。内部関数 rec が本体になりますが、深さ優先探索で木を探索しながら、トップから現在ノードまでの経路を traverse-list に格納しています。新たに辿ろうとした子ノードが traverse-list に既に含まれていた場合、循環参照が存在することが分かります。また、このとき traverse-list の先頭から同リスト内の子ノードまでが循環経路になります（コード上では traverse-list を reverse して member で子ノード以降を取り出すという操作をしています）。この辺りのアイディアは、後述のASDFでの循環参照検知方法を参考にしています（というよりそのままです）。なお、自己参照も循環参照の一種ではありますが、害はないので素通しにしています。

( defun extract-circular-nodes ( node-list ) ( labels (( rec ( current-node traverse-list ) ( setf traverse-list ( cons current-node traverse-list )) ( dolist ( child ( get-children current-node )) ( unless ( node-equalp current-node child ) ( when ( find child traverse-list :test #'node-equalp ) ( let (( result ( member child ( reverse traverse-list ) :test #'node-equalp ))) ( return-from rec result ))) ( let (( next-result ( rec child traverse-list ))) ( when next-result ( return-from rec next-result ))))) nil )) ( dolist ( node node-list ) ( awhen ( rec node nil ) ( return-from extract-circular-nodes it )))))

後はこれを利用して循環参照をエラーにするチェック関数を用意して、 sort-tree-node-with-duplication の手前に設置すれば、循環参照をエラーにする sort-tree-node-checking-circular の完成です。

( defun check-circular-dependency ( node-list ) ( awhen ( extract-circular-nodes node-list ) ( error "There is (a) circular dependency: ~A" ( mapcar #'get-node-name it )))) ( defun sort-tree-node-checking-circular ( node-list ) ( check-circular-dependency ( linearize-all-nodes node-list )) ( sort-tree-node-with-duplication node-list ))

次のように、循環参照を検知してエラーにしつつ、そうでなければ sort-tree-node-with-duplication と同等のソート性能を持つことが分かります。

( print-result *duplicated-tree1* #'sort-tree-node-checking-circular ) ( print-result *circular-tree* #'sort-tree-node-checking-circular )

余談：ASDFにおける循環参照検知

ここで余談ですが、今回 パクった 参考にしたASDFのコードについてです。

ASDFでは .asd ファイルに defsystem でシステムを定義しますが、ここで各モジュールを構成するファイル間の依存関係を定義します。 asdf:load-system 時にはこれを見て、循環参照があればエラーにしています。実際にエラーを検知してエラーを出力しているのは asdf.lisp の下記 call-while-visiting-action です。なお、これは1ノード分の処理であり、木の探索自体はより上位の関数で実行します。

若干用語を補足します。

action : 今回で言うノードに当たるようです

: 今回で言うノードに当たるようです action-list : 今回でいう traverse-list で、現在の通過経路が入ったリストです

: 今回でいう で、現在の通過経路が入ったリストです action-set : action をキーとし、ブール値を値とするハッシュです。ここでは通過経路にt、それ以外にnilを入れているようです*4

循環参照の検知をしているのは (gethash action action-set) で、通過経路に現在の action があるかを判定しています。検知した場合は、循環参照エラーにします。このとき、 action-list を reverse して member で現在の action 以降を取り出すことで、循環経路を取り出しています。…というように、ハッシュを使っている以外はそのまま参考にしました。

( defmethod call-while-visiting-action (( plan plan-traversal ) operation component fun ) ( with-accessors (( action-set plan-visiting-action-set ) ( action-list plan-visiting-action-list )) plan ( let (( action ( cons operation component ))) ( when ( gethash action action-set ) ( error ' circular-dependency :actions ( member action ( reverse action-list ) :test ' equal ))) ( setf ( gethash action action-set ) t ) ( push action action-list ) ( unwind-protect ( funcall fun ) ( pop action-list ) ( setf ( gethash action action-set ) nil )))))

段階4：循環参照ノードをグループ化して解決する

※警告：この段階4は実用性が微妙なくせに説明がとても長いです…

循環参照がある時点で基本的におかしいので、即エラーの段階3まででも良い気もします。ただ、ASDFにおけるファイル間の循環参照とは違い、パッケージ間の循環参照については検知される契機がないため、どこかでやらかしているライブラリがあると詰む可能性が考えられます。そのため、将来的な逃げ道のために循環参照をある程度いなして解決する方法を考えておきます。

循環参照が存在する木（再掲）

ここで、改めて循環参照の存在する木を眺めてみると、循環参照をグループ化して一つの塊だと思えばうまくいきそうです。つまり、FGDを1つのグループと見て、FGDはHに依存し、AとCはそれぞれFGDに依存しているといった具合です。そして、同じグループに属するノードの出力順は任意で良いことにします。さて、図を見ながら考えると、グループやグループ間の等値性、グループ間の依存は下記のように定義できそうです*5。なお、ノードとグループを別個に扱うのは面倒そうなので、ノード1つの「塊」もグループとして扱うことにします。

定義：グループ 1つ以上のノードから構成され、かつ、 2つ以上のノードが存在する場合、グループ内の全ノードを含む循環参照が存在する 要は循環参照をグループ化しますということです



( defstruct node-group nodes children )

定義：グループの等値比較 グループAとグループBが等値であるとは、構成するノードが同じであることを言う 1つのノードは必ずある1つのグループだけに属しているという制約を設けるため、実際にはノードが1つでも一致すれば等値です



( defmethod node-equalp (( node1 node-group ) ( node2 node-group )) ( let (( first-node ( first ( node-group-nodes node1 )))) ( assert first-node ) ( find first-node ( node-group-nodes node2 ) :test #'node-equalp )))

定義：グループ間の依存 グループAがグループBに依存しているとき、グループAに含まれるノードの子ノードのうち、少なくとも1つがBに含まれる



( defun group-depend-p ( target base ) ( some ( lambda ( base-node ) ( some ( lambda ( target-node ) ( find target-node ( get-children base-node ) :test #'node-equalp )) ( node-group-nodes target ))) ( node-group-nodes base )))

（きちんと証明する能がないですが…）こうした定義から下記の性質を持つ点が重要です。

性質

グループはノードとしての性質（等値比較ができる、子供を定義できる）を満たす 循環参照する複数のグループに属するノードを集めることで、一つのグループを構成できる 同一グループ内の任意の2ノードは循環参照している つまりグループ内のノード間では上下関係を決定できません 循環参照の関係にないグループA, Bがあり、かつAがBに依存しているとき、Bの全てのノードはAのどのノードから見ても（一方向の）子孫ノードである 平たく言えば、ノード間の親子（先祖/子孫）関係はグループ化しても保存されるということです

これらの性質を利用すると、下記のような手順で「循環参照を塊とみなしたソート」を実現できます

手順

ノードのリストから、各ノードを要素とするグループのリストを作成する グループのリストから（自己参照でない）循環参照を探す。なければ手順5へ飛ぶ 性質1により、ノード用の循環参照検知関数をそのまま利用できる] 手順2で見つけた循環参照グループからノードを取り出して一つのグループにまとめ（性質2による）、元のグループは破棄する この操作によりリストの要素が減るので、無限ループにならない 手順2へ戻る グループをノードとみなし（性質1による）、段階2：複数の親を許すがループは存在しない木の場合に従ってソートする 手順5でソートされた順にグループを取り出し、含まれるノードを取り出してリストとする。このリストのノードは正しくソートされている（性質4による） 同一グループ内のノードの順序は任意でよい（性質3による）

手順1～4の実装は次のようになります。

( defun calc-group-children ( group group-list ) ( remove-if ( lambda ( target ) ( not ( group-depend-p target group ))) group-list )) ( defun recalc-groups-children ( group-list ) ( dolist ( group group-list ) ( setf ( node-group-children group ) ( calc-group-children group group-list ))) group-list ) ( defun gather-ciruclar-node-group ( circular-list group-list ) ( let (( new-group ( make-node-group :nodes ( apply #'append ( mapcar ( lambda ( group ) ( node-group-nodes group )) circular-list ))))) ( recalc-groups-children ( cons new-group ( remove-if ( lambda ( group ) ( find group circular-list :test #'node-equalp )) group-list ))))) ( defun make-group-resolving-circular ( all-node-list ) ( labels (( rec ( group-list ) ( aif ( extract-circular-nodes group-list ) ( rec ( gather-ciruclar-node-group it group-list )) group-list ))) ( rec ( recalc-groups-children ( mapcar ( lambda ( node ) ( make-node-group :nodes ( list node ))) all-node-list )))))

後は手順5に従い、 make-group-resolving-circular の結果を sort-tree-node-with-duplication に渡すことでグループ間のソートは完了です*6。

( defun sort-tree-node-with-circular ( top-node-list ) ( sort-tree-node-with-duplication ( make-group-resolving-circular ( extract-all-nodes-by-dfs top-node-list ))))

なお、見た目としてはグループをまとめたままの方が分かり易いため、以降では手順6（グループ内ノードのフラット化）を省略して出力します。

上記の循環参照する木をソートした結果を見ると、グループDFGがまとまり、またそれらに依存するA, Cは後から出てくるなど正しくソートできています。

((B) (E) (H) (D F G) (C) (A))

また、複数の循環参照を含む木でうまく動くかを確認するため、2つほど例を見てみます。

2つの循環参照間に片方向の依存が存在する木

( defparameter *circular-tree2* '(( :a :b :f :c ) ( :f :h :g ) ( :g :d :x ) ( :d :f ) ( :c :d :e ) ( :x :y ) ( :y :z ) ( :z :x )))

2つの循環参照間に相互依存が存在する木

( defparameter *circular-tree3* '(( :a :b :f :c ) ( :f :h :g ) ( :g :d :x ) ( :d :f ) ( :c :d :e ) ( :x :y :g ) ( :y :z ) ( :z :x )))

なお、グループ自体もノードとしての性質を満たすため、グループを要素としたグループを（再帰的に）作成できるはずですが、特に実用的な価値はないと思われます。

コード全体

最後に、全コードを貼り付けます。

Sort nodes in tree according to their dependencies …

Roswellスクリプトとして実行でき、下記を出力します。

$ ./sort-tree-node-with-circular.ros -------------------- --- Sort simply --- -------------------- *SIMPLE-TREE*: ((A B C) (C D E) (D F G)) -> (E G F D C B A) *DUPLICATED-TREE*: ((A B F C) (C D E) (D F G) (F H I)) -> (E G D C I H F B A) -------------------- --- Sort considering duplicated parent --- -------------------- *SIMPLE-TREE*: ((A B C) (C D E) (D F G)) -> (B E G F D C A) *DUPLICATED-TREE*: ((A B F C) (C D E) (D F G) (F H I)) -> (B E G I H F D C A) *CIRCULAR-TREE1*: ((A B F C) (F H G) (G D) (D F) (C D E)) -> (B E H) -------------------- --- Sort checking circular --- -------------------- *DUPLICATED-TREE*: ((A B F C) (C D E) (D F G) (F H I)) -> (B E G I H F D C A) *CIRCULAR-TREE1*: ((A B F C) (F H G) (G D) (D F) (C D E)) ERROR: There is (a) circular dependency: (F G D) -------------------- --- Sort considering circular --- -------------------- *SIMPLE-TREE*: ((A B C) (C D E) (D F G)) -> ((F) (G) (D) (E) (C) (B) (A)) *DUPLICATED-TREE*: ((A B F C) (C D E) (D F G) (F H I)) -> ((H) (I) (F) (G) (D) (E) (C) (B) (A)) *CIRCULAR-TREE1*: ((A B F C) (F H G) (G D) (D F) (C D E)) -> ((E) (B) (H) (F G D) (C) (A)) *CIRCULAR-TREE2*: ((A B F C) (F H G) (G D X) (D F) (C D E) (X Y) (Y Z) (Z X)) -> ((E) (B) (H) (X Y Z) (F G D) (C) (A)) *CIRCULAR-TREE3*: ((A B F C) (F H G) (G D X) (D F) (C D E) (X Y D) (Y Z) (Z X)) -> ((E) (B) (H) (D F G X Y Z) (C) (A)) -------------------- --- (Test self dependncy) --- -------------------- *TREE-TO-TEST-SELF-DEPENDENCY*: ((A A B F C) (C C D E) (D F G) (F H I)) -> (B E G I H F D C A) *TREE-TO-TEST-SELF-DEPENDENCY*: ((A A B F C) (C C D E) (D F G) (F H I)) -> (B E G I H F D C A) *TREE-TO-TEST-SELF-DEPENDENCY*: ((A A B F C) (C C D E) (D F G) (F H I)) -> ((H) (I) (F) (G) (D) (E) (C) (B) (A))

以上