Code from PWLMTL 2017/09 talk on the Zhang-Shasha paper

zhang-shasha.lisp

(defpackage #:zhang-shasha
  (:use :cl))
(in-package :zhang-shasha)

(defun postorder-numbering-of-sexp (sexp)
  (let ((nodes (make-array 0 :adjustable t :fill-pointer t))
        (keyroots (make-hash-table)))
    (labels
        ((dfs (node)
           (let ((leaf
                   (if (consp node)
                       (prog1 (dfs (cadr node))
                         (loop for child in (cddr node)
                               do (dfs child)))
                       (length nodes))))
             (setf (gethash leaf keyroots) (length nodes))
             (vector-push-extend (cons leaf node) nodes)
             leaf)))
      (dfs sexp))
    (values nodes
            (sort (loop for r being the hash-values of keyroots
                        collect r)
                  #'<))))

(defun maybe-car (sexp)
  (if (consp sexp) (car sexp) sexp))

(defun spf-left (tree-1 i tree-2 j treedist)
  (labels
      ((leftmost-leaf-of (tree node) (car (aref tree node)))
       (label-of (tree node)
         (maybe-car (cdr (aref tree node))))
       (cost-of (a b)
         (if (and a b (equal (label-of tree-1 a) (label-of tree-2 b))) 0 1)))
    (let* ((left-of-i (leftmost-leaf-of tree-1 i))
           (left-of-j (leftmost-leaf-of tree-2 j))
           (forestdist (make-array (list (+ 2 (- i left-of-i))
                                         (+ 2 (- j left-of-j)))
                                   :initial-element 0)))
      (macrolet ((fd (x y)
                   `(aref forestdist
                          (max 0 (1+ (- ,x left-of-i)))
                          (max 0 (1+ (- ,y left-of-j))))))
        (loop for u from left-of-i upto i
              do (setf (fd u -1) (+ (fd (1- u) -1) (cost-of u nil))))
        (loop for v from left-of-j upto j
              do (setf (fd -1 v) (+ (fd -1 (1- v)) (cost-of nil v))))
        (loop for u from left-of-i upto i
              for left-of-u = (leftmost-leaf-of tree-1 u)
              do (loop for v from left-of-j upto j
                       for left-of-v = (leftmost-leaf-of tree-2 v)
                       do (setf (fd u v)
                                (if (and (= left-of-u left-of-i)
                                         (= left-of-v left-of-j))
                                    ;; both are trees
                                    (setf (aref treedist u v)
                                          (min (+ (fd (1- u) v) (cost-of u nil))
                                               (+ (fd u (1- v)) (cost-of nil v))
                                               (+ (fd (1- u) (1- v)) (cost-of u v))))
                                    ;; one or both are forests
                                    (min (+ (fd (1- u) v) (cost-of u nil))
                                         (+ (fd u (1- v)) (cost-of nil v))
                                         (+ (fd (1- left-of-u) (1- left-of-v))
                                            (aref treedist u v)))))))))))

(defun tree-dist (tree-1 keyroots-1 tree-2 keyroots-2)
  (let ((treedist (make-array (list (length tree-1) (length tree-2)))))
    (loop for i in keyroots-1
          do (loop for j in keyroots-2
                   do (spf-left tree-1 i tree-2 j treedist)))
    (aref treedist (1- (length tree-1)) (1- (length tree-2)))))


;;; tests

(5am:def-suite zhang-shasha)
(5am:in-suite zhang-shasha)

(defvar *figure-4-tree-1* '(f (d a (c b)) e))
(defvar *figure-4-tree-2* '(f (c (d a b)) e))

(5am:test example-of-postordering-from-paper-1
  (5am:is (equal
           '(a b c d e f)
           (loop with tree = (postorder-numbering-of-sexp *figure-4-tree-1*)
                 for (l . node) across tree
                 collect (maybe-car node)))))

(5am:test example-of-postordering-from-paper-2
  (5am:is (equal
           '(a b d c e f)
           (loop with tree = (postorder-numbering-of-sexp *figure-4-tree-2*)
                 for (l . node) across tree
                 collect (maybe-car node)))))

(5am:test figure-4-from-zs-paper
    (5am:is (= 2
               (multiple-value-bind (tree-1 keyroots-1) (postorder-numbering-of-sexp *figure-4-tree-1*)
                 (multiple-value-bind (tree-2 keyroots-2) (postorder-numbering-of-sexp *figure-4-tree-2*)
                   (tree-dist tree-1 keyroots-1 tree-2 keyroots-2))))))

(5am:test bug-1
  (5am:is (= 2
             (multiple-value-bind (tree-1 keyroots-1) (postorder-numbering-of-sexp '(a (b x y)))
               (multiple-value-bind (tree-2 keyroots-2) (postorder-numbering-of-sexp '(a x (b y)))
                 (tree-dist tree-1 keyroots-1 tree-2 keyroots-2))))))

(5am:test example-from-video-1
  (5am:is (= 3
             (multiple-value-bind (tree-1 keyroots-1) (postorder-numbering-of-sexp '(a (a (a b) b b)))
               (multiple-value-bind (tree-2 keyroots-2) (postorder-numbering-of-sexp '(c (a b) (a b) b))
                 (tree-dist tree-1 keyroots-1 tree-2 keyroots-2))))))