;
;  
;  This version specialize to alternate learning and testing on *every*
;  instance
;  This is MULTI-TEST: after each learning point, try 10 testing instances.
;
; WARNING: this is mostly just a quick way of hacking together an experiment
; for testing prediction. 
; 
;  This needs to have the classify module already loaded.


(require "classweb")
(require "struct")
(require "node-compute")
(require "node-atts")
(require "read-inst")
(require "get-time")
(require "globals")

(require "loop" "/ci/ci/worldm/bin/loop")
(use-package "LOOP")


; (proclaim '(optimize (safety 0) (speed 3)))


#|*****************************************************************************

  T O P   L E V E L   P R O C E D U R E   A N D   U S E R  I N T E R F A C E

*****************************************************************************|#

#|----------------------------------------------------------------15/Jun/88----
   Function  - run
       
   Inputs    -> input file, optional output file
       
   Returns   -> the final tree.
-------------------------------------------------------------------KThompso--|#


(defun run (&optional
	           (infile nil)
		   (num-atts 0)            ;number of attributes in input set.
	    &key 
		   (outfile nil) 
		   (testsetfile nil)
		   (breaker nil)
                   (debug nil)
		   (att-type :nominal)
		   (att-names nil)
		   (print-function :short)
		   (print-each nil)
                   (tree nil)
                   (learning t)
                   (pred-atts *PRED-ATTS*))

  (unless infile
    (usage)
    (return-from run (values)))
  (setq *LEARNING* learning)
  (setq *PRED-ATTS* pred-atts)
  (setup-node-printer print-function)

  (let ((input-stream (open infile :direction :input))
	(outfile-name                            
	   (if (eq outfile t)                    
	      (concatenate 'string infile ".out")
	      outfile)))

                               ;*setup output files
    (setf *GLOBAL-DEBUG* debug)
    (if testsetfile
          (setq *TEST-SET* (readtestset testsetfile num-atts)))
    (setq
       *OUTPUT-STREAM*
       (if outfile
	 (open outfile-name :direction :output :if-exists :new-version)
	 *standard-output*))

    (print-out-banner infile outfile-name)

    (setf *TYPE-LIST*
       (case att-type
	   (:nominal (make-list num-atts :initial-element :nominal))
	   (:numeric (make-list num-atts :initial-element :numeric))
	   (:mixed (read-att-type input-stream num-atts))))

			       ;* error-check att-names
    (when att-names
      (assert (and (= num-atts (length att-names))
		   (equal (remove-duplicates att-names) att-names))
	   (att-names)
	   "List of att-names ~A ~% is invalid -- must be length ~
            ~D and have no duplicates~%:r to continue" att-names num-atts))

                               ;* create att-names
    (setq *ATT-NAMES* (or att-names *ATT-NAMES* (make-att-names num-atts)))

			       ;* loop through remaining instances
    (setf tree 
      (main-loop print-each breaker *ATT-NAMES* input-stream outfile num-atts tree))

			       ;* finished with instances
    (close input-stream)
    (let ((str (concatenate 'string
		      "********************** Finished with instances at "
		      (get-time))))
      (pr-out "~%~A~2%" str)
      (if outfile (format t "~%~A~2%" str)))
    (if outfile (pr-out "~%~A~%" tree))    ;don't if to term; will be returned.
    (when outfile (close *OUTPUT-STREAM*))

    tree                        ;return the tree.
))

#|----------------------------------------------------------------15/Jun/88----
   Function  - MAIN-LOOP

   Inputs    -> print-each
                breaker
                *ATT-NAMES*
                input-stream
                outfile
                num-atts
                tree
       
   Returns   -> the tree resulting from looping through the instances. Or, 
        if prediction is on, a list of attributes and predicted values.

   Actions   -> Here is the basic incremental loop: an instance is read
        (into the global property list associated with 'obj), and it is 
        incorporated into the hierarchy of concepts. Note that the first
        instance is handled slightly differently.  -JHG 3/13/89
-------------------------------------------------------------------KThompso--|#

(defun main-loop (print-each breaker att-names input-stream outfile 
		  num-atts tree)

  (let ((HALT (not (readinstance input-stream num-atts)))
	(instance-cntr 1)
         predicted actual score)

  (if (null tree) ; the tree is sometimes pre-set by the user.
      (progn
        (setq tree (create-node att-names))
        (setq HALT (not (readinstance input-stream num-atts)))
	(setq instance-cntr (1+ instance-cntr)))
  )

  (loop repeat 10 do
      (setq *LEARNING* t)
	   
      (pr-out "~v%**** INCORPORATING new instance ~4D    ~A~%" 
	      (if print-each 3 1) instance-cntr (given-name 'OBJ))
      (if outfile
	  (format t "new instance~4D    ~5A~%" 
		  instance-cntr (given-name 'OBJ)))

      (setq tree (classify tree att-names 0))

      (if print-each (pr-out "~%~A" tree))
      (if breaker (break "stopping in run"))

      (setf (symbol-plist 'obj) nil)

      (setq instance-cntr (1+ instance-cntr))
      (setq HALT (not (readinstance input-stream num-atts)))

   finally
      (setq *LEARNING* nil)
      (if *TEST-SET*
      (loop for testinstance in *TEST-SET*
	    with tenscore = 0 do
        (readinst-test testinstance)
        (loop for att in *PRED-ATTS*
		 collect (get 'OBJ att) into saved
		 do (putprop 'OBJ '? att)
		 finally
		    (setq actual saved)
	)
        (setq predicted
               (cons (given-name 'obj) 
                     (classify tree att-names 0))
        )
        (setq tenscore (+ (compare predicted actual) tenscore))
      finally
        (setq score (cons (/ (float tenscore) (length *TEST-SET*)) score))
        (pr-out "score over test instances: ~4,3F~%" (car score))
      ))
      (pr-out "~%~A" tree)
      (return (reverse score))
  )
))

;*****************************************************************************
;*-----------------------------------------------------------------07/Jul/89-*
;*   ROUTINES FOR PREDICTION
;*
;*             (some of these are special purpose...)
;*--------------------------------------------------------------------JHG----*
;*****************************************************************************


#|----------------------------------------------------------------14/Feb/89----
   Function - Predicted-values
   Input - node that the test case most closely matches. (Also uses 
           *PRED-ATTS*)
   Output - a list of the predicted attributes in the given node.
            The variable *PRED-ATTS* specifies the attributes.
-------------------------------------------------------------------Allen-----|#

(defun predicted-values (node)

  (loop for att-name in *PRED-ATTS*
        for att = (find-att att-name (node-atts node)) 
        if att collect att into answer
        else do (pr-out "can't predict about attribute ~A~%" att-name)
   finally 
        (return answer)
  )
)


;*------------------------------------------------------------------09/Jun/89-*
;*  Function  - COMPARE
;* 
;*  Inputs    -> the predicted attributes and the actual ones
;* 
;*  Returns   -> The absolute difference.
;*
;* WARNING: this is special purpose hacking...
;*---------------------------------------------------------------------JHG----*

(defun compare (pred actual)

  (let ((tmp
   (abs (- (car actual) (best-val (cadr pred))))
      ))
  (pr-out "error ~6,2F" tmp)
   tmp)
)

;*------------------------------------------------------------------10/Apr/89-*
;*  Function  - FIND-ATT
;* 
;*  Inputs    -> an attribute name, and a list of attributes.
;* 
;*  Returns   -> the matching attribute from the list.
;*---------------------------------------------------------------------JHG----*

(defun find-att (attr-name att-list)
   
   (loop for attr in att-list 
         if (eq (basic-att-name attr) attr-name)
         return attr
))

;*------------------------------------------------------------------18/Apr/89-*
;*  Function  - BEST-VAL
;* 
;*  Inputs    -> an attribute
;* 
;*  Returns   -> The best (predicted) value for that attribute. For
;*      numeric attributes, this is the mean; for symbolic attributes,
;*      the value with the highest count.
;*      Currently, this is only used by Halt-test.
;*---------------------------------------------------------------------JHG----*

(defun best-val (child-att)

  (if (numericp child-att)
                          ; for CLASSIT, return the mean.
      (/ (NumAtt-sum child-att) (NumAtt-acount child-att))
                          ; for COBWEB, return the highest count value.
      (loop for pair in (NomAtt-values child-att)
            with best-cnt = 0 and value 
            if (> (cdr pair) best-cnt) do
              (setq value (car pair))
	      (setq best-cnt (cdr pair))
            finally 
              (return value))
  )
)

(defmacro numericp (attr)
  `(eq (basic-att-key ,attr) :numeric))

;*------------------------------------------------------------------07/Jul/89-*
;*  Function  - READTESTSET
;* 
;*  Inputs    -> filename and number of attributes
;* 
;*  Returns   -> a list of instances, each of which is a list of values
;*     read from the file "filename".
;*---------------------------------------------------------------------JHG----*

(defun readtestset (filename num-atts)

  (let ((fd (open filename :direction :input))
	 one-inst)
  (loop until (null (car (setq one-inst
			 (loop repeat (1+ num-atts)
			       collect (read fd nil nil)))))
	collect one-inst into result
  finally
        (close fd)
	(return result)
  ))
)

;*------------------------------------------------------------------07/Jul/89-*
;*  Function  - READINST-TEST
;* 
;*  Inputs    -> an instance as a list of values (also uses *ATT-NAMES*).
;* 
;*  Actions   -> sets the property list associated with 'OBJ to the 
;*     appropriate attribute - value pairs. 
;*   NOTICE: this is very different from readinstance, which reads instances
;*     from a file. Here, the test set if fixed, and this should be much 
;*     quicker (no file I/O).
;*---------------------------------------------------------------------JHG----*

(defun readinst-test (inst)

   (loop for value in inst
	 for name in *ATT-NAMES* do
	   (putprop 'obj value name)
      finally
         (putprop 'obj (car (last inst)) 'given)
   )
)