(defun diversity (p n)
  (let (prob)
     (if (or (zerop p)
	     (zerop n )) 0.0
          (progn
         (setf prob (/ p (+ p n)))
	 (+ (* prob (log  prob 2.0))
            (* (- 1.0 prob)
               (log  (- 1.0 prob) 2.0)))))))

(defun all-equalp (l)
       (or (< (length l) 2)
	      (and (equal (first l) (second l))
		   (all-equalp (rest l)))))

(defun attr-value  (i tr)
     (let
       (pairs b11 b10 b00 b01)
        (setf pairs (mapcar #'(lambda (x )
		       (cons (nth i x) (first (last x)))) 
                  tr))
           (setf b11 (count (cons 1 1) pairs :test #'equal))
	   (setf b10 (count (cons 1 0) pairs :test #'equal))
	   (setf b00 (count (cons 0 0) pairs :test #'equal))
	   (setf b01 (count (cons 0 1) pairs :test #'equal))
         (+ (* (+ b11 b10) (diversity b11 b10))
	    (* (+ b01 b00) (diversity b01 b00)))))

(defun best-attr   (tr)
      (let (mx vals i)
	   (setf i -1)
	   (setf mx (apply #'max
		  (setf vals (mapcar #'(lambda (x) x
			(incf i)
			 (attr-value i tr))
                         (butlast (first tr))))))
           (position mx vals)))

(defun split (tr i)
   (let (zeroes ones)
       (setf zeroes nil ones nil)
		 (mapc #'(lambda (x)
		      (if (= (nth i x) 0)
			  (setf zeroes (cons x zeroes))
			  (setf ones   (cons x ones))))
                          tr)
       (list i zeroes ones)))

(defun make-dt (tr)
   (let (s)
      (if tr
	  (if (all-equalp (mapcar #'last tr))
	      (first (last (first tr))) ; leaf
	      (progn
		   (setf s (split tr (best-attr tr))) 
		   (cons (car s)
			 (mapcar #'make-dt (rest s))))))))

(setf or '((0 0  0)
           (0 1  1)
	   (1 0  1)
	   (1 1   1)))

(setf xor '((0 0  0)
            (0 1  1)
	    (1 0  1)
	    (1 1  0)))

(setf xorp '((0 0 0  0)
             (0 1 0  1) 
	     (1 0 0  1)
	     (1 1 1  0)))


(setf and '((0 0  0)
            (0 1  0)
	    (1 0  0) 
	    (1 1  1)))

(setf maj3 '((0 0 0 0)
             (0 0 1  0)  
	     (0 1 0  0)
	     (0 1 1  1)
	     (1 0 0  0)
	     (1 0 1  1)
	     (1 1 0  1)
	     (1 1 1  1)))

(setf  prob20-5
                 '((1 0 1 0 0 0 1)
		   (1 0 1 1 0 0 1)
		   (1 0 1 0 1 0 1)
		   (1 1 0 0 1 1 1)
		   (1 1 1 1 0 0 1)
		   (1 0 0 0 1 1 1)
		   (1 0 0 0 1 0 0)
		   (0 1 1 1 0 1 1)
		   (0 1 1 0 1 1 0)
		   (0 0 0 1 1 0 0)
		   (0 1 0 1 0 1 0)
		   (0 0 0 1 0 1 0)
		   (0 1 1 0 1 1 0)
		   (0 1 1 1 0 0 0)))

(setf allergy
  ;page 416 winston
       '((-1 -1 -1 -1  1.0)
	 (0  1  -1  1   0.0)  
	 (-1 1  0   -1  1.0)
         (1  -1 1   -1  0.0)
         (-1 -1 1   1   0.0)))