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

;; 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 (score-diff temp)
  (rough-exp (/ score-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 %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)))

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

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

(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 %construct-path (planet-orders paths)
  (let ((res (list 0))
        (ps (coerce planet-orders 'list)))
    (loop for (from to) on ps by #'rest when to do
      (dolist (pos (aref (aref paths from) to))
        (push pos res)))
    (coerce (nreverse res) 'orders)))

(sb-int:defconstant-eqx +swap-vec+
    #(0 5 6 3 4 1 2 7)
  #'equalp)

(defun make-orders (planets stations time-limit)
  #>time-limit
  (let* ((start (get-internal-real-time))
         (time 0d0)
         (time-limit (float time-limit 0d0))
         (costs-and-paths-from (coerce
                                (loop for i below +planet-amount+
                                      collect (%get-nearest-costs-and-paths-from i planets stations))
                                'vector))
         (ps (make-array (1+ +planet-amount+) :element-type 'fixnum))
         (current-cost 0))
    (declare (fixnum current-cost))
    (flet ((%get-cost (from to)
             (let ((cs (first (aref costs-and-paths-from from))))
               (declare ((simple-array fixnum 1) cs))
               (the fixnum (aref cs to)))))
      (declare (inline %get-cost))
      ;; 最初は0
      (dotimes (i +planet-amount+)
        (setf (aref ps i) i))
      ;; 最後は0
      (setf (aref ps +planet-amount+) 0)
      (loop for i below +planet-amount+
            do (incf current-cost
                     (%get-cost i (rem (1+ i) +planet-amount+))))
      (loop for turn of-type fixnum from 0 do
        (when (zerop (rem turn 32))
          (setf time (float (/ (- (get-internal-real-time)
                                  start)
                               internal-time-units-per-second))))
        (when (> time time-limit)
          #>turn
          (return))
        (if (plusp (random 32))
            ;; kick (four gridges)
            (let* ((i (random (- +planet-amount+ 8)))
                   (now (loop for j below 8
                              collect (+ i j)))
                   (new (map 'list #f(+ i %) +swap-vec+))
                   (now-indexes (subseq ps i (+ i 8)))
                   (cost-diff (- (loop for (j k) on new by #'rest
                                       when k sum (%get-cost (aref ps j)
                                                             (aref ps k)))
                                 (loop for (j k) on now by #'rest
                                       when k sum (%get-cost (aref ps j)
                                                             (aref ps k)))                                 )))
              (when (minusp cost-diff)
                (loop for new-idx across +swap-vec+
                      for ii from i
                      do (setf (aref ps ii)
                               (aref now-indexes new-idx)))
                (incf current-cost cost-diff)))
            ;; 2-opt
            (let* (;; 0 〜 (n - 2)
                   (i (random (- +planet-amount+ 1)))
                   ;; 1 〜 (n - 1)
                   (j (1+ (random (- +planet-amount+ 1))))
                   (cost-diff (- (+ (%get-cost (aref ps i)
                                               (aref ps (1+ j)))
                                    (%get-cost (aref ps j)
                                               (aref ps (1+ i))))
                                 (+ (%get-cost (aref ps i)
                                               (aref ps (1+ i)))
                                    (%get-cost (aref ps j)
                                               (aref ps (1+ j))))))                   )
              (declare (fixnum i j cost-diff))
              (when (minusp cost-diff)
                (rotatef (aref ps i) (aref ps j))
                (incf current-cost)))))
      (%construct-path ps (map 'vector #'second costs-and-paths-from)))))

(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)
           (if (< o +planet-amount+)
               (values 1 o)
               (values 2 (- o +planet-amount+)))
         (format t "~a ~a~%" type (1+ id)))))))

(defun main ()
  (let* ((start (get-internal-real-time))
         (planets (read-planets))
         (stations (make-station-coords planets))
         (orders (make-orders planets stations (- 0.7
                                                  (/ (- (get-internal-real-time)
                                                        start)
                                                     internal-time-units-per-second)))))
    (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*))))