yacas 1.3.3-2 / usr / share / yacas / lists.rep / code.ys

Function("Contains",{list,element})
[
  Local(result);
  Set(result,False);
  While(And(Not(result), Not(Equals(list, {}))))
  [
    If(Equals(Head(list),element),
      Set(result, True),
      Set(list, Tail(list))
      );
  ];
  result;
];

Function("Find",{list,element})
[
  Local(result,count);
  Set(result, -1);
  Set(count, 1);
  While(And(result<0, Not(Equals(list, {}))))
  [
    If(Equals(Head(list), element),
      Set(result, count)
      );
    Set(list,Tail(list));
    Set(count,MathAdd(count,1));
  ];
  result;
];

// Find the first thingy that matches a predicate
Function("FindPredicate",{list,predicate})
[
  Local(result,count);
  Set(result, -1);
  Set(count, 1);
  While(And(result<0, Not(Equals(list, {}))))
  [
    If(Apply(predicate,{Head(list)}),
      Set(result, count)
      );
    Set(list,Tail(list));
    Set(count,MathAdd(count,1));
  ];
  result;
];  




Function("Append",{list,element})
[
  Insert(list,Length(list)+1,element);
];
Function("DestructiveAppend",{list,element})
[
  DestructiveInsert(list,Length(list)+1,element);
];

Function("DestructiveAppendList",{list,toadd})
[
  Local(i,nr);
  nr:=Length(toadd);
  For(i:=1,i<=nr,i++)
  [
    DestructiveAppend(list,toadd[i]);
  ];
  True;
];


Function("RemoveDuplicates",{list})
[
   Local(result);
   Set(result,{});
   ForEach(item,list)
     If(Not(Contains(result,item)),DestructiveAppend(result,item));
   result;
];

Function("Union",{list1,list2})
[
  RemoveDuplicates(Concat(list1,list2));
];

Function("Intersection",{list1,list2})
[
  Local(l2,index,result);
  l2:=FlatCopy(list2);
  result:={};
  ForEach(item,list1)
  [
    Set(index, Find(l2,item));
    If(index>0,
      [
        DestructiveDelete(l2,index);
        DestructiveInsert(result,1,item);
      ]
      );
  ];
  DestructiveReverse(result);
];

Function("Difference",{list1,list2})
[
  Local(l2,index,result);
  l2:=FlatCopy(list2);
  result:=FlatCopy(list1);
  ForEach(item,list1)
  [
    Set(index,Find(l2,item));
    If(index>0,
      [
        DestructiveDelete(l2,index);
        DestructiveDelete(result,Find(result,item));
      ]
      );
  ];
  result;
];

Function("Push",{stack,element})
[
  DestructiveInsert(stack,1,element);
];

Function("Pop",{stack,index})
[
  Local(result);
  result:=stack[index];
  DestructiveDelete(stack,index);
  result;
];

Function("PopFront",{stack}) Pop(stack,1);
Function("PopBack",{stack})  Pop(stack,Length(stack));

Function("Swap",{list,index1,index2})
[
  Local(item1,item2);
  item1:=list[index1];
  item2:=list[index2];
  list[index1] := item2;
  list[index2] := item1;
];


Function("Count",{list,element})
[
   Local(result);
   Set(result,0);
   ForEach(item,list) If(Equals(item, element), Set(result,MathAdd(result,1)));
   result;
];

Function("BubbleSort",{list,compare})
[
  Local(i,j,length,left,right);

  list:=FlatCopy(list);
  length:=Length(list);

  For (j:=length,j>1,j--)
  [
    For(i:=1,i<j,i++)
    [
      left:=list[i];
      right:=list[i+1];
      If(Not(Apply(compare,{left,right})),
        [
          DestructiveInsert(DestructiveDelete(list,i),i+1,left);
        ]
      );
    ];
  ];
  list;
];

