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 GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28
  29 (defvar calist-field-match-method-obarray [nil])
  30
  31 (defun define-calist-field-match-method (field-type function)
  32   "Set field-match-method for FIELD-TYPE to FUNCTION."
  33   (fset (intern (symbol-name field-type) calist-field-match-method-obarray)
  34         function))
  35
  36 (defun calist-default-field-match-method (calist field-type field-value)
  37   (let ((s-field (assoc field-type calist)))
  38     (cond ((null s-field)
  39            (cons (cons field-type field-value) calist)
  40            )
  41           ((eq field-value t)
  42            calist)
  43           ((equal (cdr s-field) field-value)
  44            calist))))
  45
  46 (defsubst calist-field-match-method (field-type)
  47   (condition-case nil
  48       (symbol-function
  49        (intern-soft
  50         (symbol-name field-type) calist-field-match-method-obarray))
  51     (error (symbol-function 'calist-default-field-match-method))
  52     ))
  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                   ))))
  78           (setq choices (cdr choices)))
  79         (if default
  80             (let ((ret-alist (calist-field-match alist type t)))
  81               (if ret-alist
  82                   (if (cdr default)
  83                       (ctree-match-calist (cdr default) ret-alist)
  84                     ret-alist))))
  85         ))))
  86
  87 (defun ctree-match-calist-partially (rule-tree alist)
  88   "Return matched condition-alist if ALIST matches RULE-TREE."
  89   (if (null rule-tree)
  90       alist
  91     (let ((type (car rule-tree))
  92           (choices (cdr rule-tree))
  93           default)
  94       (catch 'tag
  95         (while choices
  96           (let* ((choice (car choices))
  97                  (choice-value (car choice)))
  98             (if (eq choice-value t)
  99                 (setq default choice)
 100               (let ((ret-alist (calist-field-match alist type (car choice))))
 101                 (if ret-alist
 102                     (throw 'tag
 103                            (if (cdr choice)
 104                                (ctree-match-calist-partially
 105                                 (cdr choice) ret-alist)
 106                              ret-alist))
 107                   ))))
 108           (setq choices (cdr choices)))
 109         (if default
 110             (let ((ret-alist (calist-field-match alist type t)))
 111               (if ret-alist
 112                   (if (cdr default)
 113                       (ctree-match-calist-partially (cdr default) ret-alist)
 114                     ret-alist)))
 115           (calist-field-match alist type t))
 116         ))))
 117
 118 (defun ctree-find-calist (rule-tree alist &optional all)
 119   "Return list of condition-alist which matches ALIST in RULE-TREE.
 120 If optional argument ALL is specified, default rules are not ignored
 121 even if other rules are matched for ALIST."
 122   (if (null rule-tree)
 123       (list alist)
 124     (let ((type (car rule-tree))
 125           (choices (cdr rule-tree))
 126           default dest)
 127       (while choices
 128         (let* ((choice (car choices))
 129                (choice-value (car choice)))
 130           (if (eq choice-value t)
 131               (setq default choice)
 132             (let ((ret-alist (calist-field-match alist type (car choice))))
 133               (if ret-alist
 134                   (if (cdr choice)
 135                       (let ((ret (ctree-find-calist
 136                                   (cdr choice) ret-alist all)))
 137                         (while ret
 138                           (let ((elt (car ret)))
 139                             (or (member elt dest)
 140                                 (setq dest (cons elt dest))
 141                                 ))
 142                           (setq ret (cdr ret))
 143                           ))
 144                     (or (member ret-alist dest)
 145                         (setq dest (cons ret-alist dest)))
 146                     )))))
 147         (setq choices (cdr choices)))
 148       (or (and (not all) dest)
 149           (if default
 150               (let ((ret-alist (calist-field-match alist type t)))
 151                 (if ret-alist
 152                     (if (cdr default)
 153                         (let ((ret (ctree-find-calist
 154                                     (cdr default) ret-alist all)))
 155                           (while ret
 156                             (let ((elt (car ret)))
 157                               (or (member elt dest)
 158                                   (setq dest (cons elt dest))
 159                                   ))
 160                             (setq ret (cdr ret))
 161                             ))
 162                       (or (member ret-alist dest)
 163                           (setq dest (cons ret-alist dest)))
 164                       ))))
 165           )
 166       dest)))
 167
 168 (defun calist-to-ctree (calist)
 169   "Convert condition-alist CALIST to condition-tree."
 170   (if calist
 171       (let* ((cell (car calist)))
 172         (cons (car cell)
 173               (list (cons (cdr cell)
 174                           (calist-to-ctree (cdr calist))
 175                           ))))))
 176
 177 (defun ctree-add-calist-strictly (ctree calist)
 178   "Add condition CALIST to condition-tree CTREE without default clause."
 179   (cond ((null calist) ctree)
 180         ((null ctree)
 181          (calist-to-ctree calist)
 182          )
 183         (t
 184          (let* ((type (car ctree))
 185                 (values (cdr ctree))
 186                 (ret (assoc type calist)))
 187            (if ret
 188                (catch 'tag
 189                  (while values
 190                    (let ((cell (car values)))
 191                      (if (equal (car cell)(cdr ret))
 192                          (throw 'tag
 193                                 (setcdr cell
 194                                         (ctree-add-calist-strictly
 195                                          (cdr cell)
 196                                          (delete ret (copy-alist calist)))
 197                                         ))))
 198                    (setq values (cdr values)))
 199                  (setcdr ctree (cons (cons (cdr ret)
 200                                            (calist-to-ctree
 201                                             (delete ret (copy-alist calist))))
 202                                      (cdr ctree)))
 203                  )
 204              (catch 'tag
 205                (while values
 206                  (let ((cell (car values)))
 207                    (setcdr cell
 208                            (ctree-add-calist-strictly (cdr cell) calist))
 209                    )
 210                  (setq values (cdr values))))
 211              )
 212            ctree))))
 213
 214 (defun ctree-add-calist-with-default (ctree calist)
 215   "Add condition CALIST to condition-tree CTREE with default clause."
 216   (cond ((null calist) ctree)
 217         ((null ctree)
 218          (let* ((cell (car calist))
 219                 (type (car cell))
 220                 (value (cdr cell)))
 221            (cons type
 222                  (list (list t)
 223                        (cons value (calist-to-ctree (cdr calist)))))
 224            ))
 225         (t
 226          (let* ((type (car ctree))
 227                 (values (cdr ctree))
 228                 (ret (assoc type calist)))
 229            (if ret
 230                (catch 'tag
 231                  (while values
 232                    (let ((cell (car values)))
 233                      (if (equal (car cell)(cdr ret))
 234                          (throw 'tag
 235                                 (setcdr cell
 236                                         (ctree-add-calist-with-default
 237                                          (cdr cell)
 238                                          (delete ret (copy-alist calist)))
 239                                         ))))
 240                    (setq values (cdr values)))
 241                  (if (assq t (cdr ctree))
 242                      (setcdr ctree
 243                              (cons (cons (cdr ret)
 244                                          (calist-to-ctree
 245                                           (delete ret (copy-alist calist))))
 246                                    (cdr ctree)))
 247                    (setcdr ctree
 248                            (list* (list t)
 249                                   (cons (cdr ret)
 250                                         (calist-to-ctree
 251                                          (delete ret (copy-alist calist))))
 252                                   (cdr ctree)))
 253                    ))
 254              (catch 'tag
 255                (while values
 256                  (let ((cell (car values)))
 257                    (setcdr cell
 258                            (ctree-add-calist-with-default (cdr cell) calist))
 259                    )
 260                  (setq values (cdr values)))
 261                (let ((cell (assq t (cdr ctree))))
 262                  (if cell
 263                      (setcdr cell
 264                              (ctree-add-calist-with-default (cdr cell)
 265                                                             calist))
 266                    (let ((elt (cons t (calist-to-ctree calist))))
 267                      (or (member elt (cdr ctree))
 268                          (setcdr ctree (cons elt (cdr ctree)))
 269                          ))
 270                    )))
 271              )
 272            ctree))))
 273
 274 (defun ctree-set-calist-strictly (ctree-var calist)
 275   "Set condition CALIST in CTREE-VAR without default clause."
 276   (set ctree-var
 277        (ctree-add-calist-strictly (symbol-value ctree-var) calist)))
 278
 279 (defun ctree-set-calist-with-default (ctree-var calist)
 280   "Set condition CALIST to CTREE-VAR with default clause."
 281   (set ctree-var
 282        (ctree-add-calist-with-default (symbol-value ctree-var) calist)))
 283
 284
 285 ;;; @ end
 286 ;;;
 287
 288 (provide 'calist)
 289
 290 ;;; calist.el ends here