Max-Plus+離散モースによる断片ブレイド復元→再考④📒まとめ📒
重大な欠陥を見つけた。
地区A → 地区B → 地区A
って実際にある移動なんだけど、ライデマイスター移動でまっすぐの線になったら駄目なんだよ。
地区Bのポールに巻きつけてAに戻すみたいにしないと。
基本群？
いい欠陥の見つけ方だと思います。しかもこれ、実装のバグじゃなくてモデルの選択ミスなので、直し方がはっきりしています。
なぜ潰れたか
$${B_n}$$ が見ているのは紐同士の相対順序だけです。地面に釘で留まっているものが何もない。円板は可縮なので、一本の紐が右に行って左に戻る動きは、他の紐と交差しなければ $${σσ⁻¹ = e}$$ で必ず消えます。ライデマイスターII が正しく働いた結果であって、間違ってはいない。間違っているのは「$${B}$$に何もない」という前提のほう。
基本群、で合っています
ただし単なる $${π₁}$$ ではなく、穴あきの $${π₁}$$ です。
$${\pi_1(D \setminus {k{点}}) = F_k \quad ({自由群})}$$
穴を開けた瞬間、巻きつきは絶対に潰れなくなる。まさに「ポール」です。
ポール＝動かない紐
実装上は幾何を考えなくてよくて、仕事場ごとに、位置が定数の余分な紐を一本追加するだけです。割当対象にしない、動かさない、それだけ。
そしてこれには名前があります。穴一つの円環上のブレイド群は、B型のアルティン群と同型です。
τ σ₁ τ σ₁ = σ₁ τ σ₁ τ (ポールとの関係式、m=4)
σᵢ σⱼ σᵢ = σⱼ σᵢ σⱼ (紐同士、m=3、いつもの)前にヤン・バクスターとコクスター関係式の同型の話をされていましたが、その延長線上にそのまま乗ります。A型（穴なし）→ B型（穴あき）。ポールを一本立てると型が変わる。
選別規則になる
ここが一番おいしいところで、
通過 実施
┌───┐ ┌─────┐
───┘ └─── ① ───┘ ① └───
↑ ↓ ↑
● pole ● pole ← 一周する
↑ ↓
σ σ⁻¹ = e σ² ≠ e
絡み数 0 絡み数 1通過（空車回送） → $${σσ⁻¹}$$ → 簡約で消える。消えてよい。
作業（実車） → $${σ²}$$（フルツイスト）→ 絡み数1。何をしても消えない。
つまりブレイド語簡約を止める必要がない。走らせたまま、空車回送だけが勝手に蒸発して、実車だけが残る。手で「これは意味のある移動」と申告する必要がない ── ③で書かれていた「担当者に訊くのではなく余るかどうかで判定する」の、そのまま同じ形です。
出てくる数
各車両の一日を $${F_k}$$ の語 $${w}$$ として、
アーベル化 → $${ℤ^k}$$：ポール j との絡み数 ＝ その仕事を何回やったか。全車両の和が各 j でちょうど1、が実行可能性の必要条件。保存則として検算に使える。
交換子部分群のほう：順序の情報。マグナス展開の2次係数が「$${x_i}$$ の後に $${x_j}$$」の出現回数を数えるので、訪問順序が数として取り出せます。Max-Plus は時刻しか見ないので、この非可換部分は完全に取りこぼしていた領域です。
③の立方体複体との接続
前回、可換な組に2-セルを貼る話をしましたが、**ポールとは「そこに面を貼ってはいけない場所」**のことです。面を貼る＝二経路をホモトピックにする＝行って帰ったのを潰す。穴があると貼れない。
なので $${b₁}$$ の出所が具体的になります。あのとき「独立な"あちらでもこちらでもよい"の本数」と言っていたものの、少なくとも一部は、仕事場を回る本質的なループです。
一点だけ注意
いまのコードは $${area_{idx}/2}$$ で地区を1次元の直線に並べています。直線に穴を開けても巻けません（分断されるだけ）。巻きつきが意味を持つには2次元が要る。
ただ、ブレイド図を描いている時点ですでに暗黙に「円板×時間」にいるので、距離関数 $${dh}$$ は1次元のままでよくて、位相だけ円板として扱えば整合します。$${|i-j|}$$ は距離であって、位置ではない、と割り切る。
最小の変更
仕事ごとに pole(J, Pos) を立てる（不動）
作業実施時に $${σ_{pole}}$$ を2回発行（フルツイスト）、通過時は発行しない
簡約規則はそのまま。ポール紐だけ交換規則から除外
検算に linking(V, J) = 1 を追加
面白いのは、これ CHR的には制約を足しているのに、探索は増えないことです。ポールは動かないので分岐を生まない。ただ消えないだけ。
あとね。Tの枠っていうのか。
ポールに溝というか、出っ張りが付いてるイメージ。
納入時間枠の無いポールはツルツルで、巻いても移動できる 納入時間軸のあるポールは穴が空いててそこを通すので移動できない。
それ、コードにもう入ってます。nail(I, T) です。出っ張り＝釘。 名前が先に付いていて、絵が後から来た形になっている。
なぜツルツルだと滑るのか
ブレイド群は時間軸の単調な伸縮で不変だからです。$${B_n}$$ が見ているのは交差の「順序」だけで、「何時に交差したか」は最初から見ていない。だから巻きつきは上下に自由に動く。滑るのはバグではなく、$${B_n}$$ の定義そのものです。
そして ── その滑る幅がフロートです。
これが今回一番いい所だと思います。フロートはこれまで Max-Plus 側の数でしたが位相側の正体は「その交差を上下に動かせる区間の長さ」だった。
二層が分かれる理由
高さを忘れる写像を考えると、こうなります。
ファイバー = 時刻の自由度 = フロート多面体 ← ④層
↓
総空間 = 高さ付きブレイド（実際のダイヤ）
↓
底空間 = トレース（順序だけ） ← ①層底はブレイド語 ── というより、③でやった**トレース（可換で割った同値類）**です。ファイバーは、そのトレースの依存半順序の順序多面体。つまり prec/3 が張る多面体そのもの。
なので、
ブレイド語を一つ決める ＝ ファイバーを一枚選ぶ ＝ そこから先は Max/Min-Plus だけで閉じる
前に「フロート計算は二層だけで閉じる」と言われていた設計判断の、理由がここに出ます。①でトレースを決めた時点で一枚のファイバーの中に入っていて、ファイバーは順序多面体なので、伝播の代数だけで足りる。逆に言うと、閉じない場合があるとすれば、それは①を跨いだときだけ。
そして穴が、その跨ぎを作る
ツルツルのポールしかないと、どんな順序を選んでも時刻は必ず何とかなる。時間が順序に文句を言えない。①は④を一切気にしなくていい。
穴があいた瞬間、ファイバーが平面 $${t_j = c}$$ で切られて、切りすぎると空になる。空＝そのトレースは実行不能。時間の情報が順序の決定に逆流する唯一の経路が、穴あきポールです。
だから ──
問題の本当の結合度＝穴あきポールの本数
品目が何万件あっても、納入時間枠が付いているのが数十件なら、①と④の結合はその数十本のところだけ。残りは独立。これは実務的にも効くはずで「どこを慎重に組むべきか」の答えが構造から出てくる。
三段階ある
ポール 意味 フロート
ツルツル 時間指定なし 前後の紐だけで決まる（最大）
溝（幅あり） 納入時間枠 [a,b] 区間内で滑る（有界）
穴（点） 時間指定・アポイント ゼロ＝釘
いまのコードの nail/2 は三段目だけです。二段目（溝）を入れるなら asap/alap に上下から蓋をするだけなので、既存規則の組み合わせで足ります。
滑りを止めるのはポールだけではない
一点だけ。同じ紐の上の別の交差を追い越すことはできません。追い越したら語が変わる。つまり滑る範囲の上下限は、
ポールの穴（絶対的な蓋）
同じ紐の隣の交差（相対的な蓋）
の二種類。後者がそのまま prec/3 です。**ブレイド語が先行制約グラフを生成している。**①→④の受け渡しが具体的に何を渡しているのか、これで言えます。渡しているのは順序多面体の定義そのもの。
実装
ポールだけが両層に触ります。橋渡し契約が二本目になる感じで、
pole(J, Pos, free). % ツルツル
pole(J, Pos, slot(A, B)). % 溝
pole(J, Pos, notch(T)). % 穴
pole_nail @ pole(J,_,notch(T)) ==> nail(J, T).
pole_slot @ pole(J,_,slot(A,B)) ==> asap(J,A), alap(J,B).ブレイド側は何も変えなくていい。ポールは動かないので探索も増えない。増えるのはファイバーが空かどうかの検査だけです。
余談ですが、③のメビウス関数が数えていた「同時に走れる組の交代和」は、このファイバーの形の不変量です。$${b₁}$$ と言っていたものと、フロートの自由度が、同じ多面体の別の測り方になる。
すごいな通じてたのか！流石に意味論でモデルを作ると強いね！
通じたというより、先に名前が付いていたのが効いてます。
nail/2 は絵を見る前から書いてあった。あとから「出っ張り」と言われて、指す先がもうそこにあった。これ、モデルが正しかったことの一番強い証拠だと思います。要件定義から入っていたら「時間指定フラグ」みたいな名前になっていて、穴とは結びつかなかった。
そして今回、話が通ったのは**「溝と出っ張り」が実装の話ではなく物の話だった**からでもあります。何をすべきかではなく、そこに何があるか。意味論から入るというのは要するにこれで、先に物を置いておくと、あとで来た絵が勝手に嵌まる。逆順だと嵌まる場所がない。
ただ一つだけ釘を刺しておくと ── この方法は当たりすぎるのが怖いところです。豊かな数学を持ってくると、たいてい何かしら対応が付いてしまう。今回それが偶然でないと言えるのは、③でフラッグ条件が破れたからです。三台同時だと駐車場が足りない、が実際に検出された。当たるだけでなく外れる場所を指せた。あれがなければ、ただの良い喩え話で終わっていたかもしれない。
なので次の検算候補としては、こういうのが効きます:
絡み数の和が各 j でちょうど1にならないケースが実データに出るか（出たら伝票側の異常）
穴あきポールを一本外したときに、本当に①と④が切り離せるか
外れたときにちゃんと痛む所を先に決めておくと、当たったときの意味が変わります。
……にしても、18歳からのProlog使いが「制約を書いてから絵が来る」順序で仕事しているのは、まあ、そういうことなんだと思います。宣言的に書くというのは物を置くことなので。
ははは。一応、ポール巻き対応でCHR-Prolog書き直して。
rev.2 からの主な差分だけ:
§2–3 巻きと自由簡約 — 通過も実車も同じ wind/5 から文字を吐きます。回送は x(J,+1),x(J,-1)、実車は x(J,+1),x(J,+1)。あとは free_reduce を走らせるだけで、回送だけが勝手に蒸発する。判定規則を書いていないのがポイントです。
§4 保存則 — アーベル化して各ポールの絡み数を数え和が 2（フルツイスト＝1回の作業）でなければ lk_bad。手配漏れ・二重手配がここに落ちます。
§5 ポール表面 — 橋渡し契約の二本目。free / slot(A,B) / notch(T) の三段が、そのまま「何もしない / asap+alap / nail」に対応。coupled/1 を立てているのは①④の結合度を数えるためで、これが 0 本ならレポートに「二層は完全に独立」と出ます。
§8 面の制限 — indep/2 に encloses_pole/2 を追加。ポールを囲む矩形には面を貼らない。結果としてメビウス関数もクリーク分布も rev.2 より小さく出るはずで、その減った分が「潰せない往復」です。
一点だけ、braid_prec の先行制約生成は素朴に書いてあります。同一車両の連続作業しか見ていないので、ポール越しの相対制約は拾えていない。ここは実データを流してから詰めた方がいい気がします — いま凝ると、たぶん間違った形で凝る。
run. で全部走ります。データは maxconc(2) のまま残してあるので、フラッグ条件の破れも rev.2 同様に出るはずです。
元
%% -*- Mode: Prolog -*-
%% n2n_soroban.pl N対N配車「そろばん」の意味論 (rev.2 離散モース層を追加)
%% SWI-Prolog + library(chr)
%%
%% 板 = 時間展開ネットワーク (T x Area)
%% T = 離散モース関数 (最初から高さ軸になっている)
%% 断片 = 1-セル
%% 玉を繋ぐ = 勾配ベクトル場のペアリング
%% 新規投入 = 臨界セル
%% 可換な組 = 2-セル (貼る。潰さない)
%%
%% rev.1 との違い: 可換律を書き換え規則で消していたのをやめ、
%% 面として記録する。商を取るのではなく次元を上げて同一視する。
:- module(n2n, [run/0, solve/0, report/0]).
:- use_module(library(chr)).
:- dynamic job/5.
:- dynamic maxconc/1.
%% ===========================================================
%% 制約
%% ===========================================================
:- chr_constraint
%% --- そろばん (下段: 何台) ---
frag/5, % frag(Id, From, To, Ts, Te) 未処理の断片
bead/4, % bead(Veh, Area, T, LastFrag) 空き玉
assign/2,
fleet/1,
%% --- 熱帯 (上段: いつ) ---
prec/3, asap/2, alap/2, slack/2,
nail/2, infeasible/2,
%% --- 離散モース層 ---
cell/1, % cell(Id) 1-セル
vpair/2, % vpair(I, J) 勾配ベクトル場
critical/1, % critical(Id) 臨界セル
face/2, % face(I, J) 2-セル
cube/1, % cube([I,J,K]) 3-立方体
link_break/1. % link_break(S) フラッグ条件の破れ
%% ===========================================================
%% (1) そろばん本体 -- 玉の移動 = モース・マッチング
%% ===========================================================
%% 玉を取る = ハッセ図上でペアを組む。臨界セルは増えない。
take @ bead(V, A, T, P), frag(Id, From, To, Ts, Te)
<=> reach(A, T, From, Ts)
| assign(Id, V),
vpair(P, Id),
bead(V, To, Te, Id).
%% 組めない = 臨界セル。ここだけが台数を増やす。
put @ fleet(N), frag(Id, _From, To, _Ts, Te)
<=> N1 is N + 1,
assign(Id, N1),
critical(Id),
bead(N1, To, Te, Id),
fleet(N1).
reach(Area, Tavail, From, Tstart) :-
dh(Area, From, D),
Tavail + D =< Tstart.
%% 非輪状性は T の単調性からタダで手に入る。念のため検査だけ置く。
acyc @ vpair(I, J) ==> job(I,_,_,_,TeI), job(J,_,_,TsJ,_), TeI > TsJ
| infeasible(J, cyclic(I)).
%% ===========================================================
%% (2) 熱帯半環 (+) = max / (x) = +
%% ===========================================================
asap_join @ asap(I, T1) \ asap(I, T2) <=> T2 =< T1 | true.
asap_prop @ asap(I, T), prec(I, J, D) ==> T1 is T + D, asap(J, T1).
alap_join @ alap(I, T1) \ alap(I, T2) <=> T1 =< T2 | true.
alap_prop @ alap(J, T), prec(I, J, D) ==> T1 is T - D, alap(I, T1).
slack_of @ slack(I, _) \ slack(I, _) <=> true.
slack_new @ asap(I, Te), alap(I, Tl) ==> S is Tl - Te, slack(I, S).
%% ===========================================================
%% (3) 釘 (固定X) -- 伝播と検査の境目
%% ===========================================================
%% 下からの押しは積になる (伝播)。上からの蓋は積にならない (ガード)。
%% 釘は代数の外ではなく、この境目に居る。
nail_down @ nail(I, T) ==> asap(I, T).
nail_up @ nail(I, T) ==> alap(I, T).
nail_late @ nail(I, T), asap(I, T2) ==> T2 > T | infeasible(I, late(T2, T)).
nail_dup @ infeasible(I, R) \ infeasible(I, R) <=> true.
%% ===========================================================
%% (4) 立方体複体 -- 可換な組を面として貼る
%% ===========================================================
%% 独立性 (Mazurkiewicz): 資源 (エリア) を共有しなければ可換。
%% 時刻ではなく資源で決まる。これが遠隔交換律 |i-j| >= 2 の実体。
indep(I, J) :-
job(I, F1, T1, _, _),
job(J, F2, T2, _, _),
sort([F1,T1], S1), sort([F2,T2], S2),
intersection(S1, S2, []).
mkface @ cell(I), cell(J) ==> I @< J, indep(I, J) | face(I, J).
%% 対ごとに可換な三つ組 -> 3-立方体
mkcube @ face(I,J), face(J,K), face(I,K) ==> I @< J, J @< K | cube([I,J,K]).
cubedup @ cube(S) \ cube(S) <=> true.
%% Gromov のフラッグ条件。破れたら CAT(0) 性が失われ、
%% 「局所最適 = 大域最適」の保証が消える。
%% 破れの場所 = 三体的に効いている制約の在処。
flagchk @ cube(S) ==> \+ simultaneous_ok(S) | link_break(S).
lbdup @ link_break(S) \ link_break(S) <=> true.
simultaneous_ok(Set) :-
length(Set, N),
( maxconc(K) -> N =< K ; true ).
%% ===========================================================
%% (5) 下界 -- ディルワース (反鎖)
%% ===========================================================
conflict(I, J) :- \+ chainable(I, J), \+ chainable(J, I).
chainable(I, J) :-
job(I, _, ToI, _, TeI),
job(J, FromJ, _, TsJ, _),
dh(ToI, FromJ, D),
TeI + D =< TsJ.
lower_bound(LB, Witness) :-
findall(Ts-I, job(I,_,_,Ts,_), L0),
keysort(L0, L1), pairs_values(L1, Ids),
greedy_antichain(Ids, [], Witness),
length(Witness, LB).
greedy_antichain([], Acc, Acc).
greedy_antichain([I|Rest], Acc, Out) :-
( forall(member(J, Acc), conflict(I, J))
-> greedy_antichain(Rest, [I|Acc], Out)
; greedy_antichain(Rest, Acc, Out)
).
%% ===========================================================
%% (6) 相殺 (Forman) -- 臨界セル二つを唯一の勾配道で消す
%% ===========================================================
%% first-fit 貪欲が正しく走っていれば、候補は空になるのが正常。
%% 出たら実装のバグか、制約の見落とし。自己検証として使う。
tail_of(V, Area, T) :-
findall(Te-Id, (assigned(Id,V), job(Id,_,_,_,Te)), L),
max_member(T-Id, L), job(Id,_,Area,_,_).
head_of(V, Area, T) :-
findall(Ts-Id, (assigned(Id,V), job(Id,_,_,Ts,_)), L),
min_member(T-Id, L), job(Id,Area,_,_,_).
assigned(Id, V) :- find_chr_constraint(assign(Id, V)).
cancel_candidate(V1, V2) :-
tail_of(V1, A1, Te),
head_of(V2, A2, Ts), V1 \== V2,
dh(A1, A2, D), Te + D =< Ts,
findall(V, ( head_of(V, FA, TS), V \== V1,
dh(A1, FA, D2), Te + D2 =< TS ), [V2]).
%% ===========================================================
%% (7) メビウス関数 -- 独立性グラフのクリークの交代和
%% ===========================================================
%% mu = sum over C (-1)^|C|, C は互いに可換な断片の集合
%% 前に「計数半環 = 頑健性」と言っていた量の位相側の姿。
subclique([], []).
subclique([X|Xs], [X|C]) :- subclique(Xs, C), forall(member(Y,C), indep(X,Y)).
subclique([_|Xs], C) :- subclique(Xs, C).
mobius(Mu, Profile) :-
findall(I, job(I,_,_,_,_), Ids0), sort(Ids0, Ids),
findall(C, subclique(Ids, C), Cs),
foldl([C,In,Out]>>( length(C,N), S is (-1)**N, Out is In + S ), Cs, 0, Mu),
msort_profile(Cs, Profile).
msort_profile(Cs, Profile) :-
findall(N, (member(C,Cs), length(C,N)), Ns),
msort(Ns, Sorted), clumped(Sorted, Profile).
%% ===========================================================
%% データ
%% ===========================================================
area_idx(a,1). area_idx(b,2). area_idx(c,3). area_idx(d,4).
area_idx(e,5). area_idx(f,6). area_idx(g,7).
dh(A, B, D) :- area_idx(A,I), area_idx(B,J), D is abs(I-J).
jobs :-
retractall(job(_,_,_,_,_)),
assertz(job(j1, a, c, 7, 9)),
assertz(job(j2, c, e, 9, 11)),
assertz(job(j3, b, d, 7, 10)),
assertz(job(j4, a, b, 8, 10)),
assertz(job(j5, d, a, 11, 14)),
assertz(job(j6, e, c, 12, 14)),
assertz(job(j7, b, e, 11, 15)),
assertz(job(j8, f, g, 7, 10)), % j1, j3 と三つ組で独立
retractall(maxconc(_)),
assertz(maxconc(2)). % 同時稼働の上限 -> フラッグ条件を破る
%% ===========================================================
%% 駆動
%% ===========================================================
solve :-
fleet(0),
findall(I, job(I,_,_,_,_), Ids0), sort(Ids0, Ids),
forall(member(I, Ids), cell(I)), % 複体を組む
findall(Ts-Id, job(Id,_,_,Ts,_), L0),
keysort(L0, L1), pairs_values(L1, Order),
forall(member(Id, Order), % そろばんを走らせる
( job(Id,F,T,Ts,Te) -> frag(Id,F,T,Ts,Te) ; true )).
report :-
find_chr_constraint(fleet(UB)),
lower_bound(LB, W),
findall(I, find_chr_constraint(critical(I)), Cr),
findall(P, find_chr_constraint(vpair(_,_)), Vp),
findall(F, find_chr_constraint(face(_,_)), Fc),
findall(Q, find_chr_constraint(cube(Q)), Cu),
findall(B, find_chr_constraint(link_break(B)), Lb),
length(Cr,NCr), length(Vp,NVp), length(Fc,NFc), length(Cu,NCu),
mobius(Mu, Prof),
findall(V1-V2, cancel_candidate(V1,V2), Can),
format("~n== 台数 ==~n"),
format(" 上界 (玉の投入数) : ~w~n", [UB]),
format(" 下界 (反鎖) : ~w 証拠 ~w~n", [LB, W]),
( UB =:= LB -> format(" -> 一致。最適確定。~n")
; D is UB-LB, format(" -> 差 ~w。改善余地あり、または下界が緩い。~n",[D]) ),
format("~n== モース ==~n"),
format(" 臨界セル : ~w ~w~n", [NCr, Cr]),
format(" ペア : ~w~n", [NVp]),
format(" 検算 : 臨界 ~w = 台数 ~w~n", [NCr, UB]),
format("~n== 立方体複体 ==~n"),
format(" 2-セル : ~w~n", [NFc]),
format(" 3-立方体 : ~w ~w~n", [NCu, Cu]),
( Lb == [] -> format(" フラッグ条件 : OK (CAT(0) 期待可)~n")
; format(" フラッグ条件 : 破れ ~w~n", [Lb]),
format(" -> 局所最適 = 大域最適 の保証は無い~n") ),
format("~n== 不変量 ==~n"),
format(" メビウス mu : ~w~n", [Mu]),
format(" クリーク分布: ~w~n", [Prof]),
format("~n== 自己検証 ==~n"),
( Can == [] -> format(" 相殺候補なし (正常)~n")
; format(" 相殺候補 ~w <- 見落としの疑い~n", [Can]) ).
run :- jobs, solve, report.差分
%% -*- Mode: Prolog -*-
%% n2n_pole.pl N対N配車「そろばん」の意味論 (rev.3 ポール巻き対応)
%% SWI-Prolog + library(chr)
%%
%% ===========================================================
%% rev.2 からの変更点
%% ===========================================================
%%
%% rev.2 の欠陥: A -> B -> A の往復がライデマイスターII で
%% まっすぐな線に潰れてしまう。円板は可縮なので
%% 潰れて当然。間違っていたのは「B に何も無い」
%% という前提のほう。
%%
%% rev.3 の処置: 作業地点ごとに「ポール」= 動かない紐を立てる。
%% 円板に穴が開き、基本群が自由群 F_k になる。
%% 巻きつきは原理的に潰れなくなる。
%%
%% A型ブレイド群 B_n -> B型アルティン群 (穴あき)
%% sigma_i sigma_j sigma_i -> + tau sigma tau sigma = sigma tau sigma tau
%%
%% ポールの表面には三段階ある:
%%
%% free ツルツル 時間指定なし 巻いても上下に滑る = フロート最大
%% slot(A,B) 溝 納入時間枠 区間内で滑る = フロート有界
%% notch(T) 穴 アポイント 滑らない = フロート 0 (釘)
%%
%% 滑る幅 = フロート。ブレイド群は時間軸の単調な伸縮で不変なので、
%% ツルツルのポールは高さを一切拘束しない。これはバグではなく定義。
%%
%% 二層の分離もここから出る:
%%
%% ファイバー = 時刻の自由度 = 順序多面体 <- (4)層 Max/Min-Plus
%% |
%% 底空間 = トレース (順序だけ) <- (1)層 そろばん・ブレイド
%%
%% (1)でブレイド語を一つ決める = ファイバーを一枚選ぶ。
%% そこから先は伝播の代数だけで閉じる。
%% 閉じないのは、穴/溝がファイバーを切って空にしたときだけ。
%% => 問題の本当の結合度 = 穴あき・溝あきポールの本数。
:- module(n2n_pole, [run/0, solve/0, report/0]).
:- use_module(library(chr)).
:- use_module(library(lists)).
:- use_module(library(apply)).
:- dynamic job/5. % job(Id, From, To, Tstart, Tend)
:- dynamic site/2. % site(Id, Area) 作業地点 (= ポールを立てる場所)
:- dynamic maxconc/1.
%% ===========================================================
%% 制約
%% ===========================================================
:- chr_constraint
%% --- そろばん (下段: 何台) ---
frag/5, % frag(Id,From,To,Ts,Te) 未処理の断片
bead/4, % bead(Veh,Area,T,LastFrag) 空き玉
assign/2, % assign(Id, Veh)
fleet/1,
%% --- ポールとブレイド語 (中段: どう回ったか) ---
pole/3, % pole(Id, Area, Kind) 不動の紐。Kind=free|slot(A,B)|notch(T)
letters/2, % letters(Veh, [Gen|...]) 発行待ちの文字列
letter/2, % letter(Veh, Gen) 一文字
braid/2, % braid(Veh, Word) 自由簡約済みのブレイド語
lk/3, % lk(Veh, PoleId, N) 絡み数
lk_bad/2, % lk_bad(PoleId, N) 保存則の破れ
%% --- 熱帯 (上段: いつ) ---
prec/3, asap/2, alap/2, slack/2,
nail/2, infeasible/2,
empty_fiber/2, % empty_fiber(Id, Reason) ファイバーが空 = そのトレースは不能
coupled/1, % coupled(PoleId) (1)層と(4)層を結ぶ点
%% --- 離散モース層 ---
cell/1, vpair/2, critical/1,
face/2, cube/1, link_break/1.
%% ===========================================================
%% (0) 地区と距離
%% ===========================================================
%% 注意: area_idx は「距離を測るための座標」であって「位置」ではない。
%% 直線に穴を開けても巻けない。位相としては円板 x 時間に居ると割り切り、
%% dh は 1 次元のまま使う。ここは意図的な割り切り。
area_idx(a,1). area_idx(b,2). area_idx(c,3). area_idx(d,4).
area_idx(e,5). area_idx(f,6). area_idx(g,7).
dh(A, B, D) :- area_idx(A,I), area_idx(B,J), D is abs(I-J).
%% 移動 From->To が地区 X を「通過」するか (端点は含まない)
passes(From, To, X) :-
area_idx(From, I), area_idx(To, J), area_idx(X, K),
( I < J -> I < K, K < J ; J < K, K < I ).
%% ===========================================================
%% (1) そろばん本体 -- 玉の移動 = モース・マッチング
%% ===========================================================
%% rev.2 から変更なし。臨界セルの数 = 投入台数。
take @ bead(V, A, T, P), frag(Id, From, To, Ts, Te)
<=> reach(A, T, From, Ts)
| assign(Id, V),
vpair(P, Id),
wind(V, A, Id, From, To), % <- ここでブレイド語を発行
bead(V, To, Te, Id).
put @ fleet(N), frag(Id, From, To, _Ts, Te)
<=> N1 is N + 1,
assign(Id, N1),
critical(Id),
braid(N1, []),
wind(N1, From, Id, From, To),
bead(N1, To, Te, Id),
fleet(N1).
reach(Area, Tavail, From, Tstart) :-
dh(Area, From, D),
Tavail + D =< Tstart.
acyc @ vpair(I, J) ==> job(I,_,_,_,TeI), job(J,_,_,TsJ,_), TeI > TsJ
| infeasible(J, cyclic(I)).
%% ===========================================================
%% (2) ポールに巻く
%% ===========================================================
%%
%% 通過 (空車回送) -> x(J,+1), x(J,-1) ... 自由簡約で消える
%% 作業 (実車) -> x(J,+1), x(J,+1) ... フルツイスト。絶対に消えない
%%
%% 同じ発行機構で、簡約が勝手に選り分ける。
%% 「これは意味のある移動です」と人が申告する必要がない。
%% 余るかどうかで判定する、というモース層の方針と同じ形。
%% wind/5 : 車両 V が Cur から出て断片 Id (From->To) をこなす。
%% 途中で他のポールを通過し、Id のポールにはフルツイストで巻く。
wind(V, Cur, Id, From, To) :-
passed_poles(Cur, From, P1), % 回送区間で通過するポール
passed_poles(From, To, P2), % 実車区間で通過するポール
append(P1, P2, Through),
maplist([J, [x(J,1), x(J,-1)]]>>true, Through, Loops),
append(Loops, PassLetters),
append(PassLetters, [x(Id,1), x(Id,1)], Ws), % 最後にフルツイスト
letters(V, Ws).
passed_poles(From, To, Ids) :-
findall(J, ( site(J, X), passes(From, To, X) ), Ids0),
sort(Ids0, Ids).
peel_nil @ letters(_, []) <=> true.
peel @ letters(V, [G|Gs]) <=> letter(V, G), letters(V, Gs).
%% ===========================================================
%% (3) 自由簡約 -- F_k の語として潰す
%% ===========================================================
%% ポール紐は動かないので、交換規則から除外されている。
%% よって潰せるのは隣接する逆元対だけ = 自由群の簡約そのもの。
emit @ braid(V, W), letter(V, G) <=>
append(W, [G], W1), free_reduce(W1, W2), braid(V, W2).
free_reduce(W, R) :-
foldl(push, W, [], Rev),
reverse(Rev, R).
push(G, [H|T], T) :- inv(G, H), !.
push(G, S, [G|S]).
inv(x(J,S), x(J,S2)) :- S2 is -S.
inv(s(I,S), s(I,S2)) :- S2 is -S.
%% ===========================================================
%% (4) 絡み数と保存則
%% ===========================================================
%% アーベル化 F_k -> Z^k。ポール J との絡み数 = その作業を何回やったか。
%% 全車両の和が各 J でちょうど 1、が実行可能性の必要条件。
%% 破れたら伝票側の異常 (二重手配 / 手配漏れ)。
linking(Word, J, N) :-
findall(S, member(x(J,S), Word), Ss),
sum_list(Ss, N).
lk_all @ braid(V, W) ==> ground(W) |
forall_poles_lk(V, W).
forall_poles_lk(V, W) :-
findall(J, site(J,_), Js0), sort(Js0, Js),
forall(member(J, Js),
( linking(W, J, N),
( N =:= 0 -> true ; lk(V, J, N) ) )).
lk_dup @ lk(V,J,N) \ lk(V,J,N) <=> true.
conservation(J, Total) :-
findall(N, find_chr_constraint(lk(_, J, N)), Ns),
sum_list(Ns, Half),
Total is Half // 2. % フルツイスト = 2 巻きで 1 回の作業
check_conservation :-
findall(J, site(J,_), Js0), sort(Js0, Js),
forall(member(J, Js),
( conservation(J, T),
( T =:= 1 -> true ; lk_bad(J, T) ) )).
%% ===========================================================
%% (5) ポール表面 -- 溝と穴 (橋渡し契約 二本目)
%% ===========================================================
%% 一本目: assigned(ItemID, RowID, QueuePos) -> strand(RowID, ItemID, QueuePos)
%% 二本目: pole(Id, _, Kind) -> asap/alap/nail
%%
%% ポールだけが両層に触る。ここが (1) と (4) の唯一の接続点。
pole_free @ pole(_J, _, free) ==> true.
pole_slot @ pole(J, _, slot(A,B)) ==> asap(J,A), alap(J,B), coupled(J).
pole_notc @ pole(J, _, notch(T)) ==> nail(J,T), coupled(J).
cpl_dup @ coupled(J) \ coupled(J) <=> true.
%% ===========================================================
%% (6) 熱帯半環 (+) = max / (x) = +
%% ===========================================================
%% ファイバー (順序多面体) の中を伝播する。
%% prec/3 はブレイド語が生成する。同じ紐の隣の交差を追い越せない、
%% という位相的事実が、そのまま先行制約になっている。
asap_join @ asap(I, T1) \ asap(I, T2) <=> T2 =< T1 | true.
asap_prop @ asap(I, T), prec(I, J, D) ==> T1 is T + D, asap(J, T1).
alap_join @ alap(I, T1) \ alap(I, T2) <=> T1 =< T2 | true.
alap_prop @ alap(J, T), prec(I, J, D) ==> T1 is T - D, alap(I, T1).
slack_of @ slack(I, _) \ slack(I, _) <=> true.
slack_new @ asap(I, Te), alap(I, Tl) ==> S is Tl - Te, slack(I, S).
%% ===========================================================
%% (7) 釘 -- 伝播と検査の境目
%% ===========================================================
%% 下からの押しは積になる (伝播)。上からの蓋は積にならない (ガード)。
nail_down @ nail(I, T) ==> asap(I, T).
nail_up @ nail(I, T) ==> alap(I, T).
nail_late @ nail(I, T), asap(I, T2) ==> T2 > T | infeasible(I, late(T2, T)).
nail_dup @ infeasible(I, R) \ infeasible(I, R) <=> true.
%% ファイバーが空 = 選んだトレースが時間の側から拒否された。
%% ツルツルのポールしか無ければ、これは決して起きない。
%% 起きるのは穴/溝が平面で切ったときだけ。
fiber_empty @ slack(I, S) ==> S < 0 | empty_fiber(I, over(S)).
fib_dup @ empty_fiber(I,R) \ empty_fiber(I,R) <=> true.
%% ブレイド語から先行制約を作る。
%% 同じ車両の連続する作業は追い越せない。
braid_prec @ assign(I, V), assign(J, V) ==>
job(I,_,ToI,_,_), job(J,FromJ,_,_,_),
job(I,_,_,_,TeI), job(J,_,_,TsJ,_), TeI =< TsJ,
dh(ToI, FromJ, D0), Dur is TsJ - TeI, D0 =< Dur
| job(I,_,_,TsI,TeI2), Len is TeI2 - TsI, D is Len + D0,
prec(I, J, D).
%% ===========================================================
%% (8) 立方体複体 -- ただしポールを囲む面は貼れない
%% ===========================================================
%% 面を貼る = 二経路をホモトピックにする = 行って帰ったのを潰す。
%% 穴があると貼れない。ポールとは「そこに面を貼ってはいけない場所」。
%% b_1 の出所の一部が、これで具体的になる。
indep(I, J) :-
job(I, F1, T1, _, _),
job(J, F2, T2, _, _),
sort([F1,T1], S1), sort([F2,T2], S2),
intersection(S1, S2, []),
\+ encloses_pole(I, J).
%% I と J が張る矩形の内部にポールが居たら、その面は貼れない。
encloses_pole(I, J) :-
job(I, F1, T1, _, _), job(J, F2, T2, _, _),
maplist(area_idx, [F1,T1,F2,T2], Is),
min_list(Is, Lo), max_list(Is, Hi),
site(K, X), K \== I, K \== J,
area_idx(X, P), Lo < P, P < Hi, !.
mkface @ cell(I), cell(J) ==> I @< J, indep(I, J) | face(I, J).
mkcube @ face(I,J), face(J,K), face(I,K) ==> I @< J, J @< K | cube([I,J,K]).
cubedup @ cube(S) \ cube(S) <=> true.
flagchk @ cube(S) ==> \+ simultaneous_ok(S) | link_break(S).
lbdup @ link_break(S) \ link_break(S) <=> true.
simultaneous_ok(Set) :-
length(Set, N),
( maxconc(K) -> N =< K ; true ).
%% ===========================================================
%% (9) 下界 -- ディルワース (反鎖)
%% ===========================================================
conflict(I, J) :- \+ chainable(I, J), \+ chainable(J, I).
chainable(I, J) :-
job(I, _, ToI, _, TeI),
job(J, FromJ, _, TsJ, _),
dh(ToI, FromJ, D),
TeI + D =< TsJ.
lower_bound(LB, Witness) :-
findall(Ts-I, job(I,_,_,Ts,_), L0),
keysort(L0, L1), pairs_values(L1, Ids),
greedy_antichain(Ids, [], Witness),
length(Witness, LB).
greedy_antichain([], Acc, Acc).
greedy_antichain([I|Rest], Acc, Out) :-
( forall(member(J, Acc), conflict(I, J))
-> greedy_antichain(Rest, [I|Acc], Out)
; greedy_antichain(Rest, Acc, Out)
).
%% ===========================================================
%% (10) メビウス関数
%% ===========================================================
%% 互いに可換な断片の集合の交代和。ポールで indep が減った分、
%% 以前より小さいクリークしか立たない。b_1 と表裏。
subclique([], []).
subclique([X|Xs], [X|C]) :- subclique(Xs, C), forall(member(Y,C), indep(X,Y)).
subclique([_|Xs], C) :- subclique(Xs, C).
mobius(Mu, Profile) :-
findall(I, job(I,_,_,_,_), Ids0), sort(Ids0, Ids),
findall(C, subclique(Ids, C), Cs),
foldl([C,In,Out]>>( length(C,N), S is (-1)**N, Out is In + S ), Cs, 0, Mu),
findall(N, (member(C,Cs), length(C,N)), Ns),
msort(Ns, Sorted), clumped(Sorted, Profile).
%% ===========================================================
%% データ
%% ===========================================================
jobs :-
retractall(job(_,_,_,_,_)),
retractall(site(_,_)),
%% Id From To Ts Te
assertz(job(j1, a, c, 7, 9)),
assertz(job(j2, c, e, 9, 11)),
assertz(job(j3, b, d, 7, 10)),
assertz(job(j4, a, b, 8, 10)),
assertz(job(j5, d, a, 11, 14)),
assertz(job(j6, e, c, 12, 14)),
assertz(job(j7, b, e, 11, 15)),
assertz(job(j8, f, g, 7, 10)),
%% ポールは納入先に立つ
assertz(site(j1, c)), assertz(site(j2, e)), assertz(site(j3, d)),
assertz(site(j4, b)), assertz(site(j5, a)), assertz(site(j6, c)),
assertz(site(j7, e)), assertz(site(j8, g)),
retractall(maxconc(_)),
assertz(maxconc(2)).
%% ポール表面の指定。ここが (1) と (4) の結合度を決める。
%% 大半は free。free だけなら時間は順序に文句を言えず、二層は完全に独立。
poles :-
pole(j1, c, free),
pole(j2, e, slot(9, 12)), % 溝: 納入時間枠
pole(j3, d, free),
pole(j4, b, free),
pole(j5, a, notch(11)), % 穴: アポイント。滑らない
pole(j6, c, free),
pole(j7, e, free),
pole(j8, g, free).
%% ===========================================================
%% 駆動
%% ===========================================================
solve :-
fleet(0),
poles,
findall(I, job(I,_,_,_,_), Ids0), sort(Ids0, Ids),
forall(member(I, Ids), cell(I)),
findall(Ts-Id, job(Id,_,_,Ts,_), L0),
keysort(L0, L1), pairs_values(L1, Order),
forall(member(Id, Order),
( job(Id,F,T,Ts,Te) -> frag(Id,F,T,Ts,Te) ; true )),
check_conservation.
report :-
find_chr_constraint(fleet(UB)),
lower_bound(LB, W),
findall(I, find_chr_constraint(critical(I)), Cr),
findall(P, find_chr_constraint(vpair(_,_)), Vp),
findall(F, find_chr_constraint(face(_,_)), Fc),
findall(Q, find_chr_constraint(cube(Q)), Cu),
findall(B, find_chr_constraint(link_break(B)), Lb),
findall(V-Wd, find_chr_constraint(braid(V,Wd)), Br),
findall(J, find_chr_constraint(coupled(J)), Cp),
findall(J2-N2, find_chr_constraint(lk_bad(J2,N2)), Bad),
findall(I3-R3, find_chr_constraint(empty_fiber(I3,R3)), Ef),
findall(I4-S4, find_chr_constraint(slack(I4,S4)), Sl),
length(Cr,NCr), length(Vp,NVp), length(Fc,NFc),
length(Cu,NCu), length(Cp,NCp),
mobius(Mu, Prof),
format("~n== 台数 ==~n"),
format(" 上界 (玉の投入数) : ~w~n", [UB]),
format(" 下界 (反鎖) : ~w 証拠 ~w~n", [LB, W]),
( UB =:= LB -> format(" -> 一致。最適確定。~n")
; D is UB-LB, format(" -> 差 ~w。改善余地あり、または下界が緩い。~n",[D]) ),
format("~n== モース ==~n"),
format(" 臨界セル : ~w ~w~n", [NCr, Cr]),
format(" ペア : ~w~n", [NVp]),
format(" 検算 : 臨界 ~w = 台数 ~w~n", [NCr, UB]),
format("~n== ブレイド語 (自由簡約後) ==~n"),
forall(member(V-Wd, Br),
( length(Wd, LenW),
format(" 車両 ~w : 長さ ~w~n ~w~n", [V, LenW, Wd]) )),
format(" ※ x(J,+1) が対で残る = 実車。回送は簡約で蒸発済み。~n"),
format("~n== 絡み数 保存則 ==~n"),
( Bad == [] -> format(" 全ポールで作業回数 1。OK~n")
; format(" 破れ ~w <- 伝票側の異常 (二重手配/手配漏れ)~n", [Bad]) ),
format("~n== 二層の結合度 ==~n"),
format(" 穴/溝あきポール : ~w 本 ~w~n", [NCp, Cp]),
( NCp =:= 0
-> format(" -> 完全に独立。(1) は (4) を一切気にしなくてよい。~n")
; format(" -> ここだけが (1)->(4) の逆流経路。慎重に組むべき箇所。~n") ),
format("~n== フロート (ファイバーの厚み) ==~n"),
forall(member(I4-S4, Sl), format(" ~w : ~w~n", [I4, S4])),
( Ef == [] -> format(" ファイバー非空。このトレースは実行可能。~n")
; format(" 空ファイバー ~w <- このトレースは時間側から拒否~n", [Ef]) ),
format("~n== 立方体複体 ==~n"),
format(" 2-セル : ~w (ポールを囲む面は貼っていない)~n", [NFc]),
format(" 3-立方体 : ~w ~w~n", [NCu, Cu]),
( Lb == [] -> format(" フラッグ条件 : OK (CAT(0) 期待可)~n")
; format(" フラッグ条件 : 破れ ~w~n", [Lb]),
format(" -> 局所最適 = 大域最適 の保証は無い~n") ),
format("~n== 不変量 ==~n"),
format(" メビウス mu : ~w~n", [Mu]),
format(" クリーク分布: ~w~n", [Prof]).
run :- jobs, solve, report.これに離散基底を入れるのはあんまり筋が良さそうじゃないね。
同意です。しかも「今回は合わない」ではなく「方向が逆」なので、はっきりしています。
結晶基底は $${q→0}$$ の極限ですよね。$${q}$$ を落とすというのは $${R}$$ 行列を組合せ論に潰すことで、潰れた先がプラクティック・モノイド ── つまり商です。rev.3 でやったのは商を取るのをやめて次元を上げる、だった。せっかく穴を開けて潰れないようにした直後に、潰す操作を持ってくることになる。ポール巻きは $${q}$$ を保つ側の話なので、噛み合わない。
もう一つ現実的な理由として、いま居るのは $${B}$$ 型です。$${A}$$ 型の綺麗なヤング盤の組合せ論は、$${B}$$ 型に持っていくと $${KN}$$ 盤だの折り畳みだので急に汚くなる。労力に対して出てくる数が少ない。
ただし居場所はある
結晶基底・RSK が効くのは前工程のほうで、そこには既に入っています。tropical_braid_bridge.pl の Schensted bumping と玉突きです。車格に品目を積む、あそこは可換で構わない世界なので、挿入アルゴリズムがそのまま働く。
なので「入れない」ではなく「上流に留める」が正しい判断だと思います。前工程で盤を作る → 橋渡し契約で紐に変える → そこから先はポールとブレイド。境界を跨がせない。跨がせようとすると下流で商を取る羽目になる。
代わりに自然なのは
F_k の上で素直に働く道具のほうです。
Fox 微分（自由微分）とマグナス展開。
前に「マグナス展開の2次係数が訪問順序を数える」と書きましたが、あれを本気でやるなら Fox 導関数です。自由群に対して定義されているので、穴あきの構造をそのまま食う。商も極限も取らない。1次が絡み数（＝いまの保存則）、2次が順序、という段階が自然に出ます。
しかも Prolog と相性がいい ── 語に対する再帰的な書き換えなので、CHR で書けます。結晶作用素を実装するより、たぶん一桁短い。
まあ、これも「当たりすぎ」を警戒すべき所ではありますが。2次係数が実務で意味のある数になるかは、実データを通すまで分からない。
