; -*-Lisp-*- ;Time-stamp: "2005-08-18 23:19:51 ADT" ; Keyed in by Sean M. Burke, sburke@cpan.org ; See: ; "An Auxiliary Language for More Natural Expression--The A-language", ; W. Henneman in The Programming Language LISP, E.C. Berkeley et al eds, ; MIT Press 1964, pp.239-248. ; (and Appendix 4, "The LISP Program for the A-Language", pp.318-325.) ; 'define(( ... ))' changed to '(define ...) (define ( (not (lambda (x) (cond ((fq x t) nil) (tt) ))) (last (lambda (x) (cond ((null x) nil) ((null (cdr x)) (car x)) (t (last (cdr x))) ))) (fifth (lambda (x) (car (cddddr x)))) (var (lambda (x y) (cond ((null y) nil) ((or (equal (car x) (cadr y)) (member (car y) (caddr x))) (var x (cdr y))) (t (cons (car y) (var x (cdr y)))) ))) (unwind (lambda (x) (var x (fifth x)))) (thens (lambda (x) (cond ((equal (car x) 'then) (then (cdr x))) (t (thens (cdr x)))))) (def (lambda (x) (list 'define (list (list (list (cadr x) (list 'lambda (unwind x) (defn (last x)) ) ) ) ) ) )) (defl (lambda (x) (defl1 (condit 0 0 x)))) (defl1 (lambda (x) (defl2 (verb (if (cdr x))) (verb (thens x))) )) (defl2 (lambda (x y) (list (cond ((equal (length x) 1) (car x)) (t x)) (cond ((equal (length y) 1) (car y)) (t y)) ) )) (ff (lambda (x) (cond ((null x) nil) ((atom x) x) (t (ff (car x))) ))) (defb1 (lambda (x y) (cond ((null x) nil) (t (cons (defl x) (cond ((null y) nil) ((equal (car y) (ff l)) (list y)) (t y) ))) ) )) (defj (lambda (x n) (cond ((null x) nil) ((equal (car x) 'else) (cond ((equal n 1) (cond ((null (cdr x)) (print (quote (inc cond)))) ((equal (cadr x) 'if) (defm (cdr x))) (t (defl (cons 'if (cons 't (cons 'then (cdr x)))) )))) (t (defj (cdr x) (sub1 n)))) ) (t (defj (cdr x) n))))) )) (define ( (defn (lambda (x) (cond ((null x) nil) ((equal (car x) 'if) (cons 'cond (defm x))) (t (verb (cons (car x) (defn (cdr x))))) ) )) (verbiose (lambda (x y) (verbiose 1 (verbs x y y 0) y))) (verbiose1 (lambda (x y) (cond ((equal x y) t) (t x)))) )) (define ( (verb1 (lambda (x y) (cond ((equal x y) t) (t (verb y)) ))) (sex (lambda (w x y z n) (cond ((null x) nil) ((equal (difference n (verbpos x y)) 0) (cons y (sexy w x (cons y z) (length x)) ) ) ; else... (t (untouch (cdr x) y z (sub n))) ))) (begincount (lambda (m n x) (cond ((null x) nil) ((equal (car x) 'begin) (begcount m n x)) (t (begincount m n (cdr x))) ))) (begcount (lambda (m n x) (cond ((null x) nil) ; case 0 ((equal (car x) 'begin) ; case 1 (cons (car x) (begcount (add1 m) n (cdr x)) ) ) ((equal (car x) 'end) ; case 2 (cond ((equal (sub1 m) n) nil) (t (cons (car x) (begcount m (add1 n) (cdr x)) ) ) ) ) (t ; case else (cons (car x) (begcount m n (cdr x)))) ) )) (verbdef1 (lambda (x y z) (cond ((null x) (cond ((null x) y) ; testing x again? (t (cons y z)) )) ((null z) (cond ((null y) x) (t (append x (list y))) )) ((null y) (append x z)) (t (append x (cons x y))) ) )) (propform (lambda (x) (cond ((equal (length x) l) x) (t (cons (car x) (list (cdr x)))) ) )) (condit (lambda (m n x) (cond ((null x) nil) ((equal (car x) 'if) (cons (car x) (condit (add1 m) n (cdr x)) )) ((equal (car x) 'else) (cond ((equal (sub1 m) nl) nil) (t (cons (car x) (condit m (add1 n) (cdr x)))))) (t (cons (car x) (condit m n (cdr x)) )) ) )) (h (lambda (x y) (cond ((null y) (minus 1)) ((null x) (h listc (cdr y))) ((and (equal (caarx) 'define) (equal (cadar x) (car y))) ; then... (cond ((greaterp (caar (cdddar x)) (h listc (cdr y))) ; then... (caar (cdddar x))) ; else... (t (h listc (cdr y))) )) ; else... (t (h (cdr x) y)) ) )) (verb (lambda (x) (verb1 x (verbiose listc x)))) (verbs (lambda (x y z n) (cond ((null x) (verbs listc (cdr y) z (add1 n))) ((null y) t) ((member 'begin y) (append (prebeg y) (cons (beginfn (cdr (begincount 0 0 y))) (endcount 0 y) ) ) ) ((and (equal (caar x) 'define) (equal (cadar x) (car y)) ) (cond ((greaterp (caar (cdddar x)) (h listc (cdr y))) (verbdef (car x) z n)) (t (verbs listc (cdr y) z (add1 n))))) ; else... (t (verbs (cdr x) y z n)) ) )) (translate (lambda (x) (cond ((null x) nil) ((atom (car x)) nil) ((eq (caar x) 'define) (append (def (car x)) (translate (cdr x)))) (t (append (propform (verb (car x))) (translate (cdr x)))) ))) )) ;; Extra lines in ms: ;; stop))))))))))))stop ;; fin ;; (t (sex (cdr w) x y z (sub1 n ))) ))) ;; Part of a function whose first lines are missing? (define ; not in MS ( ; not in MS (verbpos (lambda (x y) (cond ((equal (car x) y) 0) (t (add1 (verbpos (cdr x) y))) ))) )) (define ( (nontouch (lambda (x y n) (cond ((null y) nil) ((equal (plus n (length x)) 1) (cdr y)) (t (nontouch x (cdr y) (sub1 n))) ))) )) (define ( (if (lambda (x)) (cond ((null x) nil) ((member 'begin x) (if (append (prebeg x) (cons (begif (begincount 0 0 x)) (endcount 0 x))))) ((equal (car x) 'if) (list (defn x))) ((equal (car x) 'than) nil) (t (cons (car x) (if (cdr x))))))) (prebeg (lambda (x) (cond ((null x) nil) ((equal (car x) 'begin) nil) (t (cons (car x) (prebeg (cdr x)))) ))) (beginfn (lambda (x) (cond ((null x) nil) (t (verb x))))) (endcount (lambda (x) (cond ((null x) nil) ((equal (car x) 'begin) (endcount (addn1 n) (cdr x))) ((equal (car x) 'end) (cond ((equal n 1) (cdr x)) (t (endcount (sub1 n) (cdr x))) )) (t (endcount n (cdr x))) ))) (begif (lambda (x y z n) (cond ((equal n 0) nil) ((null x) nil) ((member (car x) z) (sexy (cdr x) y z (sub1 n))) (t (cons (car x) (sexy (cdr x) y z (sub1 n)) )) ))) (untouch (lambda (x y z n) (cond ((null x) nil) ((null z) nil) ((equal (car x) y) (cond ((equal n 0) nil) (t (cons (car z) (untouch x y (cdr z) (sub1 n)))))) ...and...? ;;end