path: root/appl/lib/tcl_list.b

implement TclLib;

include "sys.m";
	sys: Sys;
include "draw.m";
include "tk.m";
include "bufio.m";
	bufmod : Bufio;
Iobuf : import bufmod;

include "string.m";
	str : String;

include "tcl.m";
include "tcllib.m";

include "utils.m";
	utils : Tcl_Utils;


error : int;

DEF,DEC,INT : con iota;
valid_commands:= array[] of {
		"concat" , 
		"join" , 
		"lindex" , 
		"linsert" , 
		"list" , 
		"llength" ,
		"lrange" , 
		"lreplace" , 
		"lsearch" , 
		"lsort" , 
		"split"
};

about() : array of string {
	return valid_commands;
}

exec(tcl : ref Tcl_Core->TclData,argv : array of string) : (int,string) {
	if (tcl.context==nil);
	str = load String String->PATH;
	sys = load Sys Sys->PATH;
	utils = load Tcl_Utils Tcl_Utils->PATH;
	if (str==nil || utils==nil)
		return (1,"Can't load modules\n");
	case argv[0] {
		"concat" => 
			return (error,do_concat(argv,0));					
		"join" => 
			return (error,do_join(argv));
		"lindex" => 
			return (error,do_lindex(argv));		 
		"linsert" => 
			return (error,do_linsert(argv));
		"list" => 
			return (error,do_concat(argv,1));
		"llength" =>
			return (error,do_llength(argv));					
		"lrange" => 
			return (error,do_lrange(argv));
		"lreplace" => 
			return (error,do_lreplace(argv));
		"lsearch" => 
			return (error,do_lsearch(argv));
		"lsort" => 
			return (error,do_lsort(argv));
		"split" =>
			return (error,do_split(argv));
	}
	return (1,nil);
}

spaces(s : string) : int{
	if (s==nil) return 1;
	for(i:=0;i<len s;i++)
		if (s[i]==' ' || s[i]=='\t') return 1;
	return 0;
}
	

sort(a: array of string, key: int): array of string {
	m: int;
	n := len a;
	for(m = n; m > 1; ) {
		if(m < 5)
			m = 1;
		else
			m = (5*m-1)/11;
		for(i := n-m-1; i >= 0; i--) {
			tmp := a[i];
			for(j := i+m; j <= n-1 && greater(tmp, a[j], key); j += m)
				a[j-m] = a[j];
			a[j-m] = tmp;
		}
	}
	return a;
}

greater(x, y: string, sortkey: int): int {
	case (sortkey) {
	DEF => return(x > y);
	DEC => return(x < y);
	INT => return(int x > int y);
	}
	return 0;
}

# from here on are the commands in alphabetical order...

# turns an array into a string with spaces between the elements.
# in braces is non-zero, the elements will be enclosed in braces.
do_concat(argv : array of string, braces : int) : string {
	retval :string;
	retval=nil;
	for(i:=1;i<len argv;i++){
		flag:=0;
		if (spaces(argv[i])) flag=1;
		if (braces && flag) retval[len retval]='{';
		retval += argv[i];
		if (braces && flag) retval[len retval]='}';
		retval[len retval]=' ';
	}
	if (retval!=nil)
		retval=retval[0:len retval-1];
	return retval;
}

do_join(argv : array of string) : string {
	retval : string;
	if (len argv ==1 || len argv >3)
		return notify(1,"join list ?joinString?");
	if (len argv == 2) 
		return argv[1];
	if (argv[1]==nil) return nil;
	arr := utils->break_it(argv[1]);
	for (i:=0;i<len arr;i++){
		retval+=arr[i];
		if (i!=len arr -1)
			retval+=argv[2];
	}
	return retval;
}

do_lindex(argv : array of string) : string {
	if (len argv != 3)
		return notify(1,"lindex list index");
	(num,rest):=str->toint(argv[2],10);
	if (rest!=nil)
		return notify(2,argv[2]);
	arr:=utils->break_it(argv[1]);
	if (num>=len arr)
		return nil;
	return arr[num];
}

do_linsert(argv : array of string) : string {
	if (len argv < 4){
		return notify(1,
			"linsert list index element ?element ...?");
	}
	(num,rest):=str->toint(argv[2],10);
	if (rest!=nil)
		return notify(2,argv[2]);
	arr:=utils->break_it(argv[1]);
	narr := array[len arr + len argv - 2] of string;
	narr[0]="do_concat";
	if (num==0){
		narr[1:]=argv[3:];
		narr[len argv -2:]=arr[0:];
	}else if (num>= len arr){
		narr[1:]=arr[0:];
		narr[len arr+1:]=argv[3:];
	}else{
		narr[1:]=arr[0:num];
		narr[num+1:]=argv[3:];
		narr[num+len argv -2:]=arr[num:];
	}
	return do_concat(narr,1);
}

