;;;; -*- mode:lisp -*-
;;;;**************************************************************************
;;;;FILE:               examples.aim-8
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Transcription in AIM-8 LISP of the programs presented in AIM-8.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2006-08-23 <PJB> Transcribed from AIM-8.
;;;;**************************************************************************



;;; ----------------------------------------
;;; The differential function:
;;; ----------------------------------------

(define maplist
    (lambda (x f)
      (cond ((null x) nil)
            (t        (combine (f x) (maplist (rest x) f))))))


(define diff
    (lambda (y x)
      (cond
        ((atom y)
         (cond ((eq y x) (quote one))
               (t (quote zero))))
        ((eq (first y) (quote plus))
         (combine (quote plus) (maplist (rest y) (lambda (a) (diff (first a) x)))))
        ((eq (first y) (quote times))
         (combine (quote plus)
                  (maplist
                   (rest y)
                   (lambda (a) (combine (quote times)
                                   (maplist
                                    (rest y)
                                    (lambda (w) (cond ((not (eq a w)) (first w))
                                                 (t (diff (first w) x))
                                                 )))))))))))

(diff (quote (plus (times a x) b)) (quote x))
(diff (quote (plus (times a x x) (times b x) c)) (quote x))
(diff (quote (plus (times 2 x) (times 2 x x))) (quote x))
(diff (quote (plus (times 2 x x) (times 4 x u) (times 2 y y))) (quote x))



;;; ----------------------------------------
;;; The Turing machine:
;;; ----------------------------------------

(define find
    (lambda (st sy qs)
      (cond
        ((null qs)                                 nil)
        ((and (eq (first       (first qs))  st)
              (eq (first (rest (first qs))) sy))   (rest (rest (first qs))))
        (t                                         (find st sy (rest qs))))))

(define move
    (lambda (m nsy tape dir)
      ;; tape = (current-symbol left right)
      (cond
        ((eq dir 'l)
         (combine
          (cond
            ((null (first (rest tape)))               (first (rest m)))
            (t                       (first (first (rest tape)))))
          (combine
           (cond ((null (first (rest tape)))          nil)
                 (t                  (rest (first (rest tape)))) )
           (combine
            (combine nsy (first (rest (rest tape))))
            nil))))
        ((eq dir 'r)
         (combine
          (cond ((null(first (rest (rest tape))))     (first (rest m)))
                (t                   (first (first (rest (rest tape))))))
          (combine
           (combine nsy (first(rest tape)))
           (combine
            (cond ((null (first (rest (rest tape))))  nil)
                  (t                 (rest (first (rest (rest tape))))))
            nil)))))))

(define succ
    (lambda (m c)
      (cond
        ((null (find (first c)
                     (first (rest c))
                     (rest (rest m))))  nil)
        (t (combine
            (first (rest (rest (find (first c)
                                     (first (rest c))
                                     (rest (rest m))))))
            (move m
                  (first (find (first c)
                               (first (rest c))
                               (rest (rest m))))
                  (rest c)
                  (first (rest (find (first c)
                                     (first (rest c))
                                     (rest (rest m)))))))))))

(define turing (lambda (m tape) (tu m (combine (first m) tape))))
(define tu
    (lambda (m c)
      (cond ((null (succ m c)) (rest c))
            (t                 (tu m (succ m c))))))


(define tape  (0 (1 1 1 1 b b) (1 1 0 b)))
(define m  (0 b
              (0 0 b r 0)
              (0 1 b r 1)
              (0 b 0 r 2)
              (1 0 b r 1)
              (1 1 b r 0)
              (1 b 1 r 2)))
(define c   (0                                 ; state
             0 (1 1 1 1 b b) (1 1 0 b)))       ; tape

;; (turing m c)                            ; slow


;;; ----------------------------------------
;;; Lisp Self-applied
;;; ----------------------------------------

(load (quote "aim-8.aim-8"))

(repl
        (quote
         ( (define maplist
               (lambda (x f)
                 (cond ((null x) nil)
                       (t        (combine (f x) (maplist (rest x) f))))))

           (define diff
               (lambda (y x)
                 (cond
                   ((atom y)
                    (cond ((eq y x) (quote one))
                          (t (quote zero))))
                   ((eq (first y) (quote plus))
                    (combine (quote plus)
                             (maplist (rest y) (lambda (a) (diff (first a) x)))))
                   ((eq (first y) (quote times))
                    (combine (quote plus)
                             (maplist
                              (rest y)
                              (lambda (a) (combine
                                      (quote times)
                                      (maplist
                                       (rest y)
                                       (lambda (w) (cond
                                                ((not (eq a w)) (first w))
                                                (t (diff (first w) x))
                                                )))))))))))

           (diff (quote (plus (times a x) b)) (quote x)) ; slow
           )))