fd5861c11c5f

Add rule shuffling, new stratification procedure
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Wed, 17 May 2017 13:36:59 +0000
parents 374014ff34a9
children 47c967fea4c7
branches/tags (none)
files gdl/stratego.gdl src/graphviz.lisp src/grounders/fluxplayer.lisp src/players/random-ii.lisp src/players/random-zdd.lisp src/reasoners/zdd.lisp src/rule-trees.lisp src/terms.lisp vendor/make-quickutils.lisp vendor/quickutils.lisp

Changes

--- a/gdl/stratego.gdl	Wed May 17 13:36:42 2017 +0000
+++ b/gdl/stratego.gdl	Wed May 17 13:36:59 2017 +0000
@@ -217,6 +217,7 @@
 	(true (cell ?x0 ?y0 ?p))
 )
 
+
 (<= (next (occupied ?x ?y ?r))
 	(true (cell ?x ?y ?p))
 	(true (occupied ?x ?y ?r))
--- a/src/graphviz.lisp	Wed May 17 13:36:42 2017 +0000
+++ b/src/graphviz.lisp	Wed May 17 13:36:59 2017 +0000
@@ -43,7 +43,8 @@
   (let ((*rt-label-fn* label-fn))
     (cl-dot:dot-graph
       (cl-dot:generate-graph-from-roots 'rule-tree (list rule-tree)
-                                        '(:dpi 300))
+                                        ;; '(:dpi 300)
+                                        )
       filename
       :format :png))
   rule-tree)
--- a/src/grounders/fluxplayer.lisp	Wed May 17 13:36:42 2017 +0000
+++ b/src/grounders/fluxplayer.lisp	Wed May 17 13:36:59 2017 +0000
@@ -145,11 +145,9 @@
   'ok)
 
 
-; (dump-grounded "buttons")
-; (dump-grounded "8puzzle")
-; (dump-grounded "tictactoe")
-
+;; (dump-grounded "buttons")
+;; (dump-grounded "8puzzle")
+;; (dump-grounded "tictactoe")
+;; (dump-grounded "stratego")
 ;; (dump-grounded "small_dominion")
-
-
 ;; (time (dump-grounded "meier"))
--- a/src/players/random-ii.lisp	Wed May 17 13:36:42 2017 +0000
+++ b/src/players/random-ii.lisp	Wed May 17 13:36:59 2017 +0000
@@ -1,14 +1,17 @@
 (in-package :scully.players.random-ii)
 
