[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Jul 26:
; hamurabi

(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 (hamurabi)

  (welcome)

  (let ((done?       #f)  ; #t when game is done, else #f
        (pop        100)  ; current population, each needs 20 bushels/year
        (births       5)  ; number of births in current year
        (deaths       0)  ; number of deaths in current year
        (total-deaths 0)  ; cumulative deaths in all years
        (pcnt-starved 0)  ; cumulative percentage starved
        (yield        3)  ; current-year harvest in bushels per acre
        (rats       200)  ; bushels eaten by rats in current year
        (stores    2800)  ; current bushels in stores
        (acres     1000)  ; current acres owned by city
        (buy-sell     0)  ; current year change in acres
        (feed         0)  ; bushels used to feed people in current year
        (plant        0)  ; acres planted in current year, each half bushel
        (plague?     #f)) ; 15% chance of plague in any year, half die

    (let loop ((year 1))  ; main loop starts at end of first year

      ; check for plague, make report
      (when plague? (set! pop (quotient pop 2)))
      (report year deaths births plague? pop acres yield rats stores)

      ; normal termination
      (when (< 10 year)
        (set! done? #t)
        (terminate pcnt-starved total-deaths acres pop))

      ; buy or sell acreage
      (when (not done?)
        (let ((price (get-price)))
          (set! buy-sell (get-buy-sell price stores acres))
          (cond (buy-sell (set! acres (+ acres buy-sell))
                          (set! stores (- stores (* price buy-sell))))
                (else (set! done? #t) (quit)))))

      ; feed people
      (when (not done?)
        (set! feed (get-feed stores))
        (cond (feed (set! stores (- stores feed)))
              (else (set! done? #t) (quit))))

      ; harvest
      (when (not done?)
        (set! plant (get-plant acres stores pop))
        (cond (plant (set! stores (- stores (quotient plant 2)))
                     (set! yield (randint 5 0))
                     (set! rats (let ((c (randint 5 0)))
                       (if (odd? c) 0 (quotient stores c))))
                     (set! stores (+ stores (- rats) (* yield plant))))
              (else (set! done? #t) (quit))))

      ; births and deaths
      (when (not done?)
        (set! births
          (ceiling (* (randint 5 0) (+ (* 20 acres) stores) (/ pop) 1/100)))
        (set! deaths (- pop (quotient feed 20)))
        (set! total-deaths (+ total-deaths deaths))
        (set! pcnt-starved
          (/ (+ (* (- year 1) pcnt-starved)
                (floor (* deaths 100 (/ pop))))
             year))
        (set! pop (+ pop births (- deaths)))
        (when (< (* 0.45 pop) deaths) (set! done? #t) (impeach deaths)))

      ; loop for next year
      (when (not done?) (set! plague? (< (rand) 0.15)) (loop (+ year 1))))))

(define (welcome)
  (define (spaces n) (make-string n #\space))
  (for-each display `(
    ,(spaces 32) "HAMURABI" #\newline ,(spaces 15)
    "CREATIVE COMPUTING  MORRISTOWN, NEW JERSEY"
    #\newline #\newline #\newline #\newline
    "TRY YOUR HAND AT GOVERNING ANCIENT SUMERIA" #\newline
    "FOR A TEN-YEAR TERM OF OFFICE." #\newline #\newline)))

(define (report year deaths births plague? pop acres yield rats stores)
  (for-each display `(
    #\newline #\newline
    "HAMURABI:  I BEG TO REPORT TO YOU," #\newline
    "IN YEAR " ,year ", " ,deaths " PEOPLE STARVED, "
    ,births " CAME TO THE CITY," #\newline))
  (when plague?
    (display "A HORRIBLE PLAGUE STRUCK!  HALF THE PEOPLE DIED.") (newline))
  (for-each display `(
    "POPULATION IS NOW " ,pop #\newline
    "THE CITY OWNS " ,acres " ACRES." #\newline
    "YOU HARVESTED " ,yield " BUSHELS PER ACRE." #\newline
    "RATS ATE " ,rats " BUSHELS." #\newline
    "YOU NOW HAVE " ,stores " BUSHELS IN STORE." #\newline #\newline)))

(define (terminate pcnt-starved total-deaths acres pop)
  (let ((land (quotient acres pop)))
    (for-each display `(
      "IN YOUR 10-YEAR TERM OF OFFICE, "
      ,(inexact->exact (round pcnt-starved))
      " PERCENT OF THE" #\newline
      "POPULATION STARVED PER YEAR ON AVERAGE, I.E., A TOTAL OF"
      #\newline ,total-deaths " PEOPLE DIED!!" #\newline
      "YOU STARTED WITH 10 ACRES PER PERSON AND ENDED WITH "
      ,land " ACRES PER PERSON." #\newline #\newline))
    (cond ((or (< 33 pcnt-starved) (< land 7)) (fink))
          ((or (< 10 pcnt-starved) (< land 9)) (nero))
          ((or (< 3 pcnt-starved) (< land 10)) (not-bad pop))
          (else (fantastic)))))

(define (fink)
  (display "DUE TO THIS EXTREME MISMANAGEMENT YOU HAVE NOT ONLY") (newline)
  (display "BEEN IMPEACHED AND THROWN OUT OF OFFICE BUT YOU HAVE") (newline)
  (display "ALSO BEEN DECLARED 'NATIONAL FINK' !!") (newline) (so-long))

(define (nero)
  (for-each display `(
    "YOUR HEAVY-HANDED PERFORMANCE SMACKS OF NERO AND IVAN IV." #\newline
    "THE PEOPLE (REMAINING) FIND YOU AN UNPLEASANT RULER, AND," #\newline
    "FRANKLY, HATE YOUR GUTS!")) (so-long))

(define (not-bad pop)
  (for-each display `(
    "YOUR PERFORMANCE COULD HAVE BEEN SOMEWHAT BETTER, BUT"
    #\newline "REALLY WASN'T TOO BAD AT ALL. "
    ,(randint (floor (* pop 4/5)) 0) " PEOPLE WOULD" #\newline
    "DEARLY LIKE TO SEE YOU ASSASSINATED BUT WE ALL HAVE OUR "
    "TRIVIAL PROBLEMS." #\newline)) (so-long))

(define (fantastic)
  (for-each display `(
    "A FANTASTIC PEFORMANCE!!!  CHARLEMAGNE, DISRAELI, AND" #\newline
    "JEFFERSON COMBINED COULD NOT HAVE DONE BETTER" #\newline)) (so-long))

(define (so-long)
  (do ((n 1 (+ n 1))) ((< 10 n)) (display #\bel))
  (newline) (display "SO LONG FOR NOW.") (newline) (newline))

(define (get-price)
  (let ((price (+ (randint 10) 17)))
    (for-each display `(
      "LAND IS TRADING AT " ,price " BUSHELS PER ACRE." #\newline))
    price))

(define (get-buy-sell price stores acres)
  (let ((q (get-buy price stores acres)))
    (cond ((not q) #f) ((positive? q) q)
          (else (let ((q (get-sell acres)))
                  (if q (- q) #f))))))

(define (get-buy price stores acres)
  (display "HOW MANY ACRES DO YOU WISH TO BUY? ")
  (let ((q (read)))
    (cond ((negative? q) #f)
          ((< (* price q) stores) q)
          (else (no-stores stores) (get-buy price stores acres)))))

(define (get-sell acres)
  (display "HOW MANY ACRES DO YOU WISH TO SELL? ")
  (let ((q (read)))
    (cond ((negative? q) #f) ((< q acres) q)
          (else (no-acres acres) (get-sell acres)))))
          
(define (get-feed stores)
  (newline) (display "HOW MANY BUSHELS DO YOU WISH TO FEED YOUR PEOPLE? ")
  (let ((q (read)))
    (cond ((negative? q) #f)
          ((< stores q) (no-stores stores) (get-feed stores))
          (else q))))

(define (get-plant acres stores pop)
  (newline) (display "HOW MANY ACRES DO YOU WISH TO PLANT WITH SEED? ")
  (let ((q (read)))
    (cond ((negative? q) #f) ((zero? q) q)
          ((< acres q) (no-acres acres) (get-plant acres stores pop))
          ((< stores (quotient q 2))
            (no-stores stores) (get-plant acres stores pop))
          ((< (* pop 10) q) (no-people pop) (get-plant acres stores pop))
          (else q))))

(define (no-stores stores)
  (for-each display `(
    "HAMURABI:  THINK AGAIN.  YOU HAVE ONLY " ,stores
    " BUSHELS OF GRAIN.  NOW THEN," #\newline)))

(define (no-acres acres)
  (for-each display `(
    "HAMURABI:  THINK AGAIN.  YOU ONLY OWN "
    ,acres " ACRES.  NOW THEN," #\newline)))

(define (no-people pop)
  (for-each display `(
    "BUT YOU HAVE ONLY " ,pop
    " PEOPLE TO TEND THE FIELDS.  NOW THEN," #\newline)))

(define (impeach deaths)
  (for-each display `(
    #\newline "YOU STARVED " ,deaths " PEOPLE IN ONE YEAR!!!" #\newline))
  (fink))

(define (quit)
  (newline) (display "HAMURABI:  I CANNOT DO WHAT YOU WISH.") (newline)
  (display "GET YOURSELF ANOTHER STEWARD!!!!!") (newline) (so-long))


Create a new paste based on this one


Comments: