;; Copyright 1994, Brown University, Providence, RI
;; See end of file for full copyright information
(in-package 'user)

;; This file lists examples from the symbolic programming chapter.

;;---------------------------------------------------------------------------
;; Procedure invocation:
;;---------------------------------------------------------------------------

;; (* 5 5)                                        => 25
;; (* (+ 2 3) 5)                                  => 25
;; (* (+ 1 1 (* 1 (+ 1 1 1))) (+ 1 1 1 1 1))      => 25

;;---------------------------------------------------------------------------
;; Manipulating list structures:
;;---------------------------------------------------------------------------

;; Create the expression corresponding to (1 2 (FOO 3) ((BAR 4) 5)),
;; i. Using QUOTE:
;; '(1 2 (FOO 3) ((BAR 4) 5))
;; ii. Using LIST:
;; (list 1 2 (list 'FOO 3) (list (list 'BAR 4) 5))
;; iii. Using CONS:
;; (cons 1 (cons 2 (cons (cons 'FOO (cons 3 ()))
;;                       (cons (cons (cons 'BAR (cons 4 ())) 
;;                                   (cons 5 ()))
;;                             ()))))
;;
;; Access the symbol FOO in (1 2 (FOO 3) ((BAR 4) 5)) 
;; i. Using FIRST and REST:
;; (first (first (rest (rest '(1 2 (FOO 3) ((BAR 4) 5))))))
;; ii. Using CAR and CDR:
;; (car (car (cdr (cdr '(1 2 (FOO 3) ((BAR 4) 5))))))
;; iii. Using C[A|D]R abbreviations:
;; (caaddr '(1 2 (FOO 3) ((BAR 4) 5)))
;;
;; Create the list (1 2 3 4)
;; i. Using APPEND and the lists (1 2) and (3 4):
;; (append '(1 2) '(3 4))
;; ii. Using CONS and the list (2 3 4):
;; (cons 1 '(2 3 4))

;;---------------------------------------------------------------------------
;; Predicates and boolean operators:
;;---------------------------------------------------------------------------

;; (member 'A '(1 2 A 3))                         => (A 3)
;; (listp 3)                                      => nil
;; (listp (cons 1 (list 2 3)))                    => T
;; (eq '(1 2) '(1 2))                             => nil
;; (equal '(1 2) '(1 2))                          => T
;; (not (listp '(1)))                             => nil
;; (or (listp 'FOO) (member 'A '(A 2))            => (A 2)
;; (and (not (listp 'FOO)) (numberp 4))           => T

;;---------------------------------------------------------------------------
;; Defining simple procedures:
;;---------------------------------------------------------------------------

(defun square (x) 
  (* x x))

(defun cube (x) 
  (* x x x))

(defun next-odd-number (n)
  (if (evenp n) 
      (+ n 1) 
    (+ n 2)))

(defun yes (response) 
  (cond ((member response '(yes y sure ok)) t)
        ((member response '(no n negative)) nil)
        (t (princ "Unknown response type. Assuming no.") nil)))

(defun primep (n)  
    (cond ((>= n 49) (princ "Can't count that high.") nil)
          ((or (= n 2) (= n 3) (= n 5)) t) 
          ((or (= (mod n 2) 0) 
               (= (mod n 3) 0) 
               (= (mod n 5) 0)) nil)
          (t t)))

;;---------------------------------------------------------------------------
;; Side effects:
;;---------------------------------------------------------------------------

;; SETQ assigns symbols values in environments.
;; Example: (setq x 1)                            => 1
;;
;; The scope of changes made by SETQ are determined lexically.
;; Example: (let ((x 1))
;;               (let ((x 2))
;;                    (setq x 3)) 
;;               x)                               => 1 
;;
;; Example: (setq x 1)                            => 1
;;          (defun foo () (setq x 2))             => foo
;;          (let ((x 3)) (foo) x)                 => 3
;;          x                                     => 2
;;
;;    Note: x is being used here as a global variable. Global variables 
;;          should be avoided in your code if at all possible. To alert
;;          readers to their use it is good practice to set off global
;;          variables with asterisks (e.g., *maximum-print-depth*).

;;---------------------------------------------------------------------------
;; SETF changes what pointers point to:
;;---------------------------------------------------------------------------

;; Change the symbol FOO in x to the symbol BAZ

;; (setq x '(1 2 (FOO 3) ((BAR 4) 5))) 
;; (setf (caaddr x) 'BAZ)

;;---------------------------------------------------------------------------
;; SETF can be the cause of confusing bugs:
;;---------------------------------------------------------------------------

;; Example: (let ((x '(1 2 3)))
;;               (let ((y (cons 0 x)))
;;                    (setf (caddr y) 'FOO))
;;               x)                               => (1 FOO 3)
;;
;; Example: (defun foo (x) (setf (caddr x) 'FOO)) => foo
;;          (let ((x '(1 2 3)))
;;               (let ((y (cons 0 x)))
;;                    (foo y))
;;               x)                               => (1 FOO 3)

;;---------------------------------------------------------------------------
;; Recursive functions:
;;---------------------------------------------------------------------------

;; Procedure: SIMPLE_RECURSION
;; Argument: X
;; Definition:
;;   IF X SATISFIES BASE CASE CRITERION
;;      THEN DO BASE CASE THING
;;      ELSE APPLY SIMPLE_RECURSION TO SOME REDUCTION OF X

;;---------------------------------------------------------------------------
;; Raise X to the Nth power.
;;---------------------------------------------------------------------------

(defun raise (x n)
  (if (= n 0) 
      1 
    (* x 
       (raise x 
	    (- n 1)))))

;; Script showing a trace of the exponentiation function:
;;
;; > (defun raise (x n) (if (= n 0) 1 (* x (raise x (- n 1)))))
;; raise
;; > (pretty-print-function-definition raise)
;; (define raise
;;   (lambda (x n)
;;      (if (= n 0) 1 (* x (raise x (- n 1))))))
;; > (mytrace raise)
;; (raise)
;; > (raise 3 2)
;; 1 Enter ... 
;;   Function: raise 
;;   Arguments: (3 2)
;;   Current environment: ((x 3) (n 2))
;;   Evaluating: (if (= n 0) 1 (* x (raise x (- n 1))))
;; |2 Enter ... 
;;    Function: raise 
;;    Arguments: (3 1)
;;    Current environment: ((x 3) (n 1))
;;    Evaluating: (if (= n 0) 1 (* x (raise x (- n 1))))
;; | 3 Enter ... 
;;     Function: raise 
;;     Arguments: (3 0)
;;     Current environment: ((x 3) (n 0))
;;     Evaluating: (if (= n 0) 1 (* x (raise x (- n 1))))
;; | 3 Exit  ...
;;     Function: raise 
;;     Returning: 1
;; |2 Exit ...
;;    Function: raise 
;;    Returning: 3
;; 1 Exit ...
;;   Function: raise 
;;   Returning: 9
;; 9
;; > (quit)

;;---------------------------------------------------------------------------
;; See if an atom is an element of a particular list.
;;---------------------------------------------------------------------------

(defun recur1 (some-list atom-to-look-for) 
  (cond ((null some-list) nil)
        ((eq (first some-list) atom-to-look-for) t) 
        (t (recur1 (rest some-list) atom-to-look-for))))

;;---------------------------------------------------------------------------
;; See if an atom is an element of an arbitrary S-expression.
;;---------------------------------------------------------------------------

(defun recur2 (expr atom-to-look-for) 
  (cond ((null expr) nil)
        ((atom expr) (eq expr atom-to-look-for))
        (t (or (recur2 (first expr) atom-to-look-for) 
               (recur2 (rest expr) atom-to-look-for)))))

;;---------------------------------------------------------------------------
;; What does this function compute?
;;---------------------------------------------------------------------------

(defun recur3 (some-list)
  (cond ((null some-list) (list))
        ((numberp (first some-list)) 
         (cons (first some-list) (recur3 (rest some-list))))
        (t (recur3 (rest some-list)))))

;;---------------------------------------------------------------------------
;; What does this function compute?
;;---------------------------------------------------------------------------

(defun recur4 (expr)	
  (cond ((null expr) (list))
        ((numberp expr) (list expr))
        ((atom expr) (list))
        (t (append (recur4 (first expr))
                   (recur4 (rest expr))))))

;;---------------------------------------------------------------------------
;; What's the difference between these two functions?
;;---------------------------------------------------------------------------

(defun list-sum1 (list-of-numbers)
  (cond ((null list-of-numbers) 0)
        (t (+ (first list-of-numbers) 
              (list-sum1 (rest list-of-numbers))))))

(defun list-sum2 (list-of-numbers)
  (aux-list-sum2 list-of-numbers 0))
(defun aux-list-sum2 (list-of-numbers sum-so-far)
  (cond ((null list-of-numbers) sum-so-far)
        (t (aux-list-sum2 (rest list-of-numbers) 
                          (+ (first list-of-numbers) sum-so-far)))))
 
;;---------------------------------------------------------------------------
;; Prompt the user for a yes or no answer.
;;---------------------------------------------------------------------------

(defun yes-or-no (patience)
  (princ "Yes or No: ")
  (let ((response (read)))
       (cond ((member response '(yes y sure ok)) t)
             ((member response '(no n negative)) nil)
             ((= patience 0) 
              (princ "My patience has run out.") nil)
             (t (yes-or-no (- patience 1))))))

;;---------------------------------------------------------------------------
;; Defining complex data types:
;;---------------------------------------------------------------------------

;;  CONSTRUCTION
;;  ACCESS
;;  MODIFICATION

;;---------------------------------------------------------------------------
;; Labeled binary trees.
;;---------------------------------------------------------------------------

(defun make-TREE (label left right)
  (list 'labeled-binary-tree label left right))

(defun is-TREE (x) 
  (and (listp x) (eq (first x) 'labeled-binary-tree)))

(defun TREE-label (tree) (second tree))

(defun TREE-left (tree) (third tree))

(defun TREE-right (tree) (fourth tree))

(defun set-TREE-label (tree value) 
  (setf (second tree) value))

;;---------------------------------------------------------------------------
;; Display the contents of a binary tree in depth-first order.
;;---------------------------------------------------------------------------

(defun TREE-display (tree)
  (cond ((null tree))
        (t (princ (TREE-label tree))
           (TREE-display (TREE-left tree))
           (TREE-display (TREE-right tree)))))

;;---------------------------------------------------------------------------
;; Find the binary subtree with the specified label.
;;---------------------------------------------------------------------------

(defun find-subtree (tree label)
  (cond ((null tree) nil)
        ((eq label (TREE-label tree)) tree)
        (t (or (find-subtree (TREE-left tree) label)
               (find-subtree (TREE-right tree) label)))))

;;---------------------------------------------------------------------------
;; Build a depth 3 binary tree labeled according to depth-first traversal.
;;---------------------------------------------------------------------------

(defun make-depth-3-binary-tree ()
  (make-TREE 1 (make-TREE 2 (make-TREE 3 ()())
                            (make-TREE 4 ()()))
               (make-TREE 5 (make-TREE 6 ()())
                            (make-TREE 7 ()()))))

;;---------------------------------------------------------------------------
;; Build a depth n binary tree labeled according to depth-first traversal.
;;---------------------------------------------------------------------------

(defun make-binary-tree (n)
  (make-depth-n-binary-tree n 1))
(defun make-depth-n-binary-tree (depth root-label)
  (cond ((= depth 0) ())
        (t (make-TREE root-label 
                      (make-depth-n-binary-tree (- depth 1)
                                                (+ root-label 1))
                      (make-depth-n-binary-tree (- depth 1)
                                                (+ root-label
                                                   (exp 2 (- depth 1))))))))

;;---------------------------------------------------------------------------
;; Passing procedures as arguments:
;;---------------------------------------------------------------------------

(defun my-merge (list1 list2 compare-fun)
  (cond ((null list1) list2)
        ((null list2) list1)
        ((funcall compare-fun (first list1) (first list2))
         (cons (first list1) 
	       (my-merge (rest list1) list2 compare-fun)))
        (t (cons (first list2) 
		 (my-merge list1 (rest list2) compare-fun)))))

(defun merge-test1 ()
  (my-merge '(1 3 5 7) '(2 4 6) #'<))

(defun merge-test2 ()
  (my-merge '((1 1 ) (1 1 1 1)) 
	    '((1) (1 1 1) (1 1 1 1 1)) 
	    #'(lambda (x y) (< (length x) (length y)))))

;;---------------------------------------------------------------------------
;; Builtin iterative constructs:
;;---------------------------------------------------------------------------

;; MAPCAR applies its first argument to successive CARs of lists,
;; and returns a list of the results.

;; Example: Construct a list of the squares of a list of numbers X.
;;          (squares '(1 2 3 4 5)) => (1 4 9 16 25)

(defun squares (x)
  (mapcar #'(lambda (y) (* y y)) x))

;; Example: Compute the product of two vectors represented as lists
;;          of numbers.  (v* '(1 2 3) '(2 3 4)) => (2 6 12)

(defun v* (v1 v2)
  (mapcar #'* v1 v2))

;; MAPCAN is like MAPCAR accept that it APPENDs together the results.

;; Example: Construct a list of all symbols (excluding nil) in X.
;;          (symbols '((1 2 (A 3) B) (4 C 5) (D 6 7))) => (A B C D)

(defun symbols (x)
  (cond ((and (not (null x)) (listp x)) (mapcan #'symbols x))
        ((symbolp x) (list x))
        (t ())))

;; MAPC is like MAPCAR accept that it doesn't do anything with the results.

;; Here's how we might define a version of mapcar for functions of two 
;; arguments:

(defun mapcar-2 (fun args1 args2)
  (cond ((or (null args1) (null args2)) ())
        (t (cons (funcall fun (first args1) (first args2))
                 (mapcar-2 fun (rest args1) (rest args2))))))

;; Defining a general mapcar without macros or special options for arguments
;; is somewhat difficult. Here's about as close as we can come.

(defun mapcar-n (fun arg-lists)
  (cond ((member () arg-lists) ())
        (t (cons (apply fun (cars arg-lists))
                 (mapcar-n fun (cdrs arg-lists))))))
(defun cars (lists)
  (if (null lists) () (cons (first (first lists)) (firsts (rest lists)))))
(defun cdrs (lists)
  (if (null lists) () (cons (rest (first lists)) (cdrs (rest lists)))))

;;---------------------------------------------------------------------------
;; Procedures that return procedures as results:
;;---------------------------------------------------------------------------

(defun make-adder (x)
  #'(lambda (y) (+ x y)))

;; Note: the following will not work in Franz.
(defun make-counter ()
  (let ((x 0))
       #'(lambda () (setq x (+ x 1)) x)))

(defun counter-test ()
  (let ((f (make-counter)) (g (make-counter)))
       (princ "f => ") (princ (funcall f)) (terpri)
       (princ "f => ") (princ (funcall f)) (terpri)
       (princ "f => ") (princ (funcall f)) (terpri)
       (princ "g => ") (princ (funcall g)) (terpri)
       (princ "g => ") (princ (funcall g)) (terpri)
       (princ "g => ") (princ (funcall g)) (terpri)))

;;---------------------------------------------------------------------------
;; More about LET and SET
;;---------------------------------------------------------------------------

;; SETQ and SETF change the values of identifiers in environments.
;; LET and LAMBDA serve to create or augment environments.
;; LET can be defined in terms of LAMBDA:
;; (let ((x 1) (y 2)) ... ) => ((lambda (x y) ... ) 1 2)
;;
;; What's the difference between LET and SETQ?
;; Compare (defun foo1 () (setq x 3) ... )) 
;;  versus (defun foo2 () (let ((x 3)) ... ))
;; 
;; The appropriate environment to determine the value of an identifier
;; is established by lexical scope. If you can understand the output
;; of the following contrived program, then you are well on your way
;; to understanding the difference between dynamic and lexical scoping.
;; (setq x 0)            ;; X, Y, and Z are given initial global values.
;; (setq y 0)
;; (setq z 0)
;; 
;; (defun foo ()
;;   (display-line (list x y z))
;;   (bar -1)
;;   (display-line (list x y z)))
;; 
;; (defun bar (x)
;;   (display-line (list x y z))
;;   (setq x 1)
;;   (setq y 1)
;;   (setq z 1)
;;   (display-line (list x y z))
;;   (let ((y 2))
;;        (display-line (list x y z))
;;        (baz 3)
;;        (display-line (list x y z))
;;        (setq x 4)
;;        (setq y 4)
;;        (setq z 4)
;;        (display-line (list x y z)))
;;   (display-line (list x y z))
;;   (baz 5)
;;   (display-line (list x y z)))
;; 
;; (defun baz (n)
;;   (let ((z -1))
;;        (setq x n)
;;        (setq y n)
;;        (setq z n)))
;; 
;; (defun display-line (x) (terpri) (princ x))
;;
;; > (foo)
;; (0 0 0)
;; (-1 0 0)
;; (1 1 1)
;; (1 2 1)
;; (1 2 1)
;; (4 4 4)
;; (4 3 4)
;; (4 5 4)
;; >
;; 
;; Environments and lexical scoping:
;; 
;; DEFUN allows you to give a global name to a function.
;; The result of (DEFUN FOO (args) forms) is that FOO is the global name
;; for the function specified by the LAMBDA expression (LAMBDA (args) forms).
;; More specifically 
;;      (DEFUN FOO (args) forms)
;; is more or less the same as 
;;      (SETF (SYMBOL-FUNCTION 'FOO) (FUNCTION (LAMBDA (args) forms))).
;; As we saw before LET can be defined in terms of LAMBDA also,
;;      (LET ((X 1) (Y 2)) ... ) => ((LAMBDA (X Y) ... ) 1 2).
;; For the purposes of our immediate discussion, then, there are only LAMBDA 
;; expressions, and only lambda expressions can modify variable values.
;; Each lambda expression introduces a new lexical contour delimited
;; by the scope of the LAMBDA  expressions. 
;; A top-level LAMBDA from a DEFUN has only the outer global environment;
;; the values of variables not specified in the LAMBDA expression are 
;; determined by the global environment. 
;; A LAMBDA expression nested within another may mask variable values;
;; the value of variables not specified in the nested LAMBDA expression
;; is determined by the nesting as indicated by the parenthetical
;; embedding.
;; 
;; What's the advantage of using lexical scoping?
;;  1. The compiler can figure out how to determine the values of 
;;     identifiers efficiently at compile time. Such determinations 
;;     will not depend upon run-time considerations.
;;  2. The programmer can figure out what the values of identifiers 
;;     will be just by looking at individual functions. This makes it 
;;     a lot easier to write large programs or modify programs written 
;;     by other programmers.


;; Copyright 1994, Brown University, Providence, RI
;; 
;; Permission to use and modify this software and its documentation for any
;; purpose other than its incorporation into a commercial product is hereby
;; granted without fee.  Permission to copy and distribute this software and its
;; documentation only for non-commercial use is also granted without fee,
;; provided, however, that the above copyright notice appear in all copies, that
;; both that copyright notice and this permission notice appear in supporting
;; documentation, that the name of Brown University not be used in advertising or
;; publicity pertaining to distribution of the software without specific, written
;; prior permission, and that the person doing the distribution notify Brown
;; University of such distributions outside of his or her organization. Brown
;; University makes no representations about the suitability of this software for
;; any purpose.  It is provided "as is" without express or implied warranty.
;; Brown University requests notification of any modifications to this software
;; or its documentation.
;; 
;; Send the following redistribution information:
;; 
;; 	Name:
;; 	Organization:
;; 	Address (postal and/or electronic):
;; 
;; To:
;; 	Software Librarian
;; 	Computer Science Department, Box 1910
;; 	Brown University
;; 	Providence, RI 02912
;; 
;; 		or
;; 
;; 	brusd@cs.brown.edu
;; 
;; We will acknowledge all electronic notifications.