codepad

Language:

; house of representatives

(define-syntax (define-structure x)
  (define (gen-id template-id . args)
    (datum->syntax-object template-id
      (string->symbol
        (apply string-append
               (map (lambda (x)
                      (if (string? x) x
                        (symbol->string
                            (syntax-object->datum x))))
                    args)))))
  (syntax-case x ()
    ((_ name field ...)
     (with-syntax
       ((constructor (gen-id (syntax name) "make-" (syntax name)))
        (predicate (gen-id (syntax name) (syntax name) "?"))
        ((access ...)
          (map (lambda (x) (gen-id x (syntax name) "-" x))
               (syntax (field ...))))
        ((assign ...)
          (map (lambda (x) (gen-id x "set-" (syntax name) "-" x "!"))
               (syntax (field ...))))
        (structure-length (+ (length (syntax (field ...))) 1))
        ((index ...) (let f ((i 1) (ids (syntax (field ...))))
                       (if (null? ids) '()
                         (cons i (f (+ i 1) (cdr ids)))))))
    (syntax (begin
              (define (constructor field ...)
                (vector 'name field ...))
              (define (predicate x)
                (and (vector? x)
                     (= (vector-length x) structure-length)
                     (eq? (vector-ref x 0) 'name)))
              (define (access x) (vector-ref x index)) ...
              (define (assign x update) (vector-set! x index update))
              ...))))))

; http://2010.census.gov/2010census/data/pop_change.csv
; total population excluding District of Columbia is 308143815

(define state-pop-data '(("Alabama" 4779736) ("Alaska" 710231)
  ("Arizona" 6392017) ("Arkansas" 2915918) ("California" 37253956)
  ("Colorado" 5029196) ("Connecticut" 3574097) ("Delaware" 897934)
  ("Florida" 18801310) ("Georgia" 9687653) ("Hawaii" 1360301)
  ("Idaho" 1567582) ("Illinois" 12830632) ("Indiana" 6483802)
  ("Iowa" 3046355) ("Kansas" 2853118) ("Kentucky" 4339367)
  ("Louisiana" 4533372) ("Maine" 1328361) ("Maryland" 5773552)
  ("Massachusetts" 6547629) ("Michigan" 9883640) ("Minnesota" 5303925)
  ("Mississippi" 2967297) ("Missouri" 5988927) ("Montana" 989415)
  ("Nebraska" 1826341) ("Nevada" 2700551) ("New Hampshire" 1316470)
  ("New Jersey" 8791894) ("New Mexico" 2059179) ("New York" 19378102)
  ("North Carolina" 9535483) ("North Dakota" 672591) ("Ohio" 11536504)
  ("Oklahoma" 3751351) ("Oregon" 3831074) ("Pennsylvania" 12702379)
  ("Rhode Island" 1052567) ("South Carolina" 4625364) ("South Dakota" 814180)
  ("Tennessee" 6346105) ("Texas" 25145561) ("Utah" 2763885)
  ("Vermont" 625741) ("Virginia" 8001024) ("Washington" 6724540)
  ("West Virginia" 1852994) ("Wisconsin" 5686986) ("Wyoming" 563626)))

; http://programmingpraxis.com/2009/08/14/pairing-heaps/

(define pq-empty '())
(define pq-empty? null?)

(define (pq-first pq)
  (if (null? pq)
      (error 'pq-first "can't extract minimum from null queue")
      (car pq)))

(define (pq-merge lt? p1 p2)
  (cond ((null? p1) p2)
        ((null? p2) p1)
        ((lt? (car p2) (car p1))
          (cons (car p2) (cons p1 (cdr p2))))
        (else (cons (car p1) (cons p2 (cdr p1))))))

(define (pq-insert lt? x pq)
  (pq-merge lt? (list x) pq))

(define (pq-merge-pairs lt? ps)
  (cond ((null? ps) '())
        ((null? (cdr ps)) (car ps))
        (else (pq-merge lt? (pq-merge lt? (car ps) (cadr ps))
                            (pq-merge-pairs lt? (cddr ps))))))

(define (pq-rest lt? pq)
  (if (null? pq)
      (error 'pq-rest "can't delete minimum from null queue")
      (pq-merge-pairs lt? (cdr pq))))

(define (pq->list lt? pq)
  (let loop ((pq pq) (xs '()))
    (if (pq-empty? pq) (reverse xs)
      (loop (pq-rest lt? pq) (cons (pq-first pq) xs)))))

; apportionment algorithm

(define-structure sp state pop reps g)

(define (lt? a b) (not (< (sp-g a) (sp-g b))))

(define (mean n p) (/ p (sqrt (* n (+ n 1)))))

(define (huntington-hill n xs)
  (when (< n (length xs)) (error 'huntington-hill "not enough"))
  (let loop1 ((xs xs) (k 1) (pq pq-empty))
    (if (pair? xs)
        (let* ((s (caar xs)) (p (cadar xs)) (g (mean 1 p)))
          (loop1 (cdr xs) (+ k 1)
                 (pq-insert lt? (make-sp s p 1 g) pq)))
        (let loop2 ((k k) (pq pq))
          (if (not (< n k))
              (let* ((p (pq-first pq)) (reps (+ (sp-reps p) 1)))
                (set-sp-reps! p reps)
                (set-sp-g! p (mean reps (sp-pop p)))
                (loop2 (+ k 1) (pq-insert lt? p (pq-rest lt? pq))))
              (sort (lambda (a b) (< (cadr b) (cadr a)))
                (map (lambda (sp) (list (sp-state sp) (sp-reps sp)))
                  (pq->list lt? pq))))))))

(display (huntington-hill 435 state-pop-data)) (newline)

Private [?]

Run code