; File: measure.lisp

; Purpose: algorithms for measuring coherence

; Programmer: Paul Thagard, 2-97

; updated 11-97 to included goodness (harmony)

; COH-SCORE-DUP calculates the coherence scores

; of a set of units partitioned into accepted and

; rejected. It returns a list of two scores

; %weight - the fraction of the total weight satisfied

; %constraints - the fraction of total constraints satisfied

; Input is a triple (number accepted rejected)

; This is just like coh-score except that it does not try to avoid

; counting constraints twice, and it produces a raw sum of constraints

; satified rather than a ratio.

(defun coh-score-dup (solution)

(setq *all-constraints* (list-constraints-dup *all-units*))
; note dup

(let ((num-satisfied 0)

(weights-satisfied 0)

(num-constraints (length *all-constraints*))

(constraint-weight 0)

)

(dolist (constraint *all-constraints*)

(setq constraint-weight

(cons-satisfied constraint (second solution) (third
solution))

)

(if (> constraint-weight 0)

; if constraint is satisfied by the accepted/rejected
partition, then

(and (setq num-satisfied (1+ num-satisfied))

(setq weights-satisfied (+ constraint-weight
weights-satisfied))

)

)

)

weights-satisfied

)

)

; LIST-CONSTRAINTS-DUP generates a list of all constraints
using the links associated

; with each unit (element) in a list. Each constraint has the
structure

; (unit1 unit2 weight). It is just like list-constraints in cohere.lisp,

; except that it does [not?] avoid counting constraint twice.

(defun list-constraints-dup (list-of-units)

(do ((units list-of-units (cdr units))

(constraints nil)

(unit nil)

(units-done nil)

) ; variables

((null units) constraints) ; result

; repeat:

(dolist (link (links-from (car units)))

(setq unit (car link))

;(unless (member unit units-done) ; unless clause deleted

(push (cons (car units) link) constraints)

)

(push (car units) units-done)

)

)

; COH-SCORE-SUBSET calculates the coherence of a subset of
elements, relative

; to a partition into accepted and rejected. Like coh-score-dup,
it

; can count constraints twice, e.g. when both e1 and e2 are in
the subset

; and there is an positive constraint between them and both are
accepted.

; Unlike coh-score which returns ratios, it returns a raw score
of constraints

; satisfied.

(defun coh-score-subset (elements solution)

(let ((num-satisfied 0)

(weights-satisfied 0)

(num-constraints (length *all-constraints*))

(constraint-weight 0)

)

(dolist (constraint (list-constraints-dup elements))

(setq constraint-weight

(cons-satisfied constraint (second solution) (third
solution))

)

(if (> constraint-weight 0)

; if constraint is satisfied by the accepted/rejected
partition, then

(and (setq num-satisfied (1+ num-satisfied))

(setq weights-satisfied (+ constraint-weight
weights-satisfied))

)

)

)

weights-satisfied

)

)

;================GOODNESS===================

; This is originally from run.l in old ACME.

; GOODNESS is a measure of how well constraints are satisfied..

; Returns 1 if no units. Need to divide by 2 since all

; links get counted twice.

(defun goodness (list-of-units)

(do ((units list-of-units (cdr units))

(value 0)

)

;exit:

((null units) (if (null list-of-units) 1 (/ value 2)))

;repeat:

(setq value

(+ value

(how-good-unit (car units) (get (car units) 'links-from))

)

)

)

)

; MEAN-GOODNESS cancels the effect of large networks

(defun mean-goodness (units) (/ (goodness units) (length units)))

; ****************************************************

; HOW-GOOD-UNIT calculates the goodness of a particular unit

; with respect to its associates. List-pairs is now a

; list of dotted pairs (unit . weight).

(defun how-good-unit (unit list-pairs)

(do ((pairs list-pairs (cdr pairs))

(value 0)

)

((null pairs) value)

(setq value (+ value

(* (cdar pairs) ; weight

(get unit 'activation)

(get (caar pairs) 'activation)

)

)

)

)

)

; Note: what this does is up goodness if the activation of units

; with high weights between them is high.

(defun gu (unit)

(my-print '"Goodness of " unit '" is "

(how-good-unit unit (get unit 'links-from))

)

)

(defun gum () (mapcar #'gu *all-units*))