Initial Transfer to Common-lisp.net repository

;; $Id$

;;

;; bayescl - A Common Lisp Bayesian Filtering Library

;; (c) 2003 Anthony J Ventimiglia.

;;

;; This library is free software; you can redistribute it and/or

;; modify it under the terms of the terms of the Lisp Lesser GNU

;; Public License, known as the LLGPL

;; 

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

;;

;; You should have received a copy of the Lisp Lesser General Public

;; License along with this library; if not, please see

;; http://opensource.franz.com/preamble.html.

;;

;; email: aventimiglia@common-lisp.net

;; HomePage: http://common-lisp.net/project/bayescl

(in-package #:net.common-lisp.bayescl)

(defvar *minimum-score* 1/10000)

(defclass bucket ()

  ((name :reader bucket-name

	 :type (or symbol string)

	 :initarg :name

	 :documentation "An identifying name")

   (map :accessor bucket-map

	:type hash-table

	:initarg :map)

   (token-count :accessor bucket-count

		:type (unsigned-byte 32)

		:initform 0))

  (:documentation "Used to store and retrieve token data for use by a filter object"))

(defun make-bucket (name &optional (test 'eq))

  "This is the public way to create Bayesian buckets, Do not use

MAKE-INSTANCE, since it does not initialize the internal hash table."

  (declare (type (or symbol string) name)

	   (type symbol test))

  (make-instance 'bucket :name name

		 :map (make-hash-table :test test)))

(defmethod add-token ((self bucket) token &optional (count 1))

  (declare (type bucket self)

	   (type (unsigned-byte 32) count))

  "Add COUNT TOKENs to SELF bucket"

  (let ((map (bucket-map self)))

    (setf (gethash token map) (+ count (gethash token map 0))

          (bucket-count self) (+ count (bucket-count self)))))

(defmethod score-token ((self bucket) token)

  (let ((total (bucket-count self)))

    (if (zerop total) *minimum-score*

      (/ (gethash token (bucket-map self) 0) total))))

(defun save-bucket (bucket &optional directory)

  "Saves BUCKET for later loading using the LOAD method. If DIRECTORY

is given save to that directory, otherwise saves to the current

working directory. The Bucket will be saved with the the bucket's name

with the extension"

  (let ((filename (if directory (merge-pathnames directory

						 (bucket-name bucket))

		    (bucket-name bucket))))

    (with-open-file (stream filename :direction :output)

	(format stream "(~S ~S)~%" (bucket-name bucket)

		(hash-table-test (bucket-map bucket)))

	(format stream "~S~%"

		(with-hash-table-iterator (next-token (bucket-map bucket))

		     (loop for item = (multiple-value-list (next-token))

			   while (car item)

			   collect (list (cadr item) (caddr item))))))))

(defun load-bucket (pathname)

  "Load and return a SAVEd bucket"

  (let (bucket

	(eof (gensym)))

    (with-open-file (stream pathname :direction :input)

	 (let ((bucket-info (read stream nil eof)))

	   ;; Need error checking, this assumes the file is the right format

	   (setq bucket (make-bucket (car bucket-info) (cadr bucket-info))))

	 (loop for item in (read stream nil eof)

	       do (add-token bucket (car item) (cadr item))))

    bucket))

;; $Id$

;;

;; bayescl - A Common Lisp Bayesian Filtering Library

;; (c) 2003 Anthony J Ventimiglia.

;;

;; This library is free software; you can redistribute it and/or

;; modify it under the terms of the terms of the Lisp Lesser GNU

;; Public License, known as the LLGPL

;; 

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

;;

;; You should have received a copy of the Lisp Lesser General Public

;; License along with this library; if not, please see

;; http://opensource.franz.com/preamble.html.

;;

;; email: aventimiglia@common-lisp.net

;; HomePage: http://common-lisp.net/project/bayescl

(in-package :net.common-lisp.bayescl)

(defclass filter ()

  ((buckets :accessor buckets

	    :type list

	    :initarg :buckets

	    :documentation "A list of buckets used for filtering")))

(defun make-filter (buckets)

  (if (< (length buckets) 2) 'error

    (make-instance 'filter :buckets buckets)))

(defmethod score-token ((self filter) token)

  "Returns an a list of scores for each bucket in the filter"

  (let ((bucket-ct (length (buckets self))))

    (let (; Prior probabilities

	  (P[Hx] (make-array bucket-ct	

			       :element-type 'rational

			       :initial-element (/ 1 bucket-ct)))

	  ; Conditional probabilities

	  (P[D/Hx] (make-array bucket-ct :element-type 'rational

			       :initial-contents

			       (loop for bucket in (buckets self)

				     collect (score-token bucket token)))))

      (let ((dividend (apply #'+

			     (loop for i from 0 to (1- bucket-ct)

				   collect (* (aref P[Hx] i)

					      (aref P[D/Hx] i))))))

	;; Return all posterior probabilities

	(loop for i from 0 to (1- bucket-ct)

	      collect (if (zerop dividend) *minimum-score*

			  (/ (* (aref P[Hx] i) (aref P[D/Hx] i))

			     dividend)))))))

 No newline at end of file

;; $Id$

;;

;; bayescl - A Common Lisp Bayesian Filtering Library

;; (c) 2003 Anthony J Ventimiglia.

;;

;; This library is free software; you can redistribute it and/or

;; modify it under the terms of the terms of the Lisp Lesser GNU

;; Public License, known as the LLGPL

;; 

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

;;

;; You should have received a copy of the Lisp Lesser General Public

;; License along with this library; if not, please see

;; http://opensource.franz.com/preamble.html.

;;

;; email: aventimiglia@common-lisp.net

;; HomePage: http://common-lisp.net/project/bayescl

(in-package #:cl-user)

(defpackage :net.common-lisp.bayescl

  (:nicknames #:bayescl #:bayes)

  (:use #:cl)

  (:export #:make-bucket #:bucket-name #:add-token #:score-token #:save-bucket

	   #:load-bucket #:make-filter #:*minimum-score*))

 No newline at end of file