;(defpackage nb   (:export setting learn) (:use common-lisp)) (in-package nb)

(defstruct about
  (what "abc")
  (why "a simple bayes classifier (using n-bins for discretization)")
  (when 2006)
  (who "Tim Menzies (tim@menzies.us)")
  (copyright "GPL 2.1")
  (copyright-long "
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; version 2.1.

This program 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
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this program; if not write to the Free Software
Foundation Inc. 51 Franklin St Fifth Floor Boston MA  02110-1301  USA"))

(defstruct option long short help action args)
(defstruct setting
  (about (make-about))
  (train  "train.csv")
  (test   "test.csv")
  (k 2)
  (m 1)
  (bins 10)
  (demo 0)
  help
  (flags (list
	  (make-option :short "-X" :long "--example"
		       :help "run an example" 
		       :action 'setting-demo :args 1)	 
	  (make-option :short "-T" :long "--test"
		       :help "test data" 
		       :action 'setting-test :args 1)	 
	  (make-option :short "-b" :long "--bins"
		       :help "number of discretization bins"
		       :action 'setting-bins :args 1)	 
	  (make-option :short "-c" :long "--copyright"
		       :help "show copyright" 
		       :action 'copyright )	 
	  (make-option :short "-h" :long "--help"
		       :help "show help" 
		       :action 'options)	 
	  (make-option :short "-m"
		       :help "set m-estimate" 
		       :action 'setting-m :args 1)	 
	  (make-option :short "-k" :long "--laplace"
		       :help "set laplace estimate" 
		       :action 'setting-k :args 1)
	  (make-option :short "-t" :long "--training"
		       :help "training data" 
		       :action 'setting-train :args 1)
	   )))

(defun about (&optional (x (make-setting)))
  (let* ((about (setting-about x))
	 (who   (about-who about))
	 (why    (about-why about))
	 (when  (about-when about))
	 (what  (about-what about))
	 (copyright (about-copyright about)))
    (format nil "~a : ~a~%(C)~a ~a by ~a" what why when  copyright  who))
)
;; (defun usages (&optional (x (make-setting)))
;;   (mapcar #'(lambda (flag)
;; 	      (let* ((arg-str  (if (option-args flag) "X" " "))
;; 		     (long (option-long flag))
;; 		     (long-str (if long 
;; 				   (format nil " ~~a  ~a" long arg-str) 
;; 				   ""))
;; 		     )
;; 		(format nil "  ~a  ~a   ~a            ~a~%" 
;; 			(option-short flag) arg-str
;; 			long-str 
;; 			(option-help flag))))
;; 	  (setting-flags x))))

;;;; Util
(defun %the-command-line () ext:*args*
)
(defun option-for (x option)
  (or (equalp x (option-long option))
      (equalp x (option-short option)))
)
(defun do-args (&key
		(settings (make-setting))
		(args     (%the-command-line)))
  (if (not args)
      settings
      (let* ((next         (pop args))
	     (command-p    (find-if #'(lambda(x) (option-for next x))
				    (setting-flags settings)))
	     (command      (and command-p (option-action command-p)))
	     (argument     (and command   (option-args   command-p) (pop args))))
	(cond ((argument
		(eval `(setf (,command ,settings)
			(read-from-string  ,argument))))
	       (command-p
		(funcall command settings))))
	(do-args :settings settings 
		 :args     args)))
)
(defun with-stream (x p) 
  (if (probe-file x)
      (with-open-file (stream x :direction :input)
	(reads stream p))
      (with-input-from-string (stream x)
	(reads stream p)))
)
(defun reads (s p &optional (n 1)) 
  (let ((next (read s nil :EndOfFile)))
    (unless (eq next :EndOfFile)
	(funcall p next n)
	(reads s p (+ 1 n))))
)
(defmacro o (x) 
  `(progn (format t "[~a]=[~a]~%" (quote ,x) ,x) ,x)
)

;;;; demos
(defun demo (&optional (n 0))
  (case n
    (0 (main))
    (1 (demo1))
    (2 (demo2))
    (3 (demo3))
    (4 (demo4))
    (5 (demo5))
    (otherwise (error "unknown demo: ~a~%" n))))

(defun demo1 ()
  (let ((opt (make-setting)))
    (with-stream (setting-train opt) 
      #'(lambda (thing n )
	  (format t "~a ~a ~%" thing n)))))

(defun demo2 ()
  (with-stream "'#(name  age  shoesize)
                '#(tim  23   10)
                '#(jane 41  22)"
    #'(lambda (thing n )
	(format t "~a ~a ~%" thing n))))

(defun demo3 () 
  (let ((opt (make-setting))) 
    (do-args :settings opt 
	     :args '("-t" "23" "-b" "23" "-lll"))))
(defun demo4 () 
  (let ((opt (make-setting))) 
    (do-args :settings opt :args '())))
(defun demo5 () 
  (print (do-args)))


(setf *data* "
(           Age SpectaclePrescription Astigmatism TearProductionRate RecommendedLenses)
  ; -------------- --------------------- ----------- ------------------ -----------------
(         Young                 Myope          No            Reduced              None)
(         Young                 Myope          No             Normal              Soft)
(         Young                 Myope         Yes            Reduced              None)
(         Young                 Myope         Yes             Normal              Hard)
(         Young          Hypermetrope          No            Reduced              None)
(         Young          Hypermetrope          No             Normal              Soft)
(         Young          Hypermetrope         Yes            Reduced              None)
(         Young          Hypermetrope         Yes             Normal              Hard)
(Pre-presbyopic                 Myope          No            Reduced              None)
(Pre-presbyopic                 Myope          No             Normal              Soft)
(Pre-presbyopic                 Myope         Yes            Reduced              None)
(Pre-presbyopic                 Myope         Yes             Normal              Hard)
(Pre-presbyopic          Hypermetrope          No            Reduced              None)
(Pre-presbyopic          Hypermetrope          No             Normal              Soft)
(Pre-presbyopic          Hypermetrope         Yes            Reduced              None)
(Pre-presbyopic          Hypermetrope         Yes             Normal              None)
(    Presbyopic                 Myope          No            Reduced              None)
(    Presbyopic                 Myope          No             Normal              None)
(    Presbyopic                 Myope         Yes            Reduced              None)
(    Presbyopic                 Myope         Yes             Normal              Hard)
(    Presbyopic          Hypermetrope          No            Reduced              None)
(    Presbyopic          Hypermetrope          No             Normal              Soft)
(    Presbyopic          Hypermetrope         Yes            Reduced              None)
(    Presbyopic          Hypermetrope         Yes             Normal              None)"
)

(defstruct meta name counts)

(defstruct wme cols width)

(defun prism (s &optional (n 1) (wme (make-wme)))
  (let ((next (read s nil :EndOfFile)))
    (if (eq next :EndOfFile)
	wme
	(prism1 s next n wme))))

(defun prism1 (s next n wme)
  (if (eq n 1)
      (prism-meta next wme)
      (prism-data next wme))
  (prism s (+ n 1) wme))

(defun prism-meta (cols wme)
  (setf (wme-width wme) 
	(length cols))
  (setf	(wme-cols wme)
	(mapcar 
	 #'(lambda (col)
	     (make-meta 
	      :name col 
	      :counts (make-hash-table)))	 
	 cols)))

(defun prism-data (cols wme) 
  (flet ((prism-data1 (hash attr)
	   (incf (gethash attr hash 0))
	   hash))
    (let ((class (car (last cols))))
      (if (not (eq (wme-width wme) (length cols)))
	(error "wrong number of fields in ~a" cols))
      (mapc  #'(lambda (meta col)
		 (let* ((hash (meta-counts meta)))
		   (setf (gethash class hash)
			 (prism-data1
			  (gethash class hash (make-hash-table))
			  col))))
	     (wme-cols wme) 
	     cols))))

(defun demo6 ()
  (with-input-from-string 
      (s *data*)
    (prism s)))