ids-rw.el

   1 ;;; ids-rw.el --- Rewriting utility for ideographic-structure.
   2
   3 ;; Copyright (C) 2006 MORIOKA Tomohiko
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
   6 ;; Keywords: IDS, TRS, IDC, Ideographs, UCS, Unicode
   7
   8 ;; This file is a part of IDS.
   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 this program; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (defun ideographic-structure-unify-char (structure pattern &optional env)
  28   (if (char-ref-p structure)
  29       (setq structure (plist-get structure :char)))
  30   (cond
  31    ((eq structure pattern)
  32     (or env t)
  33     )
  34    ((symbolp pattern)
  35     (if (eq env t)
  36         (setq env nil))
  37     (let ((ret (assq pattern env)))
  38       (if ret
  39           (if (eq structure (cdr ret))
  40               env)
  41         (cons (cons pattern structure)
  42               env))))))
  43
  44 (defun ideographic-structure-unify-unit (structure pattern &optional env)
  45   (or (ideographic-structure-unify-char structure pattern env)
  46       (let (prest srest ret)
  47         (if (and
  48              (progn
  49                (if (setq ret
  50                          (if (consp structure)
  51                              (cdr (assq 'ideographic-structure structure))
  52                            (char-feature structure 'ideographic-structure)))
  53                    (setq structure ret))
  54                (consp structure))
  55              (setq srest structure)
  56              (progn
  57                (if (setq ret
  58                          (cond ((consp pattern)
  59                                 (cdr (assq 'ideographic-structure pattern))
  60                                 )
  61                                ((characterp pattern)
  62                                 (char-feature pattern 'ideographic-structure)
  63                                 )))
  64                    (setq pattern ret))
  65                (consp pattern))
  66              (setq prest pattern)
  67              (catch 'tag
  68                (while prest
  69                  (if (not (setq env (ideographic-structure-unify-unit
  70                                      (car srest) (car prest) env)))
  71                      (throw 'tag nil))
  72                  (setq prest (cdr prest)
  73                        srest (cdr srest)))
  74                t))
  75             (or env t)))))
  76
  77 (defun ideographic-structure-apply-to-term (term env)
  78   (let (ret dest rest)
  79     (cond
  80      ((symbolp term)
  81       (if (setq ret (assq term env))
  82           (cdr ret)
  83         term))
  84      ((and (consp term)
  85            (cond ((setq ret (assq 'ideographic-structure term))
  86                   (setq rest (cdr ret))
  87                   )
  88                  ((atom (car term))
  89                   (setq rest term)
  90                   )))
  91       (while rest
  92         (setq dest
  93               (cons (ideographic-structure-apply-to-term
  94                      (car rest) env)
  95                     dest))
  96         (setq rest (cdr rest)))
  97       (list (cons 'ideographic-structure (nreverse dest)))
  98       )
  99      (t term))))
 100
 101 ;;;###autoload
 102 (defun ideographic-structure-rewrite (structure
 103                                       pattern replacement
 104                                       &optional env)
 105   (if (setq env (ideographic-structure-unify-unit structure pattern env))
 106       (ideographic-structure-apply-to-term replacement env)
 107     (let (srest cell ret dest)
 108       (if (setq ret
 109                 (if (consp structure)
 110                     (cdr (assq 'ideographic-structure structure))
 111                   (char-feature structure 'ideographic-structure)))
 112           (setq structure ret))
 113       (when (consp structure)
 114         (setq srest (cdr structure))
 115         (if (catch 'tag
 116               (while srest
 117                 (if (setq ret (ideographic-structure-rewrite
 118                                (car srest)
 119                                pattern replacement
 120                                env))
 121                     (throw 'tag ret))
 122                 (setq dest (cons (car srest) dest)
 123                       srest (cdr srest))))
 124             (cons (car structure)
 125                   (append (nreverse (cons ret dest))
 126                           (cdr srest))))))))
 127
 128 ;;;###autoload
 129 (defun ideographic-structure-rewrite-by-rules (structure rules)
 130   (let (rest rule ret)
 131     (while
 132         (progn
 133           (setq rest rules)
 134           (if (catch 'tag
 135                 (while rest
 136                   (setq rule (car rest))
 137                   (if (setq ret (ideographic-structure-rewrite structure
 138                                                                (car rule)
 139                                                                (cdr rule)))
 140                       (throw 'tag ret))
 141                   (setq rest (cdr rest))))
 142               (if (equal ret structure)
 143                   nil
 144                 (setq structure ret)))))
 145     structure))
 146
 147 ;;;###autoload
 148 (defun ideographic-structure-compact (structure)
 149   (let ((rest structure)
 150         cell
 151         ret dest sub)
 152     (while rest
 153       (setq cell (car rest))
 154       (cond
 155        ((and (consp cell)
 156              (cond ((setq ret (assq 'ideographic-structure cell))
 157                     (setq sub (cdr ret))
 158                     )
 159                    ((atom (car cell))
 160                     (setq sub cell)
 161                     )))
 162         (setq cell
 163               (if (setq ret (ideographic-structure-find-char sub))
 164                   ret
 165                 (list (cons 'ideographic-structure sub))))
 166         ))
 167       (setq dest (cons cell dest)))
 168     (nreverse dest)))
 169
 170
 171 ;;; @ End.
 172 ;;;
 173
 174 (provide 'ids-rw)
 175
 176 ;;; ids-rw.el ends here