; File: cohere.lisp
; Purpose: combine coherence programs and test different algorithms
; Programmer: Paul Thagard, 5-95

; variables - see variables.lisp

; EVAL-COHERE compares 4 different algorithms for accepting and rejecting
; elements based on coherence.
; 1. COH-COUNT generates all possible solutions and ranks the ones that
; best maximize the total weight W of constraints.
; 2. COH-POINT-5 is an incremental approximation algorithm that guarantees that at
; least .5 of the achievable W will be achieved.
; 3. COH-POINT-878 is an approximation algorithm that guarantees that at
; least .878 of the achievable W will be achieved. Not implemented here.
; 4. CONNECT-SOLUTION uses a connectionist algorithm to accept and reject elements.
; This function assumes that a network of constraints has already been set up by
; ECHO, DECO, ACME, IMP, or other coherence program.
; 5. GREEDY uses a greedy algorithm to maximize coherence.
; For emotional coherence, HOTCO, only exhaustive and connectionist algorithms are used.

(defun EVAL-COHERE ()
(my-print "=====================")
(my-print "Evaluating coherence for problem " *problem* " in mode " *eval-mode*)
(time (coh-count *eval-mode*)) ; mode is pure, tempered, or foundational
(time (coh-point-5))
(time (greedy *greedy-flips*)) ; use greedy algorithm with # flips
(time (connect-solution))
(my-print "*********************")
(my-print "Elements: " *all-units*)
(my-print "Constraints: " *all-constraints*)
(my-print "Coherence solutions selected for problem: " *problem*)
(my-print "solution %weight %constraints accepted rejected")
(my-print "Exhaustive solution(s):")
(print-solutions *count-solution*)
(my-print "Incremental solution:")
(my-print *point-5-solution*)
(my-print "Greedy solution:")
(my-print *greedy-solution*)
(my-print "Connectionist solution: ")
(my-print *connect-solution*)

)

; PURE, TEMPERED, FOUNDATIONAL

