結果

問題 No.142 単なる配列の操作に関する実装問題
ユーザー motoshiramotoshira
提出日時 2021-03-22 23:12:57
言語 Common Lisp
(sbcl 2.3.8)
結果
RE  
実行時間 -
コード長 14,207 bytes
コンパイル時間 638 ms
コンパイル使用メモリ 64,372 KB
実行使用メモリ 38,276 KB
最終ジャッジ日時 2023-08-16 02:38:25
合計ジャッジ時間 1,929 ms
ジャッジサーバーID
(参考情報)
judge14 / judge13
このコードへのチャレンジ(β)

テストケース

テストケース表示
入力 結果 実行時間
実行使用メモリ
testcase_00 RE -
testcase_01 RE -
testcase_02 RE -
testcase_03 RE -
testcase_04 RE -
権限があれば一括ダウンロードができます
コンパイルメッセージ
; compiling file "/home/judge/data/code/Main.lisp" (written 16 AUG 2023 02:38:23 AM):
; processing (IN-PACKAGE :CL-USER)
; processing (DEFVAR *OPT* ...)
; processing (DECLAIM (MUFFLE-CONDITIONS COMPILER-NOTE))
; processing (DISABLE-DEBUGGER)
; processing (PUSHNEW :INLINE-GENERIC-FUNCION ...)
; processing (DEFMACRO DEFINE-INT-TYPES ...)
; processing (DEFINE-INT-TYPES 2 ...)
; processing (DEFMACRO DBG ...)
; processing (DEFMACRO DO-REP ...)
; processing (DEFMACRO NLET ...)
; processing (DEFMACRO DOTIMES! ...)
; processing (DECLAIM (INLINE PRINTLN))
; processing (DEFUN PRINTLN ...)
; processing (DEFUN READ-NUMS ...)
; processing (DEFINE-MODIFY-MACRO MAXF ...)
; processing (DEFINE-MODIFY-MACRO MINF ...)
; processing (DEFCONSTANT +INF+ ...)
; processing (DEFTYPE %UINT ...)
; processing (DEFMACRO DEFINE-BITSET ...)
; processing (DEFINE-BITSET :SIZE ...)
; processing (DECLAIM (FTYPE # ...))
; processing (DEFUN UNWRAP ...)
; processing (DEFMACRO WITH-BUFFERED-STDOUT ...)
; processing (DECLAIM (INLINE READ-FIXNUM ...))
; processing (DEFUN READ-FIXNUM ...)
; processing (DEFUN SET! ...)
; processing (DEFUN READ-BASE-CHAR ...)
; processing (DEFMACRO READ-LINE! ...)
; processing (DEFUN SPLIT ...)
; processing (DEFUN MAIN ...)
; processing (MAIN)

; wrote /home/judge/data/code/Main.fasl
; compilation finished in 0:00:00.176

ソースコード

diff #

(in-package :cl-user)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar *opt*
    #+swank '(optimize (speed 3) (safety 2))
    #-swank '(optimize (speed 3) (safety 0) (debug 0)))
  #+swank (load "~/Dropbox/Code/atcoder/ac-tools/act.lisp")
  #+swank (ql:quickload :prove)
  #-swank (declaim (sb-ext:muffle-conditions sb-ext:compiler-note))
  #-swank (sb-ext:disable-debugger)
  (pushnew :inline-generic-funcion *features*))

(defmacro define-int-types (&rest ints)
  `(progn
     ,@(mapcar (lambda (int) `(deftype ,(intern (format nil "UINT~a" int)) () '(unsigned-byte ,int))) ints)
     ,@(mapcar (lambda (int) `(deftype ,(intern (format nil "INT~a" int)) () '(signed-byte ,int))) ints)))

(define-int-types 2 4 8 16 31 32 60 62 64 120)

(defmacro dbg (&rest forms)
  #-swank (declare (ignore forms))
  #+swank `(format *error-output* "~a => ~a~&" ',forms `(,,@forms)))

(defmacro do-rep (count &body body) `(loop repeat ,count do ,@body))

(defmacro nlet (name binds &body body)
  `(labels ((,name (,@(mapcar #'first binds))
              ,@body))
     (,name ,@(mapcar #'second binds))))

(defmacro dotimes! ((var count &optional (index-origin 0) (unroll 10)) &body body)
  #+swank (declare (ignorable unroll))
  #+swank `(loop for ,var from ,index-origin below (+ ,count ,index-origin)
                 do ,@body)
  #-swank
  (sb-int:with-unique-names (cnt q r)
    `(multiple-value-bind (,q ,r) (truncate ,count ,unroll)
       (declare (fixnum ,q ,r))
       (do ((,cnt 0 (the fixnum (1+ ,cnt))) (,var ,index-origin))
           ((>= ,cnt ,q) (loop repeat ,r do (progn ,@body (setf (the fixnum ,var) (the fixnum (1+ ,var))))))
         (declare (fixnum ,cnt ,var))
         ,@(loop repeat unroll append `(,@body (setf (the fixnum ,var) (the fixnum (1+ ,var)))))))))

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

(defun read-nums (count &optional (element-type '(simple-array fixnum (*))))
  (declare (fixnum count))
  (coerce (loop repeat count collect (read)) element-type))

(define-modify-macro maxf (var) max)
(define-modify-macro minf (var) min)

(defconstant +inf+ #.(ash 1 61))

;; bitset

(deftype %uint () '(unsigned-byte 60))

(defmacro define-bitset (&key size)
  "Define bitset which can contain integer from 0 to SIZE."
  (check-type size fixnum)
  (unless (zerop (rem size 60))
    (warn "SIZE is preferred to be multiple of 60. BITSET-COUNT may not return accurate value."))
  (let ((data-size (ceiling size 60)))
    `(progn
       (defstruct (bitset (:constructor make-bitset)
                          (:copier nil))
         (data (make-array ,data-size :element-type '%uint
                                      :initial-element 0)
          :type (simple-array %uint (,data-size))))

       (defun mask->bitset (mask)
         (declare (%uint mask))
         (let ((res (make-bitset))
               (i 0))
           (declare (bitset res)
                    (%uint i))
           (loop while (plusp mask)
                 do (when (logbitp 0 mask)
                      (bitset-add! res i))
                    (setf mask (ash mask -1)
                          i (1+ i)))
           res))

       (defun bitset-reset! (bitset)
         (declare (bitset bitset))
         (fill (bitset-data bitset) 0))

       (defun bitset-fill! (bitset)
         (declare (bitset bitset))
         (fill (bitset-data bitset) #.(1- (ash 1 60))))

       (defun bitset-ref (bitset idx)
         (declare (bitset bitset)
                  (%uint idx))
         (logand 1
                 (ash (aref (bitset-data bitset)
                            (floor idx 60))
                      (- (rem idx 60)))))

       (defun bitset-add! (bitset idx)
         (declare (bitset bitset)
                  (%uint idx))
         (setf (ldb (byte 1 (rem idx 60))
                    (aref (bitset-data bitset)
                          (floor idx 60)))
               1)
         #+swank (bitset->list bitset)
         )

       (defun bitset-rem! (bitset idx)
         (declare (bitset bitset)
                  (%uint idx))
         (setf (ldb (byte 1 (rem idx 60))
                    (aref (bitset-data bitset)
                          (floor idx 60)))
               0)
         #+swank (bitset->list bitset)
         )

       (defun bitset-flip! (bitset idx)
         (declare (bitset bitset)
                  (%uint idx))
         (setf #1=(ldb (byte 1 (rem idx 60))
                       (aref (bitset-data bitset)
                             (floor idx 60)))
               (logxor #1# 1))
         #+swank (bitset->list bitset)
         )

       (defun bitset->list (bitset)
         (loop for i of-type %uint from 0
               for mask of-type %uint across (bitset-data bitset)
               append (loop for b of-type (integer 0 60) below 60
                            when (logbitp b mask)
                              collect (+ (* i 60)
                                         b))))

       (defun bitset-unite (bs1 bs2)
         (declare (bitset bs1 bs2))
         (let ((tmp (make-bitset)))
           (declare (bitset tmp))
           (loop for i of-type %uint from 0
                 for mask1 of-type %uint across (bitset-data bs1)
                 for mask2 of-type %uint across (bitset-data bs2)
                 do (setf (aref (bitset-data tmp)
                                i)
                          (logior mask1
                                  mask2)))
           tmp))

       (defun bitset-intersect (bs1 bs2)
         (declare (bitset bs1 bs2))
         (let ((tmp (make-bitset)))
           (declare (bitset tmp))
           (loop for i of-type %uint from 0
                 for mask1 of-type %uint across (bitset-data bs1)
                 for mask2 of-type %uint across (bitset-data bs2)
                 do (setf (aref (bitset-data tmp)
                                i)
                          (logand mask1
                                  mask2)))
           tmp))

       (defun bitset-xor (bs1 bs2)
         (declare (bitset bs1 bs2))
         (let ((tmp (make-bitset)))
           (declare (bitset tmp))
           (loop for i of-type %uint from 0
                 for mask1 of-type %uint across (bitset-data bs1)
                 for mask2 of-type %uint across (bitset-data bs2)
                 do (setf (aref (bitset-data tmp)
                                i)
                          (logxor mask1
                                  mask2)))
           tmp))

       (defun copy-bitset (bitset)
         (declare (bitset bitset))
         (make-bitset :data (copy-seq (bitset-data bitset))))

       (defun bitset-count (bitset)
         (loop for mask of-type %uint across (bitset-data bitset)
               sum (logcount mask)))

       (defun bitset-ash (bitset count)
         (declare (bitset bitset)
                  (fixnum count))
         (let* ((new-bs (make-bitset))
                (sgn (if (zerop count)
                         0
                         (floor count (abs count))))
                (idx-delta (* sgn
                              (floor (abs count)
                                     60)))
                (ash-delta (* sgn
                              (rem (abs count)
                                   60))))
           (declare (bitset new-bs)
                    (fixnum sgn idx-delta ash-delta))
           (loop for i of-type %uint from 0 below ,data-size
                 for idx of-type fixnum
                   = (+ i idx-delta)
                 when (<= 0 idx (the %uint (1- ,data-size)))
                   do (let ((mask (aref (bitset-data bitset) i)))
                        (declare (%uint mask))
                        (setf #2=(aref (bitset-data new-bs) idx)
                              (the %uint
                                   (logand #.(1- (ash 1 60))
                                           (logior #2#
                                                   (ash mask ash-delta)))))
                        (when (plusp idx)
                          (setf #3=(aref (bitset-data new-bs) (1- idx))
                                (the %uint
                                     (logand #.(1- (ash 1 60))
                                             (logior #3#
                                                     (ash mask (+ ash-delta 60)))))))
                        (when (< idx (1- ,data-size))
                          (setf #4= (aref (bitset-data new-bs) (1+ idx))
                                (the %uint
                                     (logand #.(1- (ash 1 60))
                                             (logior #4#
                                                     (ash mask (- ash-delta 60)))))))))
           new-bs)))))


(define-bitset :size #.(* 60 10000))


;;
;; BOF
;;

(declaim (ftype (function (sequence) simple-base-string) unwrap))
(defun unwrap (sequence)
  ;; e.g. (unwrap (list 1 2 3 4 5)) => "1 2 3 4 5"
  (let ((*standard-output* (make-string-output-stream :element-type 'base-char)))
    (let ((init nil))
      (declare (boolean init))
      (map nil
           (lambda (x)
             (when init
               (princ #\space))
             (setq init t)
             (princ x))
           sequence))
    (coerce (get-output-stream-string *standard-output*) 'simple-base-string)))

(defmacro with-buffered-stdout (&body body)
  ;; Quoted from: https://competitive12.blogspot.com/2020/03/common-lisp.html
  (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 (inline read-fixnum read-nums println))
(defun read-fixnum (&optional (in *standard-input*))
  ;; Ref: https://competitive12.blogspot.com/2020/03/common-lisp.html
  ;;        partially modified
  (declare (inline read-byte))
  (flet ((%read-byte ()
           (the fixnum #+swank (char-code (read-char in nil #\Nul))
                       #-swank (read-byte in nil #.(char-code #\Nul))))
         (%byte->num (b)
           (the fixnum (- b #.(char-code #\0))))
         (%digit-p (byte)
           (declare (fixnum byte))
           (<= #.(char-code #\0) byte #.(char-code #\9))))
    (declare (inline %read-byte %byte->num %digit-p))
    (let ((minus nil)
          (res 0))
      (declare (boolean minus) (fixnum res))
      (loop for byte of-type fixnum = (%read-byte)
            do (cond
                 ((%digit-p byte)
                  (setf res (%byte->num byte))
                  (return))
                 ((= byte #.(char-code #\Nul))
                  (error "EOF"))
                 ((= byte #.(char-code #\-))
                  (setf minus t))))
      (loop for byte of-type fixnum = (%read-byte)
            do (cond
                 ((%digit-p byte)
                  (setf res (the fixnum (+ (* res 10) (%byte->num byte)))))
                 (t (return))))
      (the fixnum (if minus (- res) res)))))

(defun set! (arr count)
  (dotimes (i count)
    (setf (aref arr i)
          (read-fixnum))))

(defun read-base-char (&optional (in *standard-input*) (eof #\Newline))
  (declare (inline read-byte)
           #-swank (sb-kernel:ansi-stream in)
           (base-char eof))
  #+swank (coerce (read-char in nil eof) 'base-char)
  #-swank
  (the base-char (code-char (the (integer 0 127) (read-byte in nil (char-code eof))))))

(defmacro read-line! (simple-base-string &optional (in *standard-input*) (term #\Newline))
  "Read characters and DESTRUCTIVELY fill SIMPLE-BASE-STRING with them."
  (let ((n (gensym))
        (c (gensym))
        (i (gensym)))
    `(locally (declare (inline read-base-char))
       (let ((,n (length ,simple-base-string)))
         (declare (fixnum ,n))
         (loop for ,c of-type base-char = (read-base-char ,in #\Newline)
               with ,i of-type fixnum = 0
               until (char= ,c ,term)
               do (unless (< ,i ,n)
                    (error "Reached the end of ~a." ',simple-base-string))
                  (setf (schar ,simple-base-string ,i)
                        ,c)
                  (incf ,i))))))

(defun split (string &optional (separator #\space))
  (declare (base-string string)
           (base-char separator))
  (let ((pos (position separator string)))
    (if pos
        (cons (subseq string 0 pos)
              (split (subseq string (1+ pos))
                     separator))
        (list string))))

;;
;; EOF
;;


;;;
;;; Body
;;;

(defun main ()
  (declare #.*opt*)
  (let* ((n (read))
         (s (read))
         (x (read))
         (y (read))
         (z (read))
         (q (read))
         (as (make-array n :element-type 'uint60))
         (bs (make-bitset)))
    (declare (uint60 n s x y z q)
             ((simple-array uint60 (*)) as)
             (bitset bs))
    (loop for i of-type uint60 below n
          do (setf (aref as i)
                   (if (zerop i)
                       s
                       (the uint60
                            (rem (+ (* x (aref as (the uint60 (1- i))))
                                    y)
                                 z))))
          if (oddp (aref as i))
            do (bitset-add! bs i))
    (do-rep q
      (let* ((l-from (1- (read-fixnum)))
             (r-from (read-fixnum))
             (l-to (1- (read-fixnum)))
             (r-to (read-fixnum)))
        (declare (fixnum l-from r-from l-to r-to)
                 (ignorable r-from))
        (setf bs (bitset-xor bs
                             (bitset-intersect
                              (mask->bitset
                               (the fixnum
                                    (- (ash 1 r-to)
                                       (ash 1 l-to))))
                              (bitset-ash bs
                                          (the fixnum
                                               (- l-to
                                                  l-from))))))))
    (dotimes (i n)
      (princ (if (= 1 (bitset-ref bs i))
                 #\O
                 #\E)))
    (fresh-line)))

#-swank (main)
0