[p5sagit/p5-mst-13.2.git] / lib / unicode / mktables.PL

#!../../miniperl

$UnicodeData = "UnicodeData-Latest.txt";

# Note: we try to keep filenames unique within first 8 chars.  Using
# subdirectories for the following helps.
mkdir "In", 0777;
mkdir "Is", 0777;
mkdir "To", 0777;
mkdir "Eq", 0777;

@todo = (
# typical

    ['IsWord',  '$cat =~ /^L[ulo]|^Nd/ or $code eq "005F"',	''],
    ['IsAlnum', '$cat =~ /^L[ulo]|^Nd/',	''],
    ['IsAlpha',  '$cat =~ /^L[ulo]/',	''],
    ['IsSpace',  '$cat =~ /^Z/ or $code lt "0020" and chr(hex $code) =~ /^\s/',	''],
    ['IsDigit',  '$cat =~ /^Nd$/',	''],
    ['IsUpper',  '$cat =~ /^Lu$/',	''],
    ['IsLower',  '$cat =~ /^Ll$/',	''],
    ['IsASCII',  'hex $code <= 127',	''],
    ['IsCntrl',  '$cat =~ /^C/',	''],
    ['IsGraph',  '$cat =~ /^[^C]/ and $code ne "0020"',	''],
    ['IsPrint',  '$cat =~ /^[^C]/',	''],
    ['IsPunct',  '$cat =~ /^P/',	''],
    ['IsXDigit', '$code =~ /^00(3[0-9]|[46][1-6])$/',	''],
    ['ToUpper',  '$up',			'$up'],
    ['ToLower',  '$down',		'$down'],
    ['ToTitle',  '$title',		'$title'],
    ['ToDigit',  '$dec ne ""',		'$dec'],

# Name

    ['Name',	'$name',		'$name'],

# Category

    ['Category', '$cat',		'$cat'],

# Normative

    ['IsM',	'$cat =~ /^M/',		''],	# Mark
    ['IsMn',	'$cat eq "Mn"',		''],	# Mark, Non-Spacing 
    ['IsMc',	'$cat eq "Mc"',		''],	# Mark, Combining

    ['IsN',	'$cat =~ /^N/',		''],	# Number
    ['IsNd',	'$cat eq "Nd"',		''],	# Number, Decimal Digit
    ['IsNo',	'$cat eq "No"',		''],	# Number, Other

    ['IsZ',	'$cat =~ /^Z/',		''],	# Zeparator
    ['IsZs',	'$cat eq "Zs"',		''],	# Separator, Space
    ['IsZl',	'$cat eq "Zl"',		''],	# Separator, Line
    ['IsZp',	'$cat eq "Zp"',		''],	# Separator, Paragraph

    ['IsC',	'$cat =~ /^C/',		''],	# Crazy
    ['IsCc',	'$cat eq "Cc"',		''],	# Other, Control or Format
    ['IsCo',	'$cat eq "Co"',		''],	# Other, Private Use
    ['IsCn',	'$cat eq "Cn"',		''],	# Other, Not Assigned
 
# Informative

    ['IsL',	'$cat =~ /^L/',		''],	# Letter
    ['IsLu',	'$cat eq "Lu"',		''],	# Letter, Uppercase
    ['IsLl',	'$cat eq "Ll"',		''],	# Letter, Lowercase
    ['IsLt',	'$cat eq "Lt"',		''],	# Letter, Titlecase 
    ['IsLm',	'$cat eq "Lm"',		''],	# Letter, Modifier
    ['IsLo',	'$cat eq "Lo"',		''],	# Letter, Other 

    ['IsP',	'$cat =~ /^P/',		''],	# Punctuation
    ['IsPd',	'$cat eq "Pd"',		''],	# Punctuation, Dash
    ['IsPs',	'$cat eq "Ps"',		''],	# Punctuation, Open
    ['IsPe',	'$cat eq "Pe"',		''],	# Punctuation, Close
    ['IsPo',	'$cat eq "Po"',		''],	# Punctuation, Other

    ['IsS',	'$cat =~ /^S/',		''],	# Symbol
    ['IsSm',	'$cat eq "Sm"',		''],	# Symbol, Math
    ['IsSc',	'$cat eq "Sc"',		''],	# Symbol, Currency
    ['IsSo',	'$cat eq "So"',		''],	# Symbol, Other

# Combining class
    ['CombiningClass', '$comb',		'$comb'],

# BIDIRECTIONAL PROPERTIES
 
    ['Bidirectional', '$bid',		'$bid'],

# Strong types:

    ['IsBidiL',	'$bid eq "L"',		''],	# Left-Right; Most alphabetic,
						# syllabic, and logographic
						# characters (e.g., CJK
						# ideographs)
    ['IsBidiR',	'$bid eq "R"',		''],	# Right-Left; Arabic, Hebrew,
						# and punctuation specific to
						# those scripts

# Weak types:

    ['IsBidiEN','$bid eq "EN"',		''],	# European Number
    ['IsBidiES','$bid eq "ES"',		''],	# European Number Separator
    ['IsBidiET','$bid eq "ET"',		''],	# European Number Terminator
    ['IsBidiAN','$bid eq "AN"',		''],	# Arabic Number
    ['IsBidiCS','$bid eq "CS"',		''],	# Common Number Separator

# Separators:

    ['IsBidiB',	'$bid eq "B"',		''],	# Block Separator
    ['IsBidiS',	'$bid eq "S"',		''],	# Segment Separator

# Neutrals:

    ['IsBidiWS','$bid eq "WS"',		''],	# Whitespace
    ['IsBidiON','$bid eq "ON"',		''],	# Other Neutrals ; All other
						# characters: punctuation,
						# symbols

# Decomposition

    ['Decomposition',	'$decomp',	'$decomp'],
    ['IsDecoCanon',	'$decomp && $decomp !~ /^</',	''],
    ['IsDecoCompat',	'$decomp =~ /^</',		''],
    ['IsDCfont',	'$decomp =~ /^<font>/',		''],
    ['IsDCnoBreak',	'$decomp =~ /^<noBreak>/',	''],
    ['IsDCinitial',	'$decomp =~ /^<initial>/',	''],
    ['IsDCinital',	'$decomp =~ /^<medial>/',	''],
    ['IsDCfinal',	'$decomp =~ /^<final>/',	''],
    ['IsDCisolated',	'$decomp =~ /^<isolated>/',	''],
    ['IsDCcircle',	'$decomp =~ /^<circle>/',	''],
    ['IsDCsuper',	'$decomp =~ /^<super>/',	''],
    ['IsDCsub',		'$decomp =~ /^<sub>/',		''],
    ['IsDCvertical',	'$decomp =~ /^<vertical>/',	''],
    ['IsDCwide',	'$decomp =~ /^<wide>/',		''],
    ['IsDCnarrow',	'$decomp =~ /^<narrow>/',	''],
    ['IsDCsmall',	'$decomp =~ /^<small>/',	''],
    ['IsDCsquare',	'$decomp =~ /^<square>/',	''],
    ['IsDCcompat',	'$decomp =~ /^<compat>/',	''],

# Number

    ['Number', 	'$num',			'$num'],

# Mirrored

    ['IsMirrored', '$mir eq "Y"',	''],

# Arabic

    ['ArabLink', 	'1',		'$link'],
    ['ArabLnkGrp', 	'1',		'$linkgroup'],

# Jamo

    ['JamoShort',	'1',		'$short'],
);

