[LISP函数]：通用函数 身份证号码升位

zml84

[PHP]
通用函数 身份证号码升位.lsp

--------------------------------------------------------------------------------

;;;========================================================
;;;功能：通用函数 由15或17位身份证号码计算其效验码
;;;参数：ID  ----15或17位长度字符串表示的身份证号码
;;;返回：效验码字符 ，或nil
;;;日期：zml84 于 2007-12-17
(defun GETK (ID / LST_ID I LST_W TMP)
    (if        (or
            (= (strlen ID) 15)
            (= (strlen ID) 17)
        )
        (progn
            ;;如果是15位，则年份添加19
            (if        (= (strlen ID) 15)
                (setq ID (strcat (substr ID 1 6) "19" (substr ID 7)))
            )
            ;;化为数字表
            (setq LST_ID '()
                  I 17
            )
            (repeat 17
                (setq LST_ID (cons (atoi (substr ID I 1)) LST_ID))
                (setq I (1- I))
            )
            ;;加权因子
            (setq LST_W '(7 9 10 5 8 4 2 1 6 3 7 9 10 5 8 4 2))
            ;;计算和
            (setq TMP 0
                  I 0
            )
            (repeat 17
                (setq TMP (+ TMP (* (nth I LST_ID) (nth I LST_W))))
                (setq I (1+ I))
            )
            ;;取模
            (setq TMP (rem TMP 11))
            ;;查表得效验码
            (substr "10X98765432" (1+ TMP) 1)
        )
    )
)
;;;============================================================
;;;功能：身份证号码由15位或17升为18位
;;;参数：ID  ----长度15或17字符串表示的身份证号码
;;;返回：升位后的18位身份证号码 ，或nil
;;;日期：zml84 于 2007-12-17
(defun TEST1 (ID / K)
    (if        (or
            (= (strlen ID) 15)
            (= (strlen ID) 17)
        )
        (progn
            ;;如果是15位，则年份添加19
            (if        (= (strlen ID) 15)
                (setq ID (strcat (substr ID 1 6) "19" (substr ID 7)))
            )
            ;;获取效验码
            (setq K (GETK ID))
            ;;返回
            (strcat ID K)
        )
    )
)
;;;============================================================
;;;功能：18位身份证号码验证
;;;参数：ID  ----长度18字符串表示的身份证号码
;;;返回：若正确返回T，否则nil
;;;日期：zml84 于 2007-12-17
(defun TEST2 (ID / K)
    (and (= (strlen ID) 18)
         ;;获取效验码
         (setq K (GETK (substr ID 1 17)))
         ;;返回
         (= K (strcase (substr ID 18)))
    )
)
;;;============================================================
[/PHP]
摘自：http://zml84.blog.sohu.com/73752277.html