Submission #7022031

---

Source Code Expand

;; -*- coding: utf-8 -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter OPT
    #+swank '(optimize (speed 3) (safety 2))
    #-swank '(optimize (speed 3) (safety 0) (debug 0)))
  #+swank (ql:quickload '(:cl-debug-print :fiveam))
  #-swank (set-dispatch-macro-character #\# #\> (lambda (s c p) (declare (ignore c p)) (read s nil (values) t))))
#+swank (cl-syntax:use-syntax cl-debug-print:debug-print-syntax)
#-swank (disable-debugger) ; for CS Academy

;; BEGIN_INSERTED_CONTENTS
;;;
;;; Minimum cost flow (Primal-Dual, O(FElogV))
;;;

(setf *print-circle* t)

;; COST-TYPE and +INF-COST+ may be changed. (A supposed use case is to adopt
;; bignum).
(deftype cost-type () 'fixnum)
(defconstant +inf-cost+ most-positive-fixnum)
(assert (and (typep +inf-cost+ 'cost-type)
             (subtypep 'cost-type 'integer)))

(defstruct (edge (:constructor %make-edge))
  (to nil :type (integer 0 #.most-positive-fixnum))
  (capacity 0 :type (integer 0 #.most-positive-fixnum))
  (cost 0 :type cost-type)
  (reversed nil :type (or null edge)))

(defun push-edge (from-idx to-idx capacity cost graph)
  "FROM-IDX, TO-IDX := index of vertex
GRAPH := vector of list of all the edges that goes from the vertex"
  (declare ((simple-array list (*)) graph)
           (cost-type cost))
  (let* ((dep (%make-edge :to to-idx :capacity capacity :cost cost))
         (ret (%make-edge :to from-idx :capacity 0 :cost (- cost) :reversed dep)))
    (setf (edge-reversed dep) ret)
    (push dep (aref graph from-idx))
    (push ret (aref graph to-idx))))

;; binary heap for Dijkstra's algorithm
(defstruct (fheap (:constructor make-fheap
                          (size
                           &aux (costs (make-array (1+ size) :element-type 'cost-type))
                                (vertices (make-array (1+ size) :element-type 'fixnum)))))
  (costs nil :type (simple-array cost-type (*)) :read-only t)
  (vertices nil :type (simple-array fixnum (*)) :read-only t)
  (position 1 :type (integer 1 #.most-positive-fixnum)))

(defun fheap-push (cost vertex fheap)
  (declare #.OPT)
  (symbol-macrolet ((position (fheap-position fheap)))
    (let ((costs (fheap-costs fheap))
          (vertices (fheap-vertices fheap)))
      (labels ((update (pos)
                 (declare (optimize (safety 0)))
                 (unless (= pos 1)
                   (let ((parent-pos (ash pos -1)))
                     (when (< (aref costs pos) (aref costs parent-pos))
                       (rotatef (aref costs pos) (aref costs parent-pos))
                       (rotatef (aref vertices pos) (aref vertices parent-pos))
                       (update parent-pos))))))
        (assert (< position (length costs)))
        (setf (aref costs position) cost
              (aref vertices position) vertex)
        (update position)
        (incf position)
        fheap))))

(defun fheap-pop (fheap)
  (declare #.OPT)
  (symbol-macrolet ((position (fheap-position fheap)))
    (let ((costs (fheap-costs fheap))
          (vertices (fheap-vertices fheap)))
      (labels ((update (pos)
                 (declare (optimize (safety 0))
                          ((integer 1 #.most-positive-fixnum) pos))
                 (let* ((child-pos1 (+ pos pos))
                        (child-pos2 (1+ child-pos1)))
                   (when (<= child-pos1 position)
                     (if (<= child-pos2 position)
                         (if (< (aref costs child-pos1) (aref costs child-pos2))
                             (unless (< (aref costs pos) (aref costs child-pos1))
                               (rotatef (aref costs pos) (aref costs child-pos1))
                               (rotatef (aref vertices pos) (aref vertices child-pos1))
                               (update child-pos1))
                             (unless (< (aref costs pos) (aref costs child-pos2))
                               (rotatef (aref costs pos) (aref costs child-pos2))
                               (rotatef (aref vertices pos) (aref vertices child-pos2))
                               (update child-pos2)))
                         (unless (< (aref costs pos) (aref costs child-pos1))
                           (rotatef (aref costs pos) (aref costs child-pos1))
                           (rotatef (aref vertices pos) (aref vertices child-pos1))))))))
        (multiple-value-prog1 (values (aref costs 1) (aref vertices 1))
          (decf position)
          (setf (aref costs 1) (aref costs position)
                (aref vertices 1) (aref vertices position))
          (update 1))))))

(declaim (inline fheap-empty-p))
(defun fheap-empty-p (fheap)
  (= (fheap-position fheap) 1))

(declaim (inline fheap-reinitialize))
(defun fheap-reinitialize (heap)
  (setf (fheap-position heap) 1)
  heap)

(define-condition not-enough-capacity-error (simple-error)
  ((graph :initarg :graph :reader not-enough-capacity-error-graph)
   (flow :initarg :flow :reader not-enough-capacity-error-flow))
  (:report
   (lambda (c s)
     (format s "Cannot send ~A units of flow on graph ~A due to not enough capacity."
             (not-enough-capacity-error-flow c)
             (not-enough-capacity-error-graph c)))))

(defun min-cost-flow! (src-idx dest-idx flow graph &key density)
  "Returns the minimum cost to send FLOW units from SRC-IDX to DEST-IDX in
GRAPH. Destructively modifies GRAPH.

DENSITY := nil | the number of edges (assumed to be (size of GRAPH)^2 if NIL)"
  (declare #.OPT
           ((integer 0 #.most-positive-fixnum) flow)
           ((simple-array list (*)) graph))
  (macrolet ((the-cost-type (form)
               (reduce (lambda (x y) `(,(car form) (the cost-type ,x) (the cost-type ,y)))
		       (cdr form))))
    (let* ((size (length graph))
           (density (or density (* size size)))
           (prev-vertices (make-array size :element-type 'fixnum :initial-element 0))
           (prev-edges (make-array size :element-type 'edge))
           (potential (make-array size :element-type 'cost-type :initial-element 0))
           (dist (make-array size :element-type 'cost-type))
           (pqueue (make-fheap density))
           (res 0))
      (declare (fixnum density)
               (cost-type res))
      (loop while (> flow 0)
            do (fill dist +inf-cost+)
               (setf (aref dist src-idx) 0)
               (fheap-reinitialize pqueue)
               (fheap-push 0 src-idx pqueue)
               (loop until (fheap-empty-p pqueue)
                     do (multiple-value-bind (cost v) (fheap-pop pqueue)
                          (declare (cost-type cost)
                                   (fixnum v))
                          (when (<= cost (aref dist v))
                            (dolist (edge (aref graph v))
                              (let* ((next-v (edge-to edge))
                                     (next-cost (the-cost-type
                                                 (+ (aref dist v)
                                                    (edge-cost edge)
                                                    (aref potential v)
                                                    (- (aref potential next-v))))))
                                (when (and (> (edge-capacity edge) 0)
                                           (> (aref dist next-v) next-cost))
                                  (setf (aref dist next-v) next-cost
                                        (aref prev-vertices next-v) v
                                        (aref prev-edges next-v) edge)
                                  (fheap-push next-cost next-v pqueue)))))))
               (when (= (aref dist dest-idx) +inf-cost+)
                 (error 'not-enough-capacity-error :flow flow :graph graph))
               (let ((max-flow flow))
                 (declare (fixnum max-flow))
                 (dotimes (v size)
                   (incf (aref potential v) (aref dist v)))
                 (do ((v dest-idx (aref prev-vertices v)))
                     ((= v src-idx))
                   (setf max-flow (min max-flow (edge-capacity (aref prev-edges v)))))
                 (decf flow max-flow)
                 (incf res (the cost-type (* max-flow (aref potential dest-idx))))
                 (do ((v dest-idx (aref prev-vertices v)))
                     ((= v src-idx))
                   (decf (edge-capacity (aref prev-edges v)) max-flow)
                   (incf (edge-capacity (edge-reversed (aref prev-edges v))) max-flow))))
      res)))

(declaim (ftype (function * (values fixnum &optional)) read-fixnum))
(defun read-fixnum (&optional (in *standard-input*))
  (declare #.OPT)
  (macrolet ((%read-byte ()
               `(the (unsigned-byte 8)
                     #+swank (char-code (read-char in nil #\Nul))
                     #-swank (sb-impl::ansi-stream-read-byte in nil #.(char-code #\Nul) nil))))
    (let* ((minus nil)
           (result (loop (let ((byte (%read-byte)))
                           (cond ((<= 48 byte 57)
                                  (return (- byte 48)))
                                 ((zerop byte) ; #\Nul
                                  (error "Read EOF or #\Nul."))
                                 ((= byte #.(char-code #\-))
                                  (setf minus t)))))))
      (declare ((integer 0 #.most-positive-fixnum) result))
      (loop
        (let* ((byte (%read-byte)))
          (if (<= 48 byte 57)
              (setq result (+ (- byte 48) (* 10 (the (integer 0 #.(floor most-positive-fixnum 10)) result))))
              (return (if minus (- result) 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

(defstruct (scc (:constructor %make-scc (graph revgraph posts result sizes count)))
  graph
  revgraph
  posts
  (result nil :type (simple-array (integer 0 #.most-positive-fixnum) (*)))
  (sizes nil :type (simple-array (integer 0 #.most-positive-fixnum) (*)))
  (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)
  (declare (optimize (speed 3))
           ((simple-array list (*)) graph)
           ((or null (simple-array list (*))) 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)))
         (result (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 result 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 result sizes ord))))

(defun main ()
  (declare #.OPT)
  (let* ((n (read))
         (graph (make-array n :element-type 'list :initial-element nil)))
    (declare (uint16 n))
    (dotimes (i n)
      (dotimes (j n)
        (when (= 1 (read-fixnum))
          (push j (aref graph i)))))
    (let* ((scc (make-scc graph))
           (count (scc-count scc))
           (components (scc-result scc))
           (sizes (scc-sizes scc))
           (network (make-array (+ (* 2 count) 2) :element-type 'list :initial-element nil))
           (src (* 2 count))
           (dest (+ (* 2 count) 1))
           (compressed-adj (make-array (list count count) :element-type 'bit)))
      (declare (uint16 count))
      (dotimes (i n)
        (dolist (j (aref graph i))
          (setf (aref compressed-adj (aref components i) (aref components j)) 1)))
      (dotimes (i count)
        (setf (aref compressed-adj i i) 0))
      (dotimes (i count)
        (push-edge src i most-positive-fixnum 0 network)
        (push-edge i (+ i count) most-positive-fixnum 0 network)
        (push-edge i (+ i count) 1 (- (aref sizes i)) network)
        (push-edge (+ i count) dest most-positive-fixnum 0 network))
      (dotimes (i count)
        (dotimes (j count)
          (when (= 1 (aref compressed-adj i j))
            (push-edge (+ i count) j most-positive-fixnum 0 network))))
      (println (- (min-cost-flow! src dest 2 network))))))

#-swank (main)

Submission Info

Judge Result