;; -*- coding: utf-8 -*- (eval-when (:compile-toplevel :load-toplevel :execute) (sb-int:defconstant-eqx OPT #+swank '(optimize (speed 3) (safety 2)) #-swank '(optimize (speed 3) (safety 0) (debug 0)) #'equal) #+swank (ql:quickload '(:cl-debug-print :fiveam) :silent t) #-swank (set-dispatch-macro-character #\# #\> (lambda (s c p) (declare (ignore c p)) (read s nil nil t)))) #+swank (cl-syntax:use-syntax cl-debug-print:debug-print-syntax) #-swank (disable-debugger) ; for CS Academy ;; BEGIN_INSERTED_CONTENTS ;;; ;;; Strongly connected components of directed graph, 2-SAT ;;; (defstruct (scc (:constructor %make-scc (graph revgraph posts components sizes count))) (graph nil :type vector) ;; reversed graph (revgraph nil :type vector) ;; vertices by post-order DFS posts ;; components[i] := strongly connected component of the i-th vertex (components nil :type (simple-array (integer 0 #.most-positive-fixnum) (*))) ;; sizes[k] := size of the k-th strongly connected component (sizes nil :type (simple-array (integer 0 #.most-positive-fixnum) (*))) ;; the total number of strongly connected components (count 0 :type (integer 0 #.most-positive-fixnum))) (declaim (inline %make-revgraph)) (defun %make-revgraph (graph) (let* ((n (length graph)) (revgraph (make-array n :element-type 'list :initial-element nil))) (dotimes (i n) (dolist (dest (aref graph i)) (push i (aref revgraph dest)))) revgraph)) (defun make-scc (graph &optional revgraph) "GRAPH := vector of adjacency lists REVGRAPH := NIL | reversed graph of GRAPH" (declare (optimize (speed 3)) (vector graph) ((or null vector) revgraph)) (let* ((revgraph (or revgraph (%make-revgraph graph))) (n (length graph)) (visited (make-array n :element-type 'bit :initial-element 0)) (posts (make-array n :element-type '(integer 0 #.most-positive-fixnum))) (components (make-array n :element-type '(integer 0 #.most-positive-fixnum))) (sizes (make-array n :element-type '(integer 0 #.most-positive-fixnum) :initial-element 0)) (pointer 0) (ord 0) ; ordinal number for a strongly connected component ) (declare ((integer 0 #.most-positive-fixnum) pointer ord)) (assert (= n (length revgraph))) (labels ((dfs (v) (setf (aref visited v) 1) (dolist (neighbor (aref graph v)) (when (zerop (aref visited neighbor)) (dfs neighbor))) (setf (aref posts pointer) v) (incf pointer)) (reversed-dfs (v ord) (setf (aref visited v) 1 (aref components v) ord) (incf (aref sizes ord)) (dolist (neighbor (aref revgraph v)) (when (zerop (aref visited neighbor)) (reversed-dfs neighbor ord))))) (dotimes (v n) (when (zerop (aref visited v)) (dfs v))) (fill visited 0) (loop for i from (- n 1) downto 0 for v = (aref posts i) when (zerop (aref visited v)) do (reversed-dfs v ord) (incf ord)) (%make-scc graph revgraph posts components sizes ord)))) (declaim (ftype (function * (values (simple-array t (*)) &optional)) make-condensed-graph)) (defun make-condensed-graph (scc) "Does graph condensation. This function is non-destructive. The resultant graph doesn't contain self-loops even if the given graph does." (declare (optimize (speed 3))) (let* ((graph (scc-graph scc)) (n (length graph)) (comp-n (scc-count scc)) (components (scc-components scc)) (condensed (make-array comp-n :element-type t))) (dotimes (i comp-n) (setf (aref condensed i) (make-hash-table :test #'eql))) (dotimes (i n) (let ((i-comp (aref components i))) (dolist (neighbor (aref graph i)) (let ((neighbor-comp (aref components neighbor))) (unless (= i-comp neighbor-comp) (setf (gethash neighbor-comp (aref condensed i-comp)) t)))))) (dotimes (i comp-n) (setf (aref condensed i) (loop for x being each hash-key of (aref condensed i) collect x))) condensed)) ;;; ;;; 2-SAT ;;; (defstruct (2sat (:constructor make-2sat (size &aux (graph (make-array (* 2 size) :element-type 'list :initial-element nil))))) (size 0 :type (integer 0 #.most-positive-fixnum)) (graph nil :type (simple-array list (*))) (scc nil :type (or null scc))) (declaim (inline negate)) (defun negate (p) (- -1 p)) (declaim (inline add-implication)) (defun add-implication (2sat p q) "Adds `P => Q' to 2SAT." (declare (fixnum p q)) (let ((size (2sat-size 2sat)) (graph (2sat-graph 2sat))) (when (< p 0) (setq p (+ size (- -1 p)))) (when (< q 0) (setq q (+ size (- -1 q)))) (push q (aref graph p)) 2sat)) (declaim (inline add-disjunction)) (defun add-disjunction (2sat p q) "Adds `P or Q' to 2SAT." (declare (fixnum p q)) (add-implication 2sat (negate p) q) (add-implication 2sat (negate q) p) 2sat) (declaim (inline 2sat-solve)) (defun 2sat-solve (2sat) "Solves 2-SAT and returns a simple bit vector expressing the boolean of each variable if it is feasible, otherwise returns NIL." (let* ((size (2sat-size 2sat)) (graph (2sat-graph 2sat)) (scc (make-scc graph)) (components (scc-components scc)) (result (make-array size :element-type 'bit :initial-element 0))) (setf (2sat-scc 2sat) scc) (loop for v below size for v-comp = (aref components v) for neg-comp = (aref components (+ v size)) do (cond ((> v-comp neg-comp) (setf (sbit result v) 1)) ((= v-comp neg-comp) (return-from 2sat-solve nil)))) result)) ;; NOTE: not enclosed with (BLOCK NIL) (defmacro dopairs ((var1 var2 list &optional result) &body body) "Iterates BODY for each subset of LIST containing two elements." (let ((suffix (gensym)) (_list (gensym))) `(let ((,_list ,list)) (loop for ,suffix on ,_list for ,var1 = (car ,suffix) do (dolist (,var2 (cdr ,suffix)) ,@body)) ,result))) (defmacro dbg (&rest forms) #+swank (if (= (length forms) 1) `(format *error-output* "~A => ~A~%" ',(car forms) ,(car forms)) `(format *error-output* "~A => ~A~%" ',forms `(,,@forms))) #-swank (declare (ignore forms))) (defmacro define-int-types (&rest bits) `(progn ,@(mapcar (lambda (b) `(deftype ,(intern (format nil "UINT~A" b)) () '(unsigned-byte ,b))) bits) ,@(mapcar (lambda (b) `(deftype ,(intern (format nil "INT~A" b)) () '(signed-byte ,b))) bits))) (define-int-types 2 4 7 8 15 16 31 32 62 63 64) (declaim (inline println)) (defun println (obj &optional (stream *standard-output*)) (let ((*read-default-float-format* 'double-float)) (prog1 (princ obj stream) (terpri stream)))) (defconstant +mod+ 1000000007) ;;; ;;; Body ;;; (defun main () (let* ((n (read)) (us (make-array n :element-type 'simple-string)) (table (make-hash-table :test #'equal)) (2sat (make-2sat n))) (when (> n 52) (write-line "Impossible") (return-from main)) (dotimes (i n) (let* ((u (read-line)) (pre1 (subseq u 0 1)) (suf2 (subseq u 1 3)) (pre2 (subseq u 0 2)) (suf1 (subseq u 2 3))) (declare (simple-string u)) (push i (gethash pre1 table)) (push i (gethash suf2 table)) (push (negate i) (gethash pre2 table)) (push (negate i) (gethash suf1 table)) (setf (aref us i) u))) (loop for set being each hash-value of table do (dopairs (i j set) (declare (fixnum i j)) ;; cannot be true simultaneously (add-disjunction 2sat (negate i) (negate j)))) (let ((result (2sat-solve 2sat))) (if (null result) (write-line "Impossible") (dotimes (i n) (let ((u (aref us i))) (if (= 1 (sbit result i)) (format t "~A ~A~A~%" (aref u 0) (aref u 1) (aref u 2)) (format t "~A~A ~A~%" (aref u 0) (aref u 1) (aref u 2))))))))) #-swank (main) ;;; ;;; Test and benchmark ;;; #+swank (defun io-equal (in-string out-string &key (function #'main) (test #'equal)) "Passes IN-STRING to *STANDARD-INPUT*, executes FUNCTION, and returns true if the string output to *STANDARD-OUTPUT* is equal to OUT-STRING." (labels ((ensure-last-lf (s) (if (eql (uiop:last-char s) #\Linefeed) s (uiop:strcat s uiop:+lf+)))) (funcall test (ensure-last-lf out-string) (with-output-to-string (out) (let ((*standard-output* out)) (with-input-from-string (*standard-input* (ensure-last-lf in-string)) (funcall function))))))) #+swank (defun get-clipbrd () (with-output-to-string (out) (run-program "C:/msys64/usr/bin/cat.exe" '("/dev/clipboard") :output out))) #+swank (defparameter *this-pathname* (uiop:current-lisp-file-pathname)) #+swank (defparameter *dat-pathname* (uiop:merge-pathnames* "test.dat" *this-pathname*)) #+swank (defun run (&optional thing (out *standard-output*)) "THING := null | string | symbol | pathname null: run #'MAIN using the text on clipboard as input. string: run #'MAIN using the string as input. symbol: alias of FIVEAM:RUN!. pathname: run #'MAIN using the text file as input." (let ((*standard-output* out)) (etypecase thing (null (with-input-from-string (*standard-input* (delete #\Return (get-clipbrd))) (main))) (string (with-input-from-string (*standard-input* (delete #\Return thing)) (main))) (symbol (5am:run! thing)) (pathname (with-open-file (*standard-input* thing) (main)))))) #+swank (defun gen-dat () (uiop:with-output-file (out *dat-pathname* :if-exists :supersede) (format out ""))) #+swank (defun bench (&optional (out (make-broadcast-stream))) (time (run *dat-pathname* out)))