Advertisement
Guest User

Betapocalypse: Marriage age gap vs polygamy

a guest
Dec 9th, 2016
239
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. #!/usr/bin/newlisp -n
  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 (ratio a b) (div a (add a b))) ; transforms a ratio a:b to a decimal fraction
  24.  
  25. (define maxwives 2)
  26. (define male-age-of-death 72) ; 72
  27. (define female-age-of-death 79)
  28. (define male-age-of-majority 18)
  29. (define female-age-of-majority 16)
  30. (define female-age-of-menopause 42)
  31. (define female-age-of-widowhood 60)
  32. (define male-birth-ratio (ratio 1 1.05))
  33. (define ratio-after-40 0.6408)
  34. (define average-number-of-children-per-woman 8)
  35. (define birth-odds (div average-number-of-children-per-woman
  36.                         (sub female-age-of-menopause female-age-of-majority)))
  37.  
  38. (context '/dev/urandom)
  39. (define max-32bit-int 4294967295)
  40. (set 'fd (open "/dev/urandom" "read"))
  41. (define (/dev/urandom:/dev/urandom)
  42.   (read fd buf 4)
  43.   (div (max 1 (first (unpack "lu" buf))) max-32bit-int))
  44. (context MAIN)
  45.  
  46. (define-macro (nq a b) (eval (list 'push a b -1)))
  47. (define-macro ($# a) (-- (length (eval a)))) ; index of last element in a list, just like in Perl
  48.  
  49. (define males (list))
  50. (define females (list))
  51. (define everyone (list)) ; (m birthyear ((wife-id marriage-year) ...) (child-id ...) deathyear (current-wives))
  52.                          ; (f birthyear ((husband-id marriage-year) ...) (child-id ...) deathyear current-husband)
  53.  
  54. (define (age x) (- yr (everyone x 1)))
  55.  
  56. ;; yearly stats
  57. (define mdeaths 0) ; male deaths
  58. (define fdeaths 0) ; female deaths
  59. (define mbirths 0) ; male births
  60. (define fbirths 0) ; female births
  61. (define mages 0)   ; used to calculate average male age at marriage
  62. (define fages 0)   ; used to calculate average female age at marriage
  63. (define nmarriages 0) ; number of marriages
  64.  
  65. (define initialize-population
  66.   (lambda ()
  67.     (dotimes (yr (max male-age-of-majority female-age-of-majority))
  68.       (nq (list 'm yr '() '() nil '()) everyone)
  69.       (nq (+ -1 (length everyone)) males)
  70.       (nq (list 'f yr '() '() nil nil) everyone)
  71.       (nq (+ -1 (length everyone)) females)
  72.     )))
  73.  
  74. ;; married women can give birth between ages of 18 and 44
  75. ;; average number of children, 5
  76. ;; let's say a 1 in 5 chance of giving birth in any given year
  77.  
  78. (define (do-births yr)
  79.   (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)
  80.          gfemales (filter (fn (x) (< (/dev/urandom) (if (< (age x) 40) male-birth-ratio ratio-after-40))) bfemales)
  81.          mfemales (difference bfemales gfemales)
  82.          leveryone (+ -1 (length everyone)))
  83.     (dotimes (i (length mfemales)) (push (list 'm yr '() '() nil '()) everyone -1) (push (++ leveryone) males -1))
  84.     (dotimes (i (length gfemales)) (push (list 'f yr '() '() nil nil) everyone -1) (push (++ leveryone) females -1))
  85.     (++ mbirths (length mfemales))
  86.     (++ fbirths (length gfemales))))
  87.  
  88. (define (do-deaths yr)
  89.   (let (dmales   (filter (fn (y) (> (age y) male-age-of-death)) males)
  90.         dfemales (filter (fn (y) (> (age y) female-age-of-death)) females))
  91.     (set 'males (difference males dmales))
  92.     (set 'females (difference females dfemales))
  93.     (set 'mdeaths (length dmales))
  94.     (set 'fdeaths (length dfemales))
  95.     (dolist (m dmales)
  96.       (setf (everyone m 4) yr)
  97.       (dolist (w (everyone m 5)) (setf (everyone w 5) nil))
  98.     )
  99.     (dolist (f dfemales)
  100.       (setf (everyone f 4) yr)
  101.       (let (h (everyone f 5))
  102.         (when h
  103.           (setf (everyone h 5)
  104.               (clean (fn (x) (= x f)) (everyone h 5)))) ; free up husband to take another wife
  105.       )
  106.     )
  107.   )
  108. )
  109.  
  110. (define (do-marriages yr)
  111.   (let (smales (filter (fn (x) (and (< (length (everyone x 5)) maxwives) (> (age x) male-age-of-majority))) males)
  112.         sfemales (clean (fn (x) (or (everyone x 5) (< (age x) female-age-of-majority) (> (age x) female-age-of-widowhood))) females))
  113.   (catch (dolist (m smales)
  114.     (when (empty? sfemales) (throw))
  115.     (let (f (pop sfemales))
  116.       (push f (everyone m 5))
  117.       (setf (everyone f 5) m)
  118.       (++ fages (age f))
  119.       (++ mages (age m))
  120.       (++ nmarriages)
  121.   )))))
  122.  
  123. (define (print-year yr)
  124.   (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)"
  125.     yr
  126.     (+ (length males) (length females)) (length males) (length females)
  127.     (+ mbirths fbirths) mbirths fbirths
  128.     (+ mdeaths fdeaths) mdeaths fdeaths
  129.     nmarriages (round (div mages nmarriages)) (round (div fages nmarriages))
  130.   ))
  131.   (set 'mdeaths 0 'fdeaths 0 'mbirths 0 'fbirths 0 'mages 0 'fages 0 'nmarriages 0))
  132.  
  133. (initialize-population)
  134. (define (do-year yr)
  135.       (when (and (< 0 (length males)) (< 0 (length females)))
  136.       (do-births yr)
  137.       (do-deaths yr)
  138.       (do-marriages yr)
  139.       (print-year yr)))
  140.  
  141. (for (yr male-age-of-majority 1000)
  142.      (do-year yr))
  143.  
  144. (exit)
Advertisement
Advertisement
Advertisement
RAW Paste Data Copied
Advertisement