romannumerals.tcl

Go to the documentation of this file.

/* ==========================================================================*/
/*  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 ::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  romanvalues =  {M 1000 D 500 C 100 L 50 X 10 V 5 I 1}
}

/* ==========================================================================*/
/*  Public Functions*/
/* ==========================================================================*/

/* ----------------------------------------------------------*/
/*  Roman numerals sorted*/
/* */
ret  ::math::roman::sort list (
    type variable , type sortkey
    , type variable , type rsortkey

    , type foreach , optional from =to $, type sortkey , optional 
        regsub =-all $from =$list $to =list
    
    , type set , type list [, type lsort $, type list]
    , type foreach , optional from =to $, type rsortkey , optional 
        regsub =-all $from =$list $to =list
    
    , type return $, type list
)

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

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

/* ----------------------------------------------------------*/
/*  Roman numerals parsed into integer:*/
/* */
ret  ::math::roman::tointeger (type 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*/
/* */
ret  ::math::roman::expr args (

    type if , optional [string =first \$ =$args] >= =0  , optional 
        set =args [uplevel =subst $args]
    

    , type regsub -, type all , optional [^IVXLCDM] $, type args , optional &  , type args
    , type foreach , type i $, type args , optional 
        catch ={set i =[tointeger $i]
        , type lappend , type res $, type 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} {
         r =  [::math::roman::toroman   $i]
         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"
     x =  23
     xr =  [::math::roman::toroman $x]
     y =  77
     yr =  [::math::roman::toroman $y]
     xr = +yr [::math::roman::expr $xr + $yr]
     yr = -xr [::math::roman::expr $yr - $xr]
     xr = *yr [::math::roman::expr $xr * $yr]
     yr = /xr [::math::roman::expr $yr / $xr]
     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"
     l =  {X III IV I V}
    puts "IN : $l"
    puts "OUT: [::math::roman::sort $l]"
}