; validating telephone numbers

(define (drop-while pred? xs)
  (let loop ((xs xs))
    (if (or (null? xs) (not (pred? (car xs)))) xs
      (loop (cdr xs)))))

(define (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(define-syntax assert
  (syntax-rules ()
    ((assert expr result)
      (if (not (equal? expr result))
          (for-each display `(
            #\newline "failed assertion:" #\newline
            expr #\newline "expected: " ,result
            #\newline "returned: " ,expr #\newline))))))

(define (valid-phone str)
  (define (strip-white cs)
    (drop-while char-whitespace? cs))
  (define (strip-white-dot-dash cs)
    (let ((cs (strip-white cs)))
      (if (not (member (car cs) (list #\. #\-))) cs
        (strip-white (cdr cs)))))
  (define (get-number cs)
    ; (display "  get-number ") (display cs) (newline)
    (let loop ((i 4) (cs (strip-white cs)) (ds (list)))
      (cond ((zero? i) (values ds cs))
            ((null? cs) (values #f cs))
            ((not (char-numeric? (car cs))) (values #f cs))
            (else (loop (- i 1) (cdr cs) (cons (car cs) ds))))))
  (define (get-exchange cs)
    ; (display "  get-exchange ") (display cs) (newline)
    (let loop ((i 3) (cs (strip-white-dot-dash cs)) (ds (list)))
      (cond ((zero? i) (values ds cs))
            ((null? cs) (values #f cs))
            ((not (char-numeric? (car cs))) (values #f cs))
            (else (loop (- i 1) (cdr cs) (cons (car cs) ds))))))
  (define (get-area cs)
    ; (display "  get-area ") (display cs) (newline)
    (let ((cs (strip-white cs)))
      (cond ((null? cs) (values (list) (list)))
            ((char=? (car cs) #\-) (get-area (cdr cs)))
            ((char=? (car cs) #\.) (get-area (cdr cs)))
            ((char=? (car cs) #\))
              (call-with-values
                (lambda () (get-area (cdr cs)))
                (lambda (area cs)
                  (if (not area) (values #f cs)
                    (if (not (char=? (car cs) #\())
                        (values #f cs)
                        (values area (cdr cs)))))))
            ((char-numeric? (car cs))
              (let loop ((i 3) (cs cs) (ds (list)))
                (cond ((zero? i) (values ds cs))
                      ((null? cs) (values #f cs))
                      ((not (char-numeric? (car cs))) (values #f cs))
                      (else (loop (- i 1) (cdr cs) (cons (car cs) ds))))))
            (else (values #f cs)))))
  ; (display "input ") (display str) (newline)
  (call-with-values
    (lambda () (get-number (reverse (string->list str))))
    (lambda (number cs)
      ; (display "    result ") (display number)
      ; (display " ") (display cs) (newline)
      (if (not number) #f
        (call-with-values
          (lambda () (get-exchange cs))
          (lambda (exchange cs)
            ; (display "    result ") (display exchange)
            ; (display " ") (display cs) (newline)
            (if (not exchange) #f
              (call-with-values
                (lambda () (get-area cs))
                (lambda (area cs)
                  ; (display "    result ") (display area)
                  ; (display " ") (display cs) (newline)
                  (if (and area (null? (strip-white cs)))
                      (list->string (append area exchange number))
                      #f))))))))))

(define (test-phone)
  (let ((valid (list "1234567890" "123-456-7890" "123.456.7890"
          "(123)456-7890" "(123) 456-7890" "456-7890"))
        (invalid (list "12-345-6789" "123-45-6789" "123-456-789"
          "123-45-67890" "123:4567890" "123/456-7890" "123456"
          "12345678" "123456789" "12345678901" "123-456-7890 x123")))
    (for-each
      (lambda (str)
        (assert (string->list (valid-phone str))
                (filter char-numeric? (string->list str))))
      valid)
    (for-each
      (lambda (str) (assert (valid-phone str) #f))
      invalid)))

(test-phone) ; no news is good news