結果
| 問題 | No.5007 Steiner Space Travel |
| ユーザー |
 motoshira
|
| 提出日時 | 2023-04-27 23:20:12 |
| 言語 | Common Lisp (sbcl 2.3.8) |
| 結果 |
AC
|
| 実行時間 | 817 ms / 1,000 ms |
| コード長 | 30,850 bytes |
| コンパイル時間 | 1,389 ms |
| コンパイル使用メモリ | 87,308 KB |
| 実行使用メモリ | 87,548 KB |
| スコア | 6,518,786 |
| 最終ジャッジ日時 | 2023-04-27 23:20:41 |
| 合計ジャッジ時間 | 28,849 ms |
|
ジャッジサーバーID （参考情報） |
judge13 / judge14 |
| 純コード判定しない問題か言語 |
（要ログイン）
テストケース
テストケース表示| 入力 | 結果 | 実行時間 実行使用メモリ |
|---|---|---|
| testcase_00 | AC | 815 ms
81,668 KB |
| testcase_01 | AC | 815 ms
81,656 KB |
| testcase_02 | AC | 814 ms
81,740 KB |
| testcase_03 | AC | 814 ms
81,652 KB |
| testcase_04 | AC | 815 ms
83,636 KB |
| testcase_05 | AC | 816 ms
81,672 KB |
| testcase_06 | AC | 814 ms
81,636 KB |
| testcase_07 | AC | 814 ms
81,752 KB |
| testcase_08 | AC | 814 ms
81,660 KB |
| testcase_09 | AC | 815 ms
81,672 KB |
| testcase_10 | AC | 814 ms
81,748 KB |
| testcase_11 | AC | 816 ms
83,700 KB |
| testcase_12 | AC | 815 ms
85,384 KB |
| testcase_13 | AC | 814 ms
81,668 KB |
| testcase_14 | AC | 816 ms
83,748 KB |
| testcase_15 | AC | 814 ms
81,784 KB |
| testcase_16 | AC | 815 ms
81,732 KB |
| testcase_17 | AC | 816 ms
85,520 KB |
| testcase_18 | AC | 815 ms
83,708 KB |
| testcase_19 | AC | 817 ms
87,548 KB |
| testcase_20 | AC | 815 ms
81,732 KB |
| testcase_21 | AC | 815 ms
81,660 KB |
| testcase_22 | AC | 815 ms
81,640 KB |
| testcase_23 | AC | 816 ms
83,660 KB |
| testcase_24 | AC | 814 ms
81,748 KB |
| testcase_25 | AC | 815 ms
85,524 KB |
| testcase_26 | AC | 816 ms
81,676 KB |
| testcase_27 | AC | 815 ms
83,672 KB |
| testcase_28 | AC | 814 ms
81,664 KB |
| testcase_29 | AC | 815 ms
81,800 KB |
コンパイルメッセージ
; compiling file "/home/judge/data/code/Main.lisp" (written 27 APR 2023 11:20:12 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 (ql:quickload :rove :silent t)
#-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 (cost-diff temp)
(rough-exp (/ cost-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 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)
(let ((o (%truncate-id o)))
(if (< o +planet-amount+)
(values 1 o)
(values 2 (- o +planet-amount+))))
(format t "~a ~a~%" type (1+ id)))))))
(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)))
;; hc neighbor/kick impl
(defgeneric emit-change (state neighbor))
(defgeneric force-apply-p (state neighbor))
(defgeneric get-select-rate (state neighbor)
(:documentation "TODO 選択する割合 stateに応じて変化させたい(一定ターンおきなど)"))
;; hc state interfaces
(defgeneric estimate-cost (state change))
(defgeneric apply-change! (state change))
(defgeneric save-current-state! (state)
(:documentation "reset-state!するとその時点まで巻き戻る"))
(defgeneric reset-state! (state))
;; strategy interfaces
(defgeneric terminate (state strategy))
(defgeneric get-neighbors (state strategy))
(defgeneric need-reset-p (state strategy))
(defgeneric on-ending-turn (state strategy))
(defun %rand-nth (xs)
(nth (random (length xs)) xs))
(defun hill-climbing! (state strategy)
(loop named hc do
(when (terminate state strategy)
(return-from hc))
(let ((neighbors (get-neighbors state strategy)))
(when neighbors
(let* ((neighbor (%rand-nth neighbors))
(change (emit-change state neighbor)))
(when change
;; kickであるか、コストが下がるなら採用する
(when (or (force-apply-p state neighbor)
(< (estimate-cost state change)
(st-cost state)))
(apply-change! state change)))))
(on-ending-turn state strategy))))
;; state impl
(defconstant +max-ordres-size+ (* 1 +all-amount+))
(defstruct (state (:conc-name st-))
(time nil :type double-float)
(turn nil :type (integer 0 #.most-positive-fixnum))
(cost nil :type fixnum)
(stations nil :type stations)
;; 各座標ごとに3つずつ入っている
;; 最初と最後の惑星1は含まない
(orders nil :type (simple-array (unsigned-byte 16) (*)))
(timer nil :type function :read-only t)
(planets nil :type planets :read-only t)
(orders-by-station-id (make-hash-table) :type hash-table)
(old-state nil :type (or null state)))
(defun %planet-id-p (id)
(< id +planet-amount+))
(defun %truncate-id (id)
(rem id +all-amount+))
(defun %get-id-by-order (state order)
(aref (st-orders state) order))
(defun get-coord (state order)
(let ((id (%truncate-id (%get-id-by-order state order))))
(if (%planet-id-p id)
(aref (st-planets state) id)
(aref (st-stations state) (- id +planet-amount+)))))
(defun %treat-cost (update state order)
(let* ((now (get-coord state order))
(prev (get-coord state (1- order)))
(next (get-coord state (1+ order)))
(planet? (%planet-id-p (%truncate-id (%get-id-by-order state order))))
(prev-planet? (%planet-id-p (%truncate-id (%get-id-by-order state (1- order)))))
(next-planet? (%planet-id-p (%truncate-id (%get-id-by-order state (1+ order))))))
;; 前後との関係
(funcall update
(+ (* (squared-euclid-distance prev now)
(if planet?
+alpha+
1)
(if prev-planet?
+alpha+
1))
(* (squared-euclid-distance now next)
(if planet?
+alpha+
1)
(if next-planet?
+alpha+
1))))))
(defun %treat-cost-on-order-removal! (state order)
(%treat-cost
(lambda (s)
#>s
(decf (st-cost state)
s))
state
order))
(defun %treat-cost-on-order-addition! (state order)
(%treat-cost
(lambda (s)
#>s
(incf (st-cost state)
s))
state
order))
(defun move-station! (state id new-coord)
(let* ((truncated-id (%truncate-id id))
(orders (gethash truncated-id (st-orders-by-station-id state)))
(current-coord (aref (st-stations state) (- truncated-id +planet-amount+)))
(orders-new (cons new-coord
(remove current-coord orders :count 1))))
;; idは変化しない
(setf (aref (st-stations state) (- truncated-id +planet-amount+)) new-coord
(gethash truncated-id (st-orders-by-station-id state)) orders-new)))
(defun swap-orders! (state o1 o2)
(let ((id1 (aref (st-orders state) o1))
(id2 (aref (st-orders state) o2)))
(unless (%planet-id-p id1)
(setf (gethash id1 (st-orders-by-station-id state))
(cons o2 (remove o1 (gethash id1 (st-orders-by-station-id state)) :count 1))))
(unless (%planet-id-p id2)
(setf (gethash id2 (st-orders-by-station-id state))
(cons o1 (remove o2 (gethash id2 (st-orders-by-station-id state)) :count 1))))
(rotatef (aref (st-orders state) o1)
(aref (st-orders state) o2))))
(defun orders-size (state)
(length (st-orders state)))
(defun eval-state (state)
(loop for planet across (st-planets state)
sum (loop for st across (st-stations state)
minimize (squared-euclid-distance planet st))))
(defun %clone-table (table)
(let ((res (make-hash-table :test (hash-table-test table)
:size (hash-table-size table))))
(maphash (lambda (key val)
(setf (gethash key res) val))
table)
res))
(defmethod save-current-state! ((state state))
(setf (st-old-state state)
(make-state :time (st-time state)
:turn (st-turn state)
:cost (st-cost state)
:stations (copy-seq (st-stations state))
:orders (copy-seq (st-orders state))
:orders-by-station-id (%clone-table (st-orders-by-station-id state))
:timer (st-timer state)
:planets (st-planets state))))
(defmethod reset-state! ((state state))
(let ((old-state (st-old-state state)))
(assert old-state)
(setf (st-stations state) (st-stations old-state)
(st-orders state) (st-orders old-state)
(st-cost state) (st-cost old-state)
(st-orders-by-station-id state) (st-orders-by-station-id old-state)
(st-old-state state) nil)))
(defstruct (change (:constructor nil)))
;; ステーションの場所を少し変える
;; TODO 差分計算できるような近傍じゃないとだめそう 多分周辺200マスくらいまでで十分
;; TODO 付近に限定することで近傍として扱えそう (kickはkickで残していい)
(defstruct (neighbor (:constructor nil)))
(defstruct (change-station-position (:include neighbor)
(:conc-name csp-)))
(defstruct (change-station-position-event (:include change)
(:conc-name cspe-))
(station-ids nil :type (simple-array fixnum (*)))
(cs nil :type (simple-array coord (*))))
(defmethod force-apply-p ((state state) (csp change-station-position))
nil)
(defmethod estimate-cost ((state state) (cspe change-station-position-event))
;; TODO
(+ (st-cost state)
(loop for s-id across (cspe-station-ids cspe)
for new across (cspe-cs cspe)
for orders = (gethash s-id (st-orders-by-station-id state))
for current = (aref (st-stations state) (- s-id +planet-amount+))
sum (loop for order in orders
for c = (get-coord state order)
sum (- (squared-euclid-distance new c)
(squared-euclid-distance current c))))))
(defun %rand (min max)
#+swank (assert (<= min max))
(+ min (random (1+ (- max min)))))
(defun %normalize (x min max)
(assert (<= min max))
(max (min x max) min))
#+nil (%normalize -30 -20 20)
#+nil (%normalize -10 -20 20)
#+nil (%normalize 20 -20 20)
#+nil (%normalize 30 -20 20)
#+nil (%normalize 30 20 -20)
(defmethod emit-change ((state state) (csp change-station-position))
(let* ((amount (1+ (random 3)))
(station-ids (make-array amount :element-type 'fixnum :initial-element -1))
(cs (make-array amount :element-type 'coord)))
(dotimes (i amount)
(let* ((station-id-offset (loop for id-offset = (random +station-amount+)
unless (find (+ id-offset +planet-amount+) station-ids)
return id-offset))
(station-id (+ +planet-amount+ station-id-offset))
(c (aref (st-stations state) station-id-offset))
(dy (%normalize (%rand -20 20)
(- (y c))
(- +space-size+ (y c))))
(dx (%normalize (%rand -20 20)
(- (x c))
(- +space-size+ (x c))))
(nc (make-coord (+ (y c) dy)
(+ (x c) dx))))
(setf (aref station-ids i) station-id
(aref cs i) nc)))
(make-change-station-position-event :station-ids station-ids
:cs cs)))
(defun %apply-cspe (state cspe)
(loop for s-id across (cspe-station-ids cspe)
for nc across (cspe-cs cspe)
for station-id-offset = (- s-id +planet-amount+)
do (setf (aref (st-stations state) station-id-offset) nc)))
#+nil
(defun %undo-cspe (state cspe)
(flet ((%update (s-id dy dx)
(let* ((station-id-offset (- s-id +planet-amount+))
(c (aref (st-stations state) station-id-offset))
(ny (- (y c) dy))
(nx (- (x c) dx)))
(setf (aref (st-stations state) station-id-offset)
(make-coord ny nx)))))
(declare (inline %update))
(loop for s-id across (cspe-station-ids cspe)
for dy across (cspe-dys cspe)
for dx across (cspe-dxs cspe)
do (%update s-id dy dx))))
(defmethod apply-change! ((state state) (cspe change-station-position-event))
(%apply-cspe state cspe))
;; 2-opt
(defstruct (two-opt (:conc-name to-)
(:include neighbor))
"orderをswapする")
(defstruct (two-opt-change (:conc-name toc-)
(:include change))
(order1 nil :type fixnum)
(order2 nil :type fixnum))
(defmethod force-apply-p ((state state) (to two-opt))
nil)
(defmethod emit-change ((state state) (two-opt two-opt))
(let ((size (orders-size state)))
(loop
(let ((id1 (1+ (random (- size 2))))
(id2 (1+ (random (- size 2)))))
(unless (= id1 id2)
(let ((obj-id1 (aref (st-orders state) id1))
(obj-id2 (aref (st-orders state) id2)))
(unless (= (%truncate-id obj-id1)
(%truncate-id obj-id2))
(return
(make-two-opt-change :order1 id1
:order2 id2)))))))))
(defmethod estimate-cost ((state state) (toc two-opt-change))
(with-accessors ((id1 toc-order1)
(id2 toc-order2)) toc
(let* ((from1 (get-coord state id1))
(to1 (get-coord state (1+ id1)))
(from2 (get-coord state id2))
(to2 (get-coord state (1+ id2))))
(+ (st-cost state)
(- (+ (squared-euclid-distance from1 from2)
(squared-euclid-distance to2 to1))
(+ (squared-euclid-distance from1 to1)
(squared-euclid-distance from2 to2)))))))
(defmethod apply-change! ((state state) (toc two-opt-change))
;; 内側はすべて反転
(let* ((min (min (toc-order1 toc) (toc-order2 toc)))
(max (max (toc-order1 toc) (toc-order2 toc)))
(mid (floor (+ min max) 2)))
(loop for u from (1+ min) to mid
for v downfrom max
when (< u v)
do (swap-orders! state u v))
(setf (st-cost state)
(estimate-cost state toc))))
;; four-bridges
(defstruct (four-bridge (:conc-name fb-)
(:include neighbor)))
(defstruct (four-bridge-change (:conc-name fbc-)
(:include change))
(indexes nil :type (simple-array fixnum 1)))
(defmethod force-apply-p ((state state) (_ four-bridge))
t)
(defmethod emit-change ((state state) (_ four-bridge))
(let ((size (orders-size state)))
(loop
(let ((xs (sort (coerce (loop repeat 4 collect (1+ (random (- size 3))))
'(simple-array fixnum 1))
#'<)))
(when (equalp (remove-duplicates xs)
xs)
(return
(make-four-bridge-change
:indexes xs)))))))
(eval-always
(sb-int:defconstant-eqx +four-bridge-indexes+
'(0 5 6 3 4 1 2 7)
#'equalp))
(eval-always
(defun %get-swap-indexes (xs)
(let* ((xs (copy-seq xs))
(res nil)
(n (length xs)))
(dotimes (i (1- n))
(let ((j (position i xs)))
(assert (<= i j))
(loop for k downfrom (1- j) to i
do (push k res)
do (rotatef (nth k xs) (nth (1+ k) xs)))))
res)))
#+nil
(defmacro %expand-into-swap (state)
(let ((order (gensym)))
`(progn
,@ (loop for i in (%get-swap-indexes +four-bridge-indexes+)
collect `(let ((,order (+ ,start ,i)))
(declare (fixnum ,order))
(swap-orders! ,state ,order (the fixnum (1+ ,order))))))))
(defun %get-indexes (xs)
(coerce
(apply
#'append
(map 'list
(lambda (x)
(list x (1+ x)))
xs))
'(simple-array fixnum 1)))
(defmethod apply-change! ((state state) (fbc four-bridge-change))
;; 内側はすべて反転
(let ((xs (%get-indexes (fbc-indexes fbc))))
(dolist (i '#.(%get-swap-indexes +four-bridge-indexes+))
(swap-orders! state
(aref xs i)
(aref xs (1+ i))))))
;; strategy impl
(defstruct (strategy (:conc-name str-)
(:constructor nil))
(neighbors nil :type list)
(kicks nil :type list))
(defstruct (by-count-strategy (:conc-name bcs-)
(:include strategy))
(cnt nil :type fixnum))
(defstruct (by-time-strategy (:conc-name bts-)
(:include strategy))
(time-limit nil :type double-float))
(defmethod get-neighbors ((state state) (strategy strategy))
;; TODO 選択確率を変えられるといいかも
(cond
((zerop (rem (+ (st-turn state) 10) 32))
(str-kicks strategy))
(t
(str-neighbors strategy))))
(defun %need-reset-p (state)
(and (st-old-state state)
(zerop (rem (st-turn state) 512))
(> (st-cost state) (st-cost (st-old-state state)))))
(defmethod on-ending-turn ((state state) (_ strategy))
(incf (st-turn state))
(when (zerop (rem (st-turn state) 128))
(setf (st-time state) (funcall (st-timer state)))
#+nil
(cond
((%need-reset-p state)
#>:reset
(reset-state! state))
(t
(save-current-state! state)))))
(defmethod terminate ((state state) (bcs by-count-strategy))
(>= (st-turn state) (bcs-cnt bcs)))
(defmethod terminate ((state state) (bts by-time-strategy))
(>= (st-time state) (bts-time-limit bts)))
;;;
(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))
#+nil
(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)))
(defun make-init-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 %make-orders-by-station-id (orders)
(let ((res (make-hash-table)))
(dotimes (i (length orders))
(let ((id (aref orders i)))
(unless (%planet-id-p (%truncate-id id))
(push i (gethash id res)))))
res))
(defun main ()
(let* ((start (get-internal-real-time))
(planets (read-planets))
(stations (make-init-station-coords planets))
(orders (coerce (append (list 0)
(loop for i below 100
append (loop repeat 1 collect i))
(loop for i from 100 below 108
append (loop repeat 8 collect i))
(list 0))
'(simple-array (unsigned-byte 16) (*))))
(state (make-state :time 0.0d0
:turn 0
:cost 0
:timer (lambda ()
(float
(/ (- (get-internal-real-time)
start)
#.internal-time-units-per-second)
0d0))
;; :old-state nil
:stations stations
:planets planets
:orders orders
:orders-by-station-id (%make-orders-by-station-id orders)))
(strategy #+swank (make-by-count-strategy :neighbors (list (make-two-opt)
(make-change-station-position))
:kicks (list #+nil (make-four-bridge))
:cnt 100000)
#-swank (make-by-time-strategy :neighbors (list (make-two-opt)
(make-change-station-position))
:kicks (list #+nil (make-four-bridge))
:time-limit 0.8d0)))
(setf (st-cost state) (eval-state state))
(hill-climbing! state strategy)
(print-ans (st-stations state)
(map 'orders #f(rem % +all-amount+) (st-orders state)))))
#-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*))))