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     ; Return the id of the new article.
 157     uid))
 158
 159 (defun get-content (uid)
 160   "Return the content of the article."
 161   (cddr (gethash uid (nth 2 current-net))))
 162
 163 (defun get-source (uid)
 164   "Return the source of the article."
 165   (car (gethash uid (nth 2 current-net))))
 166
 167 (defun get-sink (uid)
 168   "Return the sink of the article."
 169   (cadr (gethash uid (nth 2 current-net))))
 170
 171 (defun update-content (uid txt)
 172   "Replace the content of the article."
 173   (puthash uid
 174               (let ((x (gethash uid (nth 2 current-net))))
 175                      `(,(car x)    ; old source
 176                               ,(cadr x) . ; old sink
 177                                      ,txt))      ; new content
 178                  (nth 2 current-net)))
 179
 180 (defun update-source (uid new-src)
 181   "Replace the source of the article."
 182   (let* ((x (gethash uid (nth 2 current-net)))
 183           (old-src (car x))   ; extract current source
 184            (old-snk (cadr x))  ; extract current sink
 185             (old-txt (cddr x))) ; extract current content
 186     ; Update the entry in the article table.
 187     (puthash uid
 188                   `(,new-src ,old-snk . ,old-txt)
 189                        (nth 2 current-net))
 190     ; Remove the entry with the old source in the
 191     ; forward link table.  If that is the only entry
 192     ; filed under old-src, remove it from table.
 193     (let ((y (delete `(,uid . ,old-snk)
 194                           (gethash old-src (nth 3 current-net) nil))))
 195       (if y
 196             (puthash old-src y (nth 3 current-net))
 197         (remhash old-src (nth 3 current-net))))
 198     ; Add an entry with the new source in the
 199     ; forward link table.
 200     (puthash new-src
 201                   (cons `(,uid . ,old-snk)
 202                            (gethash old-src (nth 3 current-net) nil))
 203                        (nth 3 current-net))
 204     ; Update the entry in the backward link table.
 205     (puthash old-snk
 206                   (cons `(,uid . ,new-src)
 207                            (delete `(,uid . ,old-src)
 208                                       (gethash old-src (nth 4 current-net) nil)))
 209                        (nth 4 current-net))))
 210
 211 (defun update-sink (uid new-snk)
 212   "Change the sink of the article."
 213   (let* ((x (gethash uid (nth 2 current-net)))
 214           (old-src (car x))   ; extract current source
 215            (old-snk (cadr x))  ; extract current sink
 216             (old-txt (cddr x))) ; extract current content
 217     ; Update the entry in the article table.
 218     (puthash uid
 219                   `(,old-src ,new-snk . ,old-txt)
 220                        (nth 2 current-net))
 221     ; Remove the entry with the old sink in the
 222     ; backward link table.  If that is the only entry
 223     ; filed under old-src, remove it from table.
 224     (let ((y (delete `(,uid . ,old-src)
 225                           (gethash old-snk (nth 4 current-net) nil))))
 226       (if y
 227             (puthash old-snk y (nth 4 current-net))
 228         (remhash old-snk (nth 4 current-net))))
 229     ; Add an entry with the new source in the
 230     ; backward link table.
 231     (puthash new-snk
 232                   (cons `(,uid . ,old-src)
 233                            (gethash old-snk (nth 4 current-net) nil))
 234                        (nth 4 current-net))
 235     ; Update the entry in the forward link table.
 236     (puthash old-src
 237                   (cons `(,uid . ,new-snk)
 238                            (delete `(,uid . ,old-snk)
 239                                       (gethash old-src (nth 3 current-net) nil)))
 240                        (nth 3 current-net))))
 241
 242 (defun remove-article (uid)
 243   "Remove this article from the database."
 244   (let ((old-src (car (gethash uid (nth 2 current-net))))
 245         (old-snk (cadr (gethash uid (nth 2 current-net)))))
 246   ; Remove forward link created by article.
 247   (let ((new-fwd (delete `(,uid . ,old-snk)
 248                           (gethash old-src (nth 3 current-net)))))
 249     (if new-fwd
 250         (puthash old-src new-fwd (nth 3 current-net))
 251       (remhash old-src (nth 3 current-net))))
 252   ; Remove backward link created by article.
 253   (let ((new-bkw (delete `(,uid . ,old-src)
 254                           (gethash old-snk (nth 4 current-net)))))
 255     (if new-bkw
 256         (puthash old-snk new-bkw (nth 4 current-net))
 257       (remhash old-snk (nth 4 current-net))))
 258   ; Remove record from article table.
 259   (remhash uid (nth 2 current-net))))
 260
 261 (defun get-forward-links (uid)
 262   "Return all links having given object as source."
 263   (mapcar 'car (gethash uid (nth 3 current-net))))
 264
 265 (defun get-backward-links (uid)
 266   "Return all links having given object as sink."
 267   (mapcar 'car (gethash uid (nth 4 current-net))))
 268
 269 (defun label-article (uid label)
 270   "Assign the label to the given object."
 271   (puthash uid label (nth 5 current-net))
 272   (puthash label uid (nth 6 current-net)))
 273
 274 (defun label2uid (label)
 275   "Return the unique identifier corresponding to a label."
 276   (gethash label (nth 6 current-net) nil))
 277
 278 (defun uid2label (uid)
 279   "Return the label associated to a unique identifier."
 280   (gethash uid (nth 5 current-net) nil))
 281
 282 ;; Search and Query
 283
 284 (defun uid-p (uid)
 285   "Is this a valid uid?"
 286   (let ((z '(())))
 287     (not (eq z (gethash uid (nth 2 current-net) z)))))
 288
 289 (defun ground-p (uid)
 290   "Is this article the ground?"
 291   (= uid 0))
 292
 293 (defun source-p (x y)
 294   "Is the former article the sink of the latter?"
 295   (equal x (get-source y)))
 296
 297 (defun sink-p (x y)
 298   "Is the former article the sink of the latter?"
 299   (equal x (get-sink y)))
 300
 301 (defun links-from (x y)
 302   "Return all links from article x to artice y."
 303   (filter '(lambda (z) (source-p x z))
 304             (get-backward-links y)))
 305
 306 (defun links-p (x y)
 307   "Does article x link to article y?"
 308   (when (member x (mapcar
 309                       'get-source
 310                          (get-backward-links y))) t))
 311
 312 (defun triple-p (x y z)
 313   "Do the three articles form a triplet?"
 314   (and (source-p y x)
 315        (sink-p y z)))
 316
 317 (defun network-p (x)
 318   "Is this object a network?"
 319   (let ((ans t))
 320     (setq ans (and ans
 321                       (equal (car x) "*network*")))
 322     (setq ans (and ans
 323                       (integrp (cadr x))))
 324     (dotimes (n 5)
 325           (setq ans (and ans (hash-table-p
 326                                     (nth (+ n 2) x)))))
 327     ans))
 328
 329 ;; Upgrade this to concatenate the results together.
 330 ;; Also maybe allow options to add headers or to
 331 ;; only loop over unique tuplets.
 332
 333 (defmacro search (vars prop)
 334   "Find all n-tuplets satisfying a condition"
 335   ;; Surround the search within dolist loops on free variables.
 336   (let ((foo '(lambda (vars cmnd)
 337                 (if vars
 338                         Wrap in a loop.
 339                         `(dolist (,(car vars) uids)
 340                                   ,(funcall foo (cdr vars) cmnd))
 341                         ;; Wrap no further when finished.
 342                     cmnd))))
 343     (funcall foo vars prop)))
 344
 345 (provide 'honey)