;;; @Package     ccnum.scm
;;; @Subtitle    Credit Card Number Utilities in Scheme
;;; @HomePage    http://www.neilvandyke.org/ccnum-scm/
;;; @Author      Neil W. Van Dyke
;;; @AuthorEmail neil@@neilvandyke.org
;;; @Version     0.2
;;; @Date        2005-03-29

;; $Id: ccnum.scm,v 1.44 2005/03/30 03:42:40 neil Exp $

;;; @legal
;;; Copyright @copyright{} 2004 - 2005 Neil W. Van Dyke.  This program is Free
;;; Software; you can redistribute it and/or modify it under the terms of the
;;; GNU Lesser General Public License as published by the Free Software
;;; Foundation; either version 2.1 of the License, or (at your option) any
;;; later version.  This program is distributed in the hope that it will be
;;; useful, but without any warranty; without even the implied warranty of
;;; merchantability or fitness for a particular purpose.  See the GNU Lesser
;;; General Public License [LGPL] for details.  For other license options and
;;; consulting, contact the author.
;;; @end legal

;;; @section Introduction

;;; This is a Scheme library of a few utilities for validating and formatting
;;; credit card numbers.  Credit card numbers are represented as strings
;;; containing digits and arbitrary whitespace.  The procedures are based on
;;; information gleaned from dozens of written artifacts of credit card number
;;; oral tradition, including [Bradbury], [Gilleland], and [Hippy].  The author
;;; invites free copies of authoritative documentation.
;;;
;;; This library should work with any R5RS-compliant Scheme implementation that
;;; has an @code{error} procedure similar to that in [SRFI-23].
;;;
;;; Achtung!  Do not use this library as anything other than a novelty unless
;;; you understand the code thoroughly and can invest in validation of it.
;;; (The same caution applies to all the other credit card number checking
;;; routines the author has seen in other languages, most of which are
;;; surprisingly inefficient and otherwise do not instill confidence.)

(define (%ccnum:error p m o) (error (string-append p " - " m) o))

