[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/RjEZcaLh    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Jun 26:
; world cup prognostication

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (uniq-c eql? xs)
  (if (null? xs) xs
    (let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
      (cond ((null? xs) (reverse (cons (cons prev k) result)))
            ((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
            (else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result)))))))

(define rand #f)
(define randint #f)
(let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
  (define (mod-diff x y) (modulo (- x y) two31)) ; generic version
  ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
  (define (flip-cycle)
    (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (set! fptr 54) (vector-ref a 55))
  (define (init-rand seed)
    (let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
      (vector-set! a 55 prev)
      (do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
        (vector-set! a i next) (set! next (mod-diff prev next))
        (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
        (set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
      (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
  (define (next-rand)
    (if (negative? (vector-ref a fptr)) (flip-cycle)
      (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
  (define (unif-rand m)
    (let ((t (- two31 (modulo two31 m))))
      (let loop ((r (next-rand)))
        (if (<= t r) (loop (next-rand)) (modulo r m)))))
  (init-rand 19380110) ; happy birthday donald e knuth
  (set! rand (lambda seed
    (cond ((null? seed) (/ (next-rand) two31))
          ((eq? (car seed) 'get) (cons fptr (vector->list a)))
          ((eq? (car seed) 'set) (set! fptr (caadr seed))
                                 (set! a (list->vector (cdadr seed))))
          (else (/ (init-rand (modulo (numerator
                  (inexact->exact (car seed))) two31)) two31)))))
  (set! randint (lambda args
    (cond ((null? (cdr args))
            (if (< (car args) two31) (unif-rand (car args))
              (floor (* (next-rand) (car args)))))
          ((< (car args) (cadr args))
            (let ((span (- (cadr args) (car args))))
              (+ (car args)
                 (if (< span two31) (unif-rand span)
                   (floor (* (next-rand) span))))))
          (else (let ((span (- (car args) (cadr args))))
                  (- (car args)
                     (if (< span two31) (unif-rand span)
                       (floor (* (next-rand) span))))))))))

(define teams
  '(("URU" 1890) ("KOR" 1746) ("USA" 1785) ("GHA" 1711)
    ("NED" 2045) ("SVK" 1654) ("BRA" 2082) ("CHI" 1883)
    ("ARG" 1966) ("MEX" 1873) ("GER" 1930) ("ENG" 1945)
    ("PAR" 1771) ("JPN" 1744) ("ESP" 2061) ("POR" 1874)))

(define (win-expectation t1 t2)
  (/ (+ 1 (expt 10 (/ (- (cadr t2) (cadr t1)) 400)))))

(define (point-change t1 t2)
  (* 60 (- 1 (win-expectation t1 t2))))

(define (match t1 t2)
  (if (< (rand) (win-expectation t1 t2))
      (list (car t1) (+ (cadr t1) (point-change t1 t2)))
      (list (car t2) (+ (cadr t2) (point-change t2 t1)))))

(define (round teams)
  (let loop ((teams teams) (result '()))
    (if (null? teams)
        (reverse result)
        (loop (cddr teams)
              (cons (match (car teams) (cadr teams)) result)))))

(define (tournament teams)
  (let loop ((teams teams))
    (if (null? (cdr teams))
        (caar teams)
        (loop (round teams)))))

(define (simulate n)
  (let loop ((n n) (result '()))
    (if (zero? n)
        (sort (lambda (x y) (> (cdr x) (cdr y)))
              (uniq-c string=? (sort string<? result)))
        (loop (- n 1) (cons (tournament teams) result)))))

(display (simulate 5000))


Output:
1
((BRA . 1102) (ESP . 1097) (NED . 954) (ARG . 407) (ENG . 308) (URU . 273) (GER . 227) (MEX . 138) (CHI . 136) (POR . 126) (USA . 86) (PAR . 47) (KOR . 39) (JPN . 30) (GHA . 28) (SVK . 2))


Create a new paste based on this one


Comments: