提出 #7080100

---

ソースコード 拡げる

;; -*- 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 (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 get-2dcumul))
(defun get-2dcumul (cumul-table i0 j0 i1 j1)
  "Returns the cumulative sum of the region given by the rectangle [i0, i1)*[j0,
j1). CUMUL-TABLE must be appropriately initialized beforehand:
i.e. CUMUL-TABLE[i][j] = sum of the region given by the regtangle [0, i)*[0,
j)."
  (+ (- (aref cumul-table i1 j1)
        (aref cumul-table i0 j1)
        (aref cumul-table i1 j0))
     (aref cumul-table i0 j0)))

;;;
;;; Memoization macro
;;;

;;
;; Basic usage:
;;
;; (with-cache (:hash-table :test #'equal :key #'cons)
;;   (defun add (a b)
;;     (+ a b)))
;; This function caches the returned values for already passed combinations of
;; arguments. In this case ADD stores the key (CONS A B) and the return value to
;; a hash-table when evaluating (ADD A B) for the first time. ADD returns the
;; stored value when it is called with the same arguments (w.r.t. EQUAL) again.
;;
;; The storage for the cache is hash-table or array. Let's see an example for
;; array:
;; (with-cache (:array (10 20 30) :initial-element -1 :element-type 'fixnum)
;;   (defun foo (a b c) ... ))
;; This form stores the value of FOO in the array created by (make-array (list
;; 10 20 30) :initial-element -1 :element-type 'fixnum). Note that
;; INITIAL-ELEMENT must always be given here as it is used as the flag for `not
;; yet stored'. (Therefore INITIAL-ELEMENT should be a value FOO never takes.)
;;
;; If you want to ignore some arguments, you can put `*' in dimensions:
;; (with-cache (:array (10 10 * 10) :initial-element -1)
;;   (defun foo (a b c d) ...)) ; then C is ignored when querying or storing cache
;;
;; Available definition forms in WITH-CACHE are DEFUN, LABELS, FLET, and
;; SB-INT:NAMED-LET.
;;
;; You can trace the memoized function by :TRACE option:
;; (with-cache (:array (10 10) :initial-element -1 :trace t)
;;   (defun foo (x y) ...))
;; Then FOO is traced as with CL:TRACE.
;;

;; FIXME: *RECURSION-DEPTH* should be included within the macro.
(declaim (type (integer 0 #.most-positive-fixnum) *recursion-depth*))
(defparameter *recursion-depth* 0)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun %enclose-with-tracing (fname args form)
    (let ((value (gensym)))
      `(progn
         (format t "~&~A~A: (~A ~{~A~^ ~}) =>"
                 (make-string *recursion-depth*
                              :element-type 'base-char
                              :initial-element #\ )
                 *recursion-depth*
                 ',fname
                 (list ,@args))
         (let ((,value (let ((*recursion-depth* (1+ *recursion-depth*)))
                         ,form)))
           (format t "~&~A~A: (~A ~{~A~^ ~}) => ~A"
                   (make-string *recursion-depth*
                                :element-type 'base-char
                                :initial-element #\ )
                   *recursion-depth*
                   ',fname
                   (list ,@args)
                   ,value)
           ,value))))

  (defun %extract-declarations (body)
    (remove-if-not (lambda (form) (eql 'declare (car (if (listp form) form (list form)))))
                   body))

  (defun %parse-cache-form (cache-specifier)
    (let ((cache-type (car cache-specifier))
          (cache-attribs (cdr cache-specifier)))
      (assert (member cache-type '(:hash-table :array)))
      (let* ((dims-with-* (when (eql cache-type :array) (first cache-attribs)))
             (dims (remove '* dims-with-*))
             (rank (length dims))
             (rest-attribs (ecase cache-type
                             (:hash-table cache-attribs)
                             (:array (cdr cache-attribs))))
             (key (prog1 (getf rest-attribs :key) (remf rest-attribs :key)))
             (trace-p (prog1 (getf rest-attribs :trace) (remf rest-attribs :trace)))
             (cache-form (case cache-type
                           (:hash-table `(make-hash-table ,@rest-attribs))
                           (:array `(make-array (list ,@dims) ,@rest-attribs))))
             (initial-element (when (eql cache-type :array)
                                (assert (member :initial-element rest-attribs))
                                (getf rest-attribs :initial-element))))
        (let ((cache (gensym "CACHE"))
              (value (gensym))
	      (present-p (gensym))
              (name-alias (gensym))
	      (args-lst (gensym))
              (indices (loop repeat rank collect (gensym))))
          (labels
              ((make-cache-querier (cache-type name args)
                 (let ((res (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 dims-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))))))))
                   (if trace-p
                       (%enclose-with-tracing name args res)
                       res)))
               (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)))))
            (values cache cache-form cache-type name-alias
                    #'make-reset-name
                    #'make-reset-form
                    #'make-cache-querier)))))))

(defmacro with-caches (cache-specs def-form)
  "DEF-FORM := definition form with LABELS or FLET.

 (with-caches (cache-spec1 cache-spec2)
   (labels ((f (x) ...) (g (y) ...))))
is equivalent to the line up of
 (with-cache cache-spec1 (labels ((f (x) ...))))
and
 (with-cache cache-spec2 (labels ((g (y) ...)))) "
  (assert (member (car def-form) '(labels flet)))
  (let (cache-symbol-list cache-form-list cache-type-list name-alias-list make-reset-name-list make-reset-form-list make-cache-querier-list)
    (dolist (cache-spec (reverse cache-specs))
      (multiple-value-bind (cache-symbol cache-form cache-type name-alias
                            make-reset-name make-reset-form make-cache-querier)
          (%parse-cache-form cache-spec)
        (push cache-symbol cache-symbol-list)
        (push cache-form cache-form-list)
        (push cache-type cache-type-list)
        (push name-alias name-alias-list)
        (push make-reset-name make-reset-name-list)
        (push make-reset-form make-reset-form-list)
        (push make-cache-querier make-cache-querier-list)))
    (labels ((def-name (def) (first def))
             (def-args (def) (second def))
             (def-body (def) (cddr def)))
      (destructuring-bind (_ definitions &body labels-body) def-form
        (declare (ignore _))
        `(let ,(loop for cache-symbol in cache-symbol-list
                     for cache-form in cache-form-list
                     collect `(,cache-symbol ,cache-form))
           (,(car def-form)
            (,@(loop for def in definitions
                     for cache-type in cache-type-list
                     for make-reset-name in make-reset-name-list
                     for make-reset-form in make-reset-form-list
                     collect `(,(funcall make-reset-name (def-name def)) ()
                               ,(funcall make-reset-form cache-type)))
             ,@(loop for def in definitions
                     for cache-type in cache-type-list
                     for name-alias in name-alias-list
                     for make-cache-querier in make-cache-querier-list
                     collect `(,(def-name def) ,(def-args def)
                               ,@(%extract-declarations (def-body def))
                               (labels ((,name-alias ,(def-args def) ,@(def-body def)))
                                 (declare (inline ,name-alias))
                                 ,(funcall make-cache-querier cache-type (def-name def) (def-args def))))))
            (declare (ignorable ,@(loop for def in definitions
                                        for make-reset-name in make-reset-name-list
                                        collect `#',(funcall make-reset-name
                                                             (def-name def)))))
            ,@labels-body))))))

