elisp/sch-prog-redux.el

   1 ;; sch-prog-demo.el - Minimal example of scholiumific programming
   2
   3 ;; Copyright (C) 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 http://arxana.net/foo-goo.jpg for a vital map.
  21
  22 ;;; CODE:
  23
  24 (load-file "prelim.el")
  25 (load-file "honey-redux.el")
  26 (require 'cl)
  27
  28 (defun node-fun (node retrieve-code
  29                       retrieve-vars
  30                       retrieve-link)
  31   (list (quote lambda)
  32         (funcall retrieve-vars node)
  33         (cons (quote flet)
  34               (cons (mapcar (quote (lambda (item)
  35                                      (let ((var-list
  36                                             (funcall retrieve-vars (cadr item))))
  37                                        (\` ((\, (car item))
  38                                             (\, var-list)
  39                                             (apply (node-fun (\, (cadr item))
  40                                                              (quote (\, retrieve-code))
  41                                                              (quote (\, retrieve-vars))
  42                                                              (quote (\, retrieve-link)))
  43                                                    (\, (cons (quote list) var-list))))))))
  44                             (funcall retrieve-link node))
  45                     (funcall retrieve-code node)))))
  46
  47 ;; Make a new scholium-based document.
  48
  49 (set-current-plexus (add-plexus))
  50
  51 ;; Put the main program in a node.
  52
  53 (label-nema
  54  (add-nema (label2uid "ground")
  55            (label2uid "ground")
  56            '((list (foo 5)
  57                    (goo 6))))
  58  "main-prog")
  59
  60 ;; Put two subroutines in their own nodes.
  61
  62 (label-nema
  63  (add-nema (label2uid "ground")
  64            (label2uid "ground")
  65            '((* x x)))
  66  "sub-foo")
  67
  68 (label-nema
  69  (add-nema (label2uid "ground")
  70            (label2uid "ground")
  71            '((+ x 3)))
  72  "sub-goo")
  73
  74 ;; Make links from the main program to its subroutines.  The text of
  75 ;; the link states the name of the subroutine.
  76
  77 (label-nema
  78  (add-nema
  79   (label2uid "main-prog")
  80   (label2uid "sub-foo")
  81   '(sub foo))
  82  "link-foo")
  83
  84 (label-nema
  85  (add-nema
  86   (label2uid "main-prog")
  87   (label2uid "sub-goo")
  88   '(sub goo))
  89  "link-goo")
  90
  91 ;; Add nodes and links for the variables.
  92
  93 (label-nema
  94  (add-nema
  95   (label2uid "ground")
  96   (label2uid "ground")
  97   nil)
  98  "main-vars")
  99
 100 ;; Argument list of node 1 (points to "main-vars", which contains nil)
 101 ;; In order words, List 1 doesn't have any unbound variables.
 102
 103 (label-nema
 104  (add-nema
 105   (label2uid "main-vars")
 106   (label2uid "main-prog")
 107   'var)
 108  "main-args")
 109
 110 (label-nema
 111  (add-nema
 112   (label2uid "ground")
 113   (label2uid "ground")
 114   '(x))
 115  "sub-vars")
 116
 117 ;; Argument lists of node 2 and node 3
 118
 119 (label-nema
 120  (add-nema
 121   (label2uid "sub-vars")
 122   (label2uid "sub-foo")
 123   'var)
 124  "foo-args")
 125
 126 (label-nema
 127  (add-nema
 128   (label2uid "sub-vars")
 129   (label2uid "sub-goo")
 130   'var)
 131  "goo-args")
 132
 133 ; We provide functions to identify scholia of type
 134 ;; var and sub and retrieve the appropriate data.
 135
 136 (defun get-dependencies (art)
 137   (mapcar '(lambda (x)
 138              (list (cadr (get-content x))
 139                    (get-sink x)))
 140           (filter
 141            '(lambda (y)
 142               (equal 'sub
 143                      (car (get-content y))))
 144            (get-forward-links art))))
 145
 146 (defun get-vars (art)
 147   (delete-dups
 148    (apply 'append
 149           (mapcar
 150            '(lambda (x)
 151               (get-content (get-source x)))
 152            (filter
 153             '(lambda (y)
 154                (equal 'var (get-content y)))
 155             (get-backward-links art))))))
 156
 157 ;; Here is the output they produce:
 158
 159 (get-dependencies (label2uid "main-prog"))
 160   =>
 161 ((goo 4) (foo 3))
 162
 163 (get-vars  (label2uid "sub-foo"))
 164   =>
 165 (x)
 166
 167 ;; Using these functions, we evaluate our node.  Remember that the code
 168 ;; at node 1 is supposed to invoke foo and goo, which are found as
 169 ;; scholia attached to node 2.  As we see, it does this correctly.
 170
 171 (funcall (node-fun
 172           (label2uid "main-prog")
 173           'get-content
 174           'get-vars
 175           'get-dependencies))
 176 => (25 9)
 177
 178 ;; In case you're interested, here are the gory details of how
 179 ;; node-fun wrapped up the code inside the node.
 180
 181 (node-fun (label2uid "main-prog")
 182           'get-content
 183           'get-vars
 184           'get-dependencies)
 185
 186
 187 (lambda nil (flet ((goo (x) (apply (node-fun 4 (quote get-content) (quote get-vars) (quote get-dependencies)) (list x))) (foo (x) (apply (node-fun 3 (quote get-content) (quote get-vars) (quote get-dependencies)) (list x)))) (list (foo 5) (goo 6))))
 188
 189
 190   =>
 191 (lambda nil (flet ((goo (x) (apply (node-fun 3
 192                                              (quote get-txt)
 193                                              (quote get-vars)
 194                                              (quote get-dependencies))
 195                                    (list x)))
 196                    (foo (x) (apply (node-fun 2
 197                                              (quote get-txt)
 198                                              (quote get-vars)
 199                                              (quote get-dependencies))
 200                                    (list x))))
 201               (list (foo 5) (goo 6))))
 202
 203
 204 (node-fun (label2uid "sub-goo")
 205           'get-content
 206           'get-vars
 207           'get-dependencies)
 208 =>
 209 (lambda (x) (flet nil (+ x 3)))
 210
 211 (get-content (label2uid "sub-goo")) => ((+ x 3))
 212 (get-vars (label2uid "sub-goo")) => (x)
 213 (get-dependencies (label2uid "sub-goo")) => nil
 214