;;; -*- mode:Scheme -*- ;;;;

;;(declare (usual-integrations))

;;; For SCM
;;(require 'sort)
(define (first x) (car x))
(define (second x) (cadr x))
(define (third x) (caddr x))
;;; End SCM

;;;; GLOBAL VARIABLES

(define *id-tree* '())             ; Assigned to an identification tree
(define *id-verbose* #f)

;;; High-Level interface for classification

;; The actual names of the classes
(define *id-class0* #f)			; set by id-train
(define *id-class1* #f)

(define (id-train data)
  (let ((classes (map car (class-counts data))))
    (cond ((= (length classes) 2)
	   (cond ((or (equal? classes '(0 1))
		      (equal? classes '(0.0 1.0))
		      (equal? classes '(1 0))
		      (equal? classes '(1.0 0.0)))
		  (set! *id-class0* 0)
		  (set! *id-class1* 1))
		 (else
		  (set! *id-class0* (first classes))
		  (set! *id-class1* (second classes)))))
	  (else 
	   (error "Only two classes allowed, but we have" classes))))
  (make-id-tree data)
  'done)

(define (id-classify sample) (identify sample))

;;;; INTERMEDIATE NODE CONSTRUCTOR AND ACCESS FUNCTIONS

(define (make-branching-node dimension
			     threshold
			     left-branch
			     right-branch)
  (list 'branching-node dimension threshold left-branch right-branch))

(define (branching-node? x)
  (and (list? x) (eq? 'branching-node (first x))))

(define (branching-node-dimension x)
  (if (branching-node? x) (list-ref x 1) (error 'accessor "Error in accessor")))

(define (branching-node-threshold x)
  (if (branching-node? x) (list-ref x 2) (error 'accessor "Error in accessor")))

(define (branching-node-left-branch x)
  (if (branching-node? x) (list-ref x 3) (error 'accessor "Error in accessor")))

(define (branching-node-right-branch x)
  (if (branching-node? x) (list-ref x 4) (error 'accessor "Error in accessor")))

;;;; TERMINAL NODE CONSTRUCTOR AND ACCESS FUNCTIONS

(define (make-terminal-node samples identity)
  (list 'terminal-node samples identity))

(define (terminal-node? x)
  (and (list? x) (eq? 'terminal-node (first x))))

(define (terminal-node-samples x)
  (if (terminal-node? x) (list-ref x 1) (error 'accessor "Error in accessor")))

(define (terminal-node-identity x)
  (if (terminal-node? x) (list-ref x 2) (error 'accessor "Error in accessor")))

;;;; ID-TREE CONSTRUCTOR

(define *maximum-depth* 0)		; A global used by MAKE-ID-TREE and
					; MAKE-ID-TREE-AUX

;;;  Purpose:	Supplies arguments to MAKE-ID-TREE-AUX
;;;             Assigns value to *id-tree*.
;;;             Initializes *maximum-depth*.
(define (make-id-tree data)
  (set! *maximum-depth* 0)
  (cond ((and (list? data) (not (null? data)))
	 (set! *id-tree* (make-id-tree-aux data 0))
	 (display* "\nThe maximum depth of the id-tree is " *maximum-depth*))
	(else
	 (display* "\nNo training data available.")))
  (if *draw* 
      (draw-classifier
       id-get-point
       (map (lambda (p) 
	      (make-data-point (list (if (eq? (data-point-class p) *id-class0*) 0 1)) 
			       (data-point-features p)))
	    data)))
  #t)

;;;  Purpose:	Construct a identification id-tree from samples.
;;;  Returns:	A branching node.
(define (make-id-tree-aux samples level)
  ;; Keep track of the maximum depth of recursion, which equals the id-tree depth:
  (set! *maximum-depth* (max *maximum-depth* level))
  (let ((dimension-count (length (data-point-features (first samples))))
	(disorder 10000)		; I.e., infinity
	(dimension 0)
	(threshold 0)
	(left-samples '())
	(right-samples '()))
    ;; Find the dimension and threshold that produces the minimum disorder.
    ;; First, try each dimension:
    (for-each
     (lambda (d)
       (if *id-verbose*
	   (display* "Trying thresholds in dimension " d))
       ;; During which, try each threshold:
       (for-each
	(lambda (t)
	  (let* ((split (score-threshold t d samples))
		 (score (split-score split)))
	    (if *id-verbose*
		(display* "  Threshold = " t ", disorder = " score))
	    ;; If the current score is lower than the best so far,
	    ;; then reset variables accordingly:
	    (cond ((< score disorder)
		   (if *id-verbose*
		       (display* "Dimension " d ": New best disorder --> " score))
		   (set! disorder score)
		   (set! dimension d)
		   (set! threshold t)
		   (set! left-samples (split-left-samples split))
		   (set! right-samples (split-right-samples split))))))
	;; Supply a list of thresholds:
	(compute-thresholds-in-dimension d samples)))
     ;; Supply a list of dimensions:
     (list-dimensions dimension-count))
    ;; At this point, announce the disorder minimizing dimension and threshold:
    (display* "\nSplitting in dimension " dimension
	      " at threshold " threshold
	      " with disorder " disorder)
    (if (and (null? left-samples) (null? right-samples))
	;; could not find a threshold (all the values are the same)
	;; this means that we have contradictory training data.
	(make-terminal-node samples
			    ;; Allows for mixed class terminals
			    (most-common-class samples))
	;; Make a new node, using the discovered dimension and threshold:
	(make-branching-node
	 dimension
	 threshold
	 ;; Also, if the remaining samples in the left branch suggest multiple
	 ;; predictions ...
	 (if (continue-branching? left-samples)
	     ;; then make another branching node on the left side,
	     (make-id-tree-aux left-samples (+ 1 level))
	     ;; otherwise, make a terminal node:
	     (make-terminal-node left-samples
				 ;; Allows for mixed class terminals
				 (most-common-class left-samples)))
	 ;; Repeat for the right branch:
	 (if (continue-branching? right-samples)
	     (make-id-tree-aux right-samples (+ 1 level))
	     (make-terminal-node right-samples
				 ;; Allows for mixed class terminals
				 (most-common-class right-samples)))))))


;;;  Purpose:         Given a number of dimensions, return a list:
;;;  Sample argument: 4
;;;  Sample value:    (0 1 2 3)
(define (list-dimensions count)
  (define (loop n)
    (if (= n count)
	'()
	(cons n (loop (+ 1 n)))))
  (loop 0))

;;;  Purpose:	   Given a list of numbers, return all intermediate numbers:
;;;  Sample argument: (1 2 2 3 3 4 6)
;;;  Sample value:	   (1.5 2.5 3.5 5.0)
(define (compute-thresholds numbers)
  (let ((numbers (remove-duplicates (sort numbers <))))
    ;; Compute average
    (map (lambda (x y) (* 0.5 (+ x y)))     
	 (reverse (rest (reverse numbers)))
	 (rest numbers))))

;;;  Purpose:	Find potential thresholds
;;;  Returns:      A list of thresholds
;;;  Remark:       COMPUTE-THRESHOLDS does the work
(define (compute-thresholds-in-dimension dimension samples)
  (compute-thresholds
   (map (lambda (x) (list-ref (data-point-features x) dimension))
	samples)))

;;;  Purpose:	Compute disorder score for given dimension and threshold.
;;;  Returns:	A list of the score and two lists into which the samples
;;;             are divided by the threshold in the dimension
(define (score-threshold threshold dimension samples)
  (let ((left-samples '())
	(right-samples '()))
    ;; Loop over the samples:
    (for-each
     (lambda (x)
       ;; If the appropriate attribute value is less than the threshold ...
       (if (< (list-ref (data-point-features x) dimension)
	      threshold)
	   ;; Add to variable describing the left branch:
	   (set! left-samples (cons x left-samples))
	   ;; Otherwise, add to variable describing the right branch:
	   (set! right-samples (cons x right-samples))))
     samples)
    ;; Given the way the threshold divides the samples ...
    (make-split
     ;; Return the disorder score:
     (disorder-of-threshold left-samples right-samples)
     ;; Along with the way the samples were divided:
     left-samples
     right-samples)))

;;; SPLITS

(define make-split list)		; Constructor

(define split-score first)		; Getters
(define split-left-samples second)
(define split-right-samples third)

;;;; DISORDER CALCULATIONS

;;; Computes disorder associated with a particular threshold.
(define (disorder-of-threshold left-samples right-samples)
  (let* ((left-count (length left-samples))
	 (right-count (length right-samples))
	 (total-count (+ left-count right-count)))
    (+ (* (/ left-count total-count)
	  (disorder-of-set left-count (map data-point-class left-samples)))
       (* (/ right-count total-count)
	  (disorder-of-set right-count (map data-point-class right-samples)))))
  )

;;;  Purpose: Compute disorder of a set
;;;  Returns: Disorder value
(define (disorder-of-set size set)
  (let* ((elts				; distinct labels
	  (remove-duplicates set))
	 (counts			; count of each label
	  (map (lambda (x) (count x set)) elts))
	 (disorder 
	  (apply + (map (lambda (x) (compute-disorder-term x size))
			counts))))
    (if *id-verbose*
	(display* "   " (map cons elts counts) " -> " disorder))
    disorder
    ))

(define (compute-disorder-term x total)
  (let ((ratio (/ x total)))
    (- (* ratio (log2 ratio)))))

(define (log2 x) (/ (log x) (log 2)))

;;;; DISPLAY ID-TREE

;;;   Purpose:	Supply arguments to show-id-tree-aux.
(define (show-id-tree)
  (show-id-tree-aux *id-tree* 0 #f)
  (newline)
  'done)

;;;  Purpose:	Display a id-tree using indentation to indicate level
;;;  Arguments:	The root node of the id-tree, the level, and the direction

(define (show-id-tree-aux node level branch)
  (cond ((branching-node? node)
	 ;; It's a branching node; describe it:
	 (display* (indent level)
		   ;; Usually BRANCH's value is not #f, but not
		   ;; when SHOW-ID-TREE-AUX is called by SHOW-ID-TREE:
		   (if branch branch "Top")
		   " a split on dimension "
		   (branching-node-dimension node)
		   " [at " (branching-node-threshold node) "]")
	 ;; Recurse left:
	 (show-id-tree-aux
	  (branching-node-left-branch node) (+ 1 level) "Left branch")
	 ;; Recurse right:
	 (show-id-tree-aux
	  (branching-node-right-branch node) (+ 1 level) "Right branch"))
	(else
	 ;; It is a terminal node; describe it:
	 (let ((count (length (terminal-node-samples node))))
	   (display* (indent level)
		     "Answer: " (terminal-node-identity node)
		     " [" count " sample"
		     ;; Get the english correct:
		     (if (> count 1) "s" "")
		     "]"
		     ))))
  #t)

;;;; IDENTIFICATION

;;;  Purpose:	To perform a prediction using an identification tree.
;;;  Argument:	A list of a prediction and various attribute values
;;;  Returns:	The best guess for an unknown's prediction.

(define (identify unknown)
 (let* ((result (find-id-answer (data-point-features unknown) *id-tree* 0))
	(prediction (id-answer-prediction result))
	(supporter-count (id-answer-support result)))
      (display* "The winner is " prediction
	      " according to " supporter-count 
	      " example" (if (= 1 supporter-count) "" "s")
	      ".  Correct is " (data-point-class unknown)
	      "."
	      )
      prediction))

(define (make-id-prediction features)
  (id-answer-prediction 
   (find-id-answer features *id-tree* 0)))

;;;   Purpose:	Find answer using identification tree.
(define (find-id-answer features id-tree level)
  (let* ((dimension (branching-node-dimension id-tree))
	 (threshold (branching-node-threshold id-tree))
	 (projection (list-ref features dimension))
	 (next-node #f))
    ;; Decide which branch wins:
    (if (> projection threshold)
	(set! next-node (branching-node-right-branch id-tree))
	(set! next-node (branching-node-left-branch id-tree)))
    ;;If the winning branch is an branching node ...
    (if (branching-node? next-node)
	;; Then find the closest neighbor by calling FIND-ID-ANSWER recursively:
	(find-id-answer features next-node (+ 1 level))
	;; Otherwise the winning branch is a terminal node:
	(make-id-answer next-node))))

;;; ID-ANSWERS

(define (make-id-answer node)			;Constructor
  (list (terminal-node-identity node)
	(length (terminal-node-samples node))))

(define id-answer-prediction first)		;Getters
(define id-answer-support second)

;;;  Purpose:	See if the samples vary in their class:
;;;  Returns:	#t or #f
;;;  NOTE- this is superseded by the definition below this one...
(define (continue-branching? samples)
  (let ((reference (data-point-class (first samples))))
    ;; Define a testing loop:
    (define (loop others)
      (if (null? others)
	  ;; If no more samples to test, there is no variation:
	  #f
	  ;; If there is at least one, compare with reference;
	  ;; If same, keep going; if not, there is variation:
	  (if (equal? reference (data-point-class (first others)))
	      (loop (rest others))
	      #t)))
    ;; If there is just one sample ...
    (if (null? (rest samples))
	;; there is no variation:
	#f
	;; otherwise, launch the testing loop:
	(loop (rest samples)))))

;;; Simple function that attempts to limit leaves with too small size
;;; (if *min-leaf-size* > 1).

(define *min-leaf-size* 1)

(define (continue-branching? samples)
  (let* ((counts (class-counts samples))
	 (lc (length counts)))
    (if *id-verbose* (display* counts))
    (cond ((= lc 1) #f)			; only one class
	  ((<= (length samples) *min-leaf-size*) #f)
	  ;; 2 classes and one of them is of size min size means stop
	  ((= lc 2) (>= (apply min (map cdr counts)) *min-leaf-size*))
	  ;; else keep going
	  (else #t))))