# <![CDATA[
# KEHOME/src/hwalk.icn
# Oct/16/2005 Feb/13/2007
# Jun/9/2008 check for "i:"
# Jul/18/2008 use new OpenCyc Web Services
# Jul/28/2008 interaction,interevent
# Aug/17/2008 fix ho_map_symbol(), do_hierarchy() bug
# new definition of "primitive concept" May/19/2003
# number of units > 0
# treat kbmode=gdbm same as kbmode=mke Aug/21/2005
global USIZE, # count units in subhierarchy
CSIZE, # count concepts in subhierarchy
ULIST, # alphalist of units in subhierarchy
CLIST, # alphalist of concepts in subhierarchy
FSIZE, # count facts
HLEVEL, # count level
PATH, # path up/down
NEST, # nest of path up/down
LOOPSET, # loopset for path up/down
TOTALSET, # totalset for path up/down
EXPLEVEL # hlevel for isa**exp, isc**exp
record HOUNIT (
holist, # phraselist -- holist[1] is 0 or more / or \
hoend
)
# methods
#=======#
# ho_list(x)
# ho_end(x)
# ho_writes(fd,x)
# ho_unparse(fd,x)
# ho_tsize(x)
# ho_map_symbol(tsym,tok)
# hwalkN()
# hwalk()
# hdo()
# do_hierarchy()
# class()
# primitive()
# make_alphalist()
# get_rootname(hname,hstack)
# get_genlmt(v) # v genlmt generalized view
# get_specmt(v) # v specmt specialized view
# get_unit(x) # x isp unit
# get_primitive(x) # x isu primitive
# get_species(x) # x isg species
# get_genus(x) # x iss genus
# get_member(x) # x isall member
# get_ingroup(x) # x isalt ingroup
# get_alternative(x) # x isany alternative
# get_exgroup(x) # x ismem exgroup
# ...
#--------------------------------------#
# list
procedure ho_list(x)
#===================
return x.holist
end
# string
procedure ho_end(x)
#==================
return x.hoend
end
procedure ho_writes(fd,x)
#========================
writes(fd,"HOUNIT(")
writes_any(fd,x.holist)
writes(fd,",",x.hoend)
writes(fd,")")
end
# string
procedure ho_unparse(x)
#======================
local y
y := unparse(x.holist)
y ||:= unparse(x.hoend)
return y
end
# string
procedure ho_tsize(x)
#====================
local size
size := tsize(x.holist)
size +:= tsize(x.hoend)
return size
end
# string
procedure ho_map_symbol(tsym,tok)
#================================
local hsubject,hsemicolon
static info
initial {
info := "INFO: ho_map_symbol: "
}
if DEBUG=="MAP_SYMBOL" then {
writes_type(mybug,tsym,info||"tsym")
writes_type(mybug,tok,info||"tok")
}
hsubject := map_symbol(tsym.holist,tok)
hsemicolon := map_symbol(tsym.hoend,tok)
return HOUNIT(hsubject,hsemicolon)
end
#--------------------------------------#
# list
procedure hwalkN(nlevel,cname,action,direction,option,hfd)
#=========================================================
local dval,save_hmaxlevel
static info
initial {
info := "INFO: hwalkN: "
}
cname := unparse(cname)
action := unparse(action)
direction := unparse(direction)
if DEBUG==("HWALK"|"CYC") then {
writes_type(myerr,nlevel,info||"nlevel")
writes_type(myerr,cname,info||"cname")
writes_type(myerr,action,info||"action")
writes_type(myerr,direction,info||"direction")
}
save_hmaxlevel := HMAXLEVEL
#HMAXLEVEL := nlevel
put_parameter("hmaxlevel",nlevel)
dval := hwalk(cname,action,direction,option,hfd)
put_parameter("hmaxlevel",save_hmaxlevel)
#HMAXLEVEL := save_hmaxlevel
if DEBUG==("HWALK"|"NSM") then {
writes_type_all(dval,info||"return dval")
}
return dval
end
# list
procedure hwalk(cname,action,direction,option,hfd)
#=================================================
local checkname
local actlist
local uset
local uplist,downlist,save_hoseparator
local pname,aname
local act,dir,q,kbmode,cresult,hfrom,hto,gname,uname
local failed,aborting,pid,notdir
local cshortname,wname,ename
local krmode,dbmode,gset,line
local units,gtype
local head
local savedir
static b
static hlevel, hcount, info, warning,error,ierror,ferror
initial {
hlevel := 0
hcount := 0
info := "INFO: hwalk: "
warning := "WARNING: hwalk: "
error := "ERROR: hwalk: "
ierror := "Internal ERROR: hwalk: "
ferror := "Fatal ERROR: hwalk: "
b := " "
}
/action := "name"; act := action
/direction := "genus"; dir := direction
/option := ""
/hfd := myout
cname := unparse(cname)
if DEBUG==("HWALK"|"CYC") then {
writes_type(myerr,cname,info||"cname")
writes_type(myerr,action,info||"action")
writes_type(myerr,direction,info||"direction")
writes_type(myerr,HMAXLEVEL,info||"HMAXLEVEL")
}
if action == "?" then {
actlist := hdo(cname,action,direction)
return actlist
}
save_hoseparator := get_parameter("hoseparator")
direction := dequote(direction) # allow "isa","isu",...
case direction of {
default: {
writes_type_all(direction,ierror||"unexpected direction")
}
"alpha": { }
"up": { }
"down": { }
("ISA"|"isa"|"isa*"): { direction := "ISA"}
("ISS"|"genus"|"iss"|"iss*"): { direction := "genus"}
("ISU"|"primitive"|"isu"|"isu*"): { direction := "primitive"}
("ISC"|"isc"|"isc*"): { direction := "ISC"}
("ISG"|"species"|"isg"|"isg*"): { direction := "species"}
("ISP"|"unit"|"isp"|"isp*"): { direction := "unit"}
("WHOLE"|"whole"|"isapart"|"isapart*"):{ direction := "whole"}
("PART"|"part"|"haspart"|"haspart*"): { direction := "part"}
("ISALL"|"member"|"isall"|"isall*"): { direction := "member"}
("ISMEM"|"ingroup"|"ismem"|"ismem*"): { direction := "ingroup"}
("ISANY"|"alternative"|"isany"|"isany*"): { direction := "alternative"}
("ISALT"|"exgroup"|"isalt"|"isalt*"): { direction := "exgroup"}
("means"|"means*"): { direction := "means"}
("isref"|"isref*"): { direction := "isref"}
("causes"|"causes*"): { direction := "causes"}
("because"|"because*"): { direction := "because"}
("before"|"before*"): { direction := "before"}
("after"|"after*"): { direction := "after"}
("below"|"below*"): { direction := "below"}
("above"|"above*"): { direction := "above"}
("beside"|"beside*"): { direction := "beside"}
("inside"|"inside*"): { direction := "inside"}
("outside"|"outside*"): { direction := "outside"}
("like"|"like*"): { direction := "like"}
("happensod"|"happensod*"): { direction := "happensod"}
"genlmt": { direction := "genlmt" }
"specmt": { direction := "specmt" }
"genlmt*": { direction := "genlmt" }
"specmt*": { direction := "specmt" }
} # end case direction
dir := direction
case direction of {
default: {
writes_type_all(direction,ierror||"unexpected direction")
}
"alpha": { }
"up": { put_parameter("hoseparator","\\") }
"down": { put_parameter("hoseparator","/") }
"ISA": { put_parameter("hoseparator","\\") }
"genus": { put_parameter("hoseparator","\\") }
"primitive": { put_parameter("hoseparator","\\") }
"ISC": { put_parameter("hoseparator","/") }
"species": { put_parameter("hoseparator","/") }
"unit": { put_parameter("hoseparator","/") }
"whole": { put_parameter("hoseparator","\\") }
"part": { put_parameter("hoseparator","/") }
"member": { put_parameter("hoseparator","/") }
"ingroup": { put_parameter("hoseparator","\\") }
"alternative": {put_parameter("hoseparator","/") }
"exgroup": { put_parameter("hoseparator","\\") }
"means": { put_parameter("hoseparator","/") }
"isref": { put_parameter("hoseparator","\\") }
"causes": { put_parameter("hoseparator","/") }
"because": { put_parameter("hoseparator","\\") }
"before": { put_parameter("hoseparator","/") }
"after": { put_parameter("hoseparator","\\") }
"below": { put_parameter("hoseparator","\\") }
"above": { put_parameter("hoseparator","/") }
"beside": { put_parameter("hoseparator","\\") }
"inside": { put_parameter("hoseparator","\\") }
"outside": { put_parameter("hoseparator","/") }
"like": { put_parameter("hoseparator","/") }
"happensod": { put_parameter("hoseparator","\\") }
"genlmt": { put_parameter("hoseparator","\\") }
"specmt": { put_parameter("hoseparator","/") }
"genlmt*": { put_parameter("hoseparator","\\") }
"specmt*": { put_parameter("hoseparator","/") }
} # end case direction
if DEBUG==("HDO"|"HWALK") then {
head := info||"hlevel <"||hlevel||"> direction <"||direction||
"> cname <"||cname||"> action"
writes_type(mybug,action,head)
writes_type(mylog,action,head)
}
cname := unparse(cname)
checkname := cname
checkname ?:= { ="i:" & tab(0) } # delete leading "i:"
if member(unique,checkname) then {
q := unique[checkname]
} else {
case KBMODE of {
default: {
write(myerr,warning,"cname <",checkname,"> not defined in <",STV,">")
write(mylog,warning,"cname <",checkname,"> not defined in <",STV,">")
}
"tap": { }
"cyc": { }
"odp": { }
"google": { }
"gdbm": { }
} # end case KBMODE
q := new_concept(cname)
} # end if member()
krmode := KNIT[q].krmode
dbmode := get_parameter("dbmode")
kbmode := get_parameter("kbmode")
if DEBUG==("HWALK"|"CYC") then {
writes_type(myerr,krmode,info||"krmode")
writes_type(myerr,dbmode,info||"dbmode")
writes_type(myerr,kbmode,info||"kbmode")
writes_type(myerr,KBMODE,info||"KBMODE")
}
cresult := []
case dir of {
"alpha": { }
default: { put(cresult, hdo(cname,act,hlevel,option,hfd)) }
#################################
} # end case dir
hlevel +:= 1
if hlevel > HMAXLEVEL then { # skip the rest
if HMAXLEVEL > 10 then {
# not isc**1, ..., isc**10
hcount +:= 1
if DEBUG=="LOOP" then {
write(mylog,warning,"hmaxlevel limit exceeded: "||
"hlevel=",hlevel," cname <",cname,">")
}
if hcount > HMAXCOUNT then {
writes_all([TypeComment,ferror,"hmaxlevel count exceeded: ",
"hcount=",hcount," hlevel=",hlevel," cname <",cname,">"])
interpret_line("exit;")
} # end if hcount > HMAXCOUNT
} # end if HMAXLEVEL
} else {
# check for mounted hierarchy
case dir of {
default: {
#####writes_type_all(dir,ierror||"unexpected dir")
}
("down"|"ISC"|"species"|"unit"|"member"|"alternative"|"action"|"event"): {
# down
if member(KNIT[q].attr,"mount") then {
if KNIT[q].attr["mount"] ? { ="from " & hfrom := tab(0) } then {
q := new_concept(hfrom)
if DEBUG=="MOUNT" then {
writes_type(mybug,q,info||"down mounted hierarchy: q")
writes_type(mylog,q,info||"down mounted hierarchy: q")
}
} # end if
} # end if
}
("up"|"ISA"|"genus"|"primitive"|"ingroup"|"exgroup"): {
# up
if member(KNIT[q].attr,"mount") then {
if KNIT[q].attr["mount"] ? { ="to " & hto := tab(0) } then {
q := new_concept(hto)
if DEBUG=="MOUNT" then {
writes_type(mybug,q,info||"up base hierarchy: q")
writes_type(mylog,q,info||"up base hierarchy: q")
}
} # end if
} # end if
}
} # end case dir
case dir of {
default:{
writes_type_all(dir,ierror||"unexpected dir")
}
"one": { }
"alpha":{ # alphabetical
every q := sort_key(KNIT) do
put(cresult, hdo(q,act,hlevel,option,hfd))
#############################
}
"genlmt": {
uplist := get_genlmt(cname)
delete(uplist,cname) # avoid infinite loop
if KNIT[q].mark > 1 then # repeat
uplist := []
every gname := ! sort(uplist) do
put(cresult, hwalk(gname,act,dir,option,hfd))
}
"specmt": {
downlist := get_specmt(cname)
delete(downlist,cname) # avoid infinite loop
if KNIT[q].mark > 1 then # repeat
downlist := []
every uname := ! sort(downlist) do
put(cresult, hwalk(uname,act,dir,option,hfd))
}
# NSM concepts
(
"means"|"isref"|
"causes"|"because"|
"before"|"after"|
"below"|"above"|
"beside"|"inside"|"outside"|
"like"|
"happensod"
): {
uset := to_set(unparse(KNIT[q].brel[dir]))
if DEBUG=="NSM" then {
writes_type_all(uset,info||cname||b||dir||b)
}
delete(uset,cname) # avoid infinite loop
every uname := ! sort(uset) do
put(cresult, hwalk(uname,act,dir,option,hfd))
}
"up": { # up all types
every gname := ! sort(get_genus(cname)) do
put(cresult, hwalk(gname,act,dir,option,hfd))
every gname := ! sort(get_primitive(cname)) do
put(cresult, hwalk(gname,act,dir,option,hfd))
every gname := ! sort(get_exgroup(cname)) do
put(cresult, hwalk(gname,act,dir,option,hfd))
every gname := ! sort(get_ingroup(cname)) do
put(cresult, hwalk(gname,act,dir,option,hfd))
}
"down": { # down all types -- some are list, not set
every uname := ! sort(get_species(cname)) do
put(cresult, hwalk(uname,act,dir,option,hfd))
every uname := ! sort(get_unit(cname)) do
put(cresult, hwalk(uname,act,dir,option,hfd))
downlist := get_alternative(cname)
case gtype := KNIT[q].attr["gtype"] of {
default: { }
"enum": { downlist := sort(downlist) }
}
every uname := ! downlist do
put(cresult, hwalk(uname,act,dir,option,hfd))
downlist := get_member(cname)
case gtype := KNIT[q].attr["gtype"] of {
default: { }
"set": { downlist := sort(downlist) }
("requisite"|"req"): { downlist := sort(downlist) }
}
every uname := ! downlist do
put(cresult, hwalk(uname,act,dir,option,hfd))
}
"ISA": { # up primitive & genus
uplist := get_genus(cname)
delete(uplist,cname) # avoid infinite loop
every gname := ! sort(uplist) do
put(cresult, hwalk(gname,act,dir,option,hfd))
uplist := get_primitive(cname)
delete(uplist,cname) # avoid infinite loop
every gname := ! sort(uplist) do
put(cresult, hwalk(gname,act,dir,option,hfd))
}
"ISC": { # down unit & species
downlist := get_species(cname)
delete(downlist,cname) # avoid infinite loop
every uname := ! sort(downlist) do
put(cresult, hwalk(uname,act,dir,option,hfd))
downlist := get_unit(cname)
delete(downlist,cname) # avoid infinite loop
every uname := ! sort(downlist) do
put(cresult, hwalk(uname,act,dir,option,hfd))
}
"genus": { # up genus
uplist := get_genus(cname)
delete(uplist,cname) # avoid infinite loop
if KNIT[q].mark > 1 then # repeat
uplist := []
every gname := ! sort(uplist) do
put(cresult, hwalk(gname,act,dir,option,hfd))
}
"species": { # down species
downlist := get_species(cname)
delete(downlist,cname) # avoid infinite loop
if KNIT[q].mark > 1 then # repeat
downlist := []
every uname := ! sort(downlist) do
put(cresult, hwalk(uname,act,dir,option,hfd))
}
"primitive":{ # up primitive
uplist := get_primitive(cname)
delete(uplist,cname) # avoid infinite loop
if KNIT[q].mark > 1 then # repeat
uplist := []
every gname := ! sort(uplist) do
put(cresult, hwalk(gname,act,dir,option,hfd))
}
"unit": { # down unit
downlist := get_unit(cname)
delete(downlist,cname) # avoid infinite loop
if KNIT[q].mark > 1 then # repeat
downlist := []
every uname := ! sort(downlist) do
put(cresult, hwalk(uname,act,dir,option,hfd))
}
"fsgenus":{ # up genus & primitive links (.. directory)
# now in cname/.. directory
failed := ierror||"fsgenus: FAILED: chdir"
aborting := info||"fsgenus: aborting recursion in directory"
every pname := ! sort(KNIT[q].genus++KNIT[q].primitive) do {
savedir := do_pwd()
if chdir("..") then {
# now in cname/../..
put(cresult, hwalk(pname,act,dir,option,hfd))
if chdir(savedir) then {
# back in cname/..
} else {
# still in cname/../.. directory
writes_type(myerr,pid,failed)
writes_type(mylog,pid,failed)
writes_type(myerr,cname||"/../..",aborting)
writes_type(mylog,cname||"/../..",aborting)
fail
} # end if chdir(savedir)
} else {
# still in cname/.. directory
writes_type(myerr,"..",failed)
writes_type(mylog,"..",failed)
} # end if chdir("..")
} # end every pname
} # end "fsgenus"
"fsunit":{ # down species & unit links (fsunit() directories)
# now in cname/.. directory
failed := ierror||"fsunit: FAILED: chdir"
aborting := info||"fsunit: aborting recursion in directory"
notdir := warning||"fsunit: not directory"
cshortname := get_char("attr",cname,"shortname") | cname
#####if is_directory(cshortname) then {
every uname := ! sort(KNIT[q].species++KNIT[q].unit) do {
if chdir(cshortname) then {
# now in cname
put(cresult, hwalk(uname,act,dir,option,hfd))
if chdir("..") then {
# back in cname/..
} else {
# still in cname directory
writes_type(myerr,"..",failed)
writes_type(mylog,"..",failed)
writes_type(myerr,cshortname,aborting)
writes_type(mylog,cshortname,aborting)
fail
} # end if chdir("..")
} else {
# still in cname/.. directory
writes_type(myerr,cshortname,failed)
writes_type(mylog,cshortname,failed)
} # end if chdir(cshortname)
} # end every uname
#####} else {
###### still in cname/..
#####writes_type(myerr,cshortname,notdir)
#####writes_type(mylog,cshortname,notdir)
#####} # end if is_directory(cshortname)
} # end "fsunit"
"exgroup":{ # up exgroup - do NOT sort
uplist := get_exgroup(cname)
delete(uplist,cname) # avoid infinite loop
every wname := ! uplist do
put(cresult, hwalk(wname,act,dir,option,hfd))
}
"alternative": { # down alternative - do NOT sort unless enum
downlist := get_alternative(cname)
list_delete(downlist,cname) # avoid infinite loop
case gtype := KNIT[q].attr["gtype"] of {
default: { }
"enum": { downlist := sort(downlist) }
}
every uname := ! downlist do
put(cresult, hwalk(uname,act,dir,option,hfd))
}
"ingroup":{ # up ingroup - do NOT sort
uplist := get_ingroup(cname)
delete(uplist,cname) # avoid infinite loop
every wname := ! uplist do
put(cresult, hwalk(wname,act,dir,option,hfd))
}
"member": { # down member - do NOT sort unless Set or requisite
downlist := get_member(cname)
list_delete(downlist,cname) # avoid infinite loop
case gtype := KNIT[q].attr["gtype"] of {
default: { }
"set": { downlist := sort(downlist) }
("requisite"|"req"): { downlist := sort(downlist) }
}
every uname := ! downlist do
put(cresult, hwalk(uname,act,dir,option,hfd))
}
"action": { # down act & a_event
every aname := key(KNIT[q].act) do {
every ename := ! KNIT[q].act[aname] do
put(cresult, hwalk(aname,act,"event",option,hfd))
}
}
"event": {
}
} # end case dir
} # end if hlevel > HMAXLEVEL
hlevel -:= 1
put_parameter("hoseparator",save_hoseparator)
if DEBUG==("HWALK"|"NSM") then {
writes_type_all(cresult,info||"return cresult")
}
return cresult
end
# string
procedure hdo(cname,action,hlevel,option,hfd)
#============================================
local dval
local uname
local head,clabel,mark
local fd,q,tabunit,prefix
local units,ftype,ctype
local cshortname,crootname,cclassname
local ushortname,urootname,uclassname
local moreinfo,failed
static info,ierror,warning, dirlevel
static stop
initial {
dirlevel := 0
info := "INFO: hdo: "
ierror := "Internal ERROR: hdo: "
warning := "WARNING: hdo: "
stop := "STOP: hdo: "
/HTAB := 2
}
/hlevel := 0
/option := ""
/hfd := myout
fd := hfd
if DEBUG==("HDO"|"HWALK") then {
head := info||"hlevel <"||hlevel||"> cname <"||cname||"> action"
writes_type(mybug,action,head)
writes_type(mylog,action,head)
}
if action == "?" then {
NCOMMAND -:= 1
NQUESTION +:= 1
# hdo ? done; # without "ke"
dval := write_char(myout,"ke","hact")
return dval
}
#q := unique[cname]
q := new_concept(cname) # return q
tabunit := repl(" ",HTAB)
prefix := repl(tabunit,hlevel)
if (HLOOP == "count") ||
(KBMODE == "cyc")
then {
case action of {
"print": {
action := "cycprint"
}
} # end case
} # end if
# update visit count - check for repeats/loops
case action of {
"mark0": { KNIT[q].mark := 0; return q }
"mark1": { KNIT[q].mark +:= 1; return q }
"cycprint": {
case hlevel of {
0: {
hwalk(cname,"mark0","alpha")
KNIT[q].mark +:= 1
clabel := cname
print_concept(fd,clabel,hlevel)
}
default: {
KNIT[q].mark +:= 1
case mark := KNIT[q].mark of {
1: {
clabel := cname
print_concept(fd,clabel,hlevel)
}
default: {
clabel := "["||mark||"]" ||cname
print_concept(fd,clabel,hlevel)
if HLOOP == "stop" then {
writes_all(TypeComment||stop||"HLOOP = "||HLOOP)
do_exit()
}
}
} # end case mark
}
} # end case hlevel
return q
} # end "cycprint"
} # end case action
if type(action)=="procedure" then {
writes_type(mylog,action,info||"executing procedure")
action(cname,hlevel,hfd)
return q
}
case action of {
default: {
KERROR +:= 1
write(mylog,TypeComment||ierror,"unexpected action <",action,">",
" cname <",cname,"> hlevel <",hlevel,">")
}
"name": { write(fd,prefix,cname) }
"print": { print_concept(fd,cname,hlevel) }
"unithierarchy":{
units := sort(get_unit(cname))
if *units > 0 then {
print_concept(fd,cname,0)
every print_concept(fd,!units,1)
}
}
"write": { write_concept(fd,cname,hlevel) }
"dump": { dump_concept(fd,cname,hlevel) }
"define": { write_definition(fd,cname) }
"echar": { write_char(fd,cname,"echar",hlevel) }
"rel": { write_char(fd,cname,"rel",hlevel) }
"attr": { write_char(fd,cname,"attr",hlevel) }
"part": { write_char(fd,cname,"PART",hlevel) }
"act": { write_char(fd,cname,"act",hlevel) }
"eobj": { write_char(fd,cname,"eobj",hlevel) }
"action": { write_char(fd,cname,"action",hlevel) }
"event": { write_char(fd,cname,"event",hlevel) }
"interaction": { write_char(fd,cname,"interaction",hlevel) }
"interevent": { write_char(fd,cname,"interevent",hlevel) }
#####"mark0": { KNIT[q].mark := 0 }
#####"mark1": { KNIT[q].mark +:= 1 }
"csize": { CSIZE +:= 1 }
"psize": { if *KNIT[q].unit > 0 then CSIZE +:= 1 }
"usize": { USIZE +:= *KNIT[q].unit }
"altsize": { USIZE +:= *KNIT[q].alternative }
"memsize": { USIZE +:= *KNIT[q].member }
"clist": { put(CLIST,cname) }
"plist": { if *KNIT[q].unit > 0 then put(CLIST,cname) }
"ulist": { every put(ULIST,!KNIT[q].unit) }
"altlist": { every put(ULIST,!KNIT[q].alternative) }
"memlist": { every put(ULIST,!KNIT[q].member) }
"factsize": { FSIZE +:= *KNIT[q].fact }
"hlevel": { if hlevel > HLEVEL then HLEVEL := hlevel }
"explevel": { if hlevel = EXPLEVEL then put(ULIST,cname) }
#==============================================================#
# record path though hierarchy
"species_path":{ # species path
if *PATH = 0 & *NEST > 0 then {
PATH := NEST[-1][1+:hlevel]
}
put(PATH,cname)
if *KNIT[q].species = 0 then {
put(NEST,PATH)
PATH := []
if DEBUG == "PATH" then
hprint(fd,NEST,,"NEST = ")
}
} # end "species_path"
"genus_path":{ # genus path
if *PATH = 0 & *NEST > 0 then
PATH := NEST[-1][1+:hlevel]
put(PATH,cname)
if *KNIT[q].genus = 0 then {
put(NEST,PATH)
PATH := []
if DEBUG == "PATH" then
hprint(fd,NEST,,"NEST = ")
}
} # end "genus_path"
"unit_path":{ # unit path
if *PATH = 0 & *NEST > 0 then {
PATH := NEST[-1][1+:hlevel]
}
put(PATH,cname)
if *KNIT[q].unit = 0 then {
put(NEST,PATH)
PATH := []
if DEBUG == "PATH" then
hprint(fd,NEST,,"NEST = ")
}
} # end "unit_path"
"primitive_path":{ # primitive path
if *PATH = 0 & *NEST > 0 then
PATH := NEST[-1][1+:hlevel]
put(PATH,cname)
if *KNIT[q].primitive = 0 then {
put(NEST,PATH)
PATH := []
if DEBUG == "PATH" then
hprint(fd,NEST,,"NEST = ")
}
} # end "primitive_path"
"alternative_path":{ # alternative path
if *PATH = 0 & *NEST > 0 then {
PATH := NEST[-1][1+:hlevel]
}
put(PATH,cname)
if *KNIT[q].alternative = 0 then {
put(NEST,PATH)
PATH := []
if DEBUG == "PATH" then
hprint(fd,NEST,,"NEST = ")
}
} # end "alternative_path"
"exgroup_path":{ # exgroup path
if *PATH = 0 & *NEST > 0 then
PATH := NEST[-1][1+:hlevel]
put(PATH,cname)
if *KNIT[q].exgroup = 0 then {
put(NEST,PATH)
PATH := []
if DEBUG == "PATH" then
hprint(fd,NEST,,"NEST = ")
}
} # end "exgroup_path"
"member_path":{ # member path
if *PATH = 0 & *NEST > 0 then {
PATH := NEST[-1][1+:hlevel]
}
put(PATH,cname)
if *KNIT[q].member = 0 then {
put(NEST,PATH)
PATH := []
if DEBUG == "PATH" then
hprint(fd,NEST,,"NEST = ")
}
} # end "member_path"
"ingroup_path":{ # ingroup path
if *PATH = 0 & *NEST > 0 then
PATH := NEST[-1][1+:hlevel]
put(PATH,cname)
if *KNIT[q].ingroup = 0 then {
put(NEST,PATH)
PATH := []
if DEBUG == "PATH" then
hprint(fd,NEST,,"NEST = ")
}
} # end "ingroup_path"
#==============================================================#
# read/write file system
# record shortname, rootname, classname
# use rootname for add_species(), new_concept(), put_char()
# use shortname for fsunit(), chdir(), mkdir()
"read directory": { # file system
#==============#
# from fs fsgenus-fsunit to ku genus-species
# option not currently needed
# execution sequence:
# do read directory od cname from fsdir done
# read_directory(cname,fsdir,option) # dir.icn
# action := "read directory"
# path := "fsunit"
# hwalk(cname,action,path,option,fd) in directory cname/..
# hdo(cname,action,hlevel,option,fd) in directory cname/..
moreinfo := info||action||": "||hlevel||": "
if DEBUG==("DIR"|"DIRECTORY") then {
writes_type(mylog,cname,moreinfo||"cname")
}
# set path
if *PATH = 0 & *NEST > 0 then {
PATH := NEST[-1][1+:hlevel]
}
cshortname := get_char("attr",cname,"shortname") | cname
put(PATH,cshortname)
crootname := unparse(PATH,"/")
#cclassname := unparse(reverse_list(PATH),"\\")
cclassname := unparse(reverse(PATH),"\\")
put_char("attr",crootname,"shortname",cshortname)
put_char("attr",crootname,"rootname",crootname)
put_char("attr",crootname,"classname",cclassname)
units := fsunit(cshortname,"nodot") # read directory cname
if *units = 0 then {
put(NEST,PATH)
PATH := []
if DEBUG == "PATH" then
hprint(fd,NEST,,"NEST = ")
} # end if *units
# link species to cname
every uname := !units do {
ushortname := uname
urootname := crootname||"/"||uname
uclassname := uname||"\\"||cclassname
put_char("attr",urootname,"shortname",ushortname)
put_char("attr",urootname,"rootname",urootname)
put_char("attr",urootname,"classname",uclassname)
ftype := get_ftype(cshortname||"/"||ushortname)
add_file(urootname,crootname,ftype) # dir.icn
} # end every uname
} # end "read directory"
"write directory": { # file system
#===============#
# from ku genus-species to fs fsgenus-fsunit
# option not currently needed
# execution sequence:
# do write directory od cname to fsdir done
# write_directory(cname,fsdir,option) # dir.icn
# action := "write directory"
# path := "fsunit"
# hwalk(cname,action,path,option,fd) in directory cname/..
# hdo(cname,action,hlevel,option,fd) in directory cname/..
moreinfo := info||action||": "||hlevel||": "
failed := ierror||action||": "||hlevel||": FAILED: "
# create new file -- directory or regular
ctype := get_ctype(cname)
cshortname := get_char("attr",cname,"shortname") | cname
if DEBUG==("DIR"|"DIRECTORY") then {
writes_type(mylog,cname,moreinfo||"cname")
writes_type(mylog,cshortname,moreinfo||"cshortname")
}
if mkfile(cshortname,ctype) then { # dir.icn
# set path
if *PATH = 0 & *NEST > 0 then {
PATH := NEST[-1][1+:hlevel]
}
put(PATH,cshortname)
crootname := unparse(PATH,"/")
#cclassname := unparse(reverse_list(PATH),"\\")
cclassname := unparse(reverse(PATH),"\\")
put_char("attr",crootname,"shortname",cshortname)
put_char("attr",crootname,"rootname",crootname)
put_char("attr",crootname,"classname",cclassname)
if *KNIT[q].species = 0 then {
put(NEST,PATH)
PATH := []
if DEBUG == "PATH" then
hprint(fd,NEST,,"NEST = ")
}
} else {
writes_type(myerr,cshortname,failed||"mkdir")
writes_type(mylog,cshortname,failed||"mkdir")
##### put(NEST,PATH)
##### PATH := []
##### if DEBUG == "PATH" then
##### hprint(fd,NEST,,"NEST = ")
}
} # end "write directory"
#==============================================================#
} # end case action
return q
end
procedure do_hierarchy(ho)
#=========================
# process hierarchy definition
# ho ::= [[hlevel,hname], ...]
# called by interp_ho() in sentence.icn
# called by ho_init() in init.icn
# called by primitive_init() in init.icn
# called by directory_init() in init.icn
# KFORMAT ::=
# ho hierarchy,lattice,... add_species() shortname
# hounit unithierarchy,... add_unit() shortname
# dir directory add_file() rootname
local hstack,i,hpair,hlevel,hname,toplevel,topname
local rname
local atab
local head
local kformat,kinfo,kwarning,kerror
static info,warning,error,ierror
initial {
info := "INFO: do_hierarchy"
warning := "WARNING: do_hierarchy"
error := "ERROR: do_hierarchy"
ierror := "InternalERROR: do_hierarchy: "
}
case kformat := KFORMAT of {
("ho"|"hounit"|"dir"): { }
default: { writes_type_all(kformat,ierror||"unexpected KFORMAT"); fail }
}
kinfo := info||"("||kformat||"): "
kwarning := warning||"("||kformat||"): "
kerror := error||"("||kformat||"): "
if DEBUG==("HO"|"HOUNIT"|"DIR") then {
writes_type(mybug,ho,kinfo||"ho")
writes_type(mylog,ho,kinfo||"ho")
}
if *ho = 0 then {
###if DEBUG==("HO"|"HIERARCHY"|"PRIMITIVE"|"DIR") then
writes_type_all(ho,kwarning||"null hierarchy")
fail
}
toplevel := ho[1][1]
if toplevel ~= 0 then {
KERROR +:= 1
head := kerror||"ho start level not 0"
writes_type(myerr,ho,head)
writes_type(mylog,ho,head)
}
topname := ho[1][2]
#####writes_type_all(topname,kinfo||"topname")
new_concept(topname)
hstack := []
push(hstack,ho[1])
every i := 2 to *ho do {
hpair := ho[i]
hlevel := hpair[1]; hname := hpair[2]
toplevel := hstack[1][1]; topname := hstack[1][2]
if DEBUG == ("HO"|"HOUNIT"|"DIR") then {
writes_type_all(hname,kinfo||"hname")
writes_type_all(topname,kinfo||"topname")
}
if hlevel > toplevel + 1 then {
KERROR +:= 1
head := kerror||"ho level change not 1"
writes_type(myerr,ho,head)
writes_type(mylog,ho,head)
} else if hlevel = toplevel + 1 then {
case KFORMAT of {
"dir": {
hname := get_rootname(hname,hstack) # hwalk.icn
topname := get_rootname("",hstack) # hwalk.icn
add_file(hname,topname) # dir.icn
}
"ho": { add_species(hname,topname) } # hop.icn
"hounit": {
add_unit(hname,topname) # hop.icn
atab := KNIT[new_concept(topname)].attr
}
} # end case KFORMAT
} else {
while hlevel <= toplevel do {
if pop(hstack) then {
} else {
KERROR +:= 1
head := kerror||"ho end level <= start level"
writes_type(myerr,ho,head)
writes_type(mylog,ho,head)
return
} # end if pop()
toplevel := hstack[1][1]; topname := hstack[1][2]
} # end while hlevel
case KFORMAT of {
"dir": {
hname := get_rootname(hname,hstack) # hwalk.icn
topname := get_rootname("",hstack) # hwalk.icn
add_file(hname,topname) # dir.icn
}
"ho": { add_species(hname,topname) } # hop.icn
"hounit": { add_unit( hname,topname) } # hop.icn
} # end case KFORMAT
} # end if hlevel
push(hstack,hpair)
} # end every i
end
# string
procedure get_rootname(hname,hstack)
#===================================
local pair,classlist,rootname
static info
initial {
info := "INFO: get_rootname: "
}
if *hname > 0 then {
classlist := [hname]
} else {
classlist := []
}
every pair := !hstack do {
put(classlist,pair[2])
}
rootname := unparse(reverse(classlist),"/")
if DEBUG=="ROOTNAME" then {
writes_type(mybug,hname,info||"hname")
writes_type(mybug,hstack,info||"hstack")
writes_type(mybug,classlist,info||"classlist")
writes_type(mybug,rootname,info||"rootname")
}
return rootname
end
procedure hprint(fd,H,format,head,tail)
#======================================
writes(fd,head)
hwrite(fd,H,format)
write(fd,tail)
end
procedure hwrite(fd,H,format)
#============================
# H is any form of nested list
local TabUnit,fmt,start,prefix,suffix,t,u
static hlevel, maxlevel
initial { hlevel := 0; maxlevel := 20 }
TabUnit := repl(" ",HTAB)
fmt := \format | "level"
case fmt of {
"outline": {
start := ""
prefix := repl(TabUnit,hlevel)
suffix := "\n"
stop := ""
}
"level": {
start := "["
prefix := "<"
suffix := ">"
stop := "]"
}
} # end case fmt
t := type(H)
case t of {
("string"|"integer"):{
writes(fd,prefix,H,suffix)
}
"list": {
writes(fd,start)
hlevel +:= 1
every u := ! H do {
hwrite(fd,u,fmt)
}
hlevel -:= 1
writes(fd,stop)
}
"PHRASE": { hwrite(fd,H.pvalue,fmt) }
default: { writes(fd,prefix,"UNEXPECTED ",t,suffix) }
} # end case t
end
# list of isalist
procedure isa_list(uname,cname,top)
#==================================
# uname isa* cname
# return nest ::= list of [uname,...,cname]
local qu,qc,y,z,path,i
static info
initial {
info := "INFO: isa_list: "
}
/top := "existent"
/cname := top
if DEBUG=="ISA" then {
writes_all([TypeComment||info,
"uname <"||uname||">",
" cname <"||cname||">",
" top <"||top||">\n"])
}
qu := new_concept(uname)
qc := new_concept(cname)
y := genus_path(uname)
z := []
every path := ! y do {
every i := 1 to *path do {
if new_concept(path[i]) == qc then {
put(z,path[1+:i])
break
}
}
}
if DEBUG == "YES" then
writes_any(mybug,z,,"# INFO: isa_list("||uname||","||cname||") <",">\n")
return z
end
# list of isaset
procedure isa_set(uset)
#=======================
# uset isa* set([existent])
# uset isa gset isa ... isa set([existent])
# return nest ::= [uset,gset,...,set([existent])]
local nest,gset,uname,q
static info
initial {
info := "INFO: isa_set: "
}
if DEBUG=="ISA" then {
writes_type_all(uset,info||"uset")
}
nest := []
if *uset > 0 then
put(nest,uset)
gset := set()
every uname := ! uset do {
q := new_concept(uname)
gset ++:= KNIT[q].genus
}
case *gset of {
0: { return nest }
default: { return nest ||| isa_set(gset) }
} # end case
end
# set
procedure isa_loop(uset,path)
#============================
# return LOOPSET if genus path contains loop
# called from check__loop() in check.icn
local checkset
local q,gset,pset,eset,iset
local newset
static info,ierror
initial {
info := "INFO: isa_loop: "
ierror := "Internal ERROR: isa_loop: "
}
/path := "genus"
if DEBUG=="ISA" then {
writes_type_all(uset,info||"uset")
writes_type_all(path,info||"path")
}
# check for corrupted existent
q := new_concept("existent")
gset := KNIT[q].genus
if *gset > 0 then
writes_type(mylog,gset,ierror||"existent iss")
pset := KNIT[q].primitive
if *pset > 0 then
writes_type(mylog,pset,ierror||"existent isu")
eset := KNIT[q].exgroup
#####if *eset > 0 then
##### writes_type(mylog,eset,ierror||"existent isalt")
###### existent ismem existence
#####iset := KNIT[q].ingroup
#####if *iset > 1 then
##### writes_type(mylog,iset,ierror||"existent ismem")
#####q := new_concept("existence")
#####iset := KNIT[q].ingroup
#####if *iset > 0 then
##### writes_type(mylog,iset,ierror||"existence ismem")
LOOPSET := set()
TOTALSET := set()
newset := isa_new(uset,path)
if DEBUG=="LOOP" then {
writes_type(mybug,uset,info||"uset")
write(mybug,TypeComment||info||"*uset=",*uset,
" *LOOPSET=",*LOOPSET," *TOTALSET=",*TOTALSET)
}
if *newset > 0 then {
writes_type(mylog,uset,info||"uset")
writes_type(mylog,newset,ierror||"set not empty: newset")
}
# check if parallel paths or loop
case *LOOPSET of {
0: { }
default: {
newset := LOOPSET
LOOPSET := set()
TOTALSET := set()
checkset := isa_new(newset,path)
}
}
return LOOPSET
end
# set
procedure isa_new(uset,path)
#===========================
# return newset of genus path
# adapted from isa_set()
local gset,uname,q,newset,repeatset
static hlevel,info,warning,ierror
initial {
hlevel := 0
info := "INFO: isa_new: "
warning := "WARNING: isa_new: "
ierror := "Internal ERROR: isa_new: "
}
/path := "genus"
if DEBUG=="ISA" then {
writes_type_all(uset,info||"uset")
writes_type_all(path,info||"path")
}
if hlevel > HMAXLEVEL then {
write(mylog,TypeComment||warning||"hmaxlevel limit exceeded: hlevel=",hlevel,
" *uset=",*uset)
return set()
}
gset := set()
every uname := ! uset do {
q := new_concept(uname)
case path of {
default: { writes_type_all(path,ierror||"unexpected path"); return set() }
"genus": { gset ++:= KNIT[q].genus }
"primitive": { gset ++:= KNIT[q].primitive }
"exgroup": { gset ++:= KNIT[q].exgroup }
"ingroup": { gset ++:= KNIT[q].ingroup }
"genlmt": { gset ++:= KNIT[q].genlmt }
"means": { gset ++:= to_set(unparse(KNIT[q].brel["means"])) }
"because": { gset ++:= to_set(unparse(KNIT[q].brel["because"])) }
"before": { gset ++:= to_set(unparse(KNIT[q].brel["before"])) }
"below": { gset ++:= to_set(unparse(KNIT[q].brel["below"])) }
"beside": { gset ++:= to_set(unparse(KNIT[q].brel["beside"])) }
"inside": { gset ++:= to_set(unparse(KNIT[q].brel["inside"])) }
"outside": { gset ++:= to_set(unparse(KNIT[q].brel["outside"])) }
"like": { gset ++:= to_set(unparse(KNIT[q].brel["like"])) }
"happensod":{ gset ++:= to_set(unparse(KNIT[q].brel["happensod"])) }
} # end case path
}
# "existent" can't cause loop -- checked in isa_loop()
delete(gset,"existent")
TOTALSET ++:= uset
newset := gset -- TOTALSET
repeatset := gset ** TOTALSET
LOOPSET ++:= repeatset
if DEBUG=="LOOP" then {
writes_type(mybug,hlevel, info||"hlevel")
writes_type(mybug,uset, info||"uset")
writes_type(mybug,TOTALSET, info||"TOTALSET")
writes_type(mybug,newset, info||"newset")
writes_type(mybug,repeatset,info||"repeatset")
writes_type(mybug,LOOPSET, info||"LOOPSET")
}
case *newset of {
0: { }
default: {
hlevel +:= 1
newset := isa_new(newset,path)
hlevel -:= 1
}
} # end case
return newset
end
# list of set
procedure isc_nest(cnameset)
#===========================
# return list of set { cnameset isc uset }
local nest,uset,cname,q
static info
initial {
info := "INFO: isc_nest: "
}
if DEBUG=="ISC" then {
writes_type_all(cnameset,info||"cnameset")
}
nest := []
put(nest,cnameset)
uset := set()
every cname := ! cnameset do {
q := new_concept(cname)
uset ++:= KNIT[q].species
}
case *uset of {
0: { return nest }
default: { return nest ||| isc_nest(uset) }
} # end case
end
procedure distance(uname,cname)
#==============================
local useqi,cseqi
local c,useq,udistlist,udist,cseq,cdistlist,cdist,dist
c := class(set([uname,cname]))
useq := isa_list(uname,c)
if *useq > 1 then
writes_any(mylog,useq,,"# WARNING: distance: multiple paths useq <",">\n")
udistlist := []
every useqi := ! useq do
put(udistlist,*(useqi) - 1)
udist := min_list(udistlist)
cseq := isa_list(cname,c)
if *cseq > 1 then
writes_any(mylog,cseq,,"# WARNING: distance: multiple paths cseq <",">\n")
cdistlist := []
every cseqi := ! cseq do
put(cdistlist,*(cseqi) - 1)
cdist := min_list(cdistlist)
if same_concept(c,cname) then {
dist := udist
} else if same_concept(c,uname) then {
dist := cdist
} else {
dist := udist + cdist
}
return dist
end
# string
procedure class(cnameset,top)
#============================
# Upper is set of all UpperBound concepts such that
# forall cname in cnameset ( cname isa* UpperBound )
# LeastUpperBound, if it exists, is the unique concept such that
# forall UpperBound in Upper ( LeastUpperBound isa* UpperBound )
# LeastUpperBound, if it exists, is equal to Class
# Class, which always exists, is the unique concept such that
# forall cname in cnameset ( cname isa* class )
# forall cname in cnameset ( isa_list(cname) ^ isa_list(class) = isa_list(class) ) <== ???
# Class must be determined using uid of each concept (alias problem)
local qset,q1,q2,isa12,isa21
local i,risa,minlen,qname,qisa,j,rev,revlen
local result,lubset,class2
static info
initial {
info := "INFO: class: "
}
/top := "existent"
if DEBUG==("CLASS"|"LUB") then {
writes_type_all(cnameset,info||"cnameset")
writes_type_all(top,info||"top")
}
qset := set()
every insert(qset,new_concept(!cnameset))
case *qset of {
0: { fail }
1: { return !qset }
2: {
q1 := ! qset
q2 := ! delete(qset,q1)
isa12 := isa_list(q1,q2)
isa21 := isa_list(q2,q1)
if *isa12 > 0 then {
# q1 isa* q2
return q2
} else if *isa21 > 0 then {
# q2 isa* q1
return q1
} else {
# isa_list(class) is a common ending subsequence
# find it using the reverse isa_list of each concept
i := 0
risa := []
minlen := 1000
every qname := ! [q1,q2] do {
qisa := isa_list(qname,top) # all isa paths: qname, ..., top
every j := 1 to *qisa do {
i +:= 1
#rev := reverse_list(qisa[j])
rev := reverse(qisa[j])
put(risa,rev)
revlen := *rev
if minlen > revlen then
minlen := revlen
if DEBUG==("CLASS"|"LUB") then {
writes_any(mybug,rev,,"# INFO: class: "||
qname||": risa["||i||"] = ","\n")
}
}
}
result := set([top])
every j := 1 to minlen do {
lubset := set()
every i := 1 to *risa do
insert(lubset,risa[i][j])
if DEBUG==("CLASS"|"LUB") then {
writes_any(mybug,lubset,,"# INFO: class: lubset["||j||"]: ","\n")
}
if *lubset = 1 then
result := lubset
else
break
}
return ! result
} # end if
} # end 2
default: { # recurse
qname := ! qset
class2 := class(delete(qset,qname))
return class([qname,class2])
}
} # end case *cnameset
end
# set
procedure primitive(cnameset)
#============================
# return primitive concepts of cnameset
local primset,cname
static info
initial {
info := "INFO: primitive: "
}
if DEBUG == "PRIMITIVE" then {
writes_type(mybug,sort(cnameset),info||"cnameset")
writes_type(mylog,sort(cnameset),info||"cnameset")
}
primset := set()
every cname := ! cnameset do {
primset ++:= set(plist(cname))
}
if DEBUG == "PRIMITIVE" then {
writes_type(mybug,sort(primset),info||"primset")
writes_type(mylog,sort(primset),info||"primset")
}
return primset
end
#####procedure prim(cname)
######====================
###### return set of primitives of cname
#####primlist := plist(cname)
#####return set(primlist)
#####end
# list
procedure make_alphalist(knit,cname)
#===================================
# make a sorted list of all concept|unit isa* existent
# or all concept|unit isa* cname
local alphalist,index
static info
initial {
info := "INFO: make_alphalist: "
}
/knit := KNIT
/cname := ""
if *cname > 0 then {
alphalist := set2list( set(clist(cname)) ++ set(ulist(cname)) )
alphalist := sort(alphalist)
} else {
alphalist := []
every index := sort_key(knit) do {
put(alphalist,index)
if DEBUG==("CONCEPT"|"UNIT") then {
writes_type(mybug,index,info||"knit key")
writes_type(mylog,index,info||"knit key")
}
} # end every index
}
return alphalist
end
procedure species_path(cname)
#=========================
NEST := []
PATH := []
hwalk(cname,"species_path","species")
return NEST
end
procedure genus_path(cname)
#==========================
NEST := []
PATH := []
hwalk(cname,"genus_path","genus")
return NEST
end
procedure unit_path(cname)
#=========================
NEST := []
PATH := []
hwalk(cname,"unit_path","unit")
return NEST
end
procedure primitive_path(cname)
#============================
NEST := []
PATH := []
hwalk(cname,"primitive_path","primitive")
return NEST
end
procedure alternative_path(cname)
#================================
NEST := []
PATH := []
hwalk(cname,"alternative_path","alternative")
return NEST
end
procedure exgroup_path(cname)
#============================
NEST := []
PATH := []
hwalk(cname,"exgroup_path","exgroup")
return NEST
end
procedure member_path(cname)
#===========================
NEST := []
PATH := []
hwalk(cname,"member_path","member")
return NEST
end
procedure ingroup_path(cname)
#==========================
NEST := []
PATH := []
hwalk(cname,"ingroup_path","ingroup")
return NEST
end
procedure isclist(cname)
#=======================
# alphalist of units & concepts in cname subhierarchy
CLIST := []
hwalk(cname,"clist","ISC")
return sort(CLIST)
end
procedure clist(cname)
#=====================
# alphalist of concepts in cname subhierarchy
CLIST := []
hwalk(cname,"clist","species")
return sort(CLIST)
end
procedure slist(cname)
#=====================
# remove cname from clist
return get(clist(cname))
end
procedure plist(cname)
#=====================
# alphalist of primitive concepts in cname subhierarchy
CLIST := []
hwalk(cname,"plist","species")
return sort(CLIST)
end
procedure ulist(cname)
#=====================
# alphalist of units in cname subhierarchy
ULIST := []
hwalk(cname,"ulist","species")
return sort(ULIST)
end
procedure altlist(cname)
#=======================
# alphalist of alternatives in cname subhierarchy
ULIST := []
hwalk(cname,"altlist","species")
return sort(ULIST)
end
procedure memlist(cname)
#=======================
# alphalist of members in cname subhierarchy
ULIST := []
hwalk(cname,"memlist","species")
return sort(ULIST)
end
procedure glist(cname)
#=====================
# alphalist of genus concepts in cname superhierarchy
CLIST := []
hwalk(cname,"clist","genus")
return sort(CLIST)
end
procedure genus_list(cname)
#==========================
# alphalist of genus concepts in cname superhierarchy
return glist(cname)
end
procedure species_list(cname)
#============================
# alphalist of species concepts in cname subhierarchy
return slist(cname)
end
procedure primitive_list(cname)
#=======----===================
# alphalist of primitive concepts in cname superhierarchy
return plist(cname)
end
procedure unit_list(cname)
#=========================
# alphalist of unit concepts in cname subhierarchy
return ulist(cname)
end
procedure csize(cname)
#=====================
# count concepts in cname subhierarchy
# psize := count of first-level concepts
# psize + 1 <= csize <= (csize + 1)*psize/2
CSIZE := 0
hwalk(cname,"csize","species")
return CSIZE
end
procedure ssize(cname)
#=====================
# don't count cname
return csize(cname) - 1
end
procedure psize(cname)
#=====================
# count primitive concepts in cname subhierarchy
CSIZE := 0
hwalk(cname,"psize","ISC")
return CSIZE
end
procedure usize(cname)
#=====================
# count units in cname subhierarchy
USIZE := 0
hwalk(cname,"usize","ISC")
return USIZE
end
procedure altsize(cname)
#=======================
# count units in cname subhierarchy
USIZE := 0
hwalk(cname,"altsize","alternative")
return USIZE
end
procedure memsize(cname)
#=======================
# count units in cname subhierarchy
USIZE := 0
hwalk(cname,"memsize","member")
return USIZE
end
procedure factsize(cname)
#========================
# count facts in cname subhierarchy
FSIZE := 0
hwalk(cname,"factsize","ISC")
return FSIZE
end
procedure hlevel(cname)
#======================
# distance of cname from existent
HLEVEL := -1
hwalk(cname,"hlevel","ISA")
return HLEVEL
end
procedure hdepth(cname)
#======================
# distance of cname from lowest unit|primitive
HLEVEL := -1
hwalk(cname,"hlevel","ISC")
return HLEVEL
end
procedure isa_exp(cname,exp)
#===========================
EXPLEVEL := exp
ULIST := []
hwalk(cname,"explevel","ISA")
return ULIST
end
procedure isc_exp(cname,exp)
#===========================
EXPLEVEL := exp
ULIST := []
hwalk(cname,"explevel","ISC")
return ULIST
end
#============================================================#
#============================================================#
# set
procedure get_genlmt(x)
#======================
# up the Microtheory lattice
local q,answer,question,svopad,symbol
local cmdline,line
local mkrline,cycline
static info,warning
initial {
info := "INFO: get_genlmt: "
warning := "WARNING: get_genlmt: "
}
if DEBUG=="HWALK" then {
writes_type(myerr,x,info||"x")
}
if answer := cache_get(x,"genlmt") then {
} else {
case KBMODE of {
("mke"|"gdbm"): {
q := new_concept(x)
answer := KNIT[q].genlmt
}
"tap": {
svopad := [x,"genlmt","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := tap_question("hwalk",question,symbol,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" genlmt "||x
writes_type(mylog,line,warning||"infinite loop ")
delete(answer,x)
}
}
"cycws": {
answer := wsget_genlmt(x)
}
"cyc": {
mkrline := x||" genlmt ?x;"
cycline := "(#$genlMt "||x||" ?x)"
answer := cyc_answer(cycline,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" genlmt "||x
writes_type(mylog,line,warning||"infinite loop ")
#####delete(answer,x)
}
if x == ("BaseKB"|"#$BaseKB") then {
if *answer > 0 then {
line := x||" genlmt "||unparse(answer)
writes_type(mylog,line,warning||"infinite loop ")
#####answer := set()
} # end if
} # end if
}
("google"|"dmoz"|"odp"): {
answer := google_genlmt(x)
}
}
cache_put(x,"genlmt",answer)
} # end if cache_get()
if DEBUG=="HWALK" then {
writes_type(myerr,answer,info||"answer")
}
return answer
end
# set
procedure get_specmt(x)
#======================
# down the Microtheory lattice
local q,answer,question,svopad,symbol
local cmdline,line
local mkrline,cycline
static info,warning
initial {
info := "INFO: get_specmt: "
warning := "WARNING: get_specmt: "
}
if DEBUG=="HWALK" then {
writes_type(myerr,x,info||"x")
}
if answer := cache_get(x,"specmt") then {
} else {
case KBMODE of {
("mke"|"gdbm"): {
q := new_concept(x)
answer := KNIT[q].specmt
}
"tap": {
svopad := [x,"specmt","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := tap_question("hwalk",question,symbol,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" specmt "||x
writes_type(mylog,line,warning||"infinite loop ")
#####delete(answer,x)
}
case x of {
default: { }
"Resource": {
case *answer of {
0: { }
default: {
line := x||" type "||unparse(answer)
writes_type(mylog,line,warning||"infinite loop ")
#####answer := set()
}
} # end case *answer
}
} # end case x
}
"cycws": {
answer := wsget_specmt(x)
}
"cyc": {
mkrline := "?x genlmt "||x||";"
cycline := "(#$genlMt ?x "||x||")"
answer := cyc_answer(cycline,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" genlmt "||x
writes_type(mylog,line,warning||"infinite loop ")
#####delete(answer,x)
}
if member(answer,"BaseKB") then {
line := "BaseKB"||" genlmt "||x
writes_type(mylog,line,warning||"infinite loop ")
#####delete(answer,"BaseKB")
} # end if
if member(answer,"#$BaseKB") then {
line := "#$BaseKB"||" genlmt "||x
writes_type(mylog,line,warning||"infinite loop ")
#####delete(answer,"#$BaseKB")
} # end if
}
("google"|"dmoz"|"odp"): {
answer := google_specmt(x)
}
}
cache_put(x,"specmt",answer)
} # end if cache_get()
if DEBUG=="HWALK" then {
writes_type(myerr,answer,info||"answer")
}
return answer
end
# set
procedure get_unit(x)
#====================
local q,answer,question,svopad,symbol
local mkrline,cycline,line
static info,warning
initial {
info := "INFO: get_unit: "
warning := "WARNING: get_unit: "
}
if DEBUG=="HWALK" then {
writes_type(myerr,x,info||"x")
}
if answer := cache_get(x,"unit") then {
} else {
case KBMODE of {
("mke"|"gdbm"): {
q := new_concept(x)
answer := KNIT[q].unit
}
"tap": {
svopad := [x,"isp","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := tap_question("hwalk",question,symbol,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" type "||x
writes_type(mylog,line,warning||"infinite loop ")
delete(answer,x)
}
}
"cycws": {
answer := wsget_unit(x)
}
"cyc": {
mkrline := x||"' isp ?x;"
cycline := "(#$isa ?x "||x||")"
answer := cyc_answer(cycline,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" isp "||x
writes_type(mylog,line,warning||"infinite loop ")
#####delete(answer,x)
}
}
("google"|"dmoz"|"odp"): {
answer := google_unit(x)
}
}
cache_put(x,"unit",answer)
} # end if cache_get()
if DEBUG=="HWALK" then {
writes_type(myerr,answer,info||"answer")
}
return answer
end
# set
procedure get_primitive(x)
#=========================
local q,answer,question,svopad,symbol
local mkrline,cycline,line
static info,warning
initial {
info := "INFO: get_primitive: "
warning := "WARNING: get_primitive: "
}
if DEBUG=="HWALK" then {
writes_type(myerr,x,info||"x")
}
if answer := cache_get(x,"primitive") then {
} else {
case KBMODE of {
("mke"|"gdbm"): {
q := new_concept(x)
answer := KNIT[q].primitive
}
"tap": {
svopad := [x,"isu","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := tap_question("hwalk",question,symbol,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" type "||x
writes_type(mylog,line,warning||"infinite loop ")
delete(answer,x)
}
case x of {
default: { }
"Resource": {
case *answer of {
0: { }
default: {
line := x||" type "||unparse(answer)
writes_type(mylog,line,warning||"infinite loop ")
answer := set()
}
} # end case *answer
}
} # end case x
}
"cycws": {
answer := wsget_primitive(x)
}
"cyc": {
mkrline := x||" isu ?x;"
cycline := "(#$isa "||x||" ?x)"
answer := cyc_answer(cycline,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" isu "||x
writes_type(mylog,line,warning||"infinite loop ")
#####delete(answer,x)
}
case x of {
default: { }
"Thing": {
case *answer of {
0: { }
default: {
line := x||" isu "||unparse(answer)
writes_type(mylog,line,warning||"infinite loop ")
#####answer := set()
}
} # end case *answer
}
} # end case x
}
("google"|"dmoz"|"odp"): {
answer := google_primitive(x)
}
}
cache_put(x,"primitive",answer)
} # end if cache_get()
if DEBUG=="HWALK" then {
writes_type(myerr,answer,info||"answer")
}
return answer
end
# set
procedure get_species(x)
#=======================
local q,answer,question,svopad,symbol
local mkrline,cycline,line
static info,warning
initial {
info := "INFO: get_species: "
warning := "WARNING: get_species: "
}
if DEBUG=="HWALK" then {
writes_type(myerr,x,info||"x")
}
if answer := cache_get(x,"species") then {
} else {
case KBMODE of {
("mke"|"gdbm"): {
q := new_concept(x)
answer := KNIT[q].species
}
"tap": {
svopad := [x,"isg","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := tap_question("hwalk",question,symbol,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" subClassOf "||x
writes_type(mylog,line,warning||"infinite loop ")
delete(answer,x)
}
}
"cycws": {
answer := wsget_species(x)
}
"cyc": {
mkrline := x||" isg ?x;"
cycline := "(#$genls ?x "||x||")"
answer := cyc_answer(cycline,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" isg "||x
writes_type(mylog,line,warning||"infinite loop ")
#####delete(answer,x)
}
}
("google"|"dmoz"|"odp"): {
answer := google_species(x) # google.icn
}
}
cache_put(x,"species",answer)
} # end if cache_get()
if DEBUG=="HWALK" then {
writes_type(myerr,answer,info||"answer")
}
return answer
end
# set
procedure get_genus(x)
#=====================
local q,answer,question,svopad,symbol
local mkrline,cycline,line
static info,warning
initial {
info := "INFO: get_genus: "
warning := "WARNING: get_genus: "
}
if DEBUG=="HWALK" then {
writes_type(myerr,x,info||"x")
}
if answer := cache_get(x,"genus") then {
} else {
case KBMODE of {
("mke"|"gdbm"): {
q := new_concept(x)
answer := KNIT[q].genus
}
"tap": {
svopad := [x,"iss","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := tap_question("hwalk",question,symbol,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" subClassOf "||x
writes_type(mylog,line,warning||"infinite loop ")
delete(answer,x)
}
case x of {
default: { }
"Resource": {
case *answer of {
0: { }
default: {
line := x||" subClassOf "||unparse(answer)
writes_type(mylog,line,warning||"infinite loop ")
answer := set()
}
} # end case *answer
}
} # end case x
}
"cycws": {
answer := wsget_genus(x)
}
"cyc": {
mkrline := x||"' iss ?x;"
cycline := "(#$genls "||x||" ?x)"
answer := cyc_answer(cycline,"quiet")
answer := set(answer)
if member(answer,x) then {
line := x||" iss "||x
writes_type(mylog,line,warning||"infinite loop ")
#####delete(answer,x)
}
case x of {
default: { }
"Thing": {
case *answer of {
0: { }
default: {
line := x||" genls "||unparse(answer)
writes_type(mylog,line,warning||"infinite loop ")
#####answer := set()
}
} # end case *answer
}
} # end case x
}
("google"|"dmoz"|"odp"): {
answer := google_genus(x)
}
}
cache_put(x,"genus",answer)
} # end if cache_get()
if DEBUG=="HWALK" then {
writes_type(myerr,answer,info||"answer")
}
return answer
end
#============================================================#
# list
procedure get_member(x)
#======================
local q,answer,question,svopad,symbol
local cmdline
static info,warning
initial {
info := "INFO: get_member: "
warning := "WARNING: get_member: "
}
if DEBUG=="HWALK" then {
writes_type(myerr,x,info||"x")
}
if answer := cache_get(x,"member") then {
} else {
case KBMODE of {
("mke"|"gdbm"): {
q := new_concept(x)
answer := KNIT[q].member
}
"tap": {
svopad := [x,"isall","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := tap_question("hwalk",question,symbol,"quiet")
}
"cycws": {
answer := wsget_member(x)
}
"cyc": {
svopad := [x,"isall","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := cyc_question("hwalk",question,symbol,"quiet")
}
("google"|"dmoz"|"odp"): {
answer := google_member(x)
}
}
cache_put(x,"member",answer)
} # end if cache_get()
if DEBUG=="HWALK" then {
writes_type(myerr,answer,info||"answer")
}
return answer
end
# set
procedure get_ingroup(x)
#=======================
local q,answer,question,svopad,symbol
local cmdline
static info,warning
initial {
info := "INFO: get_ingroup: "
warning := "WARNING: get_ingroup: "
}
if DEBUG=="HWALK" then {
writes_type(myerr,x,info||"x")
}
if answer := cache_get(x,"ingroup") then {
} else {
case KBMODE of {
("mke"|"gdbm"): {
q := new_concept(x)
answer := KNIT[q].ingroup
}
"tap": {
svopad := [x,"ismem","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := tap_question("hwalk",question,symbol,"quiet")
answer := set(answer)
}
"cycws": {
answer := wsget_ingroup(x)
}
"cyc": {
svopad := [x,"ismem","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := cyc_question("hwalk",question,symbol,"quiet")
answer := set(answer)
}
("google"|"dmoz"|"odp"): {
answer := google_ingroup(x)
}
}
cache_put(x,"ingroup",answer)
} # end if cache_get()
if DEBUG=="HWALK" then {
writes_type(myerr,answer,info||"answer")
}
return answer
end
# list
procedure get_alternative(x)
#===========================
local q,answer,question,svopad,symbol
local cmdline
static info,warning
initial {
info := "INFO: get_alternative: "
warning := "WARNING: get_alternative: "
}
if DEBUG=="HWALK" then {
writes_type(myerr,x,info||"x")
}
if answer := cache_get(x,"alternative") then {
} else {
case KBMODE of {
("mke"|"gdbm"): {
q := new_concept(x)
answer := KNIT[q].alternative
}
"tap": {
svopad := [x,"isany","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := tap_question("hwalk",question,symbol,"quiet")
}
"cycws": {
answer := wsget_member(x)
}
"cyc": {
svopad := [x,"isany","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := cyc_question("hwalk",question,symbol,"quiet")
}
("google"|"dmoz"|"odp"): {
answer := google_alternative(x)
}
}
cache_put(x,"alternative",answer)
} # end if cache_get()
if DEBUG=="HWALK" then {
writes_type(myerr,answer,info||"answer")
}
return answer
end
# set
procedure get_exgroup(x)
#=======================
local q,answer,question,svopad,symbol
local cmdline
static info,warning
initial {
info := "INFO: get_exgroup: "
warning := "WARNING: get_exgroup: "
}
if DEBUG=="HWALK" then {
writes_type(myerr,x,info||"x")
}
if answer := cache_get(x,"exgroup") then {
} else {
case KBMODE of {
("mke"|"gdbm"): {
q := new_concept(x)
answer := KNIT[q].exgroup
}
"tap": {
svopad := [x,"isalt","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := tap_question("hwalk",question,symbol,"quiet")
answer := set(answer)
}
"cycws": {
answer := wsget_exgroup(x)
}
"cyc": {
svopad := [x,"isalt","?"]
symbol := SYMBOL("qobject",svopad)
question := unparse(svopad," ")
answer := cyc_question("hwalk",question,symbol,"quiet")
answer := set(answer)
}
("google"|"dmoz"|"odp"): {
answer := google_exgroup(x)
}
}
cache_put(x,"exgroup",answer)
} # end if cache_get()
if DEBUG=="HWALK" then {
writes_type(myerr,answer,info||"answer")
}
return answer
end
# ]]>