(defmacro buffered-read-line (&optional (buffer-size 30) (in '*standard-input*) (term-char #\Space))
  "Reads ASCII inputs and returns two values: the string and the end
position. Note that the returned string will be reused if this form is executed
more than once.

This macro calls READ-BYTE to read characters though it calls READ-CHAR instead
on SLIME because SLIME's IO is not bivalent."
  (let ((buffer (gensym))
        (character (gensym))
        (idx (gensym)))
    `(let* ((,buffer (load-time-value (make-string ,buffer-size :element-type 'base-char))))
       (declare (simple-base-string ,buffer)
                (inline read-byte))
       (loop for ,character of-type base-char =
                ,(if (member :swank *features*)
                     `(read-char ,in nil #\Newline) ; on SLIME
                     `(code-char (read-byte ,in nil #.(char-code #\Newline))))
             for ,idx from 0
             until (char= ,character #\Newline)
             do (setf (schar ,buffer ,idx) ,character)
             finally (when (< ,idx ,buffer-size)
                       (setf (schar ,buffer ,idx) ,term-char))
                     (return (values ,buffer ,idx))))))

(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)
  (let* ((h (read))
         (w (read))
         (cumuls (make-array '(186 186) :element-type 'uint32 :initial-element 0)))
    (declare (uint8 h w))
    (dotimes (i h)
      (let ((line (buffered-read-line 185)))
        (dotimes (j w)
          (when (char= #\# (aref line j))
            (setf (aref cumuls (+ i 1) (+ j 1)) 1)))))
    (dotimes (i (+ h 1))
      (dotimes (j w)
        (incf (aref cumuls i (+ j 1)) (aref cumuls i j))))
    (dotimes (j (+ w 1))
      (dotimes (i h)
        (incf (aref cumuls (+ i 1) j) (aref cumuls i j))))
    (with-caches ((:array (186 186 186 20)
                   :element-type 'uint8
                   :initial-element #xff)
                  (:array (186 186 186 20)
                   :element-type 'uint8
                   :initial-element #xff))
      (labels
          ((f (y1 x1 y2 c)
             (declare (uint8 y1 x1 y2 c))
             (if (zerop c)
                 (sb-int:named-let bisect ((ok x1) (ng (+ w 1)))
                   (declare (uint8 ok ng))
                   (if (<= (- ng ok) 1)
                       ok
                       (let* ((mid (floor (+ ok ng) 2))
                              (sum (get-2dcumul cumuls y1 x1 y2 mid)))
                         (if (or (= sum (* (- y2 y1) (- mid x1)))
                                 (= sum 0))
                             (bisect mid ng)
                             (bisect ok mid)))))
                 (let ((res1 (f y1 (f y1 x1 y2 (- c 1)) y2 (- c 1)))
                       (res2 (sb-int:named-let bisect ((ok x1) (ng (+ w 1)))
                               (declare (uint8 ok ng))
                               (if (<= (- ng ok) 1)
                                   ok
                                   (let* ((mid (floor (+ ok ng) 2))
                                          (val (g (g y1 x1 mid (- c 1)) x1 mid (- c 1))))
                                     (if (>= val y2)
                                         (bisect mid ng)
                                         (bisect ok mid)))))))
                   (max res1 res2))))
           (g (y1 x1 x2 c)
             (declare (uint8 y1 x1 x2 c))
             (if (zerop c)
                 (sb-int:named-let bisect ((ok y1) (ng (+ h 1)))
                   (declare (uint8 ok ng))
                   (if (<= (- ng ok) 1)
                       ok
                       (let* ((mid (floor (+ ok ng) 2))
                              (sum (get-2dcumul cumuls y1 x1 mid x2)))
                         (if (or (= sum (* (- mid y1) (- x2 x1)))
                                 (= sum 0))
                             (bisect mid ng)
                             (bisect ok mid)))))
                 (let ((res1 (g (g y1 x1 x2 (- c 1)) x1 x2 (- c 1)))
                       (res2 (sb-int:named-let bisect ((ok y1) (ng (+ h 1)))
                               (declare (uint8 ok ng))
                               (if (<= (- ng ok) 1)
                                   ok
                                   (let* ((mid (floor (+ ok ng) 2))
                                          (val (f y1 (f y1 x1 mid (- c 1)) mid (- c 1))))
                                     (if (>= val x2)
                                         (bisect mid ng)
                                         (bisect ok mid)))))))
                   (max res1 res2)))))
        (dotimes (c 20)
          (let  ((x (f 0 0 h c)))
            (when (= x w)
              (println c)
              (return-from main))))))))

#-swank (main)

提出情報

ジャッジ結果