;; some helper functions
(defun aref-or-infinity (matrix i j)
  "like aref but returns '+INFINITY if the indices are out bounds for the array"
  (handler-case (aref matrix i j)
    (simple-error () '+INFINITY)))

(defun min* (&rest args)
  (apply #'min (delete '+INFINITY args)))

(defun add* (&rest args)
  (or (find '+INFINITY args)
      (apply #'+ args)))

;; print nothing, return the matrix
(defun abstand (v w)
  "Ermittelt den Editierabstand zw. v und w, unter den Operationen
Löschen, Einfügen und Übernehmen"
  (let ((matrix (make-array (list (1+ (length w)) (1+ (length v)) )
			   :element-type 'fixnum)))
    (dotimes (i (1+ (length w)))   ;; rows
      (dotimes (j (1+ (length v))) ;; columns
	(setf (aref matrix i j)
	      (if (and (= i 0) (= j 0)) ;; (setf (aref matrix 0 0) 0)
		  0
		  (min* (add* (aref-or-infinity matrix (1- i)     j ) 1) ;; remove
			(add* (aref-or-infinity matrix     i  (1- j)) 1) ;; insert
			(add* (aref-or-infinity matrix (1- i) (1- j)) ;; take over
			      (if (and (>= i 1) (>= j 1) ;; exclude zero cols/rows
				       (char-equal (elt v (1- j)) (elt w (1- i))))
				  0
				  '+INFINITY)))))))
    matrix)) ;; replace by (aref matrix (length w) (length v)))) for value only

;; a variation that prints the matrix and the strings v and w prettily
(defun abstand-pretty (v w)
  "Ermittelt den Editierabstand zw. v und w, unter den Operationen
Löschen, Einfügen und Übernehmen"
  (let ((matrix (make-array (list (1+ (length w)) (1+ (length v)) )
			   :element-type 'fixnum)))
    (format t "    ~{  ~c~}~%" (coerce v 'list)) ;; print v
    (dotimes (i (1+ (length w)))   ;; rows
      (format t "~c" (if (zerop i) " " (elt w (1- i)))) ;; print w
      (dotimes (j (1+ (length v))) ;; columns
	(format t "~3d"
  	  (setf (aref matrix i j)
		(if (and (zerop i) (zerop j)) ;; (setf (aref matrix 0 0) 0)
		    0
		    (min* (add* (aref-or-infinity matrix (1- i)     j ) 1) ;; remove
			  (add* (aref-or-infinity matrix     i  (1- j)) 1) ;; insert
			  (add* (aref-or-infinity matrix (1- i) (1- j)) ;; take over
				(if (and (>= i 1) (>= j 1) ;; exclude zero cols/rows
					 (char-equal (elt v (1- j)) (elt w (1- i))))
				    0
				    '+INFINITY)))))))
      (format t "~%"))
    matrix nil)) ;; remove nil if you want this to return the matrix

;; same with 2x-delete ("bouncing delete key")
;; (cf. Nachklausur Informatik IV 18.10.2003, Aufgabe 4)
(defun abstand-bouncing-delete (v w)
  "Ermittelt den Editierabstand zw. v und w, unter den Operationen
2x-Löschen, Einfügen und Übernehmen"
  (let ((matrix (make-array (list (1+ (length w)) (1+ (length v)) )
			   :element-type 'fixnum)))
    (format t "    ~{  ~c~}~%" (coerce v 'list)) ;; print v
    (dotimes (i (1+ (length w))) ;; rows
      (format t "~c" (if (zerop i) " " (elt w (1- i)))) ;; print w
      (dotimes (j (1+ (length v))) ;; columns
	(format t "~3d"
  	  (setf (aref matrix i j)
		(if (and (zerop i) (zerop j)) ;; (setf (aref matrix 0 0) 0)
		    0
		    (min* (if (zerop i) ;; don't try to delete in 0th row
			    '+INFINITY
			    (add* (aref-or-infinity matrix
						    (max 0 (- i 2)) j) 1)) ;; remove
			  (add* (aref-or-infinity matrix     i  (1- j)) 1) ;; insert
			  (add* (aref-or-infinity matrix (1- i) (1- j)) ;; take over
				(if (and (>= i 1) (>= j 1) ;; exclude zero cols/rows
					 (char-equal (elt v (1- j)) (elt w (1- i))))
				    0
				    '+INFINITY)))))))
      (format t "~%"))
    matrix nil)) ;; remove nil if you want this to return the matrix