✍ Implementação do LISP de John McCarthy, de 1960

Implementação do LISP de JMC de 1960 em LTK

Hoje tive tempo para acabar a implementação do LISP de 1960 de John McCarthy (Recursive Functions of Symbolic Expressions and Their Computation by Machine, Part I, Communications of the ACM 3:4, April 1960, pp. 184-195) em LTK. O código está aqui.

A imagem mostra uma das funções descrita no artigo.

(provide :1960-lisp)
(load "/home/tca/lisp_packages/ltk/ltk.lisp")
(defpackage :1960-lisp
  (:use :common-lisp :ltk)
  (:export lisp)
  (:documentation "1960-lisp is a CL implementation of John McCarthy's  LISP from the paper
    Recursive Functions of Symbolic Expressions and Their Computation by Machine, higly inspired in Paul Graham's
    The Roots of Lisp"))

(in-package :1960-lisp)

(setf tutorial "Examples:

 1. ((eq 'a 'a) '()) => t

 2. ((eq 'a 'b) '()) => nil

 3. ((cons x '(b c))'((x a ) (y b))) => (a b c)

 4. (((label firstatom (lambda (x)
                                  (cond ((atom x) x)
                                        ('t (firstatom (car x))))))
               y)
             '((y ((a b) (c d))))) => a

 5. ((cons x (cdr y))
             '((x a) (y (b c d)))) => (a b c)

 6.  (((lambda (x) (cons 'a x)) '(b c))
       '((f (lambda (x) (cons 'a x))))) => (a b c)

 7. (((label ident (lambda (x) x))
         y)
         '((y ident))) => indent

 8. (((lambda (x) x) '((lambda (x) x))) '()) => (lambda (x) x)

 9. (((label diag (lambda (x) (list x (list 'quote x))))
          y)
        '((y list))) => (list (quote list))

 10. (((label diag (lambda (x) (list x (list 'quote x))))
         y)
       '((y diag))) => (diag (quote diag))

 11. From the original paper og JMC

     (((label ff (lambda (x)
                     (cond ((atom x) x)
                           ('t (ff (car x))))))
         y)
       '((y ((a b) (c d))))) => a
")

(defun not. (x)
  (cond (x '())
        ('t 't)))

(defun null. (x)
  (eq x '()))

(defun and. (x y)
  (cond (x (cond (y't) ('t '())))
        ('t '())))

(defun pair. (x y)
  (cond ((and. (null. x) (null. y)) '())
        ((and. (not. (atom x)) (not. (atom y)))
         (cons (list (car x) (car y))
               (pair. (cdr x) (cdr y))))))

(defun append. (x y)
  (cond ((null. x) y)
        ('t (cons (car x) (append. (cdr x) y)))))

(defun assoc. (x y)
  (cond ((eq (caar y) x) (cadar y))
        ('t (assoc. x (cdr y)))))

(defun eval. (e a)
  (cond
    ((atom e) (assoc. e a))
    ((atom (car e))
     (cond
       ((eq (car e) 'quote) (cadr e))
       ((eq (car e) 'atom)  (atom   (eval. (cadr e) a)))
       ((eq (car e) 'eq)    (eq     (eval. (cadr e) a)
                                    (eval. (caddr e) a)))
       ((eq (car e) 'car)   (car    (eval. (cadr e) a)))
       ((eq (car e) 'cdr)   (cdr    (eval. (cadr e) a)))
       ((eq (car e) 'cons)  (cons   (eval. (cadr e) a)
                                    (eval. (caddr e) a)))
       ((eq (car e) 'cond)  (evcon. (cdr e) a))
       ((eq (car e) 'list) (evlis. (cdr e) a))
       ((eq (car e) 'list) (evlis. (cdr e) a))
       ('t (eval. (cons (assoc. (car e) a)
                        (cdr e))
                  a))))
    ((eq (caar e) 'label)
     (eval. (cons (caddar e) (cdr e))
            (cons (list (cadar e) (car e)) a)))
    ((eq (caar e) 'lambda)
     (eval. (caddar e)
            (append. (pair. (cadar e) (evlis. (cdr e) a))
                     a)))))


(defun evcon. (c a)
  (cond ((eval. (caar c) a)
         (eval. (cadar c) a))
        ('t (evcon. (cdr c) a))))

(defun evlis. (m a)
  (cond ((null. m) '())
        ('t (cons (eval. (car m) a)
            (evlis. (cdr m) a)))))

(defun apply. (f a)
  (eval. (cons f (appq. a)) '()))


(defun appq. (m)
  (cond ((null m) '())
        (t
         (cons (list 'quote (car m)) (appq. (cdr m))))))

(defun lisp ()
    (with-ltk ()
      (wm-title *tk* "LISP")
      (let* ((frame-menus (make-menubar))
             (menu-help (make-menu frame-menus "Help"))
             (f-1 (make-instance 'frame))
             (f-2 (make-instance 'frame))
             (f-3 (make-instance 'frame))
             (f-tutorial (make-instance 'frame))
             (f-eval (make-instance 'frame))
             (f-t-1 (make-instance 'frame))
             (f-t-2 (make-instance 'frame))
             (title-f-1 (make-instance 'label :master f-1 :text "Input box: "))
             (title-f-2 (make-instance 'label :master f-2 :text "Output box: "))

             (input-text (make-instance 'text
                              :master f-1))
             (output-text (make-instance 'text
                                         :master f-2))
             (b-clear-in (make-instance 'button
                                     :text "Clear Input"
                                     :master f-3
                                     :width 7
                                     :command (lambda () (clear-text input-text))))
             (b-clear-out (make-instance 'button
                                     :text "Clear Output"
                                     :master f-3
                                     :width 8
                                     :command (lambda () (clear-text output-text))))

             (b-eval (make-instance 'button
                                    :text "Eval"
                                    :master f-eval
                                    :width 4
                                    :command (lambda ()
                                               (setf (text output-text)
                                                     (eval-input-text (read-from-string (text input-text))))))))
        (make-menubutton menu-help "Tutorial" (lambda ()
                                                (let* ((w-about (make-instance 'toplevel  :takefocus nil))
                                                       (txt (make-instance 'scrolled-text :master w-about)))
                                                  (wm-title w-about "Examples")
                                                  (pack txt)
                                                  (setf (text txt) tutorial))))
        (make-menubutton menu-help "About" (lambda ()
                                             (let* ((w-about (make-instance 'toplevel  :takefocus nil))
                                                    (txt (make-instance 'text :master w-about :width 60 )))
                                               (wm-title w-about "About")
                                               (pack txt)
                                               (setf (text txt) "GPLv3 - (c) Tiago Charters de Azevedo <tca@diale.org>"))))

        (pack f-1 :side :top :expand t :fill :both)

        (pack title-f-1 :side :top :expand t :fill :both)
        (pack input-text)

        (pack f-2 :side :top :expand t :fill :both)
        (pack title-f-2 :side :top :expand t :fill :both)
        (pack output-text)

        (pack f-3 :side :left :expand nil :fill :none)
        (pack b-clear-in :side :left)
        (pack b-clear-out :side :left)

        (pack f-eval :side :right :expand t :fill :both)
        (pack b-eval :side :right)
        )))

(defun eval-input-text (txt)
  (eval. (car txt) (cadadr txt)))

(lisp)

P.S. 160125: Código LTK actualizado.

Palavras chave/keywords: LISP, John McCarthy, original paper, LTK

Criado/Created: NaN

Última actualização/Last updated: 25-01-2016 [15:38]


GNU/Emacs

1999-2016 (ç) Tiago Charters de Azevedo

São permitidas cópias textuais parciais/integrais em qualquer meio com/sem alterações desde que se mantenha este aviso.

Verbatim copying and redistribution of this entire page are permitted provided this notice is preserved.