Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

[0f9724]: src / cllib / list.lisp Maximize Restore History

Download this file

list.lisp    168 lines (153 with data), 7.2 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
;;; Additional List Operations
;;;
;;; Copyright (C) 1997-2002, 2006-2008, 2013 by Sam Steingold
;;; This is Free Software, covered by the GNU GPL (v2+)
;;; See http://www.gnu.org/copyleft/gpl.html
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :cllib-base (translate-logical-pathname "clocc:src;cllib;base"))
;; `with-collect', `zero-len-p', `to-list', `filter'
(require :cllib-simple (translate-logical-pathname "cllib:simple")))
(in-package :cllib)
(export '(jumps count-jumps freqs
check-list-type check-list-values out-of-bounds-p
nsplit-list with-sublist with-nsplit call-on-split))
;;;
;;; {{{ misc
;;;
(defun jumps (seq &key (pred #'eql) (key #'value) args (what :both))
"Return the list of elements of the sequence SEQ whose KEY differs
from that of the previous element according to the predicate PRED.
ARGS (list) are passed to PRED after the previous and the current KEYs.
WHAT can be
:BOTH (list of conses of the previous and the next records,
:PREV (list of records before the jump) or
:NEXT (list of records after the jump).
Default is :BOTH."
(declare (sequence seq) (type (function (t t) t) pred)
(type (function (t) t) key))
(with-collect (collect)
(let (pkey prec)
(map nil (lambda (rec)
(let ((ckey (funcall key rec)))
(when (and pkey (apply pred pkey ckey args))
(collect (ecase what
(:both (cons prec rec))
(:prev prec)
(:next rec))))
(setq prec rec pkey ckey)))
seq))))
(defun count-jumps (seq &key (pred #'eql) (key #'value) args)
"Like `jumps', but only count the jumps.
Thus, (apply #'count-jumps args) == (length (apply #'jumps args))."
(declare (sequence seq) (type (function (t t) t) pred)
(type (function (t) t) key))
(let (pkey (res 0))
(declare (type index-t res))
(map nil (lambda (rec)
(let ((ckey (funcall key rec)))
(when (and pkey (apply pred pkey ckey args)) (incf res))
(setq pkey ckey)))
seq)
res))
(defun freqs (seq &key (test #'eql) (key #'identity))
"Return an alist of (num . freq) of elements of the SEQ.
The alist is sorted by decreasing frequencies. TEST defaults to `eql'."
(declare (sequence seq) (type (function (t t) t) test)
(type (function (t) t) key))
(unless (zero-len-p seq)
(sort
(reduce (lambda (res el)
(let ((fi (assoc el res :test test)))
(cond (fi (incf (cdr fi)) res) ((acons el 1 res)))))
seq :key key :initial-value nil)
#'> :key #'cdr)))
;;;
;;; }}}{{{ splitting, sublists
;;;
(defun nsplit-list (lst &key (pred #'eql) (key #'identity) (obj nil objp))
"Return the list of sublists of LST, separated using PRED. Destructive.
When (funcall pred a0 a1) is nil, a1 starts another sublist,
i.e., in all sublists KEY is the same according to PRED.
When OBJ is given, it serves as separator and is omitted from the list."
(declare (list lst) (type (function (t t) t) pred)
(type (or function fixnum symbol) key))
(when (symbolp key) (setq key (fdefinition key)))
(unless lst (return-from nsplit-list nil))
(if objp
(do ((ll lst) (bb lst) res)
((null ll) (nreverse (if bb (cons bb res) res)))
(if (funcall pred (funcall key (cadr ll)) obj)
(setf res (cons bb res) bb (cddr ll) (cdr ll) nil ll bb)
(setq ll (cdr ll))))
(typecase key
(function
(do ((ll lst) (k0 (funcall key (first lst)) k1) k1 (res (list lst)))
((endp (cdr ll)) (nreverse res))
(setq k1 (funcall key (second ll)))
(cond ((not (funcall pred k0 k1))
(push (cdr ll) res)
(setf (cdr ll) nil)
(setq ll (car res)))
(t (setq ll (cdr ll))))))
(fixnum
(decf key)
(do* ((ll lst) ta res) ((endp ll) (nreverse res))
(push ll res) (setq ta (nthcdr key ll) ll (cdr ta))
(when ta (setf (cdr ta) nil))))
(t (error 'case-error :proc 'nsplit-list :args
(list 'key key 'function 'fixnum))))))
(defmacro with-sublist ((newl oldl e0 e1 &key (key '#'identity) (test '#'eql))
&body body)
"Evaluate BODY, binding the NEWL to the sublist of OLDL from E0 to E1
inclusively. KEY and TEST have the usual meaning and default.
BODY may not modify the list structure of NEWL, or else!
Also, do NOT try to return a cons from NEWL. You'd be surprised!"
(with-gensyms ("WSL-" tt kk)
`(let* (,kk (,newl (member-if (lambda (el) (setq ,kk (funcall ,key el))
(or (funcall ,test ,kk ,e0)
(funcall ,test ,kk ,e1))) ,oldl))
(,tt (member (if (funcall ,test ,kk ,e0) ,e1 ,e0) ,newl :key
,key :test ,test)))
(unwind-protect
(progn (when ,tt (setq ,kk (cdr ,tt)) (setf (cdr ,tt) nil))
,@body)
(when ,tt (setf (cdr ,tt) ,kk))))))
(defmacro with-nsplit ((newl oldl &rest split-args) &body body)
"Evaluate BODY, binding NEWL to the splitting of OLDL.
BODY may not modify the list structure of NEWL, or else!
Also, do NOT try to return a cons from NEWL. You'd be surprised!"
`(let (,newl)
(unwind-protect
(progn (setq ,newl (nsplit-list ,oldl ,@split-args)) ,@body)
(setq ,oldl (apply #'nconc ,newl)))))
(defun call-on-split (lst func &rest args &key (split-key #'value)
(split-pred #'eql) min-len &allow-other-keys)
"Call FUNC on all sublists of LST generated by `nsplit-list'."
(declare (list lst) (function func) (type (or null fixnum) min-len))
(setq args (remove-plist args :split-key :split-pred :min-len))
(with-nsplit (nl lst :key split-key :pred split-pred)
(let ((ii -1) (cnt? (typep split-key 'fixnum)))
(declare (type (signed-byte 21) ii))
(filter nl (lambda (ll) (or (null min-len) (> (length ll) min-len)))
(lambda (ll)
(cons (if cnt? (incf ii) (funcall split-key (car ll)))
(apply func ll args)))))))
(defun batch-map (list batch-size function)
"Call FUNCTION on sublists of LIST of size BATCH-SIZE.
Temporarily modifies LIST to avoid unnecessary consing.
Returns the list of return values of FUNCTION."
;; http://stackoverflow.com/questions/17198677/process-n-items-from-a-list-at-a-time-in-lisp
;; this is the optimized version of
;; (loop for tail on list by (lambda (l) (nthcdr batch-size l))
;; collect (funcall function (subseq tail 0 (min (length tail) batch-size))))
(do ((tail list (cdr end)) end ret (bs1 (1- batch-size)))
((endp tail) (nreverse ret))
(setq end (nthcdr bs1 tail))
(if (consp end)
(let ((next (cdr end)))
(setf (cdr end) nil)
(unwind-protect (push (funcall function tail) ret)
(setf (cdr end) next)))
(push (funcall function tail) ret))))
(provide :cllib-list)
;;; list.lisp ends here