;;;  -*- Hen -*-
;;;; levenshtein-sequence-vector.scm
;;;; Kon Lovett, Sep '06
;;;; Kon Lovett, Apr 2012

(include "levenshtein-sequence-interface")

(module levenshtein-sequence-vector SEQUENCE-OPER

  (import scheme chicken)

  (use
    vector-lib
    numeric-macros
    type-checks
    type-errors)

;;;

(define (sequence->vector seq)
  (cond
    ((vector? seq)          seq)
    ((%shared-vector? seq)  seq)
    ((list? seq)            (list->vector seq))
    ((string? seq)          (list->vector (string->list seq)))
    (else                   #f)) )

;;;

(define-record-type shared-vector
  (%make-shared-vector vec start end)
  %shared-vector?
  (vec %shared-vector-vector)
  (start %shared-vector-start)
  (end %shared-vector-end) )

(define (*vector? obj)
  (or (vector? obj) (%shared-vector? obj)) )

(define (error/type/vector loc obj)
  (error-argument-type loc obj "vector") )

(define (check-*vector loc obj)
  (unless (*vector? obj)
    (error/type/vector loc obj)) )

;;;

(define (*vector-length vec)
  (cond
    ((vector? vec) (vector-length vec))
    ((%shared-vector? vec) (fx- (%shared-vector-end vec) (%shared-vector-start vec)))
    (else
      (error/type/vector '*vector-length vec)) ) )

(define (*vector-ref vec idx)
  (cond
    ((vector? vec) (vector-ref vec idx))
    ((%shared-vector? vec)
      (let ((ridx (fx+ (%shared-vector-start vec) idx)))
        (if (and (fx<= (%shared-vector-start vec) ridx) (fx< ridx (%shared-vector-end vec)))
            (*vector-ref (%shared-vector-vector vec) ridx)
            (error 'vector-ref "out of range" idx))))
    (else
      (error/type/vector '*vector-ref vec)) ) )

(define (*vector-for-each f vec . vectors)
  (define (vec-for-each f vec start end)
    (do ((i start (fx+ i 1)))
        ((fx<= end i))
      (f i (*vector-ref vec i)) ) )
  (check-procedure 'vector-for-each f)
  (check-*vector 'vector-for-each vec)
  (if (null? vectors)
      (vec-for-each f vec 0 (*vector-length vec))
      (error 'vector-for-each "multiple vector support not implemented") ) )

(define (subvector/shared vec start #!optional (end (*vector-length vec)))
  (check-vector 'subvector/shared vec)
  (%make-shared-vector vec start end) )

(define (vector-prefix-length elm-eql v1 v2
          #!optional (s1 0) (e1 (*vector-length v1)) (s2 0) (e2 (*vector-length v2)))
  (check-*vector 'vector-prefix-length v1)
  (check-*vector 'vector-prefix-length v2)
  (let loop ((i1 s1) (i2 s2))
    (cond
      ((or (fx>= i1 e1) (fx>= i2 e2))
        (if (fx> i1 e1) 0 (fx- i1 s1)))
      ((elm-eql (*vector-ref v1 i1) (*vector-ref v2 i2))
        (loop (fx++ i1) (fx++ i2)))
      (else
        (fx- i1 s1)))) )

(define (vector-suffix-length elm-eql v1 v2
          #!optional (s1 0) (e1 (*vector-length v1)) (s2 0) (e2 (*vector-length v2)))
  (check-*vector 'vector-suffix-length v1)
  (check-*vector 'vector-suffix-length v2)
  (let loop ((i1 (fx-- e1)) (i2 (fx-- e2)))
    (cond
      ((or (fx<= i1 s1) (fx<= i2 s2))
        (if (fx< i1 s1) 0 (fx- e1 (fx++ i1))))
      ((elm-eql (*vector-ref v1 i1) (*vector-ref v2 i2))
        (loop (fx-- i1) (fx-- i2)))
      (else
        (fx- e1 (fx++ i1))))) )

;;;

(define sequence-length *vector-length)
(define sequence-prefix-length vector-prefix-length)
(define sequence-suffix-length vector-suffix-length)
(define sequence-for-each *vector-for-each)
(define subsequence/shared subvector/shared)

) ;module levenshtein-sequence-vector