;;;; levenshtein-sequence-vector.scm -*- Scheme -*-
;;;; Kon Lovett, Mar '20
;;;; Kon Lovett, Apr '12
;;;; Kon Lovett, May '06

(include "levenshtein-sequence-interface")

(module levenshtein-sequence-vector SEQUENCE-OPER

(import scheme)
(import (chicken base))
(import (chicken type))
(import vector-lib)
(import numeric-macros)
(import type-checks)
(import type-errors)

(: sequence-length (sequence -> number))
(: sequence-prefix-length (procedure sequence sequence #!rest sequence -> number))
(: sequence-suffix-length (procedure sequence sequence #!rest sequence -> number))
(: sequence-for-each (procedure sequence #!rest sequence -> number))
(: subsequence/shared (sequence number #!optional number -> sequence))

;;;

(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 shared-vector)
(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) (- (%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 (+ (%shared-vector-start vec) idx)))
        (if (and (<= (%shared-vector-start vec) ridx) (< 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 (+ i 1)))
        ((<= 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 (>= i1 e1) (>= i2 e2))
        (if (> i1 e1) 0 (- i1 s1)))
      ((elm-eql (*vector-ref v1 i1) (*vector-ref v2 i2))
        (loop (++ i1) (++ i2)))
      (else
        (- 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 (-- e1)) (i2 (-- e2)))
    (cond
      ((or (<= i1 s1) (<= i2 s2))
        (if (< i1 s1) 0 (- e1 (++ i1))))
      ((elm-eql (*vector-ref v1 i1) (*vector-ref v2 i2))
        (loop (-- i1) (-- i2)))
      (else
        (- e1 (++ 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