結果
| 問題 | No.5015 Escape from Labyrinth |
| ユーザー |
 motoshira
|
| 提出日時 | 2023-04-16 18:25:15 |
| 言語 | Common Lisp (sbcl 2.3.8) |
| 結果 |
RE
|
| 実行時間 | - |
| コード長 | 59,812 bytes |
| コンパイル時間 | 1,007 ms |
| コンパイル使用メモリ | 116,196 KB |
| 実行使用メモリ | 340,932 KB |
| スコア | 20,580 |
| 最終ジャッジ日時 | 2023-04-16 18:30:07 |
| 合計ジャッジ時間 | 287,734 ms |
|
ジャッジサーバーID （参考情報） |
judge12 / judge14 |
（要ログイン）
テストケース
テストケース表示| 入力 | 結果 | 実行時間 実行使用メモリ |
|---|---|---|
| testcase_00 | AC | 2,872 ms
226,112 KB |
| testcase_01 | AC | 2,932 ms
191,528 KB |
| testcase_02 | AC | 2,990 ms
295,920 KB |
| testcase_03 | AC | 2,855 ms
265,276 KB |
| testcase_04 | RE | - |
| testcase_05 | AC | 2,901 ms
304,092 KB |
| testcase_06 | AC | 2,862 ms
167,504 KB |
| testcase_07 | AC | 2,859 ms
277,448 KB |
| testcase_08 | AC | 2,983 ms
263,160 KB |
| testcase_09 | AC | 2,922 ms
203,544 KB |
| testcase_10 | AC | 2,856 ms
261,004 KB |
| testcase_11 | AC | 2,858 ms
295,808 KB |
| testcase_12 | RE | - |
| testcase_13 | RE | - |
| testcase_14 | RE | - |
| testcase_15 | RE | - |
| testcase_16 | TLE | - |
| testcase_17 | AC | 2,860 ms
223,892 KB |
| testcase_18 | AC | 2,854 ms
314,208 KB |
| testcase_19 | AC | 2,903 ms
246,688 KB |
| testcase_20 | AC | 2,860 ms
210,576 KB |
| testcase_21 | TLE | - |
| testcase_22 | AC | 2,909 ms
293,600 KB |
| testcase_23 | AC | 2,857 ms
173,024 KB |
| testcase_24 | RE | - |
| testcase_25 | AC | 2,863 ms
218,100 KB |
| testcase_26 | AC | 2,858 ms
207,868 KB |
| testcase_27 | AC | 2,890 ms
209,880 KB |
| testcase_28 | RE | - |
| testcase_29 | RE | - |
| testcase_30 | AC | 2,969 ms
265,240 KB |
| testcase_31 | RE | - |
| testcase_32 | AC | 2,899 ms
242,524 KB |
| testcase_33 | AC | 2,855 ms
275,404 KB |
| testcase_34 | AC | 2,907 ms
204,384 KB |
| testcase_35 | AC | 2,946 ms
228,356 KB |
| testcase_36 | RE | - |
| testcase_37 | AC | 2,862 ms
191,552 KB |
| testcase_38 | AC | 2,859 ms
263,084 KB |
| testcase_39 | AC | 2,989 ms
277,564 KB |
| testcase_40 | AC | 2,862 ms
340,932 KB |
| testcase_41 | RE | - |
| testcase_42 | AC | 2,871 ms
257,024 KB |
| testcase_43 | RE | - |
| testcase_44 | RE | - |
| testcase_45 | AC | 2,858 ms
211,872 KB |
| testcase_46 | AC | 2,939 ms
246,588 KB |
| testcase_47 | RE | - |
| testcase_48 | RE | - |
| testcase_49 | RE | - |
| testcase_50 | AC | 2,888 ms
191,480 KB |
| testcase_51 | AC | 2,866 ms
277,480 KB |
| testcase_52 | AC | 2,953 ms
207,844 KB |
| testcase_53 | TLE | - |
| testcase_54 | AC | 2,905 ms
220,032 KB |
| testcase_55 | AC | 2,980 ms
214,636 KB |
| testcase_56 | TLE | - |
| testcase_57 | AC | 2,871 ms
193,420 KB |
| testcase_58 | AC | 2,901 ms
187,196 KB |
| testcase_59 | AC | 2,947 ms
279,468 KB |
| testcase_60 | AC | 2,892 ms
315,232 KB |
| testcase_61 | AC | 2,857 ms
320,420 KB |
| testcase_62 | AC | 2,859 ms
211,752 KB |
| testcase_63 | AC | 2,891 ms
262,960 KB |
| testcase_64 | AC | 2,854 ms
168,888 KB |
| testcase_65 | AC | 2,864 ms
272,348 KB |
| testcase_66 | AC | 2,856 ms
277,504 KB |
| testcase_67 | TLE | - |
| testcase_68 | AC | 2,861 ms
211,852 KB |
| testcase_69 | TLE | - |
| testcase_70 | AC | 2,858 ms
289,836 KB |
| testcase_71 | RE | - |
| testcase_72 | AC | 2,857 ms
254,920 KB |
| testcase_73 | AC | 2,855 ms
298,008 KB |
| testcase_74 | TLE | - |
| testcase_75 | AC | 2,857 ms
250,760 KB |
| testcase_76 | AC | 2,869 ms
218,076 KB |
| testcase_77 | AC | 2,932 ms
316,440 KB |
| testcase_78 | AC | 2,925 ms
265,092 KB |
| testcase_79 | AC | 2,956 ms
273,264 KB |
| testcase_80 | AC | 2,958 ms
220,056 KB |
| testcase_81 | AC | 2,892 ms
271,260 KB |
| testcase_82 | AC | 2,961 ms
257,024 KB |
| testcase_83 | AC | 2,895 ms
278,400 KB |
| testcase_84 | AC | 2,896 ms
258,936 KB |
| testcase_85 | RE | - |
| testcase_86 | TLE | - |
| testcase_87 | AC | 2,998 ms
277,476 KB |
| testcase_88 | AC | 2,900 ms
316,260 KB |
| testcase_89 | AC | 2,870 ms
234,408 KB |
| testcase_90 | AC | 2,954 ms
283,400 KB |
| testcase_91 | AC | 2,854 ms
167,504 KB |
| testcase_92 | AC | 2,860 ms
198,216 KB |
| testcase_93 | AC | 2,956 ms
298,052 KB |
| testcase_94 | AC | 2,861 ms
271,388 KB |
| testcase_95 | AC | 2,855 ms
273,284 KB |
| testcase_96 | AC | 2,858 ms
297,944 KB |
| testcase_97 | AC | 2,961 ms
293,856 KB |
| testcase_98 | AC | 2,941 ms
256,668 KB |
| testcase_99 | RE | - |
コンパイルメッセージ
; compiling file "/home/judge/data/code/Main.lisp" (written 16 APR 2023 06:25:15 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/AVL-TREE ...) ; processing (IN-PACKAGE AVL) ; processing (DECLAIM (INLINE %%MAKE-NODE)) ; processing (DEFSTRUCT (NODE # ...) ...) ; processing (DEFMACRO DEFINE-ACCESSOR-FOR-NULLABLE-NODE ...) ; processing (DEFINE-ACCESSOR-FOR-NULLABLE-NODE %VALUE ...) ; processing (DEFINE-ACCESSOR-FOR-NULLABLE-NODE %KEY ...) ; processing (DEFINE-ACCESSOR-FOR-NULLABLE-NODE %CNT ...) ; processing (DEFINE-ACCESSOR-FOR-NULLABLE-NODE %HEIGHT ...) ; processing (DEFINE-ACCESSOR-FOR-NULLABLE-NODE %L ...) ; processing (DEFINE-ACCESSOR-FOR-NULLABLE-NODE %R ...) ; processing (DEFUN DUMP-TO-LIST ...) ; processing (DEFMETHOD PRINT-OBJECT ...) ; processing (DEFUN DUMP-TO-TREE ...) ; processing (DECLAIM (INLINE %MAKE-NODE)) ; processing (DEFUN %MAKE-NODE ...) ; processing (DEFUN MAKE-AVL-TREE ...) ; processing (DECLAIM (INLINE %UPDATE-NODE)) ; processing (DEFUN %UPDATE-NODE ...) ; processing (DECLAIM (INLINE %ROTATE-LEFT)) ; processing (DEFUN %ROTATE-LEFT ...) ; processing (DECLAIM (INLINE %ROTATE-RIGHT)) ; processing (DEFUN %ROTATE-RIGHT ...) ; processing (DECLAIM (INLINE %ROTATE-LR)) ; processing (DEFUN %ROTATE-LR ...) ; processing (DECLAIM (INLINE %ROTATE-RL)) ; processing (DEFUN %ROTATE-RL ...) ; processing (DEFCONSTANT +TOO-LEFT+ ...) ; processing (DEFCONSTANT +LEFT+ ...) ; processing (DEFCONSTANT +EVEN+ ...) ; processing (DEFCONSTANT +RIGHT+ ...) ; processing (DEFCONSTANT +TOO-RIGHT+ ...) ; processing (DECLAIM (INLINE %BIAS)) ; processing (DEFUN %BIAS ...) ; processing (DECLAIM (INLINE %LEFT-RIGHT-CASE-P)) ; processing (DEFUN %LEFT-RIGHT-CASE-P ...) ; processing (DECLAIM (INLINE %RIGHT-LEFT-CASE-P)) ; proces
ソースコード
(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
;;;
(defpackage cp-library/avl-tree
(:use #:cl)
(:nicknames #:avl)
(:shadow #:remove
#:count)
(:export #:make-avl-tree
#:insert
#:remove
#:insert!
#:remove!
#:count
#:dump-to-list
#:dump-to-tree
#:keys
#:vals
#:predecessor
#:successor
#:nth-element
#:compare-default
#:compare-keyword
#:ref
#:update
#:update!
#:make-avl-tree-from-list
#:rand-nth))
(in-package avl)
(declaim (inline %%make-node))
(defstruct (node (:constructor %%make-node)
(:conc-name %%))
(key nil :type t)
(value nil :type t)
(cnt nil :type fixnum)
(height nil :type fixnum)
(l nil :type (or null node))
(r nil :type (or null node)))
(defmacro define-accessor-for-nullable-node (name accessor default)
`(progn
(declaim (inline ,name))
(defun ,name (node)
(if node
(,accessor node)
,default))))
(define-accessor-for-nullable-node %value %%value nil)
(define-accessor-for-nullable-node %key %%key nil)
(define-accessor-for-nullable-node %cnt %%cnt 0)
(define-accessor-for-nullable-node %height %%height 0)
(define-accessor-for-nullable-node %l %%l nil)
(define-accessor-for-nullable-node %r %%r nil)
(defun dump-to-list (node)
(let ((res nil))
(labels ((rec (node)
(when node
(rec (%%l node))
(push (cons (%%key node)
(%%value node))
res)
(rec (%%r node)))))
(rec node)
(reverse res))))
(defmethod print-object ((node node) s)
(print-unreadable-object (node s :type t)
(dolist (kv (dump-to-list node))
(fresh-line s)
(princ kv s))
(terpri s)))
(defun dump-to-tree (node)
(labels ((rec (node)
(when node
(cl:remove nil
(list
(rec (%%l node))
(when node
(cons (%%key node)
(%%value node)))
(rec (%%r node)))))))
(rec node)))
(declaim (inline %make-node))
(defun %make-node (&key key value l r)
(declare ((or null node) l r))
(let ((height (1+ (max (%height l)
(%height r))))
(cnt (1+ (the fixnum
(+ (%cnt l)
(%cnt r))))))
(declare (fixnum height cnt))
(%%make-node :key key
:value value
:height height
:cnt cnt
:l l
:r r)))
(defun make-avl-tree ()
"Create an empty avl-tree."
nil)
;; helper functions
(declaim (inline %update-node))
(defun %update-node (node &key (key nil k-p) (value nil v-p) (l nil l-p) (r nil r-p))
(%make-node :key (if k-p
key
(%key node))
:value (if v-p
value
(%value node))
:l (if l-p
l
(%l node))
:r (if r-p
r
(%r node))))
(declaim (inline %rotate-left))
(defun %rotate-left (node)
(declare (node node)
#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
(let* ((r (%%r node))
(rl (%l r)))
(%update-node r :l (%update-node node :r rl))))
(declaim (inline %rotate-right))
(defun %rotate-right (node)
(declare (node node)
#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
(let* ((l (%%l node))
(lr (%r l)))
(%update-node l :r (%update-node node :l lr))))
(declaim (inline %rotate-lr))
(defun %rotate-lr (node)
(%rotate-right
(%update-node node
:l (%rotate-left (%%l node)))))
(declaim (inline %rotate-rl))
(defun %rotate-rl (node)
(%rotate-left
(%update-node node
:r (%rotate-right (%%r node)))))
(defconstant +too-left+ -2)
(defconstant +left+ -1)
(defconstant +even+ 0)
(defconstant +right+ 1)
(defconstant +too-right+ 2)
(declaim (inline %bias))
(defun %bias (node)
(if (null node)
0
(- (%height (%%r node))
(%height (%%l node)))))
(declaim (inline %left-right-case-p))
(defun %left-right-case-p (node)
(= (%bias (%%l node)) +right+))
(declaim (inline %right-left-case-p))
(defun %right-left-case-p (node)
(= (%bias (%%r node)) +left+))
(declaim (inline %balance))
(defun %balance (node)
(let ((b (%bias node)))
(cond
((= b +even+) (values node t))
((or (= b +left+)
(= b +right+))
(values node nil))
((<= b +too-left+)
(values (if (%left-right-case-p node)
(%rotate-lr node)
(%rotate-right node))
t))
(t
(values (if (%right-left-case-p node)
(%rotate-rl node)
(%rotate-left node))
t)))))
(defun compare-default (key node-key)
(declare (fixnum node-key key)
(optimize (speed 3) (safety 0)))
(cond
((= key node-key) :eq)
((< key node-key) :less)
(t :greater)))
(defun compare-keyword (k1 k2)
(declare (keyword k1 k2))
(let ((k1 (sb-impl::eq-hash k1))
(k2 (sb-impl::eq-hash k2)))
(cond
((< k1 k2) :less)
((= k1 k2) :eq)
(t :greater))))
(defun insert (node key value &optional (compare #'compare-default))
;; (values balanced-node need-to-balance-parents)
(declare (optimize (speed 3) (safety 0))
(function compare))
(labels ((%rec (node)
(unless node
(return-from %rec
(values (%make-node :key key
:value value)
nil)))
(ecase (funcall compare key (%%key node))
(:eq
;; 書き換えだけなのでbalanceしなくていい
(values (%update-node node :value value)
t))
(:less
(multiple-value-bind (l balanced) (%rec (%%l node))
(let ((new-node (%update-node node :l l)))
(if balanced
(values new-node t)
(%balance new-node)))))
(:greater
(multiple-value-bind (r balanced) (%rec (%%r node))
(let ((new-node (%update-node node :r r)))
(if balanced
(values new-node t)
(%balance new-node))))))))
(%rec node)))
(defun %remove-rightest (node)
;; (values new-node removed-node balanced)
(declare (optimize (speed 3) (safety 0)))
(let ((r (%%r node)))
(if (null r)
;; node = rightest
(let ((l (%%l node))
(removed (%update-node node :l nil)))
(values l removed nil))
(multiple-value-bind (new-r removed balanced) (%remove-rightest r)
(let ((new (%update-node node :r new-r)))
(if balanced
(values new removed t)
(multiple-value-bind (new balanced) (%balance new)
(values new removed balanced))))))))
(defun remove (node key &optional (compare #'compare-default))
(declare (optimize (speed 3) (safety 0))
(function compare))
(labels ((%rec (node)
(unless node
(return-from %rec (values nil nil)))
(ecase (funcall compare key (%%key node))
(:eq
(let ((l (%%l node))
(r (%%r node)))
(unless (and l r)
(return-from %rec
(if #1=(or l r)
(values #1# nil)
(values nil t))))
(multiple-value-bind (new-l removed balanced) (%remove-rightest l)
(if (null removed)
;; 変更なし
(values node t)
(let ((new-node (%make-node :key (%%key removed)
:value (%%value removed)
:l new-l
:r (%%r node))))
(if balanced
(values new-node t)
(%balance new-node)))))))
(:less
(multiple-value-bind (l balanced) (%rec (%%l node))
(let ((new-node (%update-node node :l l)))
(if balanced
(values new-node t)
(%balance new-node)))))
(:greater
(multiple-value-bind (r balanced) (%rec (%%r node))
(let ((new-node (%update-node node :r r)))
(if balanced
(values new-node t)
(%balance new-node))))))))
(%rec node)))
(define-modify-macro insert! (key value &optional (compare '(function compare-default))) insert)
(define-modify-macro remove! (key &optional (compare '(function compare-default))) remove)
(defun keys (node)
(mapcar #'car (dump-to-list node)))
(defun vals (node)
(mapcar #'cdr (dump-to-list node)))
(defun count (node)
(%cnt node))
(defun predecessor (node key &optional (compare #'compare-default))
(declare (optimize (speed 3) (safety 0))
(function compare))
(labels ((%rec (node)
(when node
(ecase (funcall compare key (%%key node))
(:greater
(or (%rec (%%r node))
node))
((:eq :less)
(%rec (%%l node)))))))
(let ((res (%rec node)))
(if res
(values (%%key res) (%%value res) t)
(values nil nil nil)))))
(defun successor (node key &optional (compare #'compare-default))
(declare (optimize (speed 3) (safety 0))
(function compare))
(labels ((%rec (node)
(when node
(ecase (funcall compare key (%%key node))
(:less
(or (%rec (%%l node))
node))
((:eq :greater)
(%rec (%%r node)))))))
(let ((res (%rec node)))
(if res
(values (%%key res) (%%value res) t)
(values nil nil nil)))))
(defun nth-element (node n)
(declare (optimize (speed 3) (safety 0))
(fixnum n))
(labels ((%rec (node k)
(declare (fixnum k))
(let ((l-cnt (%cnt (%%l node))))
(declare (fixnum l-cnt))
(cond
((< k l-cnt)
(%rec (%%l node)
k))
((= k l-cnt)
node)
(t
(%rec (%%r node)
(- k l-cnt 1)))))))
(if (<= 0 n (the fixnum (1- (the fixnum (%cnt node)))))
(let ((res (%rec node n)))
(declare (node node))
(values (%%key res) (%%value res) t))
(values nil nil nil))))
(defun rand-nth (node)
(when node
(nth-element node (random (count node)))))
(defun ref (node key &optional (compare #'compare-default))
(declare (optimize (speed 3) (safety 0))
(function compare))
(labels ((%rec (node)
(when node
(ecase (funcall compare key (%%key node))
(:eq node)
(:less (%rec (%%l node)))
(:greater (%rec (%%r node)))))))
(let ((res (%rec node)))
(if res
(values (%%key node) (%%value node) t)
(values nil nil nil)))))
(defun update (node key fn &optional (compare #'compare-default))
(let ((current (ref node key compare)))
(insert node key (funcall fn current) compare)))
(defun make-avl-tree-from-list (key-fn value-fn list &optional (compare #'compare-default))
(let ((res nil))
(dolist (x list res)
(avl:insert! res
(funcall key-fn x)
(funcall value-fn x)
compare))))
(define-modify-macro update! (key fn &optional (compare '(function compare-default))) update)
;;;
;;; 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))
#-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 do-iota ((var count &optional (start 0) (step 1)) &body body)
(check-type step integer)
(let* ((last (gensym))
(terminate (if (plusp step) `(>= ,var ,last) `(<= ,var ,last))))
`(let ((,last (+ ,start (the fixnum (* ,step ,count)))))
(declare (fixnum ,last))
(do
((,var ,start (+ ,var ,step)))
(,terminate
(progn ,@body))))))
(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))
;;;
;;; I/O
;;;
(in-package #:cl-user)
(declaim (inline println))
(defun println (obj &optional (stream *standard-output*))
#+sbcl (declare (sb-kernel:ansi-stream stream))
(let ((*read-default-float-format* 'double-float))
(prog1 obj
(princ obj stream)
(terpri stream))))
(declaim (inline %read-byte))
(defun %read-byte (&optional (stream *standard-input*))
(declare (inline read-byte)
#+(and sbcl (not swank)) (sb-kernel:ansi-stream stream))
(the fixnum #+swank (char-code (read-char stream nil #\Nul))
#-swank (read-byte stream nil #.(char-code #\Nul))))
(declaim (inline read-fixnum))
(defun read-fixnum (&optional (in *standard-input*) (byte-reader #'%read-byte))
;; Ref: https://competitive12.blogspot.com/2020/03/common-lisp.html
;; partially modified
(declare ((function (stream) (unsigned-byte 8)) byte-reader)
(optimize (speed 3) (safety 0) (debug 0)))
(let ((minus nil)
(res 0))
(declare (boolean minus)
(fixnum res))
(labels ((%byte->num (b)
(the fixnum (- (the fixnum b) #.(char-code #\0))))
(%digit-p (byte)
(<= #.(char-code #\0) (the fixnum byte) #.(char-code #\9)))
(%first-proc! ()
(loop for byte of-type fixnum = (funcall byte-reader in)
do (cond
((%digit-p byte)
(setf (the fixnum res) (%byte->num byte))
(return))
((= byte #.(char-code #\Nul))
(error "EOF"))
((= byte #.(char-code #\-))
(setf minus t)))))
(%rest-proc! ()
(loop for byte of-type fixnum = (funcall byte-reader in)
do (cond
((%digit-p byte)
(setf (the fixnum res) (the fixnum (+ (the fixnum (* res 10)) (%byte->num byte)))))
(t (return))))))
(declare (inline %byte->num %digit-p %first-proc! %rest-proc!))
(%first-proc!)
(%rest-proc!)
(the fixnum (if minus (- res) res)))))
(declaim (inline read-base-char))
(defun read-base-char (&optional (stream *standard-input*))
(code-char (%read-byte stream)))
(defun read-line-fast (&optional (stream *standard-input*))
#+(and (not swank) sbcl) (declare (sb-kernel:ansi-stream stream))
(loop with buffer of-type base-string = (make-array 0 :element-type 'base-char :fill-pointer 0)
for c of-type base-char = (read-base-char stream)
until (or (eql c #\Newline)
(eql c #\Nul))
do (vector-push-extend c buffer)
finally (return buffer)))
(defun split (string &optional (separator #\space))
(declare (base-char separator))
(let ((pos (position separator string)))
(if pos
(cons (subseq string 0 pos)
(split (subseq string (1+ pos))
separator))
(list string))))
(declaim (inline parse-fixnum))
(defun parse-fixnum (string)
(with-input-from-string (in string)
(read-fixnum in #f(the (unsigned-byte 8)
(char-code (read-char % nil #\Nul nil))))))
(declaim (inline read-times))
(defun read-times (count &key (result-type 'list) (reader #'read-fixnum))
(coerce (loop repeat count collect (funcall reader)) result-type))
(defun unwrap (sequence)
;; e.g. (unwrap (list 1 2 3 4 5)) => "1 2 3 4 5"
(let ((*standard-output* (make-string-output-stream :element-type 'base-char)))
(let ((init nil))
(declare (boolean init))
(map nil
(lambda (x)
(when init
(princ #\space))
(setq init t)
(princ x))
sequence))
(coerce (get-output-stream-string *standard-output*) 'simple-base-string)))
;;;
;;; 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
;; TODO wait
(defconstant +grid-size+ 60)
(defconstant +player-vital+ 1500)
(sb-int:defconstant-eqx +char-int-assoc+
'((#\. . 0)
(#\# . 1)
(#\S . 2)
(#\G . 3)
(#\K . 4)
(#\J . 5)
(#\F . 6)
(#\E . 7))
#'equalp)
(sb-int:defconstant-eqx +move-dy-dx-assoc+
'((:down . (1 . 0))
(:up . (-1 . 0))
(:left . (0 . -1))
(:right . (0 . 1))
#+nil (:wait . (0 . 0)))
#'equalp)
(sb-int:defconstant-eqx +dir-char-assoc+
'((:down . #\D)
(:up . #\U)
(:left . #\L)
(:right . #\R))
#'equal)
(sb-int:defconstant-eqx +moves+ (mapcar #'car +move-dy-dx-assoc+)
#'equal)
(sb-int:defconstant-eqx +dy-dx+ (mapcar #'cdr +move-dy-dx-assoc+)
#'equalp)
(defun swap-cons (xs)
(cons (cdr xs) (car xs))))
(deftype moves () `(member ,@'#.+moves+))
(define-ecase-expander char->int-ecase #.+char-int-assoc+)
(define-ecase-expander int->char-ecase #.(mapcar #'swap-cons +char-int-assoc+))
(define-ecase-expander dir->char-ecase #.+dir-char-assoc+)
(defun char->int (c)
(char->int-ecase c))
(defun int->char (int)
(declare ((unsigned-byte 4) int)
(optimize (speed 3) (safety 0)))
(int->char-ecase int))
(defun dir->char (dir)
(declare (moves dir)
(optimize (speed 3) (safety 0)))
(dir->char-ecase dir))
(defun move->dy-dx (move)
"Returns (cons dy dx)"
(cdr (assoc move +move-dy-dx-assoc+)))
;; Coord
(eval-always
(defconstant +each-coord-word-size+ 8))
(eval-always
(deftype coord () '(unsigned-byte #.(* +each-coord-word-size+ 2))))
(declaim (inline y x))
(defun y (c)
(ldb (byte #.+each-coord-word-size+ 0)
c))
(defun x (c)
(ldb (byte #.+each-coord-word-size+ #.+each-coord-word-size+)
c))
#+nil
(defun valid-coord-p (c)
(and (<= 0 (y c) (1- +grid-size+))
(<= 0 (x c) (1- +grid-size+))))
(declaim (inline make-coord))
(defun make-coord (&key y x)
(when (and (<= 0 y (1- +grid-size+))
(<= 0 x (1- +grid-size+)))
(dpb x
(byte +each-coord-word-size+ +each-coord-word-size+)
y)))
#+nil
(let ((c (make-coord :y 3 :x 1)))
(values c (y c) (x c)))
(declaim (inline next-coord))
(defun next-coord (c dy dx)
(make-coord :y (the fixnum (+ (y c) dy))
:x (the fixnum (+ (x c) dx))))
(deftype costs () '(simple-array single-float (#.+grid-size+ #.+grid-size+)))
(deftype objs () '(simple-array (unsigned-byte 4) (#.+grid-size+ #.+grid-size+)))
(defstruct (game-info (:conc-name %))
"ゲーム中に変化しない情報をまとめる"
(estimated-cost-to-goal nil :type costs)
(estimated-cost-to-key nil :type costs)
(key-pos nil :type coord)
(objs nil :type objs :read-only t)
;; TODO use vector
(finder-cycle-by-coord (make-hash-table) :type hash-table :read-only t)
(finder-penalty nil :type fixnum))
(defun estimated-cost-to-goal (game-info c)
(aref (%estimated-cost-to-goal game-info) (y c) (x c)))
(defun estimated-cost-to-key (game-info c)
(aref (%estimated-cost-to-key game-info) (y c) (x c)))
(defun obj-at (game-info c)
(declare (optimize (speed 3) (safety 0))
(fixnum c))
(int->char (aref (%objs game-info) (y c) (x c))))
(defun finder-active-p (game-info pos turn)
;; MEMO turnは1からスタートする
(let ((finder-cycle (gethash pos (%finder-cycle-by-coord game-info))))
(zerop (rem turn finder-cycle))))
(defstruct (state (:conc-name %))
(pos nil :type coord)
(has-key (error "Need to specify value") :type boolean)
;; avl-tree of coord (shared with other boards)
;; TODO 削除操作がなければbloom filterで保持できるとうれしそう
(visited nil :type t :read-only t)
(destroyed-finders nil :type t :read-only t)
(blocks nil :type t :read-only t)
;; positive fixnum
(fire-amount 0 :type (integer 0 #.most-positive-fixnum))
(jewel-amount 0 :type (integer 0 #.most-positive-fixnum))
(elapsed-turn 0 :type (integer 0 #.most-positive-fixnum))
(elapsed-vital 0 :type (integer 0 #.most-positive-fixnum)))
(defun visitedp (state coord)
(avl:ref (%visited state) coord))
(defun %get-next-visited (state coord)
(avl:insert (%visited state) coord t))
(defun reachablep (state game-info coord)
;; coordのマスへ移動できる
;; TODO moveを引数に取りたい
(let ((c (obj-at game-info coord)))
(and (not (avl:ref (%blocks state) coord))
(or (find c ".SGKJF")
(and (char= c #\E)
(avl:ref (%destroyed-finders state) coord))))))
(defun block-placeable-p (state game-info coord)
;; coordのマスにブロックを配置できる
;; finder破壊後のマスにも置ける？
(let ((c (obj-at game-info coord)))
(and (char= c #\.)
(null (avl:ref (%blocks state) coord)))))
(defun block-removable-p (state game-info coord)
;; coordのマスのブロックを削除
(declare (ignore game-info))
(avl:ref (%blocks state) coord))
(defun %find-obj (get-obj-at obj)
(loop for y below +grid-size+
for c = (loop for x below +grid-size+
for c = (make-coord :y y :x x)
for i = (funcall get-obj-at c)
when (char= i obj)
return c)
when c
return it))
(defun %make-est-cost-from-obj (objs start-obj finder-cycle-by-coord)
(flet ((obj-at (c)
(int->char (aref objs (y c) (x c)))))
(let ((sc (%find-obj #'obj-at start-obj))
(costs (make-array (list +grid-size+ +grid-size+) :element-type 'single-float
:initial-element most-positive-single-float))
(heap (rh:make-randomized-heap #'< #'first)))
(assert sc)
(rh:push! heap (list 0.0 sc))
(while (not (rh:empty-p heap))
(destructuring-bind (cost c) (rh:pop! heap)
(when (<= cost (aref costs (y c) (x c)))
(setf (aref costs (y c) (x c))
cost)
(loop for (dy . dx) in +dy-dx+
for ny = (+ (y c) dy)
for nx = (+ (x c) dx)
for nc = (make-coord :y ny :x nx)
when (and nc
(not (find (obj-at nc)
"#E")))
do (let ((penalty 0))
(loop for (dy . dx) in +dy-dx+ unless (= dy dx 0) do
;; ncは即値
(let ((c nc))
(while c
(cond
((char= (obj-at c) #\W)
(return))
((char= (obj-at c) #\E)
;; 一番近くの探知機で止まる
(let ((cycle (gethash c finder-cycle-by-coord)))
(assert cycle)
;; TODO いい感じの係数をかける
(incf penalty (float (/ cycle)))
(return)))
(t
(setf c (next-coord c dy dx)))))))
(let ((new-cost (+ cost penalty)))
(when (< new-cost (aref costs (y nc) (x nc)))
(setf (aref costs (y nc) (x nc))
new-cost)
(rh:push! heap (list new-cost nc)))))))))
;; (break)
costs)))
(defun read-game-info ()
(destructuring-bind (n d h) (mapcar #'parse-fixnum (split (read-line)))
(declare (ignore n h))
(let ((objs (make-array '(#.+grid-size+ #.+grid-size+) :element-type '(unsigned-byte 4))))
(dotimes (y +grid-size+)
(let ((s (read-line)))
(dotimes (x +grid-size+)
(setf (aref objs y x)
(char->int (char s x))))))
(let ((m (read))
(finder-cycle-by-coord (make-hash-table)))
(dotimes (_ m)
(destructuring-bind (y x dd) (mapcar #'parse-fixnum (split (read-line)))
(setf (gethash (make-coord :y y :x x) finder-cycle-by-coord)
dd)))
(make-game-info :estimated-cost-to-goal (%make-est-cost-from-obj objs #\G finder-cycle-by-coord)
:estimated-cost-to-key (%make-est-cost-from-obj objs #\K finder-cycle-by-coord)
:key-pos (%find-obj #f(int->char (aref objs (y %) (x %))) #\K)
:objs objs
:finder-cycle-by-coord finder-cycle-by-coord
:finder-penalty d)))))
(defun %find-nearest-finders (game-info block-exist-p finder-destroyed-p pos &optional (directions +dy-dx+))
(declare (optimize (speed 3) (safety 0))
(function block-exist-p finder-destroyed-p)
(fixnum pos))
(let ((res nil))
(loop for (dy . dx) of-type (fixnum . fixnum) in directions do
(let ((c pos))
(declare ((or null fixnum) c))
(while c
(cond
((char= (obj-at game-info c)
#\W)
(return))
((funcall block-exist-p c)
(return))
((and (char= (obj-at game-info c) #\E)
(not (funcall finder-destroyed-p c)))
;; 一番近くの探知機で止まる
(push c res)
(return))
(t
(setf c (next-coord c dy dx)))))))
(nreverse res)))
;; TODO 他のアクションと共通の部分は切り出すとよさそう？→バグらせそうなのでやめたほうがいい
;; TODO 体力消費、ターン消費？(アイテム取得は移動時だけ)
(defun do-nothing (state game-info)
(with-accessors ((pos %pos)
(visited %visited)
(has-key %has-key)
(dfs %destroyed-finders)
(bs %blocks)
(fa %fire-amount)
(ja %jewel-amount)
(ev %elapsed-vital)
(et %elapsed-turn)) state
(let* ((nearest-finders (%find-nearest-finders
game-info
;; block-exist-p
(lambda (c)
(avl:ref bs c))
;; finder-destroyed-p
(lambda (c)
(avl:ref dfs c))
pos))
(nev (+ ev
(* (length (remove-if-not #f(finder-active-p game-info % (1+ et))
nearest-finders))
(%finder-penalty game-info))
1)))
;; #>(pos new-pos)
(make-state :pos pos
:has-key has-key
:visited visited
:destroyed-finders dfs
:blocks bs
:fire-amount fa
:jewel-amount ja
:elapsed-vital nev
:elapsed-turn (1+ et)))))
(defun move (state game-info move)
(with-accessors ((pos %pos)
(visited %visited)
(has-key %has-key)
(dfs %destroyed-finders)
(bs %blocks)
(fa %fire-amount)
(ja %jewel-amount)
(ev %elapsed-vital)
(et %elapsed-turn)) state
(destructuring-bind (dy . dx) (move->dy-dx move)
(let* ((ny (+ (y pos) dy))
(nx (+ (x pos) dx))
(new-pos (make-coord :y ny
:x nx))
(nobj (obj-at game-info new-pos))
(new-visited (%get-next-visited state new-pos))
(nfa (if (char= nobj #\F)
(1+ fa)
fa))
(nja (if (and (char= nobj #\J)
(not (visitedp state new-pos)))
(1+ ja)
ja))
(nearest-finders (%find-nearest-finders
game-info
;; block-exist-p
(lambda (c)
(avl:ref bs c))
;; finder-destroyed-p
(lambda (c)
(avl:ref dfs c))
new-pos))
(nev (+ ev
(* (length (remove-if-not #f(finder-active-p game-info % (1+ et))
nearest-finders))
(%finder-penalty game-info))
1)))
;; #>(pos new-pos)
(make-state :pos new-pos
:has-key (or has-key (char= (obj-at game-info new-pos)
#\K))
:visited new-visited
:destroyed-finders dfs
:blocks bs
:fire-amount nfa
:jewel-amount nja
:elapsed-vital nev
:elapsed-turn (1+ et))))))
(defun place-block (state game-info place-pos)
(with-accessors ((pos %pos)
(visited %visited)
(hk %has-key)
(dfs %destroyed-finders)
(bs %blocks)
(fa %fire-amount)
(ja %jewel-amount)
(ev %elapsed-vital)
(et %elapsed-turn)) state
(let* (;; 空のマスでないといけない
(nbs (avl:insert bs place-pos t))
(nearest-finders (%find-nearest-finders
game-info
;; block-exist-p
(lambda (c)
(avl:ref nbs c))
;; finder-destroyed-p
(lambda (c)
(avl:ref dfs c))
pos))
(nev (+ ev
(* (length nearest-finders)
(%finder-penalty game-info))
1)))
(make-state :pos pos
:visited visited
:has-key hk
:destroyed-finders dfs
:blocks nbs
:fire-amount fa
:jewel-amount ja
:elapsed-vital nev
:elapsed-turn (1+ et)))))
(defun destroy-block (state game-info place-pos)
(with-accessors ((pos %pos)
(visited %visited)
(has-key %has-key)
(dfs %destroyed-finders)
(bs %blocks)
(fa %fire-amount)
(ja %jewel-amount)
(ev %elapsed-vital)
(et %elapsed-turn)) state
(let* ((nbs (avl:remove bs place-pos))
(nearest-finders (%find-nearest-finders
game-info
;; block-exist-p
(lambda (c)
(avl:ref nbs c))
;; finder-destroyed-p
(lambda (c)
(avl:ref dfs c))
pos))
(nev (+ ev
(* (length (remove-if-not #f(finder-active-p game-info % (1+ et))
nearest-finders))
(%finder-penalty game-info))
1)))
(make-state :pos pos
:visited visited
:has-key has-key
:destroyed-finders dfs
:blocks nbs
:fire-amount fa
:jewel-amount ja
:elapsed-vital nev
:elapsed-turn (1+ et)))))
(defun destroy-finders-by-fire (state game-info dir)
(with-accessors ((pos %pos)
(has-key %has-key)
(visited %visited)
(dfs %destroyed-finders)
(bs %blocks)
(fa %fire-amount)
(ja %jewel-amount)
(ev %elapsed-vital)
(et %elapsed-turn)) state
(let* ((destroyed-finders (%find-nearest-finders
game-info
;; block-exist-p
(lambda (c)
(avl:ref bs c))
;; finder-destroyed-p
(lambda (c)
(avl:ref dfs c))
pos
(list (move->dy-dx dir))))
(ndfs (reduce (lambda (dfs c)
(avl:insert dfs c t))
destroyed-finders
:initial-value dfs))
(nearest-finders (%find-nearest-finders
game-info
;; block-exist-p
(lambda (c)
(avl:ref bs c))
;; finder-destroyed-p
(lambda (c)
(avl:ref ndfs c))
pos))
(nfa (1- fa))
(nev (+ ev
(* (length (remove-if-not #f(finder-active-p game-info % (1+ et))
nearest-finders))
(%finder-penalty game-info))
1)))
(assert (>= nfa 0))
(make-state :pos pos
:visited visited
:destroyed-finders ndfs
:has-key has-key
:blocks bs
:fire-amount nfa
:jewel-amount ja
:elapsed-vital nev
:elapsed-turn (1+ et)))))
(defun make-init-state (game-info)
(let* ((sp (%find-obj #f(obj-at game-info %) #\S))
(visited (avl:make-avl-tree-from-list #'identity (constantly t) (list sp))))
(make-state :pos sp
:has-key nil
:visited visited
:destroyed-finders nil
:blocks nil)))
(defun goal-state-p (state game-info)
(and (%has-key state)
(char= (obj-at game-info (%pos state))
#\G)))
(defun validate-state (state game-info)
;; TODO 必要そうなものを適宜足す
(unless (reachablep state game-info (%pos state))
(error "~a is not unreachable" (%pos state)))
(unless (visitedp state (%pos state))
(error "Player is at ~a, but visited is not marked" (%pos state)))
(awhen (loop for c in (avl:keys (%destroyed-finders state))
for obj = (obj-at game-info c)
when (char/= obj
#\E)
return (cons c obj))
(error "~a is contained in destroyed-finders, but is actually ~a" (car it) (cdr it)))
(awhen (loop for c in (avl:keys (%blocks state))
for obj = (obj-at game-info c)
when (char/= obj #\.)
return (cons c obj))
(error "~a is contained in blocks, so supposed to be empty block, but is actually ~a" (car it) (cdr it))))
(defconstant +dist-penalty-factor+ -1.0)
(defconstant +est-cost-factor+ 5.0d0)
(defun %eval-dist-to-goal (state game-info)
(- (round (estimated-cost-to-goal game-info (%pos state)))))
(defun %eval-dist-to-key (state game-info)
(let ((est-cost-from-here-to-key (round (estimated-cost-to-key game-info (%pos state)))))
;; 最短で取りに行きたい
(if (zerop est-cost-from-here-to-key)
(%elapsed-vital state)
(- est-cost-from-here-to-key))))
(defstruct (node (:conc-name %))
;; TODO hash
(parent nil :type (or null node))
(state nil :type state)
(score nil :type fixnum)
(last-action nil :type (or null cons)))
(defconstant +heap-size-threshold+ 200)
(defun chokudai-search (game-info eval-state goal-state-p
&key
init-states
time-limit
elapsed-vital-min
elapsed-vital-max)
(declare (function eval-state goal-state-p))
(let* ((n (- elapsed-vital-max elapsed-vital-min))
(states (make-array (1+ n)))
(start (get-internal-real-time))
(goal-candidates (rh:make-randomized-heap #'> #'%score)))
(dotimes (elapsed (1+ n))
(setf (aref states elapsed)
(rh:make-randomized-heap #'> #'%score)))
(dolist (init-state init-states)
(rh:push! (aref states (- (%elapsed-vital init-state)
elapsed-vital-min))
(make-node :state init-state
:score (funcall eval-state init-state game-info))))
;; 時間いっぱいchokudaiサーチ
(loop named search for turn from 1 do
(loop for elapsed-vital from elapsed-vital-min below elapsed-vital-max for e-index = (- elapsed-vital elapsed-vital-min) do
;; #>elapsed-vital
(when (> (/ (float (- (get-internal-real-time)
start))
internal-time-units-per-second)
time-limit)
#>turn
(return-from search))
(unless (rh:empty-p #1=(aref states e-index))
(let ((node (rh:pop! #1#)))
(labels ((%treat-next (next-state action)
#+(and swank) (validate-state next-state game-info)
(let* ((next-node (make-node :parent node
:state next-state
:score (funcall eval-state next-state game-info)
:last-action action))
(nev (%elapsed-vital next-state)))
(when (<= nev elapsed-vital-max)
;; #>(nev elapsed-vital-min elapsed-vital-max)
(cond
((funcall goal-state-p next-state game-info)
(rh:push! goal-candidates next-node))
(t
(rh:push! (aref states (- nev elapsed-vital-min))
next-node)
(when (= (rh:count (aref states (- nev elapsed-vital-min)))
+heap-size-threshold+)
(rh:prune! (aref states (- nev elapsed-vital-min))
(ash +heap-size-threshold+ -1)))))))))
(declare (inline %treat-next))
(%treat-next (do-nothing (%state node) game-info)
(cons :wait nil))
(loop for (dir . (dy . dx)) in +move-dy-dx-assoc+ do
(let ((nc (next-coord (%pos (%state node)) dy dx)))
(when nc
;; 移動
(when (reachablep (%state node) game-info nc)
(%treat-next (move (%state node)
game-info
dir)
(cons :move dir)))
;; ブロックを配置
(when (block-placeable-p (%state node) game-info nc)
(%treat-next (place-block (%state node)
game-info
nc)
(cons :place-block dir)))
;; ブロックを破壊
(when (block-removable-p (%state node) game-info nc)
(%treat-next (destroy-block (%state node)
game-info
nc)
(cons :destroy-block dir)))
;; ファイヤー
#+nil
(when (plusp (%fire-amount (%state node)))
(%treat-next (destroy-finders-by-fire (%state node) game-info dir)
(cons :fire dir)))))))))))
;; moveを復元してリストとして返す
#>((rh:count goal-candidates))
(let ((best-node (unless (rh:empty-p goal-candidates)
(rh:pop! goal-candidates)))
(res nil))
(assert best-node)
#>((%score best-node))
(while (%parent best-node)
(push (%last-action best-node)
res)
(setf best-node (%parent best-node)))
res)))
(defun print-res (res)
(princ
(with-output-to-string (*standard-output*)
(loop for (act . dir) in res
do (println
(ecase act
(:wait "S")
(:move
(format nil
"M ~a"
(dir->char dir)))
((:place-block :destroy-block)
(format nil "B ~a" (dir->char dir)))
(:fire
(format nil "F ~a" (dir->char dir)))))))))
(defun apply-action (state game-info action dir)
(ecase action
(:wait (do-nothing state game-info))
(:move (move state game-info dir))
(:place-block
(destructuring-bind (dy . dx) (move->dy-dx dir)
(place-block state game-info (next-coord (%pos state) dy dx))))
(:destroy-block
(destructuring-bind (dy . dx) (move->dy-dx dir)
(destroy-block state game-info (next-coord (%pos state) dy dx))))
(:fire
(destroy-finders-by-fire state game-info dir))))
(defun apply-actions (state game-info actions)
(reduce (lambda (acc act)
(destructuring-bind (act-type . dir) act
(apply-action acc game-info act-type dir)))
actions
:initial-value state))
(defconstant +find-key-time-limit+ 0.3)
(defconstant +earn-coin-time-limit+ 2.0)
(defconstant +find-goal-time-limit+ 0.5)
#+nil
(defun eval-state (state game-info)
;; TODO ゴールに辿りつくのが難しい場合ほど大きなペナルティ
;; TODO 残り体力が少なくなるほど傾斜を強くする？
(cond
((not (%has-key state))
(- (%eval-for-dist-to-key state game-info)
100000))
;; 残り100ターンを切ったらゴールを最優先して目指す
((< (- +player-vital+ (%elapsed-vital state))
400)
(+ (%eval-for-dist-to-goal state game-info)
(* 100000 (%jewel-amount state))))
(t
(%jewel-amount state))))
(declaim (notinline main))
(defun main ()
(let* ((game-info (read-game-info))
(init-state (make-init-state game-info))
(best-moves-to-key (chokudai-search
game-info
#'%eval-dist-to-key
(lambda (state game-info)
(declare (ignore game-info))
(%has-key state))
:init-states (list init-state)
:time-limit +find-key-time-limit+
:elapsed-vital-min 0
:elapsed-vital-max (round (* (estimated-cost-to-key game-info (%pos init-state))
10))))
(next-init-state (apply-actions init-state game-info best-moves-to-key))
(elapsed-vital-to-key (%elapsed-vital next-init-state))
(earn-end (max (1+ elapsed-vital-to-key)
(round (- +player-vital+
(* (estimated-cost-to-goal game-info (%key-pos game-info))
10)))))
(best-earn-moves (chokudai-search
game-info
(lambda (state game-info)
(declare (ignore game-info))
(%jewel-amount state))
(lambda (state game-info)
(declare (ignore game-info))
(<= (abs (- (%elapsed-vital state)
earn-end))
30))
:init-states (list next-init-state)
:time-limit +earn-coin-time-limit+
:elapsed-vital-min (%elapsed-vital next-init-state)
:elapsed-vital-max earn-end))
(next-init-state (apply-actions next-init-state game-info best-earn-moves))
(_ #>next-init-state)
(best-back-moves (chokudai-search
game-info
#'%eval-dist-to-goal
#'goal-state-p
:init-states (list next-init-state)
:time-limit +find-goal-time-limit+
:elapsed-vital-min (%elapsed-vital next-init-state)
:elapsed-vital-max +player-vital+))
(res (concatenate 'list
best-moves-to-key
best-earn-moves
best-back-moves)))
#>(elapsed-vital-to-key earn-end)
(print-res res)))
#-swank (main)
;;;
;;; Debug
;;;
#+swank
(defun run ()
(let ((*standard-input*
(make-string-input-stream
(with-output-to-string (*standard-output*)
(run-program
(truename "~/.roswell/bin/copy-or-paste")
'()
:output *standard-output*)))))
(main)))
;; 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*))
(with-open-file (*standard-input* infile :direction :input)
(with-open-file (*standard-output* outfile :direction :output
:if-exists :supersede)
(main))
(sb-ext:run-program "/usr/bin/java" (list "Judge" infile outfile)
:output out
:error *error-output*)))
#+swank (declaim (notinline run-sample-zero))
#+swank
(defun run-sample-zero ()
(gc :full t)
(with-input-from-string (*standard-input* "60 3 1500
.......JJ....J#..#E#....EE.J..E...E#J.....#.#EE......#..J.J#
#E#.....##J..JE....E..#....J.........#......#..#J.........#.
.J.J.#.#....J.#..#........J#...#J#.KJE.J.E.#J.#....#......J.
J..E..#.E#.......E........JEJ.....F..##..............#...J.J
..J.......JE...#......J.#.#..#J#JFJ.......E..#..#....E.....J
#..J.....EE....J........E............##.E#.E.#JJ..........E.
...#......J.J..J#...#...#.#..JE#....##E...#F.#....E....#E#..
.JJ.....###.J.EE...J...#E#E#...E.E.....#E......J..#...#....#
E.E.......#JF.J.J.E.##E#...EE..J....F..#.#J#..E#J..E..J...#F
##....F.#F#.E.#.EJ...J#E..#..#.J.......E...J....#..#..#....S
.E...E...J..J#........#...E.E.......#.....J..J.....E..E....#
.................#J#.....F...JE.#......##.........JJ.J....#.
E..J...E##..#.J...#...#.E....##...#.....EEJJJ.##.#.E.....E#.
E#.F.#.......JF..#..E#......EJ.....#.#.E.##..JJ.......E.J..E
JE..#E....E..E.J#.E...E...J...#J#J.#.E.....E..#E#.E..EF###..
E....J.#..J#....#..EE#.E...E.J.J...E#E#.J..J...E..........J#
.....#..J.#JF.#....E..#EE..E..#.......E.........#..J..#..J.F
#.EF.......E.J.E............#.........#...........E...#.#J..
F.....JJ...E#..E.#....#.E#...#...F.J.#.E.F.#.....J.....#EJ.E
###......#.E.J.E...#E..#..E...#.....#..#.#......F#.E.J..#.#E
....JEEE..EE.#.E#..#JJ............#J.E.#E..J........E....#.E
..E....EJ...J........#..J..J.#E#.#...#.E....#E.#E.#.#E..#..#
...#E#.E.....#J.E.#.#.J.J...E.JJ#J...#.J...##....J.J.......#
.....F....#..J#J..#....#.E...EJ#..#...#.#F#F.EE#..#.....#E.E
J#..#....#.#E..#.J.#.#......EJ..J.............#...#....#.E..
..##EEEE.....JJ..J.#..#..#.E....#J#E#E...E......#JJ#.E..E.#J
#E..##..JJ.#.JE.....E.##.E....E#.....#E.#J..#....JJ..#.#....
.E.#.E....#E..E..JEJ..JE..#F#..#.#.#..E#J#......#.E.EJ#..F.E
.J....#....J.JE.J#...JF.E..JE.J..#....F.F#..E.##JJE....#F.EE
..F.EJF...E...EE#..J.#F.F#....JE#J.......E#F.....E.....J...#
#E##EJ#.E....E......JJ..F##J..E...J..JE..J.EJ..E.....E.EE.#E
E#...E...JE.#.#..E..#.J....E..#.#.J#.E.E.#.#E.##.#...#...E.J
...G##..EF.J#J.J....E.F.......E#.J...#..E...##........#.E.#.
.....J.#..J...E..EJ..E......J....E...#.#.F#E.EE..#J.E......E
........E.E..#FJ.E#.F..E#.#...........F....J..#.##.##..EFJ.E
....E.#....##.JE...EE.E.#E#..JJEF....#J.#....J.JE..J.....J..
#E...........JJ....###....J#................J..#J.JJ#JE.EJ..
JE.#EJE..#..E..J..#.J.#.....J.J.....#EJJ.E#.E..#E.......E..#
#.#J......#....#...#....J.J.E#J.E##.J....EE.#..E..##J..E....
E..E.F.#E....E.....J.#.#.EJ.#.#.J.#...JJ##..#J.....#J.EJ....
.#J.E#......#..E..#..#...J#J....#.E.J......#F.#.E.EJ..E...#.
....J.E..#.#......J...#.JE.#.E...#..E..E.J.E..#.E...#....#EJ
...##.J..J.J...JEJEJ...#.##.#.EE.F...F#.......E.E...#.....J.
...#F..JJ....J##.......F...#..#E....#JJJE.E.J##.E..J...F#J#.
#....J..#......EJ.#....EE.#...E....E...#.E.J.E...JEE.E..J..#
...#...#.#....#...E.#.E..E.E..F.E.FEE...............F..#.E#.
E.JJ.....E#EJE#....##....#.#.F..#J..#E...#...E.#..##EJ#.#...
F....#....#..........E.E.FE.#E......#..#EE..#...#EE....FE..#
..JJ#J..EE...J........J#.E..E..J..E.#...##......J..J........
..##...#...JJF#J....F....#.....#E.......EJ.........J.#......
....J.#J.....J....##J..#..JJ.#..#.#.#...J.JE##E.JJ....E#.#.E
...#......EE.....JE..........J.J..J#...#.#..#F..#..J..E...#.
E...E..E.F.E#....J....E.#.E.JJ..J.J.J.#.##.....J.E..J.......
##E.....E#EJJ.##.......E.##....EE......E...FE.#.....E.J##..J
..#E#J#......J#......#.#.J....E.#..E..#E.##.#.###......#....
#E#.#J...E.#.JE.#.J...#.....#....J..EE.##EE#..##.......##E..
#.#......#.J.J...E#.E...JE#......#..J.....J#JF..#E.EJ.J.....
J....#...JJ...E......#E.J..##.....#.J.#..#E.E..#.....##..J..
E#E.......J#.....EE.J..##...F.....J.FJ#.E........E........#.
J.E....J.E.J...E.#..E........##..E....#J..#.#..J...#...E#E..
374
0 18 5
0 24 5
0 25 2
0 30 3
0 34 2
0 45 3
0 46 4
1 1 3
1 14 5
1 19 2
2 37 5
2 41 5
3 3 3
3 8 4
3 17 3
3 27 3
4 11 2
4 42 4
4 53 2
5 9 4
5 10 2
5 24 3
5 40 5
5 43 2
5 58 5
6 30 2
6 38 5
6 50 5
6 56 5
7 14 2
7 15 5
7 24 5
7 26 4
7 31 5
7 33 4
7 40 3
8 0 5
8 2 5
8 18 5
8 22 3
8 27 3
8 28 5
8 46 2
8 51 5
9 12 3
9 16 3
9 23 5
9 39 4
10 1 5
10 5 2
10 26 5
10 28 3
10 51 4
10 54 3
11 30 2
12 0 4
12 7 4
12 24 4
12 40 5
12 41 4
12 51 5
12 57 4
13 0 4
13 20 2
13 28 2
13 39 4
13 54 2
13 59 5
14 1 5
14 5 4
14 10 4
14 13 5
14 18 2
14 22 4
14 37 2
14 43 4
14 47 4
14 50 2
14 53 3
15 0 3
15 19 3
15 20 4
15 23 2
15 27 3
15 35 2
15 37 3
15 47 5
16 19 4
16 23 2
16 24 5
16 27 2
16 38 5
17 2 5
17 11 4
17 15 5
17 50 3
18 11 5
18 15 3
18 24 3
18 39 5
18 56 4
18 59 5
19 11 5
19 15 5
19 20 2
19 26 4
19 51 4
19 59 4
20 5 4
20 6 4
20 7 4
20 10 3
20 11 4
20 15 4
20 37 5
20 40 4
20 52 2
20 59 3
21 2 2
21 7 3
21 30 5
21 39 3
21 45 3
21 48 2
21 53 4
22 4 4
22 7 2
22 16 4
22 28 2
23 25 3
23 29 2
23 45 4
23 46 5
23 57 4
23 59 4
24 12 3
24 28 5
24 57 2
25 4 2
25 5 3
25 6 4
25 7 2
25 27 4
25 35 5
25 37 3
25 41 3
25 53 3
25 56 4
26 1 5
26 14 2
26 20 3
26 25 3
26 30 3
26 38 5
27 1 2
27 5 4
27 11 2
27 14 3
27 18 2
27 23 2
27 38 3
27 50 2
27 52 2
27 59 5
28 14 2
28 24 5
28 28 2
28 44 3
28 50 3
28 58 4
28 59 3
29 4 2
29 10 5
29 14 4
29 15 2
29 31 3
29 41 3
29 49 4
30 1 4
30 4 3
30 8 2
30 13 5
30 30 3
30 38 4
30 43 3
30 47 3
30 53 3
30 55 3
30 56 2
30 59 2
31 0 5
31 5 3
31 10 2
31 17 5
31 27 4
31 37 2
31 39 3
31 44 4
31 57 4
32 8 3
32 20 3
32 30 5
32 40 2
32 56 5
33 14 3
33 17 4
33 21 3
33 33 3
33 43 4
33 45 3
33 46 4
33 52 5
33 59 5
34 8 4
34 10 4
34 17 2
34 23 5
34 55 5
34 59 5
35 4 2
35 15 3
35 19 5
35 20 2
35 22 5
35 25 2
35 31 5
35 48 2
36 1 4
36 54 3
36 56 2
37 1 5
37 4 2
37 6 3
37 12 4
37 37 5
37 41 5
37 44 2
37 48 2
37 56 2
38 28 2
38 32 3
38 41 5
38 42 5
38 47 5
38 55 2
39 0 4
39 3 2
39 8 2
39 13 5
39 25 3
39 54 3
40 4 2
40 15 3
40 34 4
40 48 5
40 50 4
40 54 4
41 6 4
41 25 4
41 29 4
41 36 5
41 39 4
41 43 4
41 48 4
41 58 4
42 16 2
42 18 3
42 30 5
42 31 4
42 46 2
42 48 2
43 31 2
43 40 2
43 42 2
43 48 5
44 15 4
44 23 3
44 24 5
44 30 2
44 35 2
44 41 5
44 45 4
44 50 2
44 51 3
44 53 3
45 18 3
45 22 5
45 25 5
45 27 2
45 32 3
45 35 4
45 36 2
45 57 4
46 0 4
46 9 5
46 11 2
46 13 4
46 37 3
46 45 3
46 52 2
47 21 2
47 23 4
47 26 2
47 29 5
47 40 2
47 41 3
47 49 3
47 50 4
47 56 5
48 8 3
48 9 2
48 25 5
48 28 4
48 34 2
49 32 5
49 40 5
50 43 2
50 46 5
50 54 5
50 59 3
51 10 4
51 11 3
51 18 2
51 54 4
52 0 4
52 4 4
52 7 3
52 11 2
52 22 2
52 26 2
52 49 3
53 2 3
53 8 4
53 10 2
53 23 4
53 31 3
53 32 3
53 39 4
53 44 2
53 52 2
54 3 3
54 30 4
54 35 4
54 39 4
55 1 3
55 9 5
55 14 4
55 36 2
55 37 5
55 41 4
55 42 2
55 57 3
56 17 5
56 20 3
56 25 3
56 49 4
56 51 4
57 14 2
57 22 2
57 42 5
57 44 3
58 0 2
58 2 4
58 17 2
58 18 4
58 40 2
58 49 4
59 2 4
59 9 4
59 15 3
59 20 3
59 33 2
59 55 5
59 57 2
")
(main)))