Skip to content
Switch branches/tags
Go to file
Cannot retrieve contributors at this time
;;; Google Code Jam 2020, Qualification Round, Problem 3: Parenting Partnering Returns
(defun solve (&optional (in *standard-input*))
(dotimes (caseno (read in))
(format t "Case #~D: " (1+ caseno))
(solve-case in)))
(defstruct (graph (:constructor make-graph (n-nodes)))
(defmethod print-object ((g graph) out)
(print-unreadable-object (g out :type t)
(dotimes (i (graph-n-nodes g))
(format out "~A" (or (node-color (graph-node g i)) #\–)))
(format out " with ~D nodes" (graph-n-nodes g))))
(defstruct (node)
(graph nil :type graph)
(index nil :type unsigned-byte)
(discovered nil)
(processed nil))
(defmethod print-object ((n node) out)
(print-unreadable-object (n out :type t)
(format out "#~D ~D–~D" (node-index n) (node-S n) (node-E n))
(format out " ~A" (ecase (node-color n)
((#\C) #\C)
((#\J) #\J)
((nil) #\–)))))
(defun graph-node (g i)
(aref (graph-nodes g) i))
(defun nodes-linked-p (n1 n2)
(let ((l (graph-links (node-graph n1))))
(not (zerop (aref l (node-index n1) (node-index n2))))))
(defun create-graph (n-nodes)
(let ((g (make-graph n-nodes)))
(setf (graph-nodes g) (make-array (list n-nodes)))
(setf (graph-links g) (make-array (list n-nodes n-nodes) :element-type 'bit :initial-element 0))
(defmacro do-nodes ((var graph) &body body)
(let ((i (gensym (symbol-name :i)))
(g (gensym (symbol-name :g))))
`(let ((,g ,graph))
(dotimes (,i (graph-n-nodes ,g))
(let ((,var (graph-node ,g ,i)))
(defmacro do-neighbors ((var node) &body body)
(let ((g (gensym (symbol-name :g)))
(n1 (gensym (symbol-name :n1))))
`(let* ((,n1 ,node)
(,g (node-graph ,n1)))
(do-nodes (,var ,g)
(when (and (not (eq ,n1 ,var)) (nodes-linked-p ,n1 ,var))
(defun make-queue ()
(cons nil '()))
(defun queue-empty-p (q)
(declare (type cons q))
(not (endp (cdr q))))
(defun pop-queue (q)
(declare (type cons q))
(assert (not (endp (cdr q))))
(let ((result (first (cdr q))))
(setf (cdr q) (rest (cdr q)))
(defparameter default-color #\C)
(defun complement-color (color)
(case color
((#\C) #\J)
((#\J) #\C)))
(defun push-queue (v q)
(setf (cdr q) (cons v (cdr q)))
(defun bfs (g fun-ne fun-nl fun-edge)
(let ((q (make-queue)))
(do-nodes (n1 g)
(unless (node-discovered n1)
(push-queue n1 q)
(setf (node-discovered n1) t)
(setf (node-color n1) default-color)
(do ()
((not (queue-empty-p q)))
(let ((v (pop-queue q)))
(funcall fun-ne v)
(setf (node-processed v) t)
(do-neighbors (y v)
(unless (node-processed y)
(funcall fun-edge v y))
(unless (node-discovered y)
(push-queue y q)
(setf (node-discovered y) t)))
(funcall fun-nl v)))))))
(defun compute-overlap (g)
((overlapp (ni nj)
(or (overlapp-1 ni nj)
(overlapp-1 nj ni)))
(overlapp-1 (ni nj)
(if (<= (node-S ni) (node-S nj))
(> (node-E ni) (node-S nj))
(and (< (node-E ni) (node-E nj))
(< (node-S ni) (node-E nj))))))
;; detect overlaps
(do-nodes (n1 g)
(do-nodes (n2 g)
(unless (eq n1 n2)
(setf (aref (graph-links g) (node-index n1) (node-index n2))
(if (overlapp n1 n2) 1 0)))))))
(defun solve-case (in)
(let* ((n-nodes (read in))
(g (create-graph n-nodes)))
;; read chores
(dotimes (i n-nodes)
(setf (aref (graph-nodes g) i)
:graph g
:index i
:S (read in)
:E (read in))))
;; compute links
(compute-overlap g)
;; color graph
(bfs g
#'(lambda (n) (declare (ignore n)))
#'(lambda (n) (declare (ignore n)))
#'(lambda (n1 n2)
(when (eq (node-color n1) (node-color n2))
(format t "IMPOSSIBLE~%")
(return-from solve-case (values)))
(unless (node-color n2)
(setf (node-color n2)
(if (node-color n1) (complement-color (node-color n1)) default-color)))))
(dotimes (i n-nodes)
(format t "~A" (node-color (graph-node g i))))
(format t "~%")))