SHARE
TWEET

Untitled

a guest Dec 9th, 2016 102 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. #!/usr/bin/newlisp
  2.  
  3. ;;; marriage-age-gap-simulation.lsp Copyright (c) 2016 Mycroft Jones
  4. ;;;
  5. ;;; to run: newlisp.exe marriage-age-gap-simulation.lsp
  6. ;;;
  7. ;;; The polygamy problem: If some men have more than one wife, other men will
  8. ;;; have to go without!  Is this problem real?  Or does it depend on false
  9. ;;; assumptions?
  10. ;;;
  11. ;;; Assuming an age gap between the age at which men and women marry, how many
  12. ;;; men can have 2 wives?
  13. ;;;
  14. ;;; Assuming every man has a certain number of wives, what age gap is required?
  15. ;;; Also, how many times will a woman marry, compared to a man?
  16. ;;;
  17. ;;; First model:
  18. ;;;   * everyone lives their full lifespan
  19. ;;;   * no abortions, miscarriages, murders
  20. ;;;   * marriage is for life, no divorce
  21. ;;;   * if father is over 40, female birthrate goes to 0.6408
  22.  
  23. (define maxwives 2)
  24. (define male-age-of-death 72) ; 72
  25. (define female-age-of-death 79)
  26. (define male-age-of-majority 18)
  27. (define female-age-of-majority 16)
  28. (define female-age-of-menopause 42)
  29. (define female-age-of-widowhood 60)
  30. (define male-birth-ratio (ratio 1 1.05))
  31. (define ratio-after-40 0.6408)
  32. (define average-number-of-children-per-woman 8)
  33. (define birth-odds (div average-number-of-children-per-woman
  34.                         (sub female-age-of-menopause female-age-of-majority)))
  35.  
  36. (context '/dev/urandom)
  37. (define max-32bit-int 4294967295)
  38. (set 'fd (open "/dev/urandom" "read"))
  39. (define (/dev/urandom:/dev/urandom)
  40.   (read fd buf 4)
  41.   (div (max 1 (first (unpack "lu" buf))) max-32bit-int))
  42. (context MAIN)
  43.  
  44. ;(define-macro (nq a b) (push (eval a) (eval b) -1))
  45. (define-macro (nq a b) (eval (list 'push a b -1)))
  46. (define-macro ($# a) (+ -1 (length (eval a))))
  47.  
  48. (define males (list))
  49. (define females (list))
  50. (define everyone (list)) ; (m birthyear ((wife-id marriage-year) ...) (child-id ...) deathyear (current-wives))
  51.                          ; (f birthyear ((husband-id marriage-year) ...) (child-id ...) deathyear current-husband)
  52.  
  53. (define (age x) (- yr (everyone x 1)))
  54.  
  55. ;; yearly stats
  56. (define mdeaths 0) ; male deaths
  57. (define fdeaths 0) ; female deaths
  58. (define mbirths 0) ; male births
  59. (define fbirths 0) ; female births
  60. (define mages 0)   ; used to calculate average male age at marriage
  61. (define fages 0)   ; used to calculate average female age at marriage
  62. (define nmarriages 0) ; number of marriages
  63.  
  64. (define initialize-population
  65.   (lambda ()
  66.     (dotimes (yr (max male-age-of-majority female-age-of-majority))
  67.       (nq (list 'm yr '() '() nil '()) everyone)
  68.       (nq (+ -1 (length everyone)) males)
  69.       (nq (list 'f yr '() '() nil nil) everyone)
  70.       (nq (+ -1 (length everyone)) females)
  71.     )))
  72.  
  73. ;; married women can give birth between ages of 18 and 44
  74. ;; average number of children, 5
  75. ;; let's say a 1 in 5 chance of giving birth in any given year
  76.  
  77. (define (do-births yr)
  78.   (letn (bfemales (filter (fn (x) (and (everyone x 5) (> (age x) female-age-of-majority) (< (age x) female-age-of-menopause) (< (/dev/urandom) birth-odds))) females)
  79.          gfemales (filter (fn (x) (< (/dev/urandom) (if (< (age x) 40) male-birth-ratio ratio-after-40))) bfemales)
  80.          mfemales (difference bfemales gfemales)
  81.          leveryone (+ -1 (length everyone)))
  82.     (dotimes (i (length mfemales)) (push (list 'm yr '() '() nil '()) everyone -1) (push (++ leveryone) males -1))
  83.     (dotimes (i (length gfemales)) (push (list 'f yr '() '() nil nil) everyone -1) (push (++ leveryone) females -1))
  84.     (++ mbirths (length mfemales))
  85.     (++ fbirths (length gfemales))))
  86.  
  87. (define (do-deaths yr)
  88.   (let (dmales   (filter (fn (y) (> (age y) male-age-of-death)) males)
  89.         dfemales (filter (fn (y) (> (age y) female-age-of-death)) females))
  90.     (set 'males (difference males dmales))
  91.     (set 'females (difference females dfemales))
  92.     (set 'mdeaths (length dmales))
  93.     (set 'fdeaths (length dfemales))
  94.     (dolist (m dmales)
  95.       (setf (everyone m 4) yr)
  96.       (dolist (w (everyone m 5)) (setf (everyone w 5) nil))
  97.     )
  98.     (dolist (f dfemales)
  99.       (setf (everyone f 4) yr)
  100.       (let (h (everyone f 5))
  101.         (when h
  102.           (setf (everyone h 5)
  103.               (clean (fn (x) (= x f)) (everyone h 5)))) ; free up husband to take another wife
  104.       )
  105.     )
  106.   )
  107. )
  108.  
  109. (define (do-marriages yr)
  110.   (let (smales (filter (fn (x) (and (< (length (everyone x 5)) maxwives) (> (age x) male-age-of-majority))) males)
  111.         sfemales (clean (fn (x) (or (everyone x 5) (< (age x) female-age-of-majority) (> (age x) female-age-of-widowhood))) females))
  112.   (catch (dolist (m smales)
  113.     (when (empty? sfemales) (throw))
  114.     (let (f (pop sfemales))
  115.       (push f (everyone m 5))
  116.       (setf (everyone f 5) m)
  117.       (++ fages (age f))
  118.       (++ mages (age m))
  119.       (++ nmarriages)
  120.   )))))
  121.  
  122. (define (print-year yr)
  123.   (println (format "Year %d. population %d (m: %d f: %d) %d births (m: %d f: %d) %d deaths (m: %d f: %d) %d marriages (m: %d f: %d)"
  124.     yr
  125.     (+ (length males) (length females)) (length males) (length females)
  126.     (+ mbirths fbirths) mbirths fbirths
  127.     (+ mdeaths fdeaths) mdeaths fdeaths
  128.     nmarriages (round (div mages nmarriages)) (round (div fages nmarriages))
  129.   ))
  130.   (set 'mdeaths 0 'fdeaths 0 'mbirths 0 'fbirths 0 'mages 0 'fages 0 'nmarriages 0))
  131.  
  132. (initialize-population)
  133. (define (do-year yr)
  134.       (when (and (< 0 (length males)) (< 0 (length females)))
  135.       (do-births yr)
  136.       (do-deaths yr)
  137.       (do-marriages yr)
  138.       (print-year yr)))
  139.  
  140. (for (yr male-age-of-majority 1000)
  141.      (do-year yr))
  142.  
  143. (exit)
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
Top