# This is not written for speed...

foreach $file (@todo) {
    my ($table, $wanted, $val) = @$file;
    next if @ARGV and not grep { $_ eq $table } @ARGV;
    print $table,"\n";
    if ($table =~ /^(Is|In|To)(.*)/) {
	open(OUT, ">$1/$2.pl") or die "Can't create $1/$2.pl: $!\n";
    }
    else {
	open(OUT, ">$table.pl") or die "Can't create $table.pl: $!\n";
    }
    print OUT <<"END";
return <<'END';
END
    print OUT proplist($table, $wanted, $val);
    print OUT "END\n";
    close OUT;
}

# Must treat blocks specially.

exit if @ARGV and not grep { $_ eq Block } @ARGV;
print "Block\n";
open(UD, 'blocks.txt') or die "Can't open blocks.txt: $!\n";
open(OUT, ">Block.pl") or die "Can't create $table.pl: $!\n";
print OUT <<"END";
return <<'END';
END

while (<UD>) {
    next if /^#/;
    next if /^$/;
    chomp;
    ($code, $last, $name) = split(/; */);
    if ($name) {
	print OUT "$code	$last	$name\n";
	$name =~ s/\s+//g;
	open(BLOCK, ">In/$name.pl");
	print BLOCK <<"END2";
return <<'END';
$code	$last
END
END2
	close BLOCK;
    }
}

