(in-package :cl-user) (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 :cp/util) :silent t) #+swank (use-package :cp/util :cl-user) #-swank (set-dispatch-macro-character #\# #\> (lambda (s c p) (declare (ignore c p)) `(values ,(read s nil nil t)))) #+sbcl (setq *random-state* (seed-random-state (nth-value 1 (get-time-of-day))))) #+swank (set-dispatch-macro-character #\# #\> #'cl-debug-print:debug-print-reader) (macrolet ((def (b) `(progn (deftype ,(intern (format nil "UINT~A" b)) () '(unsigned-byte ,b)) (deftype ,(intern (format nil "INT~A" b)) () '(signed-byte ,b)))) (define-int-types (&rest bits) `(progn ,@(mapcar (lambda (b) `(def ,b)) bits)))) (define-int-types 2 4 7 8 15 16 31 32 62 63 64)) (defconstant +mod+ 1000000007) (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))) (declaim (inline println)) (defun println (obj &optional (stream *standard-output*)) (let ((*read-default-float-format* (if (typep obj 'double-float) 'double-float *read-default-float-format*))) (prog1 (princ obj stream) (terpri stream)))) ;; BEGIN_INSERTED_CONTENTS (defpackage :cp/max-flow (:use :cl) (:export #:edge #:add-edge #:reinitialize-flow-network #:max-flow-overflow #:edge-to #:edge-capacity #:edge-default-capacity #:edge-reversed)) (in-package :cp/max-flow) (define-condition max-flow-overflow (error) ((graph :initarg :graph :reader max-flow-overflow-graph)) (:report (lambda (condition stream) (format stream "MOST-POSITIVE-FIXNUM or more units can flow on graph ~W." (max-flow-overflow-graph condition))))) (defstruct (edge (:constructor %make-edge (to capacity reversed &aux (default-capacity capacity)))) (to nil :type (integer 0 #.most-positive-fixnum)) (capacity 0 :type (integer 0 #.most-positive-fixnum)) (default-capacity 0 :type (integer 0 #.most-positive-fixnum)) (reversed nil :type (or null edge))) (defmethod print-object ((edge edge) stream) (let ((*print-circle* t)) (call-next-method))) (defun add-edge (graph from-idx to-idx capacity &key bidirectional) "FROM-IDX, TO-IDX := index of vertex GRAPH := vector of lists of all the edges that goes from each vertex If BIDIRECTIONAL is true, ADD-EDGE adds the reversed edge of the same capacity in addition." (declare (optimize (speed 3)) ((simple-array list (*)) graph)) (let* ((dep (%make-edge to-idx capacity nil)) (ret (%make-edge from-idx (if bidirectional capacity 0) dep))) (setf (edge-reversed dep) ret) (push dep (aref graph from-idx)) (push ret (aref graph to-idx)))) (declaim (inline reinitialize-flow-network)) (defun reinitialize-flow-network (graph) "Sets the current CAPACITY of every edge in GRAPH to the default capacity. That is, this function reinitialize the graph network to the state prior to sending flow." (loop for edges across graph do (dolist (edge edges) (setf (edge-capacity edge) (edge-default-capacity edge))))) ;;; ;;; Minimum cost flow (SSP) ;;; (defpackage :cp/min-cost-flow (:use :cl :cp/max-flow) (:export #:cedge #:cedge-p #:copy-cedge #:add-cedge #:+inf-cost+ #:cost-type #:cedge-reversed #:cedge-cost #:cedge-capacity #:cedge-to #:cedge-default-capacity #:not-enough-capacity-error #:not-enough-capacity-error-graph #:not-enough-capacity-error-flow #:not-enough-capacity-error-score)) (in-package :cp/min-cost-flow) ;; 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 (cedge (:constructor %make-cedge) (:include edge)) (cost 0 :type cost-type)) (define-condition not-enough-capacity-error (error) ((graph :initarg :graph :reader not-enough-capacity-error-graph) (flow :initarg :flow :reader not-enough-capacity-error-flow) (score :initarg :score :reader not-enough-capacity-error-score)) (: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))))) (defmethod print-object ((cedge cedge) stream) (let ((*print-circle* t)) (call-next-method))) (defun add-cedge (graph from-idx to-idx cost capacity) "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-cedge :to to-idx :capacity capacity :cost cost)) (ret (%make-cedge :to from-idx :capacity 0 :cost (- cost) :reversed dep))) (setf (cedge-reversed dep) ret) (push dep (aref graph from-idx)) (push ret (aref graph to-idx)))) (defpackage :cp/ssp (:use :cl :cp/min-cost-flow) (:export #:min-cost-flow!)) (in-package :cp/ssp) ;; binary heap for Dijkstra's algorithm (defstruct (heap (:constructor make-heap (size &aux (costs (make-array (1+ size) :element-type 'cost-type)) (vertices (make-array (1+ size) :element-type 'fixnum)))) (:copier nil) (:predicate nil)) (costs nil :type (simple-array cost-type (*))) (vertices nil :type (simple-array fixnum (*))) (position 1 :type (integer 1 #.most-positive-fixnum))) (defun heap-push (cost vertex heap) (declare (optimize (speed 3))) (symbol-macrolet ((position (heap-position heap))) (when (>= position (length (heap-costs heap))) (setf (heap-costs heap) (adjust-array (heap-costs heap) (* position 2)) (heap-vertices heap) (adjust-array (heap-vertices heap) (* position 2)))) (let ((costs (heap-costs heap)) (vertices (heap-vertices heap))) (labels ((heapify (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)) (heapify parent-pos)))))) (setf (aref costs position) cost (aref vertices position) vertex) (heapify position) (incf position) heap)))) (defun heap-pop (heap) (declare (optimize (speed 3))) (symbol-macrolet ((position (heap-position heap))) (let ((costs (heap-costs heap)) (vertices (heap-vertices heap))) (labels ((heapify (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)) (heapify 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)) (heapify 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)) (heapify 1)))))) (declaim (inline heap-empty-p)) (defun heap-empty-p (heap) (= (heap-position heap) 1)) (declaim (inline heap-reinitialize)) (defun heap-reinitialize (heap) (setf (heap-position heap) 1) heap) (defmacro the-cost-type (form) (reduce (lambda (x y) `(,(car form) (the cost-type ,x) (the cost-type ,y))) (cdr form))) (defun min-cost-flow! (graph src-idx dest-idx flow &key edge-count (if-overflow :error) bellman-ford) "Returns the minimum cost to send FLOW units from SRC-IDX to DEST-IDX in GRAPH. This function destructively modifies GRAPH. EDGE-COUNT := initial reserved size for heap (it should be the number of edges) IF-OVERFLOW := :error | nil If BELLMAN-FORD is true, this function does Bellman-Ford before all. It should be enabled for a graph that contains negative edges: Currently this function returns a correct result for a graph that contains negative edges, even when BELLMAN-FORD is disabled (only if no negative **cycles** are contained, of course). In this case, however, the worst-case time complexity is exponential. As a special case, if an input network is for a weighted bipartite matching that contains negative weights, this function works without Bellman-Ford." (declare (optimize (speed 3)) ((integer 0 #.most-positive-fixnum) flow src-idx dest-idx) ((simple-array list (*)) graph)) (let* ((size (length graph)) (edge-count (or edge-count (* size 2))) (prev-vertices (make-array size :element-type 'fixnum :initial-element 0)) (prev-edges (locally (declare (sb-ext:muffle-conditions style-warning)) (make-array size :element-type 'cedge))) (potential (make-array size :element-type 'cost-type :initial-element 0)) (dists (make-array size :element-type 'cost-type)) (pqueue (make-heap edge-count)) (res 0)) (declare (fixnum edge-count) (cost-type res)) (labels ((update-potential () (when (= (aref dists dest-idx) +inf-cost+) (if if-overflow (error 'not-enough-capacity-error :flow flow :graph graph :score res) (return-from min-cost-flow! res))) (dotimes (v size) (setf (aref potential v) (min +inf-cost+ (+ (aref potential v) (aref dists v))))))) (when bellman-ford (fill dists +inf-cost+) (setf (aref dists src-idx) 0) (dotimes (_ (- size 1)) (dotimes (v size) (let ((dist (aref dists v))) (when (< dist +inf-cost+) (dolist (cedge (aref graph v)) (when (> (cedge-capacity cedge) 0) (let ((to (cedge-to cedge))) (setf (aref dists to) (min (aref dists to) (+ dist (cedge-cost cedge))))))))))) (update-potential)) (loop (when (<= flow 0) (return-from min-cost-flow! res)) (fill dists +inf-cost+) (setf (aref dists src-idx) 0) (heap-reinitialize pqueue) (heap-push 0 src-idx pqueue) (loop until (heap-empty-p pqueue) do (multiple-value-bind (cost v) (heap-pop pqueue) (declare (cost-type cost) (fixnum v)) (when (<= cost (aref dists v)) (dolist (edge (aref graph v)) (let* ((next-v (cedge-to edge)) (next-cost (the-cost-type (+ (aref dists v) (cedge-cost edge) (aref potential v) (- (aref potential next-v)))))) (when (and (> (cedge-capacity edge) 0) (> (aref dists next-v) next-cost)) (setf (aref dists next-v) next-cost (aref prev-vertices next-v) v (aref prev-edges next-v) edge) (heap-push next-cost next-v pqueue))))))) (update-potential) (let ((max-flow flow)) (declare ((integer 0 #.most-positive-fixnum) max-flow)) (do ((v dest-idx (aref prev-vertices v))) ((= v src-idx)) (setq max-flow (min max-flow (cedge-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 (cedge-capacity (aref prev-edges v)) max-flow) (incf (cedge-capacity (cedge-reversed (aref prev-edges v))) max-flow))))))) (defpackage :cp/read-fixnum (:use :cl) (:export #:read-fixnum)) (in-package :cp/read-fixnum) (declaim (ftype (function * (values fixnum &optional)) read-fixnum)) (defun read-fixnum (&optional (in *standard-input*)) "NOTE: cannot read -2^62" (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 #\-)) (setq 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)))))))) ;; BEGIN_USE_PACKAGE (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cp/read-fixnum :cl-user)) (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cp/min-cost-flow :cl-user)) (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cp/ssp :cl-user)) (in-package :cl-user) ;;; ;;; Body ;;; (defun main () (let* ((n (read)) (m (read)) (graph (make-array n :element-type 'list :initial-element nil))) (dotimes (_ m) (let ((u (- (read-fixnum) 1)) (v (- (read-fixnum) 1)) (c (read-fixnum)) (d (read-fixnum))) (add-cedge graph u v c 1) (add-cedge graph v u c 1) (add-cedge graph u v d 1) (add-cedge graph v u d 1))) (println (min-cost-flow! graph 0 (- n 1) 2)))) #-swank (main) ;;; ;;; Test and benchmark ;;; #+swank (progn (defparameter *lisp-file-pathname* (uiop:current-lisp-file-pathname)) (setq *default-pathname-defaults* (uiop:pathname-directory-pathname *lisp-file-pathname*)) (uiop:chdir *default-pathname-defaults*) (defparameter *dat-pathname* (uiop:merge-pathnames* "test.dat" *lisp-file-pathname*)) (defparameter *problem-url* "https://yukicoder.me/problems/no/1301")) #+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))) #+(and sbcl (not swank)) (eval-when (:compile-toplevel) (when (or (> sb-c::*compiler-warning-count* 0) sb-c::*undefined-warnings*) (error "count: ~D, undefined warnings: ~A" sb-c::*compiler-warning-count* sb-c::*undefined-warnings*))) ;; To run: (5am:run! :sample) #+swank (5am:test :sample (5am:is (equal "8 " (run "3 2 1 2 1 4 2 3 1 2 " nil))) (5am:is (equal "3 " (run "3 3 1 2 1 4 2 3 1 5 1 3 1 6 " nil))))