;;;; PERCEPTRON is a simple system for learning from examples which uses the
;;;; perceptron learning procedure to adjust a set of weights on a single
;;;; linear threshold unit until all of the training examples are correctly
;;;; classified. The perceptron convergence theorem assures that the system
;;;; will halt if the examples are linearly separable but if not the system
;;;; may not halt.  The file BINARY-ENCODER contains the functions needed
;;;; for converting feature vector examples to bit strings

;;;; Copyright (c) 1988 by Raymond Joseph Mooney. This program may be freely
;;;; copied, used, or modified provided that this copyright notice is included
;;;; in each copy of this code and parts thereof.

(sys:compile-load-if "wimberly:mooney.data;data-utilities")
(sys:compile-load-if "wimberly:mooney.ml;binary-encoder")

(setf (get 'perceptron 'expect-training-error) t) ; Not guarantee training set
 correctness
(setf (get 'perceptron 'parameters) '(*tie-breaker* *max-perceptron-epochs*
 *loop-check* *one-bit-for-two-values*))

(defparameter *trace-perceptron* nil "Produces trace of weight updates if T")
(defparameter *trace-epoch*      nil "Just prints epoch number")
(defparameter *trace-multi-perceptron* nil "Prints output for each category")
(defparameter *max-perceptron-epochs* 5000 "Maximum number of epochs of
 training")
(defparameter *loop-check* nil             "Checks for repeated weight vector
 and terminates")

(defstruct (perceptron (:print-function print-perceptron))
  weights threshold)

(defun train-perceptron (examples)
  (make-encoding)
  (setf examples  (mapcar #'convert-to-binary-example (make-ordered-examples
 examples nil)))
  (setf examples (eliminate-conflicting-examples examples))
  (if (pos-neg?)
      (perceptron examples)
      (multi-perceptron examples)))

(defun test-perceptron (example perceptron)
  (setf example (convert-to-binary-example (make-ordered-example example nil)))
  (if (perceptron-p perceptron)
      (if (compute-perceptron-output example perceptron) (positive-category)
 (negative-category))
      (multi-perceptron-output example perceptron)))

(defun eliminate-conflicting-examples  (examples)
  (let ((conflicts-list (find-conflicting-examples examples))
	discards)
    (dolist (conflicts conflicts-list)
      (let ((majority-category (majority-category conflicts)))
	(dolist (example conflicts)
	  (unless (eq (first example) majority-category)
	    (push example discards)))))
    (set-difference examples discards)))

(defun majority-category (examples)
  (let (class-counts class-count)
    (dolist (example examples)
      (setf class-count (assoc (first example) class-counts))
      (if class-count
	  (incf (cdr class-count))
	  (push (cons (first example) 1) class-counts)))
    (maximum-label class-counts *categories*)))

(defun perceptron (examples &optional (threshold 0) (delta 1))
  ;;; Apply perceptron learning algorithm to the examples.  Iterates
  ;;; through all of the examples adjusting weights when system is wrong
  ;;; until all examples are classified correctly. Threshold and delta
  ;;; define the initial threshold of the perceptron and the learning
  ;;; increment.

  (let* ((num-features (if (first examples)
			   (length (second (first examples)))
			   (length *binary-feature-names*)))
	 (weights (make-array (list num-features)    ; define weight vector
			      :element-type 'number
			      :initial-element 0))   ; weights initalized to 0
	 (pos-category (positive-category)) (neg-category (negative-category))
	 (all-correct nil) (i 0) (epoch-num 0) previous-weights
	 (perceptron (make-perceptron :weights weights :threshold threshold)))
    (trace-print *trace-perceptron* "~%~A" perceptron)
    ;; Loop until all examples are correct or exceed max epochs or detect loop
    (loop (cond (all-correct (trace-print *trace-perceptron* "~%~%Converged.")
 (return perceptron))
		((eql epoch-num *max-perceptron-epochs*)
		 (trace-print *trace-perceptron* "~%~%Exceeded maximum allowed epochs.")
		 (return perceptron))
		(*loop-check*
		 (let ((save (cons (perceptron-threshold perceptron) (copy-seq weights))))
		   (if (member save previous-weights :test #'equalp)
		     (progn (trace-print *trace-perceptron* "~%~%Loop detected, not linearly separable")
			    (return perceptron))
		     (push save  previous-weights)))))
	  (incf epoch-num)        ; Keep track of the number of trials
	  (trace-print *trace-perceptron* "~%~%Epoch ~D:" epoch-num)
	  (trace-print *trace-epoch* " ~D," epoch-num)
	  (setf all-correct t)
	  (dolist (example examples)           ; Each trial look at all examples
	    (if (compute-perceptron-output example perceptron)
		(cond ((eq (first example) neg-category)  ; if network says + but its - example
		       (trace-print *trace-perceptron* "~%~%Classifies ~A wrong" example)
		       (setf all-correct nil)
		       (incf (perceptron-threshold perceptron) delta)	; Then increase threshold to make +
						                        ; classification harder
		       ;; and decrement weights for features present in the example
		       (setf i 0)
		       (dolist (feature-value (second example))
			 (unless (zerop feature-value)
			   (incf (aref weights i) (- (* delta feature-value)))
			   (trace-print *trace-perceptron*
					"~%Decrementing weight of feature ~A by ~,2F"
					(binary-feature-name i) (* delta feature-value)))
			 (incf i)))
		      (t (trace-print *trace-perceptron* "~%~%Classifies ~A right" example)))
		(cond ((eq (first example) pos-category)  ; if network says - but its +
		       (trace-print *trace-perceptron* "~%~%Classifies ~A wrong" example)
		       (setf all-correct nil)
		       (incf (perceptron-threshold perceptron) (- delta))   ; Then decrease threshold to make +
            						                    ; classification easier
		       ;; and increment weights for features present in the example
		       (setf i 0)
		       (dolist (feature-value (second example))
			 (unless (zerop feature-value)
			   (incf (aref weights i) (* delta feature-value))
			   (trace-print *trace-perceptron*
					"~%Incrementing weight of feature ~A by ~,2F"
					(binary-feature-name i) (* delta feature-value)))
			 (incf i)))
		      (t (trace-print *trace-perceptron* "~%~%Classifies ~A right" example)))))
	  (trace-print *trace-perceptron* "~%~A" perceptron))))


(defun compute-perceptron-output (example perceptron &optional analog)
  ;;; Determine value of perceptron for the given input. Return T or NIL
  ;;; instead of 0 or 1 to simply tests

  (let ((sum 0) (i 0)(weights (perceptron-weights perceptron)))
    ;; Simply sum the weight*input for all of the features
    ;; and return T if greater than threshold.
    (dolist (feature-value (second example))
	(incf sum (* feature-value (aref weights i)))
	(incf i))
    (if analog
	(- sum (perceptron-threshold perceptron))
	(> sum (perceptron-threshold perceptron)))))


(defun print-perceptron (perceptron &optional (stream t) depth)
  ;; Printout the current weight vector and threshold

  (format t "~%Weights:")
  (dotimes (i (length (perceptron-weights perceptron)))
    (format t " ~A" (aref (perceptron-weights perceptron) i)))
  (format t "~%Threshold: ~A" (perceptron-threshold perceptron)))

;;;---------------------------------------------------------------------------
;;;       Multi-category perceptron (1 perceptron for each category)
;;;---------------------------------------------------------------------------

(defun multi-perceptron (examples)
  (dolist (cat *categories*)
    (setf (get cat 'training-examples) nil))
  (dolist (example examples)
    (push (rest example) (get (first example) 'training-examples)))
  (mapcar #'(lambda (cat)
	      (trace-print *trace-multi-perceptron* "~%~%~A:" cat)
	      (let* ((training-examples
		       (append (category-examples cat '+)
			       (mapcan #'(lambda (other-cat)
					   (category-examples other-cat '-))
				       (remove cat *categories*))))
		     (*categories* '(+ -))
		     (perceptron (perceptron training-examples)))
		(trace-print *trace-multi-perceptron* "~A" perceptron)
		(cons cat perceptron)))
	  *categories*))

(defun category-examples (cat label)
  (mapcar #'(lambda (inst) (cons label inst)) (get cat 'training-examples)))


(defun multi-perceptron-output (example perceptron-alist)
  "Pick category with maximum output above threshold"
  (let (output max-categories (max-output most-negative-fixnum))
    (trace-print *trace-perceptron* "~%")
    (dolist (pair perceptron-alist)
      (setf output (compute-perceptron-output example (cdr pair) t))
      (trace-print *trace-perceptron* "~%~A: ~A" (first pair) output)
      (cond ((> output max-output)
	     (setf max-output output)
	     (setf max-categories (list (first pair))))
	    ((= output max-output)
	     (push (first pair) max-categories))))
    (if (eq *tie-breaker* 'random)
	(pick-one max-categories)
	(dolist (cat *categories*)
	  (when (member cat max-categories)
	    (return cat))))))