Submission #8424641

---

Source Code Expand

;; -*- 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) :silent t)
  #-swank (set-dispatch-macro-character
           ;; enclose the form with VALUES to avoid being captured by LOOP macro
           #\# #\> (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

;; BEGIN_INSERTED_CONTENTS

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

;;;
;;; Modular arithmetic
;;;

;; Blankinship algorithm
;; Reference: https://topcoder.g.hatena.ne.jp/spaghetti_source/20130126/1359171466 (Japanese)
(declaim (ftype (function * (values fixnum fixnum &optional)) %ext-gcd))
(defun %ext-gcd (a b)
  (declare (optimize (speed 3) (safety 0))
           (fixnum a b))
  (let ((y 1)
        (x 0)
        (u 1)
        (v 0))
    (declare (fixnum y x u v))
    (loop (when (zerop a)
            (return (values x y)))
          (let ((q (floor b a)))
            (decf x (the fixnum (* q u)))
            (rotatef x u)
            (decf y (the fixnum (* q v)))
            (rotatef y v)
            (decf b (the fixnum (* q a)))
            (rotatef b a)))))

;; recursive version
;; (defun %ext-gcd (a b)
;;   (declare (optimize (speed 3) (safety 0))
;;            (fixnum a b))
;;   (if (zerop b)
;;       (values 1 0)
;;       (multiple-value-bind (p q) (floor a b) ; a = pb + q
;;         (multiple-value-bind (v u) (%ext-gcd b q)
;;           (declare (fixnum u v))
;;           (values u (the fixnum (- v (the fixnum (* p u)))))))))

