suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

no message

Browse Source 
original commit: 3415dee4f14a0d2d91579d4960d551f9c0dbc63f
This commit is contained in:
Robby Findler 2001-08-02 17:30:32 +00:00
parent 9ceb0382fb
commit b1fb00799c
1 changed files with 74 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
collects/tests/utils/gui.ss
View File

@ -2,8 +2,81 @@
(require (lib "mred.ss" "mred")
(lib "class.ss")
(lib "etc.ss"))
(provide find-labelled-window)
(provide find-labelled-window whitespace-string=?)
;; whitespace-string=? : string string -> boolean
;; determines if two strings are equal, up to their whitespace.
;; each string is required to have whitespace in the same place,
;; but not necessarily the same kinds or amount.
(define (whitespace-string=? string1 string2)
(let loop ([i 0]
[j 0]
[in-whitespace? #t])
(cond
[(= i (string-length string1)) (only-whitespace? string2 j)]
[(= j (string-length string2)) (only-whitespace? string1 i)]
[else (let ([c1 (string-ref string1 i)]
[c2 (string-ref string2 j)])
(cond
[in-whitespace?
(cond
[(whitespace? c1)
(loop (+ i 1)
j
#t)]
[(whitespace? c2)
(loop i
(+ j 1)
#t)]
[else (loop i j #f)])]
[(and (whitespace? c1)
(whitespace? c2))
(loop (+ i 1)
(+ j 1)
#t)]
[(char=? c1 c2)
(loop (+ i 1)
(+ j 1)
#f)]
[else #f]))])))
;; whitespace? : char -> boolean
;; deteremines if `c' is whitespace
(define (whitespace? c)
(or (char=? c #\newline)
(char=? c #\space)
(char=? c #\tab)
(char=? c #\return)))
;; only-whitespace? : string number -> boolean
;; returns true if string only contains whitespace, from index `i' onwards
(define (only-whitespace? str i)
(let loop ([n i])
(cond
[(= n (string-length str))
#t]
[(whitespace? (string-ref str n))
(loop (+ n 1))]
[else #f])))
;; whitespace-string=? tests
'(map (lambda (x) (apply equal? x))
(list (list #t (whitespace-string=? "a" "a"))
(list #f (whitespace-string=? "a" "A"))
(list #f (whitespace-string=? "a" " "))
(list #f (whitespace-string=? " " "A"))
(list #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? "a a" "a a"))
(list #t (whitespace-string=? "a a" "a a"))
(list #t (whitespace-string=? "a a" "a a"))
(list #t (whitespace-string=? " a" "a"))
(list #t (whitespace-string=? "a" " a"))
(list #t (whitespace-string=? "a " "a"))
(list #t (whitespace-string=? "a" "a "))))
;;; find-labelled-window : (union ((union #f string) -> window<%>)
;;; ((union #f string) (union #f class) -> window<%>)
;;; ((union #f string) (union class #f) area-container<%> -> window<%>))