/// fast in-place sorting of a list (or array!)
/// SmallSort sorts up to 3 elements, HeapSort sorts 4 and more elements
SmallSort(_list, _first, _last, _compare) _ (last=first) <-- list;
SmallSort(_list, _first, _last, _compare) _ (last=first+1) <--
[
	Local(temp);
	temp := list[first];
	If(
		Apply(compare,{temp,list[last]}),
		list,
		[
			list[first] := list[last];
			list[last] := temp;
		]	//Swap(list, first, last)
	);
	list;
];
SmallSort(_list, _first, _last, _compare) _ (last=first+2) <--
[
	Local(temp);
	temp := list[first];
	If(
		Apply(compare,{list[first+1],temp}),
		[
			list[first] := list[first+1];
			list[first+1] := temp;
		]	//Swap(list, first, first+1)	// x>y, z
	);
	// x<y, z
	temp := list[last];
	If(
		Apply(compare,{list[first],temp}),
		If(	// z>x<y
			Apply(compare,{list[first+1],temp}),
			list,
			[
				list[last] := list[first+1];
				list[first+1] := temp;
			]	//Swap(list, first+1, last)	// 1, 3, 2
		),
		[	// 2, 3, 1 -> 1, 2, 3
			list[last] := list[first+1];
			list[first+1] := list[first];
			list[first] := temp;
		]
	);
	list;
];

