(defun prism (n tbl &key (verbose t)) (labels ((trainer (tbl cautions egs) (prism-trainer tbl verbose)) (tester (tbl cautions model one) (cons (isa one tbl) (prism-tester one model)))) (n-way n tbl :verbose verbose :trainer #'trainer :tester #'tester))) (defmacro n (class feature range x) `(gethash `(,class ,feature ,range) ,x 0)) (defun prism-index (tbl &optional (x (make-hash-table :test 'equal)) (ranges (make-hash-table)) (classes (make-hash-table))) (let ((classi (table-class tbl))) (dolist (eg (table-egs tbl)) (let ((class (nth classi eg))) (incf (gethash class classes 0)) (doitems (range feature eg) (incf (n class feature range x)) (let ((old (gethash feature ranges))) (unless (member range old) (push range (gethash feature ranges))))))))) (defstruct rule if then ) (defstruct (rule-info (:include rule)) missed) (defun prism-tester (eg rules &optional (not-found #\?)) (dolist (rule rules not-found) (let ((tmp t)) (doitems (test i (rule-if rule)) (setf tmp (and tmp (eql (nth (first test) eg) (rest test))))) (if tmp (return-from prism-tester (rule-then rule)))))) (defun prism-trainer (tbl &optional verbose rules last-missed ) (let* ((r (prism-rule tbl)) (missed (rule-info-missed r)) (nmissed (length missed))) (cond ( (null missed) (reverse rules)) (t (setf (rule-info-missed r) nmissed) (push r rules) (if verbose (format t "if ~a then ~a (~a)~%" (rule-if r) (rule-then r) nmissed)) (if last-missed (if (< nmissed last-missed) (prism-trainer (table-copy tbl missed) verbose rules nmissed) (reverse rules)) (prism-trainer (table-copy tbl missed) verbose rules nmissed))))))