#| 
   Metric-tree routines.
   
   Author: Dmitri Hrapof <yavannadil@yahoo.com>
   Version: 0.4
   Copyright (C) 2004, 2005 Dmitri Hrapof

This file is part of Geiriadur.

Geiriadur is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

Geiriadur is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with Geiriadur; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  
|#

(declaim (optimize (speed 3)))

(defpackage coeden
   (:use common-lisp)
   (:export metric-tree 
	    burkhard-keller-tree 
	    vantage-point-tree
	    inoculate gather grow tree-fruit))

(in-package coeden)

(defgeneric grow (tree lst metric &key key))
(defgeneric inoculate (tree obj metric &key key))
(defgeneric gather (tree obj metric r &key key))
(defgeneric tree-fruit (tree))

(defmethod grow (tree lst metric &key (key #'identity))
  (declare (ignore tree metric key))
  lst)

(defmethod inoculate (tree obj metric &key (key #'identity))
  (declare (ignore metric key))
  (push obj tree))

(defmethod gather (tree obj metric r &key (key #'identity))
  (remove-if 
   #'(lambda (y) (> y r))
   (mapcar #'(lambda (l) (list (funcall metric (funcall key l) obj) l)) tree)
   :key #'car))

(defmethod tree-fruit (tree)
  tree)

(defclass metric-tree ()
  ((fruit :initarg :fruit :initform nil) 
   (branches :initform nil)))

(defmethod tree-fruit ((tree metric-tree))
  (slot-value tree 'fruit))

(defclass burkhard-keller-tree (metric-tree) ())

(defmethod inoculate ((tree burkhard-keller-tree) obj metric 
		      &key (key #'identity))
  (with-slots 
   (fruit branches) tree
   (let ((d (funcall metric (funcall key fruit) (funcall key obj))))
     ;(if (zerop d) tree
       (let ((p (assoc d branches)))
	 (if p (inoculate (cdr p) obj metric :key key)
	   (let ((n (make-instance 'burkhard-keller-tree :fruit obj)))
	     (setf branches (acons d n branches))
	      n))))));)

(defmethod grow ((tree burkhard-keller-tree) lst metric &key (key #'identity))
  (if lst
      (with-slots 
       (fruit) tree 
       (setf fruit (nth (random (length lst)) lst))
       (dolist (obj (remove fruit lst))
	 (inoculate tree obj metric :key key))))
  tree)

(defmethod gather ((tree burkhard-keller-tree) obj metric r
			  &key (key #'identity))
  (with-slots 
   (fruit branches) tree
   (let ((d (funcall metric (funcall key fruit) obj)))
     (apply 
      #'append
      (if (<= d r) (list (list d tree)))
      (mapcar
       #'(lambda (p) (gather (cdr p) obj metric r :key key))
       (remove-if-not 
	#'(lambda (y) (and (>= y (- d r)) (<= y (+ d r))))
	branches :key #'car))))))

(defclass vantage-point-tree (metric-tree) 
  ((maxd :initform 0 :initarg :maxd) 
   (mind :initform 0 :initarg :mind) 
   (degree :initform 2 :initarg :degree)))

(defun separate (lst len num ret)
  (if (zerop len) (reverse ret)
    (let ((s (min num len)))
      (separate (subseq lst s) (- len s) num (push (subseq lst 0 s) ret))))) 

(defmethod grow ((tree vantage-point-tree) lst metric &key (key #'identity))
  (if lst
      (with-slots
       (fruit branches maxd mind degree) tree
       (let* ((len (length lst))
	      (root (nth (random len) lst))
	      (rst (sort 
		    (mapcar
		     #'(lambda (obj) (list (funcall metric (funcall key root) 
						    (funcall key obj)) obj))
		     (remove root lst)) #'< :key #'car))
	      (bst (separate rst (1- len) (ceiling (1- len) degree) ())))
	 (setf fruit root
	       branches
	       (mapcar
		#'(lambda (l)
		    (let ((1st (mapcar #'car l))
			  (2nd (mapcar #'second l)))
		      (grow (make-instance 
			     'vantage-point-tree
			     :degree degree
			     :maxd (if 1st (apply #'max 1st) 0)
			     :mind (if 2nd (apply #'min 1st) 0))
			    2nd metric :key key)))
		bst)))))
    tree)

(defmethod gather ((tree vantage-point-tree) obj metric r
			  &key (key #'identity))
  (with-slots 
   (fruit branches maxd mind ) tree
   (let ((d (funcall metric (funcall key fruit) obj)))
     (if (<= d r) (list (list d tree))
       (apply 
	#'append
	(mapcar
	 #'(lambda (p) (gather p obj metric r :key key))
	 (remove-if-not 
	  #'(lambda (b) 
	      (with-slots 
	       (maxd mind fruit) b
	       (let ((d-r (- d r)) (d+r (+ d r)))
		 (or (and (>= maxd d-r) (<= maxd d+r))
		     (and (>= mind d-r) (<= mind d+r))
		     (and (>= mind d-r) (<= maxd d+r))
		     (and (<= mind d-r) (>= maxd d+r))))))
	  branches)))))))