# <![CDATA[
# KEHOME/src/utility.icn
# Oct/16/2005
# Aug/30/2008 more arg error checking
# Aug/31/2008 average function
# Sep/2/2008 list_dollar
# utility functions for list/table/nest/...
# includes sum, scaning, ...
global TypeComment
global OutputFiles
# table
procedure list_dollar(tuple,dollar_tuple)
#========================================
# set $1,$2,... for list members
# adapted from nrel_dollar() in relation.icn
# used for dovalue list in everydo.icn
local i,dvar,dval
static info,warning
initial {
info := "INFO: list_dollar: "
warning := "WARNING: list_dollar: "
}
/dollar_tuple := table()
every i := 1 to *tuple do {
if i < 10 then {
dvar := "$"||i
} else {
dvar := "${"||i||"}" # a la KornShell
}
dval := tuple[i]
case *dval of {
default: { }
0: {
dval := &null
writes_type_all(dval,warning||"null value: "||dvar||" = ")
}
1: {
if dval[1] == "" then # empty string
dval[1] := "''"
}
} # end case *dval
insert(dollar_tuple,dvar,dval) # $i = argi
} # end every i
return dollar_tuple
end
# list
procedure list_delete(L,x)
#=========================
# L ::= list of string
# called by hwalk() in hwalk.icn
local y,z
z := []
every y := !L do
if y ~== x then
put(z,y)
return z
end
# string
procedure random(arglist)
#========================
# do random od concept:1,... done;
# do random od concept:1 done;
# choose random element of list
# called by command() in command.icn
local choice,clist,q,ctype,uset
clist := arglist
case *clist of {
1: { # concept - get units, species, members, alternatives
q := new_concept(!clist)
ctype := KNIT[q].ctype
case ctype of {
default: {
uset := KNIT[q].unit ++ KNIT[q].species
choice := ?uset
}
("ingroup"|"list"|"set"|"multiset"|"sequence"): {
uset := KNIT[q].member
choice := ?uset
}
("exgroup"|"enum"): {
uset := KNIT[q].alternative
choice := ?uset
}
} # end case ctype
} # end 1
default: { # concept list
choice := ?clist
}
} # end case *clist
choice := unparse(choice)
write(myout,choice)
return choice
end
procedure table_writes(fd,x,head,tail,lsep,lend,nvsep)
#=====================================================
/head := ""
/tail := ""
/lsep := ","
/lend := " "
/nvsep := " "||NVSEPARATOR||" "
writes(fd,head)
writes(fd,table_unparse(x,lsep,lend,nvsep)) # unparse.icn
writes(fd,tail)
end
procedure list_writes(fd,x,sep,head,tail,join,list0,list1,list2,string0)
#=======================================================================
local t,n,i,y
local list0left,list0right
local list1left,list1right
local list2left,list2right
static info,ierror
initial {
info := "INFO: list_writes: "
ierror := "Internal ERROR: list_writes: "
}
/sep := ","
/head := ""
/tail := ""
/join := NVSEPARATOR
/list0 := "[]" # length 0
/list1 := "" # length 1
/list2 := "[]" # length 2 or more
/string0 := "\"\"" # length 0
list0left := list0[1] | ""
list0right := list0[2] | ""
list1left := list1[1] | ""
list1right := list1[2] | ""
list2left := list2[1] | ""
list2right := list2[2] | ""
#writes(mybug,TypeComment||info||"list2 <",list2,">\n")
case t := type(x) of {
"list": { }
default: {
writes_type(myerr,x,ierror||"not list: x")
writes_type(mylog,x,ierror||"not list: x")
fail
}
}
writes(fd,head)
n := *x
i := 0
case n of {
0: { writes(fd,list0left) }
1: { writes(fd,list1left) }
default: { writes(fd,list2left) } # length 2 or more
}
every y := ! x do {
i +:= 1
writes_any(fd,y,sep,"","",join,list0,list1,list2,string0)
if i < n then
writes(fd,sep) # original comma separator removed by map_symbol()
}
case n of {
0: { writes(fd,list0right) }
1: { writes(fd,list1right) }
default: { writes(fd,list2right) } # length 2 or more
}
writes(fd,tail)
end
procedure set_writes(fd,x,sep,head,tail,join,list0,list1,list2,string0)
#======================================================================
# like list_writes(), but sort members
local y
static info
initial {
info := "INFO: set_writes: "
}
/sep := ","
/head := ""
/tail := ""
/join := NVSEPARATOR
/list0 := "[]" # length 0
/list1 := "" # length 1
/list2 := "[]" # length 2 or more
/string0 := "\"\"" # length 0
#writes(mybug,TypeComment||info||"list2 <",list2,">\n")
y := sort(x)
list_writes(fd,y,sep,head,tail,join,list0,list1,list2)
end
procedure writes_object(fd,x,sep,head,tail,join,list0,list1,list2,string0)
#=========================================================================
static info
initial {
info := "INFO: writes_object: "
}
/sep := ","
/head := ""
/tail := ""
/join := NVSEPARATOR
/list0 := "[]" # length 0
/list1 := "" # length 1
/list2 := "" # length 2 or more
/string0 := "\"\"" # length 0
#writes(mybug,TypeComment||info||"list2 <",list2,">\n")
writes_any(fd,x,sep,head,tail,join,list0,list1,list2,string0)
end
procedure writes_value(fd,x,sep,head,tail,join,list0,list1,list2,string0)
#========================================================================
local tcol
static info
initial {
info := "INFO: writes_value: "
}
#####tcol := "\n"||repl(" ",4)
#####case CHARFORMAT of {
#####default: { /sep := "," }
#####"line": { /sep := "," }
#####"column": { /sep := ","||tcol }
#####} # end case CHARFORMAT
/sep := ","
/head := ""
/tail := ""
/join := NVSEPARATOR
/list0 := "[]" # length 0
/list1 := "" # length 1
/list2 := "[]" # length 2 or more
/string0 := "\"\"" # length 0
#writes(mybug,TypeComment||info||"list2 <",list2,">\n")
writes_any(fd,x,sep,head,tail,join,list0,list1,list2,string0)
end
procedure writes_type_all(var,label,tail)
#========================================
# writes_type() to myout,myerr,mylog
local fd,OutputFiles
/tail := ">\n"
OutputFiles := [myout,myerr,mylog]
every fd := !OutputFiles do {
case fd of {
default: {
writes_type(fd,var,label,tail)
}
myerr: {
if \namein ~== "input" then {
writes_type(fd,var,label,tail)
}
}
} # end case fd
} # end every fd
end
procedure writes_any_all(var,sep,label,tail)
#========================================
# writes_any() to myout,myerr,mylog
local fd,OutputFiles
/sep := ","
/tail := ">\n"
OutputFiles := [myout,myerr,mylog]
every fd := !OutputFiles do {
case fd of {
default: {
writes_any(fd,var,sep,label,tail)
}
myerr: {
if \namein ~== "input" then {
writes_any(fd,var,sep,label,tail)
}
}
} # end case fd
} # end every fd
end
procedure writes_all(x,tail)
#===========================
# x ::= list of any
# write() to myout,myerr,mylog
local fd,outfiles
initial {
OutputFiles := [myout,myerr,mylog]
}
case namein of {
"input": { outfiles := [myout,mylog] }
default: { outfiles := OutputFiles }
}
/tail := "\n"
every fd := !outfiles do {
every writes_any(fd,!x); writes(fd,tail)
}
end
procedure writes_type(fd,x,label,tail)
#=====================================
# write x & its type
# typical TypeComment ::= TypeComment | "" | "\n"
local sep,head,join
local t,typeANDsize
initial {
/TypeComment := TypeComment
}
/label := "type"
sep := ","
t := type(x)
typeANDsize := t
case t of {
("string"|"list"|"set"|"table"): {
typeANDsize ||:= "["||*x||"]"
}
}
head := TypeComment||label ||"("||typeANDsize||") <"
/tail := ">\n"
join := NVSEPARATOR
writes_any(fd,x,sep,head,tail,join)
end
procedure writes_any(fd,x,sep,head,tail,join,list0,list1,list2,string0,option)
#=============================================================================
# bracket all list/set
local s,L,B,S,E
local tcol,t,n,i,j,k,name,op,value,y
local thead,tcont,tsep,ttail
static q,info
initial {
q := "\""
info := "INFO: writes_any: "
}
/sep := ","
/head := ""
/tail := ""
/join := NVSEPARATOR
/list0 := "[]" # length 0
/list1 := "" # length 1
/list2 := "[]" # length 2 or more
/string0 := "\"\"" # length 0
option := "nobad"
tcol := "\n"||repl(" ",4)
case CHARFORMAT of {
default: { thead := ""; tcont := sep; tsep := ""; ttail := "" }
"column": { thead := tcol; tcont := sep||tcol; tsep := ""; ttail := "" }
}
#writes(mybug,TypeComment||info||"list2 <",list2,">\n")
writes(fd,head)
case t := type(x) of {
default: { writes(fd,"UNEXPECTED TYPE <",t,">") }
# record types
"htmlstate": { print_htmlstate(fd,x) } # htmltest.icn
"htmlinput": { print_htmlinput(fd,x) } # htmltest.icn
"htmloutput": { print_htmloutput(fd,x) }# htmltest.icn
"PHRASE": { phrase_writes(fd,x) } # symbol.icn
"NVPHRASE": { nv_writes(fd,x) } # nvlist.icn
"AAPHRASE": { aa_writes(fd,x) } # array.icn
"BSE": { bse_writes(fd,x) } # bselist.icn
"PPOBJECT": { ppobject_writes(fd,x) } # pplist.icn
"GROUP": { group_writes(fd,x) } # begin.icn
"HOUNIT": { ho_writes(fd,x) } # hwalk.icn
"RELUNIT": { nrel_writes(fd,x) } # relation.icn
"WORD": {
writes(fd,"WORD(",x.wtype,",")
writes(fd,x.wvalue)
writes(fd,")")
}
"TOKEN": {
writes(fd,"TOKEN(",x.ttype,",")
writes(fd,x.tvalue)
writes(fd,")")
}
"SYMBOL": {
writes(fd,"SYMBOL(",x.stype,",")
case x.stype of {
default: { writes_any(fd,x.svalue,",") }
#"nv": { writes_any(fd,x.svalue," ") } # list: [name,=,value]
#"wp": { writes_any(fd,x.svalue," ") } # string: phrase # <== obsolete
}
writes(fd,")")
}
"XMLNS": {
writes(fd,"XMLNS(",x.nsname,",")
writes_any(fd,x.nsfile)
writes(fd,")")
}
"posix_stat": {
writes(fd,"posix_stat(")
n := *x
every i := 1 to n-1 do
writes(fd,x[i],tcont)
writes(fd,x[n])
writes(fd,")")
}
# other Icon types
"null": { writes(fd,"&null") }
"procedure": { writes(fd,image(x)) }
"co-expression": { writes(fd,image(x)) }
"window": { writes(fd,image(x)) }
"file": { writes(fd,image(x)) }
"cset": { writes(fd,image(x)) }
"integer": { writes(fd,x) }
"real": { writes(fd,x) }
"string": {
if *x = 0 then
writes(fd,string0)
else
writes(fd,x)
} # end "string"
"list": { list_writes(fd,x,sep,"","",join,list0,list1,list2) }
"set": { set_writes(fd,x,sep,"","",join,list0,list1,list2) }
"table":{
writes(fd,table_unparse(x)) # unparse.icn
##### n := *x
##### i := 0; j := 0
##### if n > 0 then writes(fd,thead)
##### every k := sort_key(x) do {
##### i +:= 1
##### name := k # name := sym2string(name)
##### op := join
##### value := x[k] # value := sym2string(value)
##### if option=="nobad" & bad_value(value) then { } else {
##### j +:= 1
##### if j > 1 then writes(fd,tcont)
##### writes_any(fd,name)
##### writes(fd,op)
##### # quote separator values - for later read
##### case name of {
##### default: { }
##### "hoseparator": { value := forcequote(value) } # hierarchy
##### "mseparator": { value := forcequote(value) } # method
##### "nvseparator": { value := forcequote(value) } # namevalue
##### "pseparator": { value := forcequote(value) } # phrase
##### "relseparator": { value := forcequote(value) } # relation
##### "roleseparator": { value := forcequote(value) } # role
#####
##### "automatic": { value := forcequote(value) } # "isa","isa*"
##### "kcase": { value := forcequote(value) } # "no"
##### "stv": { value := forcequote(value) } # "SPACE,TIME,VIEW"
##### } # end case name
##### writes_any(fd,value,sep,"","",join,"[]","",list2,"[]")
##### #if i < n then
##### # writes(fd,tsep)
##### } # end if
##### } # end every k
##### if n > 0 then writes(fd,ttail)
} # end "table"
} # end case type
writes(fd,tail)
end
#-----------------------------------------------------------#
# SYMBOL
procedure get_nv(cname,charname,chartype)
#========================================
# for context: space,time,view
local value,charvalue
static info
initial {
info := "INFO: get_nv: "
}
/chartype := "attr"
if DEBUG=="NV" then {
writes_type(mybug,cname,info||"cname")
writes_type(mybug,charname,info||"charname")
}
cname := unparse(cname)
charname := unparse(charname)
if charvalue := get_char(chartype,cname,charname) then {
if DEBUG=="NV" then {
writes_type(mybug,charvalue,info||"charvalue")
}
#value := unparse(charvalue)
#return SYMBOL("nv",[charname,NVSEPARATOR,value])
return new_nv([charname,NVSEPARATOR,charvalue])
} else {
fail
}
end
procedure put_nv(cname,nv,chartype)
#==================================
# for context: space,time,view
local t,st
local nov,charname,op,charvalue
static info,ierror
initial {
info := "INFO: put_nv: "
ierror := "Internal ERROR: put_nv: "
}
/chartype := "attr"
if DEBUG=="NV" then {
writes_type(mybug,cname,info||"cname")
writes_type(mybug,nv,info||"nv")
writes_type(mylog,cname,info||"cname")
writes_type(mylog,nv,info||"nv")
}
set_charnest(cname,[nv],chartype)
end
procedure writes_nv(fd,nv)
#=========================
local nov,charname,op,charvalue
static ierror
initial {
ierror := "Internal ERROR: writes_nv: "
}
nv_writes(fd,nv) # nvlist.icn
return
#==============#
case type(nv) of {
default: {
writes_type(mylog,nv,ierror||"unexpected type: nv")
fail
}
"SYMBOL": {
case nv.stype of {
default: {
writes_type(mylog,nv,ierror||"unexpected stype: nv")
fail
}
"nv": { nov := nv.svalue }
"nvnull": { nov := [nv.svalue,NVSEPARATOR,""] }
} # end "SYMBOL"
} # end case stype
} # end case type
charname := nov[1]
op := nov[2]
charvalue := nov[3]
charvalue := parse_list(charvalue)
writes_any(fd,charname)
case op of {
"=": { }
("+="|"-="|"*="): { writes(fd," ") } # for proper parsing as input
}
writes_any(fd,op)
writes_any(fd,charvalue)
end
# SYMBOL
procedure copy_nv(x)
#===================
# called by copy_event() in knit.icn
local y
static info,ierror
initial {
info := "INFO: copy_nv: "
ierror := "Internal ERROR: copy_nv: "
}
if DEBUG=="COPY" then
writes_type(mybug,x,info||"input")
case type(x) of {
default: {
writes_type(mylog,x,ierror||"unexpected type")
return x
}
"string": { return copy(x) }
"integer": { return copy(x) }
"real": { return copy(x) }
"list": { y := []; every put(y,copy_nv(!x)); return y }
"set": { y := []; every insert(y,copy_nv(!x)); return y }
"PHRASE": {
return PHRASE(copy(phrase_list(x)))
} # end "PHRASE"
"NVPHRASE": {
return new_nv(copy_nv(nv_novlist(x)))
} # end "NVPHRASE"
"SYMBOL": {
case x.stype of {
default: {
writes_type(mylog,x,ierror||"unexpected stype")
return x
}
"pplist": { return SYMBOL("pplist",copy_nv(x.svalue)) }
"pp": { return SYMBOL("pp", copy_nv(x.svalue)) }
"nv": { return SYMBOL("nv", copy_nv(x.svalue)) }
"nvnull": { return SYMBOL("nvnull",copy_nv(x.svalue)) }
"nvobject": { return SYMBOL("nvobject",copy_nv(x.svalue)) }
} # end case stype
} # end "SYMBOL"
} # end case type
end
#-------------------------------------------------------#
#-------------------------------------------------------#
# string
procedure mapquote(s,quotes)
#===========================
local q,qlist,qpair,qbegin,qend,qmark
local i
static info,ierror
initial {
info := "INFO: mapquote: "
ierror := "Internal ERROR: mapquote: "
}
/quotes := "\"\""
q := repl("n",*s)
case type(quotes) of {
default: {
writes_type(mylog,quotes,ierror||"unexpected quotes")
return q
}
"string": { qlist := [quotes] }
"list": { qlist := quotes }
}
every qpair := !qlist do {
case *qpair of {
default: {
writes_type(mylog,qpair,ierror||"unexpected qpair")
}
2: {
qbegin := qpair[1]
qend := qpair[2]
qmark := "n"
every i := 1 to *s do {
case qmark of {
"n": {
case s[i] of {
qbegin: { q[i] := "y"; qmark := "y" }
default:{ }
}
}
"y": {
case s[i] of {
qend: { q[i] := "y"; qmark := "n" }
default:{ q[i] := "y" }
}
}
} # end case qmark
} # end every i
} # end 2
} # end case *qpair
} # end every qpair
if DEBUG=="QUOTE" then {
writes_type(mybug,s,info||"s")
writes_type(mybug,q,info||"q")
}
return q
end
#-----------------------------------------------------------#
#-----------------------------------------------------------#
procedure write_nest(fd,nest,nsep,nhead,ntail)
#=============================================
# nest is list of x
local sep,head,tail,n,i
local x
sep := \nsep | ""
head := \nhead | "{"
tail := \ntail | "}"
writes(fd,head)
n := *nest
i := 0
every x := ! nest do {
i +:= 1
case type(x) of {
"string": { writes(fd,x) }
"list": { write_list(fd,x,"/","{","}") }
"set": { write_set (fd,x,"/","{","}") }
#"PHRASE": { write_list (fd,x.pvalue," "," "," ") }
default: { writes(fd,"UNEXPECTED TYPE") }
}
if i < n then
writes(fd,sep)
}
writes(fd,tail)
end
#-----------------------------------------------------------#
#-----------------------------------------------------------#
procedure nest_find(word,symbol,quote)
#=====================================
# find string s in nest of string
local i,j,k,gsym,sym,inquote
/quote := "\"\"" # do NOT match inside quote
every i := 1 to *symbol do {
gsym := symbol[i]
every j := 1 to *gsym do {
sym := gsym[j]
inquote := mapquote(sym,quote)
if k := find(word,sym) & inquote[k] == "n" then
suspend [i,j,k]
}
}
fail
end
procedure list_find(s,L,quote)
#=============================
# find string s in list of string
local i,j,inquote
/quote := "\"\"" # do NOT match inside quote
every i := 1 to *L do {
inquote := mapquote(L[i],quote)
if j := find(s,L[i]) & inquote[j] == "n" then {
suspend [i,j]
}
}
fail
end
procedure nest_match(word,symbol,quote)
#======================================
# match string s in nest of string
local i,j,k,gsym,sym,inquote
/quote := "\"\"" # do NOT match inside quote
every i := 1 to *symbol do {
gsym := symbol[i]
every j := 1 to *gsym do {
sym := gsym[j]
inquote := mapquote(sym,quote)
#write(mybug,"nest_match: word <",word,"> sym <",sym,"> inquote <",inquote,">")
if k := match(word,sym) & inquote[k - *word] == "n" then
return [i,j,k]
}
}
fail
end
procedure nest_rmatch(word,symbol,quote)
#=======================================
# match string s in nest of string
# scan backwards to find last occurrence
local i,j,k,gsym,sym,inquote
/quote := "\"\"" # do NOT match inside quote
every i := *symbol to 1 by -1 do {
gsym := symbol[i]
every j := *gsym to 1 by -1 do {
sym := gsym[j]
inquote := mapquote(sym,quote)
#write(mybug,"nest_match: word <",word,"> sym <",sym,"> inquote <",inquote,">")
if k := match(word,sym) & inquote[k - *word] == "n" then
return [i,j,k]
}
}
fail
end
procedure list_match(s,L,quote)
#==============================
# match string s in list of string
local i,j,inquote
/quote := "\"\"" # do NOT match inside quote
every i := 1 to *L do {
inquote := mapquote(L[i],quote)
if j := match(s,L[i]) & inquote[j - *s] == "n" then {
return [i,j]
}
}
fail
end
#-----------------------------------------------------------#
#-----------------------------------------------------------#
# list
procedure keylist(T)
#===================
# sorted list of keys of table
local x,L,S
L := []
every x := key(T) do
put(L,x)
S := sort(L)
return S
end
procedure sort_key(T)
#====================
# generate sorted keys of table
local x,L,S
L := []
every x := key(T) do
put(L,x)
S := sort(L)
every x := ! S do
suspend x
end
procedure sort_gen(G,object)
#===========================
# sort output of generator
local L
L := []
every put(L, G(object))
suspend ! sort(L)
end
procedure reverse_list(L)
#========================
return reverse(L)
#####local R
#####R := []
#####every x := ! L do
##### push(R,x)
#####return R
end
#-----------------------------------------------------------#
#-----------------------------------------------------------#
# time operations
# string
procedure to_ymd(time)
#=====================
local ymd
ymd := parse_time(time)
ymd := list2value(ymd," ")
return trimws(ymd)
end
# string
procedure to_dmy(time)
#=====================
local ymd,dmy
ymd := parse_time(time)
dmy := reverse(ymd)
dmy := list2value(dmy," ")
return trimws(dmy)
end
# string
procedure to_mdy(time)
#=====================
local ymd,mdy
ymd := parse_time(time)
mdy := [ymd[2],ymd[3],ymd[1]]
mdy := list2value(mdy," ")
return trimws(mdy)
end
# string or list
procedure get_date(cmd,time)
#===========================
local result
case cmd of {
default: { result := parse_time(time) }
"ymd": { result := to_ymd(time) }
"dmy": { result := to_dmy(time) }
"mdy": { result := to_dmy(time) }
"year": { result := get_year(time) }
"month": { result := get_month(time) }
"day": { result := get_day(time) }
}
return result
end
# list
procedure parse_time(time)
#=========================
# time ::=
# year/mon/day
# year mon day
local year,month,day,date
static sep,MONTH
initial {
sep := '/' ++ ' '
MONTH := ["Jan","Feb","Mar","Apr","May","Jun",
"Jul","Aug","Sep","Oct","Nov","Dec"]
}
if upto(sep,time) then { } else
return [time,"",""]
year := time
month := ""
day := ""
time ?:= { year := tab(upto(sep)) & move(1) & month := tab(0) }
time ?:= { month := tab(upto(sep)) & move(1) & day := tab(0) }
if *month > 0 & is_number(month) then
month := MONTH[month]
date := [year,month,day]
# check for different orders
if *day = 4 then # day/mon/year => year/mon/day
date[1] :=: date[3]
if numeric(date[2]) then # year/day/mon => year/mon/day
date[2] :=: date[3]
return date
end
# string
procedure get_year(time)
#=======================
# year of time
return parse_time(time)[1]
end
# string
procedure get_month(time)
#=======================
# month of time
return parse_time(time)[2]
end
# string
procedure get_day(time)
#=======================
# day of time
return parse_time(time)[3]
end
#-----------------------------------------------------------#
#-----------------------------------------------------------#
# numeric operations
# arglist ::= nest
procedure get_numeric(cmd,arglist)
#=================================
local result
if DEBUG=="NUMERIC" then
writes_type(mybug,arglist,"INFO: get_numeric: "||cmd||" arglist")
case cmd of {
default: {
write(myerr,arglist,,"# WARNING: illegal numeric command <"||cmd||" ",">\n")
fail
}
"min": { result := min_list(arglist) }
"max": { result := max_list(arglist) }
"sum": { result := list_sum(arglist) }
}
if DEBUG=="NUMERIC" then
writes_type(mybug,result,"INFO: get_numeric: "||cmd||" result")
return result
end
procedure min_list(L)
#====================
# minimum of units of list or set
# L ::= nest
local min, u, newmin
if *L = 0 then fail
min := numeric(L[1][1])
every u := !L do {
u := !u
u := unparse(u)
newmin := numeric(u)
if newmin < min then min := newmin
}
return min
end
procedure max_list(L)
#====================
# maximum of units of list or set
# L ::= nest
local max, u, newmax
if *L = 0 then fail
max := numeric(L[1][1])
every u := !L do {
u := !u
u := unparse(u)
newmax := numeric(u)
if newmax > max then max := newmax
}
return max
end
# real
procedure list_average(L)
#========================
# average of numbers in list or set
# L ::= list | set | gname
local avg,num,den
local u,gtype,arity,uset
static info,warning
initial {
info := "INFO: list_average: "
warning := "WARNING: list_average: "
}
if DEBUG == "AVERAGE" then {
writes_type_all(L,info||"L")
}
num := list_sum(L)
case type(L) of {
default:{ fail }
"null": { fail }
"list": { den := *L }
"set": { den := *L }
"string": {
# group name
u := unparse(L)
if DEBUG == "AVERAGE" then
writes_type_all(u,info||"u")
den := size_member(u)
} # end "string"
"relation": {
arity := get_arity(L)
if arity = 1 then {
uset := get_unit(L)
den := *uset
if DEBUG=="AVERAGE" then
writes_type_all(uset,info||"uset")
} else {
writes_type_all(arity,warning||"unexpected relation: arity")
fail
} # end if
}
} # end case type(L)
if /den then fail
if den = 0 then fail
avg := div(num,den)
if DEBUG == "AVERAGE" then {
writes_type_all(num,info||"num")
writes_type_all(den,info||"den")
writes_type_all(avg,info||"avg")
}
return avg
end
# integer
procedure list_sum(L)
#====================
# sum of numbers in list or set
# L ::= list | set | gname
# calls is_number() in newword.icn
local sum
static info,warning
initial {
info := "INFO: list_sum: "
warning := "WARNING: list_sum: "
}
sum := numeric(0)
case type(L) of {
default:{ }
"null": { }
"list": { every sum +:= numeric(!L) }
"set": { every sum +:= numeric(!L) }
"string": { # group name
sum := list_sum(get_member(L))
}
} # end case type(L)
if DEBUG=="SUM" then {
writes_type_all(sum,info||"sum")
}
return sum
end
#-----------------------------------------------------------#
#-----------------------------------------------------------#
# size operations
procedure table_sum(T,zero)
#==========================
# sum of table of count
# also known as bag or counted set
local z,x,sum
z := \zero | 0
sum := z
every x := key(T) do
sum +:= T[x]
return sum
end
procedure list_count(L,zero,increment)
#=====================================
# table of count of list unit
# also known as bag or counted set
local z,i,count,u
z := \zero | 0
i := \increment | 1
count := table(integer(z))
every u := !L do
count[u] +:= i
return count
end
procedure size_nest(N,zero)
#==========================
# list of size of nest unit
local ns,u
/zero := 0
ns := []
every u := !N do
put(ns,*u+zero)
return ns
end
#-----------------------------------------------------------#
#-----------------------------------------------------------#
# copy
procedure copy_nest(N)
#=====================
local nest,L
static warning
initial {
warning := "WARNING: copy_nest: "
}
case type(N) of {
default: {
writes_type_all(N,warning||"unexpected type: N")
}
"null": { fail }
"list": { }
}
nest := []
every L := ! N do
put(nest,copy_list(L))
return nest
end
procedure copy_set(S)
#====================
return set(copy_list(S))
end
procedure copy_list(L)
#=====================
# 2-level copy
local newlist,t
static warning
initial {
warning := "WARNING: copy_list: "
}
case t := type(L) of {
"null": { fail }
default: {
writes_type_all(L,warning||"unexpected type: L")
}
"string": {
writes_type(mylog,L,warning||"unexpected type: L")
return L
}
"list": { }
"set": { }
"BSE": { return bse_copy(L) }
}
newlist := []
every put(newlist,copy(!L))
return newlist
end
procedure copy_table(T,tdefault)
#===============================
local newtab,k
static warning
initial {
warning := "WARNING: copy_table: "
}
case type(T) of {
default: {
writes_type_all(T,warning||"unexpected type: T")
}
"null": { fail }
"table": { }
}
newtab := table(tdefault)
every k := key(T) do
newtab[k] := T[k]
return newtab
end
#-----------------------------------------------------#
#-----------------------------------------------------#
# windows
procedure dump_wattrib(fd,win,head,tail)
#=======================================
# print window attributes
local mlabel,miconlabel
local msize,mresize,mcursor,mecho,mcanvas
local mfont,mbg,mfg
local awin
static info,warning
initial {
info := "INFO: dump_wattr: "
warning := "WARNING: dump_wattr: "
}
/head := ""
/tail := ""
#awin := active_windows()
#every w := !awin do write(fd,"# INFO: ",image(w))
write(fd,TypeComment,head)
case type(win) of {
"null": {
writes_type(fd,win,info||"null window")
}
default: {
writes_type(fd,win,warning||"not window")
}
"window": {
mbg := WAttrib(win,"bg")
mcanvas := WAttrib(win,"canvas")
mcursor := WAttrib(win,"cursor")
mecho := WAttrib(win,"echo")
mfg := WAttrib(win,"fg")
mfont := Font(win)
miconlabel := WAttrib(win,"iconlabel")
mlabel := WAttrib(win,"label")
mresize := WAttrib(win,"resize")
msize := WAttrib(win,"size")
write(fd,"# window <",image(win),">")
write(fd,"# label <",miconlabel,">")
write(fd,"# iconlabel <",miconlabel,">")
write(fd,"# canvas <",mcanvas,">")
write(fd,"# size <",msize,">")
write(fd,"# resize <",mresize,">")
write(fd,"# cursor <",mcursor,">")
write(fd,"# echo <",mecho,">")
write(fd,"# font <",mfont,">")
write(fd,"# bg <",mbg,">")
write(fd,"# fg <",mfg,">")
} # end "window"
} # end case type
write(fd,TypeComment,tail)
end
# ]]>