Commits

Robert Smith committed 530afcd

Add a version of jump/case that does binary searching.

Comments (0)

Files changed (1)

 (defmacro constant-load-time-value (value)
   `(load-time-value ,value t))
 
+
+;;; XXX: This doesn't support referencing the lexical environment.
 (defmacro jump ((n &optional default) &body cases)
   "Efficiently execute the body of a case in CASES chosen by the
 non-negative integer N. If there is no case matching N and N is less
                                  ,(table-to-initial-contents)))
                     ,n))))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;; Binary Search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun generate-search (numbers &optional code-dict)
+    (let ((var (gensym "N"))
+          (otherwise (gensym "OTHERWISE-")))
+      (labels ((lookup (n)
+                 (gethash n code-dict))
+               
+               (split (numbers)
+                 (let ((len/2 (ceiling (length numbers) 2)))
+                   (values (subseq numbers 0 len/2)
+                           (subseq numbers len/2))))
+               
+               (rec (numbers)
+                 (cond
+                   ((null numbers)
+                    (error "We got a null list..."))
+
+                   ((null (rest numbers))
+                    `(if (= ,var ,(first numbers))
+                         (progn ,@(lookup (first numbers)))
+                         (,otherwise)))
+                   
+                   (t
+                    (multiple-value-bind (left right)
+                        (split numbers)
+                      (let ((left-min (first left))
+                            (left-max (car (last left)))
+                            (right-min (first right))
+                            (right-max (car (last right))))
+                        (if (and (= left-min left-max)
+                                 (= right-min right-max)) ; should always be true
+                            `(cond
+                               ((= ,var ,left-min) ,@(lookup left-min))
+                               ((= ,var ,right-min) ,@(lookup right-min))
+                               (t (,otherwise)))
+                            `(if (<= ,left-min ,var ,left-max)
+                                 ,(rec left)
+                                 ,(rec right)))))))))
+        (let* ((sorted (sort (copy-list numbers) #'<))
+               (min (first sorted))
+               (max (car (last sorted))))
+          `(lambda (,var)
+             ,(if (= min max)
+                  `(if (= ,var ,min)
+                       (progn ,@(lookup min))
+                       (progn ,@(lookup t)))
+                  `(flet ((,otherwise ()
+                            ,@(lookup t)))
+                     (declare (dynamic-extent (function ,otherwise)))
+                     (if (<= ,min ,var ,max)
+                         ,(rec sorted)
+                         (,otherwise))))))))))
+
+(defmacro binary-case (n &body cases)
+  (let ((code-dict (make-hash-table)))
+    (labels ((extract-keys ()
+               (mapcan (lambda (c)
+                         (let ((key (car c)))
+                           (cond
+                             ((listp key) (copy-list key))
+                             ((integerp key) (list key))
+                             (t nil))))
+                       cases))
+             
+             (populate-code-dict ()
+               (loop :for (keys . body) :in cases
+                     :do (cond
+                           ((or (eql keys t)
+                                (eql keys 'otherwise))
+                            (setf (gethash t code-dict) body))
+                           
+                           ((integerp keys)
+                            (setf (gethash keys code-dict) body))
+                           
+                           ((listp keys)
+                            (dolist (key keys)
+                              (setf (gethash key code-dict) body)))
+                           
+                           (t (error "Invalid case key: ~S" keys))))))
+      
+      (populate-code-dict)
+      
+      (unless (gethash t code-dict)
+        (setf (gethash t code-dict) (list nil)))
+      
+      `(funcall ,(generate-search (extract-keys) code-dict)
+                ,n))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Tests ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
      ,@(loop :for i :below num-cases
              :collect (list i i))))
 
+(defmacro generate-binary-case-form (num-cases)
+  `(binary-case (random ,num-cases)
+     ,@(loop :for i :below num-cases
+             :collect (list i i))))
+
 (defun test-jump ()
   (loop :repeat *trials*
         :do (generate-jump-form 1000)))
   (loop :repeat *trials*
         :do (generate-case-form 1000)))
 
+(defun test-binary-case ()
+  (loop :repeat *trials*
+        :do (generate-binary-case-form 1000)))
+
+
 ;; CL-USER> (progn
 ;;            (time (test-jump))
-;;            (time (test-case)))
+;;            (time (test-case))
+;;            (time (test-binary-case)))
 ;; Evaluation took:
-;;   0.567 seconds of real time
-;;   0.567869 seconds of total run time (0.565772 user, 0.002097 system)
-;;   100.18% CPU
-;;   960,677,725 processor cycles
-;;   0 bytes consed
+;;   0.600 seconds of real time
+;;   0.601523 seconds of total run time (0.599077 user, 0.002446 system)
+;;   100.33% CPU
+;;   1,017,956,287 processor cycles
+;;   11,008 bytes consed
 ;;
 ;; Evaluation took:
-;;   4.753 seconds of real time
-;;   4.761654 seconds of total run time (4.743117 user, 0.018537 system)
-;;   100.19% CPU
-;;   8,061,858,720 processor cycles
-;;   16,272 bytes consed
+;;   4.777 seconds of real time
+;;   4.786960 seconds of total run time (4.768514 user, 0.018446 system)
+;;   100.21% CPU
+;;   8,103,027,934 processor cycles
+;;   62,304 bytes consed
+;;
+;; Evaluation took:
+;;   0.776 seconds of real time
+;;   0.777397 seconds of total run time (0.774449 user, 0.002948 system)
+;;   100.13% CPU
+;;   1,315,515,748 processor cycles
+;;   0 bytes consed
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;; STATE MACHINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+(defun run-machine ()
+  (loop :named state-machine
+        :with previous-state := nil
+        :and state := 0
+        :do (macrolet ((next (n)
+                         `(progn
+                            (psetf previous-state state
+                                   state ,n)
+                            (return-from next-state)))
+                       (done (return-val)
+                         `(return-from state-machine ,return-val)))
+              (block next-state
+                (format t "~A --> ~A: " previous-state state)
+                (tagbody
+                   (case state
+                     (0       (go :TAG-ZERO))
+                     (1       (go :TAG-ONE))
+                     ((2 4 6) (go :TAG-TWO))
+                     ((3 5)   (go :TAG-THREE))
+                     (7       (go :TAG-SEVEN)))
+                 :TAG-ZERO
+                   (format t "Hello!~%")
+                   (next 1)
+                 :TAG-ONE
+                   (format t "World!~%")
+                   (next 2)
+                 :TAG-TWO
+                   (format t "even!~%")
+                   (next (random 8))
+                 :TAG-THREE
+                   (format t "odd!~%")
+                   (next (random 8))
+                 :TAG-SEVEN
+                   (format t "done!~%")
+                   (done t))))))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.