(declaim (inline mod-inverse)
         (ftype (function * (values (mod #.most-positive-fixnum) &optional)) mod-inverse))
(defun mod-inverse (a modulus)
  "Solves ax ≡ 1 mod m. A and M must be coprime."
  (declare (integer a)
           ((integer 1 #.most-positive-fixnum) modulus))
  (mod (%ext-gcd a modulus) modulus))

;; Should we do this with UNWIND-PROTECT?
(defmacro with-buffered-stdout (&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)))))

;;;
;;; Arithmetic operations with static modulus
;;;

(defmacro define-mod-operations (divisor)
  `(progn
     (defun mod* (&rest args)
       (reduce (lambda (x y) (mod (* x y) ,divisor)) args))

     (sb-c:define-source-transform mod* (&rest args)
       (if (null args)
           1
           (reduce (lambda (x y) `(mod (* ,x ,y) ,',divisor)) args)))

     (defun mod+ (&rest args)
       (reduce (lambda (x y) (mod (+ x y) ,divisor)) args))

     (sb-c:define-source-transform mod+ (&rest args)
       (if (null args)
           0
           (reduce (lambda (x y) `(mod (+ ,x ,y) ,',divisor)) args)))

     (define-modify-macro incfmod (delta)
       (lambda (x y) (mod (+ x y) ,divisor)))

     (define-modify-macro decfmod (delta)
       (lambda (x y) (mod (- x y) ,divisor)))

     (define-modify-macro mulfmod (multiplier)
       (lambda (x y) (mod (* x y) ,divisor)))))

;;;
;;; Disjoint sparse table on arbitrary semigroup
;;;

;;; Reference:
;;; https://discuss.codechef.com/questions/117696/tutorial-disjoint-sparse-table
;;; http://noshi91.hatenablog.com/entry/2018/05/08/183946 (Japanese)
;;; http://drken1215.hatenablog.com/entry/2018/09/08/162600 (Japanese)

;; NOTE: This constructor is slow on SBCL version earlier than 1.5.6 as the type
;; propagation of MAKE-ARRAY doesn't work. The following files are required to
;; enable the optimization.
;; version < 1.5.0: array-element-type.lisp, make-array-header.lisp
;; version < 1.5.6: make-array-header.lisp
(defun make-disjoint-sparse-table (vector)
  "BINOP := binary operator (comprising a semigroup)"
  (declare (optimize (speed 3) (safety 0))
           ((simple-array uint31 (*)) vector))
  (let* ((n (length vector))
         (height (max 1 (integer-length (- n 1))))
         (table (make-array (list height n) :element-type 'uint62)))
    (dotimes (j n)
      (setf (aref table 0 j) (aref vector j)))
    (do ((i 1 (+ i 1)))
        ((>= i height))
      (let* ((width/2 (ash 1 i))
             (width (* width/2 2)))
        (do ((j 0 (+ j width)))
            ((>= j n))
          (let ((mid (min (+ j width/2) n)))
            ;; fill the first half
            (setf (aref table i (- mid 1))
                  (aref vector (- mid 1)))
            (do ((k (- mid 2) (- k 1)))
                ((< k j))
              (setf (aref table i k)
                    (lcm (aref vector k) (aref table i (+ k 1)))))
            (when (>= mid n)
              (return))
            ;; fill the second half
            (setf (aref table i mid)
                  (aref vector mid))
            (let ((end (min n (+ mid width/2))))
              (do ((k (+ mid 1) (+ k 1)))
                  ((>= k end))
                (setf (aref table i k)
                      (lcm (aref table i (- k 1)) (aref vector k)))))))))
    table))

(declaim (inline dst-query))
(defun dst-query (table left right &optional identity)
  "Queries the interval [LEFT, RIGHT). Returns IDENTITY for a null interval [x,
x)."
  (declare ((integer 0 #.most-positive-fixnum) left right)
           ((simple-array * (* *)) table))
  (when (>= left right)
    (return-from dst-query identity))
  (setq right (- right 1)) ;; change to closed interval
  (if (= left right)
      (aref table 0 left)
      (let ((h (- (integer-length (logxor left right)) 1)))
        (lcm (aref table h left) (aref table h right)))))

(declaim (inline decompose-to-cycles))
(defun decompose-to-cycles (permutation)
  "Returns the list of all the cyclic permutations in a given permutation of {0,
1, ..., N-1}"
  (declare (vector permutation))
  (let* ((n (length permutation))
         result
         (visited (make-array n :element-type 'bit :initial-element 0)))
    (dotimes (init n)
      (when (zerop (sbit visited init))
        (push (loop for x = init then (aref permutation x)
                    until (= (sbit visited x) 1)
                    collect x
                    do (setf (sbit visited x) 1))
              result)))
    result))

(declaim (ftype (function * (values fixnum &optional)) read-fixnum))
(defun read-fixnum (&optional (in *standard-input*))
  (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 #\-))
                                  (setf 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))))))))

;;;
;;; 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 (integer 0 #.most-positive-fixnum) (*)))
  (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)
  "TOTAL-WIDTH is the width of the interval on which the queries exist. (NOT the
number of queries.)"
  (declare (optimize (speed 3) (safety 0))
           ((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 '(integer 0 #.most-positive-fixnum))))
    (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-current))
(defun mo-get-current (mo)
  "Returns the original index of the current 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. EXTEND and SHRINK take three arguments: the index
added or deleted, and both ends of the current range: [LEFT, RIGHT)"
  (declare (function extend shrink))
  (let* ((ord (mo-get-current 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 posl posr))
    (loop while (< posr right)
          do (funcall extend posr posl (+ posr 1))
             (incf posr))
    (loop while (< posl left)
          do (funcall shrink posl (+ posl 1) posr)
             (incf posl))
    (loop while (< right posr)
          do (decf posr)
             (funcall shrink posr posl 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)))

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

(define-mod-operations +mod+)
(defun main ()
  (declare #.OPT)
  (let* ((n (read))
         (q (read))
         (ps (make-array n :element-type 'uint31))
         (ls (make-array q :element-type 'uint31))
         (rs (make-array q :element-type 'uint31)))
    (declare (uint31 n q))
    (dotimes (i n)
      (setf (aref ps i) (- (read-fixnum) 1)))
    (dotimes (i q)
      (let ((l (- (read-fixnum) 1))
            (r (read-fixnum)))
        (setf (aref ls i) l
              (aref rs i) r)))
    (let* ((cycles (coerce (decompose-to-cycles ps) '(simple-array list (*))))
           (len (length cycles))
           (perimeters (make-array len :element-type 'uint31))
           (perim-invs (make-array len :element-type 'uint31))
           (point-perimeters (make-array n :element-type 'uint31))
           (sums (make-array len :element-type 'uint31))
           (cycle-dict (make-array n :element-type 'uint31))
           (res (make-array q :element-type 'uint31)))
      (dotimes (i len)
        (let ((sum 0)
              (perimeter 0))
          (declare (uint31 sum perimeter))
          (dolist (v (aref cycles i))
            (declare (uint31 v))
            (incfmod sum v)
            (incf perimeter)
            (setf (aref cycle-dict v) i))
          (setf (aref sums i) sum
                (aref perimeters i) perimeter
                (aref perim-invs i) (mod-inverse perimeter +mod+))))
      (dotimes (i n)
        (let ((j (aref cycle-dict i)))
          (setf (aref point-perimeters i) (aref perimeters j))))
      (let* ((dtable (make-disjoint-sparse-table point-perimeters))
             (mo (make-mo 1000 ls rs))
             (value 0)
             (lcm 1)
             (/lcm 1)
             (original-idx 0))
        (declare ((simple-array uint62 (* *)) dtable)
                 (uint31 value original-idx lcm /lcm))
        (dotimes (_ q)
          (setq original-idx (mo-get-current mo))
          (mo-process
           mo
           (lambda (pos l r)
             (let* ((cycle-idx (aref cycle-dict pos))
                    (sum (aref sums cycle-idx))
                    (new-lcm (mod (the uint62 (dst-query dtable l r 1)) +mod+))
                    (ratio (mod* new-lcm /lcm))
                    (perimeter (aref perimeters cycle-idx))
                    (/perimeter (aref perim-invs cycle-idx)))
               (declare (uint31 cycle-idx perimeter /perimeter lcm ratio sum))
               (mulfmod value ratio)
               (incfmod value (mod* (the uint31 (+ perimeter sum)) (mod* new-lcm /perimeter)))
               (unless (= lcm new-lcm)
                 (setq lcm new-lcm
                       /lcm (mod-inverse new-lcm +mod+)))))
           (lambda (pos l r)
             (let* ((cycle-idx (aref cycle-dict pos))
                    (sum (aref sums cycle-idx))
                    (new-lcm (mod (the uint62 (dst-query dtable l r 1)) +mod+))
                    (ratio (mod* new-lcm /lcm))
                    (perimeter (aref perimeters cycle-idx))
                    (/perimeter (aref perim-invs cycle-idx)))
               (declare (uint31 cycle-idx perimeter /perimeter new-lcm ratio sum))
               (mulfmod value ratio)
               (incfmod value (the uint31 (- +mod+ (mod* (the uint31 (+ perimeter sum))
                                                         (mod* new-lcm /perimeter)))))
               (unless (= lcm new-lcm)
                 (setq lcm new-lcm
                       /lcm (mod-inverse new-lcm +mod+))))))
          (setf (aref res original-idx) value)))
      (with-buffered-stdout
        (map () #'println res)))))

#-swank (main)

Submission Info

Judge Result