提出 #9278348

---

ソースコード 拡げる

;; -*- coding: utf-8 -*-
(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))
  #-swank (set-dispatch-macro-character #\# #\> (lambda (s c p) (declare (ignore c p)) (read s nil (values) t))))
#+swank (cl-syntax:use-syntax cl-debug-print:debug-print-syntax)
#-swank (disable-debugger) ; for CS Academy

;; BEGIN_INSERTED_CONTENTS
(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)
         `(progn
            (assert (<= start end))
            (if (= start end) end
                (labels
                    ((%bisect-left (left ok)
                       ;; TARGET[OK] >= VALUE always holds (assuming
                       ;; TARGET[END] = +infinity)
                       ,@(when declaration (list declaration))
                       (let ((mid (ash (+ left ok) -1)))
                         (if (= mid left)
                             (if (funcall order (funcall key (,accessor target left)) value)
                                 ok
                                 left)
                             (if (funcall order (funcall key (,accessor target mid)) value)
                                 (%bisect-left mid ok)
                                 (%bisect-left left mid))))))
                  (%bisect-left start end))))))
    (etypecase target
      (vector
       (let ((end (or end (length target))))
         (frob aref (declare ((integer 0 #.most-positive-fixnum) left ok)))))
      (function
       (assert end () "Requires END argument if TARGET is a function.")
       (frob funcall)))))

;;;
;;; Binary heap to change priorities of arbitrary keys
;;;

(define-condition kheap-empty-error (error)
  ((heap :initarg :heap :reader kheap-empty-error-heap))
  (:report
   (lambda (condition stream)
     (format stream "Attempted to get an element from empty heap ~W" (kheap-empty-error-heap condition)))))

(define-condition kheap-duplicate-keys-error (error)
  ((heap :initarg :heap :reader kheap-duplicate-keys-error-heap)
   (key :initarg :key :reader kheap-duplicate-keys-error-key))
  (:report
   (lambda (condition stream)
     (format stream "Attempted to push an existing key ~W to ~W"
             (kheap-duplicate-keys-error-key condition)
             (kheap-duplicate-keys-error-heap condition)))))

(defstruct (kheap
            (:constructor make-kheap
                (size max-key
                 &aux
                 (keys (make-array (1+ size) :element-type '(integer 0 #.most-positive-fixnum)))
                 (priorities (make-array (1+ size) :element-type 'fixnum))
                 (table (make-array (1+ max-key) :element-type 'fixnum :initial-element -1)))))
  (keys nil :type (simple-array (integer 0 #.most-positive-fixnum) (*)))
  (priorities nil :type (simple-array fixnum (*)))
  (table nil :type (simple-array fixnum (*)))
  (end 1 :type (integer 1 #.array-total-size-limit)))

(defun kheap-ensure-key (key priority heap)
  (declare #.OPT
           ((mod #.array-total-size-limit) key)
           (fixnum priority))
  (symbol-macrolet ((end (kheap-end heap)))
    (when (>= end (length (kheap-keys heap)))
      (let ((new-size (min (* end 2) #.(- array-total-size-limit 1))))
        (setf (kheap-keys heap)
              (adjust-array (kheap-keys heap) new-size)
              (kheap-priorities heap)
              (adjust-array (kheap-priorities heap) new-size))))
    (let ((keys (kheap-keys heap))
          (priorities (kheap-priorities heap))
          (table (kheap-table heap)))
      (labels
          ((heapify-up (pos)
             (unless (= pos 1)
               (let ((parent-pos (ash pos -1)))
                 (when (> (aref priorities pos) (aref priorities parent-pos))
                   (rotatef (aref table key) (aref table (aref keys parent-pos)))
                   (rotatef (aref keys pos) (aref keys parent-pos))
                   (rotatef (aref priorities pos) (aref priorities parent-pos))
                   (heapify-up parent-pos)))))
           (heapify-down (pos)
             (let* ((cpos1 (+ pos pos))
                    (cpos2 (+ 1 cpos1)))
               (when (< cpos1 end)
                 (if (< cpos2 end)
                     (if (> (aref priorities cpos1) (aref priorities cpos2))
                         (when (> (aref priorities cpos1) (aref priorities pos))
                           (rotatef (aref table key) (aref table (aref keys cpos1)))
                           (rotatef (aref keys pos) (aref keys cpos1))
                           (rotatef (aref priorities pos) (aref priorities cpos1))
                           (heapify-down cpos1))
                         (when (> (aref priorities cpos2) (aref priorities pos))
                           (rotatef (aref table key) (aref table (aref keys cpos2)))
                           (rotatef (aref keys pos) (aref keys cpos2))
                           (rotatef (aref priorities pos) (aref priorities cpos2))
                           (heapify-down cpos2)))
                     (when (> (aref priorities cpos1) (aref priorities pos))
                       (rotatef (aref table key) (aref table (aref keys cpos1)))
                       (rotatef (aref keys pos) (aref keys cpos1))
                       (rotatef (aref priorities pos) (aref priorities cpos1))))))))
        (let ((pos (aref table key)))
          (if (= pos -1)
              (progn
                (setf (aref keys end) key
                      (aref priorities end) priority
                      (aref table key) end)
                (heapify-up end)
                (incf end))
              (let ((prev-priority (aref priorities pos)))
                (setf (aref priorities pos)
                      (+ prev-priority priority))
                (if (> prev-priority (aref priorities pos))
                    (heapify-down pos)
                    (heapify-up pos)))))
        heap))))

(declaim (inline kheap-peek))
(defun kheap-peek (heap)
  "Returns the topmost element of HEAP, key and its priority."
  (if (= 1 (kheap-end heap))
      (error 'kheap-empty-error :heap heap)
      (values (aref (kheap-keys heap) 1)
              (aref (kheap-priorities heap) 1))))

(defun delete-adjacent-duplicates (seq)
  "Destructively deletes adjacent duplicates of SEQ: e.g. #(1 1 1 2 2 1 3) ->
#(1 2 1 3)"
  (declare #.OPT
           ((simple-array (unsigned-byte 31) (*)) seq))
  (if (zerop (length seq))
      seq
      (let ((prev (aref seq 0))
            (end 1))
        (loop for pos from 1 below (length seq)
              unless (= prev (aref seq pos))
              do (setf prev (aref seq pos)
                       (aref seq end) (aref seq pos)
                       end (+ 1 end)))
        (adjust-array seq end))))

(defmacro with-output-buffer (&body body)
  "Buffers all outputs to *STANDARD-OUTPUT* in BODY and flushes them to
*STANDARD-OUTPUT* after BODY has been done (without error). Note that only
BASE-CHAR is allowed."
  (let ((out (gensym)))
    `(let ((,out (make-string-output-stream :element-type 'base-char)))
       (let ((*standard-output* ,out))
         ,@body)
       (write-string (get-output-stream-string ,out)))))

(declaim (ftype (function * (values fixnum &optional)) read-fixnum+))
(defun read-fixnum+ (&optional (in *standard-input*))
  (declare #.OPT
           #-swank (sb-kernel:ansi-stream in))
  (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* ((result (loop (let ((byte (%read-byte)))
                           (cond ((<= 48 byte 57)
                                  (return (- byte 48)))
                                 ((zerop byte) ; #\Nul
                                  (error "Read EOF or #\Nul.")))))))
      (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 result)))))))
 
