/[gcl]/gcl/lsp/gcl_seqlib.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_seqlib.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:06 2003 UTC
# Line 0  Line 1 
1    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
2    
3    ;; This file is part of GNU Common Lisp, herein referred to as GCL
4    ;;
5    ;; GCL is free software; you can redistribute it and/or modify it under
6    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
7    ;; the Free Software Foundation; either version 2, or (at your option)
8    ;; any later version.
9    ;;
10    ;; GCL is distributed in the hope that it will be useful, but WITHOUT
11    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
13    ;; License for more details.
14    ;;
15    ;; You should have received a copy of the GNU Library General Public License
16    ;; along with GCL; see the file COPYING.  If not, write to the Free Software
17    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
18    
19    
20    ;;;;   seqlib.lsp
21    ;;;;
22    ;;;;                           sequence routines
23    
24    
25    (in-package 'lisp)
26    
27    
28    (export '(reduce fill replace
29              remove remove-if remove-if-not
30              delete delete-if delete-if-not
31              count count-if count-if-not
32              substitute substitute-if substitute-if-not
33              nsubstitute nsubstitute-if nsubstitute-if-not
34              find find-if find-if-not
35              position position-if position-if-not
36              remove-duplicates delete-duplicates
37              mismatch search
38              with-hash-table-iterator
39              sort stable-sort merge map-into))
40    
41    
42    (in-package 'system)
43    
44    
45    (proclaim '(optimize (safety 2) (space 3)))
46    
47    
48    (proclaim '(function seqtype (t) t))
49    (defun seqtype (sequence)
50      (cond ((listp sequence) 'list)
51            ((stringp sequence) 'string)
52            ((bit-vector-p sequence) 'bit-vector)
53            ((vectorp sequence) (list 'array (array-element-type sequence)))
54            (t (error "~S is not a sequence." sequence))))
55    
56    (proclaim '(function call-test (t t t t) t))
57    (defun call-test (test test-not item keyx)
58      (cond (test (funcall test item keyx))
59            (test-not (not (funcall test-not item keyx)))
60            (t (eql item keyx))))
61    
62    
63    (proclaim '(function check-seq-start-end (t t) t))
64    (defun check-seq-start-end (start end)
65      (unless (and (si:fixnump start) (si:fixnump end))
66              (error "Fixnum expected."))
67      (when (> (the fixnum start) (the fixnum end))
68            (error "START is greater than END.")))
69    
70    (proclaim '(function test-error() t))
71    (defun test-error()
72      (error "both test and test not supplied"))
73    
74    (defun bad-seq-limit (x &optional y)
75      (specific-error :wrong-type-argument "bad sequence limit ~a" (if y (list x y) x)))
76    
77    
78    (eval-when (compile eval)
79    (proclaim '(function the-start (t) fixnum))
80    (proclaim '(function the-end (t t) fixnum))
81    (defmacro f+ (x y) `(the fixnum (+ (the fixnum ,x) (the fixnum ,y))))
82    (defmacro f- (x y) `(the fixnum (- (the fixnum ,x) (the fixnum ,y))))
83    
84    (defmacro with-start-end ( start end seq &body body)
85      `(let ((,start (if ,start (the-start ,start) 0)))
86         (declare (fixnum ,start))
87         (let ((,end (the-end ,end ,seq)))
88           (declare (fixnum ,end))
89           (or (<= ,start ,end) (bad-seq-limit  ,start ,end))
90           ,@ body)))
91    )
92    
93    (defun the-end (x y)
94      (cond ((fixnump x)
95             (or (<= (the fixnum x) (the fixnum (length y)))
96                 (bad-seq-limit x))
97             x)
98            ((null x)
99             (length y))
100            (t (bad-seq-limit x))))
101            
102    (defun the-start (x)
103      (cond ((fixnump x)
104             (or (>= (the fixnum x) 0)
105                 (bad-seq-limit x))
106             (the fixnum x))
107            ((null x) 0)
108            (t (bad-seq-limit x))))
109      
110    
111    
112    (defun reduce (function sequence
113                   &key from-end
114                        start
115                        end
116                        (initial-value nil ivsp)
117                        (key #'identity))
118      (with-start-end  start end sequence
119         (cond ((not from-end)
120               (when (null ivsp)
121                     (when (>= start end)
122                           (return-from reduce (funcall function)))
123                     (setq initial-value (funcall key (elt sequence start)))
124                     (setf start (f+ 1 start))
125                     )
126               (do ((x initial-value
127                       (funcall function x (funcall key (prog1 (elt sequence start)
128                                                  (setf start (f+ 1 start))
129                                                           )))))
130                   ((>= start end) x)))
131              (t
132               (when (null ivsp)
133                     (when (>= start end)
134                           (return-from reduce (funcall function)))
135                     (setf end (f+ end -1))
136                      (setq initial-value (funcall key (elt sequence end)))
137                      )
138                (do ((x initial-value (funcall function (funcall key (elt sequence end)) x)))
139                   ((>= start end) x)
140                   (setf end (f+ -1 end)))))))
141    
142    
143    (defun fill (sequence item
144                          &key start end )
145      (with-start-end start end sequence
146                      (do ((i start (f+ 1 i)))
147                          ((>= i end) sequence)
148                         (declare (fixnum i))
149                         (setf (elt sequence i) item))))
150    
151    
152    (defun replace (sequence1 sequence2
153                    &key start1  end1
154                         start2 end2 )
155      (with-start-end start1 end1 sequence1
156         (with-start-end start2 end2 sequence2                
157        (if (and (eq sequence1 sequence2)
158                 (> start1 start2))
159            (do* ((i 0 (f+ 1 i))
160                  (l (if (<  (f- end1 start1)
161                             (f- end2 start2))
162                          (f- end1 start1)
163                          (f- end2 start2)))
164                  (s1 (f+ start1  (f+ -1 l)) (f+ -1 s1))
165                  (s2 (f+ start2  (f+ -1 l)) (f+ -1 s2)))
166                ((>= i l) sequence1)
167              (declare (fixnum i l s1 s2))
168              (setf (elt sequence1 s1) (elt sequence2 s2)))
169            (do ((i 0 (f+ 1 i))
170                 (l (if (<  (f- end1 start1)
171                            (f- end2 start2))
172                        (f- end1 start1)
173                        (f- end2 start2)))
174                 (s1 start1 (f+ 1 s1))
175                 (s2 start2 (f+ 1 s2)))
176                ((>= i l) sequence1)
177              (declare (fixnum i l s1 s2))
178              (setf (elt sequence1 s1) (elt sequence2 s2)))))))
179    
180    
181    ;;; DEFSEQ macro.
182    ;;; Usage:
183    ;;;
184    ;;;    (DEFSEQ function-name argument-list countp everywherep body)
185    ;;;
186    ;;; The arguments ITEM and SEQUENCE (PREDICATE and SEQUENCE)
187    ;;;  and the keyword arguments are automatically supplied.
188    ;;; If the function has the :COUNT argument, set COUNTP T.
189    
190    (eval-when (eval compile)
191    (defmacro defseq
192              (f args countp everywherep body
193               &aux (*macroexpand-hook* 'funcall))
194      (setq *body* body)
195      (list 'progn
196            (let* ((from-end nil)
197                   (iterate-i '(i start (f+ 1 i)))
198                   (iterate-i-from-end '(i (f+ -1  end) (f+ -1 i)))
199                   (endp-i '(>= i end))
200                   (endp-i-from-end '(< i start))
201                   (iterate-i-everywhere '(i 0 (f+ 1 i)))
202                   (iterate-i-everywhere-from-end '(i (f+ -1  l) (f+ -1  i)))
203                   (endp-i-everywhere '(>= i l))
204                   (endp-i-everywhere-from-end '(< i 0))
205                   (i-in-range '(and (<= start i) (< i end)))
206                   (x '(elt sequence i))
207                   (keyx `(funcall key ,x))
208                   (satisfies-the-test `(call-test test test-not item ,keyx))
209                   (number-satisfied
210                    `(n (internal-count item sequence
211                                        :from-end from-end
212                                        :test test :test-not test-not
213                                        :start start :end end
214                                        ,@(if countp '(:count count))
215                                        :key key)))
216                   (within-count '(< k count))
217                   (kount-0 '(k 0))
218                   (kount-up '(setq k (f+ 1  k))))
219               `(defun ,f (,@args item sequence
220                           &key from-end test test-not
221                                start end
222                                ,@(if countp '(count))
223                                (key #'identity)
224                           ,@(if everywherep
225                                 (list '&aux '(l (length sequence)))
226                                 nil))
227                  ,@(if everywherep '((declare (fixnum l))))
228                  (if (eq key nil) (setq key #'identity))
229           (with-start-end start end sequence
230              (let ,@(if countp
231                         '(((count (if (null count)
232                                       most-positive-fixnum count)))))            
233                  ,@(if countp '((declare (integer count))))
234                  nil
235                  (and test test-not (test-error))
236                    (if (not from-end)
237                        ,(eval-body)
238                        ,(progn (setq from-end t
239                                      iterate-i iterate-i-from-end
240                                      endp-i endp-i-from-end
241                                      iterate-i-everywhere
242                                      iterate-i-everywhere-from-end
243                                      endp-i-everywhere
244                                      endp-i-everywhere-from-end)
245                                (eval-body)))))))
246            `(defun ,(intern (si:string-concatenate (string f) "-IF")
247                             (symbol-package f))
248                    (,@args predicate sequence
249                     &key from-end
250                          start end
251                          ,@(if countp '(count))
252                          (key #'identity))
253                    (if (eq key nil) (setq key #'identity))
254               (,f ,@args predicate sequence
255                   :from-end from-end
256                   :test #'funcall
257                   :start start :end end
258                   ,@(if countp '(:count count))
259                   :key key))
260            `(defun ,(intern (si:string-concatenate (string f) "-IF-NOT")
261                             (symbol-package f))
262                    (,@args predicate sequence
263                     &key from-end start end
264                          ,@(if countp '(count))
265                          (key #'identity))
266                    (if (eq key nil) (setq key #'identity))
267               (,f ,@args predicate sequence
268                   :from-end from-end
269                   :test-not #'funcall
270                   :start start :end end
271                   ,@(if countp '(:count count))
272                   :key key))
273            (list 'quote f)))
274    
275    (defmacro eval-body () *body*)
276    )
277    
278    
279    (defseq remove () t nil
280      (if (not from-end)
281          `(if (listp sequence)
282               (let ((l sequence) (l1 nil))
283                 (do ((i 0 (f+ 1  i)))
284                     ((>= i start))
285                   (declare (fixnum i))
286                   (push (car l) l1)
287                   (pop l))
288                 (do ((i start (f+ 1  i)) (j 0))
289                     ((or (>= i end) (>= j count) (endp l))
290                      (nreconc l1 l))
291                   (declare (fixnum i j))
292                   (cond ((call-test test test-not item (funcall key (car l)))
293                          (setf  j (f+ 1  j))
294                          (pop l))
295                         (t
296                          (push (car l) l1)
297                          (pop l)))))
298               (delete item sequence
299                       :from-end from-end
300                       :test test :test-not test-not
301                       :start start :end end
302                       :count count
303                       :key key))
304          `(delete item sequence
305                   :from-end from-end
306                   :test test :test-not test-not
307                   :start start :end end
308                   :count count
309                   :key key)))
310    
311    
312    (defseq delete () t t
313      (if (not from-end)
314          `(if (listp sequence)
315               (let* ((l0 (cons nil sequence)) (l l0))
316                 (do ((i 0 (f+ 1  i)))
317                     ((>= i start))
318                   (declare (fixnum i))
319                   (pop l))
320                 (do ((i start (f+ 1  i)) (j 0))
321                     ((or (>= i end) (>= j count) (endp (cdr l))) (cdr l0))
322                   (declare (fixnum i j))
323                   (cond ((call-test test test-not item (funcall key (cadr l)))
324                          (setf  j (f+ 1  j))
325                          (rplacd l (cddr l)))
326                         (t (setq l (cdr l))))))
327               (let (,number-satisfied)
328                 (declare (fixnum n))
329                 (when (< n count) (setq count n))
330                 (when (< count 0) (setq count 0))
331                 (do ((newseq
332                       (make-sequence (seqtype sequence)
333                                      (the fixnum (f- l count))))
334                      ,iterate-i-everywhere
335                      (j 0)
336                      ,kount-0)
337                     (,endp-i-everywhere newseq)
338                   (declare (fixnum i j k))
339                   (cond ((and ,i-in-range ,within-count ,satisfies-the-test)
340                          ,kount-up)
341                         (t (setf (elt newseq j) ,x)
342                            (setf  j (f+ 1  j)))))))
343          `(let (,number-satisfied)
344             (declare (fixnum n))
345             (when (< n count) (setq count n))
346             (when (< count 0) (setq count 0))
347             (do ((newseq
348                   (make-sequence (seqtype sequence) (the fixnum (f- l count))))
349                  ,iterate-i-everywhere
350                  (j (f+ -1 (the fixnum (f- l count))))
351    ;              (j (f- (the fixnum (f+ -1  end)) n))
352                  ,kount-0)
353                 (,endp-i-everywhere newseq)
354               (declare (fixnum i j k))
355               (cond ((and ,i-in-range ,within-count ,satisfies-the-test)
356                      ,kount-up)
357                     (t (setf (elt newseq j) ,x)
358                        (setq  j (f+ -1  j))))))))
359    
360    
361    (defseq count () nil nil
362      `(do (,iterate-i ,kount-0)
363           (,endp-i k)
364         (declare (fixnum i k))
365         (when (and ,satisfies-the-test)
366               ,kount-up)))
367    
368    
369    (defseq internal-count () t nil
370      `(do (,iterate-i ,kount-0)
371           (,endp-i k)
372         (declare (fixnum i k))
373         (when (and ,within-count ,satisfies-the-test)
374               ,kount-up)))
375    
376    
377    (defseq substitute (newitem) t t
378      `(do ((newseq (make-sequence (seqtype sequence) l))
379            ,iterate-i-everywhere
380            ,kount-0)
381           (,endp-i-everywhere newseq)
382         (declare (fixnum i k))
383         (cond ((and ,i-in-range ,within-count ,satisfies-the-test)
384                (setf (elt newseq i) newitem)
385                ,kount-up)
386               (t (setf (elt newseq i) ,x))))))
387    
388    
389    (defseq nsubstitute (newitem) t nil
390      `(do (,iterate-i ,kount-0)
391           (,endp-i sequence)
392         (declare (fixnum i k))
393         (when (and ,within-count ,satisfies-the-test)
394               (setf ,x newitem)
395               ,kount-up)))
396    
397    
398    (defseq find () nil nil
399      `(do (,iterate-i)
400           (,endp-i nil)
401         (declare (fixnum i))
402         (when ,satisfies-the-test (return ,x))))
403    
404    
405    (defseq position () nil nil
406      `(do (,iterate-i)
407           (,endp-i nil)
408         (declare (fixnum i))
409         (when ,satisfies-the-test (return i))))
410    
411    
412    (defun remove-duplicates (sequence
413                              &key from-end
414                                   test test-not
415                                   start end
416                                   (key #'identity))
417      (and test test-not (test-error))
418      (when (and (listp sequence) (not from-end) (null start)
419                 (null end))
420            (when (endp sequence) (return-from remove-duplicates nil))
421            (do ((l sequence (cdr l)) (l1 nil))
422                ((endp (cdr l))
423                 (return-from remove-duplicates (nreconc l1 l)))
424              (unless (member1 (car l) (cdr l)
425                               :test test :test-not test-not
426                               :key key)
427                      (setq l1 (cons (car l) l1)))))
428      (delete-duplicates sequence
429                         :from-end from-end
430                         :test test :test-not test-not
431                         :start start :end end
432                         :key key))
433          
434    
435    (defun delete-duplicates (sequence
436                              &key from-end
437                                   test test-not
438                                   start
439                                   end
440                                   (key #'identity)
441                              &aux (l (length sequence)))
442      (declare (fixnum l))
443      (and test test-not (test-error))
444      (when (and (listp sequence) (not from-end) (null start)
445                 (null end))
446            (when (endp sequence) (return-from delete-duplicates nil))
447            (do ((l sequence))
448                ((endp (cdr l))
449                 (return-from delete-duplicates sequence))
450                (cond ((member1 (car l) (cdr l)
451                                :test test :test-not test-not
452                                :key key)
453                       (rplaca l (cadr l))
454                       (rplacd l (cddr l)))
455                      (t (setq l (cdr l))))))
456      (with-start-end start end sequence
457        (if (not from-end)
458            (do ((n 0)
459                 (i start (f+ 1  i)))
460                ((>= i end)
461                 (do ((newseq (make-sequence (seqtype sequence)
462                                             (the fixnum (f- l n))))
463                      (i 0 (f+ 1  i))
464                      (j 0))
465                     ((>= i l) newseq)
466                   (declare (fixnum i j))
467                   (cond ((and (<= start i)
468                               (< i end)
469                               (position (funcall key (elt sequence i))
470                                         sequence
471                                         :test test
472                                         :test-not test-not
473                                         :start (the fixnum (f+ 1  i))
474                                         :end end
475                                         :key key)))
476                         (t
477                          (setf (elt newseq j) (elt sequence i))
478                          (setf  j (f+ 1  j))))))
479              (declare (fixnum n i))
480              (when (position (funcall key (elt sequence i))
481                              sequence
482                              :test test
483                              :test-not test-not
484                              :start (the fixnum (f+ 1  i))
485                              :end end
486                              :key key)
487                    (setf  n (f+ 1  n))))
488            (do ((n 0)
489                 (i (f+ -1  end) (f+ -1  i)))
490                ((< i start)
491                 (do ((newseq (make-sequence (seqtype sequence)
492                                             (the fixnum (f- l n))))
493                      (i (f+ -1  l) (f+ -1  i))
494                      (j (f- (the fixnum (f+ -1  l)) n)))
495                     ((< i 0) newseq)
496                   (declare (fixnum i j))
497                   (cond ((and (<= start i)
498                               (< i end)
499                               (position (funcall key (elt sequence i))
500                                         sequence
501                                         :from-end t
502                                         :test test
503                                         :test-not test-not
504                                         :start start
505                                         :end i
506                                         :key key)))
507                         (t
508                          (setf (elt newseq j) (elt sequence i))
509                          (setq  j (f+ -1  j))))))
510              (declare (fixnum n i))
511              (when (position (funcall key (elt sequence i))
512                              sequence
513                              :from-end t
514                              :test test
515                              :test-not test-not
516                              :start start
517                              :end i
518                              :key key)
519                    (setf  n (f+ 1  n)))))))
520          
521    
522    (defun mismatch (sequence1 sequence2
523                     &key from-end test test-not
524                          (key #'identity)
525                          start1 start2
526                          end1 end2)
527      (and test test-not (test-error))
528      (with-start-end start1 end1 sequence1
529       (with-start-end start2 end2 sequence2
530        (if (not from-end)
531            (do ((i1 start1 (f+ 1  i1))
532                 (i2 start2  (f+ 1  i2)))
533                ((or (>= i1 end1) (>= i2 end2))
534                 (if (and (>= i1 end1) (>= i2 end2)) nil i1))
535              (declare (fixnum i1 i2))
536              (unless (call-test test test-not
537                                 (funcall key (elt sequence1 i1))
538                                 (funcall key (elt sequence2 i2)))
539                      (return i1)))
540            (do ((i1 (f+ -1  end1) (f+ -1  i1))
541                 (i2 (f+ -1  end2)  (f+ -1  i2)))
542                ((or (< i1 start1) (< i2 start2))
543                 (if (and (< i1 start1) (< i2 start2)) nil (f+ 1 i1)))
544              (declare (fixnum i1 i2))
545              (unless (call-test test test-not
546                                 (funcall key (elt sequence1 i1))
547                                 (funcall key (elt sequence2 i2)))
548                      (return (f+ 1 i1))))))))
549    
550    
551    (defun search (sequence1 sequence2
552                   &key from-end test test-not
553                        (key #'identity)
554                        start1 start2
555                        end1 end2)
556      (and test test-not (test-error))
557      (with-start-end start1 end1 sequence1
558       (with-start-end start2 end2 sequence2  
559        (if (not from-end)
560            (loop
561             (do ((i1 start1 (f+ 1  i1))
562                  (i2 start2 (f+ 1  i2)))
563                 ((>= i1 end1) (return-from search start2))
564               (declare (fixnum i1 i2))
565               (when (>= i2 end2) (return-from search nil))
566               (unless (call-test test test-not
567                                  (funcall key (elt sequence1 i1))
568                                  (funcall key (elt sequence2 i2)))
569                       (return nil)))
570             (setf  start2 (f+ 1  start2)))
571            (loop
572             (do ((i1 (f+ -1  end1) (f+ -1  i1))
573                  (i2 (f+ -1  end2) (f+ -1  i2)))
574                 ((< i1 start1) (return-from search (the fixnum (f+ 1  i2))))
575               (declare (fixnum i1 i2))
576               (when (< i2 start2) (return-from search nil))
577               (unless (call-test test test-not
578                                  (funcall key (elt sequence1 i1))
579                                  (funcall key (elt sequence2 i2)))
580                       (return nil)))
581             (setq  end2 (f+ -1  end2)))))))
582    
583    
584    (defun sort (sequence predicate &key (key #'identity))
585      (if (listp sequence)
586          (list-merge-sort sequence predicate key)
587          (quick-sort sequence 0 (the fixnum (length sequence)) predicate key)))
588    
589    
590    (defun list-merge-sort (l predicate key)
591      (labels
592       ((sort (l)
593          (prog ((i 0) left right l0 l1 key-left key-right)
594            (declare (fixnum i))
595            (setq i (length l))
596            (cond ((< i 2) (return l))
597                  ((= i 2)
598                   (setq key-left (funcall key (car l)))
599                   (setq key-right (funcall key (cadr l)))
600                   (cond ((funcall predicate key-left key-right) (return l))
601                         ((funcall predicate key-right key-left)
602                          (return (nreverse l)))
603                         (t (return l)))))
604            (setq i (floor i 2))
605            (do ((j 1 (f+ 1  j)) (l1 l (cdr l1)))
606                ((>= j i)
607                 (setq left l)
608                 (setq right (cdr l1))
609                 (rplacd l1 nil))
610              (declare (fixnum j)))
611            (setq left (sort left))
612            (setq right (sort right))
613            (cond ((endp left) (return right))
614                  ((endp right) (return left)))
615            (setq l0 (cons nil nil))
616            (setq l1 l0)
617            (setq key-left (funcall key (car left)))
618            (setq key-right (funcall key (car right)))
619          loop
620            (cond ((funcall predicate key-left key-right) (go left))
621                  ((funcall predicate key-right key-left) (go right))
622                  (t (go left)))
623          left
624            (rplacd l1 left)
625            (setq l1 (cdr l1))
626            (setq left (cdr left))
627            (when (endp left)
628                  (rplacd l1 right)
629                  (return (cdr l0)))
630            (setq key-left (funcall key (car left)))
631            (go loop)
632          right
633            (rplacd l1 right)
634            (setq l1 (cdr l1))
635            (setq right (cdr right))
636            (when (endp right)
637                  (rplacd l1 left)
638                  (return (cdr l0)))
639            (setq key-right (funcall key (car right)))
640            (go loop))))
641       (sort l)))
642    
643    
644    #|
645    (defun list-quick-sort (l predicate key)
646      (if (or (endp l) (endp (cdr l)))
647          l
648          (multiple-value-bind (x y)
649              (list-quick-sort-partition (car l) (cdr l) predicate key)
650            (nconc (list-quick-sort x predicate key)
651                   (list (car l))
652                   (list-quick-sort y predicate key)))))
653    
654    (defun list-quick-sort-partition (k l predicate key)
655      (do ((l l (cdr l)) (x nil) (y nil))
656          ((endp l) (values (nreverse x) (nreverse y)))
657        (if (funcall predicate (funcall key (car l)) (funcall key k))
658            (setq x (cons (car l) x))
659            (setq y (cons (car l) y)))))
660    |#
661    
662    
663    (proclaim '(function quick-sort (t fixnum fixnum t t) t))
664    
665    (defun quick-sort (seq start end pred key)
666           (declare (fixnum start end))
667      (if (<= end (the fixnum (f+ 1  start)))
668          seq
669          (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d)))
670                (declare (fixnum j k))
671            (block outer-loop
672              (loop (loop (setq  k (f+ -1  k))
673                          (unless (< j k) (return-from outer-loop))
674                          (when (funcall pred (funcall key (elt seq k)) kd)
675                                (return)))
676                    (loop (setf  j (f+ 1  j))
677                          (unless (< j k) (return-from outer-loop))
678                          (unless (funcall pred (funcall key (elt seq j)) kd)
679                                  (return)))
680                    (let ((temp (elt seq j)))
681                      (setf (elt seq j) (elt seq k)
682                            (elt seq k) temp))))
683            (setf (elt seq start) (elt seq j)
684                  (elt seq j) d)
685            (quick-sort seq start j pred key)
686            (quick-sort seq (f+ 1  j) end pred key))))
687    
688    (defun stable-sort (sequence predicate &key (key #'identity))
689      (if (listp sequence)
690          (list-merge-sort sequence predicate key)
691          (if (or (stringp sequence) (bit-vector-p sequence))
692              (sort sequence predicate :key key)
693              (coerce (list-merge-sort (coerce sequence 'list)
694                                       predicate
695                                       key)
696                      (seqtype sequence)))))
697    
698    
699    (defun merge (result-type sequence1 sequence2 predicate
700                  &key (key #'identity)
701                  &aux (l1 (length sequence1)) (l2 (length sequence2)))
702      (declare (fixnum l1 l2))
703      (when (equal key 'nil) (setq key #'identity))
704      (do ((newseq (make-sequence result-type (the fixnum (f+ l1 l2))))
705           (j 0 (f+ 1  j))
706           (i1 0)
707           (i2 0))
708          ((and (= i1 l1) (= i2 l2)) newseq)
709        (declare (fixnum j i1 i2))
710        (cond ((and (< i1 l1) (< i2 l2))
711               (cond ((funcall predicate
712                               (funcall key (elt sequence1 i1))
713                               (funcall key (elt sequence2 i2)))
714                      (setf (elt newseq j) (elt sequence1 i1))
715                      (setf  i1 (f+ 1  i1)))
716                     ((funcall predicate
717                               (funcall key (elt sequence2 i2))
718                               (funcall key (elt sequence1 i1)))
719                      (setf (elt newseq j) (elt sequence2 i2))
720                      (setf  i2 (f+ 1  i2)))
721                     (t
722                      (setf (elt newseq j) (elt sequence1 i1))
723                      (setf  i1 (f+ 1  i1)))))
724              ((< i1 l1)
725               (setf (elt newseq j) (elt sequence1 i1))
726               (setf  i1 (f+ 1  i1)))
727              (t
728               (setf (elt newseq j) (elt sequence2 i2))
729               (setf  i2 (f+ 1  i2))))))
730    
731    (defun map-into (result-sequence function &rest sequences)
732    ;  "map-into:  (result-sequence function &rest sequences)"
733      (let ((nel (apply #'min (if (subtypep (type-of result-sequence) 'vector)
734                                  (array-dimension result-sequence 0)
735                                (length result-sequence))
736                        (mapcar #'length sequences))))
737        ;; Set the fill pointer to the number of iterations
738        (when (and (subtypep  (type-of result-sequence) 'vector)
739                    (array-has-fill-pointer-p result-sequence))
740          (setf (fill-pointer result-sequence) nel))
741        ;; Perform mapping
742        (dotimes (k nel result-sequence)
743          (setf (elt result-sequence k)
744                (apply function (mapcar #'(lambda (v) (elt v k)) sequences))))))
745    
746    
747    (defmacro with-hash-table-iterator ((name hash-table) &body body)
748      (let ((table (gensym ))
749            (ind (gensym "ind")))
750        `(let ((,table ,hash-table)
751               (,ind 0))
752           (macrolet ((,name ()
753                             `(multiple-value-bind
754                               (more key val)
755                               (si::next-hash-table-entry ,',table ,',ind)
756                               (cond ((>= (the fixnum more) 0)
757                                      (setq ,',ind more)
758                                      (values t key val))
759                                     (t  (values nil nil nil))))))
760                     ,@body))))
761                    
762    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26