SICP uuendus

sicp.lisp

+(defun element-of-set-p (x set)
+  (cond ((null set) nil)
+        ((= x (entry set)) t)
+        ((< x (entry set))
+         (element-of-set-p
+          x 
+          (left-branch set)))
+        ((> x (entry set))
+         (element-of-set-p
+          x 
+          (right-branch set)))))
+
+(defun adjoin-set (x set)
+  (cond ((null set) (make-tree x '() '()))
+        ((= x (entry set)) set)
+        ((< x (entry set))
+         (make-tree 
+          (entry set)
+          (adjoin-set x (left-branch set))
+          (right-branch set)))
+        ((> x (entry set))
+         (make-tree
+          (entry set)
+          (left-branch set)
+          (adjoin-set x (right-branch set))))))
+
+
+(defun intersection-set (set1 set2)
+  (cond ((or (null set1) (null set2))
+	 '())
+	((element-of-set-p (car set1) set2)
+	 (cons (car set1)
+	       (intersection-set (cdr set1)
+				 set2)))
+	(t (intersection-set (cdr set1)
+				 set2))))
+(defun union-set (set1 set2)
+  (cond ((null set1)
+	 set2)
+	((null set2)
+	 '())
+	(t (union-set (cdr set1)
+		      (adjoin-set (car set1) set2)))))
+
+(defun entry (tree) (car tree))
+(defun left-branch (tree) (cadr tree))
+(defun right-branch (tree) (caddr tree))
+(defun make-tree (entry left right)
+  (list entry left right))
+
+(defun tree->list-1 (tree)
+  (if (null tree)
+      '()
+      (append 
+       (tree->list-1 
+        (left-branch tree))
+       (cons (entry tree)
+             (tree->list-1 
+              (right-branch tree))))))
+
+(defun tree->list-2 (tree)
+  (labels ((copy-to-list (tree result-list)
+	     (if (null tree)
+		 result-list
+		 (copy-to-list 
+		  (left-branch tree)
+		  (cons (entry tree)
+			(copy-to-list 
+			 (right-branch tree)
+			 result-list))))))
+    (copy-to-list tree '())))
+
+(defun list->tree (elements)
+  (car (partial-tree 
+        elements (length elements))))
+
+(defun partial-tree (elts n)
+  (if (= n 0)
+      (cons '() elts)
+      (let* ((left-size 
+               (floor (- n 1) 2))
+	     
+	     (left-result 
+               (partial-tree 
+                elts left-size))
+	     
+             (left-tree 
+               (car left-result))
+             (non-left-elts 
+               (cdr left-result))
+             (right-size 
+               (- n (+ left-size 1)))
+	     
+	     (this-entry 
+               (car non-left-elts))
+             (right-result 
+               (partial-tree 
+                (cdr non-left-elts)
+                right-size))
+	     
+             (right-tree 
+               (car right-result))
+             (remaining-elts 
+               (cdr right-result)))
+	
+        (cons (make-tree this-entry 
+                         left-tree 
+                         right-tree)
+              remaining-elts))))
+
+(defparameter *test-tree* '(7 (3 (1) (5)) (9 () (11))))
+
+"--deriv--"
+(defun deriv (exp var)
+  (cond ((numberp exp) 0)
+        ((variablep exp)
+         (if (same-variable-p exp var) 1 0))
+        ((sump exp)
+         (make-sum (deriv (addend exp) var)
+                   (deriv (augend exp) var)))
+        ((productp exp)
+         (make-sum
+          (make-product 
+           (multiplier exp)
+           (deriv (multiplicand exp) var))
+          (make-product 
+           (deriv (multiplier exp) var)
+           (multiplicand exp))))
+	((exponentiationp exp)
+	 (make-product
+	  (make-product
+	  (exponent exp)
+	  (make-exponentiation (base exp)
+				(make-sum (exponent exp) -1)))
+	   (deriv (base exp) var)))
+        (t (error (format nil "unknown expression type: DERIV~%~a" exp)))))
+
+(defun =numberp (exp num)
+  (and (numberp exp)
+       (= exp num)))
+
+(defun variablep (e)
+  (symbolp e))
+
+(defun same-variable-p (v1 v2)
+  (and (variable? v1)
+       (variable? v2)
+       (eq v1 v2)))
+
+(defun sump (e)
+  (and (consp e)
+       (eq (car e) '+)))
+
+(defun addend (e)
+  (second e))
+
+(defun augend (e)
+  (cddr e))
+
+(defun make-sum (&optional a1 &rest a2)
+  (format t "~&! ~d ; ~d~%" a1 a2)
+  (let* ((a-rest* (if (< (length a2) 2)
+		     a2
+		     (apply #'make-sum a2)))
+	 (a-rest (cdr a-rest*))
+	 (a2* (if (numberp a-rest)
+		  a-rest
+		  (addend a-rest))))
+    (print "---")
+    (print a1)
+    (print a-rest)
+    (print a2*)
+    (cond ((null a1)
+	   (print 1)
+	   0)
+	  ((null a2*)
+	   (print 2)
+	   a1)
+	  ((sump a1)
+	   (print 3)
+	   (make-sum (addend a1)
+		     (apply #'make-sum
+			    (augend a1)
+			    a-rest)))
+	  ((=numberp a1 0)
+	   (print 4)
+	   a-rest)
+	  ((=numberp a2* 0)
+	   (print 5)
+	   (apply #'make-sum
+		  a1
+		  (cdr a-rest)))
+	  ((and (numberp a1)
+		(numberp a2*))
+	   (print 6)
+	   (apply #'make-sum
+		  (+ a1 a2*)
+		  (cdr a-rest)))
+	  ((numberp a2*)
+	   (print 7)
+	   (apply #'list '+ a2* a1 (cdr a-rest)))
+	  (t
+	   (print 8)
+	   (apply #'list '+ a1 a-rest)))))
+
+
+(defun test (&optional a1 &rest a2)
+  (apply #'list '+ (car a2) a1 (cdr a2)))
+
+(defun productp (e)
+  (and (consp e)
+       (eq (car e) '*)))
+
+(defun multiplier (e)
+  (second e))
+
+(defun multiplicand (e)
+  (cddr e))
+
+(defun make-product (m1 m2)
+  (cond ((or (=numberp m1 0)
+	     (=numberp m2 0))
+	 0)
+	((=numberp m1 1) m2)
+	((=numberp m2 1) m1)
+	((and (numberp m1)
+	      (numberp m2))
+	 (* m1 m2))
+	(t (list '* m1 m2))))
+
+(defun exponentiationp (e)
+  (and (consp e)
+       (eq (car e) '^)))
+
+(defun base (e)
+  (second e))
+
+(defun exponent (e)
+  (third e))
+
+(defun make-exponentiation (b e)
+  (cond ((=numberp e 0) 1)
+	((=numberp e 1) b)
+	((=numberp b 1) 1)
+	((and (numberp b)
+	      (numberp e))
+	 (expt b e))
+	(t (list '^ b e))))
+
+"---"
+  
+(defun memq (item x)
+  (cond ((null x) nil)
+	((eq item (car x)) x)
+	(t (memq item (cdr x)))))
+
+(defun equal? (x y)
+  (cond ((and (symbolp x) (symbolp y))
+	 (eq x y))
+	((and (listp x) (listp y))
+	 (and (equal? (car x) (car y))
+	      (equal? (cdr x) (cdr y))))
+	(t nil)))
+
+
+
+"~~~Pictures~~~"
+
+(defun make-vect (x y)
+  (cons x y))
+
+(defun xcor-vect (vect)
+  (car vect))
+
+(defun ycor-vect (vect)
+  (cdr vect))
+
+(defun add-vect (v1 v2)
+  (make-vect (+ (xcor-vect v1)
+		(xcor-vect v2))
+	     (+ (ycor-vect v1)
+		(ycor-vect v2))))
+
+(defun sub-vect (v1 v2)
+  (make-vect (- (xcor-vect v1)
+		(xcor-vect v2))
+	     (- (ycor-vect v1)
+		(ycor-vect v2))))
+
+(defun scale-vect (scalar v)
+  (make-vect (* scalar
+		(xcor-vect v))
+	     (* scalar
+		(ycor-vect v))))
+
+(defun make-frame (origin edge1 edge2)
+  (list origin edge1 edge2))
+
+(defun origin-frame (frame)
+  (first frame))
+
+(defun edge1-frame (frame)
+  (second frame))
+
+(defun edge2-frame (frame)
+  (third frame))
+
+(defun frame-coord-map (frame)
+  (lambda (v)
+    (add-vect
+     (origin-frame frame)
+     (add-vect
+      (scale-vect (xcor-vect v)
+		  (edge1-frame frame))
+      (scale-vect (ycor-vect v)
+		  (edge2-frame frame))))))
+
+(defun make-segment (start end)
+  (cons start end))
+
+(defun start-segment (segment)
+  (car segment))
+
+(defun end-segment (segment)
+  (cdr segment))
+
+(defun outline ()
+  (segments->painter
+   (list (make-segment
+	  (make-vector 0 0)
+	  (make-vector 1 0))
+	 (make-segment
+	  (make-vector 1 0)
+	  (make-vector 1 1))
+	 (make-segment
+	  (make-vector 1 1)
+	  (make-vector 0 1))
+	 (make-segment
+	  (make-vector 0 1)
+	  (make-vector 0 0)))))
+
+"----"
+
 (defun accumulate (op initial sequence)
   (labels ((iter (sequence total)
 	     (if (null sequence)
@@ -239,6 +582,7 @@
 	(t
 	 (append (fringe (car list))
 		 (fringe (cdr list))))))
+"
 
 (defparameter *x* 
   (list (list 1 12) (list 3 4)))
@@ -279,6 +623,7 @@
 		   nil
 		   (* weight (branch-length branch))))))
     (atom (mobile-weight mobile))))
+"
 
 (defun square-tree (list)
   (tree-map #'square list))
@@ -290,10 +635,8 @@
       (list nil)
       (let ((rest (subsets (cdr s))))
         (append rest (map-my #'(lambda (x) (cons (first s) x)) rest)))))
-(identity)
-(defun verbose (x)
-  (pprint x)
-  x)
+
+
 
 "--------"