print OUT "END\n";
close OUT;

##################################################

sub proplist {
    my ($table, $wanted, $val) = @_;
    my @wanted;
    my $out;
    my $split;

    if ($table =~ /^Arab/) {
	open(UD, "arabshp.txt") or warn "Can't open $table: $!";

	$split = '($code, $name, $link, $linkgroup) = split(/; */);';
    }
    elsif ($table =~ /^Jamo/) {
	open(UD, "jamo2.txt") or warn "Can't open $table: $!";

	$split = '($code, $short, $name) = split(/; */); $code =~ s/^U\+//;';
    }
    else {
	open(UD, $UnicodeData) or warn "Can't open $UnicodeData: $!";

	$split = '($code, $name, $cat, $comb, $bid, $decomp, $dec, $dig, $num, $mir, $uni1,
		$comment, $up, $down, $title) = split(/;/);';
    }

    if ($table =~ /^(?:To|Is)[A-Z]/) {
	eval <<"END";
	    while (<UD>) {
		next if /^#/;
		next if /^\s/;
		chop;
		$split
		if ($wanted) {
		    push(\@wanted, [hex \$code, hex $val, \$name =~ /, First>\$/]);
		}
	    }
END
	die $@ if $@;

	while (@wanted) {
	    $beg = shift @wanted;
	    $last = $beg;
	    while (@wanted and $wanted[0]->[0] == $last->[0] + 1 and
		(not $val or $wanted[0]->[1] == $last->[1] + 1)) {
		    $last = shift @wanted;
	    }
	    $out .= sprintf "%04x", $beg->[0];
	    if ($beg->[2]) {
		$last = shift @wanted;
	    }
	    if ($beg == $last) {
		$out .= "\t";
	    }
	    else {
		$out .= sprintf "\t%04x", $last->[0];
	    }
	    $out .= sprintf "\t%04x", $beg->[1] if $val;
	    $out .= "\n";
	}
    }
    else {
	eval <<"END";
	    while (<UD>) {
		next if /^#/;
		next if /^\s*\$/;
		chop;
		$split
		if ($wanted) {
		    push(\@wanted, [hex \$code, $val, \$name =~ /, First>\$/]);
		}
	    }
END
	die $@ if $@;

	while (@wanted) {
	    $beg = shift @wanted;
	    $last = $beg;
	    while (@wanted and $wanted[0]->[0] == $last->[0] + 1 and
		($wanted[0]->[1] eq $last->[1])) {
		    $last = shift @wanted;
	    }
	    $out .= sprintf "%04x", $beg->[0];
	    if ($beg->[2]) {
		$last = shift @wanted;
	    }
	    if ($beg == $last) {
		$out .= "\t";
	    }
	    else {
		$out .= sprintf "\t%04x", $last->[0];
	    }
	    $out .= sprintf "\t%s\n", $beg->[1];
	}
    }
    $out;
}

# Create the equivalence mappings.

open(UNICODEDATA, $UnicodeData) || die "$0: $UnicodeData: $!\n";

while (<UNICODEDATA>) {
    ($code, $name) = split /;/;
    
    $code{$name} = $code;
    $name{$code} = $name;

    next unless $name =~ /^(.+? LETTER .+?) WITH .+( \w+ FORM)?$/;

    push @base, [ $code, $1 ];
    push @base, [ $code, $1.$2 ] if $2 ne '';

    # Before this "diacritics stripping" phase (and for Arabic, also
    # "form stripping" phase) all ligatures could be decomposed into
    # their constituent letters.
    #
    # For example the ligature
    # ARABIC LIGATURE YEH WITH HAMZA ABOVE WITH ALEF ISOLATED FORM
    # would go first through ligature decomposition producing the two letters
    # ARABIC LETTER YEH WITH HAMZA ABOVE ISOLATED FORM
    # ARABIC LETTER ALEF WITH HAMZA ABOVE ISOLATED FORM
    # and those with diacritics stripping
    # ARABIC LETTER YEH ISOLATED FORM
    # ARABIC LETTER ALEF ISOLATED FORM
    # and those with the Arabic form stripping
    # ARABIC LETTER YEH
    # ARABIC LETTER ALEF ISOLATED FORM
    # ARABIC LETTER YEH
    # ARABIC LETTER ALEF ISOLATED FORM
    #
    # Similarly for ligatures from other scripts.
    # Effectively this would mean that ligatures turn into categories
    # (Unicodese for character classes).
}

