# ACTIVESTATE TEAPOT-PKG BEGIN TM -*- tcl -*-
# -- Tcl Module

# @@ Meta Begin
# Package valtype::verhoeff 1
# Meta as::build::date 2015-05-25
# Meta as::origin      http://sourceforge.net/projects/tcllib
# Meta category        Validation types
# Meta description     Validation for plain number with a VERHOEFF
# Meta description     checkdigit
# Meta license         BSD
# Meta platform        tcl
# Meta require         {Tcl 8.5}
# Meta require         snit
# Meta require         valtype::common
# Meta subject         Checking verhoeff isA {Value checking} {Type checking}
# Meta subject         Testing Validation
# Meta summary         valtype::verhoeff
# @@ Meta End


# ACTIVESTATE TEAPOT-PKG BEGIN REQUIREMENTS

package require Tcl 8.5
package require snit
package require valtype::common

# ACTIVESTATE TEAPOT-PKG END REQUIREMENTS

# ACTIVESTATE TEAPOT-PKG BEGIN DECLARE

package provide valtype::verhoeff 1

# ACTIVESTATE TEAPOT-PKG END DECLARE
# ACTIVESTATE TEAPOT-PKG END TM
# # ## ### ##### ######## ############# ######################
## Verhoeff test of numbers
#
# The Verhoeff test is similar to the Luhn test to compute and verify
# check digits of identifier numbers, albeit quite a bit stronger,
# i.e. detecting more possible keying errors.
#
# References
#	

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

# The code below implements the interface of a snit validation type,
# making it directly usable with snit's -type option in option
# specifications.

# # ## ### ##### ######## ############# ######################
## Requisites

package require Tcl 8.5
package require snit
package require valtype::common

# # ## ### ##### ######## ############# ######################
## Implementation

namespace eval ::valtype::verhoeff {
    namespace import ::valtype::common::*
}

snit::type ::valtype::verhoeff {
    #-------------------------------------------------------------------
    # Type Methods

    typemethod validate {value {code VERHOEFF}} {
	if {[regexp {[^0-9]} $value]} {
	    badchar $code "$code number, expected only digits"
	}

	# Verhoeff test.

	set sum [Sum $value 0]
	if {$sum != 0} {
	    badcheck $code "$code number"
	}
	return $value
    }

    typemethod checkdigit {value {code VERHOEFF}} {
	if {[regexp {[^0-9]} $value]} {
	    badchar $code "$code number, expected only digits"
	}

	# Compute the verhoeff checkdigit. First sum the digits as
	# usual. Note that we start with position 1, as the check
	# digit will go into position 0.

	#return [INVERS [Sum $value 1]]
	return [lindex $ourinv [Sum $value 1]]
    }

    proc Sum {value step} {
	# 8.5 required for lreverse.
	#
	# Compute the verhoeff checkdigit. First sum the digits as
	# usual. Note that we start with position 1 for checkdigit
	# calculation, as the check digit will go into position 0.

	set sum 0
	foreach ch [lreverse [split $value {}]] {
	    #set sum [OP $sum [F step $ch]]
	    # inlined below:
	    set sum [lindex $ourop $sum [lindex $ourf $step $ch]]
	    incr step ; if {$step == 8} { set step 0}
	}
	return $sum
    }

    #-------------------------------------------------------------------
    # Constructor

    # None needed; no options

    #-------------------------------------------------------------------
    # Public Methods

    method validate {value} {
        $type validate $value
    }

    #-------------------------------------------------------------------
    # Operations in D5, and the helper permutations F^k, k in {0,...,7}.

    #proc OP     {a b} { return [lindex $ourop $a $b] }
    #proc INVERS {a}   { return [lindex $ourinv $a] }
    #proc F      {k x} { return [lindex $ourf $k $x] }

    typevariable ourop {
	{0 1 2 3 4 5 6 7 8 9}
	{1 2 3 4 0 6 7 8 9 5}
	{2 3 4 0 1 7 8 9 5 6}
	{3 4 0 1 2 8 9 5 6 7}
	{4 0 1 2 3 9 5 6 7 8}
	{5 9 8 7 6 0 4 3 2 1}
	{6 5 9 8 7 1 0 4 3 2}
	{7 6 5 9 8 2 1 0 4 3}
	{8 7 6 5 9 3 2 1 0 4}
	{9 8 7 6 5 4 3 2 1 0} 
    }

    typevariable ourinv {0 4 3 2 1 5 6 7 8 9}

    typevariable ourf {
	{0 1 2 3 4 5 6 7 8 9}
	{1 5 7 6 2 8 3 0 9 4}
	{5 8 0 3 7 9 6 1 4 2}
	{8 9 1 6 0 4 3 5 2 7}
	{9 4 5 3 1 2 6 8 7 0}
	{4 2 8 6 5 7 3 9 0 1}
	{2 7 9 3 8 0 6 4 1 5}
	{7 0 4 6 9 1 3 2 5 8}
    }
}

# # ## ### ##### ######## ############# ######################
## Ready

package provide valtype::verhoeff 1