循環が始まる場所
SRFI には、circular-list? というプロシージャがありオブジェクトが循環リストかどうかを知ることができますがどこから循環が始まっているかまで知ることはできません。
ところが、circular-list? の SRFI-1 の参照実装を少し書き換えるだけこれを知ることができるようになります。SRFI-1 の参照実装を以下に引用します。
(define (circular-list? x) (let lp ((x x) (lag x)) (and (pair? x) (let ((x (cdr x))) (and (pair? x) (let ((x (cdr x)) (lag (cdr lag))) (or (eq? x lag) (lp x lag))))))))
このプロシージャでは、実際に循環参照されているペア*1を探すことによって、循環しているかどうかを調べています。見つかれば循環していて見つかる前に終端に到達すれば循環していないということです。まず、循環している場合に見つかるペアがどこにあるかを調べてみましょう。
ループ1回（lp の呼び出し1回）ごとに、lag は1つ後ろのペアをバインドし、x は2つ後ろのペア*2をバインドします*3。
従って lag がリストの先頭から $i$ 進んだ位置（cdr を $i$ 回適用した位置）にあるペアをバインドするとき、x は $2i$ 進んだ位置にあるペアをバインドすることになります。
この2つのペアが一致するとき、そのペアが「循環している場合に見つかるペア」です。
そして、この2つのペアが一致するとき $2i$ と $i$ の差、つまり $i$ は、循環する部分の長さ（下の図では7）の整数倍になります。
つまり、循環している場合に見つかるペアは、循環する部分の長さの整数倍だけ先頭から進んだ位置にあるわけです。
ということは、このペアが見つかったタイミングで先頭のペアをバインドする変数を新たに用意し、lag と同じペースで cdr への再バインドを繰り返すと、新たな変数がバインドするペアと lag がバインドするペアは、常に循環する部分の長さの倍数の分だけ離れていることになります。そして新たな変数が循環する部分に入ると lag と同一のペアをバインドし続けることになるわけです。
最初に同一のペアをバインドするのは、両者が循環する部分の先頭に達したときです。
従って、どこから循環が始まっているかを見つけるためには、(eq? x lag) が真になったときに先頭と lag からそれぞれ cdr を1つずつたどり同じペアに到達するまでループするような処理を追加すればよいわけです。
実際のコードは例えば次のようになります*4。最初の7行は変数名以外*5 circular-list? と同じです*6。
(define (cr-in-cycle x) (let lp ((lead x) (lag x)) (and (pair? lead) (let ((lead (cdr lead))) (and (pair? lead) (let ((lead (cdr lead)) (lag (cdr lag))) (if (eq? lead lag) (do ((invader x (cdr invader)) (orbiter lag (cdr orbiter))) ((eq? invader orbiter) invader)) (lp lead lag))))))))
cr-in-cycle に循環リスト以外のオブジェクトを渡すと circular-list? と同じように #f が返ってきます（Schemoid で実行）。
(cr-in-cycle 5) => #f (cr-in-cycle '(8 . 5)) => #f (cr-in-cycle '(8 5)) => #f (cr-in-cycle '()) => #f
循環リストを渡してみます。以下ではリストの20番目の次に16番目が来るように set-cdr! して循環リストを作っています。このとき、循環は16番目から始まります*7。循環リストの表示に対応していない*8、式の評価結果を表示する、set-cdr! の評価結果は代入された値である、という実行環境*9だと set-cdr! の結果が返ってこないような書き方をしなければなりません*10。
(define lis '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20))
(begin (set-cdr! (list-tail lis 20) (list-tail lis 16))
(display "whole list:") (newline)
(do ((i 0 (+ i 1)) (p lis (cdr p)))
((>= i 100))
(display (car p)) (display " "))
(display "...") (newline)
(newline)
(display "cyclic part:") (newline)
(do ((i 0 (+ i 1)) (p (cr-in-cycle lis) (cdr p)))
((>= i 100))
(display (car p)) (display " "))
(display "...") (newline))
↓
whole list: 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 ... cyclic part: 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 16 17 18 19 20 ... #t
cr-in-cycle はちゃんと16番目を返していますね。
*1:セルとかノードとか
*2:循環している場合は必ず後ろはペアですが、循環していない場合はいずれペアではなくなるか、2つ後ろにはオブジェクトがないという状態になります。そのときは2つある (pair? x) のどちらかが偽を返し、ループが終了します。
*3:バインドのタイミングがややこしいですが。
*4:上の説明どおりにするなら do ループの2つめの変数は orbiter ではなく lag とすべきですが、この段階での lag 呼ばわりは変だと思いました。orbiter も別の意味で変ですが。
*5:ループの内側から先頭のペアにアクセスするためにはループ変数と circular-list? の引数を違う名前にしなければなりません。
*6:プロシージャ名も circular-list? から cr-in-cycle に変えています。先頭のペアは cr でいいですよね。その次が cdr でその次が cddr でその次が cdddr で...。
*7:リストの適当なペアに対してそれより手前の n 番目のペアを set-cdr! すると、循環は n 番目から始まります。
*8:対応している処理系はちゃんとあります。というかR7RS が対応しているわけで（6.13.3）（わけでは R7RS の日本語訳です。その前は Gauche のリファレンスマニュアルです）。循環リストを作るときも set-cdr! しなくてもリテラルに書けるみたい。
*9:今使ってる JScheme REPL がそれなのですよ。
*10:begin を使うやり方のほかにも set-cdr! までをファイルに保存して load か use-module するとか、いろいろな方法があります。