(defun pure ()
(setq *eval-mode* 'pure)
(setq *special-activation* *init-activ*) ; set to .01
)
(defun temp ()
(setq *eval-mode* 'tempered)
(setq *special-activation* *special-register*) ; back to 1
)

(defun found ()
(setq *eval-mode* 'foundational)
(setq *special-activation* *special-register*)
) ; and *all-data* too.

;==================== COH-COUNT ===========================

; COH-COUNT does coherence maximization in the intractably
; exhaustive way. A solution is a list (number %1 %2 accepted-list rejected-list)
; where number is the number of the solution, %1 is the decimal fraction of
; the total weight of constraints satisfied, and %2 is the fraction of
; the total number of constraints satisfied.
; Coherence can be counted in one of three modes:
; Pure: no favored elements.
; Tempered: favored elements linked to special unit, which is accepted.
; Foundational: all favored elements are accepted.

(defun coh-count (mode)
(my-print "Computing coherence using the exhaustive counting algorithm.")
(let ((solutions (gen-solutions mode))
(best nil)
)
(setq *all-constraints* (list-constraints *all-units*))
(setq solutions (coh-score-all solutions))
(print-solutions solutions)
(setq best (best-solution solutions))
(my-print "Best counting solution(s): " (print-solutions best))
(if (and (car solutions)
(= (second (car solutions)) (second (second solutions))) ; tie
)
(my-print "NOTE: " (length best) " solutions are tied.")
)
(setq *count-solution* best)
)
)

; GEN-SOLUTIONS generates all possible partitions of a set of units into
; accepted and rejected. The input *all-units* comes from ECHO or
; other coherence program.

(defun gen-solutions (mode)
(my-print "There are "
(setq *num-solutions* (expt 2 (length *all-units*)))
" pure solutions to " *problem*
)
(my-print "Generating solutions in " mode " mode.")
(if (equal mode 'foundational)
(my-print "There are "
(setq *num-solutions*
(expt 2 (length (set-difference *all-units* (get-favored))))
)
" foundational solutions to " *problem*
)
)
(cond ((> *num-solutions* *max-num-solutions*)
(my-print "TOO MANY POSSIBLE SOLUTIONS.")
nil ; quit if too big
)
(t
; otherwise loop:
(do ((element-lists (powerlist *all-units*) (cdr element-lists))
(result nil)
(count 1 (1+ count))
(favored (get-favored))
(accepted-els nil)
)
((null element-lists) result) ; return
; repeat:
(unless (and (equal mode 'foundational) ; if foundational, ignore solutions that
(not (subsetp favored (car element-lists))) ; don't accept favored elements
)
(push (list count ; number of solution
; accepted elements:
(setq accepted-els
(cond ((equal mode 'pure) (car element-lists))
((equal mode 'tempered)
(cons 'special (car element-lists)) ; special is accepted
)
((equal mode 'foundational) ; favored are accepted
(cons 'special (union favored (car element-lists)))
)
)
)
; rejected elements:
(set-difference *all-units* accepted-els) ; rejected
)
result
)
)
) ; end do
)) ; end cond
)

; GET-FAVORED returns a list of all favored elements, i.e. ones with links to SPECIAL

(defun get-favored ()
(mapcar #'car (links-from 'special))
)

; COH-SCORE-ALL revises a list of solutions of the form (number accepted rejected)
; and returns a ranked list of the form (number %weight %constraints accepted rejected)
; The score is a list of the two %.

(defun coh-score-all (lst)
(setq *weight-of-all-constraints* (sum-constraints))
(do ((input lst (cdr input))
(output nil)
(score nil)
)
((null input) (sort-solutions output)) ; return
; repeat:
(setq score (coh-score (car input)))
(push (list (caar input) ; number
(car score) ; %weight
(second score) ; %constraints
(second (car input)) ; accepted
(third (car input)) ; rejected
)
output
)
)
)

; SORT-SOLUTIONS sorts a list of solutions according to %weight satisfied.

(defun sort-solutions (lst)
(sort lst #'> :key #'second)
)

; LIST-CONSTRAINTS 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). To avoid duplicating constraints (the links are
; symmetrical), it ignores constraints with units already checked.

(defun list-constraints (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 (get (car units) 'links-from))
(setq unit (car link))
(unless (member unit units-done) ; constraint already noted
(push (cons (car units) link) constraints)
)
)
(push (car units) units-done)
)
)
; SUM-CONSTRAINTS calculates the sum of all the weights on the constraints
(defun sum-constraints ()
(apply #'+ (mapcar #'abs-third *all-constraints*))
)

; ABS-THIRD takes the absolute value of the third of a list
; third function doesn't work because a link is a dotted pair
(defun abs-third (lst)
(abs (cddr lst))
)

; COH-SCORE 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)

(defun coh-score (solution)
(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))
)
)
)
(list (roundoff 3 (float (/ weights-satisfied *weight-of-all-constraints*))) ; %weight
(roundoff 3 (float (/ num-satisfied num-constraints))) ; %constraints
)
)
)

; ROUNDOFF

(defun roundoff (places num)
"Rounds NUM to PLACES decimal places."
(cond ((eq places 0) (round num))
(t (/ (round (* num (expt 10.0 places))) (expt 10.0 places)))
)
)

; CONS-SATISFIED checks to see if a constraint is satisfied, where a constraint
; has the forum (unit1 unit2 weight). If the weight is positive, then the units
; should be either both accepted or both rejected. If the weight is negative,
; then one unit should be accepted and the other rejected.
; Number returned is 0 if constraint is not satisfied, and
; the weight on the contrainst unless the constraint is positive with
; both elements accepted and *resolution-impact* is > 1.

(defun cons-satisfied (const acc rej)
(cond ((and (> (cddr const) 0) ; positive constraint affirmatively satisfied
(member (first const) acc)
(member (second const) acc)
)
(* (cddr const) *resonance-impact*) ; add resonance factor
)
((and (> (cddr const) 0) ; positive constraint negatively satisfied
(member (first const) rej)
(member (second const) rej)
)
(cddr const)
)
; else negative constraint:
((and (< (cddr const) 0) ; negative constraint
(or (and (member (first const) acc)
(member (second const) rej)
)
(and (member (first const) rej)
(member (second const) acc)
)
)
)
(abs-third const) ; absolute value of weight
)
(t 0) ; otherwise 0
)
)

; RESON

(defun reson (num)
(setq *resonance-impact* num)

)

; PRINT-SOLUTIONS prints *show-solutions* out neatly

(defun print-solutions (lst)
(do ((solutions lst (cdr solutions))
(count 1 (1+ count))
)
((or (> count *show-solutions*) (null solutions))
(terpri) (my-print "No more than " *show-solutions* " solutions are shown.")
)
(print (car solutions))
)
)

; BEST-SOLUTION prints out the best solution, or the best solutions if there are ties.

(defun best-solution (solns)
(if (null solns) nil
(do ((solutions (cdr solns) (cdr solutions))
(result (list (car solns)))
)
((/= (second (car solns)) (second (car solutions))) ; no tie
(sort (mapcar #'resonate result) #'> :key #'last-el) ; return ordered by resonance
)
; repeat
(push (car solutions) result)
)
)
)

; RESONATE assesses the resonance of a solution, i.e. the extent to which
; it accepts elements that positively constrain each other.
; The resonance becomes the sixth entry in the solution.

(defun resonate (soln)
(do ((accepted (fourth soln) (cdr accepted))
(count 0)
)
((null accepted) (append soln (list count))) ; return
; repeat
(setq count (+ count ; count number of positivley linked accepted units
(length (intersection (linked-to (car accepted) 'positive)
(cdr accepted)
)
)
)
)
)
)

; LINKED-TO returns the units linked to a given unit, selecting either
; positive, negative or all

(defun linked-to (unit selection)
(do ((links (links-from unit) (cdr links))
(result nil)
)
((null links) result) ; return
; repeat
(cond ((and (equal selection 'positive)
(> (cdr (car links)) 0)
)
(push (caar links) result)
)
((and (equal selection 'negative)
(< (cdr (car links)) 0)
)
(push (caar links) result)
)
((equal selection 'all)
(push (caar links) result)
) ; include all units linked
)
)
)

; =============== Karsten's approximating algorithm ===========

; COH-POINT-5 uses a serial algorithm to accept or reject units.

(defun coh-point-5 ()
(my-print "Computing coherence using incremental algorithm.")
(do ((units (randomize *all-units*) (cdr units)) ; put units in random order
(accepted '(special))
(rejected nil)
(unit nil)
(units-done nil)
) ; variables
((null units) ; result
(setq *point-5-solution*
(cons 'incremental (append (coh-score (list 'incremental accepted rejected))
(list accepted rejected)
)
)
)
(my-print "Incremental algorithm chose solution " *point-5-solution*)
)
;repeat:
(setq unit (car units))
(push unit units-done)
(if (>= (coh* (cons unit accepted) rejected units-done)
(coh* accepted (cons unit rejected) units-done)
) ; coherence is greater if unit is accepted
(and (my-print "Accepting " unit)
(push unit accepted)
)
; else reject unit
(and (push unit rejected)
(my-print "Rejecting " unit)
)
)
)
)

; RANDOMIZE rewrites a list in random order

(defun randomize (list)
(do ((lst list )
(num-list nil) ; association list
(result nil)
(selected nil)
(total 0)
)
((null lst) result) ; return
; repeat
(setq num-list (assoc-nums lst)) ; make new association list
(setq total (length lst))
(setq selected (cdr (assoc (random total) num-list))) ; select random pair
(push selected result)
(setq lst (remove selected lst))
)
)

; ASSOC-NUMS produces an association list of (number unit). This is like make-units
; above.

(defun assoc-nums (list)
(do ((lst list (cdr lst))
(result nil)
(num 0 (1+ num))
)
((null lst) result) ; return
(setq result (acons num (car lst) result))
)
)
; COH* calculates the coherence of a set of units partitioned into accepted and
; rejected.

(defun coh* (acc rej all)
(let ((num-satisfied 0)
(constraints (list-constraints all))
(num-constraints 0)
)
(dolist (constraint constraints )

(if (cons-satisfied* constraint acc rej)
(setq num-satisfied (1+ num-satisfied))
)
)
(setq num-constraints (length constraints))
(if (zerop num-constraints) 1 ; else
(float (/ num-satisfied num-constraints))
)
)
)

; CONS-SATISFIED* is like cons-satisfied.

(defun cons-satisfied* (const acc rej)
(if (> (cddr const) 0) ; positive constraint
(or (and (member (first const) acc)
(member (second const) acc)
)
(and (member (first const) rej)
(member (second const) rej)
)
)
; else negative constraint:
(or (and (member (first const) acc)
(member (second const) rej)
)
(and (member (first const) rej)
(member (second const) acc)
)
)
)
)

; RANDOM-UNIT selectes a unit at random from the association list.
(defun random-unit ()
(assoc (random *total-units*) *number-units*)
)

; ================== CONNECTIONIST =========

; CONNECT-SOLUTION translates a settled network into a solution

(defun connect-solution ()
(my-print "Computing coherence using connectionist algorithm.")
(setf (get 'special 'activation) *special-activation*)
(run-hyp-net)
(setq *connect-solution*
(do ((units *all-units* (cdr units))
(acc nil)
(rej nil)
)
((null units)
(cons 'connectionist
(append (coh-score (list 'connect (cons 'special acc) rej))
(list (cons 'special acc) rej); return
)
)
)
(if (accepted (car units))
(push (car units) acc)
; else
(push (car units) rej)
)
)
)
(my-print "Connectionist solution is: " *connect-solution*)
)

; ACCEPTED yields T if a unit's activation is above 0.
; REJECTED-CONNECT yields T if a unit's activation is below 0.

(defun accepted (unit)
(> (get unit 'activation) 0)
)

(defun rejected (unit)
(< (get unit 'activation) 0)
)
; ================= .878 ===================
; Input: list of constraints, each of which is a list:
; (unit1 unit2 weight)
; Negative weights indicate negative constraints.
; Output: list of two lists:
; Accepted (must include the unit SPECIAL)
; Rejected
; Output represents the partition that maximizes the total weight
; of the constraints satisfied (see formal definition)

; =================UTILITIES================
; NAME-UNIT creates a new symbol

(defun name-unit (str num)
(make-symbol (coerce (append (coerce str 'list)
(coerce (princ-to-string num) 'list)
)
'string
)
)
)

(defun pls () (mapcar 'pl *all-units*))

(defun end-at (num)
(setq *max-times* num)
)

(defun put (atom property value)
(setf (get atom property) value)
)
; POWERLIST generates all subsets of a list

(defun powerlist (lst)
(cond ((null lst) nil)
((= (length lst) 1)
(list lst '())
)
(t (append (powerlist (cdr lst))
(push-all (car lst) (powerlist (cdr lst)))
)
)
)
)

; PUSH-ALL(E, LofL) returns a list of lists consisting of lists made by;
; consing E on to each member of LofL

(defun push-all (el list-of-lists)
(do ((lst list-of-lists (cdr lst))
(result nil)
)
((null lst) result) ; return
(push (push el (car lst)) result)
)
)