foreach my $b (@base) {
    ($code, $base) = @$b;
    next unless exists $code{$base};
    push @{$unicode{$code{$base}}}, $code;
#   print "$code: $name{$code} -> $base\n",
}

@unicode = sort keys %unicode;

print "Eq/Unicode\n";
if (open(EQ_UNICODE, ">Eq/Unicode")) {
    foreach my $c (@unicode) {
	print EQ_UNICODE "$c @{$unicode{$c}}\n";
    }
    close EQ_UNICODE;
} else {
    die "$0: failed to open Eq/Unicode for writing: $!\n";
}

print "Eq/Latin1\n";
if (open(EQ_LATIN1, ">Eq/Latin1")) {
    foreach my $c (@unicode) {
	last if hex($c) > 255;
	my @c = grep { hex($_) <= 255 } @{$unicode{$c}};
	next unless @c;
	print EQ_LATIN1 "$c @c\n";
    }
    close EQ_LATIN1;
} else {
    die "$0: failed to open Eq/Latin1 for writing: $!\n";
}
Commit	Line	Data
a0ed51b3	1	#!../../miniperl
a0ed51b3	2
11695a73	3	$UnicodeData = "UnicodeData-Latest.txt";
11695a73	4
a0ed51b3	5	# Note: we try to keep filenames unique within first 8 chars. Using
	6	# subdirectories for the following helps.
	7	mkdir "In", 0777;
	8	mkdir "Is", 0777;
	9	mkdir "To", 0777;
