# Untitled

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