(import (scheme) (unicode-data))

(include "extract-common.ss")

(define code-point-limit #x110000) ; as of Unicode 5.1

#;(define table-limit #x30000)

(define table-limit code-point-limit)

(define-table (make-table table-ref table-set! table-ref-code)

(make-vector vector-ref vector-set!)

table-limit #x40 #x40)

(define-record-type chardata

(fields (immutable ucchar)

(immutable lcchar)

(immutable tcchar)

(mutable fcchar)

(mutable ucstr)

(mutable lcstr)

(mutable tcstr)

(mutable fcstr)

(immutable decomp-canon)

(immutable decomp-compat)

(mutable grapheme-cluster-break))

(protocol

(lambda (new)

(lambda (ucchar lcchar tcchar decomp-canon decomp-compat)

(new ucchar lcchar tcchar 0 ucchar lcchar tcchar 0

decomp-canon decomp-compat 0)))))

(define (find-cdrec idx ls)

(cond

[(assq idx ls) => cdr]

[else (error 'find-cdrec "~s is missing" idx)]))

(define data-case

(lambda (fields)

(let ([n (hex->num (car fields))]

[uc (list-ref fields 12)]

[lc (list-ref fields 13)]

[tc (list-ref fields 14)])

(define (f x) (if (string=? x "") 0 (- (hex->num x) n)))

(cons n (make-chardata (f uc) (f lc) (f tc)

(parse-decomp n (list-ref fields 5) #f)

(parse-decomp n (list-ref fields 5) #t))))))

(define (split str)

(remove ""

(let f ([i 0] [n (string-length str)])

(cond

[(= i n) (list (substring str 0 n))]

[(char=? (string-ref str i) #\space)

(cons (substring str 0 i)

(split (substring str (+ i 1) n)))]

[else (f (add1 i) n)]))))

(define (improperize ls)

(cond

[(null? (cdr ls)) (car ls)]

[else (cons (car ls) (improperize (cdr ls)))]))

(define (c*->off c* n)

(if (= (length c*) 1)

(- (car c*) n)

(improperize (map integer->char c*))))

(define (codes->off str n)

(c*->off (map hex->num (split str)) n))

(define (parse-decomp n str compat?)

(let f ([ls (split str)])

(cond

[(null? ls) 0]

[(char=? (string-ref (car ls) 0) #\<)

(if compat? (c*->off (map hex->num (cdr ls)) n) 0)]

[else (c*->off (map hex->num ls) n)])))

(define (insert-foldcase-data! ls data)

(for-each

(lambda (fields)

(let ([n (hex->num (car fields))])

(let ([cdrec (find-cdrec n ls)]

[offset (codes->off (caddr fields) n)])

(chardata-fcchar-set! cdrec offset)

(chardata-fcstr-set! cdrec offset))))

(filter (lambda (fields) (member (cadr fields) '("C" "S"))) data))

(for-each

(lambda (fields)

(let ([n (hex->num (car fields))])

(chardata-fcstr-set!

(find-cdrec n ls)

(codes->off (caddr fields) n))))

(filter (lambda (fields) (equal? (cadr fields) "F")) data)))

(define (insert-specialcase-data! ls data)

(for-each

(lambda (fields)

(let ([n (hex->num (car fields))])

(let ([cdrec (find-cdrec n ls)])

(chardata-lcstr-set! cdrec (codes->off (list-ref fields 1) n))

(chardata-tcstr-set! cdrec (codes->off (list-ref fields 2) n))

(chardata-ucstr-set! cdrec (codes->off (list-ref fields 3) n)))))

(filter

(lambda (fields) (= 0 (string-length (list-ref fields 4))))

data)))

(define grapheme-cluster-break-props '(Other

CR

LF

Control

Extend

ZWJ

Regional_Indicator

Prepend

SpacingMark

L

V

T

LV

LVT))

(define (insert-graphemebreak-data! ls data)

(for-each

(lambda (fields)

(let-values ([(lo hi) (hex-range->nums (car fields))])

(let loop ([n lo])

(unless (> n hi)

(unless (assq n ls)

(let ([cdrec (make-chardata 0 0 0 0 0)])

(set! ls (cons (cons n cdrec) ls))))

(let ([cdrec (find-cdrec n ls)])

(chardata-grapheme-cluster-break-set!

cdrec

(let ([s (string->symbol (list-ref fields 1))])

(let loop ([i 0] [props grapheme-cluster-break-props])

(if (eq? s (car props))

i

(loop (add1 i) (cdr props)))))))

(loop (add1 n))))))

data)

ls)

(define verify-identity!

(lambda (n cdrec)

(define (zeros? . args) (andmap (lambda (x) (eqv? x 0)) args))

(unless (zeros? (chardata-ucchar cdrec)

(chardata-lcchar cdrec)

(chardata-tcchar cdrec)

(chardata-fcchar cdrec)

(chardata-ucstr cdrec)

(chardata-lcstr cdrec)

(chardata-tcstr cdrec)

(chardata-fcstr cdrec)

(chardata-decomp-canon cdrec)

(chardata-decomp-compat cdrec))

(error 'verify-identity "failed for ~x, ~s" n cdrec))))

(define build-uncommonized-table

(lambda (acc ls)

(let ([table (make-table 0)])

(for-each

(lambda (x)

(let ([n (car x)] [cdrec (cdr x)])

(unless (< n code-point-limit)

(error 'build-table

"code point value ~s is at or above declared limit ~s"

n code-point-limit))

(if (>= n table-limit)

(verify-identity! n cdrec)

(table-set! table n (acc cdrec)))))

ls)

table)))

(define build-table

(lambda (acc ls)

(commonize* (build-uncommonized-table acc ls))))

(define (get-composition-pairs decomp-canon-table)

(define ($str-decomp-canon c)

(define (strop tbl c)

(let ([n (char->integer c)])

(if (and (fx< table-limit code-point-limit)

(fx>= n table-limit))

c

(let ([x (table-ref tbl n)])

(if (fixnum? x)

(integer->char (fx+ x n))

x)))))

(strop decomp-canon-table c))

(let ([exclusions

(map hex->num

(map car (get-unicode-data

"UNIDATA/CompositionExclusions.txt")))]

[from* '()]

[to* '()])

(define (enter i)

(unless (memv i exclusions)

(let* ([c (integer->char i)] [c* ($str-decomp-canon c)])

(when (pair? c*)

(set! from* (cons c* from*))

(set! to* (cons c to*))))))

(do ([i 0 (fx+ i 1)]) ((fx= i #xD800)) (enter i))

(do ([i #xE000 (fx+ i 1)]) ((fx= i code-point-limit)) (enter i))

(commonize* (cons (list->vector from*) (list->vector to*)))))

(let ([ls (map data-case (get-unicode-data "UNIDATA/UnicodeData.txt"))])

(insert-foldcase-data! ls (get-unicode-data "UNIDATA/CaseFolding.txt"))

(insert-specialcase-data! ls (get-unicode-data "UNIDATA/SpecialCasing.txt"))

(let* ([ls (insert-graphemebreak-data! ls (get-unicode-data "UNIDATA/GraphemeBreakProperty.txt"))])

; insert final sigma flag for char-downcase conversion

(chardata-lcstr-set! (find-cdrec #x3a3 ls) 'sigma)

(with-output-to-file* "unicode-char-cases.ss"

(lambda ()

(parameterize ([print-graph #t] [print-vector-length #f] [print-unicode #f])

(pretty-print

`(module ($char-upcase $char-downcase $char-titlecase $char-foldcase

$str-upcase $str-downcase $str-titlecase $str-foldcase

$str-decomp-canon $str-decomp-compat

$char-grapheme-cluster-break $char-grapheme-break-property

$composition-pairs

,@grapheme-cluster-break-props grapheme-cluster-break-property-count)

(define char-upcase-table ',(build-table chardata-ucchar ls))

(define char-downcase-table ',(build-table chardata-lcchar ls))

(define char-titlecase-table ',(build-table chardata-tcchar ls))

(define char-foldcase-table ',(build-table chardata-fcchar ls))

(define string-upcase-table ',(build-table chardata-ucstr ls))

(define string-downcase-table ',(build-table chardata-lcstr ls))

(define string-titlecase-table ',(build-table chardata-tcstr ls))

(define string-foldcase-table ',(build-table chardata-fcstr ls))

(define decomp-canon-table ',(build-table chardata-decomp-canon ls))

(define decomp-compat-table ',(build-table chardata-decomp-compat ls))

(define grapheme-cluster-break-table ',(build-table chardata-grapheme-cluster-break ls))

,@(let loop ([i 0] [props grapheme-cluster-break-props])

(if (null? props)

'()

(cons `(define ,(car props) ,i)

(loop (add1 i) (cdr props)))))

(define grapheme-cluster-break-property-count ,(length grapheme-cluster-break-props))

(define table-limit ,table-limit)

(define code-point-limit ,code-point-limit)

(define table-ref ,table-ref-code)

(define (charop tbl c)

(let ([n (char->integer c)])

(if (and (fx< table-limit code-point-limit)

(fx>= n table-limit))

c

(integer->char (fx+ (table-ref tbl n) n)))))

(define (strop tbl c)

(let ([n (char->integer c)])

(if (and (fx< table-limit code-point-limit)

(fx>= n table-limit))

c

(let ([x (table-ref tbl n)])

(if (fixnum? x)

(integer->char (fx+ x n))

x)))))

(define (intop tbl c)

(let ([n (char->integer c)])

(if (and (fx< table-limit code-point-limit)

(fx>= n table-limit))

0

(table-ref tbl n))))

(define ($char-upcase c) (charop char-upcase-table c))

(define ($char-downcase c) (charop char-downcase-table c))

(define ($char-titlecase c) (charop char-titlecase-table c))

(define ($char-foldcase c) (charop char-foldcase-table c))

(define ($str-upcase c) (strop string-upcase-table c))

(define ($str-downcase c) (strop string-downcase-table c))

(define ($str-titlecase c) (strop string-titlecase-table c))

(define ($str-foldcase c) (strop string-foldcase-table c))

(define ($str-decomp-canon c) (strop decomp-canon-table c))

(define ($str-decomp-compat c) (strop decomp-compat-table c))

(define ($char-grapheme-cluster-break c) (intop grapheme-cluster-break-table c))

(define ($char-grapheme-break-property c) (vector-ref ',(list->vector grapheme-cluster-break-props)

(intop grapheme-cluster-break-table c)))

(define ($composition-pairs)

',(get-composition-pairs

(build-uncommonized-table chardata-decomp-canon ls))))))))))

(printf "Happy Happy Joy Joy ~a\n" (sizeof cache))