--- 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 ;;;;