move to scheme/base, and improve code

svn: r16593

collects/mysterx/private/util.ss

@@ -1,101 +1,34 @@
 ;;; util.ss -- utility procedures for MysterX
+#lang scheme/base
 
-(module util mzscheme
+(require scheme/string)
-  (require mzlib/unitsig)
+(provide (all-defined-out))
-  (require mzlib/list)	   
 
-  (provide 
+(define (fold-strings-with-spaces strs) (string-join strs " "))
-   fold-strings-with-spaces
-   map-to-string
-   empty-string?
-   bool->string
-   exact-with-bounds?
-   list-pos
-   remove-ws
-   symbols->string
-   hex-digit-string?
-   hex-color-string?
-   empty-property-error)
-  
-  (define (fold-strings-with-spaces strs)
-    (foldr (lambda (s accum) 
-	     (if (string? accum)
-		 (string-append s " " accum)
-		 s))
-	     'dummy
-	     strs))
 
-  (define (map-to-string f)
+(define (map-to-string f)
-    (lambda (lst)
+  (lambda (lst) (fold-strings-with-spaces (map f lst))))
-    (let loop ([lst lst])
-      (cond
-       [(null? lst) ""]
-       [(null? (cdr lst))
-	(f (car lst))]
-       [else
-	(string-append (f (car lst)) 
-		       " "
-		       (loop (cdr lst)))]))))
 
-  (define empty-string?
+(define (empty-string? s) (equal? "" s))
-    (lambda (s)
-      (and (string? s) 
-	   (eq? (string-length s) 0))))
 
-  (define (bool->string v)
+(define (bool->string v) (if v "true" "false"))
-    (if v
-	"true"
-	"false"))
 
-  (define (exact-with-bounds? n lo hi)
+(define (exact-with-bounds? n lo hi) (and (exact-integer? n) (<= lo n hi)))
-	(and (number? n)
-	     (exact? n)
-	     (>= n lo)
-	     (<= n hi)))
 
-  (define (list-pos v lst)
+(define (list-pos v lst)
-    (let loop ([lst lst]
+  (for/or ([x (in-list lst)] [i (in-naturals)]) (and (eq? x v) i)))
-	       [n 0])
-      (if (eq? v (car lst))
-	  n
-	  (loop (cdr lst) (add1 n)))))
-   
-  (define remove-ws ; remove leading whitespace
-    (lambda (cs)
-      (cond [(null? cs) '()]
-	    [(char-whitespace? (car cs))
-	     (remove-ws (cdr cs))]
-	    [else cs])))
 
-  (define symbols->string ; '(a b c ...) => "a b c ..."
+(define (remove-ws cs) ; remove leading whitespace
-    (lambda (syms)
+  (cond [(null? cs) '()]
-      (cond [(null? syms) ""]
+        [(char-whitespace? (car cs)) (remove-ws (cdr cs))]
-	    [(null? (cdr syms))
+        [else cs]))
-	     (symbol->string (car syms))]
-	    [else
-	     (string-append (symbol->string (car syms))
-			    " "
-			    (symbols->string (cdr syms)))])))
-
-  (define (hex-digit-string? elt)
-    (let ([lst (string->list elt)]
-	  [hex-digit? 
-	   (lambda (c)
-	     (or (char-numeric? c)
-		 (memq c '(#\a #\b #\c #\d #\e #\f 
-			   #\A #\B #\C #\D #\E #\F))))])
-      (and (= (length lst) 7)
-	   (eq? (car lst) #\#)
-	   (andmap hex-digit? (cdr lst)))))
-
-  (define (hex-color-string? s)
-    (and (string? s)
-	 (hex-digit-string? s)))
-
-  (define empty-property-error
-     (lambda (p)
-       (error (format "Empty value for property ~a" p)))))
 
+(define (symbols->string syms) ; '(a b c ...) => "a b c ..."
+  (fold-strings-with-spaces (map symbol->string syms)))
 
+(define (hex-digit-string? elt) (regexp-match? #px"(?i:^#[0-9a-f]{6}$)" elt))
 
+(define (hex-color-string? s) (and (string? s) (hex-digit-string? s)))
 
+(define (empty-property-error p)
+  (error (format "Empty value for property ~a" p))))