;;;; 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
;;;; To run on multi-category problems like SOYBEAN-DATA, after loading the data
;;;; you must encode instances of all categories into bit strings using
;;;; ENCODE-CATEGORY-INSTANCES (e.g. (encode-category-instances soybean-categories))
;;;; and then partition encoded examples into training and test sets using
;;;; SEPARATE-INSTANCES and then use PERCEPTRON-CATEGORIES to do the
;;;; learning and TEST-CATEGORIES to test the learned perceptron.

;;;; Uses functions defined in the files: BINARY-ENCODER and TESTER

;;;; 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.


(defvar *trace-perceptron* nil)     ; produces trace of weight updates if T.
(defvar *perceptron* nil)           ; Stores the final learned perceptron.
(defvar *domains*)                  ; List of domains (possible value list) for 
                                    ; each feature

(setf test1 '((+ (0 1 0))           ; Simple testing example
	      (+ (1 0 1))
	      (+ (1 1 1))
	      (- (0 0 1))))

(setf test2 '((- (0 0))             ; Infamous XOR example
	      (+ (0 1))
	      (+ (1 0))
	      (- (1 1))))

(defmacro trace-print (test-var &rest format-form)
  ;; Print using the format string only is test-var is nonNIL
  `(if ,test-var
       (format t ,@format-form)))


(defun perceptron-m (examples &optional short-encode-flag
		     (threshold 0) (delta 1))
  ;;; Perceptron for examples with multi-valued features. First encodes
  ;;; examples into binary features and then runs standard perceptron.
  ;;; Uses n bits to encode n valued features unless short-encode-flag
  ;;; is set in which case uses log(n) bits.

  (format t "~%Examples: ~A" examples)
  (perceptron (convert-to-bits examples short-encode-flag) threshold delta))


(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. *perceptron* is set to the learned perceptron which
  ;;; is of the form (<weights> <threshold>) where weights is a vector
  ;;; (arrary) of the feature weights

  (let* ((num-features (length (second (first examples))))
	 (weights (make-array (list num-features)    ; define weight vector
			      :element-type 'number  
			      :initial-element 0))   ; weights initalized to 0
	 (all-correct nil) (i 0) (trial-num 0))
    (when *trace-perceptron* (print-perceptron weights threshold))
    (loop (if all-correct (return nil))        ; Loop until all examples are correctly
	  (setf all-correct t)                 ; classified.
	  (dolist (example examples)           ; Each trial look at all examples
	    (if (compute-perceptron-output (second example) weights threshold)
		(cond ((eq (first example) `-)  ; if network says + but its - example
		       (trace-print *trace-perceptron* "~%~%Classifies ~A wrong" example)
		       (setf all-correct nil)
		       (incf threshold 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))
			 (when (eq feature-value 1)
			   (incf (aref weights i) (- delta))
			   (trace-print *trace-perceptron*
					"~%Decrementing weight for feature ~A" (+ i 1)))
			 (incf i)))
		      (t (trace-print *trace-perceptron* "~%~%Classifies ~A right" example)))
		(cond ((eq (first example) '+)  ; if network says - but its +
		       (trace-print *trace-perceptron* "~%~%Classifies ~A wrong" example)
		       (setf all-correct nil)
		       (incf threshold (- 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))
			 (when (eq feature-value 1)
			   (incf (aref weights i) delta)
			   (trace-print *trace-perceptron*
					"~%Incrementing weight for feature ~A" (+ i 1)))
			 (incf i)))
		      (t (trace-print *trace-perceptron* "~%~%Classifies ~A right" example)))))
	  (incf trial-num)                     ; Keep track of the number of trials
	  (when *trace-perceptron* (print-perceptron weights threshold)))
    (format t "~%Trials: ~A" trial-num)
    (unless *trace-perceptron* (print-perceptron weights threshold))
    (setf *perceptron* (list weights threshold))))   ; Return the final perceptron


(defun compute-perceptron-output (feature-values weights threshold)
  ;;; 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))
    ;; Simply sum the weight*input for all of the features
    ;; and return T if greater than threshold.
    (dolist (feature-value feature-values)
      (when (eq feature-value 1)
	(incf sum (aref weights i)))
      (incf i))
    (> sum threshold)))


