;;; @Package     ccnum
;;; @Subtitle    Credit Card Number Utilities in Scheme
;;; @HomePage    http://www.neilvandyke.org/ccnum-scheme/
;;; @Author      Neil Van Dyke
;;; @Version     0.4
;;; @Date        2009-03-11
;;; @PLaneT      neil/ccnum:1:2

;; $Id: ccnum.ss,v 1.51 2009/03/11 10:16:25 neilpair Exp $

;;; @legal
;;; Copyright @copyright{} 2004--2009 Neil 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 3 of the License (LGPL 3), 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
;;; @indicateurl{http://www.gnu.org/licenses/} for details.  For other licenses
;;; and consulting, please contact the author.
;;; @end legal

#lang scheme/base

;;; @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.  The author invites free copies of authoritative
;;; documentation.
;;;
;;; Achtung!  Do not use this library as anything other than a novelty unless
;;; you understand the code thoroughly and can invest in verifying its
;;; correctness.
;;;
;;; Some references that were used:
;;;
;;; @itemize
;;;
;;; @item
;;; Jeremy Scott Bradbury,
;;; ``@uref{http://www.cs.queensu.ca/~bradbury/checkdigit/creditcardcheck.htm,
;;; Credit Card Check Digit},'' Web page, viewed 2004-05-15.
;;;
;;; @item
;;; Michael Gilleland, ``@uref{http://www.merriampark.com/anatomycc.htm,
;;; Anatomy of Credit Card Numbers},'' Web page, viewed 2004-05-15.
;;;
;;; @item
;;; Happy Hippy, ``@uref{http://www.hippy.freeserve.co.uk/credcard.htm, Credit
;;; Card Magic},'' Web page, viewed 2004-05-15.
;;;
;;; @end itemize

(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.  For example
;;;
;;; @lisp
;;; (write-formatted-credit-card-number " 1 23 456  7890 12345 6 "
;;;                                     (current-output-port))
;;; @end lisp
;;;
;;; @noindent Outputs:
;;;
;;; @example
;;; 1234 5678 9012 3456
;;; @end example

(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))
      (and (< 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: 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.4 --- 2009-03-11 --- PLaneT @code{(1 2)}
;;; Documentation tweaks.
;;;
;;; @item Version 0.3 --- 2009-03-03 --- PLaneT @code{(1 1)}
;;; License is now LGPL 3.  Converted to author's new Scheme administration
;;; system.  Tweaks for PLT 4.x.
;;;
;;; @item Version 0.2 --- 2005-03-29 --- PLaneT @code{(1 0)}
;;; Minus characters (@code{#\-}) are now accepted as blanks in credit card
;;; numbers.
;;;
;;; @item Version 0.1 --- 2004-05-15
;;; First release.
;;;
;;; @end table

(provide
 check-credit-card-number
 credit-card-number-check-digit-ok?
 credit-card-number-seems-ok?
 formatted-credit-card-number
 write-formatted-credit-card-number)