elisp/honey.el

   1 ;; honey.el - Higher Order NEsted Yarnknotter --- back-end for Arxana
   2
   3 ;; Copyright (C) 2010, 2011, 2012, 2013 Raymond S. Puzio
   4
   5 ;; This program is free software: you can redistribute it and/or modify
   6 ;; it under the terms of the GNU Affero General Public License as published by
   7 ;; the Free Software Foundation, either version 3 of the License, or
   8 ;; (at your option) any later version.
   9
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU Affero General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU Affero General Public License
  16 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 ;;; Commentary:
  19
  20 ;; See honey-demo.tex for background.
  21
  22 ;;; Code:
  23
  24 (defun new-net (parent)
  25   "Create a new network."
  26   (let ((newbie (list '*network*
  27                       1                               ; article counter
  28                       (make-hash-table :test 'equal)  ; article table
  29                       (make-hash-table :test 'equal)  ; forward links
  30                       (make-hash-table :test 'equal)  ; backward links
  31                       (make-hash-table :test 'equal)  ; forward labels
  32                       (make-hash-table :test 'equal)  ; backward labels
  33                       parent)))
  34                                         ; Define ground and article-type.
  35     (puthash 0 '(0 0) (nth 2 newbie))
  36     (puthash 1 '(0 0) (nth 2 newbie))
  37     (puthash 0 '((0 . 0) (1 . 0)) (nth 3 newbie))
  38     (puthash 0 '((0 . 0) (1 . 0)) (nth 4 newbie))
  39     (puthash 0 '"ground" (nth 5 newbie))
  40     (puthash '"ground" 0 (nth 6 newbie))
  41     (puthash 1 '"article-type" (nth 5 newbie))
  42     (puthash '"article-type" 1 (nth 6 newbie))
  43     newbie))
  44
  45 (defvar root-level 0)
  46
  47 (defun set-net (net)
  48   "Examine a different network instead."
  49   (setq current-net net))
  50
  51 (defmacro with-current-net (net &rest expr)
  52   (append `(let ((current-net ,net))) ,expr))
  53
  54 (defun current-net ()
  55   "Return the network currently being examined."
  56   current-net)
  57
  58 (defun reset-net ()
  59   "Reset the database to its initial configuration."
  60   ; Reset article counter and hash tables.
  61   (setcar (cdr current-net) 1)
  62   (dotimes (n 5) (clrhash (nth (+ n 2) current-net)))
  63   ; Define ground and article-type.
  64   (puthash 0 '(0 0) (nth 2 current-net))
  65   (puthash 1 '(0 0) (nth 2 current-net))
  66   (puthash 0 '((0 . 0) (1 . 0)) (nth 3 current-net))
  67   (puthash 0 '((0 . 0) (1 . 0)) (nth 4 current-net))
  68   (puthash 0 '"ground" (nth 5 current-net))
  69   (puthash '"ground" 0 (nth 6 current-net))
  70   (puthash 1 '"article-type" (nth 5 current-net))
  71   (puthash '"article-type" 1 (nth 6 current-net))
  72   nil)
  73
  74 (defun next-unique-id ()
  75   "Produce a yet unused unique identifier."
  76   (setcar (cdr current-net)
  77             (1+ (cadr current-net))))
  78
  79 (defun download-en-masse ()
  80   "Produce a representation of the database as quintuples."
  81   (let ((net nil))
  82     (maphash '(lambda (uid tplt)
  83                 ; Unpack triplet.
  84                 (let ((src (car tplt))
  85                             (snk (nth 1 tplt))
  86                                   (txt (nthcdr 2 tplt)))
  87                     ; Obtain next label if exists.
  88                     (setq lbl (gethash uid
  89                                             (nth 5 current-net)
  90                                                  nil))
  91                       ; Write data to list.
  92                       (setq net (cons `(,uid ,lbl ,src ,snk . ,txt)
  93                                         net))))
  94                   (nth 2 current-net))
  95     ; Return list of data.
  96     (reverse net)))
  97
  98 (defun upload-en-masse (net)
  99   "Load a representation of a database as quintuples into memory."
 100   (dolist (qplt net t)
 101     ; unpack quintuplet
 102     (let ((uid (car qplt))
 103             (lbl (nth 1 qplt))
 104               (src (nth 2 qplt))
 105                 (snk (nth 3 qplt))
 106                   (txt (nthcdr 4 qplt)))
 107       ; plug into tables
 108       (puthash uid
 109                       `(,src ,snk . ,txt)
 110                              (nth 2 current-net))
 111       (puthash src
 112                       (cons `(,uid . ,snk)
 113                                  (gethash src (nth 3 current-net) nil))
 114                              (nth 3 current-net))
 115       (puthash snk
 116                       (cons
 117                        `(,uid . ,src)
 118                        (gethash snk (nth 4 current-net) nil))
 119                              (nth 4 current-net))
 120       (when lbl
 121           (progn
 122                 (puthash uid lbl (nth 5 current-net))
 123                     (puthash lbl uid (nth 6 current-net))))
 124       ; Bump up article counter if needed.
 125       (when (> uid (cadr current-net))
 126              (setcar (cdr current-net) uid)))))
 127
 128 (defun add-en-masse (net)
 129   "Add multiple articles given as list of quartuplets."
 130   (mapcar '(lambda (qplt)
 131                   (let ((uid next-unique-id))
 132                            (put-article (nth 1 net)
 133                                             (nth 2 net)
 134                                                 (nthcar 2 net))
 135                                   (label-article uid (car qplt))))
 136             net))
 137
 138 (defun put-article (src snk txt)
 139   "Enter a new article to the database."
 140   (let ((uid (next-unique-id)))
 141     ; Add record to article table.
 142     (puthash uid
 143                    `(,src ,snk . ,txt)
 144                          (nth 2 current-net))
 145     ; Add record to list of forward links of source.
 146     (puthash src
 147                   (cons `(,uid . ,snk)
 148                               (gethash src (nth 3 current-net) nil))
 149                        (nth 3 current-net))
 150     ; Add record to list of backward links of sink.
 151     (puthash snk
 152                   (cons
 153                          `(,uid . ,src)
 154                                (gethash snk (nth 4 current-net) nil))
 155                        (nth 4 current-net))
 156     uid))
 157
 158 (defun get-content (uid)
 159   "Return the content of the article."
 160   (cddr (gethash uid (nth 2 current-net))))
 161
 162 (defun get-source (uid)
 163   "Return the source of the article."
 164   (car (gethash uid (nth 2 current-net))))
 165
 166 (defun get-sink (uid)
 167   "Return the sink of the article."
 168   (cadr (gethash uid (nth 2 current-net))))
 169
 170 (defun update-content (uid txt)
 171   "Replace the ontent of the article."
 172   (puthash uid
 173               (let ((x (gethash uid (nth 2 current-net))))
 174                      `(,(car x)    ; old source
 175                               ,(cadr x) . ; old sink
 176                                      ,txt))      ; new content
 177                  (nth 2 current-net)))
 178
 179 (defun update-source (uid new-src)
 180   "Replace the source of the article."
 181   (let* ((x (gethash uid (nth 2 current-net)))
 182           (old-src (car x))   ; extract current source
 183            (old-snk (cadr x))  ; extract current sink
 184             (old-txt (cddr x))) ; extract current content
 185     ; Update the entry in the article table.
 186     (puthash uid
 187                   `(,new-src ,old-snk . ,old-txt)
 188                        (nth 2 current-net))
 189     ; Remove the entry with the old source in the
 190     ; forward link table.  If that is the only entry
 191     ; filed under old-src, remove it from table.
 192     (let ((y (delete `(,uid . ,old-snk)
 193                           (gethash old-src (nth 3 current-net) nil))))
 194       (if y
 195             (puthash old-src y (nth 3 current-net))
 196         (remhash old-src (nth 3 current-net))))
 197     ; Add an entry with the new source in the
 198     ; forward link table.
 199     (puthash new-src
 200                   (cons `(,uid . ,old-snk)
 201                            (gethash old-src (nth 3 current-net) nil))
 202                        (nth 3 current-net))
 203     ; Update the entry in the backward link table.
 204     (puthash old-snk
 205                   (cons `(,uid . ,new-src)
 206                            (delete `(,uid . ,old-src)
 207                                       (gethash old-src (nth 4 current-net) nil)))
 208                        (nth 4 current-net))))
 209
 210 (defun update-sink (uid new-snk)
 211   "Chane the sink of the article."
 212   (let* ((x (gethash uid (nth 2 current-net)))
 213           (old-src (car x))   ; extract current source
 214            (old-snk (cadr x))  ; extract current sink
 215             (old-txt (cddr x))) ; extract current content
 216     ; Update the entry in the article table.
 217     (puthash uid
 218                   `(,old-src ,new-snk . ,old-txt)
 219                        (nth 2 current-net))
 220     ; Remove the entry with the old sink in the
 221     ; backward link table.  If that is the only entry
 222     ; filed under old-src, remove it from table.
 223     (let ((y (delete `(,uid . ,old-src)
 224                           (gethash old-snk (nth 4 current-net) nil))))
 225       (if y
 226             (puthash old-snk y (nth 4 current-net))
 227         (remhash old-snk (nth 4 current-net))))
 228     ; Add an entry with the new source in the
 229     ; backward link table.
 230     (puthash new-snk
 231                   (cons `(,uid . ,old-src)
 232                            (gethash old-snk (nth 4 current-net) nil))
 233                        (nth 4 current-net))
 234     ; Update the entry in the forward link table.
 235     (puthash old-src
 236                   (cons `(,uid . ,new-snk)
 237                            (delete `(,uid . ,old-snk)
 238                                       (gethash old-src (nth 3 current-net) nil)))
 239                        (nth 3 current-net))))
 240
 241 (defun remove-article (uid)
 242   "Remove this article from the database."
 243   (let ((old-src (car (gethash uid (nth 2 current-net))))
 244         (old-snk (cadr (gethash uid (nth 2 current-net)))))
 245   ; Remove forward link created by article.
 246   (let ((new-fwd (delete `(,uid . ,old-snk)
 247                           (gethash old-src (nth 3 current-net)))))
 248     (if new-fwd
 249         (puthash old-src new-fwd (nth 3 current-net))
 250       (remhash old-src (nth 3 current-net))))
 251   ; Remove backward link created by article.
 252   (let ((new-bkw (delete `(,uid . ,old-src)
 253                           (gethash old-snk (nth 4 current-net)))))
 254     (if new-bkw
 255         (puthash old-snk new-bkw (nth 4 current-net))
 256       (remhash old-snk (nth 4 current-net))))
 257   ; Remove record from article table.
 258   (remhash uid (nth 2 current-net))))
 259
 260 (defun get-forward-links (uid)
 261   "Return all links having given object as source."
 262   (mapcar 'car (gethash uid (nth 3 current-net))))
 263
 264 (defun get-backward-links (uid)
 265   "Return all links having given object as sink."
 266   (mapcar 'car (gethash uid (nth 4 current-net))))
 267
 268 (defun label-article (uid label)
 269   "Assign the label to the given object."
 270   (puthash uid label (nth 5 current-net))
 271   (puthash label uid (nth 6 current-net)))
 272
 273 (defun label2uid (label)
 274   "Return the unique identifier corresponding to a label."
 275   (gethash label (nth 6 current-net) nil))
 276
 277 (defun uid2label (uid)
 278   "Return the label associated to a unique identifier."
 279   (gethash uid (nth 5 current-net) nil))
 280
 281 ;; Search and Query
 282
 283 (defun ground-p (uid)
 284   "Is this article the ground?"
 285   (= uid 0))
 286
 287 (defun source-p (x y)
 288   "Is the former article the sink of the latter?"
 289   (equal x (get-source y)))
 290
 291 (defun sink-p (x y)
 292   "Is the former article the sink of the latter?"
 293   (equal x (get-sink y)))
 294
 295 (defun links-from (x y)
 296   "Return all links from article x to artice y."
 297   (filter '(lambda (z) (source-p x z))
 298             (get-backward-links y)))
 299
 300 (defun links-p (x y)
 301   "Does article x link to article y?"
 302   (when (member x (mapcar
 303                       'get-source
 304                          (get-backward-links y))) t))
 305
 306 (defun triple-p (x y z)
 307   "Do the three articles form a triplet?"
 308   (and (source-p y x)
 309        (sink-p y z)))
 310
 311 (defun network-p (x)
 312   "Is this object a network?"
 313   (let ((ans t))
 314     (setq ans (and ans
 315                       (equal (car x) "*network*")))
 316     (setq ans (and ans
 317                       (integrp (cadr x))))
 318     (dotimes (n 5)
 319           (setq ans (and ans (hash-table-p
 320                                     (nth (+ n 2) x)))))
 321     ans))
 322
 323 (defmacro search (vars prop)
 324   "Find all n-tuplets satisfying a condition"
 325   ; Surround the search within dolist loops on free variables.
 326   (let ((foo '(lambda (vars cmnd)
 327                 (if vars
 328                         ; Wrap in a loop.
 329                         `(dolist (,(car vars) uids)
 330                                   ,(funcall foo (cdr vars) cmnd))
 331                     ; Wrap no further when finished.
 332                     cmnd))))
 333     (funcall foo vars prop)))