(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 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 make-orders (planets stations)
  ;; 各惑星間の移動最小コストを求めてから Nearest Neighbor で貪欲に経路を決める
  ;; TODO TSPを解く
  (let ((costs-and-paths-from (coerce
                               (loop for i below +planet-amount+
                                     collect (%get-nearest-costs-and-paths-from i planets stations))
                               'vector))
        (ps nil)
        (visited (make-hash-table)))
    (setf (gethash 0 visited) t)
    (loop repeat (1- +planet-amount+) with now = 0 do
      (let ((nearest -1)
            (nearest-path nil)
            (min-dist +inf+))
        (dotimes (next +planet-amount+)
          (destructuring-bind (cs ps) (aref costs-and-paths-from now)
            (let ((path (aref ps next))
                  (cost (aref cs next)))
              (when (and (not (gethash next visited))
                         (< cost min-dist))
                (setf nearest next
                      nearest-path path
                      min-dist cost)))))
        #>(now nearest)
        (assert (/= now nearest))
        (setf now nearest
              (gethash now visited) t)
        (push nearest-path ps)))
    (push (list 0 0) ps)
    (coerce (cons 0 (apply #'concatenate 'list (mapcar #'rest (reverse ps))))
            'orders)))

(defun print-ans (stations orders)
  (declare (orders orders)
           (stations stations))
  #>orders
  ;; 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* ((planets (read-planets))
         (stations (get-best-station-positions-with-dp planets))
         (orders (make-orders planets 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*))))