# # KEHOME/src/child.icn # Richard H. McCullough Oct/6/2003 Jul/20/2009 Aug/15/2014 Mar/29/2015 ##### $include "mkr_parser.h" $include "keparam.h" # procedures #==========# # family_tree(fname,husband,wife,child,htree) # get_child(typechild) # procedure_child(rname,nvtab) ## automatic: 5 proposition/infon ## meaning: 8 proposition/infon # # childtype isa attribute # #r_child is relation with # arity = "*", # tmode = gdbm,relKey = "$1_$2", # relLabel = (husband, wife, childtype/child...), # relType = (person, person, childtype/person), # relVariable = (1, 2, *), # automatic = none, # meaning = procedure_child; ## meaning = { ## $1_$2 is family with husband = $1,wife = $2; ## $1_$2 has child += ($*); ## $1,$2 has family_spouse += $1_$2; ## $1,$2 rel child += ($*); ## $1 has sex = male,has spouse += $2; ## $2 has sex = female,has spouse += $1; ## $* has family_child += $1_$2; ## $* has parent += ($1,$2); ## in hierarchy = familytree {$* iss $1,$2;}; ## }; # string procedure family_tree(fname,husband,wife,child,htree) #===================================================# # in hierarchy = htree {child iss husband,wife;}; local c,qc,qh,qw local fdebug static prog,b,colon,yyprefix initial { prog := "family_tree: " b := " " colon := ":" } fdebug := mylog yyprefix := yylineno||colon||yywordno||b||yyformat||b||prog /htree := "familytree" if /htree | (*htree = 0) then { write(&errout,yyprefix,"ERROR: null external hierarchy name") write(fdebug, yyprefix,"ERROR: null external hierarchy name") fail } ##if DEBUG == ("TREE"|"CHILD") then { write(fdebug,yyprefix,"htree = (",htree,") husband = (",husband,") wife = (",wife,") child = (",showparse(child),")") ##} qh := new_concept(husband,"person") qw := new_concept(wife,"person") every c := !child do { qc := new_concept(c,"person") hoadd_species(qc,qh,htree) hoadd_species(qc,qw,htree) } return htree end invocable "procedure_child" procedure procedure_child(rname,nvtab) #===================================== local htree,t local qc,qh,qw local pc,ph,pw local d1,d2,d3 local qfam,f,p,q local arity,j,dvar local typechild,i,tc local childtype,childtypelist local child,childlist local cache local fdebug static prog,b,colon,yyprefix static info initial { prog := "procedure_child: " b := " " colon := ":" info := "INFO: " } fdebug := mylog yyprefix := yylineno||colon||yywordno||b||yyformat||b||prog case rname of { default: { write(&errout,yyprefix,"ERROR: unexpected relation name (",rname,")"); fail } "r_child": { # initialization #--------------# if DEBUG == ("CHILD"|"DOLLAR") then { write_table(fdebug,nvtab,"nvtab",,yyprefix||rname,,"showparse") } d1 := unparse(nvtab["$1"]) # $1 = husband d2 := unparse(nvtab["$2"]) # $2 = wife qh := new_concept(d1,"person"); ph := new_person(qh) qw := new_concept(d2,"person"); pw := new_person(qw) d3 := unparse(nvtab["$*"]) # $* = childtype/child of first child tc := get_child(d3) childtypelist := [tc[1]] qc := new_concept(tc[2],"person"); pc := new_person(qc) childlist := [qc] arity := *nvtab - 1 # $0 $1 $2 ... every j := 4 to arity do { if j < 10 then dvar := "$"||j else dvar := "${"||j||"}" typechild := unparse(nvtab[dvar]) tc := get_child(typechild) put(childtypelist,tc[1]) qc := new_concept(tc[2],"person"); pc := new_person(qc) put(childlist,qc) } # end every j #####case type(childlist) of { #####"BSE": { childlist := bse_list(childlist) } #####default: { childlist := [unparse(childlist)] } #####} #####childlist := list_unparse(childlist) #####childlist := set(childlist) if DEBUG == "CHILD" then { write(fdebug,yyprefix,"husband = (",qh,") wife = (",qw,")") write(fdebug,yyprefix,"childtype = (",showparse(childtypelist),")") write(fdebug,yyprefix,"child = (",showparse(childlist),")") } # meaning #-------# # child iss husband,wife; # $1_$2 is family with husband = $1,wife = $2; # $1_$2 has child += [$*]; # ... qfam := family_name(qh,qw) q := new_concept(qfam,"family") t := family_tree(q,qh,qw,childlist,htree) # child.icn f := new_family(q,qh,qw,childlist) # ged.icn every i := 1 to *childlist do { if childtypelist[i] == "adopted" then { child := childlist[i] if DEBUG == "CHILD" then write(fdebug,yyprefix,"adopted child = (",child,")") qc := new_concept(child,"person") put_nv(qc,NVPHRASE(["adopted","+=",set(q)])) # qc has adopted += [q] put_nv(q, NVPHRASE(["adopted","+=",set(qc)])) # q has adopted += [qc] } # end if } # end every i } # end "r_child" } # end case rname end # # typechild ::= # type/child # child # default type ::= natural # # list procedure get_child(typechild) #============================= # typechild ::= childtype||"/"||child local i,tc local fdebug static prog,b,colon,yyprefix static sep initial { prog := "get_child: " b := " " colon := ":" sep := "/" } fdebug := mylog yyprefix := yylineno||colon||yywordno||b||yyformat||b||prog if DEBUG == "CHILD" then write(fdebug,yyprefix,"typechild = (",showparse(typechild),")") typechild := unparse(typechild) if i := upto(sep,typechild) then { tc := [ typechild[1:i],typechild[i+1:0] ] } else { tc := [ "natural",typechild ] } if DEBUG == "CHILD" then write(fdebug,yyprefix,"tc = (",showparse(tc),")") return tc end #