tcllib 1.17-dfsg-1 / usr / share / tcltk / tcllib1.17 / math / romannumerals.tcl

This file is indexed.

/usr/share/tcltk/tcllib1.17/math/romannumerals.tcl is in tcllib 1.17-dfsg-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below. 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
#==========================================================================
# Roman Numeral Utility Functions
#==========================================================================
# Description
#
#   A set of utility routines for handling and manipulating
#   roman numerals.
#-------------------------------------------------------------------------
# Copyright/License
#
#   This code was originally harvested from the Tcler's
#   wiki at http://wiki.tcl.tk/1823 and as such is free
#   for any use for any purpose.
#-------------------------------------------------------------------------
# Modification history
#
#   27 Sep 2005 Kenneth Green
#       Original version derived from wiki code
#-------------------------------------------------------------------------

package provide math::roman 1.0

#==========================================================================
# Namespace
#==========================================================================
namespace eval ::math::roman {
    namespace export tointeger toroman

    # We dont export 'sort' or 'expr' to prevent collision
    # with existing commands. These functions are less likely to be
    # commonly used and have to be accessed as fully-scoped names.

    # romanvalues - array that maps roman letters to integer values.
    #
    variable romanvalues

    # i2r - list of integer-roman tuples
    variable i2r {1000 M 900 CM 500 D 400 CD 100 C 90 XC 50 L 40 XL 10 X 9 IX 5 V 4 IV 1 I}

    # sortkey - list of patterns to supporting sorting of roman numerals
    variable sortkey {IX VIIII L Y XC YXXXX C Z D {\^} ZM {\^ZZZZ} M _}
    variable rsortkey {_ M {\^ZZZZ} ZM {\^} D Z C YXXXX XC Y L VIIII IX}

    # Initialise array variables
    array set romanvalues {M 1000 D 500 C 100 L 50 X 10 V 5 I 1}
}

#==========================================================================
# Public Functions
#==========================================================================

#----------------------------------------------------------
# Roman numerals sorted
#
proc ::math::roman::sort list {
    variable sortkey
    variable rsortkey

    foreach {from to} $sortkey {
        regsub -all $from $list $to list
    }
    set list [lsort $list]
    foreach {from to} $rsortkey {
        regsub -all $from $list $to list
    }
    return $list
}

#----------------------------------------------------------
# Roman numerals from integer
#
proc ::math::roman::toroman {i} {
    variable i2r

    set res ""
    foreach {value roman} $i2r {
        while {$i>=$value} {
            append res $roman
            incr i -$value
        }
    }
    return $res
}

#----------------------------------------------------------
# Roman numerals parsed into integer:
#
proc ::math::roman::tointeger {s} {
    variable romanvalues

    set last 99999
    set res  0
    foreach i [split [string toupper $s] ""] {
        if { [catch {set val $romanvalues($i)}] } {
            return -code error "roman::tointeger - un-Roman digit $i in $s"
        }
        incr res $val
        if { $val > $last } {
            incr res [::expr -2*$last]
        }
        set last $val
    }
    return $res
}

#----------------------------------------------------------
# Roman numeral arithmetic
#
proc ::math::roman::expr args {

    if { [string first \$ $args] >= 0 } {
        set args [uplevel subst $args]
    }

    regsub -all {[^IVXLCDM]} $args { & } args
    foreach i $args {
        catch {set i [tointeger $i]}
        lappend res $i
    }
    return [toroman [::expr $res]]
}

#==========================================================
# Developer test code
#
if { 0 } {

    puts "Basic int-to-roman-to-int conversion test"
    for { set i 0 } {$i < 50} {incr i} {
        set r [::math::roman::toroman   $i]
        set j [::math::roman::tointeger $r]
        puts [format "%5d   %-15s %s" $i $r $j]
        if { $i != $j } {
            error "Invalid conversion: $i -> $r -> $j"
        }
    }

    puts ""
    puts "roman arithmetic test"
    set x 23
    set xr [::math::roman::toroman $x]
    set y 77
    set yr [::math::roman::toroman $y]
    set xr+yr [::math::roman::expr $xr + $yr]
    set yr-xr [::math::roman::expr $yr - $xr]
    set xr*yr [::math::roman::expr $xr * $yr]
    set yr/xr [::math::roman::expr $yr / $xr]
    set yr/xr2 [::math::roman::expr {$yr / $xr}]
    puts "$x + $y\t\t= [expr $x + $y]"
    puts "$x * $y\t\t= [expr $x * $y]"
    puts "$y - $x\t\t= [expr $y - $x]"
    puts "$y / $x\t\t= [expr $y / $x]"
    puts "$xr + $yr\t= ${xr+yr} = [::math::roman::tointeger ${xr+yr}]"
    puts "$xr * $yr\t= ${xr*yr} = [::math::roman::tointeger ${xr*yr}]"
    puts "$yr - $xr\t= ${yr-xr} = [::math::roman::tointeger ${yr-xr}]"
    puts "$yr / $xr\t= ${yr/xr} = [::math::roman::tointeger ${yr/xr}]"
    puts "$yr / $xr\t= ${yr/xr2} = [::math::roman::tointeger ${yr/xr2}]"

    puts ""
    puts "roman sorting test"
    set l {X III IV I V}
    puts "IN : $l"
    puts "OUT: [::math::roman::sort $l]"
}

APT Browse - Built by Thomas Orozco.