From 05e83012402ab4231225d00f937924272924fb4b Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Wed, 30 Apr 2014 15:41:05 +0100
Subject: [PATCH] zone.lisp: Refactor and improve the domain-name sorting.

Sort the components according to a `natural' ordering which tries to do
approximately sane things with numeric sequences.  It's not always
successful: in particular, it wants to order 144, 144-159, 145, ...; but
it's not too awful.
---
 zone.lisp | 118 +++++++++++++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 93 insertions(+), 25 deletions(-)

diff --git a/zone.lisp b/zone.lisp
index b9c8fa1..c586915 100644
--- a/zone.lisp
+++ b/zone.lisp
@@ -111,6 +111,94 @@
       (when timep
 	(format s "~2,'0D:~2,'0D:~2,'0D" hr min sec)))))
 
+(defun natural-string< (string1 string2
+			&key (start1 0) (end1 nil)
+			(start2 0) (end2 nil))
+  "Answer whether STRING1 precedes STRING2 in a vaguely natural ordering.
+
+   In particular, digit sequences are handled in a moderately sensible way.
+   Split the strings into maximally long alternating sequences of non-numeric
+   and numeric characters, such that the non-numeric sequences are
+   non-empty.  Compare these lexicographically; numeric sequences order
+   according to their integer values, non-numeric sequences in the usual
+   lexicographic ordering.
+
+   Returns two values: whether STRING1 strictly precedes STRING2, and whether
+   STRING1 strictly follows STRING2."
+
+  (let ((end1 (or end1 (length string1)))
+	(end2 (or end2 (length string2))))
+    (loop
+      (cond ((>= start1 end1)
+	     (let ((eqp (>= start2 end2)))
+	       (return (values (not eqp) nil))))
+	    ((>= start2 end2)
+	     (return (values nil t)))
+	    ((and (digit-char-p (char string1 start1))
+		  (digit-char-p (char string2 start2)))
+	     (let* ((lim1 (or (position-if-not #'digit-char-p string1
+					       :start start1 :end end1)
+			      end1))
+		    (n1 (parse-integer string1 :start start1 :end lim1))
+		    (lim2 (or (position-if-not #'digit-char-p string2
+					       :start start2 :end end2)
+			      end2))
+		    (n2 (parse-integer string2 :start start2 :end lim2)))
+	       (cond ((< n1 n2) (return (values t nil)))
+		     ((> n1 n2) (return (values nil t))))
+	       (setf start1 lim1
+		     start2 lim2)))
+	    (t
+	     (let ((lim1 (or (position-if #'digit-char-p string1
+					  :start start1 :end end1)
+			     end1))
+		   (lim2 (or (position-if #'digit-char-p string2
+					  :start start2 :end end2)
+			     end2)))
+	       (cond ((string< string1 string2
+			       :start1 start1 :end1 lim1
+			       :start2 start2 :end2 lim2)
+		      (return (values t nil)))
+		     ((string> string1 string2
+			       :start1 start1 :end1 lim1
+			       :start2 start2 :end2 lim2)
+		      (return (values nil t))))
+	       (setf start1 lim1
+		     start2 lim2)))))))
+
+(defun domain-name< (name-a name-b)
+  "Answer whether NAME-A precedes NAME-B in an ordering of domain names.
+
+   Split the names into labels at the dots, and then lexicographically
+   compare the sequences of labels, right to left, using `natural-string<'.
+
+   Returns two values: whether NAME-A strictly precedes NAME-B, and whether
+   NAME-A strictly follows NAME-B."
+  (let ((pos-a (length name-a))
+	(pos-b (length name-b)))
+    (loop (let ((dot-a (or (position #\. name-a
+				     :from-end t :end pos-a)
+			   -1))
+		(dot-b (or (position #\. name-b
+				     :from-end t :end pos-b)
+			   -1)))
+	    (multiple-value-bind (precp follp)
+		(natural-string< name-a name-b
+				 :start1 (1+ dot-a) :end1 pos-a
+				 :start2 (1+ dot-b) :end2 pos-b)
+	      (cond (precp
+		     (return (values t nil)))
+		    (follp
+		     (return (values nil t)))
+		    ((= dot-a -1)
+		     (let ((eqp (= dot-b -1)))
+		       (return (values (not eqp) nil))))
+		    ((= dot-b -1)
+		     (return (values nil t)))
+		    (t
+		     (setf pos-a dot-a
+			   pos-b dot-b))))))))
+
 ;;;--------------------------------------------------------------------------
 ;;; Zone types.
 
@@ -291,31 +379,11 @@
   "Return the ZONE's records, in a pleasant sorted order."
   (sort (copy-seq (zone-records zone))
 	(lambda (zr-a zr-b)
-	  (let* ((name-a (zr-name zr-a)) (pos-a (length name-a))
-		 (name-b (zr-name zr-b)) (pos-b (length name-b)))
-	    (loop (let ((dot-a (or (position #\. name-a
-					     :from-end t :end pos-a)
-				   -1))
-			(dot-b (or (position #\. name-b
-					     :from-end t :end pos-b)
-				   -1)))
-		    (cond ((string< name-a name-b
-				    :start1 (1+ dot-a) :end1 pos-a
-				    :start2 (1+ dot-b) :end2 pos-b)
-			   (return t))
-			  ((string> name-a name-b
-				    :start1 (1+ dot-a) :end1 pos-a
-				    :start2 (1+ dot-b) :end2 pos-b)
-			   (return nil))
-			  ((= dot-a dot-b -1)
-			   (return (string< (zr-type zr-a) (zr-type zr-b))))
-			  ((= dot-a -1)
-			   (return t))
-			  ((= dot-b -1)
-			   (return nil))
-			  (t
-			   (setf pos-a dot-a)
-			   (setf pos-b dot-b)))))))))
+	  (multiple-value-bind (precp follp)
+	      (domain-name< (zr-name zr-a) (zr-name zr-b))
+	    (cond (precp t)
+		  (follp nil)
+		  (t (string< (zr-type zr-a) (zr-type zr-b))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Serial numbering.
-- 
2.11.0