224 lines
8.0 KiB
Scheme
224 lines
8.0 KiB
Scheme
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; Copyright (c) 2006 Michael Sperber
|
|
; All rights reserved.
|
|
;
|
|
; Redistribution and use in source and binary forms, with or without
|
|
; modification, are permitted provided that the following conditions
|
|
; are met:
|
|
; 1. Redistributions of source code must retain the above copyright
|
|
; notice, this list of conditions and the following disclaimer.
|
|
; 2. Redistributions in binary form must reproduce the above copyright
|
|
; notice, this list of conditions and the following disclaimer in the
|
|
; documentation and/or other materials provided with the distribution.
|
|
; 3. The name of the authors may not be used to endorse or promote products
|
|
; derived from this software without specific prior written permission.
|
|
;
|
|
; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
|
; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
|
; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
|
; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
|
; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
|
; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
|
; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
|
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
|
; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
|
; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;
|
|
; Majorly hacked for Larceny by William D Clinger, 3 August 2006.
|
|
; Hacked again for Larceny's test/Lib by W D Clinger, 30 May 2007.
|
|
; Converted into an R6RS benchmark by W D Clinger, 28 November 2007.
|
|
;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(import (rnrs base)
|
|
(rnrs unicode)
|
|
(rnrs bytevectors)
|
|
(rnrs lists)
|
|
(rnrs control)
|
|
(rnrs exceptions)
|
|
(rnrs conditions)
|
|
(rnrs io ports)
|
|
(rnrs io simple))
|
|
|
|
; Given a string and a starting index,
|
|
; returns the index of the first character in the string
|
|
; at or following the starting index that is not a hex digit.
|
|
; Returns the length of the string if no such character is found.
|
|
|
|
(define (index-of-next-non-hex-digit s i)
|
|
(let ((n (string-length s)))
|
|
(let loop ((i i))
|
|
(if (< i n)
|
|
(case (string-ref s i)
|
|
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
|
|
#\a #\b #\c #\d #\e #\f
|
|
#\A #\B #\C #\D #\E #\F)
|
|
(loop (+ i 1)))
|
|
(else
|
|
i))
|
|
n))))
|
|
|
|
; Given a string of hex digits, returns its value as an integer.
|
|
|
|
(define (hexstring->int s)
|
|
(define (hexdigit->int c)
|
|
(case c
|
|
((#\0) 0)
|
|
((#\1) 1)
|
|
((#\2) 2)
|
|
((#\3) 3)
|
|
((#\4) 4)
|
|
((#\5) 5)
|
|
((#\6) 6)
|
|
((#\7) 7)
|
|
((#\8) 8)
|
|
((#\9) 9)
|
|
((#\a #\A) 10)
|
|
((#\b #\B) 11)
|
|
((#\c #\C) 12)
|
|
((#\d #\D) 13)
|
|
((#\e #\E) 14)
|
|
((#\f #\F) 15)
|
|
(else (error 'hexstring->int "Bad hex digit: " c))))
|
|
(let ((n (string-length s)))
|
|
(do ((i 0 (+ i 1))
|
|
(result 0 (+ (* 16 result) (hexdigit->int (string-ref s i)))))
|
|
((= i n) result))))
|
|
|
|
; Given a non-comment line from NormalizationTest.txt,
|
|
; returns the 5 strings parsed from that line (as multiple values).
|
|
|
|
(define (parse-scalar-values s)
|
|
(let ((size (string-length s)))
|
|
(let column-loop ((start 0) (count 0) (rev-columns '()))
|
|
(if (= count 5)
|
|
(apply values (reverse rev-columns))
|
|
(let sv-loop ((start start) (rev-svs '()))
|
|
(let* ((i (index-of-next-non-hex-digit s start))
|
|
(n (hexstring->int (substring s start i))))
|
|
(if (char=? #\space (string-ref s i))
|
|
(sv-loop (+ 1 i) (cons n rev-svs))
|
|
(column-loop (+ 1 i) (+ 1 count)
|
|
(cons (list->string
|
|
(map integer->char
|
|
(reverse (cons n rev-svs))))
|
|
rev-columns)))))))))
|
|
|
|
; Crude test rig.
|
|
|
|
(define total-tests 0)
|
|
(define total-failed 0)
|
|
(define total-inputs 0)
|
|
(define current-input "")
|
|
(define failed-inputs '())
|
|
|
|
(define (normalization-test-init!)
|
|
(set! total-tests 0)
|
|
(set! total-failed 0)
|
|
(set! total-inputs 0)
|
|
(set! current-input "")
|
|
(set! failed-inputs '()))
|
|
|
|
(define (normalization-test-start name)
|
|
;(display ".")
|
|
(set! total-inputs (+ total-inputs 1))
|
|
(set! current-input name))
|
|
|
|
(define (failure-message-failed id ans correct)
|
|
(display "********** FAILURE *********") (newline)
|
|
(display " ") (display id) (display " did not pass test.")
|
|
(newline)
|
|
(display " Returned value = ") (display ans) (newline)
|
|
(display " Correct value = ") (display correct) (newline))
|
|
|
|
(define (normalization-test name predicate x y)
|
|
(set! total-tests (+ total-tests 1))
|
|
(if (not (predicate x y))
|
|
(begin (set! total-failed (+ total-failed 1))
|
|
(failure-message-failed name x y)
|
|
(if (or (null? failed-inputs)
|
|
(not (equal? current-input (car failed-inputs))))
|
|
(set! failed-inputs (cons current-input failed-inputs))))))
|
|
|
|
(define (normalization-test-summarize)
|
|
(newline)
|
|
(display "Failed ")
|
|
(write total-failed)
|
|
(display " out of ")
|
|
(write total-tests)
|
|
(newline))
|
|
|
|
(define (normalization-check-line s)
|
|
(call-with-values
|
|
(lambda ()
|
|
(parse-scalar-values s))
|
|
(lambda (c1 c2 c3 c4 c5)
|
|
(normalization-test-start s)
|
|
(normalization-check-one c1 c2 c3 c4 c5))))
|
|
|
|
(define (normalization-check-one c1 c2 c3 c4 c5)
|
|
(normalization-test "c2 == NFC(c1)" string=? c2 (string-normalize-nfc c1))
|
|
(normalization-test "c2 == NFC(c2)" string=? c2 (string-normalize-nfc c2))
|
|
(normalization-test "c2 == NFC(c3)" string=? c2 (string-normalize-nfc c3))
|
|
(normalization-test "c4 == NFC(c4)" string=? c4 (string-normalize-nfc c4))
|
|
(normalization-test "c4 == NFC(c5)" string=? c4 (string-normalize-nfc c5))
|
|
|
|
(normalization-test "c3 == NFD(c1)" string=? c3 (string-normalize-nfd c1))
|
|
(normalization-test "c3 == NFD(c2)" string=? c3 (string-normalize-nfd c2))
|
|
(normalization-test "c3 == NFD(c3)" string=? c3 (string-normalize-nfd c3))
|
|
(normalization-test "c5 == NFD(c4)" string=? c5 (string-normalize-nfd c4))
|
|
(normalization-test "c5 == NFD(c5)" string=? c5 (string-normalize-nfd c5))
|
|
|
|
(normalization-test "c4 == NFKC(c1)" string=? c4 (string-normalize-nfkc c1))
|
|
(normalization-test "c4 == NFKC(c2)" string=? c4 (string-normalize-nfkc c2))
|
|
(normalization-test "c4 == NFKC(c3)" string=? c4 (string-normalize-nfkc c3))
|
|
(normalization-test "c4 == NFKC(c4)" string=? c4 (string-normalize-nfkc c4))
|
|
(normalization-test "c4 == NFKC(c5)" string=? c4 (string-normalize-nfkc c5))
|
|
|
|
(normalization-test "c5 == NFKD(c1)" string=? c5 (string-normalize-nfkd c1))
|
|
(normalization-test "c5 == NFKD(c2)" string=? c5 (string-normalize-nfkd c2))
|
|
(normalization-test "c5 == NFKD(c3)" string=? c5 (string-normalize-nfkd c3))
|
|
(normalization-test "c5 == NFKD(c4)" string=? c5 (string-normalize-nfkd c4))
|
|
(normalization-test "c5 == NFKD(c5)" string=? c5 (string-normalize-nfkd c5)))
|
|
|
|
(define current-line "")
|
|
|
|
(define (normalization-check-all filename)
|
|
(call-with-input-file filename
|
|
(lambda (port)
|
|
(let loop ()
|
|
(let ((thing (get-line port)))
|
|
(set! current-line thing)
|
|
(if (string? thing)
|
|
(begin
|
|
(if (and (not (string=? "" thing))
|
|
(not (char=? (string-ref thing 0) #\#))
|
|
(not (char=? (string-ref thing 0) #\@)))
|
|
(normalization-check-line thing))
|
|
(loop))))))))
|
|
|
|
(define (run-normalization-tests input)
|
|
;(display "Normalization") (newline)
|
|
(normalization-test-init!)
|
|
(normalization-check-all input)
|
|
;(normalization-test-summarize)
|
|
(- total-tests (length failed-inputs)))
|
|
|
|
(define (main)
|
|
(let* ((count (read))
|
|
(input1 (read))
|
|
(output (read))
|
|
(s2 (number->string count))
|
|
(s1 input1)
|
|
(name "normalization"))
|
|
(run-r6rs-benchmark
|
|
(string-append name ":" s2)
|
|
count
|
|
(lambda () (run-normalization-tests (hide count input1)))
|
|
(lambda (result)
|
|
(and (null? failed-inputs)
|
|
(= result output))))))
|