The Algorithm Saga Continues

Last time, I talked about some problems that I encountered while trying to write my implementation of Algorithm X, promising at the end to give it's current state next time. That, of course, was a shameless delaying tactic, while I tried to get the bugs out. However, about an hour ago, I finally ironed out the problems I'd been having, and it seems to be working now. I'll write unit tests soon, I promise. Anyway, this time I want to talk a bit more about the problems I had, and then hopefully get to what worked.

A Brief Segue Into Things That Annoy Me

As I mentioned in the previous entry, I had to put in what I'm referring to as a “tag” for each row; an alphabetical character which doesn't change as the row index does, to allow me to reference in a meaningful way the rows that are chosen while recursing on sub-matrices of the original matrix. However, I really don't like the way I did it. It's an ugly kludge, and I really want to find a better way to do it. As it is, having the cons pairs as the values of the hash makes the sparse-matrix class far less general, and as I ranted about last time, if there's one thing that drives me crazy, it's specific solutions. What if I want to use that implementation of sparse matrices in something else? I'm carrying around these characters that are completely useless to me, just taking up space. It's also forced me to change the implementation of various methods in non-obvious ways. If anyone actually read this, I'd solicit suggestions for a better method...

We Now Return to Your Regularly Scheduled Ravings

So, one thing that I learned in the course of implementing this was how to make asdf work. All my previous common lisp programs had been fairly small, but I figured that I should probably learn how make require-able packages. Unfortunately, most of the tutorials I found were on how to make one's package asdf-installable. Luckily, the fine people on #lisp were able to give me a hand, and everything went smoothly.

So, now the moment you've all been waiting for: My algorithm X implementation in all it's glory

(defun algorithm-x-solve (matrix)
  "Given a sparse-matrix, determine the exact spanning set, using Knuth's Algorithm X.  Returns a
list of rows which compose an exact spanning set"
  (labels (        
           ;; Helper function that gives a list of the cols of the matrix, sorted by least filled to most
           (get-min-cols (mat)
             (sort (range 1 (cols mat)) (lambda (a b) (< (length (rows-filled a mat)) (length (rows-filled b mat))))))
           
           ;; Function to perform the main recursive step of the solver
           (rec (r mat acc)
             
             ;; Find the first column with the least rows filled (Step 2)
             (let* ((col (car (get-min-cols mat)))
                    (cur-row (get-tag r mat))
                    (poss-rows (mapcar #'(lambda (r) (get-tag r mat)) (rows-filled col mat))))
               
               ;; Perform step 5
               (let* ((rows-to-drop nil)
                      (cols-to-drop
                       (loop for j from 1 to (cols mat)
                          when (= (get-entry r j mat) 1) collect j
                          when (= (get-entry r j mat) 1)
                          do (loop for i from 1 to (rows mat)
                                when (= (get-entry i j mat) 1)
                                do (unless (member (get-tag i mat) rows-to-drop)
                                     (push (get-tag i mat) rows-to-drop))))))
                 
                 (dolist (rw (sort rows-to-drop #'char>))
                   (setf mat (drop-by-tag rw mat)))
                 
                 (dolist (cl (reverse cols-to-drop))
                   (setf mat (drop-col cl mat))))
               
               (cond
                 ((matrix-empty-p mat)
                  (cons cur-row acc)) ;; Done, (Step 1) return the rows of the solution
                 ((null (rows-filled (car (get-min-cols mat)) mat))
                  nil) ;; A column is empty, failed
                 (t ;; Else, find a row (Step 3) 
                  (loop for row in (rows-filled (car (get-min-cols mat)) mat)
                     for ret = (rec row (copy-matrix mat) (cons cur-row acc)) then
                       (rec row (copy-matrix mat) (cons cur-row acc))
                     until ret finally (return ret)))
                 )))
           )
    
    (let ((poss-rows (rows-filled (car (get-min-cols matrix)) matrix)))
      (loop for row in poss-rows
         for ret = (rec row (copy-matrix matrix) nil) then (rec row (copy-matrix matrix) nil)
         until ret finally (return (or ret 'failure))))))
 

Yeah...it is pretty ugly. The bit that took the longest to get right was the "Perform Step 5" segment. Initially, I was dropping the rows and columns while looping across them which (obviously, in retrospect) caused things to go wrong, as the index variable of the loop was now off. Frankly, it was embarrassing how long it took to get that right.

Well, there it is. Next, I guess I'll try make a sudoku solver with that. And wither then? I'm thinking:

1. Displaying the puzzles with cl-pdf or Vecto
2. Generating sudoku puzzles
3. Writing a compiler of some sort

But we'll see...