; File: greedy.lisp

; Purpose: greedy algorithm for maximizing coherence;

; idea due to Toby Donaldson based on GSAT

; algorithm of Selman et al., Proc. AAAI-92.

; Programmer: Paul Thagard, 2-96

; GREEDY is an algorithm for approximating the most

; coherent solution. It starts

; with a randomly or otherwise generated solution,

; i.e. assignment

; to A and R. Then it repeatedly flips an element from

; A to R or R to A, based on a calculation of which

; flip will most increase the coherence score. It

; stops either when a maximum number of flips have

; taken place, or when flipping has ceased to increase

; the coherence score.

(defun greedy (max-flips)

(do ((solution (greedy-start))

(count-flips 1)

(best-weight-so-far 0)

)

((or (= count-flips max-flips) ; enough tries

(= best-weight-so-far (second solution))

; no progress in increasing coherence

)

(setq *greedy-solution* solution) ; return best solution

)

; repeat:

(my-print "Best solution at " count-flips "
is " solution)

(setq best-weight-so-far (second solution))

(setq solution (best-flip solution))

(setq count-flips (1+ count-flips))

)

)

; GREEDY-START produces an initial solution.

; If the coherence mode is pure, this is randomly

; generated, even for the special element. If the

; mode is tempered, special is put into A, but is

; not flippable (see below). If the mode is

; tempered+, then all the favored elements are put

; into A, although they can still be flipped out. If the

; mode is foundational, then all the favored elements are

; put into A and cannot be flipped out.

; Greedy-start returns a solution of the form

; (1 %weight %number accepted-list rejected-list)

(defun greedy-start ()

(do ((elements (if (or (equal *eval-mode* 'foundational)

(equal *eval-mode* 'tempered+)

)

(set-difference *all-units* (get-favored))

; else

*all-units* ; everything random

)

(cdr elements)

)

(accepted (cond ((equal *eval-mode* 'tempered)

(list 'special)

)

((or (equal *eval-mode* 'foundational)

(equal *eval-mode* 'tempered+)

)

(cons 'special (get-favored))

)

(t nil) ; pure mode

)

)

(rejected nil)

)

((null elements) ; return

(cons 1 (append (coh-score (list 1 accepted rejected))

(list accepted rejected)

)

)

)

; repeat: Do random assignment of remaining.

(if (random-yes) (push (car elements) accepted)

(push (car elements) rejected)

)

)

)

; RANDOM-YES yields t or nil randomly.

(defun random-yes ()

(if (> (random 2) 0) 't

nil

)

)

; BEST-FLIP figures out what element can best be flipped,

; i.e. moved from A to R or vice versa in a way that

; increases coherence more than flipping other elements.

; What elements are candidates for flipping depends on the

; mode. In case of ties, selection is random.

; It returns a solution. best-flips-so-far is a list

; of (element %weight)

(defun best-flip (solution)

(do ((flippables (flip-candidates) (cdr flippables))

(best-flips-so-far (list solution))

(new-candidate nil)

(to-flip nil)

)

((null flippables) ; return

(setq to-flip (caar (randomize best-flips-so-far)))

(my-print "Flipping " to-flip)

(flip to-flip solution)

)

; repeat

(setq new-candidate (flip-short (car flippables) solution))

(cond ((equal (better-solution new-candidate

(car best-flips-so-far)

)

'yes ; new one is better

)

(setq best-flips-so-far (list new-candidate)); replace

)

((equal (better-solution new-candidate

(car best-flips-so-far)

)

'tie ; no difference

)

(push new-candidate best-flips-so-far) ; add to
list

)

) ; otherwise no change

)

)

; FLIP-CANDIDATES provides a list of candidates for

; flipping based on the mode. If coherence is

; foundational, favored elements are not flippable.

; If coherence is tempered or tempered+, then special is not flippable.

; If coherence is pure, everything is flippable.

(defun flip-candidates ()

(cond ((equal *eval-mode* 'pure) *all-units*) ;special?

((or (equal *eval-mode* 'tempered)

(equal *eval-mode* 'tempered+)

)

(remove 'special *all-units*)

)

((equal *eval-mode* 'foundational)

(set-difference *all-units* (get-favored))

)

)

)

; BETTER-SOLUTION determines whether a solution has

; a higher weight than another, reporting yes, no, or tie.

(defun better-solution (solution1 solution2)

(cond ((> (second solution1) (second solution2))

'yes

)

((< (second solution1) (second solution2))

'no

)

(t 'tie)

)

)

; FLIP produces a new solution by taking an element and

; moving it from accepted to rejected or vice versa.

(defun flip (element solution)

(let (number accepted rejected)

(setq number (1+ (car solution)))

(cond ((member element (fourth solution)) ; accepted

(setq accepted (remove element (fourth solution)))

(setq rejected (cons element (fifth solution)))

)

(t (setq accepted (cons element (fourth solution))) ; rejected

(setq rejected (remove element (fifth solution)))

)

)

(cons number (append (coh-score (list number accepted
rejected))

(list accepted rejected) ;
return

)

)

)

)

; FLIP-SHORT does not produce a whole solution, just a list of

; the element flipped and its %weight score.

(defun flip-short (element solution)

(let (number accepted rejected)

(setq number (1+ (car solution)))

(cond ((member element (fourth solution)) ; accepted

(setq accepted (remove element (fourth solution)))

(setq rejected (cons element (fifth solution)))

)

(t (setq accepted (cons element (fourth solution))) ; rejected

(setq rejected (remove element (fifth solution)))

)

)

(cons element (coh-score (list number accepted rejected)))

)

)