extra/rosetta-code/luhn-test/luhn-test.factor

   1 ! Copyright (c) 2012 Anonymous
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math sequences ;
   4 IN: rosetta-code.luhn-test
   5
   6 ! http://rosettacode.org/wiki/Luhn_test_of_credit_card_numbers
   7
   8 ! The Luhn test is used by some credit card companies to
   9 ! distinguish valid credit card numbers from what could be a
  10 ! random selection of digits.
  11
  12 ! Those companies using credit card numbers that can be
  13 ! validated by the Luhn test have numbers that pass the following
  14 ! test:
  15
  16 ! 1. Reverse the order of the digits in the number.
  17
  18 ! 2. Take the first, third, ... and every other odd digit in the
  19 !    reversed digits and sum them to form the partial sum s1
  20
  21 ! 3. Taking the second, fourth ... and every other even digit in
  22 !    the reversed digits:
  23 !    a. Multiply each digit by two and sum the digits if the
  24 !       answer is greater than nine to form partial sums for the
  25 !       even digits
  26 !    b. Sum the partial sums of the even digits to form s2
  27
  28 ! 4. If s1 + s2 ends in zero then the original number is in the
  29 !    form of a valid credit card number as verified by the Luhn test.
  30
  31 ! For example, if the trial number is 49927398716:
  32
  33 ! Reverse the digits:
  34 !   61789372994
  35 ! Sum the odd digits:
  36 !   6 + 7 + 9 + 7 + 9 + 4 = 42 = s1
  37 ! The even digits:
  38 !     1,  8,  3,  2,  9
  39 !   Two times each even digit:
  40 !     2, 16,  6,  4, 18
  41 !   Sum the digits of each multiplication:
  42 !     2,  7,  6,  4,  9
  43 !   Sum the last:
  44 !     2 + 7 + 6 + 4 + 9 = 28 = s2
  45
  46 ! s1 + s2 = 70 which ends in zero which means that 49927398716
  47 ! passes the Luhn test
  48
  49 ! The task is to write a function/method/procedure/subroutine
  50 ! that will validate a number with the Luhn test, and use it to
  51 ! validate the following numbers:
  52 !   49927398716
  53 !   49927398717
  54 !   1234567812345678
  55 !   1234567812345670
  56
  57 : reversed-digits ( n -- list )
  58     { } swap
  59     [ dup 0 > ]
  60         [ 10 /mod  swapd suffix  swap ]
  61     while drop ;
  62
  63 : luhn-digit  ( n -- n )
  64     reversed-digits dup length <iota> [
  65         2dup swap nth
  66         swap odd? [ 2 *  10 /mod + ] when
  67     ] map sum 10 mod
  68     nip ;
  69
  70 : luhn? ( n -- ? )
  71     luhn-digit 0 = ;