# <![CDATA[
# KEHOME/src/child.icn
# Oct/6/2003
# Aug/25/2005 arraykey="$1_$2" (family)
# Aug/29/2005 variable arity
# Mar/11/2007 fix bug: &null at end of childlist
# Mar/14/2007 separate list for typechild & child
# Mar/15/2007 fix get_child() bug
# Mar/23/2007 fix ${j} bug -- j > 9
# Mar/24/2007 use rel instead of has
## automatic: 5 proposition/infon
## meaning: 8 proposition/infon
#
# childtype isa attribute
#
#r_child is relation with
# arity="*",
# arraymode=gdbm,arraykey="$1_$2",
# label=[husband, wife, childtype/child...],
# format=[person:1, person:2, childtype/person:*],
# 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,rel spouse +=$2;
## $2 has sex=female,rel spouse +=$1;
## $* has family_child +=$1_$2;
## $* rel parent +=[$1,$2];
## };
invocable "procedure_child"
procedure procedure_child(rname,nvtab)
#=====================================
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
static info
initial {
info := "INFO: procedure_child: "
}
case rname of {
"r_child": {
# initialization
#--------------#
if DEBUG=="CHILD" then {
table_writes(mybug,nvtab,"nvtab")
table_writes(mylog,nvtab,"nvtab")
}
d1 := unparse(nvtab["$1"]) # $1 = husband
d2 := unparse(nvtab["$2"]) # $2 = wife
d3 := unparse(nvtab["$*"]) # $* = childtype/child
tc := get_child(d3)
childtypelist := [tc[1]]
childlist := [tc[2]]
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])
put(childlist,tc[2])
} # 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 {
writes_type_all(d1,info||"husband")
writes_type_all(d2,info||"wife")
writes_type_all(childtypelist,info||"childtype")
writes_type_all(childlist,info||"child")
}
# meaning
#-------#
qfam := family_name(d1,d2)
f := new_family(qfam,d1,d2,childlist)# $1_$2 is family with husband=$1,wife=$2;
# $1_$2 has child =+[$*];
# ...
q := new_concept(qfam)
every i := 1 to *childlist do {
if childtypelist[i] == "adopted" then {
child := childlist[i]
if DEBUG=="CHILD" then
writes_type_all(child,info||"adopted child")
put_char("attr",child,"adopted",qfam,"+=") # $* has adopted +=qfam
put_char("attr",qfam,"adopted",child,"+=") # qfam has adopted +=$*
# OLD cache scheme
insert(CACHE[f].adopted,child)
p := new_cache(child,"person")
insert(CACHE[p].adopted,qfam)
} # end if get_childtype()
} # 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
static info,sep
initial {
info := "INFO: get_child: "
sep := "/"
}
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
writes_type_all(tc,info||"tc")
return tc
end
# ]]>