Artifact
708ed44d2b175fe12bf514508b76801bec648410:
Attachment "uniqpfx.tcl" to
ticket [876170ffff]
added by
kennykb
2004-01-13 23:11:42.
#----------------------------------------------------------------------
#
# uniquePrefixRegexp --
#
# Composes a regexp that performs unique-prefix matching. The
# RE matches one of a supplied set of strings, or any unique
# prefix thereof.
#
# Parameters:
# data - List of alternating match-strings and values.
# Match-strings with distinct values are considered
# distinct.
#
# Results:
# Returns a two-element list. The first is a regexp that
# matches any unique prefix of any of the strings. The second
# is a dictionary whose keys are match values from the regexp
# and whose values are the corresponding values from 'data'.
#
# Side effects:
# None.
#
#----------------------------------------------------------------------
proc uniquePrefixRegexp { data } {
set prefixMapping {}
set successors [dict create {} {}]
foreach { key value } $data {
set prefix {}
foreach char [split $key {}] {
set oldPrefix $prefix
dict set successors $oldPrefix $char {}
append prefix $char
dict lappend prefixMapping $prefix $value
if { ![dict exists $successors $prefix] } {
dict set successors $prefix {}
}
}
}
set uniquePrefixMapping {}
dict for { key valueList } $prefixMapping {
if { [llength $valueList] == 1 } {
dict set uniquePrefixMapping $key [lindex $valueList 0]
}
}
foreach { key value } $data {
dict set uniquePrefixMapping $key $value
}
return [list \
[makeUniquePrefixRegexp $successors $uniquePrefixMapping {}] \
$uniquePrefixMapping]
}
proc makeUniquePrefixRegexp { successors uniquePrefixMapping prefixString } {
set schars [dict get $successors $prefixString]
if { [dict size $schars] == 0 } {
return {}
}
set re {}
set bracketed 0
if { [dict exists $uniquePrefixMapping $prefixString] } {
append re "(?:"
} elseif { [dict size $schars] > 1 } {
append re "(?:"
}
set sep ""
dict for { c - } $schars {
set nextPrefix $prefixString$c
regsub -all {[^[:alnum:]]} $c \\\\& rechar
append re $sep $rechar \
[makeUniquePrefixRegexp \
$successors $uniquePrefixMapping $nextPrefix]
set sep |
}
if { [dict exists $uniquePrefixMapping $prefixString] } {
append re ")?"
} elseif { [dict size $schars] > 1 } {
append re ")"
}
return $re
}
puts [uniquePrefixRegexp {
lundi -1 mardi -2 mercredi -3 jeudi -4 vendredi -5 samedi -6 dimanche -7
janvier 1 février 2 fevrier 2 mars 3 avril 4 mai 5 juin 6 juillet 7
août 8 aout 8 septembre 9 octobre 10 novembre 11 décembre 12
decembre 12
}]
