#862443 (Common Lisp) No.5007 Steiner Space Travel

• 問題: No.5007 Steiner Space Travel
• ユーザー: motoshira
• 提出日時: 2023-04-23 21:57:53
• 言語: Common Lisp (sbcl 2.5.0)
• 結果: AC
• 実行時間: 30 ms / 1,000 ms
• コード長: 7,279 bytes
• コンパイル時間: 990 ms
• コンパイル使用メモリ: 40,796 KB
• 実行使用メモリ: 29,352 KB
• スコア: 1,221,702
• 最終ジャッジ日時: 2023-04-23 21:57:57
• 合計ジャッジ時間: 3,358 ms
• ジャッジサーバーID （参考情報）: judge15 / judge12

ファイルパターン	結果
other	AC * 30

コンパイルメッセージ

; compiling file "/home/judge/data/code/Main.lisp" (written 23 APR 2023 09:57:53 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 (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 +PLANET-AMOUNT+ ...) ...)
; processing (DEFTYPE COORD ...)
; processing (DECLAIM (INLINE Y ...))
; processing (DEFUN MAKE-COORD ...)
; processing (DEFUN Y ...)
; processing (DEFUN X ...)
; processing (DEFTYPE PLANETS ...)
; processing (DEFUN READ-INPUT ...)
; processing (DEFTYPE STATIONS ...)
; processing (DEFTYPE ORDERS ...)
; processing (DEFUN MAKE-STATION-COORDS ...)
; processing (DEFCONSTANT +INF+ ...)
; processing (DEFTYPE %COSTS ...)
; processing (DEFUN %PLANET-ID-P ...)
; processing (DEFINE-MODIFY-MACRO MINF ...)
; processing (DEFUN %GET-EACH-NODE-COSTS ...)
; processing (DEFUN MAKE-ORDERS ...)
; processing (DEFUN PRINT-ANS ...)
; processing (DEFUN MAIN ...)
; processing (MAIN)

; wrote /home/judge/data/code/Main.fasl
; compilation finished in 0:00:00.144

ソースコード

(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
;;;

;;;
;;; 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 +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 1000) () "y is out of range")
  #+swank (assert (<= 0 x 1000) () "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))

(deftype planets () '(simple-array coord (*)))

(defun read-input ()
  (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))

(deftype stations ()
  '(simple-array coord (*)))

(deftype orders ()
  "planetsはid0〜99, stationsはid100〜107
  最初と最後はid0でないといけない"
  '(simple-array fixnum (*)))

(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+))

(define-modify-macro minf (var) min)

(defun %get-each-node-costs (planets stations)
  ;; floyd-warshall method
  ;; TODO 各頂点の移動では他の頂点を経由していいとする
  ;; TODO 事前にdijkstraで各頂点間の最短距離を求めておく
  (let ((costs (make-array (list +all-amount+ +all-amount+)
                           :element-type 'fixnum
                           :initial-element +inf+)))
    (declare (%costs costs))
    (labels ((%get-cost (i j)
               (let* ((ci (if (%planet-id-p i)
                              (aref planets i)
                              (aref stations (- i +planet-amount+))))
                      (cj (if (%planet-id-p j)
                              (aref planets j)
                              (aref stations (- j +planet-amount+))))
                      (dy (- (y ci) (y cj)))
                      (dx (- (x ci) (x cj))))
                 (* (if (%planet-id-p i)
                        +alpha+
                        1)
                    (if (%planet-id-p j)
                        +alpha+
                        1)
                    dy dy
                    dx dx))))
      (dotimes (i +all-amount+)
        (dotimes (j +all-amount+)
          (setf (aref costs i j)
                (%get-cost i j))))
      #>costs
      (dotimes (k +all-amount+)
        (dotimes (i +all-amount+)
          (dotimes (j +all-amount+)
            (minf (aref costs i j)
                  (+ (aref costs i k)
                     (aref costs k j))))))
      costs)))

(defun make-orders (planets stations)
  ;; 各惑星間の距離を求めて Nearest Neighbor で貪欲に解く
  ;; TODO ステーションを使う
  ;; TODO TSPを解く
  (let* ((res (make-array (1+ +planet-amount+) :element-type 'fixnum))
         (costs (%get-each-node-costs planets stations))
         (visited (make-hash-table)))
    (declare (orders res)
             (%costs costs))
    (setf (aref res 0) 0
          (gethash 0 visited) t)
    (loop for i from 1 below +planet-amount+ with now = 0 do
      (let ((nearest -1)
            (min-dist +inf+))
        (dotimes (j +all-amount+)
          (when (and (not (gethash j visited))
                     (< (aref costs i j)
                        min-dist))
            (setf nearest j
                  min-dist (aref costs i j))))
        (setf now nearest
              (aref res i) nearest
              (gethash now visited) t)))
    (setf (aref res +planet-amount+) 0)
    res))

(defun print-ans (stations orders)
  (declare (orders orders)
           (stations stations))
  ;; 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* ((input (read-input))
         (stations (make-station-coords input))
         (orders (make-orders input stations)))
    (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*))))