Solutions to exercises from "lecture notes 6"

;;;; A couple of these turn out (when I actually did them) to be more
;;;; than somewhat unpleasant. Do not give up the struggle...

;;; WORD COUNTS

(defun word-count ()

;; split this off so we can run tests to verify whether it works
(defun do-word-count (string)
(let* ((count 0))
(dotimes (i (length string))
;; need to look for a word BOUNDARY...
(if (and (or (zerop i)
(spacep string (1- i)))
(not (spacep string i)))
(incf count)))
count))

;; utility
(defun spacep (string index)
(char= (aref string index) #\Space))

;; tests
(let* ((tests '(("One two three" 3)    ; simplest case
("One  two  three" 3)  ; multiple spaces
(" One two three" 3)   ; leading space
("One two three " 3)   ; trailing space
("    One         two          three         " 3)  ; lots of spaces
("" 0)                 ; empty
("         " 0)        ; just spaces
)))
(dolist (test tests)
(let* ((string (first test))
(expected (second test))
(obtained (do-word-count string)))
(unless (= expected obtained)
(error "Test on ~s failed: count appears to be ~a but expected ~a."
string obtained expected)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun rotate-square-array (array)
(let* ((dimensions (array-dimensions array))
(dimension (first dimensions))
(new-array (make-array dimensions)))
;; error check...
(unless (= dimension (second dimensions))
(error "Not a square array!"))
(dotimes (i dimension)
(dotimes (j dimension)
(setf (aref new-array j (- dimension i 1))
(aref array i j))))
new-array))                        ; nasty

(defun reducing-copy-list (list)
(reduce 'cons list :initial-value nil :from-end t))

(defun reducing-reverse (list)
(reduce 'rcons list :initial-value nil))

(defun rcons (rest first)
(cons first rest))

;; could have downcased the whole string in one go...
(defun alpha-count (string)
(let* ((counts (make-array 26 :initial-element 0))
(lower-a (char-code #\a)))
(dotimes (i (length string))
(let* ((char (aref string i)))
(if (alpha-char-p char)
(incf (aref counts (- (char-code (char-downcase char))
lower-a))))))
(dotimes (i 26)
(format t "~&~a   ~a"
(code-char (+ lower-a i))
(aref counts i))))
nil)

;; char= and = &co require one argument minimum...
(defun better-equal (things)
(if things
(in-better-equal (first things) (rest things))
(error "Call to ~s needs at least one thing." 'better-equal)))

(defun in-better-equal (thing others)
(if others
(if (equal thing (first others))
(in-better-equal thing (rest others))
nil)                       ; termination condition: fail
t)))                           ; termination condition: success

(defun recursive-compare (list vector)
(in-recursive-compare list vector 0))

(defun in-recursive-compare (list vector index)
(let* ((vector-length (length vector))
(vector-expired (= index vector-length))
(list-expired (null list)))
(or ;; got to the end of both?
(and vector-expired list-expired)
;;    did one sequence run out too soon?
(and (not (or vector-expired list-expired))
;; do the check
(equal (first list)
(aref vector index))
;; and carry on along both sequences
(in-recursive-compare (rest list) vector (1+ index)))))
)                                ; quite unpleasant

;; probably less hassle to use a "free ride" along the vector, ie to
;; use dotimes - this way we don't have to worry about going over the
;; end of the vector
(defun iterative-compare (list vector)
(and (dotimes (i (length vector) t)  ; note the default return value
(if (or (null list)
(not (equal (pop list)
(aref vector i))))
(return nil)))
(null list)))              ; moderately tough

If you have tried the exercises, looked at the solutions and still do not understand what's going on, I am available for consultation at the times advertised on my office door. Bring your code with you in BOTH the following forms:

• Logbook containing printout (nothing handwritten please)
• file on floppy

Nick Levine