;; Copyright (C) 2010  Tiago Charters de Azevedo <tca@diale.org>

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


(provide :1960-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 on 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
				     :height 1
				     :command (lambda () (clear-text input-text))))
	     (b-clear-out (make-instance 'button
				     :text "Clear Output"
				     :master f-3
				     :width 8
				     :height 1
				     :command (lambda () (clear-text output-text))))
							 
	     (b-eval (make-instance 'button
				    :text "Eval"
				    :master f-eval
				    :width 4
				    :height 1
				    :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 :height 15)))
					       (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)))