do_llength(argv : array of string) : string {
	if (len argv !=2){
		return notify(1,"llength list");
	}
	arr:=utils->break_it(argv[1]);
	return string len arr;
}

do_lrange(argv :array of string) : string {
	beg,end : int;
	rest : string;
	if (len argv != 4)
		return notify(1,"lrange list first last");
	(beg,rest)=str->toint(argv[2],10);
	if (rest!=nil)
		return notify(2,argv[2]);
	(end,rest)=str->toint(argv[3],10);
	if (rest!=nil)
		return notify(2,argv[3]);
	if (beg <0) beg=0;
	if (end < 0) return nil;
	if (beg > end) return nil;
	arr:=utils->break_it(argv[1]);
	if (beg>len arr) return nil;
	narr:=array[end-beg+2] of string;
	narr[0]="do_concat";
	narr[1:]=arr[beg:end+1];
	return do_concat(narr,1);
}

do_lreplace(argv : array of string) : string {
	beg,end : int;
	rest : string;
	if (len argv < 3)
		return notify(1,"lreplace list "+
			"first last ?element element ...?");
	arr:=utils->break_it(argv[1]);
	(beg,rest)=str->toint(argv[2],10);
	if (rest!=nil)
		return notify(2,argv[2]);
	(end,rest)=str->toint(argv[3],10);
	if (rest!=nil)
		return notify(2,argv[3]);
	if (beg <0) beg=0;
	if (end < 0) return nil;
	if (beg > end) 
		return notify(0,
		       "first index must not be greater than second");
	if (beg>len arr) 
		return notify(1,
			"list doesn't contain element "+string beg);
	narr:=array[len arr-(end-beg+1)+len argv - 3] of string;
	narr[1:]=arr[0:beg];
	narr[beg+1:]=argv[4:];
	narr[beg+1+len argv-4:]=arr[end+1:];
	narr[0]="do_concat";
	return do_concat(narr,1);
}

do_lsearch(argv : array of string) : string {
	if (len argv!=3) 
		return notify(1,"lsearch ?mode? list pattern");
	arr:=utils->break_it(argv[1]);
	for(i:=0;i<len arr;i++)
		if (arr[i]==argv[2])
			return string i;
	return "-1";
}

do_lsort(argv : array of string) : string {
	lis : array of string;
	key : int;
	key=DEF;
	if (len argv == 1) 
		return notify(1,"lsort ?-ascii? ?-integer? ?-real?"+
			" ?-increasing? ?-decreasing?"+
			" ?-command string? list");
	for(i:=1;i<len argv;i++)
		if (argv[i][0]=='-')
			case argv[i]{
				"-decreasing" =>
					key = DEC;
				* =>
					if (len argv != i+1)
					return notify(0,sys->sprint(
					"bad switch \"%s\": must be"+
					" -ascii, -integer, -real, "+
					"-increasing -decreasing, or"+
					" -command" ,argv[i]));
			}
	lis=utils->break_it(argv[len argv-1]);
	arr:=sort(lis,key);
	narr:= array[len arr+1] of string;
	narr[0]="list";
	narr[1:]=arr[0:];
	return do_concat(narr,1);
}



do_split(argv : array of string) : string {
	arr := array[20] of string;
	narr : array of string;
	if (len argv ==1 || len argv>3)
		return notify(1,"split string ?splitChars?");
	if (len argv == 2)
		return argv[1];
	s:=argv[1];
	if (s==nil) return nil;
	if (argv[2]==nil){
		arr=array[len s+1] of string;
		for(i:=0;i<len s;i++)
			arr[i+1][len arr[i+1]]=s[i];
		arr[0]="do_concat";
		return do_concat(arr,1);
	}
	i:=1;
	while(s!=nil){
		(piece,rest):=str->splitl(s,argv[2]);
		arr[i]=piece;
		if (len rest>1)
			s=rest[1:];
		if (len rest==1) 
			s=nil;
		i++;
		if (i==len arr){
			narr=array[i+10] of string;
			narr[0:]=arr[0:];
			arr=array[i+10] of string;
			arr=narr;
		}
	}
	narr = array[i] of string;
	arr[0]="do_concat";
	narr = arr[0:i+1];
	return do_concat(narr,1);
}

notify(num : int,s : string) : string {
	error=1;
	case num{
		1 =>
			return sys->sprint(
			"wrong # args: should be \"%s\"",s);		
		2 =>
			return sys->sprint(
			"expected integer but got \"%s\"",s);
		* =>
			return s;
	}
}