elisp/binom-demo.el

   1 ;; binom-demo.el - Example of scholium programming using a math example
   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/binom.jpg for a vital map.
  21
  22 ;;; CODE:
  23
  24 (load-file "prelim.el")
  25 (load-file "bootstart.el")
  26 (load-file "schprog.el")
  27
  28 ;; Access functions to pull up relevant information
  29 ;; for operations to weave, tangle, and run the program.
  30
  31 (defun get-dependencies (art)
  32   (mapcar '(lambda (x)
  33              (list (cadr (get-txt x))
  34                    (get-snk x)))
  35           (filter
  36            '(lambda (y)
  37               (let ((z (get-txt y)))
  38                 (when (listp z)
  39                   (equal 'sub
  40                          (car z)))))
  41               (get-flk art))))
  42
  43 (defun get-vars (art)
  44   (delete-dups
  45    (apply 'append
  46           (mapcar
  47            '(lambda (x)
  48               (get-txt (get-src x)))
  49            (filter
  50             '(lambda (y)
  51                (equal 'var (get-txt y)))
  52             (get-blk art))))))
  53
  54 (defun get-name (art)
  55   (get-txt
  56    (get-src
  57     (car
  58      (filter
  59       '(lambda (y)
  60          (equal 'name (get-txt y)))
  61       (get-blk art))))))
  62
  63 (defun get-chunks (art)
  64   (mapcar '(lambda (x)
  65              (list (cadr (get-txt x))
  66                    (get-src x)))
  67           (filter
  68            '(lambda (y)
  69               (let ((z (get-txt y)))
  70                 (when (listp z)
  71                   (equal 'chunk
  72                          (car z)))))
  73            (get-blk art))))
  74
  75 (defun get-code (node)
  76   (tangle-module node
  77                  'get-txt
  78                  'get-chunks))
  79
  80 ;; The network shown in the accompanying picture.
  81
  82 (set 'article-list
  83      '(24 (23 (5) (chunk (CALL MYSELF)) (3))
  84           (22 (4) (chunk (BOUNDARY CASE)) (3))
  85           (21 (11) var (3))
  86           (20 (10) name (3))
  87           (19 (9) var (2))
  88           (18 (8) name (2))
  89           (17 (3) (sub choose) (3))
  90           (16 (2) (sub pow) (2))
  91           (15 (1) (sub choose) (3))
  92           (14 (1) (sub pow) (2))
  93           (13 (7) var (1))
  94           (12 (6) name (1))
  95           (11 (0 21) (m n) (0))
  96           (10 (0 20) choose (0))
  97           (9 (0 19) (x n) (0))
  98           (8 (0 18) pow (0))
  99           (7 (0 13) (m n p) (0))
 100           (6 (0 12) bin-prob (0))
 101           (5 (0 23)
 102              (+ (choose (- m 1) n)
 103                 (choose (- m 1) (- n 1)))
 104              (0))
 105           (4 (0 22)
 106              (or (equal n 0)
 107                  (equal n m))
 108              (0))
 109           (3 (0 17)
 110              ((if (BOUNDARY CASE)
 111                   1
 112                 (CALL MYSELF)))
 113              (0 23 22 21 20 17 15))
 114           (2 (0 16)
 115              ((if (equal n 0)
 116                   1
 117                 (* x (pow x (- n 1)))))
 118              (0 19 18 16 14))
 119           (1 (0 15 14)
 120              ((* (choose m n)
 121                  (pow (- 1 p) (- n 1))
 122                  (pow p n)))
 123              (0 13 12))
 124           (0 (0 11 10 9 8 7 6 5 4 3 2 1)
 125              nil
 126              (0 11 10 9 8 7 6 5 4 3 2 1))))
 127
 128 ;; Run the program in situ.
 129
 130 (funcall (node-fun 1
 131                    'get-code
 132                    'get-vars
 133                    'get-dependencies)
 134          3 2 0.5)
 135 => 0.375
 136
 137 ;; A look under the hood.
 138
 139 (node-fun 1
 140           'get-code
 141           'get-vars
 142           'get-dependencies)
 143   =>
 144 (lambda (m n)
 145   (flet ((choose (m n)
 146                  (apply (node-fun 1
 147                                   (quote get-code)
 148                                   (quote get-vars)
 149                                   (quote get-dependencies))
 150                         (list m n))))
 151     (if (or (equal n 0)
 152             (equal n m))
 153         1
 154       (+ (choose (- m 1) n)
 155          (choose (- m 1) (- n 1))))))
 156
 157 ;;  Tangle it down to a regular program lising, then run it.
 158
 159 (tangle-routine 1
 160                 'get-name
 161                 'get-vars
 162                 'get-code
 163                 'get-chunks
 164                 'get-dependencies)
 165   =>
 166 (defun bin-prob (m n p)
 167   (* (choose m n)
 168      (pow (- 1 p) (- n 1))
 169      (pow p n)))
 170 => bin-prob
 171
 172 (tangle-routine 2
 173                 'get-name
 174                 'get-vars
 175                 'get-code
 176                 'get-chunks
 177                 'get-dependencies)
 178   =>
 179 (defun pow (x n) (if (equal n 0)
 180                      1
 181                    (* x (pow x (- n 1)))))
 182
 183 => pow
 184
 185 (tangle-routine 3
 186                 'get-name
 187                 'get-vars
 188                 'get-code
 189                 'get-chunks
 190                 'get-dependencies)
 191   =>
 192 (defun choose (m n)
 193   (if (or (equal n 0)
 194           (equal n m))
 195       1 (+ (choose (- m 1) n)
 196            (choose (- m 1) (- n 1)))))
 197 => choose
 198
 199 (bin-prob 3 2 0.5)
 200 => 0.375
 201
 202
 203
 204
 205
 206