Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
CodeIQ 言語総選挙
(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)
(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)
(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))))))
(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)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment