elisp/bootstart.el

   1 ;; bootstart.el - Basic functions for literate scholium-based programming
   2
   3 ;; Copyright (C) 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 ;;; CODE:
  21
  22 (require 'cl)
  23
  24 (defun tangle-module (node retrieve-cont retrieve-links)
  25   (insert-chunk
  26    (funcall retrieve-cont node)
  27    (funcall retrieve-links node)
  28    retrieve-cont
  29    retrieve-links))
  30
  31 (defun insert-chunk (body chunks retrieve-cont retrieve-links)
  32   (cond ((null body) nil)
  33         ((null chunks) body)
  34         ((assoc body chunks)
  35          (tangle-module
  36           (cadr (assoc body chunks))
  37           retrieve-cont
  38           retrieve-links))
  39         ((atom body) body)
  40         (t (cons (insert-chunk (car body) chunks retrieve-cont retrieve-links)
  41                  (insert-chunk (cdr body) chunks retrieve-cont retrieve-links)))))
  42
  43 (defun node-fun (node retrieve-code
  44                       retrieve-vars
  45                       retrieve-link)
  46   (list (quote lambda)
  47         (funcall retrieve-vars node)
  48         (cons (quote flet)
  49               (cons (mapcar (quote (lambda (item)
  50                                      (let ((var-list
  51                                             (funcall retrieve-vars (cadr item))))
  52                                        (\` ((\, (car item))
  53                                             (\, var-list)
  54                                             (apply (node-fun (\, (cadr item))
  55                                                              (quote (\, retrieve-code))
  56                                                              (quote (\, retrieve-vars))
  57                                                              (quote (\, retrieve-link)))
  58                                                    (\, (cons (quote list) var-list))))))))
  59                             (funcall retrieve-link node))
  60                     (funcall retrieve-code node)))))
  61
  62 (defun get-src (n)
  63   (car (nth 0 (cdr (assoc n (cdr article-list))))))
  64
  65 (defun get-flk (n)
  66   (cdr (nth 0 (cdr (assoc n (cdr article-list))))))
  67
  68 (defun get-txt (n)
  69   (nth 1 (cdr (assoc n (cdr article-list)))))
  70
  71 (defun get-snk (n)
  72   (car (nth 2 (cdr (assoc n (cdr article-list))))))
  73
  74 (defun get-blk (n)
  75   (cdr (nth 2 (cdr (assoc n (cdr article-list))))))
  76
  77 (defun get-ids nil
  78   (mapcar (quote car) (cdr article-list)))
  79
  80 (defun get-gnd nil 0)
  81
  82 (defun set-src (n x)
  83   (if (equal n 0)
  84       0
  85     (progn (let ((old-backlink
  86                   (nth 1 (assoc (get-src n) (cdr article-list)))))
  87              (setcdr old-backlink (delete n (cdr old-backlink))))
  88            (let ((new-backlink
  89                   `(nth 1 (assoc x (cdr article-list)))))
  90              (setcdr new-backlink (cons n (cdr new-backlink))))
  91            (setcar (nth 1 (assoc n (cdr article-list))) x))))
  92
  93 (defun set-txt (n x)
  94   (setcar (cdr (cdr (assoc n (cdr article-list)))) x))
  95
  96 (defun set-snk (n x)
  97   (if (equal n 0)
  98       0
  99     (progn (let ((old-backlink
 100                   (nth 3 (assoc (get-snk n) (cdr article-list)))))
 101              (setcdr old-backlink (delete n (cdr old-backlink))))
 102            (let ((new-backlink
 103                   (nth 3 (assoc x (cdr article-list)))))
 104              (setcdr new-backlink (cons n (cdr new-backlink))))
 105            (setcar (nth 3 (assoc n (cdr article-list))) x))))
 106
 107 (defun ins-nod (src txt snk)
 108   (progn (setcdr article-list
 109                  (cons (list (car article-list)
 110                              (list src)
 111                              txt
 112                              (list snk))
 113                        (cdr article-list)))
 114          (let ((backlink
 115                 (nth 3 (assoc snk (cdr article-list)))))
 116            (setcdr backlink (cons (car article-list) (cdr backlink))))
 117          (let ((backlink
 118                 (nth 1 (assoc src (cdr article-list)))))
 119            (setcdr backlink (cons (car article-list) (cdr backlink))))
 120          (- (setcar article-list (+ 1 (car article-list))) 1)))
 121
 122 (defun del-nod (n)
 123   (if (or (equal n 0)
 124           (get-blk n)
 125           (get-flk n))
 126       nil
 127     (progn (let ((old-backlink
 128                   (nth 3 (assoc (get-snk n) (cdr article-list)))))
 129              (setcdr old-backlink (delete n (cdr old-backlink))))
 130            (let ((old-backlink
 131                   (nth 1 (assoc (get-src n) (cdr article-list)))))
 132              (setcdr old-backlink (delete n (cdr old-backlink))))
 133            (setcdr article-list
 134                    (delete (assoc n (cdr article-list))
 135                            (cdr article-list)))
 136             t)))