;;; -*- Mode: LISP; Package: COMMON-LISP-USER; Base: 10; Syntax: Common-lisp -*-

;;;**************************************
;;;
;;;  File : >marshall>autoclass>iris>iris-data-mods.lisp
;
;    Functions: PRINT-IRIS-CLASSES
;		PRINT-IRIS-CLASSES-3
;		IRIS-FIRST-PAGE-HEADER
;		IRIS-PAGINATE
;		OUTPUT-IRIS-PAGE-HEADERS
;		GET-IRIS-CLASSES 
;		
;;;
;;;**********************************
;;; 


(defmacro IRIS-AREF (datum-array &optional
			 (header-field '(case-number)))
  "accessor macro for IRIS datum array - element of *base-data* array"
  (let* ((field-assoc-list '((case-number . 0)))
	 (index (rest (assoc header-field field-assoc-list))))
    `(aref ,datum-array ,index)))

; (iris-aref (elt *base-data* 0) case-num)
;;;
;;;********************************** 
;;;  

(defun PRINT-IRIS-CLASSES (file &optional (data *base-data*) (weights *curr-wts*))
  " Sorts the elements of get-iris-classes
   by AutoClass max-class and case number"
  (with-open-file (out-str file :direction :output)
;;  (let ((out-str t))
   (iris-first-page-header out-str *n-data* *current-db* (part-total-mml *partition*) *current-results*)
    (format out-str "~%~18@T  SORTED BY AUTOCLASS CLASSIFICATION.")
    (let ((iris-classes nil) (key-element-p t))
      (setf iris-classes (get-iris-classes data weights))
      (setf iris-classes			; compute sort key & insert at front
	    (map 'list #'(lambda (elt)
			   (let ((key (+ (* 250000000
					     (first (second elt)))	; AutoClass class
					  (* (first (first elt)) 10000))))
			     (cons key elt)))
		 iris-classes))
      (iris-paginate out-str (stable-sort iris-classes #'< :key #'first) key-element-p))))
;;;
;;;********************************** 
;;;  

(defun PRINT-IRIS-CLASSES-3 (file &optional (data *base-data*) (weights *curr-wts*))
  " Writes the elements of get-iris-classes
   sorted by case-num (*base-data* is already in this order)"
  (let ((key-element-p t))
    (with-open-file (out-str file :direction :output)
;;    (let ((out-str t))
      (iris-first-page-header out-str *n-data* *current-db* (part-total-mml *partition*) *current-results*)
      (format out-str "~%~18@TSORTED BY CASE NUMBER.")
      (iris-paginate out-str (get-iris-classes data weights) (not key-element-p)))))
;;;
;;;********************************** 
;;;  

(defun IRIS-FIRST-PAGE-HEADER (out-str n-data current-db part-total-mml current-results)
  "output header on first page"
  (format out-str
	    "~%~12@TAutoClass classifications for the ~A Obserevations~%~12@Tin ~A, ~%~12@Tusing the ~A MML classification ~%~12@Tin ~A."
	    n-data current-db part-total-mml current-results))
;;;
;;;********************************** 
;;;  

(defun IRIS-PAGINATE (out-str list-of-lines key-element-p)
  "write output with headers at top of each page"
  (output-iris-page-headers out-str t)
  (let ((cnt 0) (line-cnt 62)
	(format-string
	  "~%~15@T~{~7D~} ~20@T~{~{(~@2A ~4,2F)~}~}"))
    (dolist (elt list-of-lines)
      (let ((arg1 (first elt)) (arg2 (rest elt)))
	(if key-element-p
	    (setf arg1 (second elt) arg2 (rest (rest elt))))
	(setf cnt (+ cnt (length arg2)))
	(format out-str format-string arg1 arg2))
      (when (>= cnt line-cnt)
	(setf cnt 0)
	(setf line-cnt 70)
	(format out-str "~|")
	(output-iris-page-headers out-str nil)))))
;;; 
;;;********************************** 
;;;  

(defun OUTPUT-IRIS-PAGE-HEADERS (out-str page-1-p)
  "write out page headers for sort listings"
  (let ((new-line "~%"))
    (if page-1-p
	(setf new-line "~2%"))
    (format out-str (concatenate
		      'string new-line
		      "~15@T    Case                    AutoClass"))
    (format out-str "~%~15@T    Number                    Class ~2%")))
;;;
;;;********************************** 
;;;  

(defun GET-IRIS-CLASSES (&optional (data *base-data*) (weights *curr-wts*))
  "collects data from *base-data* along with
   with the ordered set of (class wt)
   pairs for which wt > .1 as: ((h1 h2 ... h-N) (c1 w1) (c2 w2) ...)."
  (let* ((N-classes (length (elt weights 0)))
	 (temp (make-array N-classes))
	 (out-list ()))
    (do* ((index 0 (1+ index)))
	 ((= index *n-data*))
;;	 ((= index 50))
      (let ((collector ()) (wt ())
	    (datum (aref data index))
	    (wts (aref weights index)))
	(setq temp (sort (replace temp wts) '>))
	(dotimes (n N-classes)
	  (setq wt (elt temp n))
	  (if (> wt .1)  
	      (push (list (position (position wt wts) *class-wt-ordering*)	; class
			  wt)
		    collector)
	      (return)  )  )
	(setf out-list (cons (cons (list (iris-aref datum case-number))
				   (nreverse collector)) out-list))))
    (nreverse out-list)))
;;;
;;;**********************************
;;;