結果
問題 | No.5007 Steiner Space Travel |
ユーザー | motoshira |
提出日時 | 2023-04-25 00:16:19 |
言語 | Common Lisp (sbcl 2.3.8) |
結果 |
AC
|
実行時間 | 412 ms / 1,000 ms |
コード長 | 18,769 bytes |
コンパイル時間 | 712 ms |
コンパイル使用メモリ | 64,280 KB |
実行使用メモリ | 86,032 KB |
スコア | 5,514,671 |
最終ジャッジ日時 | 2023-04-25 00:16:35 |
合計ジャッジ時間 | 15,204 ms |
ジャッジサーバーID (参考情報) |
judge11 / judge13 |
純コード判定しない問題か言語 |
(要ログイン)
テストケース
テストケース表示入力 | 結果 | 実行時間 実行使用メモリ |
---|---|---|
testcase_00 | AC | 410 ms
80,308 KB |
testcase_01 | AC | 410 ms
80,252 KB |
testcase_02 | AC | 410 ms
78,380 KB |
testcase_03 | AC | 410 ms
80,300 KB |
testcase_04 | AC | 411 ms
82,284 KB |
testcase_05 | AC | 411 ms
80,244 KB |
testcase_06 | AC | 411 ms
78,424 KB |
testcase_07 | AC | 410 ms
80,232 KB |
testcase_08 | AC | 410 ms
80,260 KB |
testcase_09 | AC | 410 ms
78,312 KB |
testcase_10 | AC | 410 ms
80,352 KB |
testcase_11 | AC | 410 ms
80,224 KB |
testcase_12 | AC | 410 ms
80,272 KB |
testcase_13 | AC | 410 ms
80,336 KB |
testcase_14 | AC | 410 ms
80,324 KB |
testcase_15 | AC | 412 ms
82,288 KB |
testcase_16 | AC | 411 ms
78,304 KB |
testcase_17 | AC | 410 ms
78,272 KB |
testcase_18 | AC | 411 ms
82,320 KB |
testcase_19 | AC | 410 ms
80,324 KB |
testcase_20 | AC | 411 ms
82,328 KB |
testcase_21 | AC | 410 ms
80,244 KB |
testcase_22 | AC | 410 ms
80,344 KB |
testcase_23 | AC | 411 ms
82,260 KB |
testcase_24 | AC | 410 ms
78,304 KB |
testcase_25 | AC | 412 ms
86,032 KB |
testcase_26 | AC | 411 ms
82,136 KB |
testcase_27 | AC | 411 ms
82,272 KB |
testcase_28 | AC | 411 ms
80,352 KB |
testcase_29 | AC | 411 ms
84,020 KB |
コンパイルメッセージ
; compiling file "/home/judge/data/code/Main.lisp" (written 25 APR 2023 12:16:19 AM): ; processing (IN-PACKAGE #:CL-USER) ; processing (DECLAIM (OPTIMIZE # ...)) ; processing (DECLAIM (MUFFLE-CONDITIONS COMPILER-NOTE)) ; processing (DISABLE-DEBUGGER) ; processing (SET-DISPATCH-MACRO-CHARACTER #\# ...) ; processing (SET-DISPATCH-MACRO-CHARACTER #\# ...) ; processing (DEFPACKAGE CP-LIBRARY/SIMULATED-ANNEALING-TOOLS ...) ; processing (IN-PACKAGE SA-TOOLS) ; processing (DECLAIM (INLINE RANDOM-PROB)) ; processing (DEFUN RANDOM-PROB ...) ; processing (DECLAIM (INLINE ROUGH-EXP)) ; processing (DEFUN ROUGH-EXP ...) ; processing (DECLAIM (INLINE GET-TEMP)) ; processing (DEFUN GET-TEMP ...) ; processing (DECLAIM (INLINE GET-PROB)) ; processing (DEFUN GET-PROB ...) ; processing (DEFMACRO WITH-TIMER ...) ; processing (DEFPACKAGE RANDOMIZED-HEAP ...) ; processing (IN-PACKAGE #:RANDOMIZED-HEAP) ; processing (DEFVAR *OPT* ...) ; processing (DECLAIM (INLINE %MAKE-NODE ...)) ; processing (DEFSTRUCT (NODE # ...) ...) ; processing (DEFSTRUCT (RANDOMIZED-HEAP #) ...) ; processing (DEFUN COUNT ...) ; processing (DECLAIM (INLINE %DIRECTION)) ; processing (DEFUN %DIRECTION ...) ; processing (DEFUN MELD ...) ; processing (DECLAIM (INLINE PEAK)) ; processing (DEFUN PEAK ...) ; processing (DEFUN EMPTY-P ...) ; processing (DECLAIM (INLINE POP! ...)) ; processing (DEFUN POP! ...) ; processing (DEFUN PUSH! ...) ; processing (DEFMACRO DO-ALL-KVS ...) ; processing (DEFUN PRUNE! ...) ; processing (IN-PACKAGE #:CL-USER) ; processing (DEFMACRO AWHEN ...) ; processing (DEFMACRO WHILE ...) ; processing (DEFMACRO EVAL-ALWAYS ...) ; processing (IN-PACKAGE #:CL-USER) ; processing (DEFMACRO %EXPANDER-BODY ...) ; processing (DEFMACRO DEFINE-ECASE-EXPANDER ...) ; processing (EVAL-ALWAYS (DEFCONSTANT +SPACE-SIZE+ ...) ...) ; processing (DEFTYPE COORD ...) ; processing (DECLAIM (INLINE Y ...)) ; processing (DEFUN MAKE-COORD ...) ; processing (DEFUN Y ...) ; processing (DEFUN X ...) ; processing (DECLAIM (INLI
ソースコード
(in-package #:cl-user) ;;; ;;; Init ;;; (eval-when (:compile-toplevel :load-toplevel :execute) ;; #+swank (declaim (optimize (speed 3) (safety 2))) #+swank (declaim (optimize (speed 0) (safety 3) (debug 3))) #-swank (declaim (optimize (speed 3) (safety 0) (debug 0))) #-swank (declaim (sb-ext:muffle-conditions sb-ext:compiler-note)) #-swank (sb-ext:disable-debugger)) ;;; ;;; Reader Macros ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (set-dispatch-macro-character #\# #\f #'(lambda (stream c2 n) (declare (ignore c2 n)) (let ((form (read stream t nil t))) `(lambda (&optional %) (declare (ignorable %)) ,form)))) (set-dispatch-macro-character #\# #\> #'(lambda (stream c2 n) (declare (ignore c2 n)) (let ((form (read stream t nil t))) (declare (ignorable form)) #-swank nil #+swank (if (atom form) `(format *error-output* "~a => ~a~&" ',form ,form) `(format *error-output* "~a => ~a~&" ',form `(,,@form))))))) ;;; ;;; Libraries ;;; ;;; ;;; BOF ;;; ;; sa ;; https://ja.wikipedia.org/wiki/%E7%84%BC%E3%81%8D%E3%81%AA%E3%81%BE%E3%81%97%E6%B3%95?action=edit (defpackage cp-library/simulated-annealing-tools (:use #:cl) (:nicknames #:sa-tools) (:export #:random-prob #:get-temp #:get-prob #:rough-exp #:with-timer)) (in-package sa-tools) (declaim (inline random-prob)) (defun random-prob (x) (declare (double-float x)) (< (random 1.0d0) x)) (declaim (inline rough-exp)) (defun rough-exp (x) (declare (double-float x)) (macrolet ((%n-th (n) `(/ (* ,@(loop :repeat n :collect 'x)) ,(loop :for m :from 1 :to n :collect m :into tmp :finally (return (float (reduce #'* tmp) 0d0)))))) (max 0.01d0 (+ 1d0 (%n-th 1) (%n-th 2) (%n-th 3))))) (declaim (inline get-temp)) (defun get-temp (start-temp end-temp current-time end-time) (+ start-temp (* (- end-temp start-temp) (/ current-time end-time)))) (declaim (inline get-prob)) (defun get-prob (score-diff temp) (rough-exp (/ score-diff temp))) (defmacro with-timer (get-time &body body) (let ((init (gensym))) `(let ((,init (get-internal-real-time))) (flet ((,get-time () (/ (float (- (get-internal-real-time) ,init)) #.(float internal-time-units-per-second)))) (declare (inline ,get-time) (dynamic-extent #',get-time)) ,@body)))) ;;; ;;; EOF ;;; ;;; ;;; BOF ;;; (defpackage randomized-heap (:use #:cl) (:nicknames #:rh) (:shadow #:count) (:export #:make-randomized-heap #:empty-p #:push! #:pop! #:peak #:count #:do-all-kvs #:prune!)) (in-package #:randomized-heap) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *OPT* #+swank '(optimize (speed 3) (safety 2) (debug 3)) #-swank '(optimize (speed 3) (safety 0) (debug 0)))) (declaim (inline %make-node make-randomized-heap)) (defstruct (node (:constructor %make-node) (:conc-name %n-)) (key nil :type fixnum) (value nil :type t) (children (make-array 2 :element-type '(or null node) :initial-element nil) :type (simple-array (or null node) (2)))) (defstruct (randomized-heap (:constructor make-randomized-heap (&optional (compare #'sb-impl::two-arg-<) (key-fn #'identity)))) (root nil :type (or null node)) (count 0 :type (integer 0 #.most-positive-fixnum)) (comparator compare :type (function (fixnum fixnum) boolean)) (key-fn key-fn :type (function (t) fixnum))) (defun count (heap) (randomized-heap-count heap)) (declaim (inline %direction)) (defun %direction () (declare #.*OPT*) (random 2)) (defun meld (l r comparator) (declare #.*OPT* ((or null node) l r) ((function (fixnum fixnum) boolean) comparator)) (cond ((or (null l) (null r)) (or l r)) ((funcall comparator (%n-key l) (%n-key r)) ;; l is root (let ((dir (%direction))) (setf (aref (%n-children l) dir) (meld (aref (%n-children l) dir) r comparator)) l)) (t ;; r is root (let ((dir (%direction))) (setf (aref (%n-children r) dir) (meld l (aref (%n-children r) dir) comparator)) r)))) (declaim (inline peak)) (defun peak (heap) (declare #.*OPT*) (let ((root (randomized-heap-root heap))) (values (%n-value root) (%n-key root)))) (defun empty-p (heap) (null (randomized-heap-root heap))) (declaim (inline pop! push!)) (defun pop! (heap) (declare #.*OPT*) (when (empty-p heap) (error "heap is empty")) (decf (randomized-heap-count heap)) (multiple-value-bind (value key) (peak heap) (let* ((children (%n-children (randomized-heap-root heap))) (l (aref children 0)) (r (aref children 1))) (setf (randomized-heap-root heap) (meld l r (randomized-heap-comparator heap))) (values value key)))) (defun push! (heap value) (declare #.*OPT*) (let ((key (funcall (randomized-heap-key-fn heap) value))) (incf (randomized-heap-count heap)) (setf (randomized-heap-root heap) (meld (randomized-heap-root heap) (%make-node :key key :value value) (randomized-heap-comparator heap)))) heap) (defmacro do-all-kvs ((key value heap) &body body &environment env) (let ((temp (gensym))) (multiple-value-bind (args argvs res setter accessor) (get-setf-expansion heap env) `(let ((,temp (make-randomized-heap (randomized-heap-comparator ,accessor) (randomized-heap-key-fn ,accessor)))) (loop :until (empty-p ,accessor) :do (multiple-value-bind (,value ,key) (pop! ,accessor) (progn ,@body) (push! ,temp ,value))) (let* (,@(mapcar #'list args argvs) (,(car res) ,temp)) ,setter nil))))) (defun prune! (heap cnt) (let ((new-root nil) (comparator (randomized-heap-comparator heap))) (dotimes (_ cnt) (multiple-value-bind (v k) (pop! heap) (setf new-root (meld new-root (%make-node :key k :value v) comparator)))) (setf (randomized-heap-root heap) new-root))) ;;; ;;; EOF ;;; ;;; ;;; Macros ;;; (in-package #:cl-user) (defmacro awhen (test &body forms) `(let ((it ,test)) (when it ,@forms))) (defmacro while (test &body body) `(loop while ,test do (progn ,@body))) (defmacro eval-always (&body body) `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body)) ;;; ;;; Body ;;; (in-package #:cl-user) (defmacro %expander-body (form cases) `(ecase ,form ,@(loop for (from . to) in cases collect `(,from ,to)))) (defmacro define-ecase-expander (name assoc-list) `(defmacro ,name (form) `(%expander-body ,form ,',assoc-list))) (eval-always (defconstant +space-size+ 1000) (defconstant +planet-amount+ 100) (defconstant +station-amount+ 8) (defconstant +all-amount+ (+ +planet-amount+ +station-amount+)) (defconstant +alpha+ 5)) (deftype coord () '(unsigned-byte 32)) (declaim (inline y x)) (defun make-coord (y x) #+swank (assert (<= 0 y +space-size+) () "y is out of range") #+swank (assert (<= 0 x +space-size+) () "x is out of range") (dpb y '#.(byte 16 16) x)) (defun y (c) (ldb (byte 16 16) c)) (defun x (c) (ldb (byte 16 0) c)) #+nil (y (make-coord 1000 0)) #+nil (x (make-coord 0 1000)) (declaim (inline squared-euclid-distance)) (defun squared-euclid-distance (c1 c2) (let* ((dy (- (y c1) (y c2))) (dx (- (x c1) (x c2)))) (declare (fixnum dy dx)) (+ (the fixnum (* dy dy)) (the fixnum (* dx dx))))) (deftype planets () '(simple-array coord (*))) (deftype stations () '(simple-array coord (*))) (deftype orders () "planetsはid0〜99, stationsはid100〜107 最初と最後はid0でないといけない" '(simple-array fixnum (*))) (defun read-planets () (let ((n (read)) (m (read)) (planets (make-array +planet-amount+ :element-type 'coord))) (declare (ignore n m)) (dotimes (i +planet-amount+) (setf (aref planets i) (make-coord (read) (read)))) planets)) (defun %get-center-of-gravity (ps) (when (null ps) (return-from %get-center-of-gravity (make-coord (+ 400 (random 201)) (+ 400 (random 201))))) (let ((gy (floor (loop for p in ps sum (y p)) (length ps))) (gx (floor (loop for p in ps sum (x p)) (length ps)))) (make-coord gy gx))) (defun %improve-with-k-means-method (planet-group-ids planets) (let* ((stations (loop for g-id across planet-group-ids for p across planets with ps = (make-array +station-amount+ :initial-element nil) do (push p (aref ps g-id)) finally (return (map 'vector #'%get-center-of-gravity ps)))) (planet-group-ids (map 'vector (lambda (p) (loop for st across stations for i from 0 with min-d = most-positive-fixnum with res = nil for d = (squared-euclid-distance st p) when (< d min-d) do (setf res i min-d d) finally (return res))) planets))) planet-group-ids)) (defun make-station-coords (planets) (let ((planet-group-ids (make-array +planet-amount+ :initial-element nil)) (group-points (make-array +station-amount+ :initial-element nil))) (dotimes (i +planet-amount+) (setf (aref planet-group-ids i) (random +station-amount+))) (dotimes (_ 20) (setf planet-group-ids (%improve-with-k-means-method planet-group-ids planets))) (dotimes (p-id +planet-amount+) (push (aref planets p-id) (aref group-points (aref planet-group-ids p-id)))) (map 'stations #'%get-center-of-gravity group-points))) (defconstant +inf+ #.(ash 1 60)) (deftype %costs () '(simple-array fixnum (* *))) (defun %planet-id-p (id) (< id +planet-amount+)) (defun %get-nearest-costs-and-paths-from (start planets stations) ;; 惑星startから他の惑星までの移動の最小コストを求める(移動の間に他の惑星やステーションを経由してよい) ;; dijkstra法 (let ((costs (make-array +all-amount+ :element-type 'fixnum :initial-element +inf+)) (paths (make-array +all-amount+ :element-type 'list :initial-element nil)) (heap (rh:make-randomized-heap #'< #'first))) (rh:push! heap (list 0 (list start))) (while (not (rh:empty-p heap)) (destructuring-bind (cost path) (rh:pop! heap) (let ((node (first path))) (when (<= cost (aref costs node)) (setf (aref costs node) cost) (setf (aref paths node) path) (dotimes (next +all-amount+) (let* ((coord (if (%planet-id-p node) (aref planets node) (aref stations (- node +planet-amount+)))) (new-coord (if (%planet-id-p next) (aref planets next) (aref stations (- next +planet-amount+)))) (nc (+ cost (* (if (%planet-id-p node) +alpha+ 1) (if (%planet-id-p next) +alpha+ 1) (squared-euclid-distance coord new-coord))))) (when (< nc (aref costs next)) (setf (aref costs next) nc (aref paths next) (cons next path)) (rh:push! heap (list nc (cons next path)))))))))) (list costs (map 'vector #'reverse paths)))) (defun %construct-path (planet-orders paths) (let ((res (list 0)) (ps (coerce planet-orders 'list))) (loop for (from to) on ps by #'rest when to do (dolist (pos (aref (aref paths from) to)) (push pos res))) (coerce (nreverse res) 'orders))) (sb-int:defconstant-eqx +swap-vec+ #(0 5 6 3 4 1 2 7) #'equalp) (defun make-orders (planets stations time-limit) #>time-limit (let* ((start (get-internal-real-time)) (time 0d0) (time-limit (float time-limit 0d0)) (costs-and-paths-from (coerce (loop for i below +planet-amount+ collect (%get-nearest-costs-and-paths-from i planets stations)) 'vector)) (ps (make-array (1+ +planet-amount+) :element-type 'fixnum)) (current-cost 0)) (declare (fixnum current-cost)) (flet ((%get-cost (from to) (let ((cs (first (aref costs-and-paths-from from)))) (declare ((simple-array fixnum 1) cs)) (the fixnum (aref cs to))))) (declare (inline %get-cost)) ;; 最初は0 (dotimes (i +planet-amount+) (setf (aref ps i) i)) ;; 最後は0 (setf (aref ps +planet-amount+) 0) (loop for i below +planet-amount+ do (incf current-cost (%get-cost i (rem (1+ i) +planet-amount+)))) (loop for turn of-type fixnum from 0 do (when (zerop (rem turn 32)) (setf time (float (/ (- (get-internal-real-time) start) internal-time-units-per-second)))) (when (> time time-limit) #>turn (return)) (if (plusp (random 16)) ;; kick (four gridges) (let* ((i (random (- +planet-amount+ 8))) (now (loop for j below 8 collect (+ i j))) (new (map 'list #f(+ i %) +swap-vec+)) (now-indexes (subseq ps i (+ i 8))) (cost-diff (- (loop for (j k) on new by #'rest when k sum (%get-cost (aref ps j) (aref ps k))) (loop for (j k) on now by #'rest when k sum (%get-cost (aref ps j) (aref ps k))) ))) (when (minusp cost-diff) (loop for new-idx across +swap-vec+ for ii from i do (setf (aref ps ii) (aref now-indexes new-idx))) (incf current-cost cost-diff))) ;; 2-opt (let* (;; 0 〜 (n - 2) (i (random (- +planet-amount+ 1))) ;; 1 〜 (n - 1) (j (1+ (random (- +planet-amount+ 1)))) (cost-diff (- (+ (%get-cost (aref ps i) (aref ps (1+ j))) (%get-cost (aref ps j) (aref ps (1+ i)))) (+ (%get-cost (aref ps i) (aref ps (1+ i))) (%get-cost (aref ps j) (aref ps (1+ j)))))) ) (declare (fixnum i j cost-diff)) (when (minusp cost-diff) (rotatef (aref ps i) (aref ps j)) (incf current-cost))))) (%construct-path ps (map 'vector #'second costs-and-paths-from))))) (defun print-ans (stations orders) (declare (orders orders) (stations stations)) #>orders (princ (with-output-to-string (*standard-output*) ;; stations (sb-int:dovector (c stations) (format t "~a ~a~%" (y c) (x c))) (format t "~a ~%" (length orders)) ;; orders (sb-int:dovector (o orders) (multiple-value-bind (type id) (if (< o +planet-amount+) (values 1 o) (values 2 (- o +planet-amount+))) (format t "~a ~a~%" type (1+ id))))))) (defun main () (let* ((start (get-internal-real-time)) (planets (read-planets)) (stations (make-station-coords planets)) (orders (make-orders planets stations (- 0.4 (/ (- (get-internal-real-time) start) internal-time-units-per-second))))) (print-ans stations orders))) #-swank (main) ;;; ;;; Debug ;;; ;; Raise error on warning at compile time #+(and sbcl (not swank)) (eval-when (:compile-toplevel) (when (or (plusp sb-c::*compiler-warning-count*) sb-c::*undefined-warnings*) (error "compiler-error-count:~a, undefined warnings:~a" sb-c::*compiler-warning-count* sb-c::*undefined-warnings*))) #+swank (defun run-sample (infile outfile &optional (out *standard-output*) (vis t)) (let ((args (append (list "tester.dll" "judge" "-i" infile "-o" outfile) (when vis (list "-v" "vis.png"))))) (with-open-file (*standard-input* infile :direction :input) (with-open-file (*standard-output* outfile :direction :output :if-exists :supersede) (main)) (sb-ext:run-program "dotnet" args :output out :search t :error *error-output*))))