micro-icp.lisp

(in-package "ICP")
;;------------------------------------------------------------------------------
;; 
;; File:    MICRO-ICP.LISP 
;; Created: 10/20/94
;; Author:  Will Fitzgerald
;; 
;; Description: Micro version of indexed concept parsing.
;; 
;;------------------------------------------------------------------------------

(eval-when (load eval compile)
  (unless (find-package :icp)
    (make-package :icp)))

(in-package :icp)

(use-package :frames)
(use-package :dmap)
(use-package :tables)
(use-package :log)

(export '(def-assoc clear-icp-memory icp information-value
           best-results *icp-results* print-icp-log m-reference-concept m-root
           score target-concept index-concepts ticp))

;;------------------------------------------------------------------------------
;; Data structures for index concepts, target concepts, and their relationships
;;------------------------------------------------------------------------------

;; an index set is a target concept and its associated index concepts

(defclass index-set ()
  ((target-concept :initarg :target-concept :accessor target-concept)
   (indices :initarg :indices :accessor indices)))

(defmethod print-object ((self index-set) stream)
    (print-unreadable-object (self stream :type t :identity t)
      (format stream "~s "  (target-concept self))
      (format stream "~s"(indices self))))

;; Data tables:
;; whether an object is a target concept;
;; from an index to all of the index sets it participates in;
;; from an index to all of the target concepts for which it is associated;
;; from an index to the number of target concepts it's associated with (for
;; calculating information value)

(deftable target-concept-p)
(deftable index->index-sets)
(deftable index->target-concepts)
(deftable index->target-concepts-cardinality)

(defun target-concept-cardinality ()
  "How many target concepts -- for calculating information value"
  (hash-table-count (target-concept-p)))

;;------------------------------------------------------------------------------
;; Installation of index sets.
;;------------------------------------------------------------------------------

(defmethod equal-instance-p ((index-set1 index-set) (index-set2 index-set))
  (and (eql (target-concept index-set1)
            (target-concept index-set2))
       (equal (indices index-set1)
              (indices index-set2))))

(defun set-index->target-concepts-cardinality (index)
  (if (index->target-concepts-cardinality index)
    (incf (index->target-concepts-cardinality index))
    (setf (index->target-concepts-cardinality index) 1)))

