elisp/concord.el

   1 (defun concord-object-p (object)
   2   (eq (aref object 0) :concord))
   3
   4 (defun concord-object-type (object)
   5   (and (concord-object-p object)
   6        (aref object 1)))
   7
   8 (defun concord-object-id (object)
   9   (and (concord-object-p object)
  10        (aref object 2)))
  11
  12 (defun concord-define-object (type spec &optional id)
  13   (concord-el-define-object type spec id))
  14
  15 (defun concord-object-get-value (object feature)
  16   (concord-el-object-get-value object feature))
  17
  18 (defun concord-object-spec (object)
  19   (concord-el-object-spec object))
  20
  21 (defun concord-feature-list (type)
  22   (concord-el-feature-list type))
  23
  24 (defun concord-map-objects (function type)
  25   (concord-el-map-objects function type))
  26
  27 (defun concord-map-feature (function feature type)
  28   (concord-el-map-feature function feature type))
  29
  30
  31 (defvar concord-el-type-list-table
  32   (make-hash-table))
  33
  34 (defun concord-el-get-type-table (type)
  35   (gethash type concord-el-type-list-table))
  36
  37 (defun concord-el-get-type-table-create (type)
  38   (let ((type-table (gethash type concord-el-type-list-table)))
  39     (unless type-table
  40       (setq type-table (make-hash-table))
  41       (puthash type type-table concord-el-type-list-table))
  42     type-table))
  43
  44 (defun concord-el-type-table-get-feature-table (type-table feature)
  45   (gethash feature type-table))
  46
  47 (defun concord-el-type-table-get-feature-table-create (type-table feature)
  48   (let ((feature-table (gethash feature type-table)))
  49     (unless feature-table
  50       (setq feature-table (make-hash-table))
  51       (puthash feature feature-table type-table))
  52     feature-table))
  53
  54
  55 (defun concord-el-type-table-get-object-feature (type-table object-id feature)
  56   (let ((feature-table
  57          (concord-el-type-table-get-feature-table type-table feature)))
  58     (if feature-table
  59         (gethash object-id feature-table))))
  60
  61 (defun concord-el-type-table-put-object-feature (type-table object-id
  62                                                             feature value)
  63   (let ((feature-table
  64          (concord-el-type-table-get-feature-table-create type-table feature)))
  65     (cond
  66      ((eq '->subsumptive feature)
  67       (dolist (spec value)
  68         (concord-el-type-table-put-object type-table spec))))
  69     (puthash object-id value feature-table)))
  70
  71
  72 (defun concord-el-type-table-put-object (type-table spec &optional id)
  73   (let (self)
  74     (unless id
  75       (setq id (cdr (assq '=id spec))))
  76     (when id
  77       (dolist (feature spec)
  78         (concord-el-type-table-put-object-feature
  79          type-table id (car feature)(cdr feature)))
  80       (setq self (vector :concord type id))
  81       (concord-el-type-table-put-object-feature
  82        type-table id '=self self)
  83       self)))
  84
  85 (defun concord-el-define-object (type spec &optional id)
  86   (let ((type-table (concord-el-get-type-table-create type)))
  87     (if type-table
  88         (concord-el-type-table-put-object type-table spec id))))
  89
  90 (defun concord-el-object-get-value (object feature)
  91   (let ((type (concord-object-type object))
  92         type-table id)
  93     (when (and (setq type-table (concord-el-get-type-table type))
  94                (setq id (concord-object-id object)))
  95       (concord-el-type-table-get-object-feature type-table id feature))))
  96
  97 (defun concord-el-object-spec (object)
  98   (let ((type (concord-object-type object))
  99         dest ret)
 100     (dolist (feature (concord-el-feature-list type))
 101       (when (setq ret (concord-el-object-get-value object feature))
 102         (setq dest (cons (cons feature ret) dest))))
 103     dest))
 104
 105 (defun concord-el-map-feature (function feature type)
 106   (let ((type-table (concord-el-get-type-table type))
 107         feature-table self)
 108     (if type-table
 109         (if (setq feature-table
 110                   (concord-el-type-table-get-feature-table
 111                    type-table feature))
 112             (maphash (lambda (id val)
 113                        (setq self
 114                              (concord-el-type-table-get-object-feature
 115                               type-table id '=self))
 116                        (funcall function self val))
 117                      feature-table)))))
 118
 119 (defun concord-el-map-objects (function type)
 120   (let ((type-table (concord-el-get-type-table type))
 121         feature-table)
 122     (if type-table
 123         (if (setq feature-table
 124                   (concord-el-type-table-get-feature-table
 125                    type-table '=self))
 126             (maphash (lambda (id self)
 127                        (funcall function self))
 128                      feature-table)))))
 129
 130 (defun concord-el-feature-list (type)
 131   (let (dest)
 132     (maphash (lambda (key val)
 133                (setq dest (cons key dest))
 134                nil)
 135              (concord-el-get-type-table type))
 136     dest))