;;; -* mode: lisp; -*-

;;; Rudimentary jump table time testing.

(defpackage case-test
  (:use #:common-lisp))

(in-package #:case-test)


;;;; SWITCH macro

(defmacro with-gensyms ((&rest bindings) &body body)
  `(let ,(mapcar #'(lambda (binding)
                     (destructuring-bind (var prefix)
                         (if (consp binding) binding (list binding binding))
                       `(,var (gensym ,(string prefix)))))
                 bindings)
     ,@body))

(defmacro switch (form &rest cases)
  (flet ((generate-case-bodies (cases)
           (loop for (val . body) in cases
                 collect `(list (quote ,val) (lambda () ,@body))))
         (generate-default-case-body (cases)
           (let ((default-case-body
                  (find-if #'(lambda (form) (eq 'otherwise (first form))) cases)))
             (if default-case-body
                 `(lambda () ,@(rest default-case-body))
                 `(lambda () nil)))))
    (with-gensyms (table tmp default-case-body result case-value case-body)
      `(let ((,table (load-time-value
                      (let ((,tmp (make-hash-table :test 'equal)))
                        (loop for (,case-value ,case-body) in (list ,@(generate-case-bodies cases))
                              do (setf (gethash ,case-value ,tmp) ,case-body))
                        ,tmp)))
             (,default-case-body ,(generate-default-case-body cases)))
         (let* ((,result ,form)
                (,case-body (gethash ,result ,table ,default-case-body)))
           (funcall ,case-body))))))



;;;; NCASE macro

;;; Adapted (well, copied, basically) from Tim Bradshaw.
;;; http://www.tfeb.org/lisp/toys.html#NCASE

;;; Adjusted the macro so that it can compile in one file.  Controlling the
;;; variables was not considered important for this exercise.

(defmacro ncase (v &body clauses)
  ;; Semantics just like CASE, unless I've got it wrong.
  (let* ((*ncase-length-threshold* 10)
         (*ncase-density-threshold* 0.2)
         (*ncase-predicate* #'(lambda (keys)
                                (let ((l (length keys))
                                      (r (- (reduce #'max keys)
                                            (reduce #'min keys))))
                                  (and (>= l *ncase-length-threshold*)
                                       (not (zerop r))            ;weird case with one clause
                                       (>= (/ l r)
                                           *ncase-density-threshold*))))))
    (if (every #'(lambda (clause)
                   (and (consp clause)
                        (let ((key/s (first clause)))
                          ;; what about NIL: just give up for now.
                          (or (and (consp key/s)
                                   (every #'integerp key/s))
                              (integerp key/s)
                              (member key/s '(otherwise t))))))
               clauses)
        ;; OK this is a candidate for us.
        (let ((keys '())
              (key-body-map '())
              (otherwise '(nil)))
          (loop with seen-otherwise-p = nil
                for (key/s . body) in clauses
                do
                (cond ((member key/s '(otherwise t))
                       (when seen-otherwise-p
                         (error "Multiple OTHERWISE clauses."))
                       (setf otherwise body
                             seen-otherwise-p t))
                      ((integerp key/s)
                       (when (member key/s keys)
                         (error "Multiple identical keys"))
                       (push key/s keys)
                       (let ((found (rassoc body key-body-map
                                            :test #'equal)))
                         (if found
                             (push key/s (car found))
                             (push (cons (list key/s) body)
                                   key-body-map))))
                      ((consp key/s)
                       (loop for key in key/s
                             do
                             (when (member key keys)
                               (error "Multiple identical keys"))
                             (push key keys)
                             (let ((found (rassoc body key-body-map
                                                  :test #'equal)))
                               (if found
                                   (push key (car found))
                                   (push (cons (list key) body)
                                         key-body-map)))))
                      (t (error "This can't happen"))))
          ;; OK, now we are set...
          (if (funcall *ncase-predicate* keys)
              ;; dense enough
              (let ((mname (make-symbol "MAP"))
                    (vname (make-symbol "V"))
                    (min (reduce #'min keys))
                    (max (reduce #'max keys)))
                `(let ((,vname ,v))
                   (if (or (not (integerp ,vname))
                           (not (<= ,min ,vname ,max)))
                       (progn ,@otherwise)
                       ;; The map is bound here just so we can
                       ;; optimize only the bit we want.
                       (let ((,mname
                              ;; Use LOAD-TIME-VALUE to avoid any issues
                              ;; of dumping the map in a FASL - especially
                              ;; make sure that functions in it are not 
                              ;; duplicated which I can't otherwise see how
                              ;; to do.  This may be hopeless in interpreted
                              ;; code.
                              (load-time-value
                               (let ((,mname (make-array ,(1+ (- max min)))))
                                 ,@(loop with lname = (make-symbol "L")
                                         and iname = (make-symbol "I")
                                         for (keys . body) in
                                         (cons (cons
                                                (loop for i from min to max
                                                      unless (member i keys) 
                                                      collect i)
                                                otherwise)
                                               key-body-map)
                                         collect
                                         `(loop with ,lname = (lambda () ,@body)
                                                for ,iname in ',keys
                                                do (setf (aref ,mname (- ,iname
                                                                         ,min))
                                                         ,lname)))
                                 ,mname)
                               ;; it's a constant
                               t)))
                         (locally
                             (declare (optimize speed (safety 0)))
                           (funcall (aref ,mname (- ,vname ,min))))))))
              ;; punt - failed *NCASE-PREDICATE*
              `(case ,v ,@clauses)))
        ;; punt - not all keys are integers
        `(case ,v ,@clauses))))



;;;; CASE GENERATOR

(defmacro generate-generic-case (kind var num)
  `(,kind ,var
     ,@(loop for i from 1 to num
             collect (list i i) into clauses
             finally (return (append clauses (list (list 'otherwise nil)))))))


;;;; TEST FUNCTIONS

(defun case-10 (n) (generate-generic-case case n 10))
(defun case-100 (n) (generate-generic-case case n 100))
(defun case-1000 (n) (generate-generic-case case n 1000))

(defun ncase-10 (n) (generate-generic-case ncase n 10))
(defun ncase-100 (n) (generate-generic-case ncase n 100))
(defun ncase-1000 (n) (generate-generic-case ncase n 1000))

(defun switch-10 (n) (generate-generic-case switch n 10))
(defun switch-100 (n) (generate-generic-case switch n 100))
(defun switch-1000 (n) (generate-generic-case switch n 1000))


;;;; TIMING GOODNESS

(defun time-test (func times)
  (time (loop repeat times do (funcall func 10000000))))

(defun run-tests ()
  (loop for kind in '(case ncase switch)
        do (loop for n in '(10 100 1000)
                 for func = (intern (format nil "~A-~D" kind n) (find-package '#:case-test))
                 do (format t "~%***** ~A~%" func)
                 do (time-test func 1000000))))