source: branches/qres/ccl/library/sequence-utils.lisp @ 15278

Last change on this file since 15278 was 9916, checked in by gz, 11 years ago

Merge in some more changes from trunk, unused here (e.g. for other platforms) but keeping in sync makes diffs easier

File size: 3.5 KB
Line 
1;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*-
2;;;; ***********************************************************************
3;;;; FILE IDENTIFICATION
4;;;;
5;;;; Name:          sequence-utils.lisp
6;;;; Version:       0.2
7;;;; Project:       utilities
8;;;; Purpose:       utilities for working with sequences
9;;;;
10;;;; ***********************************************************************
11
12(in-package "CCL")
13
14;;; -----------------------------------------------------------------
15;;; splitting sequences
16;;; -----------------------------------------------------------------
17
18;;; Split a sequence SEQ at each point where TEST is true
19;;; DIR should be one of :BEFORE, :AFTER or :ELIDE
20
21(defun split-if (test seq &optional (dir :before))
22  (remove-if
23   #'(lambda (x) (equal x (subseq seq 0 0)))
24   (loop for start fixnum = 0 
25         then (if (eq dir :before) stop (the fixnum (1+ (the fixnum stop))))
26         while (< start (length seq))
27         for stop = (position-if 
28                     test seq 
29                     :start (if (eq dir :elide) start (the fixnum (1+ start))))
30         collect (subseq 
31                  seq start 
32                  (if (and stop (eq dir :after)) 
33                    (the fixnum (1+ (the fixnum stop))) 
34                    stop))
35         while stop)))
36 
37(defun split-if-char (char seq &optional dir)
38  (split-if #'(lambda (ch) (eq ch char)) seq dir))
39
40(defmethod split-lines ((text string))
41  (delete-if (lambda (x) (string= x ""))
42             (mapcar (lambda (s)
43                       (string-trim '(#\return #\newline) s))
44                     (split-if (lambda (c) (member c '(#\return #\newline) :test #'char=))
45                               text))))
46
47;;; -----------------------------------------------------------------
48;;; matching subsequences
49;;; -----------------------------------------------------------------
50
51(defun match-subsequence (subseq seq &key (test #'eql) (start 0))
52  (let ((max-index (1- (length seq))))
53    (block matching
54      ;; search for mismatches
55      (dotimes (i (length subseq))
56        (let ((pos (+ start i)))
57          (when (or (> pos max-index)
58                    (not (funcall test (elt seq pos)
59                                  (elt subseq i))))
60            (return-from matching nil))))
61      ;; no mismatches found; return true
62      (return-from matching t))))
63
64(defun %find-matching-subsequence-backward (subseq seq &key (test #'eql) (start 0) end)
65  (let ((end (or end (length seq)))
66        (pos end)
67        (min-index (or start 0)))
68    (block finding
69      (dotimes (i (- (length seq) start))
70        (setf pos (- end i))
71        (if (<= pos min-index)
72            (return-from finding nil)
73            (when (match-subsequence subseq seq :test test :start pos)
74              (return-from finding pos))))
75      nil)))
76
77(defun %find-matching-subsequence-forward (subseq seq &key (test #'eql) (start 0) end)
78  (let ((pos start)
79        (max-index (or end (length seq))))
80    (block finding
81      (dotimes (i (- (length seq) start))
82        (setf pos (+ start i))
83        (if (>= pos max-index)
84            (return-from finding nil)
85            (when (match-subsequence subseq seq :test test :start pos)
86              (return-from finding pos))))
87      nil)))
88
89(defun find-matching-subsequence (subseq seq &key (test #'eql) (start 0) end from-end)
90  (if from-end
91      (%find-matching-subsequence-backward subseq seq :test test :start start :end end)
92      (%find-matching-subsequence-forward subseq seq :test test :start start :end end)))
Note: See TracBrowser for help on using the repository browser.