結果
| 問題 |
No.5007 Steiner Space Travel
|
| コンテスト | |
| ユーザー |
 motoshira
|
| 提出日時 | 2023-04-24 23:02:49 |
| 言語 | Common Lisp (sbcl 2.5.0) |
| 結果 |
AC
|
| 実行時間 | 414 ms / 1,000 ms |
| コード長 | 19,338 bytes |
| コンパイル時間 | 1,253 ms |
| コンパイル使用メモリ | 63,980 KB |
| 実行使用メモリ | 84,128 KB |
| スコア | 4,855,783 |
| 最終ジャッジ日時 | 2023-04-24 23:03:06 |
| 合計ジャッジ時間 | 16,269 ms |
|
ジャッジサーバーID （参考情報） |
judge14 / judge12 |
| 純コード判定しない問題か言語 |
（要ログイン）
| ファイルパターン | 結果 |
|---|---|
| other | AC * 30 |
コンパイルメッセージ
; compiling file "/home/judge/data/code/Main.lisp" (written 24 APR 2023 11:02:49 PM): ; 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))
(defconstant +grid-size+ 10)
(defconstant +dp-array-size+ (/ +space-size+ +grid-size+))
(defstruct (dp-node (:conc-name %))
(cost nil :type fixnum)
;; ステーションを今までどこに置いたか
(stations nil :type list))
(defun %update (node new-node)
(if (null node)
new-node
(if (< (%cost new-node)
(%cost node))
new-node
node)))
(define-modify-macro update! (new-node) %update)
#+nil (* 8 100 100 100)
(defun %get-next-cost (node planets new-station)
;; 新しくstationを置く→付近の惑星からみた最小距離が縮まる
(declare (planets planets)
(values fixnum)
(optimize (speed 3) #-swank (safety 0)))
(loop for planet of-type fixnum across planets
with res of-type fixnum = 0
do (incf res (the fixnum
(loop for st of-type fixnum in (cons new-station (%stations node))
minimize (squared-euclid-distance planet st))))
finally (return res)))
(defun get-best-station-positions-with-dp (planets)
;; 100x100に区切ってDPする
;; dp[xx][used-station-cnt]
(let ((dp (make-array (list (1+ +dp-array-size+) (1+ +station-amount+))
:element-type t
:initial-element nil)))
(setf (aref dp 0 0) (make-dp-node :cost 0 :stations nil))
(dotimes (yy +dp-array-size+)
(let ((y (* yy +grid-size+)))
(dotimes (used-cnt (1+ +station-amount+))
(let ((node (aref dp yy used-cnt)))
(when node
;; 使わない
(setf (aref dp (1+ yy) used-cnt)
(update! (aref dp (1+ yy) used-cnt)
node))
;; 1つ使う
(when (< used-cnt +station-amount+)
(loop for x below +space-size+ by +grid-size+ do
(let* ((new-station (make-coord y x))
(new-node (make-dp-node :cost (%get-next-cost node planets new-station)
:stations (cons new-station (%stations node)))))
(update! (aref dp (1+ yy) (1+ used-cnt))
new-node)))))))))
(let ((best-node (aref dp +dp-array-size+ +station-amount+)))
(values (coerce (reverse (%stations best-node)) 'stations)
(%cost best-node)))))
#+nil
(defun make-station-coords (planets)
;; TODO いい感じの場所に置く
(declare (ignore planets))
(let ((res (make-array +station-amount+ :element-type 'coord)))
(dotimes (i +station-amount+)
(setf (aref res i)
(make-coord (random 1001) (random 1001))))
res))
(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
(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))) )))
#> (now new)
(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 (get-best-station-positions-with-dp 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*))))