(eval-when (:compile-toplevel :load-toplevel :execute)
  (sb-int:defconstant-eqx opt
    #+swank '(optimize (speed 3) (safety 2))
    #-swank '(optimize (speed 3) (safety 0) (debug 0))
    #'equal)
  #+swank (ql:quickload '(:cl-debug-print :fiveam) :silent t)
  #-swank (set-dispatch-macro-character
           #\# #\> (lambda (s c p) (declare (ignore c p)) `(values ,(read s nil nil t)))))
#+swank (cl-syntax:use-syntax cl-debug-print:debug-print-syntax)
#-swank (disable-debugger) ; for CS Academy

(defmacro define-int-types (&rest bits)
  `(progn
     ,@(mapcar (lambda (b) `(deftype ,(intern (format nil "UINT~A" b)) () '(unsigned-byte ,b))) bits)
     ,@(mapcar (lambda (b) `(deftype ,(intern (format nil "INT~A" b)) () '(signed-byte ,b))) bits)))
(define-int-types 2 4 7 8 15 16 31 32 62 63 64)

;; BEGIN_INSERTED_CONTENTS
;;;
;;; Sort multiple vectors
;;;

;; TODO: throw an error if there are two ore more identical vectors in the given
;; vectors

(declaim (inline %median3))
(defun %median3 (x y z)
  (if (> x y)
      (if (> y z)
          y
          (if (> z x)
              x
              z))
      (if (> z y)
          y
          (if (> x z)
              x
              z))))

(defun parallel-sort! (vector vector1 vector2 end)
  (declare #.OPT
           ((simple-array int32 (*)) vector)
           ((simple-array t (*)) vector1 vector2)
           ((integer 0 #.array-total-size-limit) end))
  (labels
      ((recur (left right)
         (declare ((integer -1 #.array-total-size-limit) left right))
         (when (< left right)
           (let* ((l left)
                  (r right)
                  (pivot (%median3 (aref vector l)
                                   (aref vector (ash (+ l r) -1))
                                   (aref vector r))))
             (declare ((integer 0 #.most-positive-fixnum) l r))
             (loop (loop while (> (aref vector l) pivot)
                         do (incf l 1))
                   (loop while (> pivot (aref vector r))
                         do (decf r 1))
                   (when (>= l r)
                     (return))
                   (rotatef (aref vector l) (aref vector r))
                   (rotatef (aref vector1 l) (aref vector1 r))
                   (rotatef (aref vector2 l) (aref vector2 r))
                   (incf l 1)
                   (decf r 1))
             (recur left (- l 1))
             (recur (+ r 1) right)))))
    (recur 0 (- end 1))
    vector))

(declaim (inline bisect-left))
(defun bisect-left (target value &key (start 0) end (order #'<) (key #'identity))
  "TARGET := vector | function (taking an integer argument)
ORDER := strict order

Analogue of lower_bound() of C++ or bisect_left() of Python: Returns the
smallest index (or input) i that fulfills TARGET[i] >= VALUE, where '>=' is the
complement of ORDER. In other words, this function returns the leftmost index at
which VALUE can be inserted with keeping the order. Therefore, TARGET must be
monotonically non-decreasing with respect to ORDER.

- This function returns END if VALUE exceeds TARGET[END-1]. 
- The range [START, END) is half-open.
- END must be explicitly specified if TARGET is function.
- KEY is applied to each element of TARGET before comparison."
  (declare (function key order)
           (integer start)
           ((or null integer) end))
  (macrolet
      ((frob (accessor &optional declaration)
         `(labels
              ((%bisect-left (ng ok)
                 ;; TARGET[OK] >= VALUE always holds (assuming
                 ;; TARGET[END] = +infinity)
                 ,@(when declaration (list declaration))
                 (if (<= (- ok ng) 1)
                     ok
                     (let ((mid (ash (+ ng ok) -1)))
                       (if (funcall order (funcall key (,accessor target mid)) value)
                           (%bisect-left mid ok)
                           (%bisect-left ng mid))))))
            (assert (<= start end))
            (%bisect-left (- start 1) end))))
    (etypecase target
      (vector
       (let ((end (or end (length target))))
         (frob aref (declare ((integer -1 (#.most-positive-fixnum)) ng ok)))))
      (function
       (assert end () "Requires END argument if TARGET is a function.")
       (frob funcall)))))

(declaim (inline bisect-right))
(defun bisect-right (target value &key (start 0) end (order #'<) (key #'identity))
  "TARGET := vector | function (taking an integer argument)
ORDER := strict order

Analogue of upper_bound() of C++ or bisect_right() of Python: Returns the
smallest index (or input) i that fulfills TARGET[i] > VALUE. In other words,
this function returns the rightmost index at which VALUE can be inserted with
keeping the order. Therefore, TARGET must be monotonically non-decreasing with
respect to ORDER.

- This function returns END if VALUE >= TARGET[END-1].
- The range [START, END) is half-open.
- END must be explicitly specified if TARGET is function.
- KEY is applied to each element of TARGET before comparison."
  (declare (function key order)
           (integer start)
           ((or null integer) end))
  (macrolet
      ((frob (accessor &optional declaration)
         `(labels
              ((%bisect-right (ng ok)
                 ;; TARGET[OK] > VALUE always holds (assuming
                 ;; TARGET[END] = +infinity)
                 ,@(when declaration (list declaration))
                 (if (<= (- ok ng) 1)
                     ok
                     (let ((mid (ash (+ ng ok) -1)))
                       (if (funcall order value (funcall key (,accessor target mid)))
                           (%bisect-right ng mid)
                           (%bisect-right mid ok))))))
            (assert (<= start end))
            (%bisect-right (- start 1) end))))
    (etypecase target
      (vector
       (let ((end (or end (length target))))
         (frob aref (declare ((integer -1 (#.array-total-size-limit)) ng ok)))))
      (function
       (assert end () "Requires END argument if TARGET is a function.")
       (frob funcall)))))

(declaim (ftype (function * (values fixnum &optional)) read-fixnum))
(defun read-fixnum (&optional (in *standard-input*))
  "NOTE: cannot read -2^62"
  (declare #.OPT)
  (macrolet ((%read-byte ()
               `(the (unsigned-byte 8)
                     #+swank (char-code (read-char in nil #\Nul))
                     #-swank (sb-impl::ansi-stream-read-byte in nil #.(char-code #\Nul) nil))))
    (let* ((minus nil)
           (result (loop (let ((byte (%read-byte)))
                           (cond ((<= 48 byte 57)
                                  (return (- byte 48)))
                                 ((zerop byte) ; #\Nul
                                  (error "Read EOF or #\Nul."))
                                 ((= byte #.(char-code #\-))
                                  (setq minus t)))))))
      (declare ((integer 0 #.most-positive-fixnum) result))
      (loop
        (let* ((byte (%read-byte)))
          (if (<= 48 byte 57)
              (setq result (+ (- byte 48)
                              (* 10 (the (integer 0 #.(floor most-positive-fixnum 10))
                                         result))))
              (return (if minus (- result) result))))))))

(in-package :cl-user)

(defmacro dbg (&rest forms)
  #+swank
  (if (= (length forms) 1)
      `(format *error-output* "~A => ~A~%" ',(car forms) ,(car forms))
      `(format *error-output* "~A => ~A~%" ',forms `(,,@forms)))
  #-swank (declare (ignore forms)))

(declaim (inline println))
(defun println (obj &optional (stream *standard-output*))
  (let ((*read-default-float-format* 'double-float))
    (prog1 (princ obj stream) (terpri stream))))

(defconstant +mod+ 1000000007)

;;;
;;; Body
;;;


(defstruct state
  (d 0 :type uint16)
  (cs nil :type (simple-array uint8 (*)))
  (ss nil :type (simple-array uint32 (365 26)))
  (schedule nil :type (simple-array uint8 (*)))
  (history-table nil :type (simple-array (simple-array int16 (*)) (26)))
  (ends nil :type (simple-array uint16 (*)))
  (score 0 :type fixnum))

(defun make-state-from (d cs ss schedule)
  (declare #.OPT
           (uint32 d)
           ((simple-array uint8 (*)) cs schedule)
           ((simple-array uint32 (* *)) ss))
  (let ((history-table (make-array 26 :element-type '(simple-array int16 (*))))
        (ends (make-array 26 :element-type 'uint16 :initial-element 1)))
    (dotimes (i 26)
      (let ((history (make-array (+ d 2) :element-type 'int16)))
        (setf (aref history 0) -1)
        (setf (aref history-table i) history)))
    (dotimes (i d)
      (let ((type (aref schedule i)))
        (setf (aref (aref history-table type) (aref ends type)) i)
        (incf (aref ends type))))
    (dotimes (i 26)
      (setf (aref (aref history-table i) (aref ends i)) d)
      (incf (aref ends i)))
    (let* ((prevs (make-array 26 :element-type 'int32 :initial-element -1))
           (score 0))
      (declare (fixnum score))
      (dotimes (i d)
        (let ((type (aref schedule i)))
          (incf score (aref ss i type))
          (setf (aref prevs type) i)
          (dotimes (j 26)
            (decf score (* (aref cs j) (- i (aref prevs j)))))))
      (make-state :d d
                  :cs cs
                  :ss ss
                  :schedule schedule
                  :history-table history-table
                  :ends ends
                  :score score))))

(defun state-update! (state day new-type &optional old-pos new-pos)
  (declare #.OPT
           (uint16 day new-type)
           ((or null uint16) old-pos new-pos))
  (symbol-macrolet ((score (state-score state))
                    (cs (state-cs state))
                    (ss (the (simple-array uint32 (365 26)) (state-ss state)))
                    (history-table (state-history-table state))
                    (ends (state-ends state)))
    (let* ((old-type (aref (state-schedule state) day))
           (old-history (aref history-table old-type))
           (new-history (aref history-table new-type)))
      (declare ((array int16 (*)) old-history new-history))
      ;; delete old type
      (decf score (aref ss day old-type))
      (unless old-pos
        (setq old-pos (bisect-left old-history day :end (aref ends old-type))))
      (let* ((pos old-pos)
             (prev-day (aref old-history (- pos 1)))
             (next-day (aref old-history (+ pos 1))))
        ;; (assert (= day (aref old-history pos)))
        (decf score (* (aref cs old-type) (- day prev-day) (- next-day day)))
        (loop for i from pos below (aref ends old-type)
              do (rotatef (aref old-history i) (aref old-history (+ i 1))))
        (decf (aref ends old-type)))
      ;; add new type 
      (incf score (aref ss day new-type))
      (unless new-pos
        (setq new-pos (bisect-left new-history day :end (aref ends new-type))))
      (let* ((pos new-pos)
             (next-day (aref new-history pos))
             (prev-day (aref new-history (- pos 1))))
        ;; (assert (< day (aref new-history pos)))
        (incf score (* (aref cs new-type) (- day prev-day) (- next-day day)))
        (setf (aref new-history (aref ends new-type)) day)
        (loop for i from (aref ends new-type) above pos
              do (rotatef (aref new-history i) (aref new-history (- i 1))))
        (incf (aref ends new-type)))
      (setf (state-score state) score)
      (setf (aref (state-schedule state) day) new-type)
      (values state old-pos new-pos))))

(defun state-eval-update (state day new-type)
  (declare #.OPT
           (uint16 day new-type))
  (symbol-macrolet ((cs (state-cs state))
                    (ss (the (simple-array uint32 (365 26)) (state-ss state)))
                    (history-table (state-history-table state))
                    (ends (state-ends state)))
    (let* ((score (state-score state))
           (old-type (aref (state-schedule state) day))
           (old-history (aref history-table old-type))
           (new-history (aref history-table new-type)))
      (declare (int32 score)
               ((array int16 (*)) old-history new-history))
      ;; delete old type
      (decf score (aref ss day old-type))
      (let* ((old-pos (bisect-left old-history day :end (aref ends old-type)))
             (prev-day (aref old-history (- old-pos 1)))
             (next-day (aref old-history (+ old-pos 1))))
        ;; (assert (= day (aref old-history old-pos)))
        (decf score (* (aref cs old-type) (- day prev-day) (- next-day day)))
        ;; add new type 
        (incf score (aref ss day new-type))
        (let* ((new-pos (bisect-left new-history day :end (aref ends new-type)))
               (next-day (aref new-history new-pos))
               (prev-day (aref new-history (- new-pos 1))))
          ;; (assert (< day (aref new-history new-pos)))
          (incf score (* (aref cs new-type) (- day prev-day) (- next-day day)))
          (values score old-pos new-pos))))))

(declaim (inline calc-prob))
(defun calc-prob (prev-score new-score temp)
  (declare (int32 prev-score new-score)
           (double-float temp))
  (if (>= new-score prev-score)
      1d0
      (exp (/ (- new-score prev-score) temp))))

(defun anneal (state &optional (time 1.5d0))
  (declare #.OPT
           (double-float time))
  (let* ((opt-schedule (copy-seq (state-schedule state)))
         (opt-score (state-score state))
         (start-temp 1000d0)
         (end-temp 10d0)
         (loop-count 0))
    (declare (fixnum loop-count opt-score)
             (double-float start-temp end-temp))
    (sb-int:with-progressive-timeout (rem-time :seconds time)
      (loop
        (incf loop-count)
        (let ((rem-time (float (rem-time) 1d0)))
          (when (zerop rem-time)
            (return))
          (if (zerop (random 4))
              (let* ((day (random (state-d state)))
                     (old-type (aref (state-schedule state) day))
                     (new-type (random 26))
                     (old-score (state-score state)))
                (unless (= old-type new-type)
                  ;; tmp. update
                  (multiple-value-bind (new-score old-pos new-pos)
                      (state-eval-update state day new-type)
                    (let* ((temp (+ end-temp (/ (* rem-time (- start-temp end-temp)) time)))
                           (prob (calc-prob old-score new-score temp)))
                      (declare (double-float temp))
                      (when (<= (random 1.0) prob)
                        (state-update! state day new-type old-pos new-pos)
                        (when (> new-score opt-score)
                          (setq opt-schedule (copy-seq (state-schedule state))
                                opt-score new-score)))))))
              (let* ((width (+ 1 (random 16)))
                     (day (random (- (state-d state) width)))
                     (type1 (aref (state-schedule state) day))
                     (type2 (aref (state-schedule state) (+ day width)))
                     (old-score (state-score state)))
                (unless (= type1 type2)
                  (multiple-value-bind (_ old-pos1 new-pos1)
                      (state-update! state day type2)
                    (multiple-value-bind (new-score old-pos2 new-pos2)
                        (state-eval-update state (+ day width) type1)
                      (let* ((temp (+ end-temp (/ (* rem-time (- start-temp end-temp)) time)))
                             (prob (calc-prob old-score new-score temp)))
                        (declare (double-float temp))
                        (if (<= (random 1.0) prob)
                            (progn
                              (state-update! state (+ day width) type1 old-pos2 new-pos2)
                              (when (> new-score opt-score)
                                (setq opt-schedule (copy-seq (state-schedule state))
                                      opt-score new-score)))
                            (state-update! state day type1 new-pos1 old-pos1)))))))))))
    #>loop-count
    (values opt-schedule opt-score)))

(defun print* (state)
  (write-string
   (with-output-to-string (*standard-output* nil :element-type 'base-char)
     (loop for x across state
           do (println (+ x 1))))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +beam-width+ 400))

(defun make-initial-schedule (d cs ss)
  (declare #.OPT
           (uint16 d)
           ((simple-array uint8 (*)) cs)
           ((simple-array uint32 (365 26)) ss))
  (let* (;; score schedule prevs
         (que1 (make-array #.(* +beam-width+ 26) :element-type 'int32))
         (que2 (make-array #.(* +beam-width+ 26) :element-type t))
         (que3 (make-array #.(* +beam-width+ 26) :element-type t))
         (new-que1 (make-array #.(* +beam-width+ 26) :element-type 'int32))
         (new-que2 (make-array #.(* +beam-width+ 26) :element-type t))
         (new-que3 (make-array #.(* +beam-width+ 26) :element-type t))
         (end 0)
         (new-end 0))
    (declare ((simple-array int32 (*)) que1 new-que1)
             ((simple-array t (*)) que2 new-que2 que3 new-que3)
             (uint31 end new-end))
    (setf (aref que1 0) 0
          (aref que2 0) nil
          (aref que3 0) (make-array 26 :element-type 'int16 :initial-element -1))
    (incf end)
    (dotimes (i d)
      (loop for j below (min +beam-width+ end)
            for base-score of-type int32 = (aref que1 j)
            for schedule of-type list = (aref que2 j)
            for prevs of-type (simple-array int16 (*)) = (aref que3 j)
            do (dotimes (type 26)
                 (decf base-score (* (aref cs type) (- i (aref prevs type)))))
               (dotimes (type 26)
                 (let ((new-score (+ base-score
                                     (aref ss i type)
                                     (* (aref cs type) (- i (aref prevs type)))))
                       (new-prevs (copy-seq prevs)))
                   (setf (aref new-prevs type) i)
                   (setf (aref new-que1 new-end) new-score
                         (aref new-que2 new-end) (cons type schedule)
                         (aref new-que3 new-end) new-prevs)
                   (incf new-end))))
      (parallel-sort! new-que1 new-que2 new-que3 new-end)
      (rotatef que1 new-que1)
      (rotatef que2 new-que2)
      (rotatef que3 new-que3)
      (setq end new-end
            new-end 0))
    (coerce (reverse (aref que2 0)) '(simple-array uint8 (*)))))

(defun main ()
  (declare #.OPT)
  (let* ((d (read))
         (cs #-swank (sb-int:make-static-vector 26)
             #+swank (make-array 26 :element-type 'uint8 :initial-element 0))
         (ss (make-array (list d 26) :element-type 'uint32 :initial-element 0)))
    (dotimes (i 26)
      (setf (aref cs i) (read-fixnum)))
    (dotimes (i d)
      (dotimes (j 26)
        (setf (aref ss i j) (read-fixnum))))
    ;; #>ss
    (let* ((init-schedule (make-initial-schedule d cs ss))
           (init-state (make-state-from d cs ss init-schedule)))
      ;; #>init-state
      ;; #>(state-score init-state)
      ;; (print* init-state)
      ;; (loop for x across (initialize-scores d cs ss init-state) sum x)
      (multiple-value-bind (schedule score) (anneal init-state)
        (let ((result-state (make-state-from d cs ss schedule)))
          (assert (= score (state-score result-state))))
        (print* schedule)
        score))))

;; #+linux
;; (eval-when (:compile-toplevel :load-toplevel :execute)
;;   (require :sb-sprof))
;; #+linux
;; (sb-sprof:start-profiling)

#-swank (main)

;; #+linux
;; (progn
;;   (sb-sprof:stop-profiling)
;;   (sb-sprof:report))

;;;
;;; Test and benchmark
;;;

#+swank
(defun io-equal (in-string out-string &key (function #'main) (test #'equal))
  "Passes IN-STRING to *STANDARD-INPUT*, executes FUNCTION, and returns true if
the string output to *STANDARD-OUTPUT* is equal to OUT-STRING."
  (labels ((ensure-last-lf (s)
             (if (eql (uiop:last-char s) #\Linefeed)
                 s
                 (uiop:strcat s uiop:+lf+))))
    (funcall test
             (ensure-last-lf out-string)
             (with-output-to-string (out)
               (let ((*standard-output* out))
                 (with-input-from-string (*standard-input* (ensure-last-lf in-string))
                   (funcall function)))))))

#+swank
(defun get-clipbrd ()
  (with-output-to-string (out)
    (run-program "powershell.exe" '("-Command" "Get-Clipboard") :output out :search t)))

#+swank (defparameter *this-pathname* (uiop:current-lisp-file-pathname))
#+swank (defparameter *dat-pathname* (uiop:merge-pathnames* "test.dat" *this-pathname*))

#+swank
(defun run (&optional thing (out *standard-output*))
  "THING := null | string | symbol | pathname

null: run #'MAIN using the text on clipboard as input.
string: run #'MAIN using the string as input.
symbol: alias of FIVEAM:RUN!.
pathname: run #'MAIN using the text file as input."
  (let ((*standard-output* out))
    (etypecase thing
      (null
       (with-input-from-string (*standard-input* (delete #\Return (get-clipbrd)))
         (main)))
      (string
       (with-input-from-string (*standard-input* (delete #\Return thing))
         (main)))
      (symbol (5am:run! thing))
      (pathname
       (with-open-file (*standard-input* thing)
         (main))))))

#+swank
(defun gen-dat (seed)
  (uiop:with-output-file (out *dat-pathname* :if-exists :supersede)
    (let ((state (seed-random-state seed)))
      (format out "365~%")
      (dotimes (i 26)
        (println (random 101 state) out))
      (dotimes (i 365)
        (dotimes (j 26)
          (println (random 20001 state) out))))))

#+swank
(defun bench ()
  (let ((*random-state* (seed-random-state 0)))
    (loop for i below 10
          do (gen-dat i)
          sum #>(run *dat-pathname*))))


Measured memory_bytes: 86216