;;; XEmacs: This file contains -*- Scheme -*- source code. ;;; tourney.ss: referee and judge for a ``prisoner's dilemma'' tournament ;;; John David Stone ;;; Department of Mathematics and Computer Science ;;; Grinnell College ;;; stone@cs.grinnell.edu ;;; Original version: February 22, 1986 ;;; Last revised: July 1, 2001 ;;; The ``prisoner's dilemma'' is a game for two persons -- call them A and ;;; B. In each round of the game, each player independently selects one of ;;; two options, traditionally called ``cooperation'' and ``defection.'' ;;; The players then reveal their selections simultaneously and score ;;; points according to the following table: ;;; A's play B's play A's score B's score ;;; ------------------------------------------------------- ;;; cooperation cooperation 3 3 ;;; cooperation defection 0 5 ;;; defection cooperation 5 0 ;;; defection defection 1 1 ;;; Thus the game is symmetrical and does not favor either player. Since ;;; the scoring table is such that each player gets more points for ;;; defecting than for cooperating, no matter which option the other player ;;; selects, a rational player always defects if he sees the other player ;;; as an opponent and concerns himself only with trying to outscore the ;;; other player. Two such players, therefore, score one point each. A ;;; different kind of rational player sees the other player as a potential ;;; ally and chooses cooperation in the hope of obtaining a total of six ;;; points (the maximum) for the allies. ;;; Although this latter strategy is in one sense less certain to succeed, ;;; an additional reason for cooperating appear when the same players ;;; participate in several successive rounds of the game: Cooperation in ;;; early rounds may induce the other player to cooperate subsequently, to ;;; the advantage of both players. When such a multi-round game forms part ;;; of a tournament involving a large number of players, each successively ;;; paired with each, with the overall scores determined by adding the ;;; results of the individual matches, there is an even stronger reason to ;;; choose cooperation at least some of the time: If cooperation is ;;; reciprocal, a player who receives three points per round in many games ;;; will accumulate a higher total than a chronic defector who usually ;;; receives one point per round. It is even possible for a player who ;;; never outscores any of her opponents in a single match to place first ;;; in the overall tournament, if the other players obtain lower scores ;;; when matched to one another than when matched to her. ;;; This program stages exactly such a round-robin tournament. Each player ;;; is represented by a Scheme procedure that embodies his selection ;;; strategy as a function of the number of rounds previously played in the ;;; current match and the record of both players' selections in previous ;;; rounds. ;;; First, let's look at some players. ;;; The ABSENTEE player cooperates in the first two rounds and ;;; subsequently defects if the other player has defected in each of the ;;; two preceding rounds, but cooperates if the other player cooperated in ;;; either of those two rounds. (This player is sometimes called TIT FOR ;;; TWO TATS.) (define absentee (lambda (rounds-played my-plays your-plays) (cond ((< rounds-played 2) 'cooperation) ((eq? (vector-ref your-plays (- rounds-played 2)) 'cooperation) 'cooperation) (else (vector-ref your-plays (- rounds-played 1)))))) ;;; The DOWNING player defects on the first two rounds, then decides which ;;; move to make on the basis of the opponent's track record: It reviews ;;; the game record, determining how often in the past the opponent has ;;; responded to defection with defection and how often it has responded to ;;; cooperation with defection. It then assumes that the opponent will ;;; continue to respond to future acts of cooperation and defection with ;;; cooperation and defection in the same proportions. Finally, DOWNING ;;; computes whether it is more profitable to cooperate or to defect, given ;;; the opponent's response policy, and makes the appropriate move. (In ;;; cases where the strategy would be cooperating for the first time, it ;;; assumes that the probability that an opponent will respond to ;;; cooperation with cooperation is fifty percent.) ;;; Designer: Leslie Downing. (define Downing (let ((rewarded (lambda (trial rounds-played my-plays your-plays) (let loop ((round-number 0) (rewards 0)) (if (= round-number (- rounds-played 1)) rewards (loop (+ round-number 1) (if (and (eq? (vector-ref my-plays round-number) trial) (eq? (vector-ref your-plays (+ round-number 1)) 'cooperation)) (+ rewards 1) rewards))))))) (lambda (rounds-played my-plays your-plays) (if (< rounds-played 2) 'defection (let ((my-cooperations (let loop ((round-number 0) (cooperations 0)) (cond ((= round-number rounds-played) cooperations) ((eq? (vector-ref my-plays round-number) 'cooperation) (loop (+ round-number 1) (+ cooperations 1))) (else (loop (+ round-number 1) cooperations)))))) (let ((chance-of-cooperation-rewarded (if (zero? my-cooperations) 1/2 (/ (rewarded 'cooperation rounds-played my-plays your-plays) my-cooperations))) (chance-of-defection-rewarded (/ (rewarded 'defection rounds-played my-plays your-plays) (- rounds-played my-cooperations)))) (if (< (* 3 chance-of-cooperation-rewarded) (+ (* 4 chance-of-defection-rewarded) 1)) 'defection 'cooperation))))))) ;;; In the first five rounds, FAYE alternately cooperates and defects ;;; (beginning with cooperation). Subsequently, FAYE does whatever the ;;; other player did in the previous round. (define Faye (lambda (rounds-played my-plays your-plays) (case rounds-played ((0 2 4) 'cooperation) ((1 3) 'defection) (else (vector-ref your-plays (- rounds-played 1)))))) ;;; FLORENCIO defects in even-numbered rounds and cooperates in ;;; odd-numbered ones. (define Florencio (lambda (rounds-played my-plays your-plays) (if (even? rounds-played) 'defection 'cooperation))) ;;; The JUST-MEAN player defects in every round, regardless of what the ;;; other player does. (define just-mean (lambda (rounds-played my-plays your-plays) 'defection)) ;;; The LOOK-BACK player cooperates in the first round. On every subsequent ;;; round, it does whatever the other player did in the previous round. ;;; (Another name for this player is TIT FOR TAT.) (define look-back (lambda (rounds-played my-plays your-plays) (if (zero? rounds-played) 'cooperation (vector-ref your-plays (- rounds-played 1))))) ;;; MARILEE defects if the opponent has defected in either ;;; of the preceding rounds. (define Marilee (lambda (rounds-played my-plays your-plays) (cond ((zero? rounds-played) 'cooperation) ((eq? (vector-ref your-plays (- rounds-played 1)) 'defection) 'defection) ((= rounds-played 1) 'cooperation) (else (vector-ref your-plays (- rounds-played 2)))))) ;;; The OVERTIME player follows a pre-programmed sequence of acts of ;;; cooperation and defection, basing its choice entirely on the round ;;; number and not on the opponent's behavior. The pattern consists of ;;; alternating strings of cooperations and defections, growing longer and ;;; longer as the round number increases. After round 100, it always ;;; defects. (define overtime (lambda (rounds-played my-plays your-plays) (if (member rounds-played '(0 3 4 8 9 14 15 21 22 27 28 32 33 36 37 39 40 43 44 48 49 54 55 61 62 67 68 72 73 76 77 79 80 83 84 88 89 94 95 96 97 98 99)) 'cooperation 'defection))) ;;; The POINT SEVEN player cooperates in the first round and thereafter ;;; cooperates whenever the other player cooperated in the preceding round; ;;; after a defection by the other player, POINT SEVEN generates a random ;;; number in the range from 0 to 1 and defects if the random number is ;;; less than 0.7. ;;; Designer: Bill Murphy (define point-seven (lambda (rounds-played my-plays your-plays) (cond ((zero? rounds-played) 'cooperation) ((eq? (vector-ref your-plays (- rounds-played 1)) 'cooperation) 'cooperation) ((< (random 10) 7) 'defection) (else 'cooperation)))) ;;; PUNISHER cooperates in every round until the other player defects. It ;;; responds to the other player's first defection by defecting in the next ;;; round, to the second defection by defecting in the next two rounds, to ;;; the third defection by defecting in the next three rounds, and so ;;; on. Each new defection starts the retaliation count over at 0. When not ;;; retaliating, PUNISHER responds to cooperation with cooperation. ;;; Designer: Doria Laura (define punisher (lambda (rounds-played my-plays your-plays) (let loop ((round-number 0) (previous-defections 0) (punishment 0)) (cond ((= round-number rounds-played) (if (zero? punishment) 'cooperation 'defection)) ((eq? (vector-ref your-plays round-number) 'defection) (loop (+ round-number 1) (+ previous-defections 1) (+ previous-defections 1))) (else (loop (+ round-number 1) previous-defections (if (positive? punishment) (- punishment 1) punishment))))))) ;;; SAINT cooperates in every round, regardless of what the other player ;;; does. ;;; Designer: Morris Matati (define saint (lambda (rounds-played my-plays your-plays) 'cooperation)) ;;; The SNEAKY player follows the same strategy as LOOK-BACK for the first ;;; fifteen rounds. Beginning in the sixteenth round, however, if the ;;; other player has cooperated in all five of the preceding rounds, SNEAKY ;;; defects once, then cooperates in the following round. If, in that ;;; following round, the other player ``punishes'' SNEAKY by defecting, ;;; SNEAKY reverts to following the LOOK-BACK strategy for another fifteen ;;; rounds and then tries another unprovoked defection, and so on. If the ;;; other player fails to punish SNEAKY, SNEAKY continues to defect ;;; indefinitely until it provokes a response. (define sneaky (let* ((recently-cooperative? (lambda (rounds-played your-plays) (and (eq? (vector-ref your-plays (- rounds-played 1)) 'cooperation) (eq? (vector-ref your-plays (- rounds-played 2)) 'cooperation) (eq? (vector-ref your-plays (- rounds-played 3)) 'cooperation) (eq? (vector-ref your-plays (- rounds-played 4)) 'cooperation) (eq? (vector-ref your-plays (- rounds-played 5)) 'cooperation)))) (find-sneaky-state (lambda (rounds-played your-plays) (do ((round-number 15 (+ round-number 1)) (look-back-timer 0) (state 'looking-back)) ((= round-number rounds-played) state) (cond ((eq? state 'looking-back) (if (zero? look-back-timer) (if (recently-cooperative? round-number your-plays) (set! state 'testing)) (set! look-back-timer (- look-back-timer 1)))) ((eq? state 'testing) (set! state 'apologizing)) ((eq? state 'apologizing) (set! state 'assessing)) ((eq? state 'assessing) (if (eq? (vector-ref your-plays (- round-number 1)) 'defection) (begin (set! state 'looking-back) (set! look-back-timer 15))))))))) (lambda (rounds-played my-plays your-plays) (cond ((zero? rounds-played) 'cooperation) ((< rounds-played 15) (vector-ref your-plays (- rounds-played 1))) (else (let ((state (find-sneaky-state rounds-played your-plays))) (cond ((eq? state 'looking-back) (vector-ref your-plays (- rounds-played 1))) ((eq? state 'testing) 'defection) ((eq? state 'apologizing) 'cooperation) ((eq? state 'assessing) (if (eq? (vector-ref your-plays (- rounds-played 1)) 'cooperation) 'defection 'cooperation))))))))) ;;; TESTER defects in the first round, cooperates in the second round, and ;;; continues to alternate defection with cooperation as long as the other ;;; player does not defect. TESTER cooperates after the other player's ;;; first defection, but after that plays the same strategy as LOOK-BACK. (define tester (lambda (rounds-played my-plays your-plays) (let ((first-defection (let loop ((round-number 0)) (cond ((= round-number rounds-played) #f) ((eq? (vector-ref your-plays round-number) 'defection) round-number) (else (loop (+ round-number 1))))))) (cond ((not first-defection) (if (even? rounds-played) 'defection 'cooperation)) ((= first-defection (- rounds-played 1)) 'cooperation) (else (vector-ref your-plays (- rounds-played 1))))))) ;;; THREE-STRIKES cooperates in every round until the other player has ;;; defected three times altogether; after that, it defects in every round. (define three-strikes (lambda (rounds-played my-plays your-plays) (let loop ((round-number 0) (defections 0)) (cond ((= round-number rounds-played) 'cooperation) ((eq? (vector-ref your-plays round-number) 'cooperation) (loop (+ round-number 1) defections)) ((= defections 2) 'defection) (else (loop (+ round-number 1) (+ defections 1))))))) ;;; VANESSA cooperates in the first three rounds, then switches over to ;;; constant defection if the other player has defected in each of those ;;; first three rounds, and otherwise does whatever the other player did in ;;; the preceding round. (define Vanessa (lambda (rounds-played my-plays your-plays) (cond ((< rounds-played 3) 'cooperation) ((and (eq? (vector-ref your-plays 0) 'defection) (eq? (vector-ref your-plays 1) 'defection) (eq? (vector-ref your-plays 2) 'defection)) 'defection) (else (vector-ref your-plays (- rounds-played 1)))))) ;;; ROSTER is an association list in which each player is associated with a ;;; string that names it. (define roster (list (cons Absentee "Absentee") (cons Downing "Downing") (cons Faye "Faye") (cons Florencio "Florencio") (cons just-mean "Just mean") (cons look-back "Look back") (cons Marilee "Marilee") (cons overtime "Overtime") (cons point-seven "Point seven") (cons punisher "Punisher") (cons saint "Saint") (cons sneaky "Sneaky") (cons tester "Tester") (cons three-strikes "Three strikes") (cons Vanessa "Vanessa"))) ;;; The ADD-TO-ROSTER procedure can be used to add a new player at the end ;;; of the roster. (define add-to-roster (lambda (player name) (let loop ((rest roster)) (if (null? (cdr rest)) (set-cdr! rest (list (cons player name))) (loop (cdr rest)))))) ;;; The number of rounds in each match is supposed to be a secret from the ;;; players (otherwise, there would be no reason for them ever to cooperate ;;; in the last round of a match), but it is held constant through any one ;;; tournament: (define rounds-per-match 186) ;;; The PLAY-MATCH procedure stages a match between two given players, ;;; reporting their final scores as a pair in which the car is the first ;;; player's score and the cdr the second player's. (define play-match (lambda (player-A player-B) ;; Make sure that both players are procedures. (if (not (and (procedure? player-A) (procedure? player-B))) (error 'play-match "Both arguments must be procedures")) ;; Set up the vectors in which the plays will be recorded. (let ((A-plays (make-vector rounds-per-match)) (B-plays (make-vector rounds-per-match))) ;; Loop through successive rounds. (let loop ((rounds-played 0) (A-score 0) (B-score 0)) ;; If all the rounds have been played, return the final scores. (if (= rounds-played rounds-per-match) (cons A-score B-score) ;; Otherwise, have each player select cooperation or defection. (let ((A-play (player-A rounds-played A-plays B-plays)) (B-play (player-B rounds-played B-plays A-plays))) ;; Record their choices. (vector-set! A-plays rounds-played A-play) (vector-set! B-plays rounds-played B-play) ;; Compute their scores, add them to the running totals, and ;; proceed to the next round. If either player returns a ;; value other than COOPERATION or DEFECTION, he defaults ;; and scores 0 for the match, and the other player receives ;; the maximum match score. (case A-play ((cooperation) (case B-play ((cooperation) (loop (+ rounds-played 1) (+ A-score 3) (+ B-score 3))) ((defection) (loop (+ rounds-played 1) A-score (+ B-score 5))) (else (cons (* rounds-per-match 5) 0)))) ((defection) (case B-play ((cooperation) (loop (+ rounds-played 1) (+ A-score 5) B-score)) ((defection) (loop (+ rounds-played 1) (+ A-score 1) (+ B-score 1))) (else (cons (* rounds-per-match 5) 0)))) (else (cons 0 (* rounds-per-match 5)))))))))) ;;; The PLAY-TOURNAMENT procedure takes a vector of two or more players, ;;; stages a round-robin tournament in which each one meets every other ;;; one, adds up the match scores for each player, and reports the results. (define play-tournament (lambda () (let ((players (list->vector (map car roster)))) ;; Construct a vector to hold the scores of all the players and a ;; table to hold the outcome of each match. (let* ((len (vector-length players)) (scores (make-vector len 0)) (results (make-matrix len len))) ;; Run through all of the players, letting each one in turn be ;; player A. (let outer-loop ((player-A-number 0)) ;; When all of the players have had a chance, report the final ;; scores. (if (= player-A-number len) (report-scores players results scores) ;; Otherwise, run through the players that appear later in ;; the vector than the current player A, letting each one in ;; turn be player B. (let inner-loop ((player-B-number (+ player-A-number 1))) ;; When all the possible matches involving the current player ;; A are finished, go on to the next candidate for player A. (if (= player-B-number len) (outer-loop (+ player-A-number 1)) ;; Otherwise, play a match between players A and B, ;; record the results, and add the scores to their ;; respective totals. (let ((match-result (play-match (vector-ref players player-A-number) (vector-ref players player-B-number)))) (vector-set! scores player-A-number (+ (vector-ref scores player-A-number) (car match-result))) (vector-set! scores player-B-number (+ (vector-ref scores player-B-number) (cdr match-result))) (matrix-set! results player-A-number player-B-number (car match-result)) (matrix-set! results player-B-number player-A-number (cdr match-result)) (inner-loop (+ player-B-number 1))))))))))) ;;; The VECTOR-OF procedure takes a predicate PRED? as argument and returns ;;; a procedure that takes any object as argument and determines whether it ;;; is a vector in which PRED? correctly characterizes every element. (If ;;; it is a vector that has no elements, the procedure returned by ;;; VECTOR-OF returns #T, on the theory that PRED? is ``vacuously true'' of ;;; the vector's elements.) (define vector-of (lambda (pred?) ;; Return a procedure denoted by a LAMBDA-expression. (lambda (obj) (and (vector? obj) ;; Loop through the elements of the vector, from the highest- ;; numbered to the lowest-numbered; return #T if you get all ;; the way down to zero without finding an element that fails ;; to satisfy PRED. (let loop ((remaining (vector-length obj))) (or (zero? remaining) (let ((next (- remaining 1))) (and (pred? (vector-ref obj next)) (loop next))))))))) ;;; The result table is a two-dimensional square matrix; the number of rows ;;; and columns is the same as the number of players. Scheme does not ;;; provide built-in support for matrices. The following procedures ;;; provide the three basic operations: construction, selection, and ;;; mutation. (define make-matrix (lambda (rows columns) (let ((result (make-vector rows))) (do ((row 0 (+ row 1))) ((= row rows) result) (vector-set! result row (make-vector columns)))))) (define matrix-ref (lambda (matrix row column) (vector-ref (vector-ref matrix row) column))) (define matrix-set! (lambda (matrix row column new-value) (vector-set! (vector-ref matrix row) column new-value))) ;;; The MATRIX-ROWS and MATRIX-COLUMNS procedures take a matrix as argument ;;; and return, respective, the number of rows and of columns in the ;;; matrix. (define matrix-rows (lambda (matrix) (vector-length matrix))) (define matrix-columns (lambda (matrix) (if (zero? (vector-length matrix)) (error 'matrix-columns "The argument matrix must contain at least one row")) (vector-length (vector-ref matrix 0)))) ;;; The MATRIX? procedure determines whether a given object is a matrix -- ;;; a vector in which each element is a vector and all of those vectors ;;; have the same length. (define matrix? (lambda (obj) (and ((vector-of vector?) obj) (or (zero? (vector-length obj)) (let ((len (vector-length (vector-ref obj 0))) (rows (vector-length obj))) (let loop ((row 1)) (or (= row rows) (and (= len (vector-length (vector-ref obj row))) (loop (+ row 1)))))))))) ;;; The MATRIX-OF procedure takes a predicate PRED? as argument and returns ;;; a procedure that takes any object as argument and determines whether it ;;; is a matrix in which PRED? correctly characterizes every element. (define matrix-of (lambda (pred?) ;; Return a procedure denoted by a LAMBDA-expression. (lambda (obj) (and (matrix? obj) ;; Loop through the elements of the matrix, row by row; return ;; #T if you reach the end of the last row without finding an ;; element that fails to satisfy PRED?. (let ((rows (matrix-rows obj)) (columns (matrix-columns obj))) (let loop ((row 0) (column 0)) (cond ((= row rows) #t) ((= column columns) (loop (+ row 1) 0)) ((pred? (matrix-ref obj row column)) (loop row (+ column 1))) (else #f)))))))) ;;; The REPORT-SCORES procedure takes a vector of players, a matrix of ;;; match results, and a vector of tournament scores and displays a table ;;; of match results, followed by a list of the names and scores of the ;;; players, sorted into descending order by score. (define report-scores (lambda (players results scores) ;; Confirm that PLAYERS is a vector of procedures, that RESULTS is a ;; matrix of integers, that SCORES is a vector of integers, and that ;; the various lengths match up correctly. (if (not ((vector-of procedure?) players)) (error 'report-scores "The first argument must be a vector of procedures")) (if (not ((matrix-of integer?) results)) (error 'report-scores "The second argument must be a matrix of integers")) (if (not ((vector-of integer?) scores)) (error 'report-scores "The second argument must be a vector of integers")) (if (not (= (vector-length players) (matrix-rows results) (matrix-columns results) (vector-length scores))) (error 'report-scores (string-append "The first and third arguments must be " "vectors of equal length, and the second " "a matrix with the same number of rows and " "columns"))) ;; Display the table of match results. (let ((len (vector-length players)) (row-header-width 19) (column-width 4)) ;; First, the column headers: (display (make-string row-header-width #\space)) (do ((index 0 (+ index 1))) ((= len index) (newline)) (display (right-justify column-width (number->string (+ index 1))))) ;; Next, row by row, the names and results: (do ((row 0 (+ row 1))) ((= len row) (newline)) (display (left-justify row-header-width (string-append (right-justify 2 (number->string (+ row 1))) " " (cdr (assoc (vector-ref players row) roster))))) (do ((column 0 (+ column 1))) ((= len column) (newline)) (if (= column row) (display (make-string column-width #\space)) (display (right-justify column-width (number->string (matrix-ref results row column)))))))) ;; Form a list of pairs in which each pair is the name of a player and ;; the score that player received. Sort this list into descending ;; order by score. Display each element of the resulting list. (for-each display-name-and-score (insertion-sort (zip-names-and-scores players scores) (lambda (ns-1 ns-2) (> (cdr ns-1) (cdr ns-2))))))) ;;; The LEFT-JUSTIFY procedure takes a natural number and a string as ;;; arguments. If the natural number is greater than the length of the ;;; string, LEFT-JUSTIFY returns a string just like the one it is given ;;; except that spaces have been added at the right end to pad it out so ;;; that its length is equal to the given natural number. Otherwise ;;; LEFT-JUSTIFY returns an initial prefix of the given string that has the ;;; specified length. (define left-justify (lambda (desired-length str) (let ((len (string-length str))) (if (< len desired-length) (string-append str (make-string (- desired-length len) #\space)) (substring str 0 desired-length))))) ;;; The RIGHT-JUSTIFY procedure takes a natural number and a string as ;;; arguments. If the natural number is greater than the length of the ;;; string, RIGHT-JUSTIFY returns a string just like the one it is given ;;; except that spaces have been added at the left end to pad it out so ;;; that its length is equal to the given natural number. If the natural ;;; number is less than the length of the string, RIGHT-JUSTIFY returns a ;;; string of asterisks of the specified length. If the natural number is ;;; equal to the length of the string, RIGHT-JUSTIFY returns the string. (define right-justify (lambda (desired-length str) (let ((len (string-length str))) (cond ((< len desired-length) (string-append (make-string (- desired-length len) #\space) str)) ((< desired-length len) (make-string desired-length #\*)) (else str))))) ;;; The DISPLAY-NAME-AND-SCORE procedure displays the name and score of ;;; one player in an appropriate format. (define display-name-and-score (lambda (name-and-score) (let ((name-field-width 16) (score-field-width 10)) ;; NAME-AND-SCORE must be a pair consisting of a string of twenty ;; characters or fewer and a non-negative integer of fewer than nine ;; digits. (if (not (pair? name-and-score)) (error 'display-name-and-score "The argument must be a pair")) (let ((name (car name-and-score)) (score (cdr name-and-score))) (if (not (and (string? name) (<= (string-length name) name-field-width))) (error 'display-name-and-score (string-append "The car of the argument must be a " "string of not more than " (number->string name-field-width) " characters"))) (if (or (not (integer? score)) (negative? score) (<= (expt 10 (- score-field-width 1)) score)) (error 'display-name-and-score (string-append "The cdr of the argument must be an " "integer of fewer than " (number->string score-field-width) " digits"))) (display (left-justify name-field-width name)) (display (right-justify score-field-width (number->string score))) (newline))))) ;;; The INSERTION-SORT procedure takes a list LS and a binary predicate ;;; PRECEDES? that determines whether one element of LS should be placed ;;; ahead of another in the sorted result; it returns a sorted list ;;; containing the same elements as LS. (define insertion-sort (lambda (ls precedes?) ;; Confirm that LS is a list and PRECEDES? a procedure. (if (not (list? ls)) (error 'insertion-sort "The first argument must be a list")) (if (not (procedure? precedes?)) (error 'insertion-sort "The second argument must be a binary predicate")) ;; Divide the list into an unsorted part (initially, the entire list) ;; and a sorted part (initially, an empty list). Move elements one at ;; a time from the unsorted part into the sorted part, placing each ;; one correctly with respect to the elements previously transferred. (let outer-loop ((unsorted ls) (sorted '())) ;; When there are no more elements to be transferred, return the ;; sorted list. (if (null? unsorted) sorted ;; Until then, take the first element of the unsorted list and ;; insert it into the sorted list. (let ((element-to-insert (car unsorted))) ;; Let REST be the part of the sorted list yet to be traversed ;; in the search for the correct insertion point, and let ;; BYPASSED be the list of elements from the sorted list that ;; have already been inspected and should precede ;; ELEMENT-TO-INSERT in the sorted list. (let inner-loop ((rest sorted) (bypassed '())) ;; If the end of the sorted list has been reached, or if ;; ELEMENT-TO-INSERT should precede the rest of the elements ;; in the sorted list, attach ELEMENT-TO-INSERT to what ;; remains of the sorted list and then reattach the bypassed ;; elements, one by one. (if (or (null? rest) (precedes? element-to-insert (car rest))) ;; The reversal loop performs the reattachment. (let reversal-loop ((base (cons element-to-insert rest)) (to-restore bypassed)) ;; If there are no more bypassed elements to reattach, ;; BASE is the new sorted list; proceed to the next ;; step of the outer loop. (if (null? to-restore) (outer-loop (cdr unsorted) base) ;; Otherwise, reattach the next bypassed element to ;; BASE and repeat the reversal loop. (reversal-loop (cons (car to-restore) base) (cdr to-restore)))) ;; If the correct insertion point has not yet been ;; reached, pass by one more element from the sorted list ;; (by removing it from REST and adding it to BYPASSED). (inner-loop (cdr rest) (cons (car rest) bypassed))))))))) ;;; The ZIP-NAMES-AND-SCORES procedure takes as arguments a vector of ;;; players in the tournament -- i.e., strategic procedures -- and a vector ;;; of their respective scores. It returns a list of pairs in which each ;;; pair has as its car the name of a player and as its cdr the score for ;;; that player. (define zip-names-and-scores (lambda (players scores) ;; Confirm that PLAYERS is a vector of procedures, that SCORES is a ;; vector of integers, and that the vectors are equal in length. (if (not ((vector-of procedure?) players)) (error 'zip-names-and-scores "The first argument must be a vector of procedures")) (if (not ((vector-of integer?) scores)) (error 'zip-names-and-scores "The second argument must be a vector of integer.")) (if (not (= (vector-length players) (vector-length scores))) (error 'zip-names-and-scores "The arguments must be vectors of equal length")) (let loop ((remaining (vector-length players)) (result '())) (if (zero? remaining) result (let ((next (- remaining 1))) (loop next (cons (cons (cdr (assq (vector-ref players next) roster)) (vector-ref scores next)) result)))))))