scm/lily-sort.scm

   1 ;;;; lily-sort.scm -- improved sorting of symbols, strings, and alists.
   2 ;;;;
   3 ;;;; source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; Copyright 2009--2015 Mark Polesky <markpolesky@yahoo.com>
   6
   7
   8 ;; This file implements a LilyPond-specific character-sorting algorithm
   9 ;; that can be used to sort lists, alists, etc. consistently and
  10 ;; predictably throughout the source code. The primary advantage of this
  11 ;; algorithm is that lists are sorted in a more intuitive way, which may
  12 ;; allow users to find items faster in the documentation.
  13 ;;
  14 ;; As an example, a user, looking in the documentation to see if there's
  15 ;; a function called "ly:grob?", might assume that there isn't one,
  16 ;; since it doesn't appear before "ly:grob-alist-chain" (using the
  17 ;; default sort).
  18 ;;
  19 ;; This happens because "-" comes before "?" in the default sort order.
  20 ;; But since "?" is more likely to come at the end of a scheme symbol, a
  21 ;; more intuitive sort can be achieved by reversing that order.
  22 ;;
  23 ;; Similarly, non-alphanumeric characters can be ranked in terms of how
  24 ;; likely one will be found closer to the end of a symbol. For example,
  25 ;; ":" is stronger separator than "-", as can be seen here:
  26 ;;
  27 ;; "ly:staff-symbol::print"
  28 ;; "ly:staff-symbol-referencer::callback"
  29 ;;
  30 ;; Intuitively, "staff-symbol-referencer" ought to come after
  31 ;; "staff-symbol", but since "-" comes before ":" in the default sort
  32 ;; order, these symbols are by default listed in the opposite order.
  33 ;;
  34 ;; Thus the algorithm implemented here ranks the following nine
  35 ;; characters (starting with the space character) in order from
  36 ;; most-to-least likely to terminate a symbol: " !?<=>:-_". These nine
  37 ;; characters are in effect "extracted" from the default order and then
  38 ;; "prepended" to it so that they now come first. This is achieved with
  39 ;; the function "ly:char-generic-<?".
  40 ;;
  41 ;; This file defines 3 case-sensitive binary comparison predicates:
  42 ;;   ly:string<?     ly:symbol<?     ly:alist<?
  43 ;; and their case-insensitive counterparts:
  44 ;;   ly:string-ci<?  ly:symbol-ci<?  ly:alist-ci<?
  45 ;;
  46 ;; Case-insensitive predicates are recommended in general; otherwise
  47 ;; symbols like "Y-offset" appear near the top of lists which
  48 ;; otherwise include mostly lowercase symbols.
  49
  50 (define (ly:char-generic-<? a b ci)
  51   (let* ((init-list (string->list " !?<=>:-_"))
  52          (mem-a (member a init-list))
  53          (mem-b (member b init-list)))
  54     (cond ((and mem-a mem-b) (< (length mem-b) (length mem-a)))
  55           (mem-a #t)
  56           (mem-b #f)
  57           (else ((if ci char-ci<? char<?) a b)))))
  58
  59 (define (ly:char<? a b)
  60   (ly:char-generic-<? a b #f))
  61
  62 (define (ly:char-ci<? a b)
  63   (ly:char-generic-<? a b #t))
  64
  65 (define (first-diff-chars str0 str1 ci)
  66   (let find-mismatch ((a (string->list str0)) (b (string->list str1)))
  67     (cond ((and (null? a) (null? b)) #f)
  68           ((null? a) (cons #f (car b)))
  69           ((null? b) (cons (car a) #f))
  70           ((not ((if ci char-ci=? char=?) (car a) (car b)))
  71            (cons (car a) (car b)))
  72           (else (find-mismatch (cdr a) (cdr b))))))
  73
  74 (define (ly:string-generic-<? a b ci)
  75   (let ((mismatch (first-diff-chars a b ci)))
  76     (cond ((and mismatch (car mismatch) (cdr mismatch))
  77            ((if ci ly:char-ci<? ly:char<?)
  78             (car mismatch) (cdr mismatch)))
  79           ((and mismatch (cdr mismatch)) #t)
  80           (else #f))))
  81
  82 (define (ly:string<? a b)
  83   "Return #t if string A is less than string B in case-sensitive
  84   LilyPond sort order."
  85   (ly:string-generic-<? a b #f))
  86
  87 (define (ly:string-ci<? a b)
  88   "Return #t if string A is less than string B in case-insensitive
  89   LilyPond sort order."
  90   (ly:string-generic-<? a b #t))
  91
  92 (define (ly:symbol<? a b)
  93   "Return #t if symbol A is less than symbol B in case-sensitive
  94   LilyPond sort order."
  95   (ly:string<? (symbol->string a)
  96                (symbol->string b)))
  97
  98 (define (ly:symbol-ci<? a b)
  99   "Return #t if symbol A is less than symbol B in case-insensitive
 100   LilyPond sort order."
 101   (ly:string-ci<? (symbol->string a)
 102                   (symbol->string b)))
 103
 104 (define (ly:alist<? a b)
 105   "Return #t if the first key of alist A is less than the first key of
 106   alist B, using case-sensitive LilyPond sort order.  Keys are assumed to
 107   be symbols."
 108   (ly:string<? (symbol->string (car a))
 109                (symbol->string (car b))))
 110
 111 (define (ly:alist-ci<? a b)
 112   "Return #t if the first key of alist A is less than the first key of
 113   alist B, using case-insensitive LilyPond sort order.  Keys are assumed
 114   to be symbols."
 115   (ly:string-ci<? (symbol->string (car a))
 116                   (symbol->string (car b))))