結果
| 問題 | No.1207 グラフX |
| ユーザー |
 sansaqua
|
| 提出日時 | 2020-08-30 13:35:15 |
| 言語 | Common Lisp (sbcl 2.3.8) |
| 結果 |
AC
|
| 実行時間 | 454 ms / 2,000 ms |
| コード長 | 19,652 bytes |
| コンパイル時間 | 350 ms |
| コンパイル使用メモリ | 89,788 KB |
| 実行使用メモリ | 101,568 KB |
| 最終ジャッジ日時 | 2024-04-27 06:59:35 |
| 合計ジャッジ時間 | 14,433 ms |
|
ジャッジサーバーID （参考情報） |
judge5 / judge4 |
| 外部呼び出し有り |
（要ログイン）
テストケース
テストケース表示| 入力 | 結果 | 実行時間 実行使用メモリ |
|---|---|---|
| testcase_00 | AC | 454 ms
54,376 KB |
| testcase_01 | AC | 290 ms
52,616 KB |
| testcase_02 | AC | 277 ms
54,392 KB |
| testcase_03 | AC | 286 ms
52,616 KB |
| testcase_04 | AC | 284 ms
52,620 KB |
| testcase_05 | AC | 344 ms
99,580 KB |
| testcase_06 | AC | 352 ms
99,704 KB |
| testcase_07 | AC | 348 ms
96,560 KB |
| testcase_08 | AC | 261 ms
42,388 KB |
| testcase_09 | AC | 252 ms
48,392 KB |
| testcase_10 | AC | 337 ms
77,196 KB |
| testcase_11 | AC | 363 ms
101,568 KB |
| testcase_12 | AC | 250 ms
44,184 KB |
| testcase_13 | AC | 201 ms
40,312 KB |
| testcase_14 | AC | 281 ms
48,280 KB |
| testcase_15 | AC | 261 ms
44,308 KB |
| testcase_16 | AC | 179 ms
36,244 KB |
| testcase_17 | AC | 216 ms
46,304 KB |
| testcase_18 | AC | 164 ms
42,260 KB |
| testcase_19 | AC | 247 ms
38,292 KB |
| testcase_20 | AC | 283 ms
50,568 KB |
| testcase_21 | AC | 58 ms
36,204 KB |
| testcase_22 | AC | 207 ms
44,160 KB |
| testcase_23 | AC | 219 ms
48,248 KB |
| testcase_24 | AC | 145 ms
42,372 KB |
| testcase_25 | AC | 276 ms
48,540 KB |
| testcase_26 | AC | 230 ms
44,436 KB |
| testcase_27 | AC | 268 ms
46,492 KB |
| testcase_28 | AC | 256 ms
48,264 KB |
| testcase_29 | AC | 253 ms
46,360 KB |
| testcase_30 | AC | 161 ms
38,164 KB |
| testcase_31 | AC | 183 ms
33,916 KB |
| testcase_32 | AC | 124 ms
38,036 KB |
| testcase_33 | AC | 140 ms
38,292 KB |
| testcase_34 | AC | 250 ms
48,228 KB |
| testcase_35 | AC | 57 ms
35,928 KB |
| testcase_36 | AC | 250 ms
48,268 KB |
| testcase_37 | AC | 232 ms
42,264 KB |
| testcase_38 | AC | 81 ms
34,072 KB |
| testcase_39 | AC | 141 ms
42,340 KB |
| testcase_40 | AC | 165 ms
36,200 KB |
| testcase_41 | AC | 216 ms
38,288 KB |
| testcase_42 | AC | 21 ms
30,628 KB |
| testcase_43 | AC | 22 ms
31,688 KB |
| testcase_44 | AC | 20 ms
29,608 KB |
| testcase_45 | AC | 268 ms
50,328 KB |
| testcase_46 | AC | 269 ms
50,584 KB |
| testcase_47 | AC | 273 ms
50,588 KB |
| testcase_48 | AC | 268 ms
50,452 KB |
コンパイルメッセージ
; compiling file "/home/judge/data/code/Main.lisp" (written 27 APR 2024 06:59:20 AM): ; wrote /home/judge/data/code/Main.fasl ; compilation finished in 0:00:00.281
ソースコード
#-swank
(unless (member :child-sbcl *features*)
(quit
:unix-status
(process-exit-code
(run-program *runtime-pathname*
`("--control-stack-size" "128MB"
"--noinform" "--disable-ldb" "--lose-on-corruption" "--end-runtime-options"
"--eval" "(push :child-sbcl *features*)"
"--script" ,(namestring *load-pathname*))
:output t :error t :input t))))
(in-package :cl-user)
(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)) `(values ,(read s nil nil t)))))
#+swank (cl-syntax:use-syntax cl-debug-print:debug-print-syntax)
(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)
(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* 'double-float))
(prog1 (princ obj stream) (terpri stream))))
;; BEGIN_INSERTED_CONTENTS
;;;
;;; Minimum spanning tree (Boruvka's algorithm, O(ElogV))
;;;
;;; Reference:
;;; Ahuja, Magnanti, Orlin. Network Flows: Theory, Algorithms, and Applications.
;;;
(defpackage :cp/boruvka
(:use :cl)
(:export #:find-mst))
(in-package :cp/boruvka)
(defconstant +inf-cost+ most-positive-fixnum)
;; Here I express each connected component as a cycle with singly-linked list,
;; though Ahuja's book adopts doubly-linked list. I learned about this technique
;; in noshi91's article: http://noshi91.hatenablog.com/entry/2019/07/19/180606
;; (Japanese)
(declaim (inline find-mst)
(ftype (function * (values (simple-array fixnum (*))
(simple-array fixnum (*))
(simple-array fixnum (*))
&optional))
find-mst))
(defun find-mst (graph &key (vertex-key #'car) (cost-key #'cdr) maximize)
"Computes an MST by Boruvka's algorithm. Returns three values: a vector that
stores each cost of the edges, two vectors that store each end of the edges. If
GRAPH is not connected, this function computes MST for each connected component.
GRAPH := vector of adjacency lists
MAXIMIZE := if true, solve maximization problem instead"
(declare (vector graph))
(let* ((n (length graph))
(roots (make-array n :element-type 'fixnum))
;; next node in a connected component
(nexts (make-array n :element-type 'fixnum))
(min-costs (make-array n :element-type 'fixnum))
(min-srcs (make-array n :element-type 'fixnum))
(min-dests (make-array n :element-type 'fixnum))
(edge-count 0)
(res-costs (make-array (max 0 (- n 1)) :element-type 'fixnum))
(res-srcs (make-array (max 0 (- n 1)) :element-type 'fixnum))
(res-dests (make-array (max 0 (- n 1)) :element-type 'fixnum)))
(dotimes (i n)
(setf (aref roots i) i
(aref nexts i) i))
(labels ((%add (src dest cost)
"Adds a new edge to the (unfinished) MST."
(declare (fixnum src dest cost))
(when (> src dest) (rotatef src dest))
(setf (aref res-srcs edge-count) src
(aref res-dests edge-count) dest
(aref res-costs edge-count) (if maximize (- cost) cost)
edge-count (+ edge-count 1)))
(%merge (root1 root2)
"Merges ROOT2 into ROOT1."
(loop for v = (aref nexts root2) then (aref nexts v)
until (= v root2)
do (setf (aref roots v) root1)
finally (setf (aref roots v) root1))
;; meld two cycles
(rotatef (aref nexts root1) (aref nexts root2))))
(loop for updated = nil
while (< edge-count (- n 1))
do (fill min-costs +inf-cost+)
;; detect minimum cost edge starting from each connected component
(dotimes (u n)
(let ((root (aref roots u)))
(dolist (edge (aref graph u))
(let ((v (funcall vertex-key edge))
(cost (funcall cost-key edge)))
(declare (fixnum v cost))
(when maximize (setq cost (- cost)))
(when (and (/= root (aref roots v))
(<= cost (aref min-costs root)))
(setf (aref min-costs root) cost
(aref min-srcs root) u
(aref min-dests root) v))))))
;; merge all the pairs of connected components linked with above
;; enumerated edges
(dotimes (v n)
(let* ((root (aref roots v))
(src (aref min-srcs root))
(dest (aref min-dests root))
(cost (aref min-costs root)))
(unless (= cost +inf-cost+) ; can be true if GRAPH is not connected
(loop for root2 = (aref roots dest)
until (= root root2)
do (setq updated t)
(%add src dest cost)
(%merge root root2)
(setq src (aref min-srcs root2)
dest (aref min-dests root2)
cost (aref min-costs root2))))))
while updated)
(values (adjust-array res-costs edge-count)
(adjust-array res-srcs edge-count)
(adjust-array res-dests edge-count)))))
(defpackage :cp/mod-power
(:use :cl)
(:export #:mod-power))
(in-package :cp/mod-power)
(declaim (inline mod-power))
(defun mod-power (base power modulus)
"Returns BASE^POWER mod MODULUS. Note: 0^0 = 1.
BASE := integer
POWER, MODULUS := non-negative fixnum"
(declare ((integer 0 #.most-positive-fixnum) modulus power)
(integer base))
(let ((base (mod base modulus))
(res (mod 1 modulus)))
(declare ((integer 0 #.most-positive-fixnum) base res))
(loop while (> power 0)
when (oddp power)
do (setq res (mod (* res base) modulus))
do (setq base (mod (* base base) modulus)
power (ash power -1)))
res))
;;;
;;; Arithmetic operations with static modulus
;;;
(defpackage :cp/mod-operations
(:use :cl)
(:export #:define-mod-operations))
(in-package :cp/mod-operations)
;; NOTE: Currently MOD* and MOD+ doesn't apply MOD when the number of
;; parameters is one. For simplicity I won't fix it for now.
(defmacro define-mod-operations (divisor)
(let ((mod* (intern "MOD*"))
(mod+ (intern "MOD+"))
(incfmod (intern "INCFMOD"))
(decfmod (intern "DECFMOD"))
(mulfmod (intern "MULFMOD")))
`(progn
(defun ,mod* (&rest args)
(reduce (lambda (x y) (mod (* x y) ,divisor)) args))
(defun ,mod+ (&rest args)
(reduce (lambda (x y) (mod (+ x y) ,divisor)) args))
#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(locally (declare (sb-ext:muffle-conditions warning))
(sb-c:define-source-transform ,mod* (&rest args)
(if (null args)
1
(reduce (lambda (x y) `(mod (* ,x ,y) ,',divisor)) args)))
(sb-c:define-source-transform ,mod+ (&rest args)
(if (null args)
0
(reduce (lambda (x y) `(mod (+ ,x ,y) ,',divisor)) args)))))
(define-modify-macro ,incfmod (delta)
(lambda (x y) (mod (+ x y) ,divisor)))
(define-modify-macro ,decfmod (delta)
(lambda (x y) (mod (- x y) ,divisor)))
(define-modify-macro ,mulfmod (multiplier)
(lambda (x y) (mod (* x y) ,divisor))))))
(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))))))))
;;;
;;; Disjoint set (union by size & path compression)
;;;
(defpackage :cp/disjoint-set
(:use :cl)
(:export #:disjoint-set #:make-disjoint-set #:ds-data
#:ds-root #:ds-unite! #:ds-connected-p #:ds-size))
(in-package :cp/disjoint-set)
(defstruct (disjoint-set
(:constructor make-disjoint-set
(size &aux (data (make-array size :element-type 'fixnum :initial-element -1))))
(:conc-name ds-)
(:predicate nil)
(:copier nil))
(data nil :type (simple-array fixnum (*))))
(declaim (inline ds-root))
(defun ds-root (disjoint-set x)
"Returns the root of X."
(declare ((mod #.array-total-size-limit) x))
(let ((data (ds-data disjoint-set)))
(labels ((recur (x)
(if (< (aref data x) 0)
x
(setf (aref data x)
(recur (aref data x))))))
(recur x))))
(declaim (inline ds-unite!))
(defun ds-unite! (disjoint-set x1 x2)
"Destructively unites X1 and X2 and returns true iff X1 and X2 become
connected for the first time."
(let ((root1 (ds-root disjoint-set x1))
(root2 (ds-root disjoint-set x2)))
(unless (= root1 root2)
(let ((data (ds-data disjoint-set)))
;; NOTE: If you want X1 to always be root, just delete this form. (Time
;; complexity becomes worse, however.)
(when (> (aref data root1) (aref data root2))
(rotatef root1 root2))
(incf (aref data root1) (aref data root2))
(setf (aref data root2) root1)))))
(declaim (inline ds-connected-p))
(defun ds-connected-p (disjoint-set x1 x2)
"Returns true iff X1 and X2 have the same root."
(= (ds-root disjoint-set x1) (ds-root disjoint-set x2)))
(declaim (inline ds-size))
(defun ds-size (disjoint-set x)
"Returns the size of the connected component to which X belongs."
(- (aref (ds-data disjoint-set)
(ds-root disjoint-set x))))
;;;
;;; Sort multiple vectors
;;;
(defpackage :cp/parallel-sort
(:use :cl)
(:export #:parallel-sort!))
(in-package :cp/parallel-sort)
;; TODO: throw an error if there are two ore more identical vectors in the given
;; vectors
(declaim (inline %median3))
(defun %median3 (x y z order)
(if (funcall order x y)
(if (funcall order y z)
y
(if (funcall order z x)
x
z))
(if (funcall order z y)
y
(if (funcall order x z)
x
z))))
(defun parallel-sort! (vector order &rest vectors)
"Destructively sorts VECTOR w.r.t. ORDER and applies the same permutation to
all the vectors in VECTORS.
Note: not randomized; shuffle the inputs if necessary"
(declare (vector vector))
(labels
((recur (left right)
(when (< left right)
(let* ((l left)
(r right)
(pivot (%median3 (aref vector l)
(aref vector (ash (+ l r) -1))
(aref vector r)
order)))
(declare ((integer 0 #.most-positive-fixnum) l r))
(loop (loop while (funcall order (aref vector l) pivot)
do (incf l 1))
(loop while (funcall order pivot (aref vector r))
do (decf r 1))
(when (>= l r)
(return))
(rotatef (aref vector l) (aref vector r))
(dolist (v vectors)
(rotatef (aref v l) (aref v r)))
(incf l 1)
(decf r 1))
(recur left (- l 1))
(recur (+ r 1) right)))))
(recur 0 (- (length vector) 1))
vector))
#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(locally (declare (sb-ext:muffle-conditions warning))
(sb-c:define-source-transform parallel-sort! (vector order &rest vectors)
(let ((vec (gensym))
(vecs (loop for _ in vectors collect (gensym))))
`(let ((,vec ,vector)
,@(loop for v in vectors
for sym in vecs
collect `(,sym ,v)))
(labels
((recur (left right)
(when (< left right)
(let* ((l left)
(r right)
(pivot (%median3 (aref ,vec l)
(aref ,vec (ash (+ l r) -1))
(aref ,vec r)
,order)))
(declare ((integer 0 #.most-positive-fixnum) l r))
(loop (loop while (funcall ,order (aref ,vec l) pivot)
do (incf l 1))
(loop while (funcall ,order pivot (aref ,vec r))
do (decf r 1))
(when (>= l r)
(return))
(rotatef (aref ,vec l) (aref ,vec r))
,@(loop for sym in vecs
collect `(rotatef (aref ,sym l) (aref ,sym r)))
(incf l 1)
(decf r 1))
(recur left (- l 1))
(recur (+ r 1) right)))))
(recur 0 (- (length ,vec) 1))
,vec))))))
;; BEGIN_USE_PACKAGE
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cp/parallel-sort :cl-user))
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cp/disjoint-set :cl-user))
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cp/read-fixnum :cl-user))
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cp/mod-operations :cl-user))
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cp/mod-power :cl-user))
(eval-when (:compile-toplevel :load-toplevel :execute)
(use-package :cp/boruvka :cl-user))
(in-package :cl-user)
;;;
;;; Body
;;;
(define-mod-operations +mod+)
(defun main ()
(let* ((n (read))
(m (read))
(x (read))
(us (make-array m :element-type 'uint31 :initial-element 0))
(vs (make-array m :element-type 'uint31 :initial-element 0))
(zs (make-array m :element-type 'uint31 :initial-element 0))
(res 0))
(declare (uint31 n m x res))
(dotimes (i m)
(let ((x (- (read-fixnum) 1))
(y (- (read-fixnum) 1))
(z (read-fixnum)))
(setf (aref us i) x
(aref vs i) y
(aref zs i) z)))
(parallel-sort! zs #'< us vs)
(let ((dset (make-disjoint-set n))
(graph (make-array n :element-type 'list :initial-element nil))
(sizes (make-array n :element-type 'uint31 :initial-element 0)))
(loop for u across us
for v across vs
for z across zs
for cost = (mod-power x z +mod+)
when (ds-unite! dset u v)
do (push (cons u cost) (aref graph v))
(push (cons v cost) (aref graph u)))
(sb-int:named-let dfs ((v 0) (parent -1))
(let ((value 1))
(loop for (child . cost) in (aref graph v)
unless (= child parent)
do (dfs child v)
(incf value (aref sizes child)))
(setf (aref sizes v) value)))
#>sizes
(sb-int:named-let dfs ((v 0) (parent -1))
(loop for (child . cost) of-type (uint31 . uint31) in (aref graph v)
for size1 = (aref sizes child)
for size2 of-type uint31 = (- n size1)
unless (= child parent)
do (incfmod res (mod* cost size1 size2))
(dfs child v))))
(println res)))
#-swank (main)
;;;
;;; Test and benchmark
;;;
#+swank
(defun get-clipbrd ()
(with-output-to-string (out)
#+os-windows (run-program "powershell.exe" '("-Command" "Get-Clipboard") :output out :search t)
#+os-unix (run-program "xsel" '("-b" "-o") :output out :search t)))
#+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* (or out (make-string-output-stream)))
(res (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))))))
(if out res (get-output-stream-string *standard-output*))))
#+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)))
;; To run: (5am:run! :sample)
#+swank
(it.bese.fiveam:test :sample
(it.bese.fiveam:is
(equal "8
"
(run "3 2 3
1 2 0
2 3 1
" nil)))
(it.bese.fiveam:is
(equal "2660500
"
(run "5 5 5
1 4 3
2 4 4
3 5 7
2 3 8
2 3 10
" nil)))
(it.bese.fiveam:is
(equal "524978526
"
(run "6 8 1000000
2 6 10
3 5 11
4 6 23
1 3 26
1 6 30
5 6 48
3 5 88
3 6 100
" nil))))