Merge branch 'mob' of git://repo.or.cz/arxana into mob

[arxana.git] / elisp / honey-redux.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:

;; See honey-demo.tex for background.

;;; Code:

(defvar plexus-registry '(0 nil))

(defun 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 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 plexus-registry
          (append
           `(,(+ (car plexus-registry) 1)
             ,newbie)
           (cdr plexus-registry)))
    newbie))

(defun 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 plexus-registry
        (cons
         (car plexus-registry)
         (delete
          (assoc (nth 7 plex)
                 (cdr plexus-registry))
          (cdr plexus-registry)))))
  
(defun show-plexus-registry ()
  plexus-registry)

;; (defvar root-level 0)

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

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

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

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

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

;; Bulk operations.

(defun 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 current-plexus)
                                    nil))
                                        ; Write data to list.
                 (setq plex (cons `(,uid ,lbl ,src ,snk . ,txt) 
                                 plex))))
             (nth 2 current-plexus))
                                        ; Return list of data.
    (reverse plex)))

(defun 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 current-plexus))
      (puthash src
                      (cons `(,uid . ,snk)
                                 (gethash src (nth 3 current-plexus) nil))
                             (nth 3 current-plexus))
      (puthash snk
                      (cons
                       `(,uid . ,src)
                       (gethash snk (nth 4 current-plexus) nil))
                             (nth 4 current-plexus))
      (when lbl
          (progn
                (puthash uid lbl (nth 5 current-plexus))
                    (puthash lbl uid (nth 6 current-plexus))))
      ; Bump up nema counter if needed.
      (when (> uid (cadr current-plexus))
             (setcar (cdr current-plexus) uid)))))

(defun add-en-masse (plex)
  "Add multiple nemata given as list of quartuplets."
  (mapcar (lambda (qplt)
            (let ((uid 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 add-nema (src snk txt)
  "Enter a new nema to the database."
  (let ((uid (next-unique-id)))
    ;; Add record to nema table.
    (puthash uid
             `(,src ,snk . ,txt)
             (nth 2 current-plexus))
    ;; Add record to list of forward links of source.
    (puthash src
             (cons `(,uid . ,snk)
                   (gethash src (nth 3 current-plexus) nil))
             (nth 3 current-plexus))
    ;; Add record to list of backward links of sink.
    (puthash snk
             (cons
              `(,uid . ,src)
              (gethash snk (nth 4 current-plexus) nil))
             (nth 4 current-plexus))
    ;; Return the id of the new nema.
    uid))

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

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

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

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

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

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

(defun update-source (uid new-src)
  "Replace the source of the nema."
  (let* ((x (gethash uid (nth 2 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 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 current-plexus)
                              nil))))
      (if y
          (puthash old-src y (nth 3 current-plexus))
        (remhash old-src (nth 3 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 current-plexus) nil))
             (nth 3 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 current-plexus)
                                    nil)))
             (nth 4 current-plexus))))

(defun update-sink (uid new-snk)
  "Change the sink of the nema."
  (let* ((x (gethash uid (nth 2 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 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 current-plexus)
                              nil))))
      (if y
          (puthash old-snk y (nth 4 current-plexus))
        (remhash old-snk (nth 4 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 current-plexus)
                            nil))
             (nth 4 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 current-plexus)
                                    nil)))
             (nth 3 current-plexus))))

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

;; Labelling nemata.

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

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

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

;; Queries

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

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

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

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

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

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

(defun 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 do-plexus (var body res)
  `((maphash (lambda (,var val) ,body)
             (nth 2 current-plexus))
    ,res))

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

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