(defmethod install ((index-set index-set))
  (with-slots (target-concept indices) index-set
  (dolist (index indices)
    (unless (frame-of index)
      (warn "~S does not name a frame." index))
    (unless (member index (index->target-concepts index))      
      (push target-concept (index->target-concepts index))
      (set-index->target-concepts-cardinality index))
    (pushnew index-set (index->index-sets index) :test 'equal-instance-p))))

(defun add-index-set (target-concept indices)
  (setf (target-concept-p target-concept) t)
  (install (make-instance 'index-set 
             :target-concept target-concept
             :indices indices))
  target-concept)

(defmacro def-assoc (name &rest indices)
  `(progn
     (define-frame ',name '(m-reference-concept) nil)
     (add-index-set ',name ',indices)))


;;------------------------------------------------------------------------------
;; Class for result from the parser
;;------------------------------------------------------------------------------

(defclass icp-result ()
    ((score :initarg :score :initform 0 :accessor score)
     (target-concept :initarg :target-concept :initform nil :accessor target-concept)
     (index-concepts :initarg :index-concepts :initform nil :accessor index-concepts)))

(defmethod print-object ((self icp-result) stream)
  (with-slots (score target-concept index-concepts) self
    (print-unreadable-object (self stream :type t :identity t)
      (format stream "~4,2F ~S ~S" score target-concept index-concepts))))

(defun make-icp-result (score target-concept index-concepts)
  (make-instance 'icp-result
    :score score
    :target-concept target-concept
    :index-concepts index-concepts))

(defmethod score ((result null)) 0)

(defmethod target-concept ((result null)) nil)

(defmethod index-concepts ((result null)) nil)
  
;;------------------------------------------------------------------------------
;; ICP proper
;;------------------------------------------------------------------------------

(defvar *icp-results* () "A place to store the results of the parser")

(defun icp (words &optional (match-fn 'words->indices))
  (setf *icp-results*
        (remove-duplicates 
         (sort (score-index-sets (find-indices words match-fn))
               #'> :key #'score)
         :key 'target-concept :from-end t))
  (first *icp-results*))

(defun best-results (&optional n)
  (if n (first-n *icp-results* n) *icp-results*))

(defun find-indices (words match-fn)
  (funcall match-fn words))

(defun score-index-sets (found-indices)
  (loop for index-set in (candidate-index-sets found-indices)
        collect (make-icp-result
                 (index-set-score index-set found-indices)
                 (target-concept index-set)
                 (indices index-set))))

;;------------------------------------------------------------------------------
;; Find all candidate index sets from the index concepts seen
;;------------------------------------------------------------------------------

(defun candidate-index-sets (found-indices)
  (remove-duplicates
   (loop for index in (all-absts-in found-indices)
         append (index->index-sets index))))

(defun all-absts-in (concepts)
  (remove-duplicates 
   (loop for concept in concepts
         append (all-abstractions (frame-of concept)))))


;;------------------------------------------------------------------------------
;; Calculate the scores for each candidate index set
;; The real work is done by the appraiser functions. INDEX-SET-SCORE
;; just adds them up.  Appraisers with no votes are not called.
;;------------------------------------------------------------------------------

        
(defun index-set-score (index-set found-indices)
  (let ((score 0))
    (map-table #'(lambda (appraiser votes)
                   (unless (zerop votes)
                     (incf score
                           (call-appraiser appraiser 
                                           index-set found-indices))))
               (appraiser-votes))
    (log:record-log (target-concept index-set)
                    "Total score for target ~S  = ~5,3F"
                    (target-concept index-set)  score)
    (log:record-log (target-concept index-set)
                    "Associated index concepts: ~S~%~&~75,,,'-<~>~%" 
                    (indices index-set))
    score))

(defun call-appraiser (appraiser index-set found-indices)
  (let ((score 
         (* (funcall appraiser index-set found-indices)
            (appraiser-weight appraiser))))
    (log:record-log (target-concept index-set)
                    "~A score = ~5,3F (Raw score * ~5,3F weighting)~%"
                    appraiser score (appraiser-weight appraiser))
    score))
  
;;------------------------------------------------------------------------------
;; Information value functions
;;------------------------------------------------------------------------------

(defun probability-of-index (index)
  (let ((cardinality (index->target-concepts-cardinality index)))
    (if (null cardinality) least-positive-short-float 
        (/ cardinality 
           (target-concept-cardinality)))))

(defun information-value (index)
  (- (log (probability-of-index index) 2)))

;;------------------------------------------------------------------------------
;; Appraisers
;;------------------------------------------------------------------------------

;;; An appraiser is a function assigned a non-zero number of votes.
;;; The function should take an index-set and an found-indices and return
;;; a score between 0 and 1 inclusive. The score is then multiplied by
;;; the appraiser's weight, which is the number of votes associated
;;; with the appraiser divided by the total number of votes for all
;;; appraisers. 

;;; (ASSIGN-VOTES name [votes]) => name
;;;   Assigns the given number of votes to an appraiser. If no votes
;;;   are specified, 1 is assumed.

;;; Bookkeeping:
;;;
;;; As votes are assigned, we keep track of the total votes, to speed
;;; up calculating relative weights at parse time.

(deftable appraiser-votes)

(defvar *total-votes* 0
  "Total number of votes for appraisers.")

(defun clear-appraisers ()
  (clear-table (appraiser-votes))
  (setf *total-votes* 0))

(defun assign-votes (name &optional (votes 1))
  (setf (appraiser-votes name) votes)
  (tally-votes)
  name)

(defun tally-votes ()
  (setq *total-votes* 0)
  (map-table #'(lambda (name votes)
                 (declare (ignore name))
                 (incf *total-votes* votes))
             (appraiser-votes)))

(defun appraiser-weight (appraiser)
  (/ (appraiser-votes appraiser) *total-votes*))

;;------------------------------------------------------------------------------
;; Default appraiser functions
;;------------------------------------------------------------------------------

;;; Each of these appraisers compares a given index set against the
;;; pool of indices actually seen in the input:
;;; 
;;;   PREDICTED-SCORE -- how many predicted items were seen?
;;;   UNPREDICTED-SCORE -- how many items were not predicted?
;;;   UNSEEN-SCORE -- how many predicted items were not seen?


(defun predicted-score (index-set found-indices)
  (let* ((predicted (indices index-set))
         (predicted-items (predicted-items found-indices predicted))
         (score
          (/ (summed-value (target-concept index-set) predicted-items 'identity)
             (summed-value (target-concept index-set) predicted 'identity))))
    (log:record-log  (target-concept index-set)
                     "Predicted raw score = ~5,3F (successfully predicted / predicted)"
                     score)
    score))

(defun unpredicted-score (index-set found-indices)
  (let* ((predicted (indices index-set))
         (unpredicted-items (unpredicted-items found-indices predicted))
         (score
          (- 1 (/ (summed-value (target-concept index-set) unpredicted-items 'identity)
                  (summed-value (target-concept index-set) found-indices 'identity)))))
    (log:record-log  (target-concept index-set)
                     "Unpredicted raw score = ~5,3F (1 - unpredicted / seen)"
                     score)
    score))

(defun unseen-score (index-set found-indices)
  (let* ((predicted (indices index-set))
         (unseen-items (unseen-items found-indices predicted))
         (score
          (- 1 (/ (summed-value (target-concept index-set) unseen-items 'identity)
                  (summed-value (target-concept index-set) predicted 'identity)))))
    (log:record-log  (target-concept index-set)
                     "Unseen raw score = ~5,3F (1 - unseen / predicted)"
                     score)
    score))
 
(defun remove-parts (l)
  "remove index concepts that form part of another index concept"
  (remove-if #'(lambda (item) (member item l :test 'part-of))
             l))

(defun predicted-items (seen-set predicted-set)
  (intersection predicted-set seen-set :test 'abst-or-whole-of))

(defun unpredicted-items (seen-set predicted-set)
  (set-difference seen-set predicted-set :test 'spec-or-part-of))

(defun unpredicted-items (seen-set predicted-set)
  (set-difference (remove-parts seen-set) predicted-set :test 'specp))

(defun unseen-items (seen-set predicted-set)
  (set-difference predicted-set seen-set :test 'abst-or-whole-of))


(defun summed-value (base predicted-set fn)
  (let ((val
         (loop for item in predicted-set
               sum (funcall fn (information-value item)))))
    (log:record-log base "Summed value of ~S~:[ using ~A~;~*~] => ~5,3F"
        predicted-set (eql fn 'identity) fn val)
    val))


;;------------------------------------------------------------------------------
;; This is an example of how to write an expection appraiser, although this 
;; isn't used by default.
;;------------------------------------------------------------------------------ 

(defvar *expectations* nil 
  "A list of target concepts predicted")

(defun add-expectation (target-concept)
  (pushnew target-concept *expectations*))

(defun clear-expectations ()
  (setf *expectations* nil))

(defun set-expectations (target-concepts)
  (setf *expectations* target-concepts))

(defun expected-p (target-concept)
  (and (member target-concept *expectations* ) t))

(defun expected-score (index-set found-indices)
  (declare (ignore found-indices))
  (let* ((target-concept (target-concept index-set))
         (found (expected-p target-concept))
         (score (if found 1 0)))
    (log:record-log  target-concept
                     "Expected raw score = ~5,3F (1 if expected, 0 otherwise)"
                     score)
    score))

;;------------------------------------------------------------------------------
;; Weight the appraisers
;;------------------------------------------------------------------------------

(clear-appraisers)

(assign-votes 'predicted-score 2)
(assign-votes 'unpredicted-score)
(assign-votes 'unseen-score)

;;------------------------------------------------------------------------------
;; Clearing memory
;;------------------------------------------------------------------------------

(defun clear-icp-memory ()
  (clear-frame-memory)
  (clear-predictions :all)
  (clear-table (target-concept-p))
  (clear-table (index->target-concepts))
  (clear-table (index->index-sets))
  (clear-table (index->target-concepts-cardinality))
  t)

;;------------------------------------------------------------------------------
;; A DMAP-based index concept recognizer
;;------------------------------------------------------------------------------

(defun words->indices (sent)
  (reset-parser)
  (let (concepts)
    (setf (call-backs 'm-root)
          (list #'(lambda (item start end) 
                    (record-log 'DMAP "DMAP referenced ~S from ~S" 
                                item (subseq sent (1- start) end))
                    (push item concepts))))
    (parse sent)
    (setf concepts (mapcar #'frames::name concepts))
    (record-log 'WORDS->INDICES 
                "~S ~%produced the index pool ~S~%~75,,,'=<~>~%" 
                sent concepts)
    concepts))

;;------------------------------------------------------------------------------
;; Logging  & testing functions
;;------------------------------------------------------------------------------

(defun first-n (sequence n)
  (loop for i from 1 to n
        for el in sequence 
        collect el))

(defun print-icp-log (&optional (n 7) (stream *standard-output*))
  (print-log 'WORDs->INDICES stream)
  (loop for result in (first-n *icp-results* n) 
        doing
        (print-log (target-concept result) stream)))

(defmacro ticp (&rest words)
  `(with-logging
     (icp ',words)
     (print-icp-log)))