Submission #5218721

---

Source Code Expand

;; -*- coding: utf-8 -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defparameter OPT
    #+swank '(optimize (speed 3) (safety 2))
    #-swank '(optimize (speed 3) (safety 0) (debug 0)))
  #+swank (progn (ql:quickload '(:cl-debug-print :fiveam))
                 (shadow :run)
                 (use-package :fiveam)))
#+swank (cl-syntax:use-syntax cl-debug-print:debug-print-syntax)

;; BEGIN_INSERTED_CONTENTS
(defmacro nlet (name args &body body)
  (labels ((ensure-list (x) (if (listp x) x (list x))))
    (let ((args (mapcar #'ensure-list args)))
      `(labels ((,name ,(mapcar #'car args) ,@body))
         (,name ,@(mapcar #'cadr args))))))

;; (with-memoizing (:hash-table :test #'equal :key #'cons)
;;   (defun ...))
;; (with-memoizing (:array (10 10 * 10) :initial-element -1 :element-type 'fixnum)
;;   (defun foo (a b c d) ...) ; C is ignored.
(declaim (type (integer 0 #.most-positive-fixnum) *recursion-depth*))
(defparameter *recursion-depth* 0)

(defmacro with-memoizing (cache-attribs def-form)
  (let* ((cache-attribs (if (atom cache-attribs) (list cache-attribs) cache-attribs))
         (cache-type (first cache-attribs))
         (dimensions-with-* (when (eql cache-type :array) (second cache-attribs)))
         (dimensions (remove '* dimensions-with-*))
         (rank (length dimensions))
         (rest-attribs (ecase cache-type
                         (:hash-table (cdr cache-attribs))
                         (:array (cddr cache-attribs))))
         (key (prog1 (getf rest-attribs :key) (remf rest-attribs :key)))
         (debug (prog1 (getf rest-attribs :debug) (remf rest-attribs :debug)))
         (cache-form (case cache-type
                       (:hash-table `(make-hash-table ,@rest-attribs))
                       (:array `(make-array (list ,@dimensions) ,@rest-attribs))))
         (initial-element (when (eql cache-type :array)
                            (assert (member :initial-element rest-attribs))
                            (getf rest-attribs :initial-element))))
    (let ((cache (gensym))
          (value (gensym))
	  (present-p (gensym))
          (name-alias (gensym))
	  (args-lst (gensym))
          (indices (loop repeat rank collect (gensym))))
      (labels ((debug (name args obj)
                 (let ((value (gensym)))
                   (if debug
                       `(progn
                          (format t "~A~A: (~A ~{~A~^ ~}) =>~%"
                                  (make-string *recursion-depth*
                                               :element-type 'base-char
                                               :initial-element #\ )
                                  *recursion-depth*
                                  ',name
                                  (list ,@args))
                          (let ((,value (let ((*recursion-depth* (1+ *recursion-depth*)))
                                          ,obj)))
                            (format t "~A~A: (~A ~{~A~^ ~}) => ~A~%"
                                    (make-string *recursion-depth*
                                               :element-type 'base-char
                                               :initial-element #\ )
                                    *recursion-depth*
                                    ',name
                                    (list ,@args)
                                    ,value)
                            ,value))
                       obj)))
               (make-cache-check-form (cache-type name args)
                 (debug name
                        args
                        (case cache-type
                          (:hash-table
                           `(let ((,args-lst (funcall ,(or key #'list) ,@args)))
                              (multiple-value-bind (,value ,present-p)
                                  (gethash ,args-lst ,cache)
                                (if ,present-p
                                    ,value
                                    (setf (gethash ,args-lst ,cache)
                                          (,name-alias ,@args))))))
                          (:array
                           (let ((memoized-args (loop for dimension in dimensions-with-*
                                                      for arg in args
                                                      unless (eql dimension '*)
                                                      collect arg)))
                             (if key
                                 `(multiple-value-bind ,indices
                                      (funcall ,key ,@memoized-args)
                                    (let ((,value (aref ,cache ,@indices)))
                                      (if (eql ,initial-element ,value)
                                          (setf (aref ,cache ,@indices)
                                                (,name-alias ,@args))
                                          ,value)))
                                 `(let ((,value (aref ,cache ,@memoized-args)))
                                    (if (eql ,initial-element ,value)
                                        (setf (aref ,cache ,@memoized-args)
                                              (,name-alias ,@args))
                                        ,value))))))))
               (make-reset-form (cache-type)
                 (case cache-type
                   (:hash-table `(setf ,cache (make-hash-table ,@rest-attribs)))
                   (:array `(prog1 nil
                              (fill (array-storage-vector ,cache) ,initial-element)))))
               (make-reset-name (name)
                 (intern (format nil "RESET-~A" (symbol-name name))))
               (extract-declarations (body)
                 (remove-if-not (lambda (form) (eql 'declare (car form))) body)))
        (ecase (car def-form)
          ((defun)
           (destructuring-bind (_ name args &body body) def-form
             (declare (ignore _))
             `(let ((,cache ,cache-form))
                (defun ,(make-reset-name name) () ,(make-reset-form cache-type))
                (defun ,name ,args
                  ,@(extract-declarations body)
                  (labels ((,name-alias ,args ,@body))
                    (declare (inline ,name-alias))
                    ,(make-cache-check-form cache-type name args))))))
          ((nlet)
           (destructuring-bind (_ name bindings &body body) def-form
             (declare (ignore _))
             `(let ((,cache ,cache-form))
                (nlet ,name ,bindings
                  ,@(extract-declarations body)
                  ,(let ((args (mapcar (lambda (x) (if (atom x) x (car x))) bindings)))
                     `(labels ((,name-alias ,args ,@body))
                        (declare (inline ,name-alias))
                        ,(make-cache-check-form cache-type name args)))))))
          ((labels flet)
           (destructuring-bind (_ definitions &body labels-body) def-form
             (declare (ignore _))
             (destructuring-bind (name args &body body) (car definitions)
               `(let ((,cache ,cache-form))
                  (,(car def-form)
                   ((,(make-reset-name name) () ,(make-reset-form cache-type))
                    (,name ,args
                           ,@(extract-declarations body)
                           (labels ((,name-alias ,args ,@body))
                             (declare (inline ,name-alias))
                             ,(make-cache-check-form cache-type name args)))
                    ,@(cdr definitions))
                   (declare (ignorable #',(make-reset-name name)))
                   ,@labels-body))))))))))

;; (test with-memoizing
;;   (finishes (macroexpand `(with-memoizing (:hash-table :test #'equal)
;;                             (defun add (x y) (+ x y)))))
;;   (finishes (macroexpand `(with-memoizing (:array '(10 10)
;;                                            :element-type 'fixnum
;;                                            :initial-element -1)
;;                             (defun add (x y) (+ x y)))))
;;   (finishes (macroexpand `(with-memoizing (:array '(10 10)
;;                                            :element-type 'fixnum
;;                                            :initial-element -1)
;;                             (labels ((add (x y) (+ x y))
;; 		                     (my-print (x) (print x)))
;; 	                      (add 1 2))))))

;;;
;;; P(n, k) is the number of ways of writing n as a sum of at least k positive
;;; integers.
;;; 
;;; corner cases:
;;; P(0, k) = 1
;;; P(n, 0) = 0 (n ≠ 0)
;;; P(n, k) = P(n, n) (k > n)
;;;

(defconstant +partition-size+ 1100)
(defconstant +partition-mod+ #.(+ (expt 10 9) 7))

(declaim ((simple-array (unsigned-byte 32) (#.+partition-size+ #.+partition-size+)) *partition*))
(defparameter *partition*
  (make-array (list +partition-size+ +partition-size+)
              :element-type '(unsigned-byte 32)
              :initial-element 0))

(defun initialize-partition ()
  "Fills *PARTITION* using P(n, k) = P(n, k-1) + P(n-k, k)."
  (declare #.OPT)
  (dotimes (k +partition-size+)
    (setf (aref *partition* 0 k) 1))
  (loop for n from 1 below +partition-size+
        do (setf (aref *partition* n 0) 0)
           (loop for k from 1 to n
                 do (setf (aref *partition* n k)
                          (mod (+ (aref *partition* n (- k 1))
                                  (aref *partition* (- n k) k))
                               +partition-mod+)))
           (loop for k from (+ n 1) below +partition-size+
                 do (setf (aref *partition* n k)
                          (aref *partition* n n)))))

(initialize-partition)


(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
                                  ;; (return-from read-fixnum 0)
                                  (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) (the fixnum (* result 10))))
              (return (if minus (- result) result))))))))

(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 solve (team-sizes death-sum)
  (declare #.OPT
           ((simple-array uint16 (*)) team-sizes))
  (with-memoizing (:array (101 1001) :initial-element #xffffffff :element-type 'uint32)
    (nlet recur ((x (length team-sizes)) (y death-sum))
      (if (zerop x)
          (if (zerop y)
              1
              0)
          (loop with res of-type uint31 = 0
                for d from 0 to y
                do (setf res (mod (+ res
                                     (* (recur (- x 1) (- y d))
                                        (aref *partition* d (aref team-sizes (- x 1)))))
                                  +mod+))
                finally (return res))))))

(defun main ()
  (declare #.OPT)
  (let* ((n (read))
         (m (read))
         (as (make-array n :element-type 'uint16))
         (bs (make-array m :element-type 'uint16))
         (a-rle (make-array 0 :element-type 'uint16 :fill-pointer 0))
         (b-rle (make-array 0 :element-type 'uint16 :fill-pointer 0)))
    (dotimes (i n)
      (setf (aref as i) (read-fixnum)))
    (dotimes (i m)
      (setf (aref bs i) (read-fixnum)))
    (let ((base 0))
      (dotimes (i n (vector-push-extend (- i base) a-rle))
        (unless (= (aref as i) (aref as base))
          (vector-push-extend (- i base) a-rle)
          (setf base i))))
    (let ((base 0))
      (dotimes (i m (vector-push-extend (- i base) b-rle))
        (unless (= (aref bs i) (aref bs base))
          (vector-push-extend (- i base) b-rle)
          (setf base i))))
    (setf a-rle (coerce a-rle '(simple-array uint16 (*))))
    (setf b-rle (coerce b-rle '(simple-array uint16 (*))))
    (println (mod (* (solve a-rle (reduce #'+ bs))
                     (solve b-rle (reduce #'+ as)))
                  +mod+))))

#-swank(main)

Submission Info

Judge Result