;;; isbn.el --- Parse, hyphenate, and convert ISBN-10s and ISBN-13s

;; Copyright (C) 2008--2009 Vebjorn Ljosa

;; Author: Vebjorn Ljosa <vebjorn@ljosa.com>
;; Version: $Revision: 1.6 $
;; Date: $Date: 2009/04/10 14:39:41 $
;; Keywords: util

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, 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
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Most users will only be interested in the interactive functions
;; hyphenate-isbn-at-point, unhyphenate-isbn-at-point, and
;; convert-isbn-at-point.

;;; Code:

(eval-when-compile (require 'cl))


;; Data necessary for parsing ISBNs.

(defvar *isbn-group-ranges*
  (let ((ht (make-hash-table :test #'equal)))
    (setf (gethash "978" ht) '(("0" 1) ("6" nil) ("7" 1) ("80" 2) ("950" 3)
			       ("9900" 4) ("99900" 5)))
    ht)
  "Hash table containing a group range specification for each prefix.")

(defconst *groups-without-x* "82"
  "Areas (countries) for which the control digit X is not used.")

(defvar *isbn-registrant-ranges* 
  (let ((ht (make-hash-table :test #'equal))
	(registrant-ranges 
'(("0" ("00" "200" "7000" "85000" "900000" "9500000"))
  ("1" ("00" "100" "4000" "55000" "869800" "9990000"))
  ("2" ("00" "200" "35000" "400" "700" "84000" "900000" "9500000"))
  ("3" ("00" "030" "0340" "03700" "04" "200" "7000" "85000" "900000" "9500000"))
  ("4" ("00" "200" "7000" "85000" "900000" "9500000"))
  ("5" ("00" "200" "7000" "85000" "900000" "91000" "9200" "93000" "9500" "98000" "9900000" "9910"))
  ("7" ("00" "100" "5000" "80000" "900000"))
  ("80" ("00" "200" "7000" "85000" "900000"))
  ("81" ("00" "200" "7000" "85000" "900000"))
  ("82" ("00" "200" "7000" "90000" "990000"))
  ("83" ("00" "200" "60000" "7000" "85000" "900000"))
  ("84" ("00" "200" "7000" "85000" "9000" "920000" "92400" "930000" "95000" "9700"))
  ("85" ("00" "200" "60000" "7000" "85000" "900000" "98000"))
  ("86" ("00" "300" "7000" "80000" "900000"))
  ("87" ("00" "400" "7000" "85000" "970000"))
  ("88" ("00" "200" "6000" "85000" "900000"))
  ("89" ("00" "250" "5500" "85000" "950000"))
  ("90" ("00" "200" "5000" "70000" "800000" "8500" "900000" "940000"))
  ("91" ("0" "20" "500" "7000" "85000" "970000"))
  ("92" ("0" "60" "800" "9000" "95000" "990000"))
  ("950" ("00" "500" "9000" "99000"))
  ("951" ("0" "20" "550" "8900" "95000"))
  ("952" ("00" "200" "5000" "60" "6600" "67000" "7000" "89" "9500" "99000"))
  ("953" ("0" "10" "150" "6000" "95000"))
  ("954" ("00" "300" "8000" "90000" "9300"))
  ("955" ("0" "1000" "20" "550" "8000" "95000"))
  ("956" ("00" "200" "7000"))
  ("957" ("00" "0300" "05" "2000" "21" "28000" "31" "440" "8200" "97000"))
  ("958" ("00" "600" "8000" "95000"))
  ("959" ("00" "200" "7000"))
  ("960" ("00" "200" "6600" "690" "7000" "85000"))
  ("961" ("00" "200" "6000" "90000"))
  ("962" ("00" "200" "7000" "85000" "8700" "900"))
  ("963" ("00" "200" "7000" "85000" "9000"))
  ("964" ("00" "300" "5500" "90000" "970" "9900"))
  ("965" ("00" "200" "7000" "90000"))
  ("966" ("00" "300" "7000" "90000"))
  ("967" ("0" "60" "900" "9900" "99900"))
  ("968" ("01" "400" "5000" "800"))
  ("969" ("0" "20" "400" "8000"))
  ("970" ("01" "600" "9000" "91000" "9700"))
  ("971" ("000" "02" "0300" "06" "10" "500" "8500" "91000"))
  ("972" ("0" "20" "550" "8000" "95000"))
  ("973" ("0" "20" "550" "7600" "85000" "9000" "95000"))
  ("974" ("00" "200" "7000" "85000" "90000" "9500"))
  ("975" ("00000" "01" "250" "6000" "92000" "990"))
  ("976" ("0" "40" "600" "8000" "95000"))
  ("977" ("00" "200" "5000" "700"))
  ("978" ("000" "2000" "30000" "8000" "900"))
  ("979" ("0" "20" "3000" "400" "8000" "95000"))
  ("980" ("00" "200" "6000"))
  ("981" ("00" "200" "3000"))
  ("982" ("00" "100" "70" "9000"))
  ("983" ("00" "020" "2000" "40000" "50" "800" "9000" "99000"))
  ("984" ("00" "400" "8000" "90000"))
  ("985" ("00" "400" "6000" "90000"))
  ("986" ("00" "120" "5600" "80000"))
  ("987" ("00" "1000" "20000" "30" "500" "9000" "95000"))
  ("988" ("00" "200" "8000" "97000"))
  ("989" ("0" "20" "550" "8000" "95000"))
  ("9945" ("00" "400" "8500"))
  ("9946" ("0" "20" "400" "9000"))
  ("9947" ("0" "20" "800"))
  ("9948" ("00" "400" "8500"))
  ("9949" ("0" "10" "400" "9000"))
  ("9950" ("00" "300" "8500"))
  ("9951" ("00" "400" "8500"))
  ("9952" ("0" "20" "400" "8000"))
  ("9953" ("0" "10" "400" "60" "9000"))
  ("9954" ("0" "20" "400" "8000"))
  ("9955" ("00" "400" "9300"))
  ("9956" ("0" "10" "400" "9000"))
  ("9957" ("00" "400" "8500"))
  ("9958" ("0" "10" "500" "9000"))
  ("9959" ("0" "20" "800" "9500"))
  ("9960" ("00" "600" "9000"))
  ("9961" ("0" "30" "70009500"))
  ("9962" ("00" "5500" "56" "600" "8500"))
  ("9963" ("0" "30" "550" "7500"))
  ("9964" ("0" "70" "950"))
  ("9965" ("00" "400" "9000"))
  ("9966" ("00" "7000" "750" "9600"))
  ("9967" ("00" "400" "9000"))
  ("9968" ("00" "500" "9400"))
  ("9970" ("00" "400" "9000"))
  ("9971" ("0" "60" "900" "9900"))
  ("9972" ("00" "1" "200" "2500" "30" "600" "9000"))
  ("9973" ("0" "10" "700" "9700"))
  ("9974" ("0" "30" "550" "7500" "95"))
  ("9975" ("0" "50" "900" "9500"))
  ("9976" ("0" "60" "900" "9990"))
  ("9977" ("00" "900" "9900"))
  ("9978" ("00" "300" "40" "950" "9900"))
  ("9979" ("0" "50" "760" "9000"))
  ("9980" ("0" "40" "900" "9900"))
  ("9981" ("00" "100" "1600" "20" "800" "9500"))
  ("9982" ("00" "800" "9900" "80" "950" "9900"))
  ("9984" ("00" "500" "9000"))
  ("9985" ("0" "50" "800" "9000"))
  ("9986" ("00" "400" "9000" "940" "97"))
  ("9987" ("00" "400" "8800"))
  ("9988" ("0" "30" "550" "7500"))
  ("9989" ("0" "100" "2000" "30" "600" "9500"))
  ("99901" ("00" "500" "80"))
  ("99903" ("0" "20" "900"))
  ("99904" ("0" "60" "900"))
  ("99905" ("0" "40" "800"))
  ("99906" ("0" "30" "600" "70" "9"))
  ("99908" ("0" "10" "900"))
  ("99909" ("0" "40" "950"))
  ("99910" ("0" "30" "900"))
  ("99911" ("00" "600"))
  ("99912" ("0" "500" "60" "900"))
  ("99913" ("0" "30" "600"))
  ("99914" ("0" "50" "900"))
  ("99915" ("0" "50" "800"))
  ("99916" ("0" "30" "700"))
  ("99917" ("0" "30" "900"))
  ("99918" ("0" "40" "800"))
  ("99919" ("0" "40" "900"))
  ("99920" ("0" "50" "900"))
  ("99921" ("0" "20" "700"))
  ("99921" ("8" "90"))
  ("99922" ("0" "40" "700"))
  ("99923" ("0" "20" "800"))
  ("99924" ("0" "30" "800"))
  ("99925" ("0" "40" "800"))
  ("99926" ("0" "10" "600"))
  ("99927" ("0" "30" "600"))
  ("99928" ("0" "10" "800"))
  ("99930" ("0" "50" "800"))
  ("99931" ("0" "50" "800"))
  ("99932" ("0" "10" "600" "7" "80"))
  ("99933" ("0" "30" "600"))
  ("99934" ("0" "20" "800"))
  ("99935" ("0" "30" "600" "8" "90"))
  ("99936" ("0" "10" "600"))
  ("99937" ("0" "20" "600"))
  ("99938" ("0" "30" "600"))
  ("99939" ("0" "60" "900"))
  ("99940" ("0" "10" "700"))
  ("99941" ("0" "30" "900"))
  ("99942" ("0" "50" "800"))
  ("99943" ("0" "30" "600"))
  ("99944" ("0" "50" "800"))
  ("99945" ("0" "60" "900"))
  ("99946" ("0" "30" "600"))
  ("99947" nil)
  ("99948" ("0" "50" "800"))
  ("99949" ("0" "20" "900")))))
    (loop
     for (area ranges) in registrant-ranges
     do (setf (gethash area ht)
	      (mapcar (lambda (range-start)
			(list range-start (length range-start)))
		      ranges)))
    ht)
  "Hash table containing a registrant range specification for each group.")


;; Parse an ISBN.

(defun isbn-prefix (digits)
  "Return the prefix of an ISBN-13 (usually 978).  
Return NIL for an ISBN-10."
  (ecase (length digits)
    (10 nil)
    (13 (subseq digits 0 3))))

(defun string<= (a b)
  (or (string< a b)
      (string= a b)))

(defun search-ranges (ranges digits &optional start)
  (setq start (or start 0))
  (let ((length nil))
    (loop
     for (beginning a-length) in ranges
     while (string<= beginning (subseq digits start
				       (+ start (length beginning))))
     do (setf length a-length))
    length))

(defun isbn-group (digits)
  "Return the group (usually country or language group) of an ISBN."
  (flet ((parse-group (digits &optional start prefix)
	   (setq start (or start 0)
		 prefix (or prefix "978"))
	   (let ((ranges (gethash prefix *isbn-group-ranges*)))
	     (unless ranges
	       (error "Group ranges not known for prefix %s" prefix))
	     (subseq digits start
		     (+ start (search-ranges ranges digits start))))))
    (ecase (length digits)
      (10 (parse-group digits))
      (13 (parse-group digits 3)))))

(defun isbn-registrant (digits)
  "Return the registrant (usually publisher) of an ISBN."
  (let ((prefix-length (ecase (length digits)
			 (10 0)
			 (13 3)))
	(group (isbn-group digits)))
    (let ((ranges (gethash group *isbn-registrant-ranges*)))
      (unless ranges
	(error "Registrant ranges not known for group %s" group))
      (subseq digits (+ prefix-length (length group))
	      (+ prefix-length (length group) 
		 (search-ranges ranges digits
				(+ prefix-length (length group))))))))

(defun isbn-publication (digits)
  "Return the publication number of an ISBN."
  (let ((prefix-length (- (length digits) 10))
	(group (isbn-group digits))
	(registrant (isbn-registrant digits)))
    (subseq digits (+ prefix-length (length group)
		      (length registrant)) 
	    (+ 9 prefix-length))))

(defun isbn-check-digit (digits)
  "Return the check digit of an ISBN."
  (subseq digits (1- (length digits))))

(defun parse-isbn (digits)
  "Return a list of the prefix, group, registrant, publication, and check
digit of an ISBN."
  (list (isbn-prefix digits) (isbn-group digits) (isbn-registrant digits)
	(isbn-publication digits) (isbn-check-digit digits)))


;; Check that the input is an ISBN.

(defun digit-char-p (char)
  (if (and (<= ?0 char) (<= char ?9))
      (- char ?0)
      nil))

(defun isbn-char-p (char)
  (or (digit-char-p char)
      (member char '(?\- ?\x ?\X))))

(defun isbn-char-equal (a b)
  (or (= a b)
      (and (= a ?\X) (= b ?\x))
      (and (= a ?\x) (= b ?\X))))

(defun isbn-well-formed (digits)
  (case (length digits)
    (10 (dotimes (i 9)
	  (unless (digit-char-p (aref digits i))
	    (return nil)))
	(unless (or (digit-char-p (aref digits 9))
		    (char-equal (aref digits 9) ?\x)
		    (char-equal (aref digits 9) ?\X))
	  (return nil))
	t)
    (13 (dotimes (i 13)
	  (unless (digit-char-p (aref digits i))
	    (return nil)))
	t)
    (t nil)))

(defun compute-isbn-check-digit (digits)
  "Compute the correct check digit for an ISBN."
  (ecase (length digits)
    ((9 10) (let ((sum 0))
	      (dotimes (i 9)
		(incf sum (* (1+ i) (digit-char-p (aref digits i)))))
	      (aref "0123456789X" (mod sum 11))))
    ((12 13) (let ((sum 0))
	       (dotimes (i 12)
		 (incf sum (* (if (evenp i) 1 3)
			      (digit-char-p (aref digits i)))))
	       (+ ?0 (mod (- 10 (mod sum 10)) 10))))
    (t (error "Invalid input to compute-isbn-check-digit: %s" digits))))

(defun check-isbn (digits)
  "Signal an error if the argument is not an ISBN."
  (unless (isbn-well-formed digits)
    (error "%s is not a valid ISBN" digits))
  (let ((correct-check-digit (compute-isbn-check-digit digits)))
    (unless (isbn-char-equal (aref digits (1- (length digits)))
			     correct-check-digit)
      (error "%s is not a valid ISBN (incorrenct check digit, should be %c)" 
	     digits correct-check-digit)))
  t)

;;(check-isbn "9780123725783")
;;(check-isbn "012372578X")


;; Hyphenate and convert ISBNs.

(defun hyphenate-isbn (digits)
  "Insert hyphens at appropriate places in the given ISBN.
The argument must be a 10-character string (for an ISBN-10) or a
13-character string (for an ISBN-13)."
  (check-isbn digits)
  (destructuring-bind (prefix group registrant publication check-digit)
      (parse-isbn digits)
    (ecase (length digits)
      (10 (format "%s-%s-%s-%s" group registrant publication check-digit))
      (13 (format "%s-%s-%s-%s-%s" prefix group registrant publication 
		  check-digit)))))

;;(hyphenate-isbn "9780123725783")
;;(hyphenate-isbn "012372578X")

(defun find-isbn-at-point ()
  (let (start end)
    (save-excursion
      (while (and (< (point) (point-max))
		  (isbn-char-p (following-char)))
	(forward-char))
      (setq end (point))
      (while (and (> (point) (point-min))
		  (isbn-char-p (preceding-char)))
	(backward-char))
      (setq start (point)))
    (values (replace-in-string (buffer-substring-no-properties start end)
			       "-" "")
	    start end)))

(defun hyphenate-isbn-at-point ()
  "Insert hyphens at appropriate places in the ISBN at the point."
  (interactive)
  (multiple-value-bind (digits start end) (find-isbn-at-point)
    (let ((hyphenated (hyphenate-isbn digits)))
      (delete-region start end)
      (goto-char start)
      (insert hyphenated))))

(defun unhyphenate-isbn-at-point ()
  "Remove hyphens from the ISBN at the point."
  (interactive)
  (multiple-value-bind (digits start end) (find-isbn-at-point)
    (delete-region start end)
    (goto-char start)
    (insert digits)))

(defun convert-isbn (digits)
  (ecase (length digits)
    (10 (setq digits (concat "978" digits)))
    (13 (unless (equal (isbn-prefix digits) "978")
	  (error "Only prefix-978 ISBNs can be converted to ISBN-10s"))
	(setq digits (subseq digits 3))))
  (setf (aref digits (1- (length digits)))
	(compute-isbn-check-digit digits))
  digits)

;;(convert-isbn "978-0-12-372578-3")
;;(convert-isbn "0-12-372578-X")

(defun convert-isbn-at-point ()
  "Convert an ISBN-10 to an ISBN-13 and vice-versa."
  (interactive)
  (multiple-value-bind (digits start end) (find-isbn-at-point)
    (let ((result (hyphenate-isbn (convert-isbn digits))))
      (delete-region start end)
      (goto-char start)
      (insert result))))

;;; isbn.el ends here