HeapSort(list, compare) := HeapSort(list, Array'Create(Length(list), 0), 1, Length(list), compare);

// this will sort "list" and mangle "tmplist"
1 # HeapSort(_list, _tmplist, _first, _last, _compare) _ (last - first <= 2) <-- SmallSort(list, first, last, compare);
2 # HeapSort(_list, _tmplist, _first, _last, _compare) <-- 
[	// See: J. W. J. Williams, Algorithm 232 (Heapsort), Com. of ACM, vol. 7, no. 6, p. 347 (1964)
	// sort two halves recursively, then merge two halves
	// cannot merge in-place efficiently, so need a second list
	Local(mid, ileft, iright, pleft);
	mid := first+((last-first)>>1);
	HeapSort(list, tmplist, first, mid, compare);
	HeapSort(list, tmplist, mid+1, last, compare);
	// copy the lower part to temporary array
	For(ileft := first,  ileft <= mid, ileft++)
		tmplist[ileft] := list[ileft];
	For(
		[ileft := first; pleft := first; iright := mid+1;],
		ileft <= mid,	// if the left half is finished, we don't have to do any more work
		pleft++	// one element is stored at each iteration
	)	// merge two halves
		// elements before pleft have been stored
		// the smallest element of the right half is at iright
		// the smallest element of the left half is at ileft, access through tmplist
	If(	// we copy an element from ileft either if it is smaller or if the right half is finished; it is unnecessary to copy the remainder of the right half since the right half stays in the "list"
		iright>last Or Apply(compare,{tmplist[ileft],list[iright]}),
		[	// take element from ileft
			list[pleft] := tmplist[ileft];
			ileft++;
		],
		[	// take element from iright
			list[pleft] := list[iright];
			iright++;
		]
	);

	list;
];

LocalSymbols(max,f,low,high,mid,current)
[
FindIsq(max,f)  :=
[
  Local(low,high,mid,current);
  low:=1;
  high:=max+1;
  Set(mid,((high+low)>>1));
  While(high>low And mid>1)
  [
    Set(mid,((high+low)>>1));
    Set(current,Apply(f,{mid}));
//Echo({low,high,current});
    If(current = 0,
       high:=low-1,
       If(current > 0,
          Set(high,mid),
          Set(low,mid+1)
          )
       );
  ];
  mid;
];
];
UnFence("FindIsq",2);
LocalSymbols(max,f,result)
[
  BSearch(max,f)  :=
  [
    Local(result);
    Set(result, FindIsq(max,f));
    If(Apply(f,{result})!=0,Set(result,-1));
    result;
  ];
];
UnFence("BSearch",2);


/* VarList: return the variables this expression depends on. */
VarList(_expr) <-- VarList(expr,"IsVariable");

Function("VarList",{expr,filter})
[
  RemoveDuplicates(VarListAll(expr,filter));
];



/*
 * RuleBase for VarListAll: recursively traverse an expression looking
 * up all variables the expression depends on.
 */
/* Accept any variable. */

VarListAll(_expr) <-- VarListAll(expr,"IsVariable");

10 # VarListAll(_expr,_filter)_(Apply(filter,{expr}) = True) <--
     {expr};

/* Otherwise check all leafs of a function. */
20 # VarListAll(expr_IsFunction,_filter) <--
[
  Local(item,result, flatlist);
  Set(flatlist,Tail(Listify(expr)));
  Set(result,{});
  ForEach(item,flatlist)
    Set(result,Concat(result,VarListAll(item,filter)));
  result;
];

/* Else it doesn't depend on any variable. */
30 # VarListAll(_expr,_filter) <-- {};




/* Juan: TemplateFunction (as defined in the file "deffunc")
 * also makes the arguments to the function local symbols.
 * Use HoldArgNr to specify the index of a variable to hold
 * (since they are defined as local symbols).
 */

TemplateFunction("Table",{body,var,count'from,count'to,step})
  LocalSymbols(result,nr,ii)
  [
    MacroLocal(var);
    result:={};
    nr := (count'to - count'from) / step;
    ii := 0;
    While( ii <= nr )
      [
       MacroSet( var, count'from + ii * step );
       DestructiveInsert( result,1,Eval(body) );
       Set(ii,MathAdd(ii,1));
      ];
    DestructiveReverse(result);
  ];
HoldArgNr("Table",5,1); /* body */
HoldArgNr("Table",5,2); /* var */
UnFence("Table",5);



TemplateFunction("MapSingle",{func,list})
[
  Local(mapsingleresult);
  mapsingleresult:={};

  ForEach(mapsingleitem,list)
  [
    DestructiveInsert(mapsingleresult,1,
      Apply(func,{mapsingleitem}));
  ];
  DestructiveReverse(mapsingleresult);
];
UnFence("MapSingle",2);
HoldArg("MapSingle",func);

/* Another Macro... hack for /: to work. */
TemplateFunction("MacroMapSingle",{func,list})
[
  Local(mapsingleresult);
  mapsingleresult:={};

  ForEach(mapsingleitem,list)
  [
    DestructiveInsert(mapsingleresult,1,
      `ApplyPure(func,{Hold(Hold(@mapsingleitem))}));
  ];
  DestructiveReverse(mapsingleresult);
];
UnFence("MacroMapSingle",2);
HoldArg("MacroMapSingle",func);
HoldArg("MacroMapSingle",list);

LocalSymbols(func,lists,mapsingleresult,mapsingleitem)
[
  Function("Map",{func,lists})
  [
    Local(mapsingleresult,mapsingleitem);
    mapsingleresult:={};
    lists:=Transpose(lists);
    ForEach(mapsingleitem,lists)
    [
      DestructiveInsert(mapsingleresult,1,Apply(func,mapsingleitem));
    ];
    DestructiveReverse(mapsingleresult);
  ];
  UnFence("Map",2);
  HoldArg("Map",func);
];

TemplateFunction("MapArgs",{expr,oper})
[
  Set(expr,Listify(expr));
   UnList(Concat({expr[1]},
     Apply("MapSingle",{oper,Tail(expr)})
   ) );
];
UnFence("MapArgs",2);
HoldArg("MapArgs",oper);

/* Another Macro... hack for /: to work. */
Macro("MacroMapArgs",{expr,oper})
[
  Local(ex,tl,op);
  Set(op,@oper);
  Set(ex,Listify(@expr));
  Set(tl,Tail(ex));

   UnList(Concat({ex[1]},
     `MacroMapSingle(@op,Hold(@tl)))
   );
];
UnFence("MapArgs",2);
HoldArg("MapArgs",oper);



Function("FillList", {aItem, aLength})
[
  Local(i, aResult);
  aResult:={};
  For(i:=0, i<aLength, i++)
    DestructiveInsert(aResult,1,aItem);
  aResult;
];




/* ···· Drop ···· */

/* Needs to check the parameters */

/*
 * Drop( list, n ) gives 'list' with its first n elements dropped
 * Drop( list, -n ) gives 'list' with its last n elements dropped
 * Drop( list, {m,n} ) gives 'list' with elements m through n dropped
 */

RuleBase("Drop", {lst, range});

Rule("Drop", 2, 1, IsList(range))
    Concat(Take(lst,range[1]-1), Drop(lst, range[2]));

Rule("Drop", 2, 2, range >= 0)
    If( range = 0 Or lst = {}, lst, Drop( Tail(lst), range-1 ));

Rule("Drop", 2, 2, range < 0)
    Take( lst, Length(lst) + range );


/* ···· Take ···· */

/* Needs to check the parameters */

/*
 * Take( list, n ) gives the first n elements of 'list'
 * Take( list, -n ) gives the last n elements of 'list'
 * Take( list, {m,n} ) elements m through n of 'list'
 */

RuleBase("Take", {lst, range});

Rule("Take", 2, 1, IsList(range))
    Take( Drop(lst, range[1] -1), range[2] - range[1] + 1);

Rule("Take", 2, 2, range >= 0)
    If( Length(lst)=0 Or range=0, {},
        Concat({Head(lst)}, Take(Tail(lst), range-1)));

Rule("Take", 2, 2, range < 0)
    Drop( lst, Length(lst) + range );


/* ···· Partition ···· */

/* Partition( list, n ) partitions 'list' into non-overlapping sublists of length n */

Partition(lst, len):=
	If( Length(lst) < len Or len = 0, {},
        	Concat( {Take(lst,len)}, Partition(Drop(lst,len), len) ));


//////////////////////////////////////////////////
/// Print a list using a padding string
//////////////////////////////////////////////////

10 # PrintList(list_IsList) <-- PrintList(list, ", ");
10 # PrintList({}, padding_IsString) <-- "";
20 # PrintList(list_IsList, padding_IsString) <-- ToString() [
	Local(i);
	ForEach(i, list) [
		If(Not(Equals(i, Head(list))), WriteString(padding));
		If (IsString(i), WriteString(i), If(IsList(i), WriteString("{" : PrintList(i, padding) : "}"), Write(i)));
	];
];

//////////////////////////////////////////////////
/// FuncList --- list all function atoms used in an expression
//////////////////////////////////////////////////
/// like VarList except collects functions

10 # FuncList(expr_IsAtom) <-- {};
20 # FuncList(expr_IsFunction) <--
RemoveDuplicates(
	Concat(
		{Head(Listify(expr))},
		Apply("Concat",
			MapSingle("FuncList", Tail(Listify(expr)))
		)
	)
);

/*
This is like FuncList except only looks at arguments of a given list of functions. All other functions become "opaque".
FuncListArith() is defined to only look at arithmetic operations +, -, *, /.
*/
10 # FuncList(expr_IsAtom, look'list_IsList) <-- {};
// a function not in the looking list - return its type
20 # FuncList(expr_IsFunction, look'list_IsList)_(Not Contains(look'list, Atom(Type(expr)))) <-- {Atom(Type(expr))};
// a function in the looking list - traverse its arguments
30 # FuncList(expr_IsFunction, look'list_IsList) <--
RemoveDuplicates(
	Concat(
		{Head(Listify(expr))},
		[	// gave up trying to do it using Map and MapSingle... so writing a loop now.
			// obtain a list of functions, considering only functions in look'list
			Local(item, result);
			result := {};
			ForEach(item, expr) result := Concat(result, FuncList(item, look'list));
			result;
		]
	)
);

FuncListArith(expr) := FuncList(expr, {Atom("+"), Atom("-"), *, /});

HoldArgNr("FuncList", 1, 1);
HoldArgNr("FuncList", 2, 1);
HoldArgNr("FuncListArith", 1, 1);

/// VarListArith --- obtain arithmetic variables
// currently the VarList(x,y) semantic is convoluted so let's introduce a new name; but in principle this needs to be cleaned up
VarListArith(expr) := VarListSome(expr, {Atom("+"), Atom("-"), *, /});

/// VarListSome is just like FuncList(x,y)

10 # VarListSome({}, _look'list) <-- {};
// an atom should be a variable to qualify
10 # VarListSome(expr_IsVariable, _look'list) <-- {expr};
15 # VarListSome(expr_IsAtom, _look'list) <-- {};
// a function not in the looking list - return it whole
20 # VarListSome(expr_IsFunction, look'list_IsList)_(Not Contains(look'list, Atom(Type(expr)))) <-- {expr};
// a function in the looking list - traverse its arguments
30 # VarListSome(expr_IsFunction, look'list_IsList) <--
RemoveDuplicates(
		[	// obtain a list of functions, considering only functions in look'list
			Local(item, result);
			result := {};
			ForEach(item, expr) result := Concat(result, VarListSome(item, look'list));
			result;
		]
);

//////////////////////////////////////////////////
/// Global stack operations on variables
//////////////////////////////////////////////////


LocalSymbols(GlobalStack, x)
[
  GlobalStack := {};

	GlobalPop(x_IsAtom) <--
	[
		Check(Length(GlobalStack)>0, "GlobalPop: Error: empty GlobalStack");
		MacroSet(x, PopFront(GlobalStack));
		Eval(x);
	];

	HoldArgNr("GlobalPop", 1, 1);

	GlobalPop() <--
	[
		Check(Length(GlobalStack)>0, "GlobalPop: Error: empty GlobalStack");
		PopFront(GlobalStack);
	];

	GlobalPush(_x) <--
	[
		Push(GlobalStack, x);
		x;
	];
];



// Non-destructive Reverse operation
Reverse(list):=DestructiveReverse(FlatCopy(list));