Many people unfamiliar with Common Lisp believe it's a purely
functional language, but this is untrue. While you can shape your
Common Lisp programs in a functional way, Common Lisp also support
Object Oriented Programming via CLOS, the Common Lisp Object
System. It is truly a multi-paradigm language.

This books teaches all the aspects of CLOS, and although written
several years ago, the knowledge still applies today. After learning
about Object Oriented programming using languages like C++ and Java,
learning about CLOS really opened my eyes to what this style of
programming should feel like. All the other languages now seem to
constrained compared to the power and flexibility of CLOS.

In CLOS, classes only have member variables, called slots, and support
multiple inheritance. They do not define methods. Instead, methods are
defined for Generic Functions which specialize on the classes. While
most OO languages use single dispatch, meaning methods specialize on
only one class, CLOS uses multiple dispatch. It also supports
specializing on distinct object instances. In addition to primary
methods, CLOS has before, after and around methods. You can even
dictate the order in which CLOS calls all of the applicable methods.

I truly enjoyed this book as it expanding my understanding of object
oriented techniques. I hope the mainstream language designers can take
the time to read this and incorporate more of CLOS into today's
popular, but limited, object oriented systems.

;;; SICP Section 3.1

;;; 3.1
(defun make-accumulator (n)
  (lambda (x)
    (incf n x)))

