source: projects/emacsen-common/branches/0.4.x/apel-sample/usr/share/emacs/site-lisp/apel/calist.el @ 7238

;;; calist.el --- Condition functions

;; Copyright (C) 1998 Free Software Foundation, Inc.
;; Copyright (C) 1999 Electrotechnical Laboratory, JAPAN.
;; Licensed to the Free Software Foundation.

;; Author: MORIOKA Tomohiko <tomo@m17n.org>
;; Keywords: condition, alist, tree

;; This file is part of APEL (A Portable Emacs Library).

;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.

;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Code:

(eval-when-compile (require 'cl))

(require 'alist)

(defvar calist-package-alist nil)
(defvar calist-field-match-method-obarray nil)

(defun find-calist-package (name)
  "Return a calist-package by NAME."
  (cdr (assq name calist-package-alist)))

(defun define-calist-field-match-method (field-type function)
  "Set field-match-method for FIELD-TYPE to FUNCTION."
  (fset (intern (symbol-name field-type) calist-field-match-method-obarray)
        function))

(defun use-calist-package (name)
  "Make the symbols of package NAME accessible in the current package."
  (mapatoms (lambda (sym)
              (if (intern-soft (symbol-name sym)
                               calist-field-match-method-obarray)
                  (signal 'conflict-of-calist-symbol
                          (list (format "Conflict of symbol %s")))
                (if (fboundp sym)
                    (define-calist-field-match-method
                      sym (symbol-function sym))
                  )))
            (find-calist-package name)))

(defun make-calist-package (name &optional use)
  "Create a new calist-package."
  (let ((calist-field-match-method-obarray (make-vector 7 0)))
    (set-alist 'calist-package-alist name
               calist-field-match-method-obarray)
    (use-calist-package (or use 'standard))
    calist-field-match-method-obarray))

(defun in-calist-package (name)
  "Set the current calist-package to a new or existing calist-package."
  (setq calist-field-match-method-obarray
        (or (find-calist-package name)
            (make-calist-package name))))

(in-calist-package 'standard)

(defun calist-default-field-match-method (calist field-type field-value)
  (let ((s-field (assoc field-type calist)))
    (cond ((null s-field)
           (cons (cons field-type field-value) calist)
           )
          ((eq field-value t)
           calist)
          ((equal (cdr s-field) field-value)
           calist))))

(define-calist-field-match-method t (function calist-default-field-match-method))

(defsubst calist-field-match-method (field-type)
  (symbol-function
   (or (intern-soft (if (symbolp field-type)
                        (symbol-name field-type)
                      field-type)
                    calist-field-match-method-obarray)
       (intern-soft "t" calist-field-match-method-obarray))))

(defsubst calist-field-match (calist field-type field-value)
  (funcall (calist-field-match-method field-type)
           calist field-type field-value))

(defun ctree-match-calist (rule-tree alist)
  "Return matched condition-alist if ALIST matches RULE-TREE."
  (if (null rule-tree)
      alist
    (let ((type (car rule-tree))
          (choices (cdr rule-tree))
          default)
      (catch 'tag
        (while choices
          (let* ((choice (car choices))
                 (choice-value (car choice)))
            (if (eq choice-value t)
                (setq default choice)
              (let ((ret-alist (calist-field-match alist type (car choice))))
                (if ret-alist
                    (throw 'tag
                           (if (cdr choice)
                               (ctree-match-calist (cdr choice) ret-alist)
                             ret-alist))
                  ))))
          (setq choices (cdr choices)))
        (if default
            (let ((ret-alist (calist-field-match alist type t)))
              (if ret-alist
                  (if (cdr default)
                      (ctree-match-calist (cdr default) ret-alist)
                    ret-alist))))
        ))))

(defun ctree-match-calist-partially (rule-tree alist)
  "Return matched condition-alist if ALIST matches RULE-TREE."
  (if (null rule-tree)
      alist
    (let ((type (car rule-tree))
          (choices (cdr rule-tree))
          default)
      (catch 'tag
        (while choices
          (let* ((choice (car choices))
                 (choice-value (car choice)))
            (if (eq choice-value t)
                (setq default choice)
              (let ((ret-alist (calist-field-match alist type (car choice))))
                (if ret-alist
                    (throw 'tag
                           (if (cdr choice)
                               (ctree-match-calist-partially
                                (cdr choice) ret-alist)
                             ret-alist))
                  ))))
          (setq choices (cdr choices)))
        (if default
            (let ((ret-alist (calist-field-match alist type t)))
              (if ret-alist
                  (if (cdr default)
                      (ctree-match-calist-partially (cdr default) ret-alist)
                    ret-alist)))
          (calist-field-match alist type t))
        ))))

(defun ctree-find-calist (rule-tree alist &optional all)
  "Return list of condition-alist which matches ALIST in RULE-TREE.
If optional argument ALL is specified, default rules are not ignored
even if other rules are matched for ALIST."
  (if (null rule-tree)
      (list alist)
    (let ((type (car rule-tree))
          (choices (cdr rule-tree))
          default dest)
      (while choices
        (let* ((choice (car choices))
               (choice-value (car choice)))
          (if (eq choice-value t)
              (setq default choice)
            (let ((ret-alist (calist-field-match alist type (car choice))))
              (if ret-alist
                  (if (cdr choice)
                      (let ((ret (ctree-find-calist
                                  (cdr choice) ret-alist all)))
                        (while ret
                          (let ((elt (car ret)))
                            (or (member elt dest)
                                (setq dest (cons elt dest))
                                ))
                          (setq ret (cdr ret))
                          ))
                    (or (member ret-alist dest)
                        (setq dest (cons ret-alist dest)))
                    )))))
        (setq choices (cdr choices)))
      (or (and (not all) dest)
          (if default
              (let ((ret-alist (calist-field-match alist type t)))
                (if ret-alist
                    (if (cdr default)
                        (let ((ret (ctree-find-calist
                                    (cdr default) ret-alist all)))
                          (while ret
                            (let ((elt (car ret)))
                              (or (member elt dest)
                                  (setq dest (cons elt dest))
                                  ))
                            (setq ret (cdr ret))
                            ))
                      (or (member ret-alist dest)
                          (setq dest (cons ret-alist dest)))
                      ))))
          )
      dest)))

(defun calist-to-ctree (calist)
  "Convert condition-alist CALIST to condition-tree."
  (if calist
      (let* ((cell (car calist)))
        (cons (car cell)
              (list (cons (cdr cell)
                          (calist-to-ctree (cdr calist))
                          ))))))

(defun ctree-add-calist-strictly (ctree calist)
  "Add condition CALIST to condition-tree CTREE without default clause."
  (cond ((null calist) ctree)
        ((null ctree)
         (calist-to-ctree calist)
         )
        (t
         (let* ((type (car ctree))
                (values (cdr ctree))
                (ret (assoc type calist)))
           (if ret
               (catch 'tag
                 (while values
                   (let ((cell (car values)))
                     (if (equal (car cell)(cdr ret))
                         (throw 'tag
                                (setcdr cell
                                        (ctree-add-calist-strictly
                                         (cdr cell)
                                         (delete ret (copy-alist calist)))
                                        ))))
                   (setq values (cdr values)))
                 (setcdr ctree (cons (cons (cdr ret)
                                           (calist-to-ctree
                                            (delete ret (copy-alist calist))))
                                     (cdr ctree)))
                 )
             (catch 'tag
               (while values
                 (let ((cell (car values)))
                   (setcdr cell
                           (ctree-add-calist-strictly (cdr cell) calist))
                   )
                 (setq values (cdr values))))
             )
           ctree))))

(defun ctree-add-calist-with-default (ctree calist)
  "Add condition CALIST to condition-tree CTREE with default clause."
  (cond ((null calist) ctree)
        ((null ctree)
         (let* ((cell (car calist))
                (type (car cell))
                (value (cdr cell)))
           (cons type
                 (list (list t)
                       (cons value (calist-to-ctree (cdr calist)))))
           ))
        (t
         (let* ((type (car ctree))
                (values (cdr ctree))
                (ret (assoc type calist)))
           (if ret
               (catch 'tag
                 (while values
                   (let ((cell (car values)))
                     (if (equal (car cell)(cdr ret))
                         (throw 'tag
                                (setcdr cell
                                        (ctree-add-calist-with-default
                                         (cdr cell)
                                         (delete ret (copy-alist calist)))
                                        ))))
                   (setq values (cdr values)))
                 (if (assq t (cdr ctree))
                     (setcdr ctree
                             (cons (cons (cdr ret)
                                         (calist-to-ctree
                                          (delete ret (copy-alist calist))))
                                   (cdr ctree)))
                   (setcdr ctree
                           (list* (list t)
                                  (cons (cdr ret)
                                        (calist-to-ctree
                                         (delete ret (copy-alist calist))))
                                  (cdr ctree)))
                   ))
             (catch 'tag
               (while values
                 (let ((cell (car values)))
                   (setcdr cell
                           (ctree-add-calist-with-default (cdr cell) calist))
                   )
                 (setq values (cdr values)))
               (let ((cell (assq t (cdr ctree))))
                 (if cell
                     (setcdr cell
                             (ctree-add-calist-with-default (cdr cell)
                                                            calist))
                   (let ((elt (cons t (calist-to-ctree calist))))
                     (or (member elt (cdr ctree))
                         (setcdr ctree (cons elt (cdr ctree)))
                         ))
                   )))
             )
           ctree))))

(defun ctree-set-calist-strictly (ctree-var calist)
  "Set condition CALIST in CTREE-VAR without default clause."
  (set ctree-var
       (ctree-add-calist-strictly (symbol-value ctree-var) calist)))

(defun ctree-set-calist-with-default (ctree-var calist)
  "Set condition CALIST to CTREE-VAR with default clause."
  (set ctree-var
       (ctree-add-calist-with-default (symbol-value ctree-var) calist)))


;;; @ end
;;;

(require 'product)
(product-provide (provide 'calist) (require 'apel-ver))

;;; calist.el ends here