;;;;  -*- Hen -*-
;;;; levenshtein-path-iterator.scm
;;;; Kon Lovett, Sep 16 2005
;;;; Kon Lovett, Apr 2012

;; Issues
;;
;; - violates the 'number-means' idea since uses "numbers" egg operations &
;; not those from the 'means' actually used to compute the cost.

(module levenshtein-path-iterator

  (;export
    levenshtein-path-iterator)

  (import
    scheme
    chicken
    extras)

  (use
    numbers
    srfi-1
    srfi-63
    miscmacros
    numeric-macros
    type-checks
    type-errors)

;;;

(define (strict-array? obj)
  (and (array? obj) (not (string? obj)) (not (vector? obj))))

;;;

;; (levenshtein-path-iterator MATRIX)
;;
;; Creates an optimal edit distance operation path iterator over the
;; edit operation matrix MATRIX. The matrix is usually the result of an
;; invocation of '(levenshtein ... operations: #t)'.
;;
;; Each invocation of the iterator will generate a list of the form:
;; ((cost source-index target-index levenshtein-operator) ...). The last
;; invocation will return #f.
;;
;; Note: The iterator will return, w/ #f, to the initial caller. Saving the result of the 1st
;; invocation is not obvious.
;;
;; (define r0 (iter))
;; (define t r0)
;; ... (iter) until it quits
;; r0 now has #f, since the iterator finishes by returning to the initial caller, which is the
;; body of '(define r0 (iter))', thus re-binding r0. However, t has the original returned value.

(define (levenshtein-path-iterator pm)

  (define (trim-path path)
    (let ((cost -inf.0))
      (delete! #f
        (map-in-order
          (lambda (elm)
            (let ((elm-cost (car elm)))
              (if (or (zero? elm-cost) (= cost elm-cost))
                #f
                (begin (set! cost elm-cost) elm) ) ) )
          path)
        eq?) ) )

  (if (not (and (strict-array? pm) (fx= 2 (array-rank pm))))
      (error-argument-type 'levenshtein-path-iterator pm "rank 2 array" "path-matrix")
      (let ((dims (array-dimensions pm)))
        (let ((n (car dims))
              (m (cadr dims))
              (cost@
                (lambda (i j)
                  (if (or (fx< i 0) (fx< j 0))
                    +inf.0
                    (car (array-ref pm i j)) ) ) ) )
            (letrec ((generator
                      (lambda (yielder)
                        (let ((yield
                                (lambda (value)
                                  (let/cc continue
                                    (set! generator
                                      (lambda (k)
                                        (set! yielder k)
                                        (continue value)))
                                    (yielder value) ) ) ) )
                          (let try ((i (fx-- n)) (j (fx-- m)) (path '()))
                            (and
                              (fx<= 0 i) (fx<= 0 j)
                              (let* ((o (array-ref pm i j))
                                     (oc (car o))
                                     (oo (cdr o))
                                     (np (cons (list oc i j oo) path) ) )
                                (if (and (fx= 0 i) (fx= 0 j))
                                    (begin
                                      (yield (trim-path np))
                                      #f)
                                    (let ((ai (fx-- i))
                                          (lj (fx-- j))
                                          (better #f))
                                      (when (< (cost@ i lj) oc)
                                        (set! better #t)
                                        (try i lj np))
                                      (when (< (cost@ ai j) oc)
                                        (set! better #t)
                                        (try ai j np))
                                      (when (< (cost@ ai lj) oc)
                                        (set! better #t)
                                        (try ai lj np))
                                      (unless better
                                        (when (= (cost@ i lj) oc)
                                          (try i lj np))
                                        (when (= (cost@ ai j) oc)
                                          (try ai j np))
                                        (when (= (cost@ ai lj) oc)
                                          (try ai lj np)))
                                      #f ) ) ) ) ) ) ) ) )
              (lambda ()
                (let/cc yielder
                  (generator yielder) ) ) ) ) ) ) )

) ;module levenshtein-path-iterator