(49G) Verhoeff Check Digit Programme

[Gerald H]

For positive integer input the programme returns the original input and the check digit.

eg For input

19530818

the programme returns

19530818
1

For more info on Verhoeff check digit see

http://en.wikipedia.org/wiki/Verhoeff_algorithm

Code:

::
  CK1&Dispatch
  # FF
  ::
    MATRIX
      MATRIX
        Z1_
        Z2_
        Z3_
        Z4_
        Z5_
        Z6_
        Z7_
        Z8_
        Z9_
        Z10_
      ;
      MATRIX
        Z2_
        Z3_
        Z4_
        Z5_
        Z1_
        Z7_
        Z8_
        Z9_
        Z10_
        Z6_
      ;
      MATRIX
        Z3_
        Z4_
        Z5_
        Z1_
        Z2_
        Z8_
        Z9_
        Z10_
        Z6_
        Z7_
      ;
      MATRIX
        Z4_
        Z5_
        Z1_
        Z2_
        Z3_
        Z9_
        Z10_
        Z6_
        Z7_
        Z8_
      ;
      MATRIX
        Z5_
        Z1_
        Z2_
        Z3_
        Z4_
        Z10_
        Z6_
        Z7_
        Z8_
        Z9_
      ;
      MATRIX
        Z6_
        Z10_
        Z9_
        Z8_
        Z7_
        Z1_
        Z5_
        Z4_
        Z3_
        Z2_
      ;
      MATRIX
        Z7_
        Z6_
        Z10_
        Z9_
        Z8_
        Z2_
        Z1_
        Z5_
        Z4_
        Z3_
      ;
      MATRIX
        Z8_
        Z7_
        Z6_
        Z10_
        Z9_
        Z3_
        Z2_
        Z1_
        Z5_
        Z4_
      ;
      MATRIX
        Z9_
        Z8_
        Z7_
        Z6_
        Z10_
        Z4_
        Z3_
        Z2_
        Z1_
        Z5_
      ;
      MATRIX
        Z10_
        Z9_
        Z8_
        Z7_
        Z6_
        Z5_
        Z4_
        Z3_
        Z2_
        Z1_
      ;
    ;
    BINT0
    FPTR2 ^2LAMBIND
    DUP
    {
      Z1_
      Z5_
      Z4_
      Z3_
      Z2_
      Z7_
      Z8_
      Z9_
      Z10_
      Z6_
    }
    BINT10
    DUP
    #1+_ONE_DO
    INDEX@
    FPTR2 ^#>Z
    SWAPLOOP
    {}N
    ROTDUP
    PTR 2F3A3
    COERCEDUP
    BINT2
    #<ITE
    ::
      DROP
      ROTROT2DROP
      Z1_
      FPTR2 ^QAdd
      2GETLAM
    ;
    ::
      DUP1PUTLAM_
      ZERO_DO
      Z10_
      FPTR2 ^ZDIVext
      ROT
      4PICK
      FPTR 7 17C
      DUP4UNROLL
      SWAP
      FPTR2 ^Z2BIN
      #1+
      NTHCOMPDROP
      4UNROLL
      LOOP
      3DROP
      2GETLAM
      1GETLAM
      ONE_DO
      3UNROLL
      FPTR2 ^Z2BIN
      #1-
      #10*
      SWAP
      FPTR2 ^Z2BIN
      #+
      FPTR2 ^PULLEL[S]
      SWAPLOOP
    ;
    ABND
    SWAP
    FPTR2 ^Z>#
    FPTR2 ^MATRIX-COL
    SWAPDROP
    FPTR2 ^MATRIX2LIST
    Z1_
    EQUALPOSCOMP
    #1-
    FPTR2 ^#>Z
  ;
;