slib 3b1-5 / usr / share / slib / chap.scm

;;;; "chap.scm" Chapter ordering		-*-scheme-*-
;;; Copyright 1992, 1993, 1994, 2003 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

;;; The CHAP: functions deal with strings which are ordered like
;;; chapters in a book.  For instance, a_9 < a_10 and 4c < 4aa.  Each
;;; section of the string consists of consecutive numeric or
;;; consecutive aphabetic characters.

(require 'rev4-optional-procedures)	; string-copy

;;@code{(require 'chapter-order)}
;;@ftindex chapter-order
;;
;;The @samp{chap:} functions deal with strings which are ordered like
;;chapter numbers (or letters) in a book.  Each section of the string
;;consists of consecutive numeric or consecutive aphabetic characters of
;;like case.

;;@args string1 string2
;;Returns #t if the first non-matching run of alphabetic upper-case or
;;the first non-matching run of alphabetic lower-case or the first
;;non-matching run of numeric characters of @var{string1} is
;;@code{string<?} than the corresponding non-matching run of
;;characters of @var{string2}.
;;
;;@example
;;(chap:string<? "a.9" "a.10")                    @result{} #t
;;(chap:string<? "4c" "4aa")                      @result{} #t
;;(chap:string<? "Revised^@{3.99@}" "Revised^@{4@}")  @result{} #t
;;@end example
(define (chap:string<? s1 s2)
  (let ((l1 (string-length s1))
	(l2 (string-length s2)))
    (define (match-so-far i ctypep)
      (cond ((>= i l1) (not (>= i l2)))
	    ((>= i l2) #f)
	    (else
	     (let ((c1 (string-ref s1 i))
		   (c2 (string-ref s2 i)))
	       (cond ((char=? c1 c2)
		      (if (ctypep c1)
			  (match-so-far (+ 1 i) ctypep)
			  (delimited i)))
		     ((ctypep c1)
		      (if (ctypep c2)
			  (length-race (+ 1 i) ctypep (char<? c1 c2))
			  #f))
		     ((ctypep c2) #t)
		     (else
		      (let ((ctype1 (ctype c1)))
			(cond
			 ((and ctype1 (eq? ctype1 (ctype c2)))
			  (length-race (+ 1 i) ctype1 (char<? c1 c2)))
			 (else (char<? c1 c2))))))))))
    (define (length-race i ctypep def)
      (cond ((>= i l1) (if (>= i l2) def #t))
	    ((>= i l2) #f)
	    (else
	     (let ((c1 (string-ref s1 i))
		   (c2 (string-ref s2 i)))
	       (cond ((ctypep c1)
		      (if (ctypep c2)
			  (length-race (+ 1 i) ctypep def)
			  #f))
		     ((ctypep c2) #t)
		     (else def))))))
    (define (ctype c1)
      (cond
       ((char-numeric? c1) char-numeric?)
       ((char-lower-case? c1) char-lower-case?)
       ((char-upper-case? c1) char-upper-case?)
       (else #f)))
    (define (delimited i)
      (cond ((>= i l1) (not (>= i l2)))
	    ((>= i l2) #f)
	    (else
	     (let* ((c1 (string-ref s1 i))
		    (c2 (string-ref s2 i))
		    (ctype1 (ctype c1)))
	       (cond ((char=? c1 c2)
		      (if ctype1 (match-so-far (+ i 1) ctype1)
			  (delimited (+ i 1))))
		     ((and ctype1 (eq? ctype1 (ctype c2)))
		      (length-race (+ 1 i) ctype1 (char<? c1 c2)))
		     (else (char<? c1 c2)))))))
    (delimited 0)))
;;@body
;;Implement the corresponding chapter-order predicates.
(define (chap:string>? string1 string2) (chap:string<? string2 string1))
(define (chap:string<=? string1 string2) (not (chap:string<? string2 string1)))
(define (chap:string>=? string1 string2) (not (chap:string<? string1 string2)))

(define chap:char-incr (- (char->integer #\2) (char->integer #\1)))

(define (chap:inc-string s p)
  (let ((c (string-ref s p)))
    (cond ((char=? c #\z)
	   (string-set! s p #\a)
	   (cond ((zero? p) (string-append "a" s))
		 ((char-lower-case? (string-ref s (+ -1 p)))
		  (chap:inc-string s (+ -1 p)))
		 (else
		  (string-append
		   (substring s 0 p)
		   "a"
		   (substring s p (string-length s))))))
	  ((char=? c #\Z)
	   (string-set! s p #\A)
	   (cond ((zero? p) (string-append "A" s))
		 ((char-upper-case? (string-ref s (+ -1 p)))
		  (chap:inc-string s (+ -1 p)))
		 (else
		  (string-append
		   (substring s 0 p)
		   "A"
		   (substring s p (string-length s))))))
	  ((char=? c #\9)
	   (string-set! s p #\0)
	   (cond ((zero? p) (string-append "1" s))
		 ((char-numeric? (string-ref s (+ -1 p)))
		  (chap:inc-string s (+ -1 p)))
		 (else
		  (string-append
		   (substring s 0 p)
		   "1"
		   (substring s p (string-length s))))))
	  ((or (char-alphabetic? c) (char-numeric? c))
	   (string-set! s p (integer->char
			     (+ chap:char-incr
				(char->integer (string-ref s p)))))
	   s)
	  (else (slib:error "inc-string error" s p)))))

;;@args string
;;Returns the next string in the @emph{chapter order}.  If @var{string}
;;has no alphabetic or numeric characters,
;;@code{(string-append @var{string} "0")} is returnd.  The argument to
;;chap:next-string will always be @code{chap:string<?} than the result.
;;
;;@example
;;(chap:next-string "a.9")                @result{} "a.10"
;;(chap:next-string "4c")                 @result{} "4d"
;;(chap:next-string "4z")                 @result{} "4aa"
;;(chap:next-string "Revised^@{4@}")        @result{} "Revised^@{5@}"
;;
;;@end example
(define (chap:next-string s)
  (do ((i (+ -1 (string-length s)) (+ -1 i)))
      ((or (negative? i)
	   (char-numeric? (string-ref s i))
	   (char-alphabetic? (string-ref s i)))
       (if (negative? i) (string-append s "0")
	   (chap:inc-string (string-copy s) i)))))

;;; testing utilities
;(define (ns s1) (chap:next-string s1))

;(define (ts s1 s2)
;  (let ((s< (chap:string<? s1 s2))
;	(s> (chap:string<? s2 s1)))
;    (cond (s<
;	   (display s1)
;	   (display " < ")
;	   (display s2)
;	   (newline)))
;    (cond (s>
;	   (display s1)
;	   (display " > ")
;	   (display s2)
;	   (newline)))))