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

;; Issues
;;
;; - So as not to force use of "numbers" egg the 'cost' parameter is
;; not validated!

(module levenshtein-operators

  (;export
    make-levenshtein-operator
    clone-levenshtein-operator
    levenshtein-operator?
    levenshtein-operator-key
    levenshtein-operator-name
    levenshtein-operator-cost
    levenshtein-operator-above
    levenshtein-operator-left
    levenshtein-operator=?
    check-levenshtein-operator error-levenshtein-operator
    levenshtein-operator-ref
    levenshtein-operator-set!
    levenshtein-operator-delete!
    levenshtein-base-operator?
    levenshtein-insert-operator?
    levenshtein-delete-operator?
    levenshtein-operator-reset
    levenshtein-base-operators-vector)

  (import
    scheme
    chicken
    extras
    (only type-checks
      check-string check-symbol check-natural-fixnum
      define-check+error-type)
    (only type-errors
      error-argument-type))

  (require-library
    type-errors
    type-checks)

  (use
    srfi-69
    vector-lib)

;;;

;; numbers egg version

#; ;UNUSED
(define (check-number loc obj #!optional argnam)
  (unless (number? obj)
    (error-argument-type loc obj "number" argnam) ) )

;;;

; N & M mean length of source & target vectors respectively.
;
; Edit operation offset - (<edit oper> Ni Mj)
; where <edit oper> is {Insert Delete Substitute Transpose ...},
; Ni and Mj are fixnums >= 0,
; interpreted as D[I - Ni, J - Mj], S[I - Ni], and T[J - Mj],
; where Ni = 0 or Mj = 0 means no equivalence test required.
;
; Edit cost - ((<edit oper> Cost) ...) where Cost is number, usually 1.
;
; ?Need source & target indicies separate from above & left?

; Operator type

(define-record-type levenshtein-operator
  (*make-levenshtein-operator key name cost above left)
  levenshtein-operator?
  (key levenshtein-operator-key)
  (name levenshtein-operator-name)
  (cost levenshtein-operator-cost)
  (above levenshtein-operator-above)
  (left levenshtein-operator-left))

(define-check+error-type levenshtein-operator)

; The operator printer

(define-record-printer (levenshtein-operator eo out)
  (fprintf out "#,(levenshtein-operator ~A ~S ~A ~A ~A)"
    (levenshtein-operator-key eo)
    (levenshtein-operator-name eo)
    (levenshtein-operator-cost eo)
    (levenshtein-operator-above eo)
    (levenshtein-operator-left eo)) )

; No validation of reader input, only for printer output!

(define-reader-ctor 'levenshtein-operator *make-levenshtein-operator)

;; The levenshtein operator table

(define clear-lo-table)
(define *lo-ref)
(define *lo-set!)
(define *lo-del!)
(let ((*lo-table* #f))
  (set! clear-lo-table
    (lambda ()
      (set! *lo-table* (make-hash-table eq? hash-by-identity 5)) ) )
  (set! *lo-ref
    (lambda (key)
      (hash-table-ref/default *lo-table* key #f) ) )
  (set! *lo-set!
    (lambda (eo)
      (hash-table-set! *lo-table* (levenshtein-operator-key eo) eo) ) )
  (set! *lo-del!
    (lambda (eo)
      (hash-table-delete! *lo-table* (levenshtein-operator-key eo)) ) ) )

;; Operator table access

(define (levenshtein-operator=? a b)
  (and (levenshtein-operator? a) (levenshtein-operator? b)
       (eq? (levenshtein-operator-key a) (levenshtein-operator-key b))
       (string=? (levenshtein-operator-name a) (levenshtein-operator-name b))
       (= (levenshtein-operator-cost a) (levenshtein-operator-cost b))
       (fx= (levenshtein-operator-above a) (levenshtein-operator-above b))
       (fx= (levenshtein-operator-left a) (levenshtein-operator-left b))) )

(define (get-levenshtein-operator loc key)
  (let ((lo (*lo-ref key)))
    (or lo
        (error loc "couldn't find levenshtein operator for key" key) ) ) )

(define (get-levenshtein-operator-arg loc lo)
  (unless (levenshtein-operator? lo)
    (if (symbol? lo) (get-levenshtein-operator loc lo)
      (error-argument-type loc lo "levenshtein operator or an operator key" "oper")) ) )

(define (levenshtein-operator-ref key)
  (check-symbol 'levenshtein-operator-ref  key "key")
  (get-levenshtein-operator 'levenshtein-operator-ref key) )

(define (levenshtein-operator-set! lo)
  (check-levenshtein-operator 'levenshtein-operator-set! lo "oper")
  (*lo-set! lo) )

(define (levenshtein-operator-delete! lo)
  (*lo-del! (get-levenshtein-operator-arg 'levenshtein-operator-delete! lo)) )

(define (make-levenshtein-operator key name cost above left)
  (check-natural-fixnum 'make-levenshtein-operator above "above")
  (check-natural-fixnum 'make-levenshtein-operator left "left")
  #;(check-number 'make-levenshtein-operator cost "cost")
  (check-symbol 'make-levenshtein-operator key "key")
  (check-string 'make-levenshtein-operator name "name")
  (*make-levenshtein-operator key name cost above left) )

; Better way to handle this?
(define-syntax set-oper-key-var
  (ir-macro-transformer
    (lambda (exp inject compare)
      (let ((key-var (cadr exp))
            (eo (caddr exp)) )
      `(unless ,key-var
        (set! ,key-var
          (,(inject (string->symbol (string-append "levenshtein-operator-" (symbol->string (strip-syntax key-var)))))
            ,eo)) ) ) ) ) )

(define (clone-levenshtein-operator lo #!key key name cost above left)
  (let ((lo (get-levenshtein-operator-arg 'clone-levenshtein-operator lo)))
    (set-oper-key-var key lo)
    (set-oper-key-var name lo)
    (set-oper-key-var cost lo)
    (set-oper-key-var above lo)
    (set-oper-key-var left lo)
    (make-levenshtein-operator key name cost above left) ) )

;; Base levenshtein operators predicates

(define (levenshtein-base-operator? eo)
  (and (<= (levenshtein-operator-above eo) 1)
       (<= (levenshtein-operator-left eo) 1)))

(define (levenshtein-insert-operator? lo)
  (and (levenshtein-operator? lo)
       (= (levenshtein-operator-above lo) 0)
       (= (levenshtein-operator-left lo) 1)))

(define (levenshtein-delete-operator? lo)
  (and (levenshtein-operator? lo)
       (= (levenshtein-operator-above lo) 1)
       (= (levenshtein-operator-left lo) 0)))

(define levenshtein-operator-reset)
(define levenshtein-base-operators-vector)
(let ((*base-opers* #f))
  (set! levenshtein-operator-reset
    (lambda ()
      ; insert must be 1st!
      (set! *base-opers*
        (vector
          (*make-levenshtein-operator 'Insert "Insert" 1 0 1)
          (*make-levenshtein-operator 'Delete "Delete" 1 1 0)
          (*make-levenshtein-operator 'Substitute "Substitute" 1 1 1)))
      (clear-lo-table)
      (*lo-set! (vector-ref *base-opers* 0))
      (*lo-set! (vector-ref *base-opers* 1))
      (*lo-set! (vector-ref *base-opers* 2))
      ; Standard, but not part of the base set
      (*lo-set! (*make-levenshtein-operator 'Transpose "Transpose" 1 2 2)) ) )
  (set! levenshtein-base-operators-vector
    (lambda ()
      (vector-copy *base-opers*) ) ) )

;;;
;;; Module init
;;;

(levenshtein-operator-reset)

) ;module levenshtein-operators