(defun print-perceptron (weights threshold)
  ;; Printout the current weight vector and threshold

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


;;;; ==========================================================================================
;;;; Functions for running and testing a single concept
;;;; ==========================================================================================

(defun perceptron-test (examples train# &optional short-encode-flag)
  ;;; Run and test on the examples by using the first train# examples
  ;;; to train and the remaining to test
 (setf examples (convert-to-bits examples short-encode-flag))
 (let ((training-examples (subseq examples 0 train#))
       (testing-examples  (subseq examples train#))
       (start-time (get-internal-run-time)))
   (perceptron training-examples)
   (format t "~%~%Run time: ~,2Fs" (seconds-since start-time))
   (perceptron-test-examples testing-examples)))

(defun perceptron-test-examples (examples)
  ;;; Test on the given set of examples and report results
  (let ((correct# 0))
    (dolist (example examples)
      (let ((output (compute-perceptron-output (second example) (first *perceptron*)
					       (second *perceptron*))))
	  (if (or (and (eq (first example) '+) output)
		  (and (eq (first example) '-) (null output)))
	      (incf correct#))))
    (format t "~%~%Percentage correct: ~A" (round (* 100 (/ correct# (length examples)))))))


;;;; ==========================================================================================
;;;; The following functions are for multiple concept (category) problems like the soybean data
;;;; ==========================================================================================

(defun make-examples (pos-instances neg-instances)
  ;;; Converts lists of positive and negative instances into a list of examples
  ;;; suitable for PERCEPTRON.

  (append (mapcar #'(lambda (instance) (list '+ instance)) pos-instances)
	  (mapcar #'(lambda (instance) (list '- instance)) neg-instances)))



(defun perceptron-categories (category-list &optional (threshold 0) (delta 1))
  ;;; Perceptron for multiple concept learning problems. The arguement category-list
  ;;; should be a list of atoms which represent names of individual categories. A list of
  ;;; instances for learning should be stored on the LEARN-INSTANCES property of each
  ;;; category name. A single concept learning trial is run for each category in which the
  ;;; instances of that category are positive examples and instances of all other categories
  ;;; are negative examples.  If convergence is reached for a given category, then the
  ;;; learned perceptron (i.e. (<weights> <threshold>)) is stored on the PERCEPTRON
  ;;; property of the category name.

  (setf *instance-tester* #'perceptron-test-instance)
  (let ((start-time (get-internal-run-time)))
    (dolist (category-name category-list)
      (format t "~%~%Category: ~A" category-name)
      (perceptron (make-examples (get category-name 'learn-instances)
				 (mapcan #'(lambda (a) (copy-list (get a 'learn-instances)))
					 (remove category-name category-list)))
		  threshold delta)
      (setf (get category-name 'PERCEPTRON) *perceptron*))
    (format t "~%~%Run time: ~,3Fs" (seconds-since start-time)))
  (perceptron-test-categories category-list))

(defun perceptron-test-instance (instance categories)
  ;;; Given an instance and a list of category names returns the subset of these categories
  ;;; which it is determined that the instance belongs to (i.e. for which the learned
  ;;; perceptron for that category returns T.

   (let ((member-categories nil))
     (dolist (category categories member-categories)
      (if (compute-perceptron-output instance (first (get category 'PERCEPTRON))
				     (second (get category 'PERCEPTRON)))
	  (push category member-categories)))))

(defun perceptron-test-categories (categories &optional learn-instances?)
  ;;; To be used after *-CATEGORIES in order to test the generalizations learned 
  ;;; on a  set of new instances stored under the TEST-INSTANCES property of each category
  ;;; name in categories.  Reports % correct for each category and overall % correct.

  (let ((percent-sum 0)(percent 0))
    (dolist (category categories)
      (format t "~%~%Testing ~A instances" category)
      (let ((answers (mapcar #'(lambda (instance)
				 (funcall *instance-tester* instance categories))
			     (get category (if learn-instances?
					       'learn-instances
					       'test-instances))))
	    (count 0))
	(format t "~%~A" answers)
	(dolist (answer answers) (if (and (eq (first answer) category)(null (rest answer)))
				     (incf count)))
	(setf percent (* 100 (/ count (length answers))))
	(incf percent-sum percent)
	(format t "~%Percent correct: ~,2F" percent)))
    (format t "~%~%Total percent correct: ~,2F" (/ percent-sum (length categories)))))


;;;; ==========================================================================================
;;;; General utility functions
;;;; ==========================================================================================

(defun seconds-since (time)
   ;;; Return seconds elapsed since given time (initially set by get-internal-run-time)
  (/ (- (get-internal-run-time) time)
     internal-time-units-per-second))

(defun separate-instances (categories num-learn-instances)
  ;;; Separates a list of instances for a set of categories into learning and testing
  ;;; instances to facilitate experimentation in preparation for using VS-CATEGORIES
  ;;; and TEST-CATEGORIES.  The variable categories should be bound to a list of
  ;;; category names whose values are a list of instances of that category. The first
  ;;; num-learn-instances of these instances are stored on the LEARN-INSTANCES property
  ;;; to be used for learning and the rest are stored on TEST-INSTANCES for testing.
  
  (dolist (category categories)
    (setf (get category 'learn-instances) 
	  (subseq (eval category) 0 num-learn-instances))
    (setf (get category 'test-instances)
	  (subseq (eval category) num-learn-instances (length (eval category))))))