From 644ed77f9c0165e22290549660e71ff3ead573d5 Mon Sep 17 00:00:00 2001
From: Mark Polesky <markpolesky@yahoo.com>
Date: Wed, 1 Jul 2009 16:21:14 -0700
Subject: [PATCH] Add new file lily-sort.scm; improve sorting in docs.

- add new file lily-sort.scm
- add "lily-sort.scm" to the ly:load list in documentation-generate.scm
- "string<?" --> "ly:string-ci<?" etc. in the document-*.scm files
---
 scm/document-backend.scm       |   8 +--
 scm/document-functions.scm     |   2 +-
 scm/document-identifiers.scm   |   2 +-
 scm/document-markup.scm        |   2 +-
 scm/document-music.scm         |   6 +-
 scm/document-translation.scm   |  14 ++--
 scm/documentation-generate.scm |   1 +
 scm/lily-sort.scm              | 116 +++++++++++++++++++++++++++++++++
 8 files changed, 134 insertions(+), 17 deletions(-)
 create mode 100644 scm/lily-sort.scm

diff --git a/scm/document-backend.scm b/scm/document-backend.scm
index d77a194d31..18762aeba9 100644
--- a/scm/document-backend.scm
+++ b/scm/document-backend.scm
@@ -8,7 +8,7 @@
 (define (interface-doc-string interface grob-description)
   (let* ((name (car interface))
 	 (desc (cadr interface))
-	 (props (sort (caddr interface) symbol<?))
+	 (props (sort (caddr interface) ly:symbol-ci<?))
 	 (docfunc (lambda (pr)
 		    (property->texi
 		     'backend pr grob-description)))
@@ -61,7 +61,7 @@
 				     (hashq-ref iface->grob-table
 						(car interface)
 						'()))
-				string<?)))))
+				ly:string-ci<?)))))
     (make <texi-node>
       #:name name
       #:text (string-append
@@ -139,7 +139,7 @@ node."
      (cons (cons key val)  prior))
    '() (ly:all-grob-interfaces)))
 
