# HG changeset patch # User Steve Losh # Date 1495028219 0 # Node ID fd5861c11c5f8b7b4f90dd7692c5ab103639892e # Parent 374014ff34a9b4f2192d041a60accfc8fef47043 Add rule shuffling, new stratification procedure diff -r 374014ff34a9 -r fd5861c11c5f gdl/stratego.gdl --- 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)) diff -r 374014ff34a9 -r fd5861c11c5f src/graphviz.lisp --- 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) diff -r 374014ff34a9 -r fd5861c11c5f src/grounders/fluxplayer.lisp --- 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")) diff -r 374014ff34a9 -r fd5861c11c5f src/players/random-ii.lisp --- 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...~%") diff -r 374014ff34a9 -r fd5861c11c5f src/players/random-zdd.lisp --- 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) diff -r 374014ff34a9 -r fd5861c11c5f src/reasoners/zdd.lisp --- 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 <>) - ))) diff -r 374014ff34a9 -r fd5861c11c5f src/rule-trees.lisp --- 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)) diff -r 374014ff34a9 -r fd5861c11c5f src/terms.lisp --- 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) +;; ))) diff -r 374014ff34a9 -r fd5861c11c5f vendor/make-quickutils.lisp --- 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 diff -r 374014ff34a9 -r fd5861c11c5f vendor/quickutils.lisp --- 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 ;;;;