;;;
;;; Mo's algorithm
;;;
 
(deftype mo-integer () '(unsigned-byte 31))
 
(defstruct (mo (:constructor %make-mo
                   (lefts rights order width))
               (:conc-name %mo-)
               (:copier nil)
               (:predicate nil))
  (lefts nil :type (simple-array mo-integer (*)))
  (rights nil :type (simple-array mo-integer (*)))
  (order nil :type (simple-array mo-integer (*)))
  (width 0 :type (integer 0 #.most-positive-fixnum))
  (index 0 :type (integer 0 #.most-positive-fixnum))
  (posl 0 :type mo-integer)
  (posr 0 :type mo-integer))
 
(defun make-mo (bucket-width lefts rights)
  (declare #.OPT
           ((simple-array mo-integer (*)) lefts rights)
           ((integer 0 #.most-positive-fixnum) bucket-width)
           (inline sort))
  (let* ((q (length lefts))
         (order (make-array q :element-type 'mo-integer)))
    (assert (= q (length rights)))
    (dotimes (i q) (setf (aref order i) i))
    (setf order (sort order
                      (lambda (x y)
                        (if (= (floor (aref lefts x) bucket-width)
                               (floor (aref lefts y) bucket-width))
                            ;; Even-number [Odd-number] block is in ascending
                            ;; [descending] order w.r.t. the right boundary.
                            (if (evenp (floor (aref lefts x) bucket-width))
                                (< (aref rights x) (aref rights y))
                                (> (aref rights x) (aref rights y)))
                            (< (aref lefts x) (aref lefts y))))))
    (%make-mo lefts rights order bucket-width)))

(declaim (inline mo-get-next))
(defun mo-get-next (mo)
  "Returns the original index of the next query."
  (aref (%mo-order mo) (%mo-index mo)))

(declaim (inline mo-get-previous))
(defun mo-get-previous (mo)
  "Returns the previous index of the current query. Returns the initial index
when no queries are processed yet."
  (aref (%mo-order mo) (max 0 (- (%mo-index mo) 1))))

(declaim (inline mo-process))
(defun mo-process (mo extend shrink)
  "Processes the next query."
  (declare (function extend shrink))
  (let* ((ord (mo-get-next mo))
         (left (aref (%mo-lefts mo) ord))
         (right (aref (%mo-rights mo) ord))
         (posl (%mo-posl mo))
         (posr (%mo-posr mo)))
    (declare ((integer 0 #.most-positive-fixnum) posl posr))
    (loop while (< left posl)
          do (decf posl)
             (funcall extend posl))
    (loop while (< posr right)
          do (funcall extend posr)
             (incf posr))
    (loop while (< posl left)
          do (funcall shrink posl)
             (incf posl))
    (loop while (< right posr)
          do (decf posr)
             (funcall shrink posr))
    (setf (%mo-posl mo) posl
          (%mo-posr mo) posr)
    (incf (%mo-index mo))))

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

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

(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

(defun main ()
  (declare #.OPT
           (inline sort))
  (let* ((n (read))
         (q (read))
         (xs (make-array n :element-type 'uint31))
         (ls (make-array q :element-type 'uint31))
         (rs (make-array q :element-type 'uint31))
         (res (make-array q :element-type 'uint62)))
    (declare (uint31 n q))
    (dotimes (i n)
      (setf (aref xs i) (read-fixnum+)))
    (dotimes (i q)
      (setf (aref ls i) (- (read-fixnum+) 1)
            (aref rs i) (read-fixnum+)))
    (let* ((xs-sorted (delete-adjacent-duplicates (sort (copy-seq xs) #'<)))
           (mo (make-mo (isqrt n) ls rs))
           (heap (make-kheap (length xs-sorted) (length xs-sorted))))
      (declare ((simple-array uint31 (*)) xs-sorted))
      (dotimes (i n)
        (setf (aref xs i) (bisect-left xs-sorted (aref xs i))))
      (dotimes (i q)
        (let ((q-idx (mo-get-next mo)))
          (mo-process
           mo
           (lambda (idx)
             (let ((x (aref xs idx)))
               (kheap-ensure-key x (aref xs-sorted x) heap)))
           (lambda (idx)
             (let ((x (aref xs idx)))
               (kheap-ensure-key x (- (aref xs-sorted x)) heap))))
          (setf (aref res q-idx) (nth-value 1 (kheap-peek heap))))))
    (with-output-buffer (dotimes (i q) (println (aref res i))))))

#-swank(main)

;; For Test
#+swank
(defun io-equal (in-string out-string &optional (func #'main))
  "Passes IN-STRING to *STANDARD-INPUT*, executes FUNC, and returns true if the
string output to *STANDARD-OUTPUT* is equal to OUT-STRING."
  (labels ((ensure-last-lf (s)
             (if (and (> (length s) 0)
                      (eql (char s (- (length s) 1)) #\Linefeed))
                 s
                 (uiop:strcat s uiop:+lf+))))
    (equal (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 func)))))))

#+swank
(defun get-clipbrd ()
  (with-output-to-string (out)
    (run-program "C:/msys64/usr/bin/cat.exe" '("/dev/clipboard") :output out)))

#+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*))
  (let ((*standard-output* out))
    (etypecase thing
      (null ; Runs #'MAIN with the string on clipboard
       (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 ; Runs #'MAIN with the string in a text file
       (with-open-file (*standard-input* thing)
         (main))))))

#+swank
(defun gen-dat ()
  (uiop:with-output-file (out *dat-pathname* :if-exists :supersede)
    (format out "")))

#+swank
(defun bench (&optional (out (make-broadcast-stream)))
  (time (run *dat-pathname* out)))

#+swank
(5am:test :sample
  (5am:is (io-equal "5 5
9 8 7 8 9
1 2
3 4
4 4
1 4
2 4
"
                    "9
8
8
16
16
"))
  (5am:is (io-equal "8 4
9 9 19 9 9 15 9 19
1 4
4 6
3 5
5 8
"
                    "27
18
19
19
"))
  (5am:is (io-equal "12 15
15 9 3 15 9 3 3 8 16 9 3 17
2 7
2 5
2 2
1 12
4 12
3 6
11 12
1 7
2 6
3 5
3 10
7 10
1 4
4 8
4 8
"
                    "18
18
9
30
18
15
17
30
18
15
18
16
30
15
15
")))

提出情報

ジャッジ結果