GCJ 2010: Making Chess Boards in Common Lisp (Online Round 1C)

I was on the right track with this one, but made a logical mistake and wasn't able to fix it before time ran out. I fixed my code in the half hour after the deadline, and it was able to solve the small input set. After about another hour, I had improved the logic so that it solved the large input set quickly enough. The code that I have now is easily fast enough for solving this puzzle (4 seconds for the large set), although it is not optimal.

The general approach is as follows: We compute a "scores" matrix from the bottom right up towards the top left. Each entry in the score matrix contains the size of the maximum proper chess board starting at the corresponding spot in the board matrix, towards the bottom right.

We keep another matrix that contains, for each position, the maximum score towards the bottom or right.

Then it's easy to find the largest boards that we can cut out, in the proper order. As we cut out squares, we recompute parts of the score and max-score matrices. My code recomputes a little than is actually necessary - that's a possible area of improvement.

(defun solve-case (caseno in)
  (let* ((m (read in)) (n (read in)))
    (let ((board (make-array (list m n)))
          (score (make-array (list m n)))
          (maxscore (make-array (list m n)))
          (cuts '())
          (cut 0))
      (dotimes (i m)
        (let ((line (read-line in)))
          (dotimes (j-hi (floor n 4))
            (let ((digit (parse-integer line :start j-hi :end (1+ j-hi) :radix 16)))
              (dotimes (j-lo 4)
                (let ((j (+ (* j-hi 4) j-lo)))
                  (setf (aref board i j)
                    (if (logbitp (- 3 j-lo) digit) 1 0))))))))
      (update-scores board score maxscore m n 0 0 m n)
      (let (last-width (last-i 0) (last-j 0))
        (loop
          (let ((width (aref maxscore 0 0)))
            (when (zerop width)
              (return))
            (when (eql width 1)
              (push (cons width (- (* m n) cut)) cuts)
              (return))
            (multiple-value-bind (imax jmax)
                (if (eql last-width width)
                    (find-first-from board score m n last-i last-j width)
                  (find-first-from board score m n 0 0 width))
              (assert imax)
              (setq last-i imax last-j jmax last-width width)
              (cut-out board m n imax jmax width)
              (incf cut (* width width))
              (let ((old (assoc width cuts)))
                (if old
                    (incf (cdr old))
                  (push (cons width 1) cuts)))
              (update-scores board score maxscore m n imax jmax (+ imax width) (+ jmax width))))))
      (format t "Case #~D: ~D~%" (1+ caseno) (length cuts))
      (dolist (sizes (reverse cuts))
        (format t "~D ~D~%" (car sizes) (cdr sizes))))))

(defun find-first-from (board score m n i0 j0 width)
  (declare (ignore board))
  (do ((i i0 (1+ i)))
      ((>= i m))
    (do ((j (if (= i i0) j0 0) (1+ j)))
        ((>= j n))
      (when (= (aref score i j) width)
        (return-from find-first-from (values i j))))))

(defun cut-out (board m n i j width)
  (declare (ignore m n))
  (let ((start (aref board i j)))
    (dotimes (ioff width)
      (dotimes (joff width)
        (let ((old (aref board (+ i ioff) (+ j joff))))
          (assert (not (eql old '-)))
          (assert (evenp (+ start old ioff joff))))
        (setf (aref board (+ i ioff) (+ j joff)) '-)))))

(defun update-scores (board score maxscore m n imin jmin imax jmax)
  (declare (type (simple-array t (* *)) board score maxscore))
  (declare (optimize (speed 3) (safety 0) (debug 0)))
  (let (dirty)
    (do ((i (1- imax) (1- i)))
        ((or (< i 0)
             (and (< i imin) (not dirty))))
      (setq dirty nil)
      (do ((j (1- jmax) (1- j)))
          ((< j 0))
        (let ((oldscore (aref score i j))
              (newscore
               (cond ((eq (aref board i j) '-) 0)
                     ((or (= i (1- m)) (= j (1- n))) 1)
                     (t (if (eql (aref board i j) (aref board (1+ i) (1+ j)))
                            (let ((here (aref board i j)))
                              (if (and (eql here (aref board (1+ i) (1+ j)))
                                       (eql (- 1 here)
                                            (aref board i (1+ j)))
                                       (eql (- 1 here)
                                            (aref board (1+ i) j)))
                                  (1+ (min (aref score (1+ i) (1+ j))
                                           (aref score i (1+ j))
                                           (aref score (1+ i) j)))
                                1))
                          1)))))
          (unless (eql oldscore newscore)
            (setf (aref score i j) newscore)
            (setq dirty t)))
        (let* ((oldmax (aref maxscore i j))
               (newmax (aref score i j)))
          (when (and (< (1+ i) m) (> (aref maxscore (1+ i) j) newmax))
            (setq newmax (aref maxscore (1+ i) j)))
          (when (and (< (1+ j) n) (> (aref maxscore i (1+ j)) newmax))
            (setq newmax (aref maxscore i (1+ j))))
          (unless (eql oldmax newmax)
            (setf (aref maxscore i j) newmax)
            (setq dirty t)))))))