【abc456E】
休日を選び続ける巡回ができるか？
（有向グラフの閉路判定）

1. 問題

• E – Endless Holidays

$N$ 個の都市と $M$ 本の無向道路があり、各都市 $i$ には長さ $W$ の文字列 $S_i$ で休日の曜日が与えられます。
高橋君は曜日 $1$ の昼に任意の都市から始め、毎晩「同じ都市に留まる」か「隣接都市へ移動」できます。
各日の昼にいる都市が、その曜日で休日になるように、無限に移動を続けられるか判定します。
$T$ 個のテストケースそれぞれについて、可能なら `Yes`、不可能なら `No` を出力します。

2. コード（WA11）

2.1. 都市間グラフと休日表

まずは、問題の入力から make-edges で都市間のグラフを生成します。

;; (make-edges 4 '(1 2 1 4 2 4 2 3))
;;=> #(NIL (4 2) (3 4 1) (2) (2 1))
(defun make-edges (N lst)
  (let* ((ary (make-array (1+ N) :element-type 'list
                            :initial-element nil)))
    (loop for (u v) on lst by #'cddr 
          while v
          do
             (push v (aref ary u))
             (push u (aref ary v)))
    ary))

;; (edges->nodes *e* 2) ;=> (3 4 1)
(defun edges->nodes (edges n)
  (aref edges n))Code language: Lisp (lisp)

また、 make-holidays でグラフを休日の表を生成します。

;; (make-holidays 4 3 '("xxo" "xox" "oxo" "oxx")) ;=>
;; #2A((NIL NIL NIL NIL)
;;     (NIL NIL NIL T)
;;     (NIL NIL T NIL)
;;     (NIL T NIL T)
;;     (NIL T NIL NIL))
(defun make-holidays (N W lines)
  (let* ((ary2d (make-array (list (1+ N) (1+ W))
                            :element-type 'boolean
                            :initial-element nil)))
    (loop for city from 1 to N
          for line in lines
          do (loop for day from 1 to W
                   for ch across line
                   do (setf (aref ary2d city day)
                            (eql ch #\o))))
    ary2d))Code language: Lisp (lisp)

2.2. 次に行ける都市の候補（next-holiday-cities）

この都市間グラフと休日表を使うと、今の都市と次の日付で、次に行くことができる都市を求められるようになります。

(defun cycle (x cycle)
  (1+ (mod (1- x) cycle)))

;; (next-holiday-cities 3 2 3 *e* *h*) ;=> (3 1)
;; (next-holiday-cities 3 2 4 *e* *h*) ;=> (3 4)
;; (next-holiday-cities 3 1 2 *e* *h*) ;=> (2)
(defun next-holiday-cities (W current-city next-day edges holidays)
  (loop for city in (cons current-city
                          (edges->nodes edges current-city))
        when (aref holidays city (cycle next-day W))
          collect city))Code language: Lisp (lisp)

2.3. 移動可能な都市候補を順に進めていく

まず休日表から初日に休日になっている都市群からスタートして、次に移動可能な都市を順に進めていきます。
そうして、１週間後進むことができるかを判定します。

;; (holiday-cities 4 3 1 *h*) ;=>  (3 4)
(defun holiday-cities (N W day holidays)
  (loop for city from 1 to N
        when (aref holidays city (cycle day W))
          collect city))

;; (next-cities 3 '(1 2 3 4) 2 *e* *h*) ;=> (2)
;; (next-cities 3 '(2) 3 *e* *h*)       ;=> (3 1)
;; (next-cities 3 '(3 1) 4 *e* *h*)     ;=> (4)
;; (next-cities 3 nil 4 *e* *h*)        ;=> NIL
(defun next-cities (W cities next-day edges holidays)
  (loop for city in cities
        append (next-holiday-cities
                W city next-day edges holidays) into result
        finally (return (remove-duplicates result))))

;; (endless-holiday-p 4 3 *e* *h*) ;=> T
(defun endless-holiday-p (N W edges holidays)
  (loop for day from 2 to (1+ W)
        with current-cities = (holiday-cities N W 1 holidays)
        while current-cities
        do (setf current-cities
                 (next-cities
                  W current-cities day edges holidays))
        finally (return (consp current-cities))))Code language: Lisp (lisp)

2.4. 全コード

ただし、この方法ではAC 15, WA 11 で、まだ間違いがあります。

;; (make-edges 4 '(1 2 1 4 2 4 2 3))
;;=> #(NIL (4 2) (3 4 1) (2) (2 1))
(defun make-edges (N lst)
  (let* ((ary (make-array (1+ N) :element-type 'list
                            :initial-element nil)))
    (loop for (u v) on lst by #'cddr 
          while v
          do
             (push v (aref ary u))
             (push u (aref ary v)))
    ary))

;; (edges->nodes *e* 2) ;=> (3 4 1)
(defun edges->nodes (edges n)
  (aref edges n))

;; (make-holidays 4 3 '("xxo" "xox" "oxo" "oxx")) ;=>
;; #2A((NIL NIL NIL NIL)
;;     (NIL NIL NIL T)
;;     (NIL NIL T NIL)
;;     (NIL T NIL T)
;;     (NIL T NIL NIL))
(defun make-holidays (N W lines)
  (let* ((ary2d (make-array (list (1+ N) (1+ W))
                            :element-type 'boolean
                            :initial-element nil)))
    (loop for city from 1 to N
          for line in lines
          do (loop for day from 1 to W
                   for ch across line
                   do (setf (aref ary2d city day)
                            (eql ch #\o))))
    ary2d))


;; (defparameter *e* (make-edges 4 '(1 2 1 4 2 4 2 3)))
;; (defparameter *h*
;;   (make-holidays 4 3 '("xxo" "xox" "oxo" "oxx")))

(defun cycle (x cycle)
  (1+ (mod (1- x) cycle)))

;; (next-holiday-cities 3 2 3 *e* *h*) ;=> (3 1)
;; (next-holiday-cities 3 2 4 *e* *h*) ;=> (3 4)
;; (next-holiday-cities 3 1 2 *e* *h*) ;=> (2)
(defun next-holiday-cities (W current-city next-day edges holidays)
  (loop for city in (cons current-city
                          (edges->nodes edges current-city))
        when (aref holidays city (cycle next-day W))
          collect city))



;; (holiday-cities 4 3 1 *h*) ;=>  (3 4)
(defun holiday-cities (N W day holidays)
  (loop for city from 1 to N
        when (aref holidays city (cycle day W))
          collect city))

;; (next-cities 3 '(1 2 3 4) 2 *e* *h*) ;=> (2)
;; (next-cities 3 '(2) 3 *e* *h*)       ;=> (3 1)
;; (next-cities 3 '(3 1) 4 *e* *h*)     ;=> (4)
;; (next-cities 3 nil 4 *e* *h*)        ;=> NIL
(defun next-cities (W cities next-day edges holidays)
  (loop for city in cities
        append (next-holiday-cities
                W city next-day edges holidays) into result
        finally (return (remove-duplicates result))))

;; (endless-holiday-p 4 3 *e* *h*) ;=> T
(defun endless-holiday-p (N W edges holidays)
  (loop for day from 2 to (1+ W)
        with current-cities = (holiday-cities N W 1 holidays)
        while current-cities
        do (setf current-cities
                 (next-cities
                  W current-cities day edges holidays))
        finally (return (consp current-cities))))

(defun print-yesno (c)
  (declare (type boolean c))
  (princ (if c "Yes" "No")))

(defun main ()
  (let* ((times (read)))
    (loop repeat times
          for N = (read)
          for M = (read)
          for edge-list = (loop repeat (* M 2)
                                collect (read))
          for W = (read)
          for lines = (loop repeat N
                            collect (read-line))
          for edges = (make-edges N edge-list)
          for holidays = (make-holidays N W lines)
          do (print-yesno (endless-holiday-p
                           N W edges holidays))
             (terpri))))

#-swank(main)Code language: Lisp (lisp)

3. 開始時の都市に戻れないときがある？（TLE14）

間違いの原因を考えます。
すると、一巡したときに開始時の都市に戻れないと、最終的にどん詰まりになることがあることに気づきました。

そこで、最初の都市と一巡したときの都市が同じであるかどうかを判定することにしました。

(defun endless-holiday-p (N W edges holidays)
  (labels ((rec (start-cities)
             (loop for day from 2 to (1+ W)
                   with current-cities = start-cities
                   while current-cities
                   do (setf current-cities
                            (next-cities
                             W current-cities day edges holidays))
                   finally (return
                             (cond ((null current-cities) nil)
                                   ((equal start-cities current-cities) t)
                                   (t (rec current-cities)))))))
    (rec (holiday-cities N W 1 holidays))))Code language: JavaScript (javascript)

ただし、どうも振動してループしてしまうことがあるようです。
１週間ごとに、A->B->Aなど進めば、必ずしも同じ都市に戻らなくてもループできるからです。

3.1. ループをチェックした（TLE1）

そこで、スタート地点ごとに1週間後に移動可能な都市を求めて、それグラフにすることにしました。
そして、この週グラフ上にループ構造があれば、いつまでも休日を続けていけます。

;; (next-week-cities 4 3 *e* *h* 1) ;=> (3 4)
(defun next-week-cities (N W edges holidays city)
  (declare (ignore N))
  (loop for day from 2 to (1+ W)
        with current-cities = (list city)
        while current-cities
        do (setf current-cities
                 (next-cities
                  W current-cities day edges holidays))
        finally (return current-cities)))

;; (week-edges 4 3 *e* *h*) ;=> #(NIL NIL NIL (4 3) (4 3))
(defun week-edges (N W edges holidays)
  (let* ((start-cities (holiday-cities N W 1 holidays))
         (ary (make-array (1+ N) :element-type 'list
                                 :initial-element nil)))
    (loop for ca in start-cities
          do (loop for cb in (next-week-cities N W edges holidays ca)
                   do (push cb (aref ary ca)))
          finally (return ary))))
Code language: Lisp (lisp)

グラフにループ構造があるかは、DFSで途中の場所 :now を見つけたら判定できます。

;; (has-cycle-p 4 #(NIL NIL NIL (4 3) (4 3))) ;=> T
;; (has-cycle-p 4 #(NIL NIL NIL (4) (1))) ;=> NIL
(defun has-cycle-p (N edges)
  (let* ((state (make-array (1+ N) :initial-element :before)))
    (labels ((visit (v)
               (case (aref state v)
                 (:now t)
                 (:done nil)
                 (t (setf (aref state v) :now)
                  (let ((found-cycle (some #'visit (aref edges v))))
                    (setf (aref state v) :done)
                    found-cycle)))))
      (loop for i from 1 to N
            thereis (visit i)))))
Code language: PHP (php)

ループが見つからなかったノードは、:done にして再計算から除外します。

ここまですれば、判定そのものはシンプルです。

(defun endless-holiday-p/graph (N W edges holidays)
  (has-cycle-p N (week-edges N W edges holidays)))

結果は、TLE 1。
惜しいです。

一つだけ、異様にメモリを消費して、時間もオーバーしているので、何か見落としがあって処理がループしているかも。

;; (defparameter *e* (make-edges 4 '(1 2 1 4 2 4 2 3)))
;; (defparameter *h* (make-holidays 4 3 '("xxo" "xox" "oxo" "oxx")))

;; (make-edges 4 '(1 2 1 4 2 4 2 3))
;;=> #(NIL (4 2) (3 4 1) (2) (2 1))
(defun make-edges (N lst)
  (let* ((ary (make-array (1+ N) :element-type 'list
                            :initial-element nil)))
    (loop for (u v) on lst by #'cddr 
          while v
          do
             (push v (aref ary u))
             (push u (aref ary v)))
    ary))

;; (edges->nodes *e* 2) ;=> (3 4 1)
(defun edges->nodes (edges n)
  (aref edges n))

;; (make-holidays 4 3 '("xxo" "xox" "oxo" "oxx")) ;=>
;; #2A((NIL NIL NIL NIL)
;;     (NIL NIL NIL T)
;;     (NIL NIL T NIL)
;;     (NIL T NIL T)
;;     (NIL T NIL NIL))
(defun make-holidays (N W lines)
  (let* ((ary2d (make-array (list (1+ N) (1+ W))
                            :element-type 'boolean
                            :initial-element nil)))
    (loop for city from 1 to N
          for line in lines
          do (loop for day from 1 to W
                   for ch across line
                   do (setf (aref ary2d city day)
                            (eql ch #\o))))
    ary2d))


(defun cycle (x cycle)
  (1+ (mod (1- x) cycle)))

;; (next-holiday-cities 3 2 3 *e* *h*) ;=> (3 1)
;; (next-holiday-cities 3 2 4 *e* *h*) ;=> (3 4)
;; (next-holiday-cities 3 1 2 *e* *h*) ;=> (2)
(defun next-holiday-cities (W current-city next-day edges holidays)
  (loop for city in (cons current-city
                          (edges->nodes edges current-city))
        when (aref holidays city (cycle next-day W))
          collect city))

;; (holiday-cities 4 3 1 *h*) ;=>  (3 4)
(defun holiday-cities (N W day holidays)
  (loop for city from 1 to N
        when (aref holidays city (cycle day W))
          collect city))

;; (next-cities 3 '(1 2 3 4) 2 *e* *h*) ;=> (2)
;; (next-cities 3 '(2) 3 *e* *h*)       ;=> (3 1)
;; (next-cities 3 '(3 1) 4 *e* *h*)     ;=> (4)
;; (next-cities 3 nil 4 *e* *h*)        ;=> NIL
(defun next-cities (W cities next-day edges holidays)
  (loop for city in cities
        append (next-holiday-cities
                W city next-day edges holidays) into result
        finally (return (remove-duplicates result))))

;; (next-week-cities 4 3 *e* *h* 1) ;=> (3 4)
(defun next-week-cities (N W edges holidays city)
  (declare (ignore N))
  (loop for day from 2 to (1+ W)
        with current-cities = (list city)
        while current-cities
        do (setf current-cities
                 (next-cities
                  W current-cities day edges holidays))
        finally (return current-cities)))

;; (week-edges 4 3 *e* *h*) ;=> #(NIL NIL NIL (4 3) (4 3))
(defun week-edges (N W edges holidays)
  (let* ((start-cities (holiday-cities N W 1 holidays))
         (ary (make-array (1+ N) :element-type 'list
                                 :initial-element nil)))
    (loop for ca in start-cities
          do (loop for cb in (next-week-cities N W edges holidays ca)
                   do (push cb (aref ary ca)))
          finally (return ary))))

;; (has-cycle-p 4 #(NIL NIL NIL (4 3) (4 3))) ;=> T
;; (has-cycle-p 4 #(NIL NIL NIL (4) (1))) ;=> NIL
(defun has-cycle-p (N edges)
  (let* ((state (make-array (1+ N) :initial-element :before)))
    (labels ((visit (v)
               (case (aref state v)
                 (:now t)
                 (:done nil)
                 (t (setf (aref state v) :now)
                  (let ((found-cycle (some #'visit (aref edges v))))
                    (setf (aref state v) :done)
                    found-cycle)))))
      (loop for i from 1 to N
            thereis (visit i)))))

(defun endless-holiday-p/graph (N W edges holidays)
  (has-cycle-p N (week-edges N W edges holidays)))

(defun print-yesno (c)
  (declare (type boolean c))
  (princ (if c "Yes" "No")))

(defun main ()
  (let* ((times (read)))
    (loop repeat times
          for N = (read)
          for M = (read)
          for edge-list = (loop repeat (* M 2)
                                collect (read))
          for W = (read)
          for lines = (loop repeat N
                            collect (read-line))
          for edges = (make-edges N edge-list)
          for holidays = (make-holidays N W lines)
          do (print-yesno (endless-holiday-p/graph
                           N W edges holidays))
             (terpri))))

#-swank(main)
Code language: Lisp (lisp)

4. 遅延評価によるループチェック（AC21 135ms）

どうも、週グラフの生成で大きなサイズになってしまうことがあるようです。
たとえば、全都市が全曜日休日で連結なグラフでは、本来 ループできるのは自明です。
しかし、現在のループ判定はすべてのグラフを作った後に処理しているため、最悪 N x N の辺を確保する必要があります。

そこで、グラフ生成を遅延させることにしました。
1つずつ都市を調べてループが見つかれば、それで判定を中断すればよいのです。
has-cycle-p の中で、頂点 ca を訪れたときに初めて (next-week-cities N W edges holidays ca) を呼ぶ形にすれば、辺リストは保持されず、DFS が閉路を踏んだ時点で止まります。

;; 週グラフの辺を貯めずに、DFS で必要になった分だけ生成する
(defun endless-holiday-p/lazy (N W edges holidays)
  (let* ((state (make-array (1+ N) :initial-element :before)))
    (labels ((visit (v)
               (case (aref state v)
                 (:now t)
                 (:done nil)
                 (t (setf (aref state v) :now)
                  (let ((found-cycle
                          (some #'visit
                                (next-week-cities N W edges holidays v))))
                    (setf (aref state v) :done)
                    found-cycle)))))
      (loop for c in (holiday-cities N W 1 holidays)
            thereis (visit c)))))Code language: Lisp (lisp)

変えたところは、week-edges を削って、has-cycle-p に相当する部分を endless-holiday-p に統合しました。頂点を訪れたときにその場で next-week-cities を呼ぶので、辺リストが残りません。閉路を踏んだ時点で some と thereis が短絡して、そこで終わります。

;; (defparameter *e* (make-edges 4 '(1 2 1 4 2 4 2 3)))
;; (defparameter *h* (make-holidays 4 3 '("xxo" "xox" "oxo" "oxx")))

;; (make-edges 4 '(1 2 1 4 2 4 2 3))
;;=> #(NIL (4 2) (3 4 1) (2) (2 1))
(defun make-edges (N lst)
  (let* ((ary (make-array (1+ N) :element-type 'list
                            :initial-element nil)))
    (loop for (u v) on lst by #'cddr 
          while v
          do
             (push v (aref ary u))
             (push u (aref ary v)))
    ary))

;; (edges->nodes *e* 2) ;=> (3 4 1)
(defun edges->nodes (edges n)
  (aref edges n))

;; (make-holidays 4 3 '("xxo" "xox" "oxo" "oxx")) ;=>
;; #2A((NIL NIL NIL NIL)
;;     (NIL NIL NIL T)
;;     (NIL NIL T NIL)
;;     (NIL T NIL T)
;;     (NIL T NIL NIL))
(defun make-holidays (N W lines)
  (let* ((ary2d (make-array (list (1+ N) (1+ W))
                            :element-type 'boolean
                            :initial-element nil)))
    (loop for city from 1 to N
          for line in lines
          do (loop for day from 1 to W
                   for ch across line
                   do (setf (aref ary2d city day)
                            (eql ch #\o))))
    ary2d))


(defun cycle (x cycle)
  (1+ (mod (1- x) cycle)))

;; (next-holiday-cities 3 2 3 *e* *h*) ;=> (3 1)
;; (next-holiday-cities 3 2 4 *e* *h*) ;=> (3 4)
;; (next-holiday-cities 3 1 2 *e* *h*) ;=> (2)
(defun next-holiday-cities (W current-city next-day edges holidays)
  (loop for city in (cons current-city
                          (edges->nodes edges current-city))
        when (aref holidays city (cycle next-day W))
          collect city))

;; (holiday-cities 4 3 1 *h*) ;=>  (3 4)
(defun holiday-cities (N W day holidays)
  (loop for city from 1 to N
        when (aref holidays city (cycle day W))
          collect city))

;; (next-cities 3 '(1 2 3 4) 2 *e* *h*) ;=> (2)
;; (next-cities 3 '(2) 3 *e* *h*)       ;=> (3 1)
;; (next-cities 3 '(3 1) 4 *e* *h*)     ;=> (4)
;; (next-cities 3 nil 4 *e* *h*)        ;=> NIL
(defun next-cities (W cities next-day edges holidays)
  (loop for city in cities
        append (next-holiday-cities
                W city next-day edges holidays) into result
        finally (return (remove-duplicates result))))

;; (next-week-cities 4 3 *e* *h* 1) ;=> (3 4)
(defun next-week-cities (N W edges holidays city)
  (declare (ignore N))
  (loop for day from 2 to (1+ W)
        with current-cities = (list city)
        while current-cities
        do (setf current-cities
                 (next-cities
                  W current-cities day edges holidays))
        finally (return current-cities)))

;; 週グラフの辺を貯めずに、DFS で必要になった分だけ生成する
(defun endless-holiday-p/lazy (N W edges holidays)
  (let* ((state (make-array (1+ N) :initial-element :before)))
    (labels ((visit (v)
               (case (aref state v)
                 (:now t)
                 (:done nil)
                 (t (setf (aref state v) :now)
                  (let ((found-cycle
                          (some #'visit
                                (next-week-cities N W edges holidays v))))
                    (setf (aref state v) :done)
                    found-cycle)))))
      (loop for c in (holiday-cities N W 1 holidays)
            thereis (visit c)))))

(defun print-yesno (c)
  (declare (type boolean c))
  (princ (if c "Yes" "No")))

(defun main ()
  (let* ((times (read)))
    (loop repeat times
          for N = (read)
          for M = (read)
          for edge-list = (loop repeat (* M 2)
                                collect (read))
          for W = (read)
          for lines = (loop repeat N
                            collect (read-line))
          for edges = (make-edges N edge-list)
          for holidays = (make-holidays N W lines)
          do (print-yesno (endless-holiday-p/lazy
                           N W edges holidays))
             (terpri))))

#-swank(main)Code language: Lisp (lisp)