Guest User

Untitled

a guest
Dec 9th, 2016
125
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