-(set! interface-description-alist (sort interface-description-alist alist<?))
+(set! interface-description-alist (sort interface-description-alist ly:alist-ci<?))
 
 ;;;;;;;;;; check for dangling backend properties.
 (define (mark-interface-properties entry)
@@ -171,7 +171,7 @@ node."
     (map interface-doc interface-description-alist)))
 
 (define (backend-properties-doc-string lst)
-  (let* ((ps (sort (map symbol->string lst) string<?))
+  (let* ((ps (sort (map symbol->string lst) ly:string-ci<?))
 	 (descs (map (lambda (prop)
 		       (property->texi 'backend (string->symbol prop) '())) ps))
 	 (texi (description-list->texi descs #f)))
diff --git a/scm/document-functions.scm b/scm/document-functions.scm
index 34d406f89f..3c7646cc79 100644
--- a/scm/document-functions.scm
+++ b/scm/document-functions.scm
@@ -34,7 +34,7 @@
   (let* ((fdocs (map (lambda (x)
 		       (document-scheme-function (car x) (cadr x) (cddr x)))
 		     all-scheme-functions))
-	 (sfdocs (sort fdocs string<?))) 
+	 (sfdocs (sort fdocs ly:string-ci<?)))
     (make <texi-node>
       #:name "Scheme functions"
       #:desc "Primitive functions exported by LilyPond."
diff --git a/scm/document-identifiers.scm b/scm/document-identifiers.scm
index 67e282bd86..0d67934288 100644
--- a/scm/document-identifiers.scm
+++ b/scm/document-identifiers.scm
@@ -46,7 +46,7 @@
 
 
 (define (identifier<? a b)
-  (string<?
+  (ly:string-ci<?
    (symbol->string (car a))
    (symbol->string (car b))))
 
diff --git a/scm/document-markup.scm b/scm/document-markup.scm
index af4a65d7c6..ef99452be7 100644
--- a/scm/document-markup.scm
+++ b/scm/document-markup.scm
@@ -62,7 +62,7 @@
                           "@end itemize\n"))))))
 
 (define (markup-function<? a b)
-  (string<? (symbol->string (procedure-name a)) (symbol->string (procedure-name b))))
+  (ly:string-ci<? (symbol->string (procedure-name a)) (symbol->string (procedure-name b))))
  
 (define (markup-category-doc-node category)
   (let* ((category-string (symbol->string category))
diff --git a/scm/document-music.scm b/scm/document-music.scm
index b8190d95f4..38960ee531 100644
--- a/scm/document-music.scm
+++ b/scm/document-music.scm
@@ -10,7 +10,7 @@
     #:name "Music properties"
     #:desc "All music properties, including descriptions."
     #:text
-    (let* ((ps (sort (map symbol->string all-music-properties) string<?))
+    (let* ((ps (sort (map symbol->string all-music-properties) ly:string-ci<?))
 	   (descs (map (lambda (prop)
 			 (property->texi 'music (string->symbol prop)))
 		       ps))
@@ -55,7 +55,7 @@
        (human-listify
 	(sort
 	 (map (lambda (x) (ref-ify (symbol->string x)))
-	      (cdr entry)) string<?))
+	      (cdr entry)) ly:string-ci<?))
        "."
 
        "\n\n"
@@ -72,7 +72,7 @@
     #:children
     (map music-type-doc
 	 (sort
-	  (hash-table->alist music-types->names) alist<?))))
+	  (hash-table->alist music-types->names) ly:alist-ci<?))))
 
 (define (music-doc-str obj)
   (let* ((namesym  (car obj))
diff --git a/scm/document-translation.scm b/scm/document-translation.scm
index 5bfc83a538..77f2abff2a 100644
--- a/scm/document-translation.scm
+++ b/scm/document-translation.scm
@@ -60,7 +60,7 @@
 	  ""
 	  (string-append
 	   "\n\nThis engraver creates the following layout object(s):\n\n"
-	   (human-listify (map ref-ify (uniq-list (sort grobs string<?))))
+	   (human-listify (map ref-ify (uniq-list (sort grobs ly:string-ci<?))))
 	   "."))
 
      "\n\n"
@@ -86,7 +86,7 @@
 		(context-list (human-listify (map ref-ify
 						  (sort
 						   (map symbol->string contexts)
-						   string<?)))))
+						   ly:string-ci<?)))))
 	   (string-append
 	    "@code{" name-str "} "
 	    (if (equal? context-list "none")
@@ -176,7 +176,7 @@
 	   "")
 
        "\n\nThis context creates the following layout object(s):\n\n"
-       (human-listify (uniq-list (sort grob-refs string<?)))
+       (human-listify (uniq-list (sort grob-refs ly:string-ci<?)))
        "."
 
        (if (and (pair? props) (not (null? props)))
@@ -230,8 +230,8 @@
 (define (all-contexts-doc)
   (let* ((layout-alist
 	  (sort (ly:output-description $defaultlayout)
-		(lambda (x y) (symbol<? (car x) (car y)))))
-	 (names (sort (map symbol->string (map car layout-alist)) string<?))
+		(lambda (x y) (ly:symbol-ci<? (car x) (car y)))))
+	 (names (sort (map symbol->string (map car layout-alist)) ly:string-ci<?))
 	 (contexts (map cdr layout-alist)))
 
     (make <texi-node>
@@ -243,7 +243,7 @@
 (define all-engravers-list  (ly:get-all-translators))
 (set! all-engravers-list
       (sort all-engravers-list
-	    (lambda (a b) (string<? (symbol->string (ly:translator-name a))
+	    (lambda (a b) (ly:string-ci<? (symbol->string (ly:translator-name a))
 				    (symbol->string (ly:translator-name b))))))
 
 (define (all-engravers-doc)
@@ -255,7 +255,7 @@
     (map engraver-doc all-engravers-list)))
 
 (define (translation-properties-doc-string lst)
-  (let* ((ps (sort (map symbol->string lst) string<?))
+  (let* ((ps (sort (map symbol->string lst) ly:string-ci<?))
 	 (sortedsyms (map string->symbol ps))
 	 (propdescs
 	  (map
diff --git a/scm/documentation-generate.scm b/scm/documentation-generate.scm
index 04b0a59942..478eb20efc 100644
--- a/scm/documentation-generate.scm
+++ b/scm/documentation-generate.scm
@@ -17,6 +17,7 @@
 ;; todo: naming: grob vs. layout property
 
 (map ly:load '("documentation-lib.scm"
+	       "lily-sort.scm"
 	       "document-functions.scm"
 	       "document-translation.scm"
 	       "document-music.scm"
diff --git a/scm/lily-sort.scm b/scm/lily-sort.scm
new file mode 100644
index 0000000000..96e83b7191
--- /dev/null
+++ b/scm/lily-sort.scm
@@ -0,0 +1,116 @@
+;;;; lily-sort.scm -- improved sorting of symbols, strings, and alists.
+;;;;
+;;;; source file of the GNU LilyPond music typesetter
+;;;;
+;;;; Copyright 2009 Mark Polesky <markpolesky@yahoo.com>
+
+
+;; This file implements a LilyPond-specific character-sorting algorithm
+;; that can be used to sort lists, alists, etc. consistently and
+;; predictably throughout the source code. The primary advantage of this
+;; algorithm is that lists are sorted in a more intuitive way, which may
+;; allow users to find items faster in the documentation.
+;;
+;; As an example, a user, looking in the documentation to see if there's
+;; a function called "ly:grob?", might assume that there isn't one,
+;; since it doesn't appear before "ly:grob-alist-chain" (using the
+;; default sort).
+;;
+;; This happens because "-" comes before "?" in the default sort order.
+;; But since "?" is more likely to come at the end of a scheme symbol, a
+;; more intuitive sort can be achieved by reversing that order.
+;;
+;; Similarly, non-alphanumeric characters can be ranked in terms of how
+;; likely one will be found closer to the end of a symbol. For example,
+;; ":" is stronger separator than "-", as can be seen here:
+;;
+;; "ly:staff-symbol::print"
+;; "ly:staff-symbol-referencer::callback"
+;;
+;; Intuitively, "staff-symbol-referencer" ought to come after
+;; "staff-symbol", but since "-" comes before ":" in the default sort
+;; order, these symbols are by default listed in the opposite order.
+;;
+;; Thus the algorithm implemented here ranks the following nine
+;; characters (starting with the space character) in order from
+;; most-to-least likely to terminate a symbol: " !?<=>:-_". These nine
+;; characters are in effect "extracted" from the default order and then
+;; "prepended" to it so that they now come first. This is achieved with
+;; the function "ly:char-generic-<?".
+;;
+;; This file defines 3 case-sensitive binary comparison predicates:
+;;   ly:string<?     ly:symbol<?     ly:alist<?
+;; and their case-insensitive counterparts:
+;;   ly:string-ci<?  ly:symbol-ci<?  ly:alist-ci<?
+;;
+;; Case-insensitive predicates are recommended in general; otherwise
+;; symbols like "Y-offset" appear near the top of lists which
+;; otherwise include mostly lowercase symbols.
+
+(define (ly:char-generic-<? a b ci)
+  (let* ((init-list (string->list " !?<=>:-_"))
+         (mem-a (member a init-list))
+         (mem-b (member b init-list)))
+    (cond ((and mem-a mem-b) (< (length mem-b) (length mem-a)))
+          (mem-a #t)
+          (mem-b #f)
+          (else ((if ci char-ci<? char<?) a b)))))
+
+(define (ly:char<? a b)
+  (ly:char-generic-<? a b #f))
+
+(define (ly:char-ci<? a b)
+  (ly:char-generic-<? a b #t))
+
+(define (first-diff-chars str0 str1 ci)
+  (let find-mismatch ((a (string->list str0)) (b (string->list str1)))
+    (cond ((and (null? a) (null? b)) #f)
+          ((null? a) (cons #f (car b)))
+          ((null? b) (cons (car a) #f))
+          ((not ((if ci char-ci=? char=?) (car a) (car b)))
+              (cons (car a) (car b)))
+          (else (find-mismatch (cdr a) (cdr b))))))
+
+(define (ly:string-generic-<? a b ci)
+  (let ((mismatch (first-diff-chars a b ci)))
+    (cond ((and mismatch (car mismatch) (cdr mismatch))
+             ((if ci ly:char-ci<? ly:char<?)
+                   (car mismatch) (cdr mismatch)))
+          ((and mismatch (cdr mismatch)) #t)
+          (else #f))))
+
+(define (ly:string<? a b)
+  "Return #t if string A is less than string B in case-sensitive
+  LilyPond sort order."
+  (ly:string-generic-<? a b #f))
+
+(define (ly:string-ci<? a b)
+  "Return #t if string A is less than string B in case-insensitive
+  LilyPond sort order."
+  (ly:string-generic-<? a b #t))
+
+(define (ly:symbol<? a b)
+  "Return #t if symbol A is less than symbol B in case-sensitive
+  LilyPond sort order."
+  (ly:string<? (symbol->string a)
+               (symbol->string b)))
+
+(define (ly:symbol-ci<? a b)
+  "Return #t if symbol A is less than symbol B in case-insensitive
+  LilyPond sort order."
+  (ly:string-ci<? (symbol->string a)
+                  (symbol->string b)))
+
+(define (ly:alist<? a b)
+  "Return #t if the first key of alist A is less than the first key of
+  alist B, using case-sensitive LilyPond sort order. Keys are assumed to
+  be symbols."
+  (ly:string<? (symbol->string (car a))
+               (symbol->string (car b))))
+
+(define (ly:alist-ci<? a b)
+  "Return #t if the first key of alist A is less than the first key of
+  alist B, using case-insensitive LilyPond sort order. Keys are assumed
+  to be symbols."
+  (ly:string-ci<? (symbol->string (car a))
+                  (symbol->string (car b))))
-- 
2.39.2