;;; 3.2
(defun make-monitored (f)
  (let ((count 0))
    (lambda (x)
      (cond ((eq x 'how-many-calls?) count)
     ((eq x 'reset-count) (setf count 0))
     (t (incf count)
        (funcall f x))))))

;;; 3.3 and 3.4 - updated for 3.7
(defun make-account (balance password)
  (let ((consecutive-attempts 0))
    (labels ((withdraw (amount)
        (if (>= balance amount)
     (setf balance (- balance amount))
     "Insufficient funds"))
      (deposit (amount)
        (setf balance (+ balance amount)))
      (dispatch (pass m)
        (cond
   ;; Incorrect password?
   ((not (eq pass password))
    (lambda (x)
      (if (<= 7 (incf consecutive-attempts))
   "Calling cops"
   "Incorrect password")))
   ;; Withdrawing?
   ((eq m 'withdraw)
    (setf consecutive-attempts 0)
    #'withdraw)
   ;; Depositing?
   ((eq m 'deposit)
    (setf consecutive-attempts 0)
    #'deposit)
   ;; Creating joint account?
   ((eq m 'joint)
    (lambda (new-pass)
      (lambda (pass m)
        (if (eq pass new-pass)
     (funcall #'dispatch password m)
     (funcall #'dispatch nil m)))))
   (t (error "Unknown request -- MAKE-ACCOUNT")))))
      #'dispatch)))

(defun withdraw (acc pwd amt)
  (funcall (funcall acc pwd 'withdraw) amt))

(defun deposit (acc pwd amt)
  (funcall (funcall acc pwd 'deposit) amt))

;;; 3.5
(defun random-in-range (low high)
  (let ((range (- high low)))
    (+ low (random range))))

(defun monte-carlo (trials experiment)
  (labels ((iter (trials-remaining trials-passed)
      (cond ((= trials-remaining 0)
      (float (/ trials-passed trials)))
     ((funcall experiment)
      (iter (- trials-remaining 1) (+ trials-passed 1)))
     (t
      (iter (- trials-remaining 1) trials-passed)))))
    (iter trials 0)))

(defun in-circle-p ()
  (let ((x (random-in-range 0 1.0))
 (y (random-in-range 0 1.0)))
    (<= (+ (expt (- x 0.5) 2)
    (expt (- y 0.5) 2))
 (expt 0.5 2))))

(defun estimate-integral (p x1 x2 y1 y2 trials)
  (let ((area-of-rect (* (- x2 x1)
    (- y2 y1)))
 (frac-inside (monte-carlo trials p)))
    (* frac-inside area-of-rect)))

;;; 3.6
(let ((st (make-random-state)))
  (defun rnd (sym)
    (cond ((eq sym 'generate)
    (lambda (x)
      (random x st)))
   ((eq sym 'reset)
    (lambda (x)
      (setf st x)))
   (t "Unknown symbol"))))

;;; 3.7
(defun make-joint (acc pass new-pass)
  (funcall (funcall acc pass 'joint) new-pass))

;;; 3.8
(let ((num 1))
  (defun f (n)
    (setf num (* num n))))

Practical Common Lisp has turned into the de facto standard for beginners who want to learn Common Lisp, and deservingly so. The opening chapters delve right into the development style of Common Lisp and show how it differs from more mainstream languages. It covers all the basics and more, eventually leading into chapters explaining how to parse MP3 files and create and create an MP3 Shoutcast server from scratch.

Common Lisp is my favorite language to develop in, but most people I talk to dismiss it as being too old and irrelevant for today's computer applications. I highly disagree. The fact that the language is old is actually one of it's strengths: every design decision seems so well thought out. I've had numerous moments where I commented to myself "you know, it would be nice if this function could do this," and then discovered that it could after reading the documentation. And the development environment is the best out there. The Slime/Emacs/Lisp combination is way ahead of Visual Studio in terms of interactivity, customization, jumping through source files and debugging.

I recommend this book to all developers out there, as learning Common Lisp helped me in my day job as well. At least read through the chapter on creating a unit test framework to get a feel of what software development should be like.

SQL Prompt is a great add-on tool for SQL Server Management Studio that I use at work extensively. One of the features it has is "Snippets", which allow you to type a piece of code that expands into other code. For example, typing "ssf" and hitting Tab expands into "SELECT * FROM".

Users can customize snippets, which are saved in a file and can be shared with others (more info here). The database schema I use at work contains hundreds of tables, each named accoring to their abbreviated primary keys. Since some names are very long and cumbersome to type even with SQL Prompt, I created a Lisp script to auto generate snippets for each of the tables.

For example, lets say our database models baseball statistics. We have tables for players and teams. Since we want to tract statistics for multiple years, we have a year table and tables relating the three. So, our very simple database may look like this:

- Teams
- Players
- Years
- PlayersYears
- TeamsYears
- PlayersTeamsYears

My simple Lisp program created snippets for each of the tables, expanding "pty" to "PlayersTeamsYears" and such for each of the tables.

After saving my new SQL Prompt snippets file and starting Management Studio, SQL Prompt generated a run-time error because I had duplicate shortcut keys. Unfortuately, the error message didn't say which keys were duplicates, so I used the s-xml package and parsed the SQL Prompt file looking for duplicate shortcuts.

s-xml works by parsing the xml file sequentially. For each new element, it calls a new-element hook function, and for each new piece of text it calls a new-text hook. The new-element hook takes as pararmenters the name of the element and the attributes. The new-text hook takes the string of text. Each hook also accepts a seed element, which can be any object and is passed along while parsing the file.

I wanted to find duplicate shortcuts, so I decided to keep a hash-table with shortcuts as the key and the number of occurances as values. The shortcuts live inside of the "Shortcut" element, so my seed also needed to know the name of current element it was working on. I created the following class for my seed:

(defclass dup-shortcut-seed ()
  ((name :accessor name)
   (hash :initform (make-hash-table :test 'equalp) :accessor hash)))

I created a method to easily increment the class's hash table:

(defgeneric inc-hash (dup-shortcut-seed key))

(defmethod inc-hash ((dup-shortcut-seed dup-shortcut-seed) key)
  (incf (gethash key (hash dup-shortcut-seed) 0)))

Now that I have my seed, I created the element and text hooks that use the seed to keep track of duplicate shortcuts:

(defun dup-shortcut-xml-new-element-hook (name attributes seed)
  (declare (ignore attributes))
  (let ((name (print-xml-string name)))
    (setf (name seed) name)
    (format t "New element: ~s~%" name))
  seed)

(defun dup-shortcut-xml-text-hook (string seed)
  (when (equalp (name seed) "Shortcut")
    (format t "Modifying hash~%")
    (inc-hash seed string))
  seed)

Next I created a function to call the parser on a stream:

(defun dup-shortcut-xml (in)
  (start-parse-xml
   in
   (make-instance 'xml-parser-state
    :seed (make-instance 'dup-shortcut-seed) 
    :new-element-hook #'dup-shortcut-xml-new-element-hook
    :text-hook #'dup-shortcut-xml-text-hook)))

Finally, I created the main function, which parses the xml file and diplays any duplicate shortcuts:

(defun find-dup-shortcuts-in-xml (&optional (file *output-file*))
  (with-open-file (in file)
    (let ((hash (hash (dup-shortcut-xml in))))
      (maphash (lambda (key value)
   (when (> value 1)
     (format t "~s:~s" key value)))
        hash))))

After finding the shortcuts, I modified my snippet file and it worked beautifully!

;;;; SICP Section 2.3

;;; 2.54
(defun my-equals (list1 list2)
  (cond ((and (null list1) (null list2)) t)
 ((and (consp (car list1)) (consp (car list2)))
  (and (my-equals (car list1) (car list2))
       (my-equals (cdr list1) (cdr list2))))
 (t (and (equalp (car list1) (car list2))
  (my-equals (cdr list1) (cdr list2))))))

;;; 2.55
;; ''abc => (quote (quote abc))
;; (car (quote (quote abc))) = > quote

;;; 2.56
;;; Differentiation definitions
(defun variablep (x)
  (symbolp x))

(defun same-variable-p (v1 v2)
  (and (variablep v1) (variablep v2) (equal v1 v2)))

(defun sump (x)
  (and (consp x) (equal (car x) '+)))

(defun addend (s)
  (cadr s))

(defun augend (s)
  (caddr s))

(defun productp (x)
  (and (consp x) (equal (car x) '*)))

(defun multiplier (p)
  (cadr p))

(defun multiplicand (p)
  (caddr p))

(defun =number (exp num)
  (and (numberp exp) (= exp num)))

(defun make-sum (a1 a2)
  (cond ((=number a1 0) a2)
 ((=number a2 0) a1)
 ((and (numberp a1) (numberp a2)) (+ a1 a2))
 (t (list '+ a1 a2))))

(defun make-product (m1 m2)
  (cond ((or (=number m1 0) (=number m2 0)) 0)
 ((=number m1 1) m2)
 ((=number m2 1) m1)
 ((and (numberp m1) (numberp m2)) (* m1 m2))
 (t (list '* m1 m2))))

;;; Exponent definitions
(defun exponentiationp (x)
  (and (consp x) (equal (car x) '^)))

(defun base (exp)
  (cadr exp))

(defun exponent (exp)
  (caddr exp))

(defun make-exponentiation (base exp)
  (cond ((=number exp 0) 1)
 ((=number exp 1) base)
 ((and (numberp base) (numberp exp)) (expt base exp))
 (t (list '^ base exp))))

(defun deriv (exp var)
  (cond ((numberp exp) 0)
 ((variablep exp)
  (if (same-variable-p exp var) 1 0))
 ((sump exp)
  (make-sum (deriv (addend exp) var)
     (deriv (augend exp) var)))
 ((productp exp)
  (make-sum
   (make-product (multiplier exp)
   (deriv (multiplicand exp) var))
   (make-product (deriv (multiplier exp) var)
   (multiplicand exp))))
 ((exponentiationp exp)
  (make-product
   (exponent exp)
   (make-product
    (make-exponentiation (base exp) (- (exponent exp) 1))
    (deriv (base exp) var))))
 (t "unknown expression type")))

;;; 2.57
(defun addend (s)
  (cadr s))

(defun augend (s)
  (let ((augend (cddr s)))
    (if (= 1 (length augend))
 (car augend)
 (make-sum (car augend) (cdr augend)))))

(defun multiplier (p)
  (cadr p))

(defun multiplicand (p)
  (let ((multiplicand (cddr p)))
    (if (= 1 (length multiplicand))
 (car multiplicand)
 (make-product (car multiplicand)
        (cdr multiplicand)))))

(defun make-sum (a1 a2)
  (cond ((=number a1 0) a2)
 ((=number a2 0) a1)
 ((and (numberp a1) (numberp a2)) (+ a1 a2))
 ((sump a2) (list '+ a1 (addend a2) (augend a2)))
 ((productp a2) (list '+ a1 (make-product
        (multiplier a2)
        (multiplicand a2))))
 ((and (consp a2) (> (length a2) 1))
  (list '+ a1 (make-sum (car a2) (cdr a2))))
 ((consp a2) (list '+ a1 (car a2)))
 (t (list '+ a1 a2))))

(defun make-product (m1 m2)
  (cond ((or (=number m1 0) (=number m2 0)) 0)
 ((=number m1 1) m2)
 ((=number m2 1) m1)
 ((and (numberp m1) (numberp m2)) (* m1 m2))
 ((productp m2) (list '* m1 (multiplier m2) (multiplicand m2)))
 ((sump m2) (list '* m1 (make-sum (addend m2) (augend m2))))
 ((and (consp m2) (> (length m2) 1))
  (list '* m1 (make-product (car m2) (cdr m2))))
 ((consp m2) (list '* m1 (car m2)))
 (t (list '* m1 m2))))

;;; 2.58
(defun sump (x)
  (and (consp x) (equal (cadr x) '+)))

(defun addend (s)
  (car s))

(defun augend (s)
  (caddr s))

(defun productp (x)
  (and (consp x) (equal (cadr x) '*)))

(defun multiplier (p)
  (car p))

(defun multiplicand (p)
  (caddr p))

(defun make-sum (a1 a2)
  (cond ((=number a1 0) a2)
 ((=number a2 0) a1)
 ((and (numberp a1) (numberp a2)) (+ a1 a2))
 (t (list a1 '+  a2))))

(defun make-product (m1 m2)
  (cond ((or (=number m1 0) (=number m2 0)) 0)
 ((=number m1 1) m2)
 ((=number m2 1) m1)
 ((and (numberp m1) (numberp m2)) (* m1 m2))
 (t (list m1 '* m2))))

;;; lookup b

;;; 2.59
(defun element-of-set-p (x set)
  (cond ((null set) nil)
 ((equal x (car set)) t)
 (t (element-of-set-p x (cdr set)))))

(defun adjoin-set (x set)
  (if (element-of-set-p x set)
      set
      (cons x set)))

(defun intersection-set (set1 set2)
  (cond ((or (null set1) (null set2)) nil)
 ((element-of-set-p (car set1) set2)
  (cons (car set1)
        (intersection-set (cdr set1) set2)))
 (t (intersection-set (cdr set1) set2))))

(defun union-set (set1 set2)
  (cond ((null set1) set2)
 ((null set2) set1)
 ((element-of-set-p (car set1) set2)
  (union-set (cdr set1) set2))
 (t (cons (car set1)
   (union-set (cdr set1) set2)))))

;;; 2.60
(defun adjoin-set-2 (x set)
  (cons x set))

(defun union-set-2 (set1 set2)
  (cond ((null set1) set2)
 ((null set2) set1)
 (t (cons (car set1)
   (union-set-2 (cdr set1) set2)))))

;;; 2.61
(defun adjoin-set-2 (x set)
  (let ((first (car set)))
    (cond ((null set) (list x))
   ((= x first) set)
   ((> x first) (cons first (adjoin-set-2 x (cdr set))))
   (t (cons x set)))))

;;; 2.62
(defun union-set-2 (set1 set2)
  (cond ((null set1) set2)
 ((null set2) set1)
 ((= (car set1) (car set2))
  (cons (car set1) (union-set-2 (cdr set1) (cdr set2))))
 ((> (car set1) (car set2))
  (cons (car set2) (union-set-2 set1 (cdr set2))))
 (t (cons (car set1) (union-set-2 (cdr set1) set2)))))

;;; 2.66
(defun lookup (given-key set-of-records)
  (let ((current-record (car set-of-records))
 (key (key current-record)))
    (cond ((null set-of-records) nil)
   ((= given-key key) current-record)
   ((> given-key key)
    (lookup given-key (right-tree set-of-records)))
   (t (lookup given-key (left-tree set-of-records))))))

;;; Huffman tree representation
(defun make-leaf (symbol weight)
  (list 'leaf symbol weight))

(defun leaf? (object)
  (equalp (car object) 'leaf))

(defun symbol-leaf (x) (cadr x))

(defun weight-leaf (x) (caddr x))

(defun make-code-tree (left right)
  (list left
 right
 (append (symbols left) (symbols right))
 (+ (weight left) (weight right))))

(defun left-branch (tree) (car tree))

(defun right-branch (tree) (cadr tree))

(defun symbols (tree)
  (if (leaf? tree)
      (list (symbol-leaf tree))
      (caddr tree)))

(defun weight (tree)
  (if (leaf? tree)
      (weight-leaf tree)
      (cadddr tree)))

(defun decode (bits tree)
  (defun decode-1 (bits current-branch)
    (if (null bits)
 nil
 (let ((next-branch
        (choose-branch (car bits) current-branch)))
   (if (leaf? next-branch)
       (cons (symbol-leaf next-branch)
      (decode-1 (cdr bits) tree))
       (decode-1 (cdr bits) next-branch)))))
  (decode-1 bits tree))

(defun choose-branch (bit branch)
  (cond ((= bit 0) (left-branch branch))
 ((= bit 1) (right-branch branch))
 (t (error "bad bit"))))

(defun adjoin-set (x set)
  (cond ((null set) (list x))
 ((< (weight x) (weight (car set))) (cons x set))
 (t (cons (car set) (adjoin-set x (cdr set))))))

(defun make-leaf-set (pairs)
  (if (null pairs)
      nil
      (let ((pair (car pairs)))
 (adjoin-set (make-leaf (car pair) (cadr pair))
      (make-leaf-set (cdr pairs))))))

;;; 2.67
(defparameter *sample-tree*
  (make-code-tree (make-leaf 'a 4)
    (make-code-tree
     (make-leaf 'b 2)
     (make-code-tree (make-leaf 'd 1)
       (make-leaf 'c 1)))))

(defparameter *sample-message* '(0 1 1 0 0 1 0 1 0 1 1 1 0))

(decode *sample-message* *sample-tree*) ; => (A D A B B C A)

;;; 2.68
(defun encode (message tree)
  (if (null message)
      nil
      (append (encode-symbol (car message) tree)
       (encode (cdr message) tree))))

(defun encode-symbol (symbol tree)
  (cond ((or (null tree) (leaf? tree)) nil)
 ((member symbol (symbols (left-branch tree)))
  (cons 0 (encode-symbol symbol (left-branch tree))))
 ((member symbol (symbols (right-branch tree)))
  (cons 1 (encode-symbol symbol (right-branch tree))))
 (t (error "Symbol not in tree."))))

;;; 2.69
(defun generate-huffman-tree (pairs)
  (successive-merge (make-leaf-set pairs)))

(defun successive-merge (leaf-set &optional sub-tree)
  (cond ((null (cdr leaf-set))
  (make-code-tree (car leaf-set) sub-tree))
 ((null sub-tree)
  (successive-merge (cdr leaf-set) (car leaf-set)))
 (t (successive-merge (cdr leaf-set)
        (make-code-tree (car leaf-set)
          sub-tree)))))

;;; 2.70
(defparameter *lyric-huff-tree*
  (generate-huffman-tree '((a 2) (boom 1) (get 2) (job 2)
      (na 16) (sha 3) (yip 9) (wah 1))))

(defparameter *song* '(get a job sha na na na na na na na na
         get a job sha na na na na na na na
         wah yip yip yip yip yip yip yip yip
         yip Sha boom))

(length (encode *song* *lyric-huff-tree*)) ; => 86

;; 2.71
;; Most frequent = 1, least = N - 1

SICP Exercise 2.17

(defun last-pair (list)
  (if (null (cdr list))
      list
      (last-pair (cdr list))))

SICP Exercise 2.18

(defun rev (list)
  (if (null (cdr list))
      list
      (cons (car (last list))
        (rev (butlast list)))))

SICP Exercise 2.19

(defparameter *us-coins* (list 50 25 10 5 1))
(defparameter *uk-coins* (list 100 50 20 10 5 1 0.5))

(defun count-change (amount coin-values)
  (cc amount coin-values))

(defun cc (amount coin-values)
  (cond ((= amount 0) 1)
     ((or (< amount 0) (no-more-p coin-values)) 0)
     (t (+ (cc amount
           (except-first-denomination coin-values))
             (cc (- amount
               (first-denomination coin-values))
           coin-values)))))

(defun no-more-p (coin-values)
  (null coin-values))

(defun except-first-denomination (coin-values)
  (cdr coin-values))

(defun first-denomination (coin-values)
  (car coin-values))

SICP Exercise 2.20

(defun same-parity (integer &rest integers)
  (cond ((null integers) integer)
    ((evenp integer) (append (list integer)
                                 (remove-if-not #'evenp integers)))
    (t (append (list integer) (remove-if-not #'oddp integers)))))

SICP Exercise 2.21

defun square-list-1 (items)
  (if (null items)
      nil
      (cons (expt (car items) 2)
     (square-list-1 (cdr items)))))

(defun square-list-2 (items)
  (mapcar (lambda (x) (* x x))
   items))

SICP Exercise 2.23

(defun for-each (proc items)
  (when (consp items)
    (funcall proc (car items))
    (for-each proc (cdr items))))

SICP Exercise 2.27

(defparameter x (list (list 1 2) (list 3 4)))

(defun last-element (list)
  "Returns the last element of LIST."
  (car (last list)))

(defun deep-rev (list)
  (cond ((and (= 1 (length list)) (not (listp (car list)))) list)
 ((= 1 (length list)) (list (deep-rev (car list))))
 ((listp (last-element list))
  (cons (deep-rev (last-element list))
        (deep-rev (butlast list))))
 (t (cons (last-element list)
   (deep-rev (butlast list))))))

SICP Exercise 2.28

(defun fringe (list)
  (when list
    (if (atom list)
 (list list)
 (append (fringe (car list))
  (fringe (cdr list))))))

SICP Exercise 2.29

;; a.
(defun make-mobile (left right)
  (list left right))

(defun make-branch (length structure)
  (list length structure))

(defun left-branch (mobile)
  (first mobile))

(defun right-branch (mobile)
  (second mobile))

(defun branch-length (branch)
  (first branch))

(defun branch-structure (branch)
  (second branch))

;; b.
(defun mobilep (structure)
  (listp structure))

(defun total-weight (mobile)
  (+ (total-branch-weight (left-branch mobile))
     (total-branch-weight (right-branch mobile))))

(defun total-branch-weight (branch)
  (let ((branch-structure (branch-structure branch)))
    (if (mobilep branch-structure)
 (total-weight branch-structure)
 branch-structure)))

;;; c.
(defun torque (branch)
  (* (branch-length branch)
     (total-branch-weight branch)))

(defun balanced-mobile-p (mobile)
  (let ((left (left-branch mobile))
 (right (right-branch mobile)))
    (cond
      ;; Return false if the left and right torques are unequal.
      ((/= (torque left) (torque right)) nil)
      ;; The mobile is balanced at this level.  Return true if there
      ;; are no more submobiles.
      ((and (not (mobilep left))
     (not (mobilep right)))
       t)
      ;; Submobiles exist.  Check their balance.
      (t (and (if (mobilep (branch-structure left))
    (balanced-mobile-p (branch-structure left))
    t)
       (if (mobilep (branch-structure right))
    (balanced-mobile-p (branch-structure right))
    t))))))

;;; d. For section a, we need to replace the first and second
;;; functions with car and cdr respectively.  The remaining sections
;;; can be left intact.

SICP Exercise 2.30

(defun square-tree-1 (tree)
  (cond ((null tree) nil)
 ((not (listp tree)) (* tree tree))
 (t (cons (square-tree-1 (car tree))
   (square-tree-1 (cdr tree))))))

(defun square-tree-2 (tree)
  (mapcar (lambda (sub-tree)
     (if (listp sub-tree)
  (square-tree-2 sub-tree)
  (* sub-tree sub-tree)))
   tree))

SICP Exercise 2.31

(defun tree-map (proc tree)
  (mapcar (lambda (sub-tree)
     (if (listp sub-tree)
  (tree-map proc sub-tree)
  (funcall proc sub-tree)))
   tree))

(defun square (x)
  (* x x))

(defun square-tree-3 (tree)
  (tree-map #'square tree))

SICP Exercise 2.32

(defun subsets (s)
  (if (null s)
      (list nil)
      (let ((rest (subsets (cdr s))))
 (append rest (mapcar (lambda (x)
          (cons (car s) x))
        rest)))))

SICP Exercise 2.33

(defun accumulate (op initial sequence)
  (if (null sequence)
      initial
      (funcall op (car sequence)
        (accumulate op initial (cdr sequence)))))

(defun my-map (p sequence)
  (accumulate (lambda (x y)
  (cons (funcall p x) y))
       nil
       sequence))

(defun my-append (seq1 seq2)
  (accumulate #'cons seq2 seq1))

(defun my-length (sequence)
  (accumulate (lambda (x y)
  ;; Avoid style warnings by telling the compiler to
  ;; ignore X.
  (declare (ignore x))       
  (+ 1 y))
       0 sequence))

SICP Exercise 2.34

(defun horner-eval (x coefficient-sequence)
  (accumulate (lambda (this-coeff higher-terms)
  (+ this-coeff
     (* x higher-terms)))
       0
       coefficient-sequence))

SICP Exercise 2.35

(defun count-leaves (tree)
  (accumulate #'+
       0
       (mapcar (lambda (sub-tree)
   (if (listp sub-tree)
       (count-leaves sub-tree)
       1))
        tree)))

SICP Exercise 2.36

(defun accumulate-n (op init seqs)
  (if (null (car seqs))
      nil
      (cons (accumulate op init (mapcar #'car seqs))
     (accumulate-n op init (mapcar #'cdr seqs)))))

SICP Exercise 2.37

(defun dot-product (v w)
  (accumulate #'+ 0 (mapcar #'* v w)))

(defun matrix-*-vector (m v)
  (mapcar (lambda (row)
     (dot-product row v))
   m))

(defun transpose (mat)
  (accumulate-n #'cons nil mat))

(defun matrix-*-matrix (m n)
  (let ((cols (transpose n)))
    (mapcar (lambda (row)
       (matrix-*-vector cols row))
     m)))

SICP Exercise 2.39

(defun fold-left (op initial sequence)
  (labels ((iter (result rest)
      (if (null rest)
   result
   (iter (funcall op result (car rest))
         (cdr rest)))))
    (iter initial sequence)))

(defun fold-right (op initial sequence)
  (accumulate op initial sequence))

(defun reverse-1 (sequence)
  (fold-right (lambda (x y)
  (append y (list x)))
       nil
       sequence))

(defun reverse-2 (sequence)
  (fold-left (lambda (x y)
        (append (list y) x))
      nil
      sequence))

SICP Exercise 2.40

(defun flatmap (proc seq)
  (accumulate #'append nil (mapcar proc seq)))

(defun enumerate-interval (x y)
  "Returns the list from X to Y"
  (loop for i from x to y collect i))

(defun unique-pairs (n)
  (flatmap 
   (lambda (i)
     (mapcar (lambda (j)
        (list i j))
      (enumerate-interval 1 (- i 1))))
   (enumerate-interval 1 n)))

;;; Definitions for prime?

(defun dividesp (a b) (zerop (mod b a)))

(defun find-divisor (n test-divisor)
  (cond ((> (square test-divisor) n) n)
 ((dividesp test-divisor n) test-divisor)
 (t (find-divisor n (+ test-divisor 1)))))

(defun smallest-divisor (n)
  (find-divisor n 2))

(defun prime? (n) (= n (smallest-divisor n)))

(defun prime-sum? (pair)
  (prime? (+ (car pair) (cadr pair))))

(defun make-pair-sum (pair)
  (list (car pair) (cadr pair) (+ (car pair) (cadr pair))))

(defun prime-sum-pairs (n)
  (mapcar #'make-pair-sum
   (remove-if-not #'prime-sum?
    (unique-pairs n))))

SICP Exercise 2.41

(defun triples (n s)
  (remove-if-not (lambda (list) (= s (reduce #'+ list)))
   (flatmap
    (lambda (i)
      (flatmap
       (lambda (j)
         (mapcar (lambda (k) (list i j k))
          (enumerate-interval 1 (- j 1))))
       (enumerate-interval 1 (- i 1))))
    (enumerate-interval 1 n))))

SICP Exercise 2.42

(defparameter empty-board nil)

(defun board-position (row col)
  "Represents a chess piece's position on the board."
  (list row col))

(defun adjoin-position (row col set-of-positions)
  "Adjoins a new row-column position to a set of positions."
  (append set-of-positions (list (board-position row col))))

(defun get-column (position)
  "Returns the column of the board-position POSITION."
  (cadr position))

(defun get-row (position)
  "Returns the row of the board position POSITION."
  (car position))

(defun get-board-position (col positions)
  "Returns the board position in column COL."
  (car (remove-if-not (lambda (position)
   (= col (get-column position)))
        positions)))

(defun in-same-row? (col positions)
  "Returns true if the queen in column COL shares the same row with
another queen in the position set POSITIONS."
  (let ((row (get-row (get-board-position col positions))))
    (some (lambda (position)
     (and (/= col (get-column position))
   (= row (get-row position))))
   positions)))

(defun in-diagonal? (col positions)
  "Returns true if the queen in column COL resides in the diagonal 
of another queen in the position set POSITIONS."
  (let ((row (get-row (get-board-position col positions))))
    (some (lambda (position)
     (when (/= col (get-column position))
       (= 1 (abs (/ (- row (get-row position))
      (- col (get-column position)))))))
   positions)))

(defun safe? (new-queen old-queens)
  "Returns true if the NEW-QUEEN does not reside in the same row
or diagonal of any of the OLD-QUEENS."
  (cond
    ;; Return true when no OLD-QUEENS exist.
    ((null old-queens) t)
    ;; Test if NEW-QUEEN resides on the same row.
    ((in-same-row? new-queen old-queens) nil)
    ;; Test if NEW-QUEEN resides on the same diagonal.
    ((in-diagonal? new-queen old-queens) nil)
    ;; Return true if all the tests pass.
    (t t)))

(defun queens (board-size)
  (labels ((queen-cols (k)
      (if (= k 0)
   (list empty-board)
   (remove-if-not
    (lambda (positions) (safe? k positions))
    (flatmap
     (lambda (rest-of-queens)
       (mapcar (lambda (new-row)
          (adjoin-position new-row
      k
      rest-of-queens))
        (enumerate-interval 1 board-size)))
     (queen-cols (- k 1)))))))
    (queen-cols board-size)))

SICP Exercise 2.44

(defun up-split (painter n)
  (if (= n 0)
      painter
      (let ((smaller (up-split painter (- n 1))))
 (below painter (beside smaller smaller)))))

SICP Exercise 2.45

(defun split (proc1 proc2)
  (labels ((do-split (painter n)
      (if (= n 0)
   painter
   (let ((smaller (do-split painter (- n 1))))
     (funcall proc1 painter
       (funcall proc2 smaller smaller))))))
    (lambda (painter n)
      (do-split painter n))))

SICP Exercise 2.46

(defun make-vect (x y)
  (cons x y))

(defun xcor-vect (v)
  (car v))

(defun ycor-vect (v)
  (cdr v))

(defun add-vect (v1 v2)
  (make-vect (+ (xcor-vect v1) (xcor-vect v2))
      (+ (ycor-vect v1) (ycor-vect v2))))

(defun sub-vect (v1 v2)
  (make-vect (- (xcor-vect v1) (xcor-vect v2))
      (- (ycor-vect v2) (ycor-vect v2))))

(defun scale-vect (s v)
  (make-vect (* s (xcor-vect v))
      (* s (ycor-vect v))))

Using names.txt (right click and 'Save Link/Target As...'), a 46K text file containing over five-thousand first names, begin by sorting it into alphabetical order. Then working out the alphabetical value for each name, multiply this value by its alphabetical position in the list to obtain a name score.

For example, when the list is sorted into alphabetical order, COLIN, which is worth 3 + 15 + 12 + 9 + 14 = 53, is the 938th name in the list. So, COLIN would obtain a score of 938 × 53 = 49714.

What is the total of all the name scores in the file?

This solution's final function follows the problem's definition precisely: sort the file, compute the alphabetical values for each name, then sum the values.

;;; Use the split-sequence library for splitting the names.txt file.
(require 'split-sequence)

(defparameter *ansi-base-code* 64
  "Subtract this value from a character's ansi integer value to get
the characters position in the alphabet.")

(defparameter *names-file* "programming/lisp/euler/names.txt"
  "The locations of names.txt on my computer.")

(defun char-position (char)
  "Returns CHAR's position in the alphabet.
Example: (char #\A) => 1
         (char #\C) => 3"
  (- (char-int char)
     *ansi-base-code*))

(defun alphabetical-value (string)
  "Returns the alphabetical value of STRING. For example, COLIN is worth
3 + 15 + 12 + 9 + 14 = 53"
  (reduce #'+ (map 'list (lambda (char)
                   (char-position char))
               string)))

(defun name-score (string position)
  "Returns the name score of STRING."
  (* (alphabetical-value string) position))

(defun name-scores (list)
  "Returns a list of the name scores of LIST. Removes any quotes from
the items in LIST before calculating the score."
  (let ((alphabetical-position 0))
    (mapcar (lambda (name)
                     (incf alphabetical-position)
                     (name-score (remove #\" name) alphabetical-position))
                 list)))

(defun parse-file (file delimiter)
  "Returns a list of items from FILE parsed by DELIMITER."
  (with-open-file (stream file)
    (split-sequence:split-sequence delimiter (read-line stream))))

(defun sort-list (list)
  "Sorts LIST by alphabetical string value."
  (sort list #'string<))

(defun sum-list (list)
  "Returns the sum of all the elements in LIST."
  (reduce #'+ list))

(defun euler-22 ()
  (sum-list (name-scores (sort-list (parse-file *names-file* #\,)))))

SICP Exercise 2.2
Consider the problem of representing line segments in a plane. Each segment is represented as a pair of points: a starting point and an ending point. Define a constructor make-segment and selectors start-segment and end-segment that define the representation of segments in terms of points. Furthermore, a point can be represented as a pair of numbers: the x coordinate and the y coordinate. Accordingly, specify a constructor make- point and selectors x-point and y-point that define this representation. Finally, using your selectors and constructors, define a procedure midpoint-segment that takes a line segment as argument and returns its midpoint (the point whose coordinates are the average of the coordinates of the endpoints). To try your procedures, you'll need a way to print points: (define
(print-point p)
(newline)
(display "(")
(display (x-point p))
(display ",")
(display (y-point p))
(display ")"))

;;; Utility functions
(defun average (x y)
  (/ (+ x y)
     2))

;;; Point and segment functions
(defun make-point (x y)
  (cons x y))

(defun x-point (point)
  (car point))

(defun y-point (point)
  (cdr point))

(defun make-segment (start end)
  (cons start end))

(defun start-segment (segment)
  (car segment))

(defun end-segment (segment)
  (cdr segment))

(defun midpoint-segment (segment)
  (make-point (average (x-point (start-segment segment))
                        (x-point (end-segment segment)))
       (average (y-point (start-segment segment))
               (y-point (end-segment segment)))))

(defun print-point (p)
  (format t "x=~D y=~D~%"
   (x-point p)
   (y-point p)))

SICP Exercise 2.3
Implement a representation for rectangles in a plane. (Hint: You may want to make use of exercise 2.2.) In terms of your constructors and selectors, create procedures that compute the perimeter and the area of a given rectangle. Now implement a different representation for rectangles. Can you design your system with suitable abstraction barriers, so that the same perimeter and area procedures will work using either representation?

(defun make-rec (lower-left-pt upper-right-pt)
  (cons lower-left-pt upper-right-pt))

(defun rec-upper-right (rec)
  (cdr rec))

(defun rec-lower-left (rec)
  (car rec))

(defun rec-upper-left (rec)
  (make-point (x-point (rec-lower-left rec))
               (y-point (rec-upper-right rec))))

(defun rec-lower-right (rec)
  (make-point (x-point (rec-upper-right rec))
               (y-point (rec-lower-left rec))))
 
(defun rec-len (rec)
  (- (y-point (rec-upper-left rec))
     (y-point (rec-lower-left rec))))

(defun rec-width (rec)
  (- (x-point (rec-lower-right rec))
     (x-point (rec-lower-left rec))))

(defun area-rec (rec)
  (* (rec-len rec)
      (rec-width rec)))

(defun perimeter-rec (rec)
  (* 2
     (+ (rec-len rec)
   (rec-width rec))))

;;; Alternative representation of rectangles

(defun alt-make-rec (bottom-seg left-seg)
  (cons bottom-seg left-seg))

(defun alt-upper-left (rec)
  (end-segment (cdr rec)))

(defun alt-lower-left (rec)
  (start-segment (car rec)))

(defun alt-lower-right (rec)
  (end-segment (cdr rec)))

(defun alt-upper-right (rec)
  (make-point (x-point (alt-lower-right rec))
               (y-point (alt-upper-left rec))))

SICP Exercise 2.4
Here is an alternative procedural representation of pairs. For this representation, verify that (car (cons x y)) yields x for any objects x and y.

(define (cons x y)
(lambda (m) (m x y)))
(define (car z)
(z (lambda (p q) p)))

What is the corresponding definition of cdr? (Hint: To verify that this works, make use of the substitution model of section 1.1.5.)

;;; Redefine Scheme functions in CL
(defun alt-cons (x y)
  (lambda (m) (funcall m x y)))

(defun alt-car (z)
  (funcall z (lambda (p q) p)))

(defun alt-cdr (z)
  (funcall z (lambda (p q) q)))

SICPSICP Exercise 2.5
Show that we can represent pairs of nonnegative integers using only numbers and arithmetic operations if we represent the pair a and b as the integer that is the product 2^a*3^b. Give the corresponding definitions of the procedures cons, car, and cdr.

(defun alt2-cons (a b)
  (* (expt 2 a) (expt 3 b)))

(defun alt2-car (z)
  (do ((i 0 (1+ i))
         (n z (/ n 2)))
      ((> (mod n 2) 0) i)))

(defun alt2-cdr (z)
  (do ((i 0 (1+ i))
         (n z (/ n 3)))
      ((> (mod n 3) 0) i)))

SICP Exercise 2.6
In case representing pairs as procedures wasn't mind-boggling enough, consider that, in a language that can manipulate procedures, we can get by without numbers (at least insofar as nonnegative integers are concerned) by implementing 0 and the operation of adding 1 as

(define zero (lambda (f) (lambda (x) x)))

(define (add-1 n)
(lambda (f) (lambda (x) (f ((n f) x)))))

This representation is known as Church numerals, after its inventor, Alonzo Church, the logician who invented the calculus. Define one and two directly (not in terms of zero and add-1). (Hint: Use substitution to evaluate (add-1 zero)). Give a direct definition of the addition procedure + (not in terms of repeated application of add-1).

;;; Redefine Scheme functions in CL
(defun zero ()
  (lambda (f)
    (lambda (x) x)))

(defun add-1 (n)
  (lambda (f)
    (lambda (x)
      (funcall f (funcall (funcall n f) x)))))

;;; Definitions of one and two
(defun one ()
  (lambda (f)
    (lambda (x)
      (funcall f x))))

(defun two ()
  (lambda (f)
    (lambda (x)
      (funcall f (funcall f x)))))

;;; We can test our definitions of one and two with the following code:
;;; (funcall (funcall (one) #'1+) 0) => 1
;;; (funcall (funcall (two) #'1+) 0) => 2

;;; Notice the pattern for the definitions of one and two: the natural
;;; number N converts to its corresponding Church numeral by
;;; compositing the function f N times. We can abstract this by
;;; using a macro to define our Church numerals

(defun compose (times)
  (if (= times 1)
      '(funcall f x)
      `(funcall f ,(compose (1- times)))))

(defmacro def-church-numeral (name N)
  `(defun ,name ()
     (lambda (f)
       (lambda (x)
  ,(compose N)))))

;;; Now we can define new Church numerals as follows:
;;; (def-church-numeral three 3)
;;; (funcall (funcall (three) #'1+) 0) => 3

;;; To define an add function for Church numerals, implement the
;;; identity f(m + n)(x) = fm(fn(x)).  The code can look rather
;;; ugly in Common Lisp because the need for funcall, but to 
;;; understand it remember how we call the church numeral 
;;; functions, and see that the code calls the first church
;;; numeral and passes it to the second.

(defun add (m n)
  (lambda (f)
    (lambda (x)
      (funcall (funcall (funcall m) f)
           (funcall (funcall (funcall n) f) x)))))

;;; We can test the add function as follows:
;;;(funcall (funcall (add #'one #'three) #'1+) 0) => 4

SICP Exercise 2.7
Alyssa's program is incomplete because she has not specified the implementation of the interval abstraction. Here is a definition of the interval constructor:

(define (make-interval a b) (cons a b))

Define selectors upper-bound and lower-bound to complete the implementation.

;;; Redefine the Scheme functions in CL

(defun add-interval (x y)
  (make-interval (+ (lower-bound x) (lower-bound y))
            (+ (upper-bound x) (upper-bound y))))

(defun mul-interval (x y)
  (let ((p1 (* (lower-bound x) (lower-bound y)))
   (p2 (* (lower-bound x) (upper-bound y)))
   (p3 (* (upper-bound x) (lower-bound y)))
   (p4 (* (upper-bound x) (upper-bound y))))
    (make-interval (min p1 p2 p3 p4)
              (max p1 p2 p3 p4))))

(defun dev-interval (x y)
  (mul-interval x
        (make-interval (/ 1.0 (upper-bound y))
                         (/ 1.0 (lower-bound y)))))

(defun make-interval (a b)
  (cons a b))

;;; End of Scheme definitions

(defun upper-bound (interval)
  (max (car interval) (cdr interval)))

(defun lower-bound (interval)
  (min (car interval) (cdr interval)))

SICP Exercise 2.8
Using reasoning analogous to Alyssa's, describe how the difference of two intervals may be computed. Define a corresponding subtraction procedure, called sub-interval.

(defun sub-interval (x y)
  (add-interval x
        (make-interval (- (upper-bound y))
                         (- (lower-bound y)))))

SICP Exercise 2.9
The width of an interval is half of the difference between its upper and lower bounds. The width is a measure of the uncertainty of the number specified by the interval. For some arithmetic operations the width of the result of combining two intervals is a function only of the widths of the argument intervals, whereas for others the width of the combination is not a function of the widths of the argument intervals. Show that the width of the sum (or difference) of two intervals is a function only of the widths of the intervals being added (or subtracted). Give examples to show that this is not true for multiplication or division.

(defun interval-width (interval)
  (abs (/ (- (upper-bound interval) (lower-bound interval))
       2.0)))

SICP Exercise 2.11
In passing, Ben also cryptically comments: ‘‘By testing the signs of the endpoints of the intervals, it is possible to break mul-interval into nine cases, only one of which requires more than two multiplications.’’ Rewrite this procedure using Ben’s suggestion.

(defun sym-signum (n)
  "Calls signum and returns + or - instead of 1, -1, 0.  0 is
considered postive for the sake of this exercise"
  (let ((sign (signum n)))
    (cond ((eq sign 1) '+)
       ((eq sign -1) '-)
       ((eq sign 0) '+))))

(defun list-signs (lst)
  "Given a list of numbers, returns a list of the number's signs"
  (mapcar #'sym-signum lst))

(defmacro make-interval-if (signs &body body)
  "Cleans up the definition of new-mul-interval by removing lots
of repeated code"
  `(cond ,@(mapcar #'(lambda (statement)
         (let ((test-signs (first statement))
         (lower-bound (second statement))
         (upper-bound (third statement)))
    `((equal ,signs ',test-signs)
       (make-interval (* ,(first lower-bound)
                     ,(second lower-bound))
                 (* ,(first upper-bound)
                     ,(second upper-bound))))))
     body)))



(defun new-mul-interval (x y)
  (let* ((ux (upper-bound x))
     (lx (lower-bound x))
     (uy (upper-bound y))
     (ly (lower-bound y))
     (signs (list-signs (list lx ux ly uy)))
            ;; max and min are needed for the special case
     (max (max (* lx ly) (* lx uy) (* ux uy) (* ux ly)))
     (min (min (* lx ly) (* lx uy) (* ux uy) (* ux ly))))
    (make-interval-if signs
      ((+ + + +) (lx ly) (ux uy))
      ((+ + - +) (ux ly) (ux uy))
      ((+ + - -) (ux ly) (lx uy))
      ((- + + +) (uy lx) (uy ux))
      ((- + - -) (ux ly) (lx ly))
      ((- - + +) (lx uy) (ly ux))
      ((- - - +) (lx uy) (ly lx))
      ((- - - -) (ux uy) (ly lx))
      ;; special case:
      ((- + - +) (min 1) (max 1)))))

SICP Exercise 2.12
Define a constructor make-center-percent that takes a center and a percentage tolerance and produces the desired interval. You must also define a selector percent that produces the percentage tolerance for a given interval. The center selector is the same as the one shown above.

(defun make-center-percent (center percent)
  (let ((percent (/ percent 100.0)))
    (cons (- center (* center percent))
      (+ center (* center percent)))))

(defun center (interval)
  (/ (+ (lower-bound interval) (upper-bound interval)) 2))

(defun percent (interval)
  (let ((center (center interval))
   (lb (lower-bound interval)))
    (* (/ (- center lb)
   center)
       100)))

The sequence of triangle numbers is generated by adding the natural numbers. So the 7th triangle number would be
1 + 2 + 3 + 4 + 5 + 6 + 7 = 28.
The first ten terms would be:
1, 3, 6, 10, 15, 21, 28, 36, 45, 55, ...

Let us list the factors of the first seven triangle numbers:

1: 1
3: 1,3
6: 1,2,3,6
10: 1,2,5,10
15: 1,3,5,15
21: 1,3,7,21
28: 1,2,4,7,14,28

We can see that 28 is the first triangle number to have over five divisors.

What is the value of the first triangle number to have over five hundred divisors?

(defun num-of-divisors (num)
  "Returns the number of divisors of num for num > 1"
  (let ((square-root (sqrt num))
          (result 0))
    (do ((x 1 (1+ x)))
           ((> x square-root) result)
      (when (zerop (mod num x))
             (setf result (+ 2 result))))))

(defun euler-12 (&optional (tri-num 1) (tri-val 1))
    (if (> (num-of-divisors tri-val) 500)
         tri-val
         (euler-12 (1+ tri-num) (+ 1 tri-num tri-val))))

If you have a pre 1.0.0 version of Hunchentoot installed on your system, you'll be happy to know that upgrading is fairly easy. But be warned! Hunchentoot 1.0 is incompatible with code written for older versions!

Using asdf-upgrade is the easiest way to upgrade. First launch SBCL with root priveliges:

sudo sbcl

If you do not have asdf-upgrade, you'll need to install it:

(require 'asdf-install)
(asdf-install:install 'asdf-upgrade)

Choose a system wide install. Again, I usally skip gpg checks, but if you're inclined to check them this is a great site: http://www.pps.jussieu.fr/~jch/software/pgp-validating.html

Now we can use asdf-upgrade.

(require 'asdf-upgrade)

To see a list of out-dated packages run the report function:

(asdf-upgrade:report)

To upgrade Hunchentoot, as well as your other packages, run the upgrade command:

(asdf-upgrade:upgrade)

Now we can run Hunchentoot 1.0:

(require 'hunchentoot)
(hunchentoot:start (make-instance 'hunchentoot:acceptor :port 4242))

Point your browser to http://127.0.0.1:4242 and you should see the Hunchentoot default page.

See my previous post for further configuration details of Hunchentoot. Some major differences between the current version and older versions include discontinued support for mod_lisp and a different api to start and stop the server.

Edit: A couple days ago the developers released Hunchentoot 1.0.0 . I have updated this article for the current version. Details for pre 1.0 versions reside at the bottom of this article.

This article explains how to install Hunchentoot 1.0.0 behind Apache on Ubuntu 8.10 Intrepid. It assumes you have Apache installed and you have some basic familiarity of Lisp, Slime, Emacs, Apache and Linux. The article uses SBCL as the Common Lisp implementation.

The steps in this article follow closely to the blog Lost in Technopolis's article "Running Common Lisp behind Apache" but are updated for Ubuntu and Hunchentoot 1.0. I recommend reviewing that article also so you become aware of other options while using Hunchentoot and SBCL.

Configure Apache

Hunchentoot is more than capable of being a stand alone webserver, but if your server uses Apache to serve other sites then we need to create a site configuration file so Apache can let Hunchentoot handle requests. Some people also prefer to let Apache handle static pages and Hunchentoot handle the dynamic pages.

First we will configure a new site for our Hunchentoot server. This site will serve all URLs to Hunchentoot except for the /static directory. It looks for Hunchentoot on port 8000. Create a new file in /etc/apache2/sites-available called "htoot" and enter the text below. Be sure to modify it to suit your needs.

<VirtualHost *:80>
  # Admin email, Server Name (domain name) and any aliases
  ServerAdmin YOUR-EMAIL
  ServerName  YOUR-DOMAIN.com
  ServerAlias www.YOUR-DOMAIN.com

  # Index file and Document Root (where the public files are located)
  DirectoryIndex index.html
  DocumentRoot /home/USERNAME/public_html/YOUR-DOMAIN.com/public

  # Custom log file locations
  LogLevel warn
  ErrorLog  /home/USERNAME/public_html/YOUR-DOMAIN.com/log/error.log
  CustomLog /home/USERNAME/public_html/YOUR-DOMAIN.com/log/access.log combined
     
  ProxyRequests Off    
  <Proxy *>
    allow from all
  </Proxy>
  ProxyPass /static !
  ProxyPass / http://127.0.0.1:8000/
  ProxyPassReverse / http://127.0.0.1:8000/

</virtualhost>

Since we are configuring proxy rules on a site-level basis, comment out everything in the global proxy configuration file /etc/apache2/mods-available/proxy.conf. If you run other sites that use mod_proxy be sure they are secure as well!

Enable the site with this command:

sudo a2ensite test

Enable the proxy modules:

sudo a2enmod proxy
sudo a2enmod proxy_http

Restart Apache:

sudo /etc/init.d/apache2 restart

Now if you point your browser to your site, an Apache error message should display since we haven't install Hunchentoot yet. You can test your configuration by creating a "/static" directory in your DocumentRoot folder and pointing your browser there.

Install SBCL

Next up we need to install a lisp implementation on our machine. I created a ~/apps directory on my server and downloaded SBCL. Be sure to change the download file to the version of SBCL you're using. I usually go to the SBCL website to get the correct link for my system.

wget http://prdownloads.sourceforge.net/sbcl/sbcl-1.0.23-x86-linux-binary.tar.bz2

Unpack it:

bzip2 -cd sbcl-1.0.23-x86-linux-binary.tar.bz2 | tar xvf -

And run the installation script:

cd sbcl-1.0.23-x86-linux
sudo sh install.sh 

All done!

Configure Slime

Slime will be used to access the server while it's running. All we have to do is load "swank-loader.lisp" in the lisp image to use it. Download and upack Slime's package:

cd ~/apps
wget http://common-lisp.net/project/slime/snapshots/slime-current.tgz
tar xvf slime-current.tgz
mv slime-2009-02-15 slime

Be sure to modify the above commands for your particular version of Slime. You should now have slime installed in your ~/apps/slime directory. Now run swank-loader.lisp in SBCL so Slime creates its necessary folders:

sbcl
(load "/PATH-TO-YOUR-SLIME-DIR/swank-loader.lisp")
(swank-loader:init)
(quit)

Install Hunchentoot

We will use SBCL's ASDF-INSTALL tool to install Hunchentoot and all of its dependencies. Start SBCL with root privileges:

sudo sbcl

Start the install:

(require 'asdf-install)
(asdf-install:install :hunchentoot)

Choose to do a System-Wide installation. I chose to skip gpg checking because it's a long and tedious process, but if you're inclined to do so this website is a great source:http://www.pps.jussieu.fr/~jch/software/pgp-validating.html

When complete, install cl-who:

(asdf-install:install :cl-who)

To test the installation, in SBCL execute the following:

(hunchentoot:start (make-instance 'hunchentoot:acceptor :port 4242))

Point your browser to your server's 4242 port, such as http://your-domain.com:4242, and you should see the Hunchentoot default page. Quit SBCL before continuing.

Create start-up scripts

For security purposes, we will create a new system user to run Hunchentoot called htoot:

sudo adduser --system --group --no-create-home htoot

The Ubuntu way of launching services is to put a control script in the /etc/init.d directory. Luckily, for those of you who are not experienced at writing these scripts, Ubuntu comes with a handy skeleton file that makes a great starting point.

First go to /etc/init.d and create a new file with nano called htoot:

cd /etc/init.d
sudo nano htoot

Copy and paste the following code, being sure to replace the STARTUPSCRIPT file to where you want to put your Hunchentoot start-up lisp script that we will create next:

#! /bin/sh
### BEGIN INIT INFO
# Provides:          skeleton
# Required-Start:    $remote_fs
# Required-Stop:     $remote_fs
# Default-Start:     2 3 4 5
# Default-Stop:      0 1 6
# Short-Description: Example initscript
# Description:       This file should be used to construct scripts to be
#                    placed in /etc/init.d.
### END INIT INFO

# Author: William Bruschi (william.bruschi@gmail.com)

# Do NOT "set -e"

# PATH should only include /usr/* if it runs after the mountnfs.sh script
PATH=/sbin:/usr/sbin:/bin:/usr/bin:/usr/local/bin
DESC="Hunchentoot"
NAME=sbcl

# STARTUPSCRIPT should point to your hunchentoot lisp startup script
STARTUPSCRIPT=/ENTER-YOUR-PATH_HERE/start-hunchentoot.lisp

DAEMON=/usr/local/bin/$NAME
DAEMON_ARGS="--load $STARTUPSCRIPT"
SCRIPTNAME=/etc/init.d/htoot


# Exit if the package is not installed
[ -x "$DAEMON" ] || exit 0

# Read configuration variable file if it is present
[ -r /etc/default/$NAME ] && . /etc/default/$NAME

# Load the VERBOSE setting and other rcS variables
. /lib/init/vars.sh

# Define LSB log_* functions.
# Depend on lsb-base (>= 3.0-6) to ensure that this file is present.
. /lib/lsb/init-functions

#
# Function that starts the daemon/service
#
do_start()
{
# Return
#   0 if daemon has been started
#   1 if daemon was already running
#   2 if daemon could not be started
start-stop-daemon --start --quiet -u htoot --exec $DAEMON --test  > /dev/null \
     || return 1

sudo -b -u htoot $DAEMON $DAEMON_ARGS &
# Add code here, if necessary, that waits for the process to be ready
# to handle requests from services started subsequently which depend
# on this one.  As a last resort, sleep for some time.
}

#
# Function that stops the daemon/service
#
do_stop()
{
  # Stop the Hunchentoot and Swank servers before killing the daemon
  (telnet localhost 6440 &) > /dev/null
# Wait for servers to shutdown
sleep 10

# Return
#   0 if daemon has been stopped
#   1 if daemon was already stopped
#   2 if daemon could not be stopped
#   other if a failure occurred
start-stop-daemon --stop --quiet --retry=TERM/30/KILL/5 --name $NAME
RETVAL="$?"
[ "$RETVAL" = 2 ] && return 2
# Wait for children to finish too if this is a daemon that forks
# and if the daemon is only ever run from this initscript.
# If the above conditions are not satisfied then add some other code
# that waits for the process to drop all resources that could be
# needed by services started subsequently.  A last resort is to
# sleep for some time.
start-stop-daemon --stop --quiet --oknodo --retry=0/30/KILL/5 --exec $DAEMON
[ "$?" = 2 ] && return 2
return "$RETVAL"
}

#
# Function that sends a SIGHUP to the daemon/service
#
do_reload() {
#
# If the daemon can reload its configuration without
# restarting (for example, when it is sent a SIGHUP),
# then implement that here.
#
start-stop-daemon --stop --signal 1 --quiet --name $NAME
return 0
}

case "$1" in
start)
[ "$VERBOSE" != no ] && log_daemon_msg "Starting $DESC" "$NAME"
do_start
case "$?" in
0|1) [ "$VERBOSE" != no ] && log_end_msg 0 ;;
2) [ "$VERBOSE" != no ] && log_end_msg 1 ;;
esac
;;
stop)
[ "$VERBOSE" != no ] && log_daemon_msg "Stopping $DESC" "$NAME"
do_stop
case "$?" in
0|1) [ "$VERBOSE" != no ] && log_end_msg 0 ;;
2) [ "$VERBOSE" != no ] && log_end_msg 1 ;;
esac
;;
#reload|force-reload)
#
# If do_reload() is not implemented then leave this commented out
# and leave 'force-reload' as an alias for 'restart'.
#
#log_daemon_msg "Reloading $DESC" "$NAME"
#do_reload
#log_end_msg $?
#;;
restart|force-reload)
#
# If the "reload" option is implemented then remove the
# 'force-reload' alias
#
log_daemon_msg "Restarting $DESC" "$NAME"
do_stop
case "$?" in
0|1)
do_start
case "$?" in
0) log_end_msg 0 ;;
1) log_end_msg 1 ;; # Old process is still running
*) log_end_msg 1 ;; # Failed to start
esac
;;
*)
# Failed to stop
log_end_msg 1
;;
esac
;;
*)
#echo "Usage: $SCRIPTNAME {start|stop|restart|reload|force-reload}" >&2
echo "Usage: $SCRIPTNAME {start|stop|restart|force-reload}" >&2
exit 3
;;
esac

:

Save the file and exit nano, then make the file executable:

sudo chmod 755 htoot 

The script above starts Hunchentoot by telling SBCL to load the Hunchentoot start-up script, which we will create next. To stop Hunchentoot, we simply telnet to a specific port that the SBCL instance listens to. With this configuration, the Hunchentoot instance runs under the user 'htoot'.

Next change to the directory where you want to place the Hunchentoot start-up lisp script and create a new file called "start-hunchentoot.lisp". Copy and paste the code below. Be sure to read over this code, changing the path to your swank-loader file and any other options as you see fit.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; start-hunchentoot.lisp
;;;;
;;;; Author:  William Bruschi
;;;; Date:    02-14-2009
;;;;
;;;; Starts Hunchentoot and Swank, then listens for a shutdown
;;;; command on the specified port.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'asdf)
(require 'hunchentoot)
(require 'cl-who)
(require 'sb-bsd-sockets)

(defpackage :webserver
(:use :common-lisp :hunchentoot :cl-who))

(in-package :webserver)

(defparameter *hunchentoot-port* 8000)
(defparameter *shutdown-port* 6440)
(defparameter *swank-loader*
"/PATH-TO-SLIME/slime/swank-loader.lisp")
(defparameter *swank-port* 4006)

;;; Start the hunchentoot server
(defparameter *hunchentoot-server*
(start (make-instance 'acceptor :port *hunchentoot-port*)))
(princ "Hunchentoot server started on port ")
(princ *hunchentoot-port*) (terpri)

;;; Load any sites here



(in-package :webserver)

;;; Start swank
(load *swank-loader*)
(swank-loader:init)
(swank:create-server :port *swank-port* :dont-close t)
(princ "Loaded Swank on port ")
(princ *swank-port*)(terpri)

;;; Wait and listen for shutdown command
(let ((socket (make-instance 'sb-bsd-sockets:inet-socket
    :type :stream :protocol :tcp)))

;; Listen on a local port for a TCP connection
(sb-bsd-sockets:socket-bind socket #(127 0 0 1) *shutdown-port*)
(sb-bsd-sockets:socket-listen socket 1)

;; When it comes, close the sockets and continue
(multiple-value-bind (client-socket addr port)
(sb-bsd-sockets:socket-accept socket)
(sb-bsd-sockets:socket-close client-socket)
(sb-bsd-sockets:socket-close socket)))

;; Shut down Hunchentoot
(princ "Stopping Hunchentoot...")(terpri)
(stop *hunchentoot-server*)

;; Shut down Swank and anyone else by terminating all threads
(dolist (thread (sb-thread:list-all-threads))
(unless (equal sb-thread:*current-thread* thread)
(sb-thread:terminate-thread thread)))
(sleep 1)
(sb-ext:quit)

When you have lisp sites that you want loaded upon start up, you can place their load commands after the ';;; Load any sites here' comment above.

Now we're ready to launch Hunchentoot:

sudo /etc/init.d/htoot start

Point your browser to your site. Instead of the error seen before, you should see the Hunchentoot default page!

Starting Hunchentoot at bootup

To start Hunchentoot when Ubuntu boots, issue the following commands:

cd /etc/init.d
sudo update-rc.d htoot defaults

Connecting to your server via Slime

Our start-up scripts also starts up the swank server so we can connect to it via Slime and Emacs. View the Slime Manual for the steps on how to do so. Remember that swank is using port 4006, not the default 4005!

Troubleshooting

1. Sometimes if I use the htoot script to restart Hunchentoot, start-up will fail because port 6440 is in use. Issue the command "netstat -a | grep 6440" and verify it's free before trying to start Hunchentoot. Usually you'll have to wait a few seconds before the previous telnet command to stop Hunchentoot finishes.
2. If you have problems starting Hunchentoot during boot-up, you can modify the htoot script to direct output to a file, such as /var/log/boot to help debug. I once did this and found I had issues starting Slime when Ubuntu booted.

Conclusion

I hope this article will help people get up and running with Hunchentoot on Ubuntu, which in my opinion is web programming paradise. Feel free to leave any tips or suggestions below.

Other links of interest:

• Weblocks - A continuations based web framework
• HT-AJAX
  - AJAX framework for Hunchentoot
• LispCast
  - A series of videos about creating a Reddit clone using Hunchentoot

Hunchentoot Pre 1.0

Older versions of Hunchentoot support the Apache module mod_lisp. Instructions for installing mod_lisp and configuring Apache are as follows:

Install Mod_Lisp
First ensure your software repository list contains the proper source.

Open your software repository list

sudo nano /etc/apt/sources.list

If the file lacks the following line, add it to the end.

deb http://fr.archive.ubuntu.com/ubuntu intrepid main universe

Save the changes and exit nano. Next install mod_lisp:

sudo aptitude install libapache2-mod-lisp

The file lisp.load should now reside in /etc/apache2/mods-available/. Next enable it in Apache:

sudo a2enmod lisp

Then restart Apache:

sudo /etc/init.d/apache2 restart

The file lisp.load should now be seen in /etc/apache2/mods-enabled/

In the Apache site configuration file, add something like the following:

   LispServer 127.0.0.1 8000 "hunchentoot"

   <location "/">
       SetHandler lisp-handler
   </location>
   <location "/static">
       SetHandler None
   </location>

This lets Hunchentoot handle all of your sites pages except for the /static directory.

Note that if you are using an older version of Hunchentoot, be sure to modify start-hunchentoot.lisp to use the older start-server and stop-server functions instead of start and stop.

Let d(n) be defined as the sum of proper divisors of n (numbers less than n which divide evenly into n).
If d(a) = b and d(b) = a, where a ≠ b, then a and b are an amicable pair and each of a and b are called amicable numbers.

For example, the proper divisors of 220 are 1, 2, 4, 5, 10, 11, 20, 22, 44, 55 and 110 therefore d(220) = 284. The proper divisors of 284 are 1, 2, 4, 71 and 142 so d(284) = 220.

Evaluate the sum of all the amicable numbers under 10000.

(defun divisor-p (num divisor)
  "Tests if divisor is a divisor of num"
  (zerop (mod num divisor)))

(defun divisors (num)
  "Returns a list of num's divisors"
  (do ((i 2 (1+ i))
         (result '(1)))
      ((> i (isqrt num)) (remove-duplicates result))
    (when (divisor-p num i)
      (setf result (append result (list i (/ num i)))))))

(defun sum-divisors (num)
  "Sums the divisors of num"
  (reduce #'+ (divisors num)))

(defun amicable-p (num)
  "Tests if num is amicable"
  (let ((divisors-sum (sum-divisors num)))
    (when (and (= num (sum-divisors divisors-sum)) 
                       (not (= num divisors-sum)))
      num)))

(defun amicable-sum (limit)
  "Returns the sum of all amicable numbers below limit"
  (do ((i 1 (1+ i))
         (result 0))
      ((>= i limit) result)
    (when (amicable-p i)
      (incf result i))))
  
(defun euler-21 ()
  (amicable-sum 10000))

n! means n × (n − 1) × ... × 3 × 2 × 1

Find the sum of the digits in the number 100!

(defun add-digits (num)
  "Returns the sum of the number's digits"
  (let ((sum 0)
         (num-string (write-to-string num)))
     (dotimes (i (length num-string))
       (setf sum (+ sum (digit-char-p (schar num-string i)))))
    sum))

(defun fact (num)
  (if (= num 1)
      1
      (* num (fact (1- num)))))

(defun euler-20 ()
  (add-digits (fact 100)))

You are given the following information, but you may prefer to do some research for yourself.

* 1 Jan 1900 was a Monday.
* Thirty days has September,
April, June and November.
All the rest have thirty-one,
Saving February alone,
Which has twenty-eight, rain or shine.
And on leap years, twenty-nine.
* A leap year occurs on any year evenly divisible by 4, but not on a century unless it is divisible by 400.

How many Sundays fell on the first of the month during the twentieth century (1 Jan 1901 to 31 Dec 2000)?

(defconstant +months+ '("Jan" "Feb" "Mar" "April" "May" "June"
   "July" "Aug" "Sept" "Oct" "Nov" "Dec"))

(defconstant +days+ '("Sun" "Mon" "Tue" "Wed" "Thurs" "Fri" "Sat"))

(defun days-in-month (month year)
  "Returns the number of days in the month given the month and year"
  (cond ((member month '("Sept" "April" "June" "Nov") :test #'string=)
             30)
            ((and (string= "Feb" month) (zerop (mod year 4))) 29)
            ((string= "Feb" month) 28)
            (t 31)))

(defun move-ahead (today days)
  "Moves ahead a number of days and returns the day.
Example: (move-ahead 'Mon' 3) => 'Thurs'
         (move-ahead 'Sun' 8) => 'Mon'"
  (let ((cur-day-num (position today +days+ :test #'string=)))
    (elt +days+ (mod (+ cur-day-num days) 7))))

(defun euler-19 ()
  (let ((today "Mon")
         (result 0))
    (loop for year from 1900 to 2000 do
       (dolist (month +months+)
          (when (and (string= today "Sun") (> year 1900))
              (incf result))
          (setf today (move-ahead today (days-in-month month year)))))
       result))

By starting at the top of the triangle below and moving to adjacent numbers on the row below, the maximum total from top to bottom is 23.

3
7 5
2 4 6
8 5 9 3

That is, 3 + 7 + 4 + 9 = 23.

Find the maximum total from top to bottom of the triangle below:

75
95 64
17 47 82
18 35 87 10
20 04 82 47 65
19 01 23 75 03 34
88 02 77 73 07 63 67
99 65 04 28 06 16 70 92
41 41 26 56 83 40 80 70 33
41 48 72 33 47 32 37 16 94 29
53 71 44 65 25 43 91 52 97 51 14
70 11 33 28 77 73 17 78 39 68 17 57
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23

NOTE: As there are only 16384 routes, it is possible to solve this problem by trying every route. However, Problem 67, is the same challenge with a triangle containing one-hundred rows it cannot be solved by brute force, and requires a clever method! ;o)

This problem is best solved by starting at the base and working up. Increment the number above each pair of nodes by the largest of the two nodes, and continue until you reach the top.

(defconstant +triangle+ 
  '(
    (75)
    (95 64)
    (17 47 82)
    (18 35 87 10)
    (20 04 82 47 65)
    (19 01 23 75 03 34)
    (88 02 77 73 07 63 67)
    (99 65 04 28 06 16 70 92)
    (41 41 26 56 83 40 80 70 33)
    (41 48 72 33 47 32 37 16 94 29)
    (53 71 44 65 25 43 91 52 97 51 14)
    (70 11 33 28 77 73 17 78 39 68 17 57)
    (91 71 52 38 17 14 91 43 58 50 27 29 48)
    (63 66 04 68 89 53 67 30 73 16 69 87 40 31)
    (04 62 98 27 23 09 70 98 73 93 38 53 60 04 23)))

(defun bottom-two-rows (triangle)
  "Returns the bottom two rows of a triangle"
  (list (car (last (butlast triangle)))
         (car (last triangle))))

(defun first-node-and-stems (triangle)
  "Given two rows of a triangle, returns the first node and the
first node's stems.
Example: (first-node-and-stems '((2 4 6) (8 5 9 3))) => 2 8 5"
  (let ((node (caar triangle))
          (left-stem (first (cadr triangle)))
          (right-stem (second (cadr triangle))))
    (values node left-stem right-stem)))

(defun max-node (node left-stem right-stem)
  (max (+ node left-stem)
           (+ node right-stem)))

(defun sum-stems (rows)
  "Given two adjacent rows of a triangle, returns a list of the
maximum total of the stems for each node.
Example: (sum-stems '((2 4 6) (8 5 9 3))) => (10 13 15)"
  (when (first rows)
    (multiple-value-bind (node left-stem right-stem)
        (first-node-and-stems rows)
      (cons (max-node node left-stem right-stem)
                (sum-stems (mapcar #'cdr rows))))))

(defun max-route (triangle)
  "Returns the sum of the route that produces the maximum total of
the given triangle"
  (if (= (length triangle) 2)
      (multiple-value-bind (node left-stem right-stem)
           (first-node-and-stems triangle)
        (max-node node left-stem right-stem))
      (max-route (append (butlast (butlast triangle))
                                      (list (sum-stems
                                             (bottom-two-rows triangle)))))))

(defun euler-18 ()
  (max-route +triangle+))

If the numbers 1 to 5 are written out in words: one, two, three, four, five, then there are 3 + 3 + 5 + 4 + 4 = 19 letters used in total.
If all the numbers from 1 to 1000 (one thousand) inclusive were written out in words, how many letters would be used?
NOTE: Do not count spaces or hyphens. For example, 342 (three hundred and forty-two) contains 23 letters and 115 (one hundred and fifteen) contains 20 letters. The use of "and" when writing out numbers is in compliance with British usage.

(defun remove-hyphens (str)
  "Removes any hyphens from str"
  (remove #\- str))

(defun remove-spaces (str)
  "Removes any spaces from str"
  (remove #\Space str))

(defun euler-17 ()
  (+ (loop for i from 1 to 1000 sum
         (length (remove-hyphens (remove-spaces 
                                                       (format nil "~R" i)))))
     ;; SBCL does not include the word 'and', so add 
     ;; those letters also
     (* 3 99 9)))

2^(15) = 32768 and the sum of its digits is
3 + 2 + 7 + 6 + 8 = 26.
What is the sum of the digits of the number 2^(1000)?

(defun add-digits (num)
  "Returns the sum of the number's digits"
  (let ((sum 0)
          (num-string (write-to-string num)))
    (dotimes (i (length num-string))
      (setf sum (+ sum (digit-char-p (schar num-string i)))))
    sum))

(defun euler-16 ()
  (add-digits (expt 2 1000)))

Starting in the top left corner of a 2×2 grid, there are 6 routes (without backtracking) to the bottom right corner. How many routes are there through a 20×20 grid?

Since we can not backtrack, we can only move down and right. If we have a 2x2 grid, this means every route consists of exactly 2 right moves and 2 down moves. We can think of the routes as a set of moves, such as (d d r r), and the total number of routes will be all the different combinations of the set minus the identical combinations. To find the number of unique combinations, suppose we have the route (d d r r). Treating each move distinctly, lets write the set as (d1 d2 r1 r2). Notice how this route is equal to the route(d2 d1 r2 r1), and we only want to count this as one route. It turns out that the number of unique routes per combination is 2!*2! = 4: (d1 d2 r1 r2) (d1 d2 r2 r1) (d2 d1 r1 r2)(d2 d1 r2 r1). This means each route in the set of all possible route combinations, 4!, will have 3 other identical routes in the set, resulting in 4!/(2!2!) unique routes. This formula applies to larger grids as well.

(defun factorial (n &optional (acc 1))
  (if (<= n 1)
      acc
      (factorial (- n 1) (* acc n))))

(defun grid-routes (x-dim y-dim)
  "Calculates the number of routes from the top left corner
of a grid to the bottom right corner, without backtracking"
  (let ((total-number-of-moves (+ x-dim y-dim)))
    (/ (factorial total-number-of-moves)
       (* (factorial x-dim)
           (factorial y-dim)))))

(defun euler-15 ()
  (grid-routes 20 20))

The following iterative sequence is defined for the set of positive integers:
n → n/2 (n is even)
n → 3n + 1 (n is odd)
Using the rule above and starting with 13, we generate the following sequence:
13 → 40 → 20 → 10 → 5 → 16 → 8 → 4 → 2 → 1

It can be seen that this sequence (starting at 13 and finishing at 1) contains 10 terms. Although it has not been proved yet (Collatz Problem), it is thought that all starting numbers finish at 1.

Which starting number, under one million, produces the longest chain?

NOTE: Once the chain starts the terms are allowed to go above one million.

I listed two solutions to this problem in Common Lisp below. alt-euler-14 strictly follows the formula and computes the solution inefficiently. euler-14 stores computed values in a hash table so it never applies the formula to the same number more than once.

;;; *collatz-table* holds the number of terms for previously performed
;;; collatz calculations.  For example, say that we already found
;;; the number of terms to compute 10, which is 7.  If we compute
;;; the number of terms for 13, as in the example above, when it
;;; reaches 10 it will find this value in the table and add 7 to
;;; the current terms value to get the answer.
(defparameter *collatz-table* (make-hash-table))

(defun collatz (num)
  (cond ((= num 1) 1)
            ((gethash num *collatz-table*)
             (gethash num *collatz-table*))
            ((evenp num)
              (setf (gethash num *collatz-table*)
                      (1+ (collatz (/ num 2)))))
             (t (setf (gethash num *collatz-table*)
                         (1+ (collatz (1+ (* 3 num))))))))

(defun euler-14 ()
  (let ((answer 0)
          (max-terms 0))
    (do ((x 1 (1+ x)))
          ((>= x 1000000) answer)
      (let ((terms-of-x (collatz x)))
         (when (> terms-of-x max-terms)
           (setf max-terms terms-of-x
                   answer x))))))

(defun alt-collatz (num &optional (term 1))
  (cond ((= num 1) term)
            ((evenp num) (alt-collatz (/ num 2) (1+ term)))
            (t (alt-collatz (1+ (* 3 num)) (1+ term)))))

(defun alt-euler-14 ()
  (let ((answer 0)
         (max-terms 0))
    (do ((x 1 (1+ x)))
          ((>= x 1000000) answer)
      (let ((terms-of-x (alt-collatz x)))
        (when (> terms-of-x max-terms)
             (setf max-terms terms-of-x
                     answer x))))))

Alt-euler-14 took 8.5 seconds. euler-14's first run took 3 seconds, but the second run took 0.28 seconds. This speed came at a cost of more memory.

Work out the first ten digits of the sum of the following one-hundred 50-digit numbers.

Common Lisp handles big numbers for you, so this problem is very easy.

(defparameter numbers '(
37107287533902102798797998220837590246510135740250
46376937677490009712648124896970078050417018260538
74324986199524741059474233309513058123726617309629
91942213363574161572522430563301811072406154908250
23067588207539346171171980310421047513778063246676
89261670696623633820136378418383684178734361726757
28112879812849979408065481931592621691275889832738
44274228917432520321923589422876796487670272189318
47451445736001306439091167216856844588711603153276
70386486105843025439939619828917593665686757934951
62176457141856560629502157223196586755079324193331
64906352462741904929101432445813822663347944758178
92575867718337217661963751590579239728245598838407
58203565325359399008402633568948830189458628227828
80181199384826282014278194139940567587151170094390
35398664372827112653829987240784473053190104293586
86515506006295864861532075273371959191420517255829
71693888707715466499115593487603532921714970056938
54370070576826684624621495650076471787294438377604
53282654108756828443191190634694037855217779295145
36123272525000296071075082563815656710885258350721
45876576172410976447339110607218265236877223636045
17423706905851860660448207621209813287860733969412
81142660418086830619328460811191061556940512689692
51934325451728388641918047049293215058642563049483
62467221648435076201727918039944693004732956340691
15732444386908125794514089057706229429197107928209
55037687525678773091862540744969844508330393682126
18336384825330154686196124348767681297534375946515
80386287592878490201521685554828717201219257766954
78182833757993103614740356856449095527097864797581
16726320100436897842553539920931837441497806860984
48403098129077791799088218795327364475675590848030
87086987551392711854517078544161852424320693150332
59959406895756536782107074926966537676326235447210
69793950679652694742597709739166693763042633987085
41052684708299085211399427365734116182760315001271
65378607361501080857009149939512557028198746004375
35829035317434717326932123578154982629742552737307
94953759765105305946966067683156574377167401875275
88902802571733229619176668713819931811048770190271
25267680276078003013678680992525463401061632866526
36270218540497705585629946580636237993140746255962
24074486908231174977792365466257246923322810917141
91430288197103288597806669760892938638285025333403
34413065578016127815921815005561868836468420090470
23053081172816430487623791969842487255036638784583
11487696932154902810424020138335124462181441773470
63783299490636259666498587618221225225512486764533
67720186971698544312419572409913959008952310058822
95548255300263520781532296796249481641953868218774
76085327132285723110424803456124867697064507995236
37774242535411291684276865538926205024910326572967
23701913275725675285653248258265463092207058596522
29798860272258331913126375147341994889534765745501
18495701454879288984856827726077713721403798879715
38298203783031473527721580348144513491373226651381
34829543829199918180278916522431027392251122869539
40957953066405232632538044100059654939159879593635
29746152185502371307642255121183693803580388584903
41698116222072977186158236678424689157993532961922
62467957194401269043877107275048102390895523597457
23189706772547915061505504953922979530901129967519
86188088225875314529584099251203829009407770775672
11306739708304724483816533873502340845647058077308
82959174767140363198008187129011875491310547126581
97623331044818386269515456334926366572897563400500
42846280183517070527831839425882145521227251250327
55121603546981200581762165212827652751691296897789
32238195734329339946437501907836945765883352399886
75506164965184775180738168837861091527357929701337
62177842752192623401942399639168044983993173312731
32924185707147349566916674687634660915035914677504
99518671430235219628894890102423325116913619626622
73267460800591547471830798392868535206946944540724
76841822524674417161514036427982273348055556214818
97142617910342598647204516893989422179826088076852
87783646182799346313767754307809363333018982642090
10848802521674670883215120185883543223812876952786
71329612474782464538636993009049310363619763878039
62184073572399794223406235393808339651327408011116
66627891981488087797941876876144230030984490851411
60661826293682836764744779239180335110989069790714
85786944089552990653640447425576083659976645795096
66024396409905389607120198219976047599490197230297
64913982680032973156037120041377903785566085089252
16730939319872750275468906903707539413042652315011
94809377245048795150954100921645863754710598436791
78639167021187492431995700641917969777599028300699
15368713711936614952811305876380278410754449733078
40789923115535562561142322423255033685442488917353
44889911501440648020369068063960672322193204149535
41503128880339536053299340368006977710650566631954
81234880673210146739058568557934581403627822703280
82616570773948327592232845941706525094512325230608
22918802058777319719839450180888072429661980811197
77158542502016545090413245809786882778948721859617
72107838435069186155435662884062257473692284509516
20849603980134001723930671666823555245252804609722
53503534226472524250874054075591789781264330331690 ))

(defun euler-13 ()
  (subseq (write-to-string (apply #'+ numbers))
              0 10))