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

(defun %squared-euclid-distance (c1 c2)
  (let* ((dy (- (y c1) (y c2)))
         (dx (- (x c1) (x c2))))
    (+ (* dy dy)
       (* dx dx))))

(defun %get-nearest-costs-and-paths-from (start planets stations)
  ;; dijkstra法を利用して最小コストを求めたい
  ;; 途中でステーションを経由してもいいが、最終的に欲しいのは惑星間の移動コストとpath
  (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 paths)))

(defun %get-each-node-costs-and-paths (get-cost-and-path)
  ;; floyd-warshall method
  ;; TODO 各頂点の移動では他の頂点を経由していいとする
  ;; TODO 事前にdijkstraで各頂点間の最短距離を求めておく
  (let ((costs (make-array (list +planet-amount+ +planet-amount+)
                           :element-type 'fixnum
                           :initial-element +inf+))
        (paths (make-array (list +planet-amount+ +planet-amount+)
                           :element-type 'list
                           :initial-element nil)))
    (declare (%costs costs))
    (dotimes (i +planet-amount+)
      (dotimes (j +planet-amount+)
        (multiple-value-bind (cost path) (funcall get-cost-and-path i j)
          (setf (aref costs i j) cost
                (aref paths i j) (reverse path)))))
    #>costs
    (dotimes (k +planet-amount+)
      (dotimes (i +planet-amount+)
        (dotimes (j +planet-amount+)
          (let ((current (aref costs i j))
                (cand (+ (aref costs i k)
                         (aref costs k j))))
            (when (< cand current)
              (setf (aref costs i j) cand
                    ;; 計算量大丈夫？O(n^4)な気がする
                    (aref paths i j) (append (aref paths i k)
                                             (rest (aref paths k j)))))))))
    (values costs paths)))

(defun make-orders (planets stations)
  ;; 各惑星間の距離を求めて Nearest Neighbor で貪欲に解く
  ;; TODO ステーションを使う
  ;; 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)))
    (multiple-value-bind (costs paths) (%get-each-node-costs-and-paths
                                        (lambda (from to)
                                          (destructuring-bind (cs ps) (aref costs-and-paths-from from)
                                            (values (aref cs to)
                                                    (aref ps to)))))
      (let ((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+)
              (let ((path (aref paths now next))
                    (cost (aref costs now next)))
                (when (and (not (gethash next visited))
                           (< cost min-dist))
                  (setf nearest next
                        nearest-path path
                        min-dist cost))))
            #>(now nearest)
            (setf now nearest
                  (gethash now visited) t)
            (push nearest-path ps)))
        (push (list 0 0) ps)
        #>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-input))
         (stations (make-station-coords 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*))))