Merge branch 'master' of https://repo.or.cz/arxana

[arxana.git] / elisp / honey-standardized.el

;; honey.el - Higher Order NEsted Yarnknotter --- back-end for Arxana 

;; Copyright (C) 2010, 2011, 2012, 2013 Raymond S. Puzio

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU Affero General Public License for more details.

;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This is the first version in which we matched it to the spec we
;; just wrote.  To keep the emacs community happy, all our symbols
;; have been prefaced with "arxana-".  We have a plexus registry
;; but, as yet, no dispatcher.

;; See honey-demo.tex for background. 

;;; Code:

;; === Instance Operations ===

(defvar arxana-plexus-registry '(0 nil))

(defun arxana-add-plexus ()
  "Create a new plexus."
  (let ((newbie (list '*plexus*
                      1                               ; nema counter
                      (make-hash-table :test 'equal)  ; nema table
                      (make-hash-table :test 'equal)  ; forward links
                      (make-hash-table :test 'equal)  ; backward links
                      (make-hash-table :test 'equal)  ; forward labels
                      (make-hash-table :test 'equal)  ; backward labels
                      (car arxana-plexus-registry))))
    ;; Define ground and type nodes.
    (puthash 0 '(0 0) (nth 2 newbie))
    (puthash 1 '(0 0) (nth 2 newbie))
    (puthash 0 '((0 . 0) (1 . 0)) (nth 3 newbie))
    (puthash 0 '((0 . 0) (1 . 0)) (nth 4 newbie))
    (puthash 0 '"ground" (nth 5 newbie))
    (puthash '"ground" 0 (nth 6 newbie))
    (puthash 1 '"type" (nth 5 newbie))
    (puthash '"type" 1 (nth 6 newbie))
    ;; Register the new object and return it.
    (setq arxana-plexus-registry
          (append
           `(,(+ (car arxana-plexus-registry) 1)
             ,newbie)
           (cdr arxana-plexus-registry)))
    newbie))

(defun arxana-remove-plexus (plex)
  "Remove a plexus."
  ;; Wipe out the hash tables
  (dotimes (i 5)
    (clrhash (nth (+ i 2) plex)))
  ;; Remove the entry from the registry.
  (setq arxana-plexus-registry
        (cons
         (car arxana-plexus-registry)
         (delete
          (assoc (nth 7 plex)
                 (cdr arxana-plexus-registry))
          (cdr arxana-plexus-registry)))))

(defun arxana-reset-plexus ()
  "Reset the database to its initial configuration."
  ; Reset nema counter and hash tables.
  (setcar (cdr arxana-current-plexus) 1)
  (dotimes (n 5)
    (clrhash (nth (+ n 2) arxana-current-plexus)))
  ;; Define ground and nema-type.
  (puthash 0 '(0 0) (nth 2 arxana-current-plexus))
  (puthash 1 '(0 0) (nth 2 arxana-current-plexus))
  (puthash 0 '((0 . 0) (1 . 0)) (nth 3 arxana-current-plexus))
  (puthash 0 '((0 . 0) (1 . 0)) (nth 4 arxana-current-plexus))
  (puthash 0 '"ground" (nth 5 arxana-current-plexus))
  (puthash '"ground" 0 (nth 6 arxana-current-plexus))
  (puthash 1 '"type" (nth 5 arxana-current-plexus))
  (puthash '"type" 1 (nth 6 arxana-current-plexus))
  nil)

;; === Default Plexus ===
;;
;; Eventually, these operations will be taken over by the dispatcher
;; but, for now, we will implement them here.

;; (defvar root-level 0)

(defun arxana-show-plexus-registry ()
  arxana-plexus-registry)

(defun arxana-set-current-plexus (plex)
  "Examine a different plexus instead."
  (setq arxana-current-plexus plex))

(defmacro arxana-with-current-plexus (plex &rest expr)
  (append `(let ((arxana-current-plexus ,plex))) ,expr))

(defun arxana-show-current-plexus ()
  "Return the plexus currently being examined."
  arxana-current-plexus)

;; Should not have this visible to user.
(defun arxana-next-unique-id ()
  "Produce a yet unused unique identifier."
  (setcar (cdr arxana-current-plexus)
          (1+ (cadr arxana-current-plexus))))

;; === Bulk operations ===

(defun arxana-download-en-masse ()
  "Produce a representation of the database as quintuples."
  (let ((plex nil))
    (maphash (lambda (uid tplt)
                                        ; Unpack triplet.
               (let ((src (car tplt))
                     (snk (nth 1 tplt))
                     (txt (nthcdr 2 tplt)))
                                        ; Obtain next label if exists.
                 (setq lbl (gethash uid
                                    (nth 5 arxana-current-plexus)
                                    nil))
                                        ; Write data to list.
                 (setq plex (cons `(,uid ,lbl ,src ,snk . ,txt) 
                                 plex))))
             (nth 2 arxana-current-plexus))
                                        ; Return list of data.
    (reverse plex)))

(defun arxana-upload-en-masse (plex)
  "Load a representation of a database as quintuples into memory."
  (dolist (qplt plex t)
    ; unpack quintuplet
    (let ((uid (car qplt))
            (lbl (nth 1 qplt))
              (src (nth 2 qplt))
                (snk (nth 3 qplt))
                  (txt (nthcdr 4 qplt)))
      ; plug into tables
      (puthash uid 
                      `(,src ,snk . ,txt)
                             (nth 2 arxana-current-plexus))
      (puthash src
                      (cons `(,uid . ,snk)
                                 (gethash src (nth 3 arxana-current-plexus) nil))
                             (nth 3 arxana-current-plexus))
      (puthash snk
                      (cons
                       `(,uid . ,src)
                       (gethash snk (nth 4 arxana-current-plexus) nil))
                             (nth 4 arxana-current-plexus))
      (when lbl
          (progn
                (puthash uid lbl (nth 5 arxana-current-plexus))
                    (puthash lbl uid (nth 6 arxana-current-plexus))))
      ; Bump up nema counter if needed.
      (when (> uid (cadr arxana-current-plexus))
             (setcar (cdr arxana-current-plexus) uid)))))

(defun arxana-add-en-masse (plex)
  "Add multiple nemata given as list of quartuplets."
  (mapcar (lambda (qplt)
            (let ((uid arxana-next-unique-id))
              (put-nema (nth 1 plex)
                           (nth 2 plex)
                           (nthcar 2 plex))
              (label-nema uid (car qplt))))
          plex))

;; === Individual operations ===

;; Consider replacing the cons'es here and elewhere with
;; add-to-list's so as to avoid duplication.

(defun arxana-add-nema (src txt snk)
  "Enter a new nema to the database."
  (let ((uid (arxana-next-unique-id)))
    ;; Add record to nema table.
    (puthash uid
             `(,src ,snk . ,txt)
             (nth 2 arxana-current-plexus))
    ;; Add record to list of forward links of source.
    (puthash src
             (cons `(,uid . ,snk)
                   (gethash src (nth 3 arxana-current-plexus) nil))
             (nth 3 arxana-current-plexus))
    ;; Add record to list of backward links of sink.
    (puthash snk
             (cons
              `(,uid . ,src)
              (gethash snk (nth 4 arxana-current-plexus) nil))
             (nth 4 arxana-current-plexus))
    ;; Return the id of the new nema.
    uid))

(defun arxana-get-content (uid)
  "Return the content of the nema."
  (cddr (gethash uid (nth 2 arxana-current-plexus))))

(defun arxana-get-source (uid)
  "Return the source of the nema."
  (car (gethash uid (nth 2 arxana-current-plexus))))

(defun arxana-get-sink (uid)
  "Return the sink of the nema."
  (cadr (gethash uid (nth 2 arxana-current-plexus))))

(defun arxana-get-forward-links (uid)
  "Return all links having given object as source."
  (mapcar 'car (gethash uid (nth 3 arxana-current-plexus))))

(defun arxana-get-backward-links (uid)
  "Return all links having given object as sink."
  (mapcar 'car (gethash uid (nth 4 arxana-current-plexus))))

(defun arxana-update-content (uid txt)
  "Replace the content of the nema."
  (puthash uid
              (let ((x (gethash uid (nth 2 arxana-current-plexus))))
                     `(,(car x)    ; old source
                              ,(cadr x) . ; old sink
                                     ,txt))      ; new content
                 (nth 2 arxana-current-plexus)))

(defun arxana-update-source (uid new-src)
  "Replace the source of the nema."
  (let* ((x (gethash uid (nth 2 arxana-current-plexus)))
         (old-src (car x))   ; extract current source
         (old-snk (cadr x))  ; extract current sink 
         (old-txt (cddr x))) ; extract current content 
    ;; Update the entry in the nema table.
    (puthash uid
             `(,new-src ,old-snk . ,old-txt)
             (nth 2 arxana-current-plexus))
    ;; Remove the entry with the old source in the
    ;; forward link table.  If that is the only entry
    ;; filed under old-src, remove it from table.
    (let ((y (delete `(,uid . ,old-snk)
                     (gethash old-src
                              (nth 3 arxana-current-plexus)
                              nil))))
      (if y
          (puthash old-src y (nth 3 arxana-current-plexus))
        (remhash old-src (nth 3 arxana-current-plexus))))
    ;; Add an entry with the new source in the
    ;; forward link table.
    (puthash new-src 
             (cons `(,uid . ,old-snk)
                   (gethash old-src (nth 3 arxana-current-plexus) nil))
             (nth 3 arxana-current-plexus))
    ;; Update the entry in the backward link table.
    (puthash old-snk
             (cons `(,uid . ,new-src)
                   (delete `(,uid . ,old-src)
                           (gethash old-src
                                    (nth 4 arxana-current-plexus)
                                    nil)))
             (nth 4 arxana-current-plexus))))

(defun arxana-update-sink (uid new-snk)
  "Change the sink of the nema."
  (let* ((x (gethash uid (nth 2 arxana-current-plexus)))
          (old-src (car x))   ; extract current source
           (old-snk (cadr x))  ; extract current sink 
            (old-txt (cddr x))) ; extract current content 
    ; Update the entry in the nema table.
    (puthash uid
             `(,old-src ,new-snk . ,old-txt)
             (nth 2 arxana-current-plexus))
    ;; Remove the entry with the old sink in the
    ;; backward link table.  If that is the only entry
    ;; filed under old-src, remove it from table.
    (let ((y (delete `(,uid . ,old-src)
                     (gethash old-snk
                              (nth 4 arxana-current-plexus)
                              nil))))
      (if y
          (puthash old-snk y (nth 4 arxana-current-plexus))
        (remhash old-snk (nth 4 arxana-current-plexus))))
    ;; Add an entry with the new source in the
    ;; backward link table.
    (puthash new-snk 
             (cons `(,uid . ,old-src)
                   (gethash old-snk
                            (nth 4 arxana-current-plexus)
                            nil))
             (nth 4 arxana-current-plexus))
    ;; Update the entry in the forward link table.
    (puthash old-src
             (cons `(,uid . ,new-snk)
                   (delete `(,uid . ,old-snk)
                           (gethash old-src
                                    (nth 3 arxana-current-plexus)
                                    nil)))
             (nth 3 arxana-current-plexus))))

(defun arxana-remove-nema (uid)
  "Remove this nema from the database."
  (let ((old-src (car (gethash uid (nth 2 arxana-current-plexus))))
        (old-snk (cadr (gethash uid (nth 2 arxana-current-plexus)))))
  ;; Remove forward link created by nema.
  (let ((new-fwd (delete `(,uid . ,old-snk)
                          (gethash old-src (nth 3 arxana-current-plexus)))))
    (if new-fwd 
        (puthash old-src new-fwd (nth 3 arxana-current-plexus))
      (remhash old-src (nth 3 arxana-current-plexus))))
  ;; Remove backward link created by nema.
  (let ((new-bkw (delete `(,uid . ,old-src)
                          (gethash old-snk (nth 4 arxana-current-plexus)))))
    (if new-bkw
        (puthash old-snk new-bkw (nth 4 arxana-current-plexus))
      (remhash old-snk (nth 4 arxana-current-plexus))))
  ;; Remove record from nema table.
  (remhash uid (nth 2 arxana-current-plexus))))

;; === Labelling nemata ===

;; This will also move to the dispatcher in the future.

(defun arxana-label-nema (uid label)
  "Assign the label to the given object."
  (puthash uid label (nth 5 arxana-current-plexus))
  (puthash label uid (nth 6 arxana-current-plexus)))

(defun arxana-label2uid (label)
  "Return the unique identifier corresponding to a label."
  (gethash label (nth 6 arxana-current-plexus) nil))

(defun arxana-uid2label (uid)
  "Return the label associated to a unique identifier."
  (gethash uid (nth 5 arxana-current-plexus) nil))

;; === Queries ===

(defun arxana-uid-p (uid)
  "Is this a valid uid?"
  (let ((z '(())))
    (not (eq z (gethash uid (nth 2 arxana-current-plexus) z)))))

(defun arxana-uid-list ()
  "List of all valid uid's."
  (let ((ans nil))
    (maphash (lambda (key val)
               (push key ans))
             (nth 2 arxana-current-plexus))
    ans))
             
(defun arxana-ground-p (uid)
  "Is this nema the ground?"
  (= uid 0))

(defun arxana-source-p (x y)
  "Is the former nema the sink of the latter?" 
  (equal x (arxana-get-source y)))
     
(defun arxana-sink-p (x y)
  "Is the former nema the sink of the latter?" 
  (equal x (arxana-get-sink y)))

(defun arxana-links-from (x y)
  "Return all links from nema x to nema y."
  (filter '(lambda (z) (source-p x z))
            (arxana-get-backward-links y)))

(defun arxana-links-p (x y)
  "Does nema x link to nema y?"
  (when (member x (mapcar 
                      'arxana-get-source 
                      (arxana-get-backward-links y)))
    t))

(defun arxana-triple-p (x y z)
  "Do the three items form a triplet?"
  (and (arxana-source-p y x)
       (arxana-sink-p y z)))

(defun arxana-plexus-p (x)
  "Is this object a plexus?"
  (let ((ans t))
    (setq ans (and ans 
                      (equal (car x) "*plexus*")))
    (setq ans (and ans
                      (integrp (cadr x))))
    (dotimes (n 5)
          (setq ans (and ans (hash-table-p 
                                    (nth (+ n 2) x)))))
    ans)) 

;; Iteration

(defmacro arxana-do-plexus (var body res)
  `((maphash (lambda (,var val) ,body)
             (nth 2 arxana-current-plexus))
    ,res))

(defun arxana-map-plexus (func)
  (let ((ans nil))
    (maphash
     (lambda (key val)
       (push (funcall func key) ans))
     (nth 2 arxana-current-plexus))
    ans))

(defun arxana-filter-plexus (pred)
  (let ((ans nil))
    (maphash
     (lambda (key val)
       (when (funcall pred key)
         (push key ans)))
       (nth 2 arxana-current-plexus))
     ans))