-(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))))))))
-