ids-rw.el

   1 ;;; ids-rw.el --- Rewriting utility for ideographic-structure.
   2
   3 ;; Copyright (C) 2006, 2020 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 (require 'ids-find)
  28
  29 (defun ideographic-structure-unify-char (structure pattern &optional env)
  30   (if (char-ref-p structure)
  31       (setq structure (plist-get structure :char)))
  32   (cond
  33    ((eq structure pattern)
  34     (or env t)
  35     )
  36    ((symbolp pattern)
  37     (if (eq env t)
  38         (setq env nil))
  39     (let ((ret (assq pattern env)))
  40       (if ret
  41           (if (eq structure (cdr ret))
  42               env)
  43         (cons (cons pattern structure)
  44               env))))))
  45
  46 (defun ideographic-structure-unify-unit (structure pattern &optional env)
  47   (or (ideographic-structure-unify-char structure pattern env)
  48       (let (prest srest ret)
  49         (if (and
  50              (progn
  51                (if (setq ret
  52                          (if (consp structure)
  53                              (cdr (assq 'ideographic-structure structure))
  54                            (char-feature structure 'ideographic-structure)))
  55                    (setq structure ret))
  56                (consp structure))
  57              (setq srest structure)
  58              (progn
  59                (if (setq ret
  60                          (cond ((consp pattern)
  61                                 (cdr (assq 'ideographic-structure pattern))
  62                                 )
  63                                ((characterp pattern)
  64                                 (char-feature pattern 'ideographic-structure)
  65                                 )))
  66                    (setq pattern ret))
  67                (consp pattern))
  68              (setq prest pattern)
  69              (catch 'tag
  70                (while prest
  71                  (if (not (setq env (ideographic-structure-unify-unit
  72                                      (car srest) (car prest) env)))
  73                      (throw 'tag nil))
  74                  (setq prest (cdr prest)
  75                        srest (cdr srest)))
  76                t))
  77             (or env t)))))
  78
  79 (defun ideographic-structure-apply-to-term (term env)
  80   (let (ret dest rest)
  81     (cond
  82      ((symbolp term)
  83       (if (setq ret (assq term env))
  84           (cdr ret)
  85         term))
  86      ((and (consp term)
  87            (cond ((setq ret (assq 'ideographic-structure term))
  88                   (setq rest (cdr ret))
  89                   )
  90                  ((atom (car term))
  91                   (setq rest term)
  92                   )))
  93       (while rest
  94         (setq dest
  95               (cons (ideographic-structure-apply-to-term
  96                      (car rest) env)
  97                     dest))
  98         (setq rest (cdr rest)))
  99       (list (cons 'ideographic-structure (nreverse dest)))
 100       )
 101      (t term))))
 102
 103 ;;;###autoload
 104 (defun ideographic-structure-rewrite (structure
 105                                       pattern replacement
 106                                       &optional env)
 107   (if (setq env (ideographic-structure-unify-unit structure pattern env))
 108       (ideographic-structure-apply-to-term replacement env)
 109     (let (srest cell ret dest)
 110       (if (setq ret
 111                 (if (consp structure)
 112                     (cdr (assq 'ideographic-structure structure))
 113                   (char-feature structure 'ideographic-structure)))
 114           (setq structure ret))
 115       (when (consp structure)
 116         (setq srest (cdr structure))
 117         (if (catch 'tag
 118               (while srest
 119                 (if (setq ret (ideographic-structure-rewrite
 120                                (car srest)
 121                                pattern replacement
 122                                env))
 123                     (throw 'tag ret))
 124                 (setq dest (cons (car srest) dest)
 125                       srest (cdr srest))))
 126             (cons (car structure)
 127                   (append (nreverse (cons ret dest))
 128                           (cdr srest))))))))
 129
 130 ;;;###autoload
 131 (defun ideographic-structure-rewrite-by-rules (structure rules)
 132   (let (rest rule ret)
 133     (while
 134         (progn
 135           (setq rest rules)
 136           (if (catch 'tag
 137                 (while rest
 138                   (setq rule (car rest))
 139                   (if (setq ret (ideographic-structure-rewrite structure
 140                                                                (car rule)
 141                                                                (cdr rule)))
 142                       (throw 'tag ret))
 143                   (setq rest (cdr rest))))
 144               (if (equal ret structure)
 145                   nil
 146                 (setq structure ret)))))
 147     structure))
 148
 149
 150
 151 ;;; @ End.
 152 ;;;
 153
 154 (provide 'ids-rw)
 155
 156 ;;; ids-rw.el ends here