Lisp Koans Scoring Project: Refactor - common-lisp

Question

I am going through Lisp Koans, it's a lot of fun! But I stuck at Scoring Projects (I had a bad solution). In this project we were asked to implement a simple game called *Greed*. The problem description is here:
; *Greed* is a dice game where you roll up to five dice to accumulate
; points. The following "score" function will be used to calculate the
; score of a single roll of the dice.
;
; A greed roll is scored as follows:
; * A set of three ones is 1000 points
; * A set of three numbers (other than ones) is worth 100 times the
; number. (e.g. three fives is 500 points).
; * A one (that is not part of a set of three) is worth 100 points.
; * A five (that is not part of a set of three) is worth 50 points.
; * Everything else is worth 0 points.
;
; Examples:
;
; (score '(1 1 1 5 1)) => 1150 points
; (score '(2 3 4 6 2)) => 0 points
; (score '(3 4 5 3 3)) => 350 points
; (score '(1 5 1 2 4)) => 250 points
;
; More scoring examples are given in the tests below:
;
; Your goal is to write the score method.
My Solution is following:
WARNING! IF YOU HAVEN'T PLAY WITH THIS ONE. DO NOT SEE THIS!
I use an occurs function to calculate occurrences of number and represent in assoc-list. And a formula-wrapper function to provide correct arguments to formula function. The formula function to calculate scores. My solution is very ugly! Any advices are welcome! Thank you in advance.
(defun occurs (lst)
(let ((acc nil))
(dolist (obj lst)
(let ((p (assoc obj acc)))
(if p
(incf (cdr p))
(push (cons obj 1) acc))))
(sort acc #'> :key #'cdr)))
(defun formula-wrapper (lst)
(formula (car lst) (cdr lst)))
(defun formula (number times)
(cond ((= times 0) 0)
((= times 1)
(case number
(1 100)
(5 50)
(otherwise 0)))
((= times 2)
(case number
(1 200)
(5 100)
(otherwise 0)))
((= times 3)
(case number
(1 1000)
(otherwise (* 100 number))))
((= times 4)
(case number
(1 1100)
(5 550)
(otherwise 0)))
((= times 5)
(case number
(1 1200)
(5 600)
(otherwise 0)))
(times 0)))
(defun score (dice)
(let ((rolls (occurs dice)))
(if (null rolls)
0
(apply #'+ (mapcar #'formula-wrapper rolls))))))
The tests:
(define-test test-score-of-an-empty-list-is-zero
(assert-equal 0 (score nil)))
(define-test test-score-of-a-single-roll-of-5-is-50
(assert-equal 50 (score '(5))))
(define-test test-score-of-a-single-roll-of-1-is-100
(assert-equal 100 (score '(1))))
(define-test test-score-of-multiple-1s-and-5s-is-the-sum-of-individual-scores
(assert-equal 300 (score '(1 5 5 1))))
(define-test test-score-of-single-2s-3s-4s-and-6s-are-zero
(assert-equal 0 (score '(2 3 4 6))))
(define-test test-score-of-a-triple-1-is-1000
(assert-equal 1000 (score '(1 1 1))))
(define-test test-score-of-other-triples-is-100x
(assert-equal 200 (score '(2 2 2)))
(assert-equal 300 (score '(3 3 3)))
(assert-equal 400 (score '(4 4 4)))
(assert-equal 500 (score '(5 5 5)))
(assert-equal 600 (score '(6 6 6))))
(define-test test-score-of-mixed-is-sum
(assert-equal 250 (score '(2 5 2 2 3)))
(assert-equal 550 (score '(5 5 5 5))))

Answer 1

(defun score (dice)
(let ((freq (make-hash-table)))
(loop for x in dice do (incf (gethash x freq 0)))
(loop for x being the hash-key of freq using (hash-value c)
sum (if (<= 3 c)
(case x
(1 (+ 1000 (* 100 (- c 3))))
(5 (+ 500 (* 50 (- c 3))))
(t (* x 100)))
(case x
(1 (* c 100))
(5 (* c 50))
(t 0))))))

Answer 2

One way to write it:
(defun find-set (roll)
"which number from 1 to 6 occurs at least three times in a list of five?"
(assert (= (length roll) 5))
(loop for i from 1 to 6
when (>= (count i roll) 3)
do (return i)))
(defun score-set (i)
"compute the set score for number i"
(case i
(1 1000)
(otherwise (* i 100))))
(defun score (roll &aux (s (find-set roll)) (score 0))
(when s
(setf score (score-set s)
roll (remove s roll :count 3)))
(incf score (* (count 1 roll) 100))
(incf score (* (count 5 roll) 50))
score)
(defun test ()
(assert (= (score '(1 1 1 5 1)) 1150))
(assert (= (score '(2 3 4 6 2)) 0))
(assert (= (score '(3 4 5 3 3)) 350))
(assert (= (score '(1 5 1 2 4)) 250))
t)

Answer 3

A tail-recursive version:
(defun score (dice)
(labels ((iter (left ans)
(if (not left) ans
(cond ((and (>= (length left) 3)
(= (car left) (cadr left) (caddr left)))
(cond ((= (car left) 1)
(iter (cdddr left) (+ ans 1000)))
((= (car left) 5)
(iter (cdddr left) (+ ans 500)))
(t (iter (cdddr left) (+ ans (* (car left) 100))))))
((= (car left) 1) (iter (cdr left) (+ ans 100)))
((= (car left) 5) (iter (cdr left) (+ ans 50)))
(t (iter (cdr left) ans))))))
(iter (sort dice #'<) 0)))