(define (%ccnum:char-blank? c)
  (or (char-whitespace? c) (eqv? c #\-)))

;;; @section Validation

;;; The following procedures provide different ways of validating credit card
;;; numbers.  Most applications will use
;;; @code{credit-card-number-check-digit-ok?}  or
;;; @code{credit-card-number-seems-ok?}.

;;; @defproc check-credit-card-number str
;;;
;;; Performs a partial validation of the credit card number in @var{str}.  If
;;; the check digit is incorrect, then @code{#f} is yielded:
;;;
;;; @lisp
;;; (check-credit-card-number "4408041234567890") @result{} #f
;;; @end lisp
;;;
;;; If the check digit is correct, but the issuer cannot be determined, then an
;;; integer representing the digit count is yielded:
;;;
;;; @lisp
;;; (check-credit-card-number "1234567890123452") @result{} 16
;;; @end lisp
;;;
;;; If the check digit is correct and issuer can be determined, then a list of
;;; three elements is returned.  The first element is a boolean value for
;;; whether or not the digit count matches what is known about how many digits
;;; the issuer uses for this class of cards.  The second element is the digit
;;; count.  The third element is a symbol loosely identifying the issuer.  For
;;; example:
;;;
;;; @lisp
;;; (check-credit-card-number "5551 2121 9")      @result{} (#f 9 mastercard)
;;; (check-credit-card-number "4408041234567893") @result{} (#t 16 visa)
;;; @end lisp

(define check-credit-card-number
  ;; TODO: Maybe programmatically build a vector-based lookup tree from the
  ;;       list-based source.
  (let ((issuer-tree
         ;; TODO: http://www.beachnet.com/~hstiles/cardtype.html claims the
         ;;       following, but it is possibly wrong on at least one other
         ;;       point, so we're not yet implementing it:
         ;;
         ;;       | CARD TYPE| Prefix| Length| algorithm|
         ;;       |----------+-------+-------+----------|
         ;;       | enRoute  | 2014  | 15    | any      |
         ;;       |          | 2149  |       |          |
         ;;
         ;;       The 15-digit JCB numbers should also get corroboration.
         (let ((american-express    '(american-express    15))
               (australian-bankcard '(australian-bankcard 16))
               (carte-blanche       '(carte-blanche       14))
               (diners-club         '(diners-club         14))
               (discover-novus      '(discover-novus      16))
               (jcb-15              '(jcb                 15))
               (jcb-16              '(jcb                 16))
               (mastercard          '(mastercard          16))
               (visa                '(visa                16 13)))
           `((1 (8 (0 (0 ,@jcb-15))))
             (2 (1 (3 (1 ,@jcb-15))))
             (3 (0 (0 ,@diners-club)
                   (1 ,@diners-club)
                   (2 ,@diners-club)
                   (3 ,@diners-club)
                   (4 ,@diners-club)
                   (5 ,@diners-club))
                (4 ,@american-express)
                (5 (2 (8 ,@jcb-16)
                      (9 ,@jcb-16))
                   (3 ,@jcb-16)
                   (4 ,@jcb-16)
                   (5 ,@jcb-16)
                   (6 ,@jcb-16)
                   (7 ,@jcb-16)
                   (8 ,@jcb-16))
                (6 ,@diners-club)
                (7 ,@american-express)
                (8 (0 ,@diners-club)
                   (1 ,@diners-club)
                   (2 ,@diners-club)
                   (3 ,@diners-club)
                   (4 ,@diners-club)
                   (5 ,@diners-club)
                   (6 ,@diners-club)
                   (7 ,@diners-club)
                   (8 ,@diners-club)
                   (9 ,@carte-blanche)))
             (4 ,@visa)
             (5 (1 ,@mastercard)
                (2 ,@mastercard)
                (3 ,@mastercard)
                (4 ,@mastercard)
                (5 ,@mastercard))
             (6 (0 (1 (1 ,@discover-novus)))
                (1 (0 ,@australian-bankcard))))))
        (issuer-tree-select
         (lambda (tree d)
           (cond ((null? tree)         tree)
                 ((symbol? (car tree)) tree)
                 (else (let ((subtree (assq d tree)))
                         (if subtree
                             (cdr subtree)
                             '())))))))
    (lambda (str)
      (let ((str-len (string-length str)))
        (let scan ((digit-count 0)
                   (even-sum    0)
                   (odd-sum     0)
                   (i           0)
                   (issuers     issuer-tree))
          (if (= i str-len)
              (if (and (not (zero? digit-count))
                       (zero? (modulo (if (even? digit-count) even-sum odd-sum)
                                      10)))
                  (let ((issuer (if (and (not (null? issuers))
                                         (symbol? (car issuers)))
                                    issuers
                                    #f)))
                    (if issuer
                        (list (if (memq digit-count (cdr issuer)) #t #f)
                              digit-count
                              (car issuer))
                        digit-count))
                  #f)
              ;; Note: Before, we were doing digit-char->integer conversion
              ;; with the following, but there's no sense requiring ASCII.
              ;;
              ;;  (let ((d (- (char->integer ) 48)))
              ;;    (cond ((<= 0 d 9)
              ;;           ...)
              ;;          ...))
              (let* ((c (string-ref str i))
                     (d (case c
                          ((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4)
                          ((#\5) 5) ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9)
                          (else  #f))))
                (cond (d (let ((dd (if (< d 5) (* 2 d) (- (* 2 d) 9))))
                           (if (odd? digit-count)
                               (scan (+ digit-count      1)
                                     (+ even-sum         d)
                                     (+ odd-sum          dd)
                                     (+ i                1)
                                     (issuer-tree-select issuers d))
                               (scan (+ digit-count      1)
                                     (+ even-sum         dd)
                                     (+ odd-sum          d)
                                     (+ i                1)
                                     (issuer-tree-select issuers d)))))
                      ((%ccnum:char-blank? c)
                       (scan digit-count even-sum odd-sum (+ i 1) issuers))
                      (else #f)))))))))

;;; @defproc credit-card-number-check-digit-ok? str
;;;
;;; Predicate for whether or not the check digit of credit card number
;;; @var{str} is correct.
;;;
;;; @lisp
;;; (credit-card-number-check-digit-ok? "4408 0412 3456 7893") @result{} #t
;;; (credit-card-number-check-digit-ok? "4408 0412 3456 7890") @result{} #f
;;; (credit-card-number-check-digit-ok? "trump")               @result{} #f
;;; @end lisp

(define (credit-card-number-check-digit-ok? str)
  ;; TODO: This is a little inefficient, since we are doing computation and a
  ;;       small amount of allocation we don't need.
  (if (check-credit-card-number str) #t #f))

;;; @defproc credit-card-number-seems-ok? str
;;;
;;; Predicate for whether or not the credit card number @var{str} ``seems'' to
;;; be valid.  For a credit card number to ``seem'' valid, the check digit must
;;; be correct, the issuer must be identified, and the digit count must match
;;; what is known about issuer digit counts.  In the following example the
;;; check digit is correct, and the issuer (MasterCard) has been identified,
;;; but the digit count is too low for a MasterCard number:
;;;
;;; @lisp
;;; (credit-card-number-check-digit-ok? "5551 2121 9") @result{} #t
;;; (credit-card-number-seems-ok?       "5551 2121 9") @result{} #f
;;; @end lisp

(define (credit-card-number-seems-ok? str)
  (let ((data (check-credit-card-number str)))
    (cond ((not data)      #f)
          ((integer? data) #f)
          (else            (car data)))))

;;; @section Formatting

;;; Two procedures are provided for formatting credit card numbers.

;;; @defproc write-formatted-credit-card-number str port
;;;
;;; Writes credit card number @var{str} to output port @var{port}, using a
;;; format similar to that used on many credit cards.  In the current version
;;; of this package, the format is always groups of four digits separated by
;;; single space characters, although a future version might mimic the format
;;; used by the issuer.
;;;
;;; @lisp
;;; (write-formatted-credit-card-number " 1 23 456  7890 12345 6 "
;;;                                     (current-output-port))
;;; @print{} 1234 5678 9012 3456
;;; @end lisp
;;;

(define (write-formatted-credit-card-number str port)
  ;; TODO: Maybe signal an error if no digits written.
  (let ((len (string-length str)))
    (let scan ((i          0)
               (pad?       #f)
               (group-left 4))
      (if (< i len)
          (let ((c (string-ref str i)))
            (cond ((char-numeric? c)
                   (and pad? (write-char #\space port))
                   (write-char c port)
                   (if (= group-left 1)
                       (scan (+ 1 i) #t 4)
                       (scan (+ 1 i) #f (- group-left 1))))
                  ((%ccnum:char-blank? c)
                   (scan (+ 1 i) pad? group-left))
                  (else (%ccnum:error
                         "write-formatted-credit-card-number"
                         "invalid character in credit card number string"
                         "c"))))))))

;;; @defproc formatted-credit-card-number str
;;;
;;; Yields a formatted string representation of credit card number @var{str}
;;; like that written by @code{write-formatted-credit-card-number}.
;;;
;;; @lisp
;;; (formatted-credit-card-number "1234567890123456")
;;; @result{} "1234 5678 9012 3456"
;;;
;;; (formatted-credit-card-number "  12 34 56  7890 1234 56")
;;; @result{} "1234 5678 9012 3456"
;;;
;;; (formatted-credit-card-number "123 abc") @result{} #f
;;; @end lisp
;;;
;;; Note that @code{(write-formatted-credit-card-number @var{n} @var{p})} is
;;; more efficient than @code{(display (formatted-credit-card-number @var{n})
;;; @var{p})}.

(define (formatted-credit-card-number str)
  (let ((len (string-length str)))
    (let scan ((i           0)
               (digit-count 0)
               (group-left  4)
               (digit-pos   0))
      (if (= i len)
          (if (zero? digit-count)
              #f
              (make-string (+ digit-count (quotient (- digit-count 1) 4))
                           #\space))
          (let ((c (string-ref str i)))
            (cond ((char-numeric? c)
                   (let ((result (if (= 1 group-left)
                                     (scan (+ 1 i)
                                           (+ 1 digit-count)
                                           4
                                           (+ 2 digit-pos))
                                     (scan (+ 1 i)
                                           (+ 1 digit-count)
                                           (- group-left 1)
                                           (+ 1 digit-pos)))))
                     (and result
                          (string-set! result digit-pos c))
                     result))
                  ((%ccnum:char-blank? c)
                   (scan (+ 1 i) digit-count group-left digit-pos))
                  (else #f)))))))

;; (define (credit-card-number-mii-digit-issuer-category int)
;;   (if (<= 0 int 9)
;;       (vector-ref
;;        '#(iso-tc-68-and-other-industry-assignments
;;           airlines
;;           airlines-and-other-industry-assignments
;;           travel-and-entertainment
;;           banking-and-financial
;;           banking-and-financial
;;           merchandizing-and-banking
;;           petroleum
;;           telecommunications-and-other-industry-assignments
;;           national-assignment)
;;        int)
;;       (%ccnum:error
;;        "credit-card-number-mii-digit-issuer-category"
;;        "invalid credit card MII digit"
;;        int)))

;; TODO: Make a Testeez test suite.
;;
;; (map (lambda (x)
;;        (map check-credit-card-number x))
;;      '(
;;        ;; Good:
;;        ("4408 0412 3456 7893"
;;         "4408041234567893"
;;         "   4408041234567893  "
;;         "5368 2358 9683 1135"
;;         "4242 4242 4242 4242"
;;         "0")
;;        ;; Bad:
;;        ("4408 0412 3456 7890"
;;         "4408 0412 3456 7891"
;;         "4408 0412 3456 7892"
;;         "4408 0412 3456 7894"
;;         "4408 0412 3456 7895"
;;         "4408 0412 3456 7896"
;;         "4408 0412 3456 7897"
;;         "4408 0412 3456 7898"
;;         "4408 0412 3456 7899"
;;         ;; From sample images on the Web:
;;         "4403 1234 5678 9012"
;;         "4000 3456 7890 1234"
;;         "4544 1234 5678 9123"
;;         "4417 1234 5678 9112"
;;         "1234 5678 9012 3456"
;;         "4417 1234 5678 9112"
;;         "5490 1234 5678 9123"
;;         "5410 5678 1234 5678"
;;         "4104 1600 1234 5678"
;;         ;;
;;         "1"
;;         "trump"
;;         "")))

;; TODO: We don't permit integers to be used as a credit card number
;;       representation because apparently the first digit (the MII) could be
;;       0, which would be lost in integer representation.  This would lose
;;       information about even/odd-ness that's pertinent to the check digit
;;       calculation.  A future version of this package could conceivably
;;       support representations as lists and vectors of integers, if there is
;;       interest.

;; TODO: [Bradbury] claims ``In American Express and Discover the prefix digits
;;       are omitted from all calculations.''  I have not yet found any
;;       corroboration of this, and I found one direct refutation.  Need an
;;       authoritative source.  Also get some test cases of known valid ones.
;;
;;       "3712 321345 95006" ;; American Express sample

;; TODO: Add "write-credit-card-number-digits-only"
;;       and "credit-card-number-digits-only".

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.2 --- 2005-03-29
;;; Minus characters (@code{#\-}) are now accepted as blanks in credit card
;;; numbers.
;;;
;;; @item Version 0.1 --- 2004-05-15
;;; First release.
;;;
;;; @end table

;;; @unnumberedsec References

;;; @table @asis
;;;
;;; @item [Bradbury]
;;; Jeremy Scott Bradbury, ``Credit Card Check Digit,'' Web page, viewed
;;; 2004-05-15.@*
;;; @uref{http://www.cs.queensu.ca/~bradbury/checkdigit/creditcardcheck.htm}
;;;
;;; @item [Gilleland]
;;; Michael Gilleland, ``Anatomy of Credit Card Numbers,'' Web page, viewed
;;; 2004-05-15.@*
;;; @uref{http://www.merriampark.com/anatomycc.htm}
;;;
;;; @item [Hippy]
;;; Happy Hippy, ``Credit Card Magic,'' Web page, viewed 2004-05-15.@*
;;; @uref{http://www.hippy.freeserve.co.uk/credcard.htm}
;;;
;;; @item [LGPL]
;;; Free Software Foundation, ``GNU Lesser General Public License,'' Version
;;; 2.1, 1999-02, 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.@*
;;; @uref{http://www.gnu.org/copyleft/lesser.html}
;;;
;;; @item [SRFI-23]
;;; Stephan Houben, ``Error reporting mechanism,'' SRFI 23, 2001-04-26.@*
;;; @uref{http://srfi.schemers.org/srfi-23/srfi-23.html}
;;;
;;; @end table