[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/vxKNN1KE    [ raw code | fork ]

programmingpraxis - Scheme, pasted on May 19:
; isbn validation

(define (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(define (read-line . port)
  (define (eat p c)
    (if (and (not (eof-object? (peek-char p)))
             (char=? (peek-char p) c))
        (read-char p)))
  (let ((p (if (null? port) (current-input-port) (car port))))
    (let loop ((c (read-char p)) (line '()))
      (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
            ((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
            ((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
            (else (loop (read-char p) (cons c line)))))))

(define (clean isbn? str)
  (let loop ((cs (string->list str)) (out '()))
    (cond ((null? cs) (reverse out))
          ((and isbn? (null? (cdr cs)) (char-ci=? (car cs) #\X))
            (reverse (cons (car cs) out)))
          ((char-numeric? (car cs))
            (loop (cdr cs) (cons (car cs) out)))
          (else (loop (cdr cs) out)))))

(define (isbn? str)
  (let loop ((cs (clean #t str)) (mul 10) (sum 0))
    (if (null? cs) (zero? (modulo sum 11))
      (loop (cdr cs) (- mul 1) (+ sum (* mul
        (if (char-ci=? (car cs) #\X) 10
          (- (char->integer (car cs)) 48))))))))

(define (ean? str)
  (let loop ((cs (clean #f str)) (mul 1) (sum 0))
    (if (null? cs) (zero? (modulo sum 10))
      (loop (cdr cs) (- 4 mul) (+ sum (* mul
        (- (char->integer (car cs)) 48))))))))

(define (isbn->ean str)
  (if (not (isbn? str)) (error 'isbn->ean "invalid isbn")
    (let loop ((cs (clean #t str)) (ean '(#\8 #\7 #\9))
               (mul 3) (sum 38))
      (if (null? (cdr cs))
          (list->string (reverse (cons (integer->char (+
            (modulo (- 10 (modulo sum 10)) 10) 48)) ean)))
          (loop (cdr cs) (cons (car cs) ean) (- 4 mul)
            (+ sum (* mul (- (char->integer (car cs)) 48))))))))

(define (ean->isbn str)
  (if (not (ean? str)) (error 'ean->isbn "invalid ean")
    (let loop ((cs (drop 3 (clean #f str))) (isbn '())
               (mul 10) (sum 0))
      (if (null? (cdr cs))
          (list->string (reverse
            (cons (let ((d (modulo sum 11)))
                    (cond ((= d 0) #\0) ((= d 1) #\X)
                    (else (integer->char (- 59 d)))))
                  isbn)))
          (loop (cdr cs) (cons (car cs) isbn) (- mul 1)
            (+ sum (* mul (- (char->integer (car cs)) 48))))))))

;(define wget "c:\\cygwin\\bin\\wget -qO") ; windows/cygwin
;(define wget "/usr/local/bin/wget -qO") ; unix/hp
(define wget "/usr/bin/wget -q0") ; linux/ubuntu

(define (tempname)
  (let loop ((i 0))
    (let ((f (string-append "temp" (number->string i))))
      (if (file-exists? f) (loop (+ i 1)) f))))

(define (with-input-from-url url thunk)
  (let ((f (tempname)))
    (if (zero? (system (string-append wget " " f " \"" url "\"")))
        (begin (with-input-from-file f thunk) (delete-file f #t))
        (error 'with-input-from-url "system error in wget"))))

(define access-key "12345678") ; not a valid key

(define (display-isbndb.com isbn)
  (with-input-from-url
    (string-append "http://isbndb.com/api/books.xml?access_key="
      access-key "&index1=isbn&value1="
      (list->string (clean #t isbn)))
    (lambda ()
      (do ((c (read-char) (read-char))) ((eof-object? c))
        (display c)))))

(define (lookup-isbn isbn)
  (with-input-from-url
    (string-append "http://isbndb.com/api/books.xml?access_key="
      access-key "&index1=isbn&value1="
      (list->string (clean #t isbn)))
    (lambda ()
      (do ((str (read-line) (read-line))) ((eof-object? str))
        (when (and (< 7 (string-length str))
                   (string=? (substring str 0 7) "<Title>"))
          (display "Title: ")
          (display (substring str 7 (- (string-length str) 8)))
          (newline))
        (when (and (< 13 (string-length str))
                   (string=? (substring str 0 13) "<AuthorsText>"))
          (display "Authors: ")
          (display (substring str 13 (- (string-length str) 14)))
          (newline))))))

(lookup-isbn "0070004846")


Create a new paste based on this one


Comments: