solving Ishmael problem from http://www.renesys.com/challenge_site/challenge/count_me_ishmael

ishmael.lsp

; solving Ishmael problem from http://www.renesys.com/challenge_site/challenge/count_me_ishmael 


; NOTE: The times below are inflated since the profiling code slows everything down
; Current profile
;  seconds  |    consed   |    calls   |  sec/call  |  name
;--------------------------------------------------------------
;     0.391 |  33,214,464 |    952,404 |  0.0000004 | IS-CVVC
;     0.214 |  30,027,776 |    664,719 |  0.0000003 | IS-CHAR-CONSTANANT
;     0.156 |           0 |  2,308,632 |  0.0000001 | IS-CHAR-VOWEL
;     0.153 |           0 |  1,561,826 |  0.0000001 | LETTERP
;     0.147 |           0 |  1,237,515 |  0.0000001 | IS-LINE-EMPTY
;     0.105 |   7,733,248 |    952,404 |  0.0000001 | SET-CDR
;     0.098 |   8,164,456 |     30,324 |   0.000003 | GET-STRING
;     0.084 |   1,362,264 |     30,324 |   0.000003 | ADD-WORD-TO-HASH
;     0.037 |           0 |  1,215,791 |  0.0000000 | IS-CHAR-SPACE
;     0.001 |     139,128 |          1 |   0.000999 | HASH-TO-LIST
;     0.000 | 177,061,864 |  1,237,515 |   0.000000 | TEST-LINE
;     0.000 |   5,960,408 |          1 |   0.000000 | FILE-LINES
;--------------------------------------------------------------
;     1.385 | 263,663,608 | 10,191,456 |            | Total




(defpackage ishmael (:use :common-lisp))
(in-package :ishmael)

(defparameter *word-count* (make-hash-table :test 'equal :size 8192))


(defun add-word-to-hash (word)
        (incf (gethash (string-downcase word) *word-count* 0)))

(defun is-line-empty (line index) (equal (length line) index))
(defun is-char-vowel (char)
    (case char ((#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U) t)))
(defun letterp (char) (or (char<= #\a char #\z) (char<= #\A char #\Z)))
(defun is-char-constanant (char) (and (letterp char) (not (is-char-vowel char))))

(defun is-char-space (char) (or (char= char #\space) (char= char #\newline) (char= char #\linefeed)))


(defparameter *cvvc* (vector #'is-char-constanant #'is-char-vowel #'is-char-vowel #'is-char-constanant))

(defun get-string (line tuple)
	(remove-if-not #'letterp (subseq line (car tuple) (cdr tuple))))

(defun set-cdr (cons-list value) (cons (car cons-list) value))

(defun is-cvvc (line index cvvc)
	(if (equal cvvc t) 
		t
		(if (funcall (elt *cvvc* cvvc) (elt line index))
			(if (= cvvc 3)
				(setf cvvc t)
				(incf cvvc 1))
			(if (funcall (elt *cvvc* 0) (elt line index))
				(setf cvvc 1)
				(setf cvvc 0)))))
							

(defun test-line (line &optional (index 0) (accumulated-word '(0 . 0)) (cvvc 0))
;	(declare (optimize (speed 3) (safety 0) (debug 0)))
    (if (is-line-empty line index)
        (if (eq cvvc t) (add-word-to-hash (get-string line accumulated-word)))

        (let ((char (elt line index)))
			(cond
				((is-char-space char) (progn
					(if (eq t cvvc) (add-word-to-hash (get-string line accumulated-word)))
					(test-line line (+ 1 index) `(,(+ 1 index) . ,(+ 1 index)))))
				((is-char-vowel char) 
					(test-line line (+ 1 index) (set-cdr accumulated-word (+ 1 index)) (is-cvvc line index cvvc)))
				((is-char-constanant char)
					(test-line line (+ 1 index) (set-cdr accumulated-word (+ 1 index)) (is-cvvc line index cvvc)))
				(t
					(test-line line (+ 1 index) accumulated-word cvvc))
			))))



; Debugging functions
(defun print-hash-entry (key value)
    (format t "The value associated with the key ~S is ~S~%" key value))

(defun dump-word-table () (maphash #'print-hash-entry *word-count*))

(defun hash-to-list (hashtable)
  "Return a list that represent the HASHTABLE."
  (let ((mylist '()))
    (maphash (lambda (kk vv) (push (list kk vv) mylist)) hashtable)
    mylist))

(defun read-file (file)
	(with-open-file (in file :if-does-not-exist nil)
		(let ((input (make-array (file-length in) :element-type 'character)))
			(read-sequence input in)
			input)))

; Main function for looping through lines and computing word frequency
(defun file-lines (file)
	(progn
		(with-open-file (in file :if-does-not-exist nil)
			(when in (loop for line = (read-line in nil)
				while line do (test-line line)
		)))
		(sort (hash-to-list *word-count*) 
			(lambda (a b) 
				(cond
					((< (cadr a) (cadr b)) 'nil)
					((> (cadr a) (cadr b)) t)
					(t (string< (car a) (car b))))))
;		'nil
	))


(in-package :common-lisp-user)