From 2e9954331cde61dedfe180b611ca5beaabff3839 Mon Sep 17 00:00:00 2001
From: tomo <tomo>
Date: Mon, 20 Dec 2004 07:55:19 +0000
Subject: [PATCH 1/1] New file.

---
 elisp/ChangeLog  |    4 ++
 elisp/concord.el |  136 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 140 insertions(+)
 create mode 100644 elisp/ChangeLog
 create mode 100644 elisp/concord.el

diff --git a/elisp/ChangeLog b/elisp/ChangeLog
new file mode 100644
index 0000000..c7f0e4a
--- /dev/null
+++ b/elisp/ChangeLog
@@ -0,0 +1,4 @@
+2004-12-13  MORIOKA Tomohiko  <tomo@kanji.zinbun.kyoto-u.ac.jp>
+
+	* concord.el: New file.
+
diff --git a/elisp/concord.el b/elisp/concord.el
new file mode 100644
index 0000000..a804116
--- /dev/null
+++ b/elisp/concord.el
@@ -0,0 +1,136 @@
+(defun concord-object-p (object)
+  (eq (aref object 0) :concord))
+
+(defun concord-object-type (object)
+  (and (concord-object-p object)
+       (aref object 1)))
+
+(defun concord-object-id (object)
+  (and (concord-object-p object)
+       (aref object 2)))
+
+(defun concord-define-object (type spec &optional id)
+  (concord-el-define-object type spec id))
+
+(defun concord-object-get-value (object feature)
+  (concord-el-object-get-value object feature))
+
+(defun concord-object-spec (object)
+  (concord-el-object-spec object))
+
+(defun concord-feature-list (type)
+  (concord-el-feature-list type))
+
+(defun concord-map-objects (function type)
+  (concord-el-map-objects function type))
+
+(defun concord-map-feature (function feature type)
+  (concord-el-map-feature function feature type))
+
+
+(defvar concord-el-type-list-table
+  (make-hash-table))
+
+(defun concord-el-get-type-table (type)
+  (gethash type concord-el-type-list-table))
+
+(defun concord-el-get-type-table-create (type)
+  (let ((type-table (gethash type concord-el-type-list-table)))
+    (unless type-table
+      (setq type-table (make-hash-table))
+      (puthash type type-table concord-el-type-list-table))
+    type-table))
+
+(defun concord-el-type-table-get-feature-table (type-table feature)
+  (gethash feature type-table))
+
+(defun concord-el-type-table-get-feature-table-create (type-table feature)
+  (let ((feature-table (gethash feature type-table)))
+    (unless feature-table
+      (setq feature-table (make-hash-table))
+      (puthash feature feature-table type-table))
+    feature-table))
+
+
+(defun concord-el-type-table-get-object-feature (type-table object-id feature)
+  (let ((feature-table
+	 (concord-el-type-table-get-feature-table type-table feature)))
+    (if feature-table
+	(gethash object-id feature-table))))
+
+(defun concord-el-type-table-put-object-feature (type-table object-id
+							    feature value)
+  (let ((feature-table
+	 (concord-el-type-table-get-feature-table-create type-table feature)))
+    (cond
+     ((eq '->subsumptive feature)
+      (dolist (spec value)
+	(concord-el-type-table-put-object type-table spec))))
+    (puthash object-id value feature-table)))
+
+
+(defun concord-el-type-table-put-object (type-table spec &optional id)
+  (let (self)
+    (unless id
+      (setq id (cdr (assq '=id spec))))
+    (when id
+      (dolist (feature spec)
+	(concord-el-type-table-put-object-feature
+	 type-table id (car feature)(cdr feature)))
+      (setq self (vector :concord type id))
+      (concord-el-type-table-put-object-feature
+       type-table id '=self self)
+      self)))
+
+(defun concord-el-define-object (type spec &optional id)
+  (let ((type-table (concord-el-get-type-table-create type)))
+    (if type-table
+	(concord-el-type-table-put-object type-table spec id))))
+
+(defun concord-el-object-get-value (object feature)
+  (let ((type (concord-object-type object))
+	type-table id)
+    (when (and (setq type-table (concord-el-get-type-table type))
+	       (setq id (concord-object-id object)))
+      (concord-el-type-table-get-object-feature type-table id feature))))
+
+(defun concord-el-object-spec (object)
+  (let ((type (concord-object-type object))
+	dest ret)
+    (dolist (feature (concord-el-feature-list type))
+      (when (setq ret (concord-el-object-get-value object feature))
+	(setq dest (cons (cons feature ret) dest))))
+    dest))
+
+(defun concord-el-map-feature (function feature type)
+  (let ((type-table (concord-el-get-type-table type))
+	feature-table self)
+    (if type-table
+	(if (setq feature-table
+		  (concord-el-type-table-get-feature-table
+		   type-table feature))
+	    (maphash (lambda (id val)
+		       (setq self
+			     (concord-el-type-table-get-object-feature
+			      type-table id '=self))
+		       (funcall function self val))
+		     feature-table)))))
+
+(defun concord-el-map-objects (function type)
+  (let ((type-table (concord-el-get-type-table type))
+	feature-table)
+    (if type-table
+	(if (setq feature-table
+		  (concord-el-type-table-get-feature-table
+		   type-table '=self))
+	    (maphash (lambda (id self)
+		       (funcall function self))
+		     feature-table)))))
+
+(defun concord-el-feature-list (type)
+  (let (dest)
+    (maphash (lambda (key val)
+	       (setq dest (cons key dest))
+	       nil)
+	     (concord-el-get-type-table type))
+    dest))
-- 
1.7.10.4