;;;; levenshtein-test.scm -*- Scheme -*-

(import test)

(test-begin "Levenshtein")

;;;

(import type-checks)

(define (shift! ls #!optional default)
  (if (null? ls) default
    (begin
      (check-pair 'shift! ls)
      (let ((x (car ls))
            (d (cdr ls)) )
        (check-pair 'shift! d)
        (set-car! ls (car d))
        (set-cdr! ls (cdr d))
        x ) ) ) )

;until R⁷RS
(define (string->vector s) (list->vector (string->list s)))

;;;

;;;

(import levenshtein-operators)

(test-begin "Levenshtein Operators")

#| ;#, compiled must be from -extend
(test-group "Operations"

  (test "Insert ref" '#,(levenshtein-operator Insert "Insert" 1 0 1)
    (levenshtein-operator-ref 'Insert))

  (test "Transpose ref" '#,(levenshtein-operator Transpose "Transpose" 1 2 2)
    (levenshtein-operator-ref 'Transpose))

  (test-assert "Make foo"
    (levenshtein-operator=?
      '#,(levenshtein-operator foo "foo" 0.5 12 1)
      (make-levenshtein-operator 'foo "foo" 0.5 12 1)))

  ;-- Do not re-order these
  (test-assert "Set! foo"
    (levenshtein-operator-set! (make-levenshtein-operator 'foo "foo" 0.5 12 1)))

  (test-assert "Ref foo"
    (levenshtein-operator=?
      '#,(levenshtein-operator foo "foo" 0.5 12 1)
      (levenshtein-operator-ref 'foo)))

  (test-assert "Delete! foo" (levenshtein-operator-delete! 'foo))
  ;--

  (test-assert "Delete clone ="
    (levenshtein-operator=?
      '#,(levenshtein-operator Delete "Delete" 0.5 1 0)
      (clone-levenshtein-operator 'Delete cost: 0.5)))
)
|#
(test-group "Operations"

  (test "Insert ref" (make-levenshtein-operator 'Insert "Insert" 1 0 1)
    (levenshtein-operator-ref 'Insert))

  (test "Transpose ref" (make-levenshtein-operator 'Transpose "Transpose" 1 2 2)
    (levenshtein-operator-ref 'Transpose))

  #; ;why bother
  (test-assert "Make foo"
    (levenshtein-operator=?
      (make-levenshtein-operator 'foo "foo" 0.5 12 1)
      (make-levenshtein-operator 'foo "foo" 0.5 12 1)))

  ;-- Do not re-order these
  (test-assert "Set! foo"
    (levenshtein-operator-set! (make-levenshtein-operator 'foo "foo" 0.5 12 1)))

  (test-assert "Ref foo"
    (levenshtein-operator=?
      (make-levenshtein-operator 'foo "foo" 0.5 12 1)
      (levenshtein-operator-ref 'foo)))

  (test-assert "Delete! foo" (levenshtein-operator-delete! 'foo))
  ;--

  (test-assert "Delete clone ="
    (levenshtein-operator=?
      (make-levenshtein-operator 'Delete "Delete" 0.5 1 0)
      (clone-levenshtein-operator 'Delete cost: 0.5)))
)

(test-end "Levenshtein Operators")

;;;

(import (srfi 63))
(import levenshtein-vector)

(test-begin "Levenshtein Vector")

(let ()

    (define (cost-and-oper-matrix-match? l)
      (and (= 2 (length l))
           (= 6 (car l))
           (array? (cadr l))))

  (test-group "levenshtein"
    (let ((YWCQPGK (string->vector "YWCQPGK"))
          (LAWYQQKPGKA (string->vector "LAWYQQKPGKA")) )

      (test "distance" 6
        (let-values (((cost _) (levenshtein-distance/vector* YWCQPGK LAWYQQKPGKA))) cost))

      (test-assert "cost-and-oper-matrix-match"
        (cost-and-oper-matrix-match?
          (receive
            (levenshtein-distance/vector* YWCQPGK LAWYQQKPGKA operations: #t))))

      (test-assert "cost-and-oper-matrix-match: explicit opers"
        (cost-and-oper-matrix-match?
          (receive
            (levenshtein-distance/vector* YWCQPGK LAWYQQKPGKA operations: #t
              (levenshtein-operator-ref 'Insert)
              (levenshtein-operator-ref 'Delete)
              (levenshtein-operator-ref 'Substitute)
              (levenshtein-operator-ref 'Transpose)))))
    )
  )
)

(test-end "Levenshtein Vector")

(include "levenshtein-cost-fixnum")
(import levenshtein-vector-functor)
(module levenshtein-vector-fixnum = (levenshtein-vector-functor levenshtein-cost-fixnum))
(import (prefix levenshtein-vector-fixnum fx:))

;;

(test-begin "Levenshtein Vector Functor")

(let ()

    (define (cost-and-oper-matrix-match? l)
      (and (= 2 (length l))
           (= 6 (car l))
           (array? (cadr l))))

  (test-group "fixnum cost"
    (let ((YWCQPGK (string->vector "YWCQPGK"))
          (LAWYQQKPGKA (string->vector "LAWYQQKPGKA")) )

      (test "distance" 6
        (let-values (((cost _) (fx:levenshtein-distance/vector* YWCQPGK LAWYQQKPGKA))) cost))

      (test-assert "cost-and-oper-matrix-match"
        (cost-and-oper-matrix-match?
          (receive
            (fx:levenshtein-distance/vector* YWCQPGK LAWYQQKPGKA operations: #t))))

      (test-assert "cost-and-oper-matrix-match: explicit opers"
        (cost-and-oper-matrix-match?
          (receive
            (fx:levenshtein-distance/vector* YWCQPGK LAWYQQKPGKA operations: #t
              (levenshtein-operator-ref 'Insert)
              (levenshtein-operator-ref 'Delete)
              (levenshtein-operator-ref 'Substitute)
              (levenshtein-operator-ref 'Transpose)))))
    )
  )
)

(test-end "Levenshtein Vector Functor")

;;;

(import levenshtein-path-iterator)

(test-begin "Levenshtein Path Iterator")

(let ()

    ;FIXME these are a transpose of the actual PM since source length < target length
    ; see YWCQPGK & LAWYQQKPGKA above, shortest used for target
    ; not a problem in practice since path is the same

    (define (costs-list)
      (list
        1 2 3 3 4 5 6 7 8 9 10
        2 2 2 3 4 5 6 7 8 9 10
        3 3 3 3 4 5 6 7 8 9 10
        4 4 4 4 3 4 5 6 7 8 9
        5 5 5 5 4 4 5 5 6 7 8
        6 6 6 6 5 5 5 6 5 6 7
        7 7 7 7 6 6 5 6 6 5 6
        #f))

    (define (opers-list)
      (let ((io (levenshtein-operator-ref 'Insert))
            (so (levenshtein-operator-ref 'Substitute))
            (do (levenshtein-operator-ref 'Delete)))
        (list
          so do do so do do do do do do do
          io so so do do do do do do do do
          io io io so do do do do do do do
          io io io io so do do do do do do
          io io io io io so do so do do do
          io io io io io io so io so do do
          io io io io io io so do io so do
          #f)))

    (define (gen-test-pm)
      (let ((rs 7)
            (cs 11) )
        (let ((pm (make-array '#() rs cs))
              (costs (costs-list))
              (opers (opers-list)))
          (do ((r 0 (add1 r)))
              ((= r rs))
            (do ((c 0 (add1 c)))
                ((= c cs))
              (array-set! pm (cons (shift! costs) (shift! opers)) r c)))
          pm ) ) )

    (define *test-pm* (gen-test-pm))

    (define (gen-real-iter-vec)
      (let ((iter (levenshtein-path-iterator *test-pm*)) (vec (make-vector 6)))
        (do ((r (iter) (iter))
             (i 0 (add1 i)))
            ((not r) vec)
          (vector-set! vec i r))))

    (define (gen-test-iter-vec)
      (let ((vec (make-vector 6))
            (io (levenshtein-operator-ref 'Insert))
            (so (levenshtein-operator-ref 'Substitute))
            (do (levenshtein-operator-ref 'Delete)))
        (vector-set! vec 0
          (list (list 1 0 0 so) (list 2 1 1 so) (list 3 2 3 so) (list 4 4 5 so) (list 5 4 6 do) (list 6 6 10 do)))
        (vector-set! vec 1
          (list (list 1 0 0 so) (list 2 0 1 do) (list 3 2 3 so) (list 4 4 5 so) (list 5 4 6 do) (list 6 6 10 do)))
        (vector-set! vec 2
          (list (list 1 0 0 so) (list 2 1 1 so) (list 3 2 3 so) (list 4 3 5 do) (list 5 4 6 do) (list 6 6 10 do)))
        (vector-set! vec 3
          (list (list 1 0 0 so) (list 2 0 1 do) (list 3 2 3 so) (list 4 3 5 do) (list 5 4 6 do) (list 6 6 10 do)))
        (vector-set! vec 4
          (list (list 1 0 0 so) (list 2 1 1 so) (list 3 2 3 so) (list 4 3 5 do) (list 5 3 6 do) (list 6 6 10 do)))
        (vector-set! vec 5
          (list (list 1 0 0 so) (list 2 0 1 do) (list 3 2 3 so) (list 4 3 5 do) (list 5 3 6 do) (list 6 6 10 do)))
        vec))

  (test-assert "iterator proc" (procedure? (levenshtein-path-iterator *test-pm*)))

  (test-group "iterator path"
     (let ((vec (gen-test-iter-vec))
           (rvec (gen-real-iter-vec)) )
        (test "gen 0" (vector-ref vec 0) (vector-ref rvec 0))
        (test "gen 1" (vector-ref vec 1) (vector-ref rvec 1))
        (test "gen 2" (vector-ref vec 2) (vector-ref rvec 2))
        (test "gen 3" (vector-ref vec 3) (vector-ref rvec 3))
        (test "gen 4" (vector-ref vec 4) (vector-ref rvec 4))
        (test "gen 5" (vector-ref vec 5) (vector-ref rvec 5))
    )
  )
)

(test-end "Levenshtein Path Iterator")

;;;

;FIXME UTF-8 Chars!

(test-begin "Levenshtein Sequence Functor")

(include "levenshtein-cost-number")
(include "levenshtein-sequence-utf8")
(import levenshtein-sequence-functor)
(module levenshtein-sequence-number-utf8 = (levenshtein-sequence-functor levenshtein-cost-number levenshtein-sequence-utf8))
(import (prefix levenshtein-sequence-number-utf8 fnu8:))

(test-group "number cost & utf8 string"
  (test 6
    (fnu8:levenshtein-distance/sequence "YWCQPGK" "LAWYQQKPGKA"
      #:elm-eql char=?))
  (test 5
    (fnu8:levenshtein-distance/sequence "YWCQPGK" "LAWYQQKPGKA"
      #:elm-eql char=? #:limit-cost 5))
  (test 2.75
    (fnu8:levenshtein-distance/sequence "YWCQPGK" "LAWYQQKPGKA"
      #:insert-cost 0.5 #:delete-cost 0.25 #:substitute-cost 0.75
      #:elm-eql char=?))

  (test 9
    (fnu8:levenshtein-distance/sequence "強食" "弱肉強食秋冬あいうえお"
      #:elm-eql char=?))
  (test 5
    (fnu8:levenshtein-distance/sequence "強食" "弱肉強食秋冬あいうえお"
      #:elm-eql char=? #:limit-cost 5))
  (test 2.75
    (fnu8:levenshtein-distance/sequence "強食" "弱肉強食秋冬あいうえお"
      #:insert-cost 0.5 #:delete-cost 0.25 #:substitute-cost 0.75
      #:elm-eql char=?))
)

(test-end "Levenshtein Sequence Functor")

;;;

(test-end "Levenshtein")

(test-exit)