GopherProxy

	tsequences.lisp - clic - Clic is an command line interactive client for gopher …
	git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/
	Log
	Files
	Refs
	Tags
	LICENSE
	---
	tsequences.lisp (24604B)
	---
	1 (in-package :alexandria)
	2
	3 ;; Make these inlinable by declaiming them INLINE here and some of them
	4 ;; NOTINLINE at the end of the file. Exclude functions that have a compi…
	5 ;; macro, because NOTINLINE is required to prevent compiler-macro expans…
	6 (declaim (inline copy-sequence sequence-of-length-p))
	7
	8 (defun sequence-of-length-p (sequence length)
	9 "Return true if SEQUENCE is a sequence of length LENGTH. Signals an er…
	10 SEQUENCE is not a sequence. Returns FALSE for circular lists."
	11 (declare (type array-index length)
	12 #-lispworks (inline length)
	13 (optimize speed))
	14 (etypecase sequence
	15 (null
	16 (zerop length))
	17 (cons
	18 (let ((n (1- length)))
	19 (unless (minusp n)
	20 (let ((tail (nthcdr n sequence)))
	21 (and tail
	22 (null (cdr tail)))))))
	23 (vector
	24 (= length (length sequence)))
	25 (sequence
	26 (= length (length sequence)))))
	27
	28 (defun rotate-tail-to-head (sequence n)
	29 (declare (type (integer 1) n))
	30 (if (listp sequence)
	31 (let ((m (mod n (proper-list-length sequence))))
	32 (if (null (cdr sequence))
	33 sequence
	34 (let* ((tail (last sequence (+ m 1)))
	35 (last (cdr tail)))
	36 (setf (cdr tail) nil)
	37 (nconc last sequence))))
	38 (let* ((len (length sequence))
	39 (m (mod n len))
	40 (tail (subseq sequence (- len m))))
	41 (replace sequence sequence :start1 m :start2 0)
	42 (replace sequence tail)
	43 sequence)))
	44
	45 (defun rotate-head-to-tail (sequence n)
	46 (declare (type (integer 1) n))
	47 (if (listp sequence)
	48 (let ((m (mod (1- n) (proper-list-length sequence))))
	49 (if (null (cdr sequence))
	50 sequence
	51 (let* ((headtail (nthcdr m sequence))
	52 (tail (cdr headtail)))
	53 (setf (cdr headtail) nil)
	54 (nconc tail sequence))))
	55 (let* ((len (length sequence))
	56 (m (mod n len))
	57 (head (subseq sequence 0 m)))
	58 (replace sequence sequence :start1 0 :start2 m)
	59 (replace sequence head :start1 (- len m))
	60 sequence)))
	61
	62 (defun rotate (sequence &optional (n 1))
	63 "Returns a sequence of the same type as SEQUENCE, with the elements of
	64 SEQUENCE rotated by N: N elements are moved from the end of the sequence…
	65 the front if N is positive, and -N elements moved from the front to the …
	66 N is negative. SEQUENCE must be a proper sequence. N must be an integer,
	67 defaulting to 1.
	68
	69 If absolute value of N is greater then the length of the sequence, the r…
	70 are identical to calling ROTATE with
	71
	72 (* (signum n) (mod n (length sequence))).
	73
	74 Note: the original sequence may be destructively altered, and result seq…
	75 share structure with it."
	76 (if (plusp n)
	77 (rotate-tail-to-head sequence n)
	78 (if (minusp n)
	79 (rotate-head-to-tail sequence (- n))
	80 sequence)))
	81
	82 (defun shuffle (sequence &key (start 0) end)
	83 "Returns a random permutation of SEQUENCE bounded by START and END.
	84 Original sequence may be destructively modified, and (if it contains
	85 CONS or lists themselv) share storage with the original one.
	86 Signals an error if SEQUENCE is not a proper sequence."
	87 (declare (type fixnum start)
	88 (type (or fixnum null) end))
	89 (etypecase sequence
	90 (list
	91 (let* ((end (or end (proper-list-length sequence)))
	92 (n (- end start)))
	93 (do ((tail (nthcdr start sequence) (cdr tail)))
	94 ((zerop n))
	95 (rotatef (car tail) (car (nthcdr (random n) tail)))
	96 (decf n))))
	97 (vector
	98 (let ((end (or end (length sequence))))
	99 (loop for i from start below end
	100 do (rotatef (aref sequence i)
	101 (aref sequence (+ i (random (- end i))))))))
	102 (sequence
	103 (let ((end (or end (length sequence))))
	104 (loop for i from (- end 1) downto start
	105 do (rotatef (elt sequence i)
	106 (elt sequence (+ i (random (- end i)))))))))
	107 sequence)
	108
	109 (defun random-elt (sequence &key (start 0) end)
	110 "Returns a random element from SEQUENCE bounded by START and END. Sign…
	111 error if the SEQUENCE is not a proper non-empty sequence, or if END and …
	112 are not proper bounding index designators for SEQUENCE."
	113 (declare (sequence sequence) (fixnum start) (type (or fixnum null) end…
	114 (let* ((size (if (listp sequence)
	115 (proper-list-length sequence)
	116 (length sequence)))
	117 (end2 (or end size)))
	118 (cond ((zerop size)
	119 (error 'type-error
	120 :datum sequence
	121 :expected-type `(and sequence (not (satisfies emptyp))…
	122 ((not (and (<= 0 start) (< start end2) (<= end2 size)))
	123 (error 'simple-type-error
	124 :datum (cons start end)
	125 :expected-type `(cons (integer 0 (,end2))
	126 (or null (integer (,start) ,size…
	127 :format-control "~@<~S and ~S are not valid bounding i…
	128 a sequence of length ~S.~:@>"
	129 :format-arguments (list start end size)))
	130 (t
	131 (let ((index (+ start (random (- end2 start)))))
	132 (elt sequence index))))))
	133
	134 (declaim (inline remove/swapped-arguments))
	135 (defun remove/swapped-arguments (sequence item &rest keyword-arguments)
	136 (apply #'remove item sequence keyword-arguments))
	137
	138 (define-modify-macro removef (item &rest keyword-arguments)
	139 remove/swapped-arguments
	140 "Modify-macro for REMOVE. Sets place designated by the first argument …
	141 the result of calling REMOVE with ITEM, place, and the KEYWORD-ARGUMENTS…
	142
	143 (declaim (inline delete/swapped-arguments))
	144 (defun delete/swapped-arguments (sequence item &rest keyword-arguments)
	145 (apply #'delete item sequence keyword-arguments))
	146
	147 (define-modify-macro deletef (item &rest keyword-arguments)
	148 delete/swapped-arguments
	149 "Modify-macro for DELETE. Sets place designated by the first argument …
	150 the result of calling DELETE with ITEM, place, and the KEYWORD-ARGUMENTS…
	151
	152 (deftype proper-sequence ()
	153 "Type designator for proper sequences, that is proper lists and sequen…
	154 that are not lists."
	155 `(or proper-list
	156 (and (not list) sequence)))
	157
	158 (eval-when (:compile-toplevel :load-toplevel :execute)
	159 (when (and (find-package '#:sequence)
	160 (find-symbol (string '#:emptyp) '#:sequence))
	161 (pushnew 'sequence-emptyp features)))
	162
	163 #-alexandria::sequence-emptyp
	164 (defun emptyp (sequence)
	165 "Returns true if SEQUENCE is an empty sequence. Signals an error if SE…
	166 is not a sequence."
	167 (etypecase sequence
	168 (list (null sequence))
	169 (sequence (zerop (length sequence)))))
	170
	171 #+alexandria::sequence-emptyp
	172 (declaim (ftype (function (sequence) (values boolean &optional)) emptyp))
	173 #+alexandria::sequence-emptyp
	174 (setf (symbol-function 'emptyp) (symbol-function 'sequence:emptyp))
	175 #+alexandria::sequence-emptyp
	176 (define-compiler-macro emptyp (sequence)
	177 `(sequence:emptyp ,sequence))
	178
	179 (defun length= (&rest sequences)
	180 "Takes any number of sequences or integers in any order. Returns true …
	181 the length of all the sequences and the integers are equal. Hint: there'…
	182 compiler macro that expands into more efficient code if the first argume…
	183 is a literal integer."
	184 (declare (dynamic-extent sequences)
	185 (inline sequence-of-length-p)
	186 (optimize speed))
	187 (unless (cdr sequences)
	188 (error "You must call LENGTH= with at least two arguments"))
	189 ;; There's room for optimization here: multiple list arguments could be
	190 ;; traversed in parallel.
	191 (let* ((first (pop sequences))
	192 (current (if (integerp first)
	193 first
	194 (length first))))
	195 (declare (type array-index current))
	196 (dolist (el sequences)
	197 (if (integerp el)
	198 (unless (= el current)
	199 (return-from length= nil))
	200 (unless (sequence-of-length-p el current)
	201 (return-from length= nil)))))
	202 t)
	203
	204 (define-compiler-macro length= (&whole form length &rest sequences)
	205 (cond
	206 ((zerop (length sequences))
	207 form)
	208 (t
	209 (let ((optimizedp (integerp length)))
	210 (with-unique-names (tmp current)
	211 (declare (ignorable current))
	212 `(locally
	213 (declare (inline sequence-of-length-p))
	214 (let ((,tmp)
	215 ,@(unless optimizedp
	216 `((,current ,length))))
	217 ,@(unless optimizedp
	218 `((unless (integerp ,current)
	219 (setf ,current (length ,current)))))
	220 (and
	221 ,@(loop
	222 :for sequence :in sequences
	223 :collect `(progn
	224 (setf ,tmp ,sequence)
	225 (if (integerp ,tmp)
	226 (= ,tmp ,(if optimizedp
	227 length
	228 current))
	229 (sequence-of-length-p ,tmp ,(if opti…
	230 leng…
	231 curr…
	232
	233 (defun copy-sequence (type sequence)
	234 "Returns a fresh sequence of TYPE, which has the same elements as
	235 SEQUENCE."
	236 (if (typep sequence type)
	237 (copy-seq sequence)
	238 (coerce sequence type)))
	239
	240 (defun first-elt (sequence)
	241 "Returns the first element of SEQUENCE. Signals a type-error if SEQUEN…
	242 not a sequence, or is an empty sequence."
	243 ;; Can't just directly use ELT, as it is not guaranteed to signal the
	244 ;; type-error.
	245 (cond ((consp sequence)
	246 (car sequence))
	247 ((and (typep sequence 'sequence) (not (emptyp sequence)))
	248 (elt sequence 0))
	249 (t
	250 (error 'type-error
	251 :datum sequence
	252 :expected-type '(and sequence (not (satisfies emptyp)))…
	253
	254 (defun (setf first-elt) (object sequence)
	255 "Sets the first element of SEQUENCE. Signals a type-error if SEQUENCE …
	256 not a sequence, is an empty sequence, or if OBJECT cannot be stored in S…
	257 ;; Can't just directly use ELT, as it is not guaranteed to signal the
	258 ;; type-error.
	259 (cond ((consp sequence)
	260 (setf (car sequence) object))
	261 ((and (typep sequence 'sequence) (not (emptyp sequence)))
	262 (setf (elt sequence 0) object))
	263 (t
	264 (error 'type-error
	265 :datum sequence
	266 :expected-type '(and sequence (not (satisfies emptyp))))…
	267
	268 (defun last-elt (sequence)
	269 "Returns the last element of SEQUENCE. Signals a type-error if SEQUENC…
	270 not a proper sequence, or is an empty sequence."
	271 ;; Can't just directly use ELT, as it is not guaranteed to signal the
	272 ;; type-error.
	273 (let ((len 0))
	274 (cond ((consp sequence)
	275 (lastcar sequence))
	276 ((and (typep sequence '(and sequence (not list))) (plusp (setf…
	277 (elt sequence (1- len)))
	278 (t
	279 (error 'type-error
	280 :datum sequence
	281 :expected-type '(and proper-sequence (not (satisfies e…
	282
	283 (defun (setf last-elt) (object sequence)
	284 "Sets the last element of SEQUENCE. Signals a type-error if SEQUENCE i…
	285 sequence, is an empty sequence, or if OBJECT cannot be stored in SEQUENC…
	286 (let ((len 0))
	287 (cond ((consp sequence)
	288 (setf (lastcar sequence) object))
	289 ((and (typep sequence '(and sequence (not list))) (plusp (setf…
	290 (setf (elt sequence (1- len)) object))
	291 (t
	292 (error 'type-error
	293 :datum sequence
	294 :expected-type '(and proper-sequence (not (satisfies e…
	295
	296 (defun starts-with-subseq (prefix sequence &rest args
	297 &key
	298 (return-suffix nil return-suffix-supplied-p)
	299 &allow-other-keys)
	300 "Test whether the first elements of SEQUENCE are the same (as per TEST…
	301
	302 If RETURN-SUFFIX is T the function returns, as a second value, a
	303 sub-sequence or displaced array pointing to the sequence after PREFIX."
	304 (declare (dynamic-extent args))
	305 (let ((sequence-length (length sequence))
	306 (prefix-length (length prefix)))
	307 (when (< sequence-length prefix-length)
	308 (return-from starts-with-subseq (values nil nil)))
	309 (flet ((make-suffix (start)
	310 (when return-suffix
	311 (cond
	312 ((not (arrayp sequence))
	313 (if start
	314 (subseq sequence start)
	315 (subseq sequence 0 0)))
	316 ((not start)
	317 (make-array 0
	318 :element-type (array-element-type sequence)
	319 :adjustable nil))
	320 (t
	321 (make-array (- sequence-length start)
	322 :element-type (array-element-type sequence)
	323 :displaced-to sequence
	324 :displaced-index-offset start
	325 :adjustable nil))))))
	326 (let ((mismatch (apply #'mismatch prefix sequence
	327 (if return-suffix-supplied-p
	328 (remove-from-plist args :return-suffix)
	329 args))))
	330 (cond
	331 ((not mismatch)
	332 (values t (make-suffix nil)))
	333 ((= mismatch prefix-length)
	334 (values t (make-suffix mismatch)))
	335 (t
	336 (values nil nil)))))))
	337
	338 (defun ends-with-subseq (suffix sequence &key (test #'eql))
	339 "Test whether SEQUENCE ends with SUFFIX. In other words: return true if
	340 the last (length SUFFIX) elements of SEQUENCE are equal to SUFFIX."
	341 (let ((sequence-length (length sequence))
	342 (suffix-length (length suffix)))
	343 (when (< sequence-length suffix-length)
	344 ;; if SEQUENCE is shorter than SUFFIX, then SEQUENCE can't end wit…
	345 (return-from ends-with-subseq nil))
	346 (loop for sequence-index from (- sequence-length suffix-length) belo…
	347 for suffix-index from 0 below suffix-length
	348 when (not (funcall test (elt sequence sequence-index) (elt suf…
	349 do (return-from ends-with-subseq nil)
	350 finally (return t))))
	351
	352 (defun starts-with (object sequence &key (test #'eql) (key #'identity))
	353 "Returns true if SEQUENCE is a sequence whose first element is EQL to …
	354 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence."
	355 (let ((first-elt (typecase sequence
	356 (cons (car sequence))
	357 (sequence
	358 (if (emptyp sequence)
	359 (return-from starts-with nil)
	360 (elt sequence 0)))
	361 (t
	362 (return-from starts-with nil)))))
	363 (funcall test (funcall key first-elt) object)))
	364
	365 (defun ends-with (object sequence &key (test #'eql) (key #'identity))
	366 "Returns true if SEQUENCE is a sequence whose last element is EQL to O…
	367 Returns NIL if the SEQUENCE is not a sequence or is an empty sequence. S…
	368 an error if SEQUENCE is an improper list."
	369 (let ((last-elt (typecase sequence
	370 (cons
	371 (lastcar sequence)) ; signals for improper lists
	372 (sequence
	373 ;; Can't use last-elt, as that signals an error
	374 ;; for empty sequences
	375 (let ((len (length sequence)))
	376 (if (plusp len)
	377 (elt sequence (1- len))
	378 (return-from ends-with nil))))
	379 (t
	380 (return-from ends-with nil)))))
	381 (funcall test (funcall key last-elt) object)))
	382
	383 (defun map-combinations (function sequence &key (start 0) end length (co…
	384 "Calls FUNCTION with each combination of LENGTH constructable from the
	385 elements of the subsequence of SEQUENCE delimited by START and END. START
	386 defaults to 0, END to length of SEQUENCE, and LENGTH to the length of the
	387 delimited subsequence. (So unless LENGTH is specified there is only a si…
	388 combination, which has the same elements as the delimited subsequence.) …
	389 COPY is true (the default) each combination is freshly allocated. If COP…
	390 false all combinations are EQ to each other, in which case consequences …
	391 unspecified if a combination is modified by FUNCTION."
	392 (let* ((end (or end (length sequence)))
	393 (size (- end start))
	394 (length (or length size))
	395 (combination (subseq sequence 0 length))
	396 (function (ensure-function function)))
	397 (if (= length size)
	398 (funcall function combination)
	399 (flet ((call ()
	400 (funcall function (if copy
	401 (copy-seq combination)
	402 combination))))
	403 (etypecase sequence
	404 ;; When dealing with lists we prefer walking back and
	405 ;; forth instead of using indexes.
	406 (list
	407 (labels ((combine-list (c-tail o-tail)
	408 (if (not c-tail)
	409 (call)
	410 (do ((tail o-tail (cdr tail)))
	411 ((not tail))
	412 (setf (car c-tail) (car tail))
	413 (combine-list (cdr c-tail) (cdr tail))))))
	414 (combine-list combination (nthcdr start sequence))))
	415 (vector
	416 (labels ((combine (count start)
	417 (if (zerop count)
	418 (call)
	419 (loop for i from start below end
	420 do (let ((j (- count 1)))
	421 (setf (aref combination j) (aref …
	422 (combine j (+ i 1)))))))
	423 (combine length start)))
	424 (sequence
	425 (labels ((combine (count start)
	426 (if (zerop count)
	427 (call)
	428 (loop for i from start below end
	429 do (let ((j (- count 1)))
	430 (setf (elt combination j) (elt se…
	431 (combine j (+ i 1)))))))
	432 (combine length start)))))))
	433 sequence)
	434
	435 (defun map-permutations (function sequence &key (start 0) end length (co…
	436 "Calls function with each permutation of LENGTH constructable
	437 from the subsequence of SEQUENCE delimited by START and END. START
	438 defaults to 0, END to length of the sequence, and LENGTH to the
	439 length of the delimited subsequence."
	440 (let* ((end (or end (length sequence)))
	441 (size (- end start))
	442 (length (or length size)))
	443 (labels ((permute (seq n)
	444 (let ((n-1 (- n 1)))
	445 (if (zerop n-1)
	446 (funcall function (if copy
	447 (copy-seq seq)
	448 seq))
	449 (loop for i from 0 upto n-1
	450 do (permute seq n-1)
	451 (if (evenp n-1)
	452 (rotatef (elt seq 0) (elt seq n-1))
	453 (rotatef (elt seq i) (elt seq n-1)))))))
	454 (permute-sequence (seq)
	455 (permute seq length)))
	456 (if (= length size)
	457 ;; Things are simple if we need to just permute the
	458 ;; full START-END range.
	459 (permute-sequence (subseq sequence start end))
	460 ;; Otherwise we need to generate all the combinations
	461 ;; of LENGTH in the START-END range, and then permute
	462 ;; a copy of the result: can't permute the combination
	463 ;; directly, as they share structure with each other.
	464 (let ((permutation (subseq sequence 0 length)))
	465 (flet ((permute-combination (combination)
	466 (permute-sequence (replace permutation combination)…
	467 (declare (dynamic-extent #'permute-combination))
	468 (map-combinations #'permute-combination sequence
	469 :start start
	470 :end end
	471 :length length
	472 :copy nil)))))))
	473
	474 (defun map-derangements (function sequence &key (start 0) end (copy t))
	475 "Calls FUNCTION with each derangement of the subsequence of SEQUENCE d…
	476 by the bounding index designators START and END. Derangement is a permut…
	477 of the sequence where no element remains in place. SEQUENCE is not modif…
	478 but individual derangements are EQ to each other. Consequences are unspe…
	479 if calling FUNCTION modifies either the derangement or SEQUENCE."
	480 (let* ((end (or end (length sequence)))
	481 (size (- end start))
	482 ;; We don't really care about the elements here.
	483 (derangement (subseq sequence 0 size))
	484 ;; Bitvector that has 1 for elements that have been deranged.
	485 (mask (make-array size :element-type 'bit :initial-element 0)))
	486 (declare (dynamic-extent mask))
	487 ;; ad hoc algorith
	488 (labels ((derange (place n)
	489 ;; Perform one recursive step in deranging the
	490 ;; sequence: PLACE is index of the original sequence
	491 ;; to derange to another index, and N is the number of
	492 ;; indexes not yet deranged.
	493 (if (zerop n)
	494 (funcall function (if copy
	495 (copy-seq derangement)
	496 derangement))
	497 ;; Itarate over the indexes I of the subsequence to
	498 ;; derange: if I != PLACE and I has not yet been
	499 ;; deranged by an earlier call put the element from
	500 ;; PLACE to I, mark I as deranged, and recurse,
	501 ;; finally removing the mark.
	502 (loop for i from 0 below size
	503 do
	504 (unless (or (= place (+ i start)) (not (zerop (…
	505 (setf (elt derangement i) (elt sequence place)
	506 (bit mask i) 1)
	507 (derange (1+ place) (1- n))
	508 (setf (bit mask i) 0))))))
	509 (derange start size)
	510 sequence)))
	511
	512 (declaim (notinline sequence-of-length-p))
	513
	514 (defun extremum (sequence predicate &key key (start 0) end)
	515 "Returns the element of SEQUENCE that would appear first if the subseq…
	516 bounded by START and END was sorted using PREDICATE and KEY.
	517
	518 EXTREMUM determines the relationship between two elements of SEQUENCE by…
	519 the PREDICATE function. PREDICATE should return true if and only if the …
	520 argument is strictly less than the second one (in some appropriate sense…
	521 arguments X and Y are considered to be equal if (FUNCALL PREDICATE X Y)
	522 and (FUNCALL PREDICATE Y X) are both false.
	523
	524 The arguments to the PREDICATE function are computed from elements of SE…
	525 using the KEY function, if supplied. If KEY is not supplied or is NIL, t…
	526 sequence element itself is used.
	527
	528 If SEQUENCE is empty, NIL is returned."
	529 (let* ((pred-fun (ensure-function predicate))
	530 (key-fun (unless (or (not key) (eq key 'identity) (eq key #'ide…
	531 (ensure-function key)))
	532 (real-end (or end (length sequence))))
	533 (cond ((> real-end start)
	534 (if key-fun
	535 (flet ((reduce-keys (a b)
	536 (if (funcall pred-fun
	537 (funcall key-fun a)
	538 (funcall key-fun b))
	539 a
	540 b)))
	541 (declare (dynamic-extent #'reduce-keys))
	542 (reduce #'reduce-keys sequence :start start :end real-e…
	543 (flet ((reduce-elts (a b)
	544 (if (funcall pred-fun a b)
	545 a
	546 b)))
	547 (declare (dynamic-extent #'reduce-elts))
	548 (reduce #'reduce-elts sequence :start start :end real-e…
	549 ((= real-end start)
	550 nil)
	551 (t
	552 (error "Invalid bounding indexes for sequence of length ~S: ~…
	553 (length sequence)
	554 :start start
	555 :end end)))))