CodeIQ 言語総選挙 https://codeiq.jp/wp/vote/

vote.lisp

(defpackage #:paring
  (:use :cl))

(in-package :paring)

(defstruct seats w h map)

(defun new-seats (str)
  (with-input-from-string (s str)
    (let ((m (loop while (listen s) collect (read-line s))))
      (make-seats :w (length (car m)) :h (length m) :map m))))

(defun show-seats (s)
  (format t "~{~A~%~}" (seats-map s)))

(defun copy-seats (s)
  (make-seats :w (seats-w s) :h (seats-h s)
	      :map (mapcar #'copy-seq (seats-map s))))

(defun seats-ref (s x y)
  (when (and (< -1 x (seats-w s))
	     (< -1 y (seats-h s)))
    (aref (nth y (seats-map s)) x)))

(defun make-pair (s x1 y1 x2 y2)
  (setf (aref (nth y1 (seats-map s)) x1) #\*
	(aref (nth y2 (seats-map s)) x2) #\*))

(defmacro each-stu ((x y) s &body body)
  (let ((gs (gensym)))
    `(let ((,gs ,s))
       (dotimes (,y (seats-h ,gs))
	 (dotimes (,x (seats-w ,gs))
	   (when (char= (seats-ref ,gs ,x ,y) #\O)
	     ,@body))))))

(defun find-stu (s)
  (each-stu (x y) s (return-from find-stu (values x y))))

(defun neighbors (s x y)
  (loop for (x y) in `((,x ,(1- y)) (,(1- x) ,y) (,(1+ x) ,y) (,x ,(1+ y)))
    when (eql (seats-ref s x y) #\O)
    collect (list x y)))

(defun fill-endedge (s)
  (loop for upd = nil
    do (each-stu (x y) s
	 (let ((ns (neighbors s x y)))
	   (case (length ns)
	     (0 (return-from fill-endedge nil))
	     (1 (make-pair s x y (caar ns) (cadar ns))
		(setq upd t)))))
    while upd)
  s)

(defun rotate (s)
  (let ((ox (/ (seats-w s) 2))
	(oy (/ (seats-h s) 2))
	(counts (list 0 0 0 0)))
    (each-stu (x y) s
      (incf (nth (+ (if (< y oy) 0 2) (if (eq (>= y oy) (< x ox)) 1 0)) counts)))
    (dotimes (_ (position (apply #'min counts) counts))
      (psetf (seats-w s) (seats-h s)
	     (seats-h s) (seats-w s)
	     (seats-map s) (reverse (apply #'map 'list #'vector (seats-map s))))))
  s)

(defun solve (str)
  (let ((s (new-seats str))
	(even 0) (odd 0))
    (each-stu (x y) s
      (if (evenp (+ x y)) (incf even) (incf odd)))
    (when (or (= even odd 0) (/= even odd))
      (return-from solve nil))
    
    (labels ((rec (s)
	       (multiple-value-bind (x y) (find-stu s)
		 (when (null x)
		   (return-from solve s))
		 (loop for (nx ny) in (neighbors s x y)
		   for cp = (copy-seats s)
		   do (make-pair cp x y nx ny)
		      (rec cp)))))
      (when (fill-endedge s)
	(rotate s)
	(rec s)))))

(defun read-input ()
  (with-output-to-string (s)
    (loop while (listen) do (write-line (read-line) s))))

(compile 'seats-ref)
(compile 'neighbors)
(compile 'fill-endedge)
(compile 'solve)

(format t "~:[no~;yes~]~%" (solve (read-input)))