Add Guile version of John McCarthy's Maxwell Equations of Software.
[mes.git] / mes.scm
1 #! /bin/sh
2 # -*-scheme-*-
3 exec guile -L $(pwd) -e '(scm)' -s "$0" "$@"
4 !#
5
6 ;;; Mes --- The Maxwell Equations of Software
7 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
8 ;;;
9 ;;; This file is part of GNU Guix.
10 ;;;
11 ;;; Mes is free software; you can redistribute it and/or modify it
12 ;;; under the terms of the GNU General Public License as published by
13 ;;; the Free Software Foundation; either version 3 of the License, or (at
14 ;;; your option) any later version.
15 ;;;
16 ;;; Mes is distributed in the hope that it will be useful, but
17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 ;;; GNU General Public License for more details.
20 ;;;
21 ;;; You should have received a copy of the GNU General Public License
22 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
23
24 ;; The Maxwell Equations of Software -- John McCarthy page 13
25 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
26
27 (define-module (scm)
28   #:export (main))
29
30 (set-current-module
31  (make-module 10 `(,(resolve-interface
32                      '(guile)
33                      #:select '(
34                                 ;; Debugging
35                                 apply
36                                 cons*
37                                 current-output-port
38                                 current-error-port
39                                 display
40                                 force-output
41                                 format
42                                 newline
43
44                                 ;; Guile admin
45                                 module-define!
46                                 resolve-interface
47
48                                 ;; PRIMITIVES
49                                 car
50                                 cdr
51                                 cons
52                                 eq?
53                                 null?
54                                 pair?
55                                 )
56                      #:renamer (symbol-prefix-proc 'guile:)))))
57
58 (define (logf port string . rest)
59   (guile:apply guile:format (guile:cons* port string rest))
60   (guile:force-output port)
61   #t)
62
63 (define (stderr string . rest)
64   (guile:apply logf (guile:cons* (guile:current-error-port) string rest)))
65
66 (define (stdout string . rest)
67   (guile:apply logf (guile:cons* (guile:current-output-port) string rest)))
68
69 (define (debug . x) #t)
70 ;;(define debug stderr)
71
72 ;; TODO
73 (define (atom x)
74   (cond
75    ((guile:pair? x) #f)
76    ((guile:null? x) #f)
77    (#t x)))
78
79 ;; PRIMITIVES
80 (define car guile:car)
81 (define cdr guile:cdr)
82 (define cons guile:cons)
83 (define eq guile:eq?)
84 (define null guile:null?)
85
86
87 (define ATOM 'atom)
88 (define CAR 'car)
89 (define CDR 'cdr)
90 (define COND 'cond)
91 (define CONS 'cons)
92 (define EQ 'eq)
93 (define LABEL 'label)
94 (define LAMBDA 'lambda)
95 (define NIL '())
96 (define QUOTE 'quote)
97
98 (define (caar x) (guile:car (guile:car x)))
99 (define (cadr x) (guile:car (guile:cdr x)))
100 (define (cdar x) (guile:car (guile:cdr (guile:car x))))
101 (define (caddr x) (guile:car (guile:cdr (guile:cdr x))))
102 (define (cadar x) (guile:car (guile:cdr (guile:car x))))
103
104 ;; Page 12
105 (define (pairlis x y a)
106   (debug "pairlis x=~a y=~a a=~a\n" x y a)
107   (cond
108    ((null x) a)
109    (#t (cons (cons (car x) (car y))
110              (pairlis (cdr x) (cdr y) a)))))
111
112 (define (assoc x a)
113   (debug "assoc x=~a a=~a\n" x a)
114   (cond
115    ((eq (caar a) x) (car a))
116    (#t (assoc x (cdr a)))))
117
118 ;; Page 13
119 (define (eval-quote fn x)
120   (debug "eval-quote fn=~a x=~a" fn x)
121   (apply fn x NIL))
122
123 (define (apply fn x a)
124   (debug "apply fn=~a x=~a a=~a\n" fn x a)
125   (cond
126    ((atom fn)
127     (debug "(atom fn)=~a\n" (atom fn))
128     (cond
129      ((eq fn CAR) (caar x))
130      ((eq fn CDR) (cdar x))
131      ((eq fn CONS) (cons (car x) (cadr x)))
132      ((eq fn ATOM) (atom (car x)))
133      ((eq fn EQ) (eq (car x) (cadr x)))
134      (#t (apply (eval fn a) x a))))
135    ((eq (car fn) LAMBDA) (eval (caddr fn) (pairlis (cadr fn) x a)))
136    ((eq (car fn) LABEL) (apply (caddr fn) x (cons (cons (cadr fn)
137                                                         (caddr fn)) a)))))
138
139 (define (eval e a)
140   (debug "eval e=~a a=~a\n" e a)
141   (debug "eval (atom ~a)=~a\n" e (atom e))
142   (cond
143    ((atom e) (cdr (assoc e a)))
144    ((atom (car e))
145     (cond
146      ((eq (car e) QUOTE) (cadr e))
147      ((eq (car e) COND) (evcon (cdr e) a))
148      (#t (apply (car e) (evlis (cdr e) a) a))))
149    (#t (apply (car e) (evlis (cdr e) a) a))))
150
151 (define (evcon c a)
152   (debug "evcon c=~a a=~a\n" c a)
153   (cond
154    ((eval (caar c) a) (eval (cadar c) a))
155    (#t (evcon (cdr c) a))))
156
157 (define (evlis m a)
158   (debug "evlis m=~a a=~a\n" m a)
159   (cond
160    ((null m) NIL)
161    (#t (cons (eval (car m) a) (evlis (cdr m) a)))))
162
163 (define (main arguments)
164   (stdout "Hello scm\n")
165   (guile:display (eval 0 '((0 . 0) (1 . 1))))
166   (guile:newline)
167   (guile:display (eval 1 '((0 . 0) (1 . 1))))
168   (guile:newline)
169   (guile:display (eval '(car '(0 1)) '((0 . 0) (1 . 1))))
170   (guile:newline)
171   (guile:display (eval '(cdr '(0 1)) '((0 . 0) (1 . 1))))
172   (guile:newline)
173   (guile:display (apply 'cons '(0 1) '((0 . 0) (1 . 1))))
174   (guile:newline)
175   (guile:display (eval '(cons 0 1) '((0 . 0) (1 . 1))))
176   (guile:newline)
177   (guile:display (apply '(lambda (x y) (cons x y)) '(0 1) '((0 . 0) (1 . 1))))
178   (guile:newline)
179   (guile:display (eval '((label fun (lambda (x) x)) 2 2) '((2 . 2))))
180   (guile:newline))
181
182 (guile:module-define! (guile:resolve-interface '(scm)) 'main main)