# # KEHOME/src/utility.icn # Richard H. McCullough Oct/16/2005 Jul/20/2009 Sep/9/2014 Mar/12/2015 # utility functions for list/table/nest/... # includes sum, scaning, ... link binrel link role link mkr_word link deepcopy link nest $include "keparam.h" global TypeComment global OutputFiles global PHP,EOL global NVSEPARATOR # procedures #=========== # compressws(s) # copy_list(L) # copy_nest(N) # copy_nv(x) # copy_set(S) # copy_table(T) # count(L) # dump_wattrib(fd,win,head,tail) # FirstWord(s) # get_date(cmd,time) # get_day(time) # get_month(time) # get_numeric(cmd,arglist) # get_year(time) # is_quoted(c,s,quotes) # list_average(L) # list_count(L,zero,increment) # list_delete(L,x) # list_find(s,L,quote) # list_match(s,L,quote) # list_sum(L) # list_writes(fd,x,sep,head,tail,join,list0,list1,list2,string0) # mapquote(s,quotes) # max_list(L) # min_list(L) # mset_writes(fd,x,head,tail,lsep,lend,nvsep) # nest_find(word,symbol,quote) # nest_match(word,symbol,quote) # nest_rmatch(word,symbol,quote) # parse_list(s,sep) # parse_time(time) # random(arglist) # reverse_list(L) # set_writes(fd,x,sep,head,tail,join,list0,list1,list2,string0) # size_nest(N,zero) # sort_gen(G,object) # table_sum(T,zero) # table_writes(fd,x,head,tail,lsep,lend,nvsep) # to_dmy(time) # to_mdy(time) # to_ymd(time) # trimsemi(x) # trimws(s) # write_nest(fd,nest,nsep,nhead,ntail) # writes_all(x,tail) # writes_any(fd,x,sep,head,tail,join,list0,list1,list2,string0,option) # writes_any_all(var,sep,label,tail) # writes_nv(fd,nv) # writes_object(fd,x,sep,head,tail,join,list0,list1,list2,string0) # writes_type(fd,x,label,tail) # writes_type_all(var,label,tail) # writes_value(fd,x,sep,head,tail,join,list0,list1,list2,string0) # 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"|"synset"|"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(&output,choice) return choice end procedure table_writes(fd,x,head,tail) #===================================== /head := "" /tail := "" write_table(fd,x,,head,tail) # unparse.icn end procedure mset_writes(fd,x,head,tail,lsep,lend,nvsep) #===================================================== /head := "" /tail := "" /lsep := "," /lend := " " /nvsep := " * " write(fd,head) write_table(fd,x) # unparse.icn write(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(mylog,TypeComment||info||"list2 <",list2,">\n") case t := type(x) of { "list": { } default: { writes_type(&errout,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(mylog,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(mylog,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 b,c,info initial { b := " " c := "," info := "INFO: writes_value: " } #####tcol := "\n"||repl(" ",4) #####case CHARFORMAT of { #####default: { /sep := "," } #####"line": { /sep := "," } #####"column": { /sep := ","||tcol } #####} # end case CHARFORMAT /sep := b /head := "" /tail := "" /join := NVSEPARATOR /list0 := "[]" # length 0 /list1 := "" # length 1 /list2 := "[]" # length 2 or more /string0 := "\"\"" # length 0 #writes(mylog,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 &output,&errout,mylog local fd,OutputFiles /tail := ")"||EOL OutputFiles := [&output,mylog] every fd := !OutputFiles do { writes_type(fd,var,label,tail) } # end every fd end procedure writes_any_all(var,sep,label,tail) #======================================== # writes_any() to &output,&errout,mylog local fd,OutputFiles /sep := "," /tail := ")"||EOL OutputFiles := [&output,mylog] every fd := !OutputFiles do { writes_any(fd,var,sep,label,tail) } # end every fd end procedure writes_all(x,tail) #=========================== # x ::= list of any # write() to &output,&errout,mylog local fd,OutputFiles OutputFiles := [&output,mylog] /tail := EOL every fd := !OutputFiles do { every writes_any(fd,!x); writes(fd,tail) } # end every fd end procedure writes_type(fd,x,label,tail) #===================================== # write x & its type # typical TypeComment ::= "# " | "" | "\n" local sep,head,join local t,typeANDsize initial { /TypeComment := "# " } /label := "type" sep := "," t := type(x) typeANDsize := t case t of { ("string"|"list"|"set"|"table"): { typeANDsize ||:= "["||*x||"]" } } head := TypeComment||label ||"("||typeANDsize||") (" /tail := ")"||EOL 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(mylog,TypeComment||info||"list2 <",list2,">\n") writes(fd,head) case t := type(x) of { default: { writes(fd,"UNEXPECTED TYPE <",t,">") } # record types "PROPOSITION":{ write(fd,showparse(x)) } # unparse.icn "NEST": { nest_writes(fd,x) } # nest.icn "CSV": { writes(fd,unparse(x)) } # mkr_word.icn "NVPHRASE": { nv_writes(fd,x) } # nvlist.icn "PHRASE": { writes(fd,unparse(x)) } # mkr_word.icn "PPHRASE": { writes(fd,unparse(x)) } # mkr_word.icn "QPHRASE": { writes(fd,unparse(x)) } # mkr_word.icn "VOPHRASE": { vo_writes(fd,x) } # binrel.icn "AAPHRASE": { aa_writes(fd,x) } # array.icn "BSE": { bse_writes(fd,x) } # bselist.icn "PPOBJECT": { ppobject_writes(fd,x) } # pplist.icn "GROUP": { writes(fd,unparse(x)) } # unparse.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,")") } "PARSE": { # mkr_symbol.icn writes(fd,"PARSE(",x.pos,":") writes(fd,x.ptype) 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":{ write_table(fd,x,,head,tail) # 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 #-----------------------------------------------------------# 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 #-------------------------------------------------------# #-------------------------------------------------------# # 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(mylog,s,info||"s") writes_type(mylog,q,info||"q") } return q end procedure is_quoted(c,s,quotes) #============================== # check if c is enclosed in quotes # called from state() in statement.icn local q,i,si,qi static info initial info := "INFO: is_quoted: " q := mapquote(s,quotes) if i := upto(c,s) then { si := s[i] qi := q[i] if DEBUG=="QUOTE" then writes_all(["# "||info||" si<",si,"> qi <",qi,">"]) case qi of { "y": { return "y" } "n": { fail } } } 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,"/","{","}") } "CSV": { write(fd,unparse(x)," "," "," ") } # mkr_word.icn "NVPHRASE": { write(fd,unparse(x)," "," "," ") } # mkr_word.icn "PHRASE": { write(fd,unparse(x)," "," "," ") } # mkr_word.icn "PPHRASE": { write(fd,unparse(x)," "," "," ") } # mkr_word.icn 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 static b initial b := " " /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,unparse(sym,b,b))) & (inquote[k] == "n") then 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(mylog,"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(mylog,"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 #-----------------------------------------------------------# #-----------------------------------------------------------# 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(mylog,arglist,"INFO: get_numeric: "||cmd||" arglist") case cmd of { default: { write(&errout,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(mylog,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 local avg,num,den static prog initial { prog := "list_average: " } if DEBUG == "AVERAGE" then { write(&errout,prog,"L = (",showparse(L),")") } num := list_sum(L) den := count(L) if /den | (den = 0) then fail avg := div(num,den) if DEBUG == "AVERAGE" then { write(&errout,prog,num,"/",den," = ",avg) } return avg end # integer procedure count(L) #================= # count numbers to average in list or set local den,uset static prog initial { prog := "count: " } den := 0 case type(L) of { default:{ fail } "null": { fail } "list": { every den +:= count(L) } "set": { every den +:= count(L) } "string": { if numeric(L) then { den +:= 1 } else { # group name uset := hoget_unit(L) if DEBUG == "COUNT" then write(&errout,prog,"group = (",L,")") every den +:= count(uset) } } # end "string" "integer": { den +:= 1 } "real": { den +:= 1 } } if DEBUG == "COUNT" then write(&errout,prog,"den = (",den,")") return den end # integer procedure list_sum(L) #==================== # sum of numbers in list or set local sum,uset static prog initial { prog := "list_sum: " } sum := integer(0) case type(L) of { default:{ } "null": { } "list": { every sum +:= list_sum(!L) } "set": { every sum +:= list_sum(!L) } "string": { if numeric(L) then { return numeric(L) } else { # group name uset := hoget_unit(L) if DEBUG == "SUM" then write(&errout,prog,"group = (",L,")") sum +:= list_sum(!uset) } } "integer": { return L } "real": { return L } } if DEBUG == "SUM" then { write(&errout,prog,"sum = (",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_nv(x) #=================== # called by copy_event() in knit.icn return deepcopy(x) end procedure copy_nest(N) #===================== return deepcopy(N) end procedure copy_list(L) #===================== return deepcopy(L) end procedure copy_set(S) #==================== return deepcopy(S) end procedure copy_table(T) #====================== return deepcopy(T) 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 # string procedure trimws(s) #================== # called by prompt() in myio.icn # called by many others # remove leading and trailing WhiteSpace # use enhanced Unicon trim() local x static WhiteSpace,ierror initial { WhiteSpace := ' \t\v\r\n\f' ierror := "Internal ERROR: trimws: " } case type(s) of { default: { writes_type(mylog,s,ierror||"unexpected type s") return s } "list": { x := []; every put(x,trimws(!s)); return x } "set": { x := set(); every insert(x,trimws(!s)); return x } "string":{ } } # end case type # string ##if *s = 0 then return s s := trim(s,WhiteSpace,0) return s end procedure compressws(s) #====================== # replace consecutive WhiteSpace with single blank local t,u,v,comp static WS, blank, WordDef initial { WS := ' \t\v\r\n\f'; blank := " "; WordDef := &cset -- WS } t := blank || s u := "" t ? { while tab(upto(WordDef)) do { u ||:= blank u ||:= tab(many(WordDef)) } } return u[2:0] end # string procedure trimsemi(x) #==================== local y static b,s initial { b := " " s := ";" } y := trimws(x) y := trim(y,s) y := trim(y,b) return y end # string procedure FirstWord(s) #===================== local i,first static WhiteSpace initial WhiteSpace := ' \t\v\r\n\f' s ? { if i := upto(WhiteSpace) then first := s[1:i] else first := s } return first end # list procedure parse_list(s,sep) #========================== local L,item static b,info,serror initial { b := " " info := "INFO: parse_list: " serror := "Syntax ERROR: parse_list: " } /sep := "," if DEBUG == "PARSE_LIST" then writes_type_all(s,info||"s") L := [] if s ? { while item := tab(upto(sep)) do { item := trim(item,b,0) put(L,item) move(1) } if item := tab(0) then { item := trim(item,b,0) put(L,item) } } then { if DEBUG == "PARSE_LIST" then writes_type_all(L,info||"L") return L } else { writes_type_all(s,serror||"s") fail } end #