1 ; Portions Copyright 2003 Sun Microsystems, Inc.
2 ; Portions Copyright 1999-2003 Language Technologies Institute,
3 ; Carnegie Mellon University.
4 ; All Rights Reserved. Use is subject to license terms.
6 ; See the file "license.terms" for information on usage and
7 ; redistribution of this file, and for a DISCLAIMER OF ALL
10 ; Note: The variable t is the value true, but casts to the string "t" and is
11 ; used that way in places. nil is false.
12 ; I think consp is the list? function.
13 ; Replace the sun_string<? function when the scheme interpretor had
14 ; a built-in equivalent. (awb suggested this will happen).
18 ; used to compare two lists by their first elements which are strings
19 (define (carstring<? e1 e2)
20 ;[[[TODO: sun_string<? replace with string<? when function becomes available in
22 (sun_string<? (car e1) (car e2))
25 ; used to compare two lists by their first elements which are strings
26 (define (carstring=? e1 e2)
27 (string-equal (car e1) (car e2))
30 ; quicksort a list l based on two comparison operations < and ==.
32 (define (qsort l cmp<? cmp=?)
33 ; return three lists, a leftpart, the pivotlist and a rightpart
34 ; pivot list is a list of elements where element cmp=? pivot
35 (define (split l pivot leftlist pivotlist rightlist)
38 (list leftlist pivotlist rightlist))
39 ((cmp=? (car l) pivot)
41 leftlist (append pivotlist (list (car l))) rightlist))
42 ((cmp<? (car l) pivot)
44 (append leftlist (list (car l))) pivotlist rightlist))
45 (t (split (cdr l) pivot
46 leftlist pivotlist (append rightlist (list (car l)))))
49 ((< (length l) 3) ; base case
51 ((cdr l) ; if l has two entries
52 (if (cmp<? (car l) (cadr l))
54 (append (cdr l) (list (car l)))))
57 (t (let ((pivot (nth (/ (length l) 2) l)))
58 (let ((newlists (split l pivot nil nil nil)))
59 (append (qsort (car newlists) cmp<? cmp=?)
61 (qsort (caddr newlists) cmp<? cmp=?)))))
65 ; This function may be implemented by the interpretor in future versions
66 ;[[[TODO: replace used of sun_string<? with string<? when function
67 ; becomes available in interpreter.]]]
68 (define (sun_string<? str1 str2)
69 (define (char->int char)
71 ((string-equal char "") 45) ((string-equal char "_") 95)
72 ((string-equal char "0") 48) ((string-equal char "1") 49)
73 ((string-equal char "2") 50) ((string-equal char "3") 51)
74 ((string-equal char "4") 52) ((string-equal char "5") 53)
75 ((string-equal char "6") 54) ((string-equal char "7") 55)
76 ((string-equal char "8") 56) ((string-equal char "9") 57)
77 ((string-equal char "?") 63) ((string-equal char "@") 64)
78 ((string-equal char "A") 65) ((string-equal char "a") 97)
79 ((string-equal char "B") 66) ((string-equal char "b") 98)
80 ((string-equal char "C") 67) ((string-equal char "c") 99)
81 ((string-equal char "D") 68) ((string-equal char "d") 100)
82 ((string-equal char "E") 69) ((string-equal char "e") 101)
83 ((string-equal char "F") 70) ((string-equal char "f") 102)
84 ((string-equal char "G") 71) ((string-equal char "g") 103)
85 ((string-equal char "H") 72) ((string-equal char "h") 104)
86 ((string-equal char "I") 73) ((string-equal char "i") 105)
87 ((string-equal char "J") 74) ((string-equal char "j") 106)
88 ((string-equal char "K") 75) ((string-equal char "k") 107)
89 ((string-equal char "L") 76) ((string-equal char "l") 108)
90 ((string-equal char "M") 77) ((string-equal char "m") 109)
91 ((string-equal char "N") 78) ((string-equal char "n") 110)
92 ((string-equal char "O") 79) ((string-equal char "o") 111)
93 ((string-equal char "P") 80) ((string-equal char "p") 112)
94 ((string-equal char "Q") 81) ((string-equal char "q") 113)
95 ((string-equal char "R") 82) ((string-equal char "r") 114)
96 ((string-equal char "S") 83) ((string-equal char "s") 115)
97 ((string-equal char "T") 84) ((string-equal char "t") 116)
98 ((string-equal char "U") 85) ((string-equal char "u") 117)
99 ((string-equal char "V") 86) ((string-equal char "v") 118)
100 ((string-equal char "W") 87) ((string-equal char "w") 119)
101 ((string-equal char "X") 88) ((string-equal char "x") 120)
102 ((string-equal char "Y") 89) ((string-equal char "y") 121)
103 ((string-equal char "Z") 90) ((string-equal char "z") 122)
104 ((string-equal char ":") 58) ((string-equal char "ä") 253)
105 ((string-equal char "ö") 271)((string-equal char "ü") 277)
106 ((string-equal char "Ä") 221)((string-equal char "Ö") 239)
107 ((string-equal char "Ü") 393)
112 (define (char<? char1 char2)
113 (< (char->int char1) (char->int char2))
115 (define (charl<? charl1 charl2)
117 ((null? charl2) nil) ; return false
118 ((null? charl1) t) ; return true
119 (t (if (string-equal (car charl1) (car charl2))
120 (charl<? (cdr charl1) (cdr charl2))
121 (char<? (car charl1) (car charl2))))
123 (charl<? (symbolexplode str1) (symbolexplode str2))