;; Sept 30/07 ;; Genealogy world for developing 'discover-laws' ;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ;; To use this program, just load it (while in lisp) and after this ;; the 'create-world' function (to create a new world) and 'world' ;; function (for querying the newly created world) will be available. ;; The current world can be replaced by a new one by again typing ;; (create-world) ;; The parameters of every newly created world are printed out, as ;; well as all of the individuals created and their characteristics ;; (mother, father, children, spouses, nonspousal mates). The ;; probabilistic parameters that stochastically determine the world ;; parameters can be found in the 'initialize' function, and they ;; are easily altered -- but the current settings have been chosen ;; to generally yield a reasonably large genealogy, without taking ;; an unreasonably large amount of time to do so. ;; ;; Exploration of a world might begin with several calls ;; (world '?) ;; to obtain random facts about the world, and once some random facts ;; such as (SISTER NEILA_4 CORALINE_4) have been obtained, one can ;; use more "pointed" queries such as ;; (world '(sister coraline_4 neila_4)), ;; ("is it true that the sister relation holds for Coraline_4 and ;; Neila_4?), or ;; (world '(sister coraline_4 ?)) ;; ("give me a random sister of Coraline_4") or ;; (world '(? neila_4 coraline_4)) ;; ("give me a random relation between Neila_4 and Coraline_4"), ;; or ;; (world '(? neila_4)) ;; ("give me a random monadic property of Neila_4"). Allowable queries ;; are ones that consist entirely of a question mark, or contain 0 ;; or 1 question marks as part of a predication, as illustrated above. ;; Keep in mind that the goal of manual experimentation is to get ;; a feel for how a mechanical procedure might best explore such a ;; world so as to discover as many as possible of its laws, using as ;; few queries as possible. An example of a law (informally stated) ;; is that if X is a child of Y, then Y is a parent of X. Resist ;; the temptation to ask questions based on your own world knowledge, ;; such as asking (world '(brother neila_4 ?)), before you have seen ;; any instance of a "brother" relation! Your discovery program will ;; be tested on a completely new world, with unknown, completely ;; different predicates, individuals, and laws. ;; ;; One thing you should make sure of is that none of the function names ;; and global parameters (see 'defun's and 'defparameter's) conflict ;; with yours (or else, if you know how, you could use packages). ;; ;; A world is generated by starting with some set of ur-ancestors (e.g., ;; 10), who are taken to be unrelated. For each male, a random number ;; of offspring are chosen according to an exponential distribution with ;; mean (fixed for that world) between 2 and 3. Initially a decision is ;; made for each male whether, and to whom, to be married (with a ;; probability, e.g., .7) determined by *marriage-preference*). A choice ;; of a female mate (belonging to the same generation) is made for each ;; offspring. This is preferred to be the wife (or randomly, one of the ;; wives) as determined probabilistically by the value of the male's ;; 'fidelity' parameter (a fixed parameter for that individual, but with ;; a value chosen stochastically based on a global *fidelity* parameter). ;; If the male and female are not currently husband and wife, they become ;; so, again with the *marriage-preference* probability (so individuals ;; may end up with multiple spouses). The choice of female with whom to ;; produce a particular offspring is made with a preference for the wife ;; or wives (if any) and, for extramarital choices, for females previously ;; chosen for that male. The preference for wives or other former mates ;; is waived if the female's number of offspring has reached a certain ;; "lifetime limit". If a new female mate is chosen, there is a preference ;; for unrelated or only distantly related females, and also a preference ;; for females with 0 offspring so far. The strength of preference is ;; governed by a 'fastidiousness' parameter, a fixed value for a particular ;; male, but chosen stochastically based on a global *fastidiousness* ;; parameter. ;; ;; All this is repeated for each new generation, for some random number ;; of generations (e.g., 10). Sometimes "humanity dies out" (for lack ;; of sufficiently prolific pairings): ;; ;; Relations are mate, husband, wife, spouse, mother, father, parent, son, ;; daughter, child, brother, sister, sibling, half-brother, half-sister, ;; stepfather, stepmother, stepson, stepdaughter, stepchild, stepbrother, ;; stepsister, grandmother, grandfather, grandparent, great-grandmother, ;; great-grandfather, great-grandparent, granddaughter, grandson, ;; grandchild, great-grandson, great-granddaughter, great-grandchild, ;; aunt, uncle, niece, nephew, cousin, parent-parent, child-child ;; (the last two are ternary relations; e.g., (child-child Mary Bill ;; Sue) means that Mary has a child Bill who in turn has a child Sue), ;; [ancestor, anc-anc, descendant, desc-desc -- these were originally ;; included as well but have been suppressed because they tend to swamp ;; the set of facts about the world]. There are also the 1-place predicates ;; male, female, has-children, childless, lone-male, lone-female. ;; ;; Dozens of "laws" hold in terms of these relations... It's worth noting ;; that there are also likely to be statistical laws, such as that most ;; individuals have a mother and father (not the ur-ancestors!), most ;; individuals have children (not the last generation), most males/females ;; have only one mate (in most worlds), etc. ;; ;; Names of individuals are chosen from lists of common male and female ;; names, with a _i suffix for an individual in the i'th generation ;; (and possibly a numeric suffix preceding the underscore to avoid ;; name duplication, e.g., George_7, George2_7. (defun iterate-geometric (minv expv) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Obtain a random integer >= minv by repeatedly sampling a geometric ; distribution with expected value expv till such a value is obtained. ; (So the actual expected value is > expv.) ; (let ((v (geometric expv))) (do ( ) ((> v expv)) (setq v (geometric expv)) ) v )); end of iterate-geometric (defun geometric (mu) ;~~~~~~~~~~~~~~~~~~~~ ; Random value from a geometric distribution with mean 'mu' ; (floor (- 0.5 (* mu (log (random 1.0))))) ) (defun random-choice (min max) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Pick an integer between min and max (inclusive), using a uniform ; distribution ; (+ min (random (- (+ max 1) min))) ) (defun return-1-with-prob (p) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Return 1 with probability p, otherwise return 0 (if (<= (random 1.0) p) 1 0) ) (defun query-variants (fact) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Generate a list of queries, consisting of 'fact' and all variants ; of it containing a question mark in place of one of the list elements ; (let ((queries (list fact)) query j) (cond ((atom fact) queries) (t (dotimes (i (length fact)); subst "?" for ith element (setq j -1) (setq query nil) (dolist (x fact) (incf j) (push (if (= i j) '? x) query) ) (push (reverse query) queries) ) (reverse queries) )) )); end of query-variants (load "names.lisp"); defines parameters *male-names*, *female-names* (defparameter *nmale-names* (length *male-names*)) (defparameter *nfemale-names* (length *female-names*)) (defparameter *global-capacity* 200); an upper bound on number of people ; (o.w. garbage collection blows up) (defun initialize ( ) ;~~~~~~~~~~~~~~~~~~~~ ;; THE FOLLOWING 8 FACTORS CAN BE RESET AT WILL (AT SOME RISK ...) ;; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (defparameter *number-ur-females* (iterate-geometric 2 5)) (format t "~%*number-ur-females* = ~a" *number-ur-females*) (defparameter *number-ur-males* (iterate-geometric 2 5)) (format t "~%*number-ur-males* = ~a" *number-ur-males*) (defparameter *number-generations* (iterate-geometric 4 6)) (format t "~%*number-generations* = ~a" *number-generations*) (defparameter *average-fertility* (+ 1.7 (random 0.6))) (format t "~%*average-fertility* = ~a" *average-fertility*) (defparameter *lifetime-limit* (iterate-geometric 10 15)) (format t "~%*lifetime-limit* = ~a" *lifetime-limit*) (defparameter *marriage-preference* (+ 0.3 (random 0.7))); betw. 0 and 1 (format t "~%*marriage-preference* = ~a" *marriage-preference*) (defparameter *fidelity* (+ 0.5 (random 0.5))); betw. 0 & 1 (avg. for males) (format t "~%*fidelity* = ~a" *fidelity*) (defparameter *fastidiousness* (+ 0.8 (random 0.2))); betw. 0 & 1 (format t "~%*fastidiousness* ~a" *fastidiousness*) ; Clean up any 'indices' properties of the names (from a previous world) (dolist (name *male-names*) (remprop name 'indices)) (dolist (name *female-names*) (remprop name 'indices)) (defparameter *people* nil); everyone created (defparameter *npeople* 0); the total population (defparameter *people-table* (make-hash-table :size 101)) (defparameter *facts* nil); a list of all facts in the world generated (defparameter *nfacts* 0); the number of facts (defparameter *fact-array* nil); will allow random access to facts ; The list of predicates & its size, and a hash table containing an ; array of facts for each predicate, where the key is the predicate ; (for random access to facts with equal probability for all predicates): (defparameter *predicates* nil); to be filled in later (defparameter *npredicates* 0) (defparameter *pred-array-table* nil); will be made into hash table ; A hash table making facts accessible through arbitrary queries: (defparameter *world-table* (make-hash-table :size 2000 :test 'equal) ) (defparameter *nquestions* 0); no. of questions asked so far ); end of initialize (defun create-world ( ) ;~~~~~~~~~~~~~~~~~~~~~~ ; CREATE A GENEALOGY WORLD. ; (initialize) (let (name new-females new-males new-people females males people fidelity fastidiousness nchildren sex nwives mate) ; Ur-ancestors: (dotimes (i *number-ur-females*) (setq name (new-person 0 t)); "generation 0" females (setf (get name 'sex) 'female) (push name new-people) (push name new-females) ) (dotimes (i *number-ur-males*) (setq name (new-person 0 nil)); "generation 0" males (setf (get name 'sex) 'male) (push name new-people) (push name new-males) ) (dotimes (n *number-generations*); create successive generations (setq females new-females males new-males people new-people) (setq new-females nil new-males nil new-people nil) (when (or (null females) (null males)) (format t "~%~%HUMANITY HAS DIED OUT!!~%^^^^^^^^^^^^^^^^^^^^^^^") (format t "~%NO. OF PEOPLE = ~a" *npeople*) (setq *number-generations* n) (return nil) ); break out of generation loop (when (> *npeople* *global-capacity*) (format t "~%~%POPULATION HAS EXPLODED!!~%^^^^^^^^^^^^^^^^^^^^^^^^^") (format t "~%NO. OF PEOPLE = ~a" *npeople*) (setq *number-generations* n) (return nil) ) ; break out of generation loop ; iterate through the males, deciding on offspring and corresponding ; mates: (dolist (male males) (setq fidelity; random choice, with avg. = *fidelity* (if (< .5 *fidelity*) (+ (- (* 2 *fidelity*) 1) (random (* 2 (- 1 *fidelity*)))) (random (* 2 *fidelity*)) )) (setf (get male 'fidelity) fidelity) (setq fastidiousness; random choice, with avg. = *fastidiousness* (if (< .5 *fastidiousness*) (+ (- (* 2 *fastidiousness*) 1) (random (* 2 (- 1 *fastidiousness*))) ) (random (* 2 *fastidiousness*)) )) (setf (get male 'fastidiousness) fastidiousness) (setq nchildren (geometric *average-fertility*)) (dotimes (i (+ nchildren 1)); initial iteration is for marriage (cond ((= i 0); decide whether and whom to marry (setq nwives (return-1-with-prob *marriage-preference*)) (when (= nwives 1) (setq mate (choose-wife male females)) (push mate (get male 'spouses)); marry (push male (get mate 'spouses)) )); marry (t; choose mate to have ith child with (setq mate (choose-mate male females)) (when (not (member mate (get male 'mates))) (push mate (get male 'mates)) (push male (get mate 'mates)) ) ; If the chosen mate is not a spouse, decide whether ; to marry (when (not (member mate (get male 'spouses))) (setq nwives (return-1-with-prob *marriage-preference*)) (when (= nwives 1) (push mate (get male 'spouses)) (push male (get mate 'spouses)) )) ; define and connect the child (setq sex (random 2)); 0 (male) or 1 (female) (setq name (new-person (+ n 1) (if (= sex 1) t nil))) (push name new-people) (if (= sex 1); debugging version (push name new-females) (push name new-males) ) ; The following version doesn't work for some reason: ; (push name (if (= sex 1) new-females new-males)) (setf (get name 'sex) (if (= sex 1) 'female 'male)) (setf (get name 'mother) mate) (setf (get name 'father) male) (push name (get male 'children)) (push name (get mate 'children)) )))) ; Print out the individuals of the previous generation (n) (format t "~%~%GENERATION ~a~%^^^^^^^^^^^^^" n) (dolist (x people) (print-personal-data x)) ); end of dotimes (generations) ; Print the final generation (no children, spouses, mates) (when new-people (format t "~%~%GENERATION ~a~%^^^^^^^^^^^^^" *number-generations*) (dolist (x new-people) (print-personal-data x)) ) ; Ready to compute and tabulate all relations in *world-table*: ; mate, husband, wife, spouse, mother, father, parent, daughter, ; son, child, brother, sister, sibling, half-brother, half-sister, ; stepfather, stepmother, stepson, stepdaughter, stepchild, stepbrother, ; stepsister, grandmother, grandfather, grandparent, great-grandmother, ; great-grandfather, great-grandparent, granddaughter, grandson, ; grandchild, great-grandson, great-granddaughter, great-grandchild, ; aunt, uncle, niece, nephew, cousin, parent-parent, child-child, ; ancestor, anc-anc, descendant, desc-desc. There are also the ; 1-place predicates male, female, has-children, childless, lone-male, ; lone-female. Push all facts onto *facts*. ; (dolist (person *people*) (setq sex (get person 'sex)) (push (list sex person) *facts*); male/female (if (get person 'children) (push (list 'has-children person) *facts*); has-children/childless (push (list 'childless person) *facts*) ) (if (and (null (get person 'spouses)) (null (get person 'mates))) (if (eq sex 'female) (push (list 'lone-female person) *facts*) (push (list 'lone-male person) *facts*) )) (if (and (get person 'mates) (eq (get person 'sex) 'female)) (dolist (mate (get person 'mates)) (push (list 'mate person mate) *facts*) (push (list 'mate mate person) *facts*) )) (if (and (get person 'spouses) (eq sex 'female)) (dolist (spouse (get person 'spouses)) (push (list 'husband person spouse) *facts*) (push (list 'wife spouse person) *facts*) )) (when (get person 'mother) (push (list 'mother person (get person 'mother)) *facts*) (push (list 'father person (get person 'father)) *facts*) (push (list 'parent person (get person 'mother)) *facts*) (push (list 'parent person (get person 'father)) *facts*) ) (if (get person 'children) (dolist (ch (get person 'children)) (push (list 'child person ch) *facts*) (if (eq (get ch 'sex) 'female) (push (list 'daughter person ch) *facts*) (push (list 'son person ch) *facts*) ) (when (get person 'mother); linear grand-relations (push (list 'grandmother ch (get person 'mother)) *facts*) (push (list 'grandfather ch (get person 'father)) *facts*) (push (list 'grandparent ch (get person 'mother)) *facts*) (push (list 'grandparent ch (get person 'father)) *facts*) (push (list 'grandchild (get person 'mother) ch) *facts*) (push (list 'grandchild (get person 'father) ch) *facts*) (cond ((eq (get ch 'sex) 'female) (push (list 'granddaughter (get person 'mother) ch) *facts* ) (push (list 'granddaughter (get person 'father) ch) *facts* )) (t (push (list 'grandson (get person 'mother) ch) *facts* ) (push (list 'grandson (get person 'father) ch) *facts* )))) (dolist (ch2 (get person 'children)); sibling relations (when (not (eq ch ch2)) (push (list 'sibling ch ch2) *facts*) (if (eq (get ch2 'sex) 'female) (push (list 'sister ch ch2) *facts*) (push (list 'brother ch ch2) *facts*) ))))) ; Great-grand relations (without attempt at efficiency) (let ((ggpp (great-grandparents person))) (dolist (ggp ggpp) (push (list 'great-grandparent person ggp) *facts*) (push (list 'great-grandchild ggp person) *facts*) (if (eq sex 'female) (push (list 'great-granddaughter ggp person) *facts*) (push (list 'great-grandson ggp person) *facts*) ) (if (eq (get ggp 'sex) 'female) (push (list 'great-grandmother person ggp) *facts*) (push (list 'great-grandfather person ggp) *facts*) ))) ; Cousins, uncles, aunts, nieces, nephews (when (> (length (get person 'children)) 1); at least 2 children (dolist (sib1 (get person 'children)) (dolist (sib2 (get person 'children)) (when (not (eq sib1 sib2)) (let ((chch1 (get sib1 'children)) (chch2 (get sib2 'children)) ) (when (and chch1 chch2) (dolist (ch1 chch1) (dolist (ch2 chch2) (when (null (intersection (list (get ch1 'mother) (get ch1 'father) ) (list (get ch2 'mother) (get ch2 'father) ))) (push (list 'cousin ch1 ch2) *facts*) (if (eq (get sib1 'sex) 'female) (push (list 'aunt ch2 sib1) *facts*) (push (list 'uncle ch2 sib1) *facts*) ) (if (eq (get ch2 'sex) 'female) (push (list 'niece sib1 ch2) *facts*) (push (list 'nephew sib1 ch2) *facts*) ))))) ))))); end of cousins, etc. ; Half-siblings (when (get person 'children) (dolist (mate (get person 'mates)) (dolist (ch1 (get person 'children)) (dolist (ch2 (get mate 'children)) (case (length (intersection (list (get ch1 'mother) (get ch1 'father)) (list (get ch2 'mother) (get ch2 'father)) )) (1 ; the only relevant case (if (eq (get ch2 'sex) 'female) (push (list 'half-sister ch1 ch2) *facts*) (push (list 'half-brother ch1 ch2) *facts*) ))))))) ; Step-siblings, step parents (when (get person 'children) (dolist (spouse (get person 'spouses)) (dolist (ch1 (get person 'children)) (when (not (member spouse (list (get ch1 'mother) (get ch1 'father)) )) (push (list 'stepparent ch1 spouse) *facts*) (push (list 'stepchild spouse ch1) *facts*) (if (eq (get spouse 'sex) 'female) (push (list 'stepmother ch1 spouse) *facts*) (push (list 'stepfather ch1 spouse) *facts*) ) (if (eq (get ch1 'sex) 'female) (push (list 'stepdaughter spouse ch1) *facts*) (push (list 'stepson spouse ch1) *facts*) )) (dolist (ch2 (get spouse 'children)) (if (null (intersection ; the only relevant case (list (get ch1 'mother) (get ch1 'father)) (list (get ch2 'mother) (get ch2 'father)) )) (if (eq (get ch2 'sex) 'female) (push (list 'step-sister ch1 ch2) *facts*) (push (list 'step-brother ch1 ch2) *facts*) )))))) ; parent-parent triples and child-child triples (let ((parents (parents person)) (children (get person 'children)) ) (when (and parents children) (dolist (par parents) (dolist (ch children) (push (list 'parent-parent ch person par) *facts*) (push (list 'child-child par person ch) *facts*) )))) ; ; anc-anc triples and ancestor-closure; ; ; desc-desc triples, and descendant closure ; (do ((ancs1 (parents person))) ; ((null ancs1)) ; (dolist (anc1 ancs1) ; (push (list 'ancestor person anc1) *facts*) ; (push (list 'descendant anc1 person) *facts*) ; (do ((ancs2 (parents anc1))) ; ((null ancs2)) ; (dolist (anc2 ancs2) ; (push (list 'anc-anc person anc1 anc2) *facts*) ; (push (list 'desc-desc anc2 anc1 person) *facts*) ) ; (setq ancs2 (apply #'append (mapcar #'parents ancs2))) )) ; (setq ancs1 (apply #'append (mapcar #'parents ancs1))) ) ); end of *people* dolist ; Store all facts in *fact-array*, in *pred-array-table*, and along ; with query-variants, in *world-table*. The purpose of *pred-array-table* ; is to allow random selection of facts via "?" in a way that is immune ; to which kinds of facts (e.g., desc-desc facts) are most numerous, i.e., ; each type of fact is sampled with equal frequency: ; (format t "~%~%#facts = ~a; checking for duplicates ..." (length *facts*)); the next step tends to be slow... (setq *facts* (remove-duplicates *facts* :test 'equal)) (setq *nfacts* (length *facts*)) (format t "~%~%*nfacts* = ~a" *nfacts*) (setq *fact-array* (make-array *nfacts* :initial-contents *facts*)) (setq *predicates* (remove-duplicates (mapcar #'car *facts*))) (setq *npredicates* (length *predicates*)) (format t "~%~%*npredicates* = ~a" *npredicates*) (setq *pred-array-table* (make-hash-table :size *npredicates*)) (format t "~%~%setting up tables for fast random access to facts ...") (dolist (f *facts*); first store a list of facts for each predicate (push f (gethash (car f) *pred-array-table*))) ; Now change the lists to arrays for fast random access (dolist (p *predicates*) (let ((pfacts (gethash p *pred-array-table*))) (setf (gethash p *pred-array-table*) (make-array (length pfacts) :initial-contents pfacts) ))) (format t "~%~%setting up query-variants of facts in global table ...") ; Place facts and query-variants in *world-table*: (dolist (f *facts*) (dolist (q (query-variants f)) (push f (gethash q *world-table*)) )); NB: f is stored as singleton )); end of create-world (defun new-person (n fem) ; ~~~~~~~~~~~~~~~~~~~~~~ ; Choose a new person (female if fem is true) at generation n; e.g., CINDY_5. ; Use extra suffix preceding the underscore if the first-tried name already ; exists; e.g., CINDY2_5 (we take CINDY1_5 to be written as CINDY_5). ; (let (name pair indices index) (setq name (if fem (nth (random-choice 0 (- *nfemale-names* 1)) *female-names*) (nth (random-choice 0 (- *nmale-names* 1)) *male-names*) )) (cond ((or (null indices) (null pair)); the usual case (push (list n 1) (get name 'indices)); so 1st DUPLICATE index = 2 (setq name (intern (format nil "~a_~a" name n))) ) (t (setq index (+ (second pair) 1)) (setf (get name 'indices) (subst (list n index) pair indices :test 'equal) ) (setq name (intern (format nil "~a~a_~a" name index n))) )) (setf (get name 'sex) (if fem 'female 'male)) ; clean up properties, in case a prior run generated the same name (remprop name 'mother) (remprop name 'father) (remprop name 'children) (remprop name 'spouses) (remprop name 'mates) (setq *npeople* (+ *npeople* 1)) (push name *people*) ; global list name )); end of new-person (defun print-personal-data (person) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Print mother, father, spouses & nonspousal mates (if any), and children ; (if any), sorted by co-parent ; (let ((others (set-difference (get person 'mates) (get person 'spouses))) sorted-children lines) (format t "~%~a ~a mother: ~a father: ~a" person (get person 'sex) (get person 'mother) (get person 'father) ) (if (or (get person 'spouses) others) (format t "~% spouses: ~a nonspousal mates: ~a" (get person 'spouses) others )) (when (get person 'children) (setq sorted-children (sort-children person)) (setq sorted-children (apply #'append (mapcar #'(lambda (x) (cons (format nil " children with") (cons (format nil "~a:" (car x)) (cdr x)) )) sorted-children ))) ; print up to 6 words per line (where "children with" = 1 word) (setq lines (ceiling (/ (length sorted-children) 6))) (dotimes (i lines) (if (zerop i) (format t "~% ") (format t "~% ") ) (dotimes (j (min 6 (length sorted-children))) (format t " ~a" (pop sorted-children)) ))) )); end of print-personal-data (defun sort-children (person) ; ~~~~~~~~~~~~~~~~~~~~~~~~~~ ; For the given person (a parent), form a list of lists of form ; ((other-parent1 child11 child12 ...) ... (other-parentk childk1 childk2 ...)) ; (prog ((children (get person 'children)) (mates (get person 'mates)) (fem (eq (get person 'sex) 'female)) result ) (if (null children) (return nil)) (dolist (c children); temporarily tag mates with lists of children (push c (get (get c (if fem 'father 'mother)) 'child-list)) ) (dolist (mate mates) (when (get mate 'child-list) (push (cons mate (get mate 'child-list)) result) (remprop mate 'child-list) )) (return (reverse result)) )); end of sort-children (defun parents (person) ;~~~~~~~~~~~~~~~~~~~~~~ (remove nil (list (get person 'mother) (get person 'father))) ) (defun grandparents (person) ;~~~~~~~~~~~~~~~~~~~~~~~~~~ (union (parents (get person 'mother)) (parents (get person 'father)) )) (defun great-grandparents (person) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (union (grandparents (get person 'mother)) (grandparents (get person 'father)) )) (defun choose-wife (male females); ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Choose a wife for the given unmarried male from the given females, ; with preference for females with no spouses or mates, and no recent ; shared ancestry. The method is just to try a sequence of random ; choices, returning the "least encumbered" choice, with more ; trials if the male is "fastidious" (and no unencumbered female ; has been found). ; (let (maxtrials wife best-so-far inhib (min-inhib 12)) (setq maxtrials ; the more "fastidious" the male, the more trials ; to find a minimally encumbered wife (up to 20) (+ 1 (ceiling (/ *fastidiousness* (- 1.05 *fastidiousness*)))) ) (dotimes (i maxtrials) (setq wife (nth (random-choice 0 (- (length females) 1)) females) ) (setq inhib (inhibition male wife)) (if (zerop inhib) (return-from choose-wife wife)) (when (< inhib min-inhib) (setq best-so-far wife) (setq min-inhib inhib) )) best-so-far )); end of choose-wife (defun choose-mate (male females) ;~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ; Similar to choose-wife, except that the top choice in case the male ; is married is his wife (or one of his wives) ; (let (wives maxtrials fastidiousness mate best-so-far inhib (min-inhib 12)) (setq wives (get male 'spouses)) (setq wives; remove wives with maximum number of children (remove-if (lambda (x) (>= (length (get x 'children)) *lifetime-limit*)) wives )) (when wives (if (= 1 (return-1-with-prob (get male 'fidelity))) (return-from choose-mate (nth (random-choice 0 (- (length wives) 1)) wives) ))) (setq fastidiousness (get male 'fastidiousness)) (setq maxtrials ; the more "fastidious" the male, the more trials ; to find a minimally encumbered mate (up to 20) (+ 1 (ceiling (/ fastidiousness (- 1.05 fastidiousness)))) ) (dotimes (i maxtrials) (setq mate (nth (random-choice 0 (- (length females) 1)) females) ) (setq inhib (inhibition male mate)) (if (zerop inhib) (return-from choose-mate mate)) (when (< inhib min-inhib) (setq best-so-far mate) (setq min-inhib inhib) )) best-so-far )); end of choose-mate (defun inhibition (x y) ;~~~~~~~~~~~~~~~~~~~~~~ ; Assign inhibition values (against marriage or mating with y, from x's ; perspective) from 0 to 11 depending on relatedness and y's existing ; spouses, mates and children. Anything from 4 upward is "terrible". ; ; (The search for common parents, grandparents, & great-grandparents ; is done rather inefficiently here -- we could do better with a ; lowest-common-ancestors search up to great-grandparents.) ; (let ((inhib 0)) (cond ((equal (parents x) (parents y)) (setq inhib 4) ) ((intersection (parents x) (parents y)) (setq inhib 3) ) ((intersection (grandparents x) (grandparents y)) (setq inhib 2) ) ((intersection (great-grandparents x) (great-grandparents y)) (setq inhib 1) ) ) (if (get y 'spouses) (incf inhib 2)); avoid polyandry/polygamy (if (get y 'mates) (incf inhib)); avoid partners with children (if (>= (length (get y 'children)) *lifetime-limit*) (incf inhib 4)) inhib )); end of inhibition (defun world (query) ;~~~~~~~~~~~~~~~~~~ ; Answer queries of form "?", or an atomic wff, or one with one list element ; replaced by "?"; e.g., (P C1 C2), (? C1 C2), (P ? C2), (P C1 ?). When ; there are multiple answers, one is chosen randomly. If there is no positive ; answer, then for a query (P C1 ...Ck) without a question mark, the answer ; is (~ P C1 ...Ck); and for a query with a question mark, it is nil. ; (setq *nquestions* (+ *nquestions* 1)) (let (answers p pfacts n) (cond ((eq query '?) (setq p (nth (random-choice 0 (- *npredicates* 1)) *predicates*)) (setq pfacts (gethash p *pred-array-table*)) (setq n (array-total-size pfacts)) (aref pfacts (random-choice 0 (- n 1))) ) (t (setq answers (gethash query *world-table*)) (if answers (if (cdr answers); more than 1 answer? (nth (random-choice 0 (- (length answers) 1)) answers) ; one answer: (car answers) ) ; null answers (if (member '? query) nil (cons '~ query)) ))) )); end of world