;;;-*- Package: FST; Mode: Lisp; Base: 10 -*-
 
;;; Copyright (c) 1992 by Xerox Corporation

;;;; Skip list implementation of FSA relation protocol

(cl:in-package :fst)

(defclass fs-relation (relation)
	  ((hash-table :initarg :hash-table :accessor relation-hash-table)))

(defmethod shared-initialize :after ((relation fs-relation) slots
				     &key &allow-other-keys)
  (declare (ignore slots))
  (setf (relation-hash-table relation) (make-hash-table :test #'equal)))

(defmethod print-object ((relation fs-relation) stream)
  (format stream "#<fs-relation: ~s>" (relation-hash-table relation)))

(defclass fs-relations () ())

(defmethod make-relation (order (relations fs-relations))
  (declare (ignore order))
  (make-instance 'fs-relation))

(defparameter *non-tp* "-")

(defmethod relation-get (key (relation fs-relation))
  (let* ((tp-p (transducer-pair-p key))
         (upper (if tp-p (fst::tp-upper key) key))
         (rel-list (gethash upper (relation-hash-table relation))))
    (if tp-p
      (cdr (find (fst::tp-lower key) rel-list :key #'car :test #'dg-equal))
      (cdr (find *non-tp* rel-list :key #'car)))))

(defmethod (setf relation-get) (value key (relation fs-relation))
  ;(format t "~%key: ~a, value: ~a, relation: ~s" key value relation)
  #+ignore
  (when (> (hash-table-count (relation-hash-table relation)) 0)
    (format t "~%hash-table: ~s" (relation-hash-table relation))
    (maphash (lambda (k v) (declare (ignore v))(print k))
             (relation-hash-table relation))
    (terpri))
  (let* ((tp-p (transducer-pair-p key))
         (upper (if tp-p (fst::tp-upper key) key))
         (lower (if tp-p (fst::tp-lower key) *non-tp*))
         (rel-list (gethash upper (relation-hash-table relation)))
         (pos (if tp-p
                (position lower rel-list :key #'car
                          :test #'dg-equal)
                (position *non-tp* rel-list :key #'car))))
    (when pos (format t "~%POSSSS!!"))
    (if pos
      (setf (nth pos rel-list) (cons lower value))
      (push (cons lower value) 
            (gethash upper (relation-hash-table relation))))
    ;(print (relation-hash-table relation))
    ;(print (gethash upper (relation-hash-table relation)))
    value))

(defmethod relation-map (fn (relation fs-relation))
  (maphash (lambda (upper rel-list)
             (dolist (lower+val rel-list)
               (destructuring-bind (lower . value) lower+val
                 (funcall fn (if (eq lower *non-tp*)
                               upper
                               (make-transducer-pair upper lower))
                          value))))
           (relation-hash-table relation)))