better naming scheme

svn: r8689

collects/dynext/filename-version.ss

@@ -1,30 +1,30 @@
 #lang scheme/base
 
-;; This module provides the string that should replace xxxxxxx's in file names.
+;; This module provides the string that should replace xxxxxxx's in
-;; The version number is compacted representing alternate sets of digits by
+;; file names.  The version number is combined to a single integer,
-;; letters, and then dropping "."s:
+;; and converted to a string in base 36.  The version is X.Y.Z.W, with
-;;    3.99.1.5 => 3.jj.1.f => 3jj1f
+;; the general restrictions that Y<100 and Z<1000.  This code further
+;; assumes X<200, W<1000 and will throw an error if not -- if that
+;; happens it's time to change the naming scheme or add more x's.
 
 (provide filename-version-part)
+(require version/utils)
+
+(define (num->str n digits)
+  (let ([radix (string-length digits)])
+    (let loop ([n n] [r '()])
+      (if (<= n 0)
+        (list->string r)
+        (loop (quotient n radix)
+              (cons (string-ref digits (modulo n radix)) r))))))
 
 (define filename-version-part
-  (let* ([l (map string->number (regexp-split #rx"[.]" (version)))]
+  (let loop ([n 0]
-         [s (apply
+             [l (version->list (version))]
-             string-append
+             [radix '(200 100 1000 1000)])
-             (let loop ([l l][alpha? #f])
+    (cond [(null? l)
-               (cond
+           (let ([s (num->str n "0123456789abcdefghijklmnopqrstuvwxyz")])
-                [(null? l) null]
+             (string-append (make-string (- 7 (string-length s)) #\_) s))]
-                [else (let ([s (number->string (car l))])
+          [(not (< -1 (car l) (car radix)))
-                        (cons (if alpha?
+           (error 'version "internal error, see dynext/filename-version.ss")]
-                                  (list->string
+          [else (loop (+ (car l) (* (car radix) n)) (cdr l) (cdr radix))])))
-                                   (map (lambda (c)
-                                          (integer->char
-                                           (+ (char->integer c)
-                                              (- (char->integer #\a)
-                                                 (char->integer #\0)))))
-                                        (string->list s)))
-                                  s)
-                              (loop (cdr l) (not alpha?))))])))])
-    (string-append (make-string (max 0 (- 7 (string-length s)))
-                                #\_)
-                   s)))