emacs_el/tiny-tools/other/calist.el

   1 ;;; calist.el --- Condition functions
   2
   3 ;; Copyright (C) 1998 MORIOKA Tomohiko.
   4
   5 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; Keywords: condition, alist, tree
   7
   8 ;; This file is part of APEL (A Portable Emacs Library).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with program; see the file COPYING. If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24 ;;
  25 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (defvar calist-field-match-method-obarray [nil])
  32
  33 (defun define-calist-field-match-method (field-type function)
  34   "Set field-match-method for FIELD-TYPE to FUNCTION."
  35   (fset (intern (symbol-name field-type) calist-field-match-method-obarray)
  36         function))
  37
  38 (defun calist-default-field-match-method (calist field-type field-value)
  39   (let ((s-field (assoc field-type calist)))
  40     (cond ((null s-field)
  41            (cons (cons field-type field-value) calist))
  42           ((eq field-value t)
  43            calist)
  44           ((equal (cdr s-field) field-value)
  45            calist))))
  46
  47 (defsubst calist-field-match-method (field-type)
  48   (condition-case nil
  49       (symbol-function
  50        (intern-soft
  51         (symbol-name field-type) calist-field-match-method-obarray))
  52     (error (symbol-function 'calist-default-field-match-method))))
  53
  54 (defsubst calist-field-match (calist field-type field-value)
  55   (funcall (calist-field-match-method field-type)
  56            calist field-type field-value))
  57
  58 (defun ctree-match-calist (rule-tree alist)
  59   "Return matched condition-alist if ALIST matches RULE-TREE."
  60   (if (null rule-tree)
  61       alist
  62     (let ((type (car rule-tree))
  63           (choices (cdr rule-tree))
  64           default)
  65       (catch 'tag
  66         (while choices
  67           (let* ((choice (car choices))
  68                  (choice-value (car choice)))
  69             (if (eq choice-value t)
  70                 (setq default choice)
  71               (let ((ret-alist (calist-field-match alist type (car choice))))
  72                 (if ret-alist
  73                     (throw 'tag
  74                            (if (cdr choice)
  75                                (ctree-match-calist (cdr choice) ret-alist)
  76                              ret-alist))))))
  77           (setq choices (cdr choices)))
  78         (if default
  79             (let ((ret-alist (calist-field-match alist type t)))
  80               (if ret-alist
  81                   (if (cdr default)
  82                       (ctree-match-calist (cdr default) ret-alist)
  83                     ret-alist))))))))
  84
  85 (defun ctree-match-calist-partially (rule-tree alist)
  86   "Return matched condition-alist if ALIST matches RULE-TREE."
  87   (if (null rule-tree)
  88       alist
  89     (let ((type (car rule-tree))
  90           (choices (cdr rule-tree))
  91           default)
  92       (catch 'tag
  93         (while choices
  94           (let* ((choice (car choices))
  95                  (choice-value (car choice)))
  96             (if (eq choice-value t)
  97                 (setq default choice)
  98               (let ((ret-alist (calist-field-match alist type (car choice))))
  99                 (if ret-alist
 100                     (throw 'tag
 101                            (if (cdr choice)
 102                                (ctree-match-calist-partially
 103                                 (cdr choice) ret-alist)
 104                              ret-alist))))))
 105           (setq choices (cdr choices)))
 106         (if default
 107             (let ((ret-alist (calist-field-match alist type t)))
 108               (if ret-alist
 109                   (if (cdr default)
 110                       (ctree-match-calist-partially (cdr default) ret-alist)
 111                     ret-alist)))
 112           (calist-field-match alist type t))))))
 113
 114 (defun ctree-find-calist (rule-tree alist &optional all)
 115   "Return list of condition-alist which matches ALIST in RULE-TREE.
 116 If optional argument ALL is specified, default rules are not ignored
 117 even if other rules are matched for ALIST."
 118   (if (null rule-tree)
 119       (list alist)
 120     (let ((type (car rule-tree))
 121           (choices (cdr rule-tree))
 122           default dest)
 123       (while choices
 124         (let* ((choice (car choices))
 125                (choice-value (car choice)))
 126           (if (eq choice-value t)
 127               (setq default choice)
 128             (let ((ret-alist (calist-field-match alist type (car choice))))
 129               (if ret-alist
 130                   (if (cdr choice)
 131                       (let ((ret (ctree-find-calist
 132                                   (cdr choice) ret-alist all)))
 133                         (while ret
 134                           (let ((elt (car ret)))
 135                             (or (member elt dest)
 136                                 (setq dest (cons elt dest))))
 137                           (setq ret (cdr ret))))
 138                     (or (member ret-alist dest)
 139                         (setq dest (cons ret-alist dest))))))))
 140         (setq choices (cdr choices)))
 141       (or (and (not all) dest)
 142           (if default
 143               (let ((ret-alist (calist-field-match alist type t)))
 144                 (if ret-alist
 145                     (if (cdr default)
 146                         (let ((ret (ctree-find-calist
 147                                     (cdr default) ret-alist all)))
 148                           (while ret
 149                             (let ((elt (car ret)))
 150                               (or (member elt dest)
 151                                   (setq dest (cons elt dest))))
 152                             (setq ret (cdr ret))))
 153                       (or (member ret-alist dest)
 154                           (setq dest (cons ret-alist dest)))))))
 155                 dest)))
 156
 157 (defun calist-to-ctree (calist)
 158   "Convert condition-alist CALIST to condition-tree."
 159   (if calist
 160       (let* ((cell (car calist)))
 161         (cons (car cell)
 162               (list (cons (cdr cell)
 163                           (calist-to-ctree (cdr calist))))))))
 164
 165 (defun ctree-add-calist-strictly (ctree calist)
 166   "Add condition CALIST to condition-tree CTREE without default clause."
 167   (cond ((null calist) ctree)
 168         ((null ctree)
 169          (calist-to-ctree calist))
 170         (t
 171          (let* ((type (car ctree))
 172                 (values (cdr ctree))
 173                 (ret (assoc type calist)))
 174            (if ret
 175                (catch 'tag
 176                  (while values
 177                    (let ((cell (car values)))
 178                      (if (equal (car cell)(cdr ret))
 179                          (throw 'tag
 180                                 (setcdr cell
 181                                         (ctree-add-calist-strictly
 182                                          (cdr cell)
 183                                          (delete ret (copy-alist calist)))))))
 184                    (setq values (cdr values)))
 185                  (setcdr ctree (cons (cons (cdr ret)
 186                                            (calist-to-ctree
 187                                             (delete ret (copy-alist calist))))
 188                                      (cdr ctree))))
 189              (catch 'tag
 190                (while values
 191                  (let ((cell (car values)))
 192                    (setcdr cell
 193                            (ctree-add-calist-strictly (cdr cell) calist)))
 194                  (setq values (cdr values)))))
 195            ctree))))
 196
 197 (defun ctree-add-calist-with-default (ctree calist)
 198   "Add condition CALIST to condition-tree CTREE with default clause."
 199   (cond ((null calist) ctree)
 200         ((null ctree)
 201          (let* ((cell (car calist))
 202                 (type (car cell))
 203                 (value (cdr cell)))
 204            (cons type
 205                  (list (list t)
 206                        (cons value (calist-to-ctree (cdr calist)))))))
 207         (t
 208          (let* ((type (car ctree))
 209                 (values (cdr ctree))
 210                 (ret (assoc type calist)))
 211            (if ret
 212                (catch 'tag
 213                  (while values
 214                    (let ((cell (car values)))
 215                      (if (equal (car cell)(cdr ret))
 216                          (throw 'tag
 217                                 (setcdr cell
 218                                         (ctree-add-calist-with-default
 219                                          (cdr cell)
 220                                          (delete ret (copy-alist calist)))))))
 221                    (setq values (cdr values)))
 222                  (if (assq t (cdr ctree))
 223                      (setcdr ctree
 224                              (cons (cons (cdr ret)
 225                                          (calist-to-ctree
 226                                           (delete ret (copy-alist calist))))
 227                                    (cdr ctree)))
 228                    (setcdr ctree
 229                            (list* (list t)
 230                                   (cons (cdr ret)
 231                                         (calist-to-ctree
 232                                          (delete ret (copy-alist calist))))
 233                                   (cdr ctree)))))
 234              (catch 'tag
 235                (while values
 236                  (let ((cell (car values)))
 237                    (setcdr cell
 238                            (ctree-add-calist-with-default (cdr cell) calist)))
 239                  (setq values (cdr values)))
 240                (let ((cell (assq t (cdr ctree))))
 241                  (if cell
 242                      (setcdr cell
 243                              (ctree-add-calist-with-default (cdr cell)
 244                                                             calist))
 245                    (let ((elt (cons t (calist-to-ctree calist))))
 246                      (or (member elt (cdr ctree))
 247                          (setcdr ctree (cons elt (cdr ctree))))))
 248                             ctree))))
 249
 250 (defun ctree-set-calist-strictly (ctree-var calist)
 251   "Set condition CALIST in CTREE-VAR without default clause."
 252   (set ctree-var
 253        (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
 254
 255 (defun ctree-set-calist-with-default (ctree-var calist)
 256   "Set condition CALIST to CTREE-VAR with default clause."
 257   (set ctree-var
 258        (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
 259
 260 ))));;; @ end
 261 ;;;
 262
 263 (provide 'calist)
 264
 265 ;;; calist.el ends here