;; -*- lisp -*-
(in-package :it.bese.arnesi)
;;;; * Manipulating sequences
(defun tail (seq &optional (how-many 1))
"Returns the last HOW-MANY elements of the sequence SEQ. HOW-MANY is
greater than (length SEQ) then all of SEQ is returned."
(let ((seq-length (length seq)))
(cond
((<= 0 how-many seq-length)
(subseq seq (- seq-length how-many)))
((< seq-length how-many)
(copy-seq seq))
(t ; (< how-many 0)
(head seq (- how-many))))))
(defun but-tail (seq &optional (how-many 1))
"Returns SEQ with the last HOW-MANY elements removed."
(let ((seq-length (length seq)))
(cond
((<= 0 how-many seq-length)
(subseq seq 0 (- seq-length how-many)))
((< seq-length how-many)
(copy-seq seq))
(t
(but-head seq (- how-many))))))
(defun head (seq &optional (how-many 1))
"Returns the first HOW-MANY elements of SEQ."
(let ((seq-length (length seq)))
(cond
((<= 0 how-many seq-length)
(subseq seq 0 how-many))
((< seq-length how-many)
(copy-seq seq))
(t
(tail seq (- how-many))))))
(defun but-head (seq &optional (how-many 1))
"Returns SEQ with the first HOW-MANY elements removed."
(let ((seq-length (length seq)))
(cond ((<= 0 how-many (length seq))
(subseq seq how-many))
((< seq-length how-many)
(copy-seq seq))
(t
(but-tail seq (- how-many))))))
(defun starts-with (sequence prefix &key (test #'eql) (return-suffix nil))
"Test whether the first elements of SEQUENCE are the same (as
per TEST) as the elements of PREFIX.
If RETURN-SUFFIX is T the functions returns, as a second value, a
displaced array pointing to the sequence after PREFIX."
(let ((length1 (length sequence))
(length2 (length prefix)))
(when (< length1 length2)
(return-from starts-with (values nil nil)))
(dotimes (index length2)
(when (not (funcall test (elt sequence index) (elt prefix index)))
(return-from starts-with (values nil nil))))
;; if we get here then we match
(values t
(if return-suffix
(make-array (- (length sequence) (length prefix))
:element-type (array-element-type sequence)
:displaced-to sequence
:displaced-index-offset (length prefix)
:adjustable nil)
nil))))
(defun ends-with (seq1 seq2 &key (test #'eql))
"Test whether SEQ1 ends with SEQ2. In other words: return true if
the last (length seq2) elements of seq1 are equal to seq2."
(let ((length1 (length seq1))
(length2 (length seq2)))
(when (< length1 length2)
;; if seq1 is shorter than seq2 than seq1 can't end with seq2.
(return-from ends-with nil))
(loop
for seq1-index from (- length1 length2) below length1
for seq2-index from 0 below length2
when (not (funcall test (elt seq1 seq1-index) (elt seq2 seq2-index)))
do (return-from ends-with nil)
finally (return t))))
(defun read-sequence* (sequence stream &key (start 0) end)
"Like READ-SEQUENCE except the sequence is returned as well.
The second value returned is READ-SEQUENCE's primary value, the
primary value returned by READ-SEQUENCE* is the medified
sequence."
(let ((pos (read-sequence sequence stream :start start :end end)))
(values sequence pos)))
(defmacro deletef
(item sequence &rest delete-args
&environment e)
"Delete ITEM from SEQUENCE, using cl:delete, and update SEQUENCE.
DELETE-ARGS are passed directly to cl:delete."
(multiple-value-bind (vars vals store-vars writer-form reader-form)
(get-setf-expansion sequence e)
`(let* (,@(mapcar #'list vars vals)
(,(car store-vars) ,reader-form))
(setq ,(car store-vars) (delete ,item ,(car store-vars)
,@delete-args))
,writer-form)))
(defun copy-array (array)
"Returns a fresh copy of ARRAY. The returned array will have
the same dimensions and element-type, will not be displaced and
will have the same fill-pointer as ARRAY.
See http://thread.gmane.org/gmane.lisp.allegro/13 for the
original implementation and discussion."
(let ((dims (array-dimensions array))
(fill-pointer (and (array-has-fill-pointer-p array)
(fill-pointer array))))
(adjust-array
(make-array dims :displaced-to array)
dims
:fill-pointer fill-pointer)))
(defun make-displaced-array (array &optional (start 0) (end (length array)))
(make-array (- end start)
:element-type (array-element-type array)
:displaced-to array
:displaced-index-offset start))
;;;; ** Levenshtein Distance
;;;; 1) Set n to be the length of s. Set m to be the length of t. If n
;;;; = 0, return m and exit. If m = 0, return n and exit. Construct
;;;; a matrix containing 0..m rows and 0..n columns.
;;;; 2) Initialize the first row to 0..n. Initialize the first column
;;;; to 0..m.
;;;; 3) Examine each character of s (i from 1 to n).
;;;; 4) Examine each character of t (j from 1 to m).
;;;; 5) If s[i] equals t[j], the cost is 0. If s[i] doesn't equal
;;;; t[j], the cost is 1.
;;;; 6) Set cell d[i,j] of the matrix equal to the minimum of: a. The
;;;; cell immediately above plus 1: d[i-1,j] + 1. b. The cell
;;;; immediately to the left plus 1: d[i,j-1] + 1. c. The cell
;;;; diagonally above and to the left plus the cost: d[i-1,j-1] +
;;;; cost.
;;;; 7) After the iteration steps (3, 4, 5, 6) are complete, the
;;;; distance is found in cell d[n,m].
(defun levenshtein-distance (source target &key (test #'eql))
(block nil
(let ((source-length (length source))
(target-length (length target)))
(when (zerop source-length)
(return target-length))
(when (zerop target-length)
(return source-length))
(let ((buffer (make-array (1+ target-length))))
(dotimes (i (1+ target-length))
(setf (aref buffer i) i))
;; we make a slight modification to the alogrithm described
;; above. we don't create the entire array, just enough to
;; keep the info we need, which is an array of size
;; target-length + the "above" value and the "over". (this is
;; similar to the optimizaiont for determining lcs).
(loop
for i from 1 upto source-length
do (setf (aref buffer 0) i)
do (loop
with above-value = i
with over-value = (1- i)
for j from 1 upto target-length
for cost = (if (funcall test (elt source (1- i))
(elt target (1- j)))
0 1)
do (let ((over-value* (aref buffer j)))
(setf (aref buffer j) (min (1+ above-value)
(1+ (aref buffer j))
(+ cost over-value))
above-value (aref buffer j)
over-value over-value*))))
(return (aref buffer target-length))))))
;; Copyright (c) 2002-2006, Edward Marco Baringer
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;;
;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;; of its contributors may be used to endorse or promote products
;; derived from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.