elisp/honey-redux.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 (defvar plexus-registry nil)
  25
  26 (defun add-plexus (parent)
  27   "Create a new plexus."
  28   (let ((newbie (list '*plexus*
  29                       1                               ; nema counter
  30                       (make-hash-table :test 'equal)  ; nema table
  31                       (make-hash-table :test 'equal)  ; forward links
  32                       (make-hash-table :test 'equal)  ; backward links
  33                       (make-hash-table :test 'equal)  ; forward labels
  34                       (make-hash-table :test 'equal)  ; backward labels
  35                       parent)))
  36     ;; Define ground and type nodes.
  37     (puthash 0 '(0 0) (nth 2 newbie))
  38     (puthash 1 '(0 0) (nth 2 newbie))
  39     (puthash 0 '((0 . 0) (1 . 0)) (nth 3 newbie))
  40     (puthash 0 '((0 . 0) (1 . 0)) (nth 4 newbie))
  41     (puthash 0 '"ground" (nth 5 newbie))
  42     (puthash '"ground" 0 (nth 6 newbie))
  43     (puthash 1 '"type" (nth 5 newbie))
  44     (puthash '"type" 1 (nth 6 newbie))
  45     ;; Register the new object and return it.
  46     (setq plexus-registry (cons newbie plexus-registry))
  47     newbie))
  48
  49 (defun remove-plexus (plex)
  50   "Remove a plexus."
  51   ;; Wipe out the hash tables
  52   (dotimes (i 5)
  53     (clrhash (nth (+ i 2) plex)))  )
  54
  55 (defun show-plexus-registry ()
  56   plexus-registry)
  57
  58 (defvar root-level 0)
  59
  60 (defun set-current-plexus (plex)
  61   "Examine a different plexus instead."
  62   (setq current-plexus plex))
  63
  64 (defmacro with-current-plexus (plex &rest expr)
  65   (append `(let ((current-plexus ,plex))) ,expr))
  66
  67 (defun show-current-plexus ()
  68   "Return the plexus currently being examined."
  69   current-plexus)
  70
  71 (defun reset-plexus ()
  72   "Reset the database to its initial configuration."
  73   ; Reset nema counter and hash tables.
  74   (setcar (cdr current-plexus) 1)
  75   (dotimes (n 5)
  76     (clrhash (nth (+ n 2) current-plexus)))
  77   ;; Define ground and nema-type.
  78   (puthash 0 '(0 0) (nth 2 current-plexus))
  79   (puthash 1 '(0 0) (nth 2 current-plexus))
  80   (puthash 0 '((0 . 0) (1 . 0)) (nth 3 current-plexus))
  81   (puthash 0 '((0 . 0) (1 . 0)) (nth 4 current-plexus))
  82   (puthash 0 '"ground" (nth 5 current-plexus))
  83   (puthash '"ground" 0 (nth 6 current-plexus))
  84   (puthash 1 '"nema-type" (nth 5 current-plexus))
  85   (puthash '"nema-type" 1 (nth 6 current-plexus))
  86   nil)
  87
  88 ;; (defun next-unique-id ()
  89 ;;  "Produce a yet unused unique identifier."
  90 ;;  (setcar (cdr current-plexus)
  91 ;;          (1+ (cadr current-plexus))))
  92
  93 ;; Bulk operations.
  94
  95 (defun download-en-masse ()
  96   "Produce a representation of the database as quintuples."
  97   (let ((plex nil))
  98     (maphash (lambda (uid tplt)
  99                                         ; Unpack triplet.
 100                (let ((src (car tplt))
 101                      (snk (nth 1 tplt))
 102                      (txt (nthcdr 2 tplt)))
 103                                         ; Obtain next label if exists.
 104                  (setq lbl (gethash uid
 105                                     (nth 5 current-plexus)
 106                                     nil))
 107                                         ; Write data to list.
 108                  (setq plex (cons `(,uid ,lbl ,src ,snk . ,txt)
 109                                  plex))))
 110              (nth 2 current-plexus))
 111                                         ; Return list of data.
 112     (reverse plex)))
 113
 114 (defun upload-en-masse (plex)
 115   "Load a representation of a database as quintuples into memory."
 116   (dolist (qplt plex t)
 117     ; unpack quintuplet
 118     (let ((uid (car qplt))
 119             (lbl (nth 1 qplt))
 120               (src (nth 2 qplt))
 121                 (snk (nth 3 qplt))
 122                   (txt (nthcdr 4 qplt)))
 123       ; plug into tables
 124       (puthash uid
 125                       `(,src ,snk . ,txt)
 126                              (nth 2 current-plexus))
 127       (puthash src
 128                       (cons `(,uid . ,snk)
 129                                  (gethash src (nth 3 current-plexus) nil))
 130                              (nth 3 current-plexus))
 131       (puthash snk
 132                       (cons
 133                        `(,uid . ,src)
 134                        (gethash snk (nth 4 current-plexus) nil))
 135                              (nth 4 current-plexus))
 136       (when lbl
 137           (progn
 138                 (puthash uid lbl (nth 5 current-plexus))
 139                     (puthash lbl uid (nth 6 current-plexus))))
 140       ; Bump up nema counter if needed.
 141       (when (> uid (cadr current-plexus))
 142              (setcar (cdr current-plexus) uid)))))
 143
 144 (defun add-en-masse (plex)
 145   "Add multiple nemata given as list of quartuplets."
 146   (mapcar (lambda (qplt)
 147             (let ((uid next-unique-id))
 148               (put-nema (nth 1 plex)
 149                            (nth 2 plex)
 150                            (nthcar 2 plex))
 151               (label-nema uid (car qplt))))
 152           plex))
 153
 154 ;; Individual operations.
 155
 156 (defun add-nema (src snk txt)
 157   "Enter a new nema to the database."
 158   (let ((uid (next-unique-id)))
 159     ;; Add record to nema table.
 160     (puthash uid
 161              `(,src ,snk . ,txt)
 162              (nth 2 current-plexus))
 163     ;; Add record to list of forward links of source.
 164     (puthash src
 165              (cons `(,uid . ,snk)
 166                    (gethash src (nth 3 current-plexus) nil))
 167              (nth 3 current-plexus))
 168     ;; Add record to list of backward links of sink.
 169     (puthash snk
 170              (cons
 171               `(,uid . ,src)
 172               (gethash snk (nth 4 current-plexus) nil))
 173              (nth 4 current-plexus))
 174     ;; Return the id of the new nema.
 175     uid))
 176
 177 (defun get-content (uid)
 178   "Return the content of the nema."
 179   (cddr (gethash uid (nth 2 current-plexus))))
 180
 181 (defun get-source (uid)
 182   "Return the source of the nema."
 183   (car (gethash uid (nth 2 current-plexus))))
 184
 185 (defun get-sink (uid)
 186   "Return the sink of the nema."
 187   (cadr (gethash uid (nth 2 current-plexus))))
 188
 189 (defun update-content (uid txt)
 190   "Replace the content of the nema."
 191   (puthash uid
 192               (let ((x (gethash uid (nth 2 current-plexus))))
 193                      `(,(car x)    ; old source
 194                               ,(cadr x) . ; old sink
 195                                      ,txt))      ; new content
 196                  (nth 2 current-plexus)))
 197
 198 (defun update-source (uid new-src)
 199   "Replace the source of the nema."
 200   (let* ((x (gethash uid (nth 2 current-plexus)))
 201          (old-src (car x))   ; extract current source
 202          (old-snk (cadr x))  ; extract current sink
 203          (old-txt (cddr x))) ; extract current content
 204     ;; Update the entry in the nema table.
 205     (puthash uid
 206              `(,new-src ,old-snk . ,old-txt)
 207              (nth 2 current-plexus))
 208     ;; Remove the entry with the old source in the
 209     ;; forward link table.  If that is the only entry
 210     ;; filed under old-src, remove it from table.
 211     (let ((y (delete `(,uid . ,old-snk)
 212                      (gethash old-src
 213                               (nth 3 current-plexus)
 214                               nil))))
 215       (if y
 216           (puthash old-src y (nth 3 current-plexus))
 217         (remhash old-src (nth 3 current-plexus))))
 218     ;; Add an entry with the new source in the
 219     ;; forward link table.
 220     (puthash new-src
 221              (cons `(,uid . ,old-snk)
 222                    (gethash old-src (nth 3 current-plexus) nil))
 223              (nth 3 current-plexus))
 224     ;; Update the entry in the backward link table.
 225     (puthash old-snk
 226              (cons `(,uid . ,new-src)
 227                    (delete `(,uid . ,old-src)
 228                            (gethash old-src
 229                                     (nth 4 current-plexus)
 230                                     nil)))
 231              (nth 4 current-plexus))))
 232
 233 (defun update-sink (uid new-snk)
 234   "Change the sink of the nema."
 235   (let* ((x (gethash uid (nth 2 current-plexus)))
 236           (old-src (car x))   ; extract current source
 237            (old-snk (cadr x))  ; extract current sink
 238             (old-txt (cddr x))) ; extract current content
 239     ; Update the entry in the nema table.
 240     (puthash uid
 241              `(,old-src ,new-snk . ,old-txt)
 242              (nth 2 current-plexus))
 243     ;; Remove the entry with the old sink in the
 244     ;; backward link table.  If that is the only entry
 245     ;; filed under old-src, remove it from table.
 246     (let ((y (delete `(,uid . ,old-src)
 247                      (gethash old-snk
 248                               (nth 4 current-plexus)
 249                               nil))))
 250       (if y
 251           (puthash old-snk y (nth 4 current-plexus))
 252         (remhash old-snk (nth 4 current-plexus))))
 253     ;; Add an entry with the new source in the
 254     ;; backward link table.
 255     (puthash new-snk
 256              (cons `(,uid . ,old-src)
 257                    (gethash old-snk
 258                             (nth 4 current-plexus)
 259                             nil))
 260              (nth 4 current-plexus))
 261     ;; Update the entry in the forward link table.
 262     (puthash old-src
 263              (cons `(,uid . ,new-snk)
 264                    (delete `(,uid . ,old-snk)
 265                            (gethash old-src
 266                                     (nth 3 current-plexus)
 267                                     nil)))
 268              (nth 3 current-plexus))))
 269
 270 (defun remove-nema (uid)
 271   "Remove this nema from the database."
 272   (let ((old-src (car (gethash uid (nth 2 current-plexus))))
 273         (old-snk (cadr (gethash uid (nth 2 current-plexus)))))
 274   ;; Remove forward link created by nema.
 275   (let ((new-fwd (delete `(,uid . ,old-snk)
 276                           (gethash old-src (nth 3 current-plexus)))))
 277     (if new-fwd
 278         (puthash old-src new-fwd (nth 3 current-plexus))
 279       (remhash old-src (nth 3 current-plexus))))
 280   ;; Remove backward link created by nema.
 281   (let ((new-bkw (delete `(,uid . ,old-src)
 282                           (gethash old-snk (nth 4 current-plexus)))))
 283     (if new-bkw
 284         (puthash old-snk new-bkw (nth 4 current-plexus))
 285       (remhash old-snk (nth 4 current-plexus))))
 286   ;; Remove record from nema table.
 287   (remhash uid (nth 2 current-plexus))))
 288
 289 (defun get-forward-links (uid)
 290   "Return all links having given object as source."
 291   (mapcar 'car (gethash uid (nth 3 current-plexus))))
 292
 293 (defun get-backward-links (uid)
 294   "Return all links having given object as sink."
 295   (mapcar 'car (gethash uid (nth 4 current-plexus))))
 296
 297 ;; Labelling nemata.
 298
 299 (defun label-nema (uid label)
 300   "Assign the label to the given object."
 301   (puthash uid label (nth 5 current-plexus))
 302   (puthash label uid (nth 6 current-plexus)))
 303
 304 (defun label2uid (label)
 305   "Return the unique identifier corresponding to a label."
 306   (gethash label (nth 6 current-plexus) nil))
 307
 308 (defun uid2label (uid)
 309   "Return the label associated to a unique identifier."
 310   (gethash uid (nth 5 current-plexus) nil))
 311
 312 ;; Queries
 313
 314 (defun uid-p (uid)
 315   "Is this a valid uid?"
 316   (let ((z '(())))
 317     (not (eq z (gethash uid (nth 2 current-plexus) z)))))
 318
 319 (defun uid-list ()
 320   "List of all valid uid's."
 321   (maphash (lambda (key val) key)
 322            (nth 2 current-plexus)))
 323
 324 (defun ground-p (uid)
 325   "Is this nema the ground?"
 326   (= uid 0))
 327
 328 (defun source-p (x y)
 329   "Is the former nema the sink of the latter?"
 330   (equal x (get-source y)))
 331
 332 (defun sink-p (x y)
 333   "Is the former nema the sink of the latter?"
 334   (equal x (get-sink y)))
 335
 336 (defun links-from (x y)
 337   "Return all links from nema x to nema y."
 338   (filter '(lambda (z) (source-p x z))
 339             (get-backward-links y)))
 340
 341 (defun links-p (x y)
 342   "Does nema x link to nema y?"
 343   (when (member x (mapcar
 344                       'get-source
 345                       (get-backward-links y)))
 346     t))
 347
 348 (defun triple-p (x y z)
 349   "Do the three items form a triplet?"
 350   (and (source-p y x)
 351        (sink-p y z)))
 352
 353 (defun plexus-p (x)
 354   "Is this object a plexus?"
 355   (let ((ans t))
 356     (setq ans (and ans
 357                       (equal (car x) "*plexus*")))
 358     (setq ans (and ans
 359                       (integrp (cadr x))))
 360     (dotimes (n 5)
 361           (setq ans (and ans (hash-table-p
 362                                     (nth (+ n 2) x)))))
 363     ans))
 364
 365 ;; Iteration
 366
 367 ;; do-plexus
 368
 369 ;; map-plexus
 370
 371 ;; filter-plexus