11695a73	10	mkdir "Eq", 0777;
a0ed51b3	11
	12	@todo = (
	13	# typical
	14
b8c5462f	15	['IsWord', '$cat =~ /^L[ulo]\|^Nd/ or $code eq "005F"', ''],
	16	['IsAlnum', '$cat =~ /^L[ulo]\|^Nd/', ''],
	17	['IsAlpha', '$cat =~ /^L[ulo]/', ''],
	18	['IsSpace', '$cat =~ /^Z/ or $code lt "0020" and chr(hex $code) =~ /^\s/', ''],
	19	['IsDigit', '$cat =~ /^Nd$/', ''],
	20	['IsUpper', '$cat =~ /^Lu$/', ''],
	21	['IsLower', '$cat =~ /^Ll$/', ''],
	22	['IsASCII', 'hex $code <= 127', ''],
	23	['IsCntrl', '$cat =~ /^C/', ''],
	24	['IsGraph', '$cat =~ /^[^C]/ and $code ne "0020"', ''],
	25	['IsPrint', '$cat =~ /^[^C]/', ''],
	26	['IsPunct', '$cat =~ /^P/', ''],
	27	['IsXDigit', '$code =~ /^00(3[0-9]\|[46][1-6])$/', ''],
	28	['ToUpper', '$up', '$up'],
	29	['ToLower', '$down', '$down'],
	30	['ToTitle', '$title', '$title'],
	31	['ToDigit', '$dec ne ""', '$dec'],
a0ed51b3	32
	33	# Name
	34
	35	['Name', '$name', '$name'],
	36
	37	# Category
	38
	39	['Category', '$cat', '$cat'],
	40
	41	# Normative
	42
	43	['IsM', '$cat =~ /^M/', ''], # Mark
	44	['IsMn', '$cat eq "Mn"', ''], # Mark, Non-Spacing
	45	['IsMc', '$cat eq "Mc"', ''], # Mark, Combining
	46
	47	['IsN', '$cat =~ /^N/', ''], # Number
	48	['IsNd', '$cat eq "Nd"', ''], # Number, Decimal Digit
	49	['IsNo', '$cat eq "No"', ''], # Number, Other
	50
	51	['IsZ', '$cat =~ /^Z/', ''], # Zeparator
	52	['IsZs', '$cat eq "Zs"', ''], # Separator, Space
	53	['IsZl', '$cat eq "Zl"', ''], # Separator, Line
	54	['IsZp', '$cat eq "Zp"', ''], # Separator, Paragraph
	55
	56	['IsC', '$cat =~ /^C/', ''], # Crazy
	57	['IsCc', '$cat eq "Cc"', ''], # Other, Control or Format
	58	['IsCo', '$cat eq "Co"', ''], # Other, Private Use
	59	['IsCn', '$cat eq "Cn"', ''], # Other, Not Assigned
	60
	61	# Informative
	62
	63	['IsL', '$cat =~ /^L/', ''], # Letter
	64	['IsLu', '$cat eq "Lu"', ''], # Letter, Uppercase
	65	['IsLl', '$cat eq "Ll"', ''], # Letter, Lowercase
	66	['IsLt', '$cat eq "Lt"', ''], # Letter, Titlecase
	67	['IsLm', '$cat eq "Lm"', ''], # Letter, Modifier
	68	['IsLo', '$cat eq "Lo"', ''], # Letter, Other
	69
	70	['IsP', '$cat =~ /^P/', ''], # Punctuation
	71	['IsPd', '$cat eq "Pd"', ''], # Punctuation, Dash
	72	['IsPs', '$cat eq "Ps"', ''], # Punctuation, Open
	73	['IsPe', '$cat eq "Pe"', ''], # Punctuation, Close
	74	['IsPo', '$cat eq "Po"', ''], # Punctuation, Other
	75
	76	['IsS', '$cat =~ /^S/', ''], # Symbol
	77	['IsSm', '$cat eq "Sm"', ''], # Symbol, Math
	78	['IsSc', '$cat eq "Sc"', ''], # Symbol, Currency
	79	['IsSo', '$cat eq "So"', ''], # Symbol, Other
	80
	81	# Combining class
	82	['CombiningClass', '$comb', '$comb'],
	83
	84	# BIDIRECTIONAL PROPERTIES
	85
	86	['Bidirectional', '$bid', '$bid'],
	87
	88	# Strong types:
	89
	90	['IsBidiL', '$bid eq "L"', ''], # Left-Right; Most alphabetic,
	91	# syllabic, and logographic
	92	# characters (e.g., CJK
	93	# ideographs)
	94	['IsBidiR', '$bid eq "R"', ''], # Right-Left; Arabic, Hebrew,
	95	# and punctuation specific to
96	# those scripts
97
98	# Weak types:
99
100	['IsBidiEN','$bid eq "EN"', ''], # European Number
101	['IsBidiES','$bid eq "ES"', ''], # European Number Separator
102	['IsBidiET','$bid eq "ET"', ''], # European Number Terminator
103	['IsBidiAN','$bid eq "AN"', ''], # Arabic Number
104	['IsBidiCS','$bid eq "CS"', ''], # Common Number Separator
105
106	# Separators:
107
108	['IsBidiB', '$bid eq "B"', ''], # Block Separator
109	['IsBidiS', '$bid eq "S"', ''], # Segment Separator
110
111	# Neutrals:
112
113	['IsBidiWS','$bid eq "WS"', ''], # Whitespace
114	['IsBidiON','$bid eq "ON"', ''], # Other Neutrals ; All other
115	# characters: punctuation,
116	# symbols
117
118	# Decomposition
119
120	['Decomposition', '$decomp', '$decomp'],
121	['IsDecoCanon', '$decomp && $decomp !~ /^</', ''],
122	['IsDecoCompat', '$decomp =~ /^</', ''],
123	['IsDCfont', '$decomp =~ /^<font>/', ''],
124	['IsDCnoBreak', '$decomp =~ /^<noBreak>/', ''],
125	['IsDCinitial', '$decomp =~ /^<initial>/', ''],
126	['IsDCinital', '$decomp =~ /^<medial>/', ''],
127	['IsDCfinal', '$decomp =~ /^<final>/', ''],
128	['IsDCisolated', '$decomp =~ /^<isolated>/', ''],
129	['IsDCcircle', '$decomp =~ /^<circle>/', ''],
130	['IsDCsuper', '$decomp =~ /^<super>/', ''],
131	['IsDCsub', '$decomp =~ /^<sub>/', ''],
132	['IsDCvertical', '$decomp =~ /^<vertical>/', ''],
133	['IsDCwide', '$decomp =~ /^<wide>/', ''],
134	['IsDCnarrow', '$decomp =~ /^<narrow>/', ''],
135	['IsDCsmall', '$decomp =~ /^<small>/', ''],
136	['IsDCsquare', '$decomp =~ /^<square>/', ''],
137	['IsDCcompat', '$decomp =~ /^<compat>/', ''],
138
139	# Number
140
141	['Number', '$num', '$num'],
142
143	# Mirrored
144
145	['IsMirrored', '$mir eq "Y"', ''],
146
147	# Arabic
148
149	['ArabLink', '1', '$link'],
150	['ArabLnkGrp', '1', '$linkgroup'],
151
152	# Jamo
153
154	['JamoShort', '1', '$short'],
155	);
156
157	# This is not written for speed...
158
159	foreach $file (@todo) {
160	my ($table, $wanted, $val) = @$file;
161	next if @ARGV and not grep { $_ eq $table } @ARGV;
162	print $table,"\n";
163	if ($table =~ /^(Is\|In\|To)(.*)/) {
164	open(OUT, ">$1/$2.pl") or die "Can't create $1/$2.pl: $!\n";
165	}
166	else {
167	open(OUT, ">$table.pl") or die "Can't create $table.pl: $!\n";
168	}
169	print OUT <<"END";
170	return <<'END';
171	END
172	print OUT proplist($table, $wanted, $val);
173	print OUT "END\n";
174	close OUT;
175	}
176
177	# Must treat blocks specially.
178
179	exit if @ARGV and not grep { $_ eq Block } @ARGV;
180	print "Block\n";
181	open(UD, 'blocks.txt') or die "Can't open blocks.txt: $!\n";
182	open(OUT, ">Block.pl") or die "Can't create $table.pl: $!\n";
183	print OUT <<"END";
184	return <<'END';
185	END
186
187	while (<UD>) {
188	next if /^#/;
189	next if /^$/;
190	chomp;
191	($code, $last, $name) = split(/; */);
192	if ($name) {
193	print OUT "$code $last $name\n";
194	$name =~ s/\s+//g;
195	open(BLOCK, ">In/$name.pl");
196	print BLOCK <<"END2";
197	return <<'END';
198	$code $last
199	END
200	END2
201	close BLOCK;
202	}
203	}
204
205	print OUT "END\n";
206	close OUT;
207
208	##################################################
209
210	sub proplist {
211	my ($table, $wanted, $val) = @_;
212	my @wanted;
213	my $out;
214	my $split;
215
216	if ($table =~ /^Arab/) {
217	open(UD, "arabshp.txt") or warn "Can't open $table: $!";
218
219	$split = '($code, $name, $link, $linkgroup) = split(/; */);';
220	}
221	elsif ($table =~ /^Jamo/) {
222	open(UD, "jamo2.txt") or warn "Can't open $table: $!";
223
224	$split = '($code, $short, $name) = split(/; */); $code =~ s/^U\+//;';
225	}
226	else {
11695a73	227	open(UD, $UnicodeData) or warn "Can't open $UnicodeData: $!";
a0ed51b3	228
	229	$split = '($code, $name, $cat, $comb, $bid, $decomp, $dec, $dig, $num, $mir, $uni1,
	230	$comment, $up, $down, $title) = split(/;/);';
	231	}
	232
	233	if ($table =~ /^(?:To\|Is)[A-Z]/) {
	234	eval <<"END";
	235	while (<UD>) {
	236	next if /^#/;
	237	next if /^\s/;
	238	chop;
	239	$split
	240	if ($wanted) {
	241	push(\@wanted, [hex \$code, hex $val, \$name =~ /, First>\$/]);
	242	}
	243	}
	244	END
	245	die $@ if $@;
	246
	247	while (@wanted) {
	248	$beg = shift @wanted;
	249	$last = $beg;
	250	while (@wanted and $wanted[0]->[0] == $last->[0] + 1 and
	251	(not $val or $wanted[0]->[1] == $last->[1] + 1)) {
	252	$last = shift @wanted;
	253	}
	254	$out .= sprintf "%04x", $beg->[0];
	255	if ($beg->[2]) {
	256	$last = shift @wanted;
	257	}
	258	if ($beg == $last) {
	259	$out .= "\t";
	260	}
	261	else {
	262	$out .= sprintf "\t%04x", $last->[0];
	263	}
	264	$out .= sprintf "\t%04x", $beg->[1] if $val;
	265	$out .= "\n";
	266	}
	267	}
	268	else {
	269	eval <<"END";
	270	while (<UD>) {
	271	next if /^#/;
	272	next if /^\s*\$/;
	273	chop;
	274	$split
	275	if ($wanted) {
	276	push(\@wanted, [hex \$code, $val, \$name =~ /, First>\$/]);
	277	}
	278	}
	279	END
	280	die $@ if $@;
	281
	282	while (@wanted) {
	283	$beg = shift @wanted;
	284	$last = $beg;
	285	while (@wanted and $wanted[0]->[0] == $last->[0] + 1 and
	286	($wanted[0]->[1] eq $last->[1])) {
	287	$last = shift @wanted;
	288	}
	289	$out .= sprintf "%04x", $beg->[0];
	290	if ($beg->[2]) {
	291	$last = shift @wanted;
292	}
293	if ($beg == $last) {
294	$out .= "\t";
295	}
296	else {
297	$out .= sprintf "\t%04x", $last->[0];
298	}
299	$out .= sprintf "\t%s\n", $beg->[1];
300	}
301	}
302	$out;
303	}
11695a73	304
11eeea96	305	# Create the equivalence mappings.
11eeea96	306
13a0e1a7	307	open(UNICODEDATA, $UnicodeData) \|\| die "$0: $UnicodeData: $!\n";
	308
	309	while (<UNICODEDATA>) {
	310	($code, $name) = split /;/;
	311
	312	$code{$name} = $code;
	313	$name{$code} = $name;
	314
	315	next unless $name =~ /^(.+? LETTER .+?) WITH .+( \w+ FORM)?$/;
	316
	317	push @base, [ $code, $1 ];
	318	push @base, [ $code, $1.$2 ] if $2 ne '';
	319
	320	# Before this "diacritics stripping" phase (and for Arabic, also
	321	# "form stripping" phase) all ligatures could be decomposed into
	322	# their constituent letters.
	323	#
	324	# For example the ligature
	325	# ARABIC LIGATURE YEH WITH HAMZA ABOVE WITH ALEF ISOLATED FORM
	326	# would go first through ligature decomposition producing the two letters
	327	# ARABIC LETTER YEH WITH HAMZA ABOVE ISOLATED FORM
	328	# ARABIC LETTER ALEF WITH HAMZA ABOVE ISOLATED FORM
	329	# and those with diacritics stripping
	330	# ARABIC LETTER YEH ISOLATED FORM
	331	# ARABIC LETTER ALEF ISOLATED FORM
	332	# and those with the Arabic form stripping
	333	# ARABIC LETTER YEH
	334	# ARABIC LETTER ALEF ISOLATED FORM
	335	# ARABIC LETTER YEH
	336	# ARABIC LETTER ALEF ISOLATED FORM
	337	#
	338	# Similarly for ligatures from other scripts.
	339	# Effectively this would mean that ligatures turn into categories
	340	# (Unicodese for character classes).
	341	}
	342
	343	foreach my $b (@base) {
	344	($code, $base) = @$b;
	345	next unless exists $code{$base};
	346	push @{$unicode{$code{$base}}}, $code;
	347	# print "$code: $name{$code} -> $base\n",
	348	}
	349
	350	@unicode = sort keys %unicode;
	351
	352	print "Eq/Unicode\n";
	353	if (open(EQ_UNICODE, ">Eq/Unicode")) {
	354	foreach my $c (@unicode) {
	355	print EQ_UNICODE "$c @{$unicode{$c}}\n";
	356	}
	357	close EQ_UNICODE;
	358	} else {
	359	die "$0: failed to open Eq/Unicode for writing: $!\n";
	360	}
	361
	362	print "Eq/Latin1\n";
	363	if (open(EQ_LATIN1, ">Eq/Latin1")) {
	364	foreach my $c (@unicode) {
	365	last if hex($c) > 255;
	366	my @c = grep { hex($_) <= 255 } @{$unicode{$c}};
	367	next unless @c;
	368	print EQ_LATIN1 "$c @c\n";
	369	}
	370	close EQ_LATIN1;
371	} else {
372	die "$0: failed to open Eq/Latin1 for writing: $!\n";
373	}
11695a73	374