+(defvar *data-file* nil)
+
 
 ;;;; Random Incomplete-Information Player -------------------------------------
 (defclass random-ii-player (ggp:ggp-player)
   ((role :type symbol :accessor rp-role)
    (reasoner :accessor rp-reasoner)
-   (information-set :accessor rp-information-set)))
+   (information-set :accessor rp-information-set)
+   (turn :initform 0 :accessor rp-turn)))
 
 (define-with-macro (random-ii-player :conc-name rp)
-  role reasoner information-set)
+  role reasoner information-set turn)
 
 
 (defun percepts-match-p (player state moves percepts)
@@ -44,33 +47,35 @@
 
 
 (defmethod ggp:player-start-game ((player random-ii-player) rules role timeout)
+  (setf *data-file* (open "data-prolog" :direction :output :if-exists :append))
+  ;; (format *data-file* "turn,information set size,cons/symbol count~%")
   (let ((reasoner (make-prolog-reasoner)))
     (load-rules reasoner rules)
     (setf (rp-role player) role
-          (rp-reasoner player) reasoner
-          (rp-information-set player) (list (initial-state reasoner)))))
+          (rp-turn player) 0
+          (rp-reasoner player) reasoner)))
 
 (defmethod ggp:player-stop-game ((player random-ii-player))
+  (finish-output *data-file*)
+  (close *data-file*)
   (setf (rp-role player) nil
         (rp-reasoner player) nil
         (rp-information-set player) nil))
 
 (defmethod ggp:player-update-game-ii ((player random-ii-player) move percepts)
   (format t "~2%=====================================~%")
-  (when move
-    (setf (rp-information-set player)
-          (get-next-information-set player move percepts))))
+  (with-random-ii-player (player)
+    (setf information-set
+          (if move
+            (get-next-information-set player move percepts)
+            (list (initial-state reasoner))))
+    (format *data-file* "~D,~D,~D~%"
+            turn
+            (length information-set)
+            (information-set-objects information-set))))
 
 (defun information-set-objects (iset)
-  (let ((seen (make-hash-table)))
-    (recursively ((iset iset))
-      (etypecase iset
-        ((or integer symbol) (if (nth-value 1 (ensure-gethash iset seen))
-                               0
-                               1))
-        (cons (+ 1
-                 (recur (car iset))
-                 (recur (cdr iset))))))))
+  (apply #'+ (mapcar #'length iset)))
 
 (defmethod ggp:player-select-move ((player random-ii-player) timeout)
   (format t "Selecting move...~%")
--- a/src/players/random-zdd.lisp	Wed May 17 13:36:42 2017 +0000
+++ b/src/players/random-zdd.lisp	Wed May 17 13:36:59 2017 +0000
@@ -1,17 +1,22 @@
 (in-package :scully.players.random-zdd)
 
+(defvar *data-file* nil)
+
 
 ;;;; Random Incomplete-Information Player -------------------------------------
 (defclass random-zdd-player (ggp:ggp-player)
   ((role :type symbol :accessor rp-role)
    (reasoner :accessor rp-reasoner)
-   (information-set :accessor rp-iset)))
+   (information-set :accessor rp-iset)
+   (turn :initform 0 :accessor rp-turn)))
 
 (define-with-macro (random-zdd-player :conc-name rp)
-  role reasoner iset)
+  role reasoner iset turn)
 
 
 (defmethod ggp:player-start-game ((player random-zdd-player) rules role timeout)
+  (setf *data-file* (open "data-zdd" :direction :output :if-exists :append))
+  ;; (format *data-file* "turn,information set size,zdd node count,max node count~%")
   (scully.zdd::with-zdd
     (let* ((grounded-rules (-<> rules
                              (with-output-to-string (s)
@@ -19,37 +24,65 @@
                              (ground-gdl-string <>)))
            (reasoner (make-zdd-reasoner grounded-rules)))
       (setf (rp-role player) role
+            (rp-turn player) 0
             (rp-reasoner player) reasoner)
       t)))
 
 (defmethod ggp:player-stop-game ((player random-zdd-player))
+  (format t "Done~%")
+  (finish-output *data-file*)
+  (close *data-file*)
   (scully.zdd::with-zdd
     (with-random-zdd-player (player)
       (setf role nil
             reasoner nil
             iset nil))))
 
+(defun information-set-objects (iset)
+  (apply #'+ (mapcar #'length iset)))
+
 (defmethod ggp:player-update-game-ii ((player random-zdd-player) move percepts)
+  (incf (rp-turn player))
   (format t "~2%=====================================~%")
-  (scully.zdd::with-zdd
-    (with-random-zdd-player (player)
-      (setf iset
-            (if move
-              (-<> iset
-                (progn (format t "Information set size: ~D states, ~D ZDD nodes~%"
-                               (scully.zdd:zdd-count <>)
-                               (scully.zdd:zdd-node-count <>))
-                       <>)
-                (sprout reasoner <> (rp-role player) move)
-                (apply-happens reasoner <>)
-                (progn
-                  (format t "        Max size: ~D ZDD nodes~%"
-                          (scully.zdd:zdd-node-count <>))
-                  <>)
-                (filter-iset-for-percepts reasoner <> role percepts)
-                (compute-next-iset reasoner <>)
-                (apply-possible reasoner <>))
-              (apply-possible reasoner (initial-iset reasoner)))))))
+  (pr percepts)
+
+  (let ((max-size 0))
+    (scully.zdd::with-zdd
+      (with-random-zdd-player (player)
+        (setf iset
+              (if move
+                (-<> iset
+                  (progn
+                    (format t "Information set size: ~D states, ~D ZDD nodes~%"
+                            (scully.zdd:zdd-count <>)
+                            (scully.zdd:zdd-node-count <>))
+                    (format t "      Iset cons size: ~D things~%"
+                            (information-set-objects (scully.zdd::zdd-enumerate <>)))
+                    <>)
+                  (sprout reasoner <> (rp-role player) move)
+                  (progn (format t "After sprouting size: ~D states~%"
+                                 (scully.zdd:zdd-count <>))
+                         <>)
+                  (apply-happens reasoner <>)
+                  (progn
+                    (setf max-size (scully.zdd:zdd-node-count <>))
+                    (format t "          Max size: ~D ZDD nodes~%" max-size)
+                    <>)
+                  (filter-iset-for-percepts reasoner <> role percepts)
+                  (progn (format t "After filtering size: ~D states~%"
+                                 (scully.zdd:zdd-count <>))
+                         <>)
+                  (compute-next-iset reasoner <>)
+                  ;; (progn (dump-iset reasoner <>)
+                  ;;        <>)
+                  (apply-possible reasoner <>))
+                (apply-possible reasoner (initial-iset reasoner))))
+        (let ((object-size (information-set-objects (scully.zdd::zdd-enumerate iset))))
+          (format *data-file* "~D,~D,~D,~D,~D~%" turn
+                  (scully.zdd:zdd-count iset)
+                  (scully.zdd:zdd-node-count iset)
+                  max-size
+                  object-size))))))
 
 (defmethod ggp:player-select-move ((player random-zdd-player) timeout)
   (scully.zdd::with-zdd
@@ -69,6 +102,5 @@
                                 :name "Scully-Random-ZDD"
                                 :port 5003))
 
-(ggp:start-player *player* :server :hunchentoot :use-thread t)
+;; (ggp:start-player *player* :server :hunchentoot :use-thread t)
 ;; (ggp:kill-player *player*)
-(slot-value *player* 'ggp::request-lock)
--- a/src/reasoners/zdd.lisp	Wed May 17 13:36:42 2017 +0000
+++ b/src/reasoners/zdd.lisp	Wed May 17 13:36:59 2017 +0000
@@ -293,6 +293,22 @@
              (format t "STATE ~D:~%~{    ~S~%~}~2%" i state)))
   iset)
 
+(defun dump-rule-tree (reasoner term)
+  (draw-rule-tree
+    reasoner
+    (iterate
+      finder
+      (with target = (term-to-number reasoner term))
+      (for nf :from 0)
+      (for forest :in (list (zr-possible-forest reasoner)
+                            (zr-happens-forest reasoner)))
+      (iterate (for stratum :in (rf-strata forest))
+               (for ns :from 0)
+               (iterate (for rule :in (stratum-rule-trees stratum))
+                        (when (= target (scully.rule-trees::head rule))
+                          (pr 'forest nf 'stratum ns)
+                          (return-from finder rule)))))))
+
 
 (defun initial-iset (reasoner)
   "Return the initial information set of the game."
@@ -581,6 +597,18 @@
       (traverse-iset iset forest))))
 
 
+;;;; Stats --------------------------------------------------------------------
+(defun rule-forest-size (forest)
+  (iterate
+    (for stratum :in (rf-strata forest))
+    (appending (mapcar #'scully.rule-trees::rule-tree-size
+                       (stratum-rule-trees stratum)))))
+
+(defun reasoner-rule-tree-sizes (reasoner)
+  (append (rule-forest-size (zr-possible-forest reasoner))
+          (rule-forest-size (zr-happens-forest reasoner))))
+
+
 ;;;; Scratch ------------------------------------------------------------------
 (defparameter *rules* (scully.gdl::read-gdl "gdl/meier-grounded.gdl"))
 (defparameter *rules* (scully.gdl::read-gdl "gdl/kriegTTT_5x5-grounded.gdl"))
@@ -588,35 +616,10 @@
 (defparameter *rules* (scully.gdl::read-gdl "gdl/mastermind-grounded.gdl"))
 (defparameter *rules* (scully.gdl::read-gdl "gdl/montyhall-grounded.gdl"))
 (defparameter *rules* (scully.gdl::read-gdl "gdl/tictactoe-grounded.gdl"))
+(defparameter *rules* (scully.gdl::read-gdl "gdl/stratego-grounded.gdl"))
 
 (defparameter *i* nil)
-;; (defparameter *r* nil)
-(defparameter *r* (make-zdd-reasoner *rules*))
-
-
-(defun test ()
-  (with-zdd
-    (-<>
-        (initial-iset *r*)
+(defparameter *r* nil)
+;; (defparameter *r* (make-zdd-reasoner *rules*))
+;; (reasoner-rule-tree-sizes *r*)
 
-      (apply-possible *r* <>)
-      (sprout *r* <>)
-      (apply-happens *r* <>)
-      (filter-iset-for-move
-        *r* <>
-        'ggp-rules::player
-        'ggp-rules::wait)
-      (filter-iset-for-percepts
-        *r* <>
-        'ggp-rules::player
-        '((ggp-rules::does ggp-rules::player ggp-rules::wait)))
-      (compute-next-iset *r* <>)
-
-      (apply-possible *r* <>)
-      (sprout *r* <>)
-
-      ;; (dump-iset *r* <>)
-      (pr (scully.zdd::zdd-node-count <>))
-      ;; (draw-zdd *r* <>)
-      (no <>)
-      )))
--- a/src/rule-trees.lisp	Wed May 17 13:36:42 2017 +0000
+++ b/src/rule-trees.lisp	Wed May 17 13:36:59 2017 +0000
@@ -89,6 +89,21 @@
                         (recur (append (mapcar #'rest disallows) ignores)))))))))
 
 
+(defun rule-tree-size (tree)
+  (adt:match rule-tree tree
+    (bottom 1)
+    ((top _) 1)
+    ((node _ hi lo) (+ 1
+                       (rule-tree-size hi)
+                       (rule-tree-size lo)))))
+
+(defun head (tree)
+  (adt:match rule-tree tree
+    (bottom nil)
+    ((top term) term)
+    ((node _ hi lo) (or (head hi) (head lo)))))
+
+
 ;;;; Scratch ------------------------------------------------------------------
 (defparameter *rule* '(
                        (500 1 2 (ggp-rules::not 3))
--- a/src/terms.lisp	Wed May 17 13:36:42 2017 +0000
+++ b/src/terms.lisp	Wed May 17 13:36:59 2017 +0000
@@ -1,6 +1,15 @@
 (in-package :scully.terms)
 (in-readtable :fare-quasiquote)
 
+;;;; Shuffling ----------------------------------------------------------------
+(defparameter *shuffle-variables* nil)
+
+(defun optionally-shuffle (sequence)
+  (if *shuffle-variables*
+    (shuffle (copy-seq sequence))
+    sequence))
+
+
 ;;;; Overview -----------------------------------------------------------------
 ;;; We start with a set of grounded rules like: ((next bar) x y (true foo)).
 ;;;
@@ -24,7 +33,7 @@
 
 
 ;;;; Dependency Graph ---------------------------------------------------------
-(defun build-dependency-graph (rules &key includep)
+(defun build-dependency-graph (rules &key includep flip?)
   "Build a dependency graph of the given `rules`.
 
   All rule heads will be included as vertices.
@@ -33,6 +42,9 @@
   `(funcall includep term)` returns `t`.  If `includep` is `nil` all
   dependencies will be included.
 
+  If `flip?` is true the dependencies will be in the opposite direction
+  (bodyterm -> head).
+
   Only body terms upon which there is a dependency will be included in the graph
   -- if a body term is discarded by `includep` there will be no vertex for it.
 
@@ -41,7 +53,9 @@
     (labels
         ((mark-dependency (head dep)
            (digraph:insert-vertex graph dep)
-           (digraph:insert-edge graph head dep))
+           (if flip?
+             (digraph:insert-edge graph dep head)
+             (digraph:insert-edge graph head dep)))
          (mark-dependencies (head body)
            (digraph:insert-vertex graph head)
            (iterate (for b :in body)
@@ -176,7 +190,7 @@
 
 
 ;;;; Stratification -----------------------------------------------------------
-(defun build-single-layer-dependency-graph (rules)
+(defun build-negation-dependency-graph (rules)
   (let* ((layer-heads (remove-duplicates (mapcar #'rule-head rules)
                                          :test #'equal)))
     (build-dependency-graph
@@ -186,15 +200,52 @@
                        (member (bare-term body-term) layer-heads
                                :test #'equal))))))
 
+(defun build-reverse-dependency-graph (rules)
+  (let* ((layer-heads (remove-duplicates (mapcar #'rule-head rules)
+                                         :test #'equal)))
+    (build-dependency-graph
+      rules
+      :includep (lambda (body-term)
+                  (member (bare-term body-term) layer-heads
+                          :test #'equal))
+      :flip? t)))
+
+(defun remove-vertices (digraph vertices)
+  (dolist (v vertices)
+    (digraph:remove-vertex digraph v)))
+
+
+(defun find-reach (digraph start-vertices)
+  (iterate
+    (for start :in start-vertices)
+    (unioning (digraph:map-depth-first #'identity digraph start)
+              :test #'equal)))
+
+(defun nonleafs (digraph)
+  (remove-if (curry #'digraph::leafp digraph)
+             (digraph:vertices digraph)))
+
+(defun find-next-stratum (all-dependencies neg-dependencies)
+  (let* ((immediately-ineligible (nonleafs neg-dependencies))
+         (ineligible (find-reach all-dependencies immediately-ineligible))
+         (stratum (set-difference (digraph:vertices all-dependencies)
+                                  ineligible)))
+    (remove-vertices all-dependencies stratum)
+    (remove-vertices neg-dependencies stratum)
+    stratum))
+
 (defun stratify-layer (rules)
   "Stratify a single layer of rules into a list of strata."
   (iterate
-    (with dependencies = (build-single-layer-dependency-graph rules))
+    (with all-dependencies = (build-reverse-dependency-graph rules))
+    (with neg-dependencies = (build-negation-dependency-graph rules))
     (with remaining = rules)
     (until (null remaining))
 
-    (for next-heads = (digraph:leafs dependencies))
+    (for next-heads = (find-next-stratum all-dependencies neg-dependencies))
     (when (null next-heads)
+      (digraph.dot:draw all-dependencies :filename "digraph-all.png")
+      (digraph.dot:draw neg-dependencies :filename "digraph-neg.png")
       (error "Cycle in negations detected!"))
 
     (for stratum = (remove-if-not (lambda (head)
@@ -203,10 +254,7 @@
                                   :key #'rule-head))
     (collect stratum)
 
-    (setf remaining (set-difference remaining stratum :test #'equal))
-
-    (dolist (head next-heads)
-      (digraph:remove-vertex dependencies head))))
+    (setf remaining (set-difference remaining stratum :test #'equal))))
 
 
 ;;;; Intra-Layer Ordering -----------------------------------------------------
@@ -223,6 +271,7 @@
              (remove-duplicates <> :test #'equal))))
     (-<> strata
       (mapcar #'heads-in-stratum <>)
+      (mapcar #'optionally-shuffle <>)
       (flatten-once <>))))
 
 (defun extract-rules-for-layer (layers rules layer-key)
@@ -240,7 +289,8 @@
 (defun order-layer (layer-terms layer-strata)
   "Return a list of all terms in the layer in the proper order."
   (let* ((strata-terms (sort-and-flatten-strata layer-strata))
-         (leftovers (set-difference layer-terms strata-terms :test #'equal)))
+         (leftovers (optionally-shuffle
+                      (set-difference layer-terms strata-terms :test #'equal))))
     (append leftovers strata-terms)))
 
 
@@ -259,7 +309,16 @@
 
 (defun sort-does-layer (does-terms)
   "Return a fresh list of the does terms, sorted correctly."
-  (sort (copy-seq does-terms) #'symbol< :key #'second))
+  ;; (sort (copy-seq does-terms) #'symbol< :key #'second)
+  (-<> does-terms
+    (group-by #'second <> :test #'equal)
+    hash-table-values
+    (sort <> #'symbol< :key #'(lambda (role-terms)
+                                (-<> role-terms ; ((does KEY ...) ...)
+                                  first
+                                  second)))
+    (mapcar #'optionally-shuffle <>)
+    flatten-once))
 
 
 (defun order-terms (rules)
@@ -336,30 +395,10 @@
 
 
 ;;;; Scratch ------------------------------------------------------------------
-(defparameter *rules*
-  '(
-    (ggp-rules::<= x (ggp-rules::true a))
-    (ggp-rules::<= x (ggp-rules::true b))
-    (ggp-rules::<= (ggp-rules::next a)
-                   (ggp-rules::true foo))
-    (ggp-rules::<= z (ggp-rules::does c x))
-    (ggp-rules::<= (ggp-rules::next b)
-                   (ggp-rules::not z))
-    ))
-
-(defun print-strata (strata)
-  (iterate (for i :from 0)
-           (for stratum :in strata)
-           (format t "STRATUM ~D:~%~{    ~S~%~}~2%"
-                   i stratum)))
-
-(defun test ()
-  (-<> *rules*
-    (normalize-rules <>)
-    (integerize-rules <>)
-    (nth 2 <>)
-    ;; (pr <>)
-    (print-strata <>)
-    ;; (rest <>)
-    ;; (map nil #'print-hash-table <>)
-    (no <>)))
+;; (map nil #'pr (stratify-layer '(
+;;                                 (a b (ggp-rules::not c))
+;;                                 (c (ggp-rules::not d))
+;;                                 (d e)
+;;                                 (e d)
+;;                                 (b)
+;;                                 )))
--- a/vendor/make-quickutils.lisp	Wed May 17 13:36:42 2017 +0000
+++ b/vendor/make-quickutils.lisp	Wed May 17 13:36:59 2017 +0000
@@ -19,8 +19,10 @@
                :map-tree
                :mkstr
                :once-only
+               :partition-if
                :rcurry
                :set-equal
+               :shuffle
                :subdivide
                :symb
                :with-gensyms
--- a/vendor/quickutils.lisp	Wed May 17 13:36:42 2017 +0000
+++ b/vendor/quickutils.lisp	Wed May 17 13:36:59 2017 +0000
@@ -2,7 +2,7 @@
 ;;;; See http://quickutil.org for details.
 
 ;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :FLATTEN-ONCE :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT :MAP-TREE :MKSTR :ONCE-ONLY :RCURRY :SET-EQUAL :SUBDIVIDE :SYMB :WITH-GENSYMS :WITH-OUTPUT-TO-FILE :WRITE-STRING-INTO-FILE :YES-NO) :ensure-package T :package "SCULLY.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :FLATTEN-ONCE :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT :MAP-TREE :MKSTR :ONCE-ONLY :PARTITION-IF :RCURRY :SET-EQUAL :SHUFFLE :SUBDIVIDE :SYMB :WITH-GENSYMS :WITH-OUTPUT-TO-FILE :WRITE-STRING-INTO-FILE :YES-NO) :ensure-package T :package "SCULLY.QUICKUTILS")
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package "SCULLY.QUICKUTILS")
@@ -21,7 +21,9 @@
                                          :HASH-TABLE-KEYS :MAPHASH-VALUES
                                          :HASH-TABLE-VALUES :MAPPEND
                                          :MAP-PRODUCT :MAP-TREE :MKSTR
-                                         :ONCE-ONLY :RCURRY :SET-EQUAL
+                                         :ONCE-ONLY :PARTITION-IF :RCURRY
+                                         :SET-EQUAL :SAFE-ENDP :CIRCULAR-LIST
+                                         :PROPER-LIST-LENGTH/LAST-CAR :SHUFFLE
                                          :SUBDIVIDE :SYMB :STRING-DESIGNATOR
                                          :WITH-GENSYMS :WITH-OPEN-FILE*
                                          :WITH-OUTPUT-TO-FILE
@@ -331,6 +333,27 @@
                ,@forms)))))
   
 
+  (defun partition-if (f seq)
+    "Given a predicate F, partition SEQ into two sublists, the first
+of which has elements that satisfy F, the second which do not."
+    (let ((yes nil)
+          (no nil))
+      (map nil
+           #'(lambda (x)
+               (if (funcall f x)
+                   (push x yes)
+                   (push x no)))
+           seq)
+      (values yes no)))
+  
+  (defun partition-if-not (f seq)
+    "Partition SEQ into two sublists, the first whose elements do not
+satisfy the predicate F, and the second whose elements do."
+    (multiple-value-bind (yes no)
+        (partition-if f seq)
+      (values no yes)))
+  
+
   (defun rcurry (function &rest arguments)
     "Returns a function that applies the arguments it is called
 with and `arguments` to `function`."
@@ -354,6 +377,117 @@
                  (return nil))))))
   
 
+  (declaim (inline safe-endp))
+  (defun safe-endp (x)
+    (declare (optimize safety))
+    (endp x))
+  
+
+  (defun circular-list (&rest elements)
+    "Creates a circular list of ELEMENTS."
+    (let ((cycle (copy-list elements)))
+      (nconc cycle cycle)))
+
+  (defun circular-list-p (object)
+    "Returns true if OBJECT is a circular list, NIL otherwise."
+    (and (listp object)
+         (do ((fast object (cddr fast))
+              (slow (cons (car object) (cdr object)) (cdr slow)))
+             (nil)
+           (unless (and (consp fast) (listp (cdr fast)))
+             (return nil))
+           (when (eq fast slow)
+             (return t)))))
+  
+  (defun make-circular-list (length &key initial-element)
+    "Creates a circular list of LENGTH with the given INITIAL-ELEMENT."
+    (let ((cycle (make-list length :initial-element initial-element)))
+      (nconc cycle cycle)))
+
+  (deftype circular-list ()
+    "Type designator for circular lists. Implemented as a SATISFIES type, so not
+recommended for performance intensive use. Main usefullness as the
+expected-type designator of a TYPE-ERROR."
+    `(satisfies circular-list-p))
+  
+
+  (defun circular-list-error (list)
+    (error 'type-error
+           :datum list
+           :expected-type '(and list (not circular-list))))
+  
+  (macrolet ((def (name lambda-list doc step declare ret1 ret2)
+               (assert (member 'list lambda-list))
+               `(defun ,name ,lambda-list
+                  ,doc
+                  (do ((last list fast)
+                       (fast list (cddr fast))
+                       (slow (cons (car list) (cdr list)) (cdr slow))
+                       ,@(when step (list step)))
+                      (nil)
+                    (declare (dynamic-extent slow) ,@(when declare (list declare))
+                             (ignorable last))
+                    (when (safe-endp fast)
+                      (return ,ret1))
+                    (when (safe-endp (cdr fast))
+                      (return ,ret2))
+                    (when (eq fast slow)
+                      (circular-list-error list))))))
+    (def proper-list-length (list)
+      "Returns length of LIST, signalling an error if it is not a proper list."
+      (n 1 (+ n 2))
+      ;; KLUDGE: Most implementations don't actually support lists with bignum
+      ;; elements -- and this is WAY faster on most implementations then declaring
+      ;; N to be an UNSIGNED-BYTE.
+      (fixnum n)
+      (1- n)
+      n)
+
+    (def lastcar (list)
+      "Returns the last element of LIST. Signals a type-error if LIST is not a
+proper list."
+      nil
+      nil
+      (cadr last)
+      (car fast))
+
+    (def (setf lastcar) (object list)
+      "Sets the last element of LIST. Signals a type-error if LIST is not a proper
+list."
+      nil
+      nil
+      (setf (cadr last) object)
+      (setf (car fast) object)))
+  
+
+  (defun shuffle (sequence &key (start 0) end)
+    "Returns a random permutation of `sequence` bounded by `start` and `end`.
+Original sequece may be destructively modified, and share storage with
+the original one. Signals an error if `sequence` is not a proper
+sequence."
+    (declare (type fixnum start)
+             (type (or fixnum null) end))
+    (etypecase sequence
+      (list
+       (let* ((end (or end (proper-list-length sequence)))
+              (n (- end start)))
+         (do ((tail (nthcdr start sequence) (cdr tail)))
+             ((zerop n))
+           (rotatef (car tail) (car (nthcdr (random n) tail)))
+           (decf n))))
+      (vector
+       (let ((end (or end (length sequence))))
+         (loop for i from start below end
+               do (rotatef (aref sequence i)
+                           (aref sequence (+ i (random (- end i))))))))
+      (sequence
+       (let ((end (or end (length sequence))))
+         (loop for i from (- end 1) downto start
+               do (rotatef (elt sequence i)
+                           (elt sequence (+ i (random (- end i)))))))))
+    sequence)
+  
+
   (defun subdivide (sequence chunk-size)
     "Split `sequence` into subsequences of size `chunk-size`."
     (check-type sequence sequence)
@@ -489,8 +623,9 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(compose copy-hash-table curry ensure-boolean ensure-gethash
             ensure-list extremum flatten-once hash-table-alist hash-table-keys
-            hash-table-values map-product map-tree mkstr once-only rcurry
-            set-equal subdivide symb with-gensyms with-unique-names
-            with-output-to-file write-string-into-file yes no)))
+            hash-table-values map-product map-tree mkstr once-only partition-if
+            partition-if-not rcurry set-equal shuffle subdivide symb
+            with-gensyms with-unique-names with-output-to-file
+            write-string-into-file yes no)))
 
 ;;;; END OF quickutils.lisp ;;;;