Artifact 4c60edb0d038e3d27416c619989da5e476f4fdb1accbc92ef09d1874211ac849:
- Executable file
r38/packages/redlog/lto.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 8548) [annotate] [blame] [check-ins using] [more...]
% ---------------------------------------------------------------------- % $Id: lto.red,v 1.7 2003/01/29 10:44:08 sturm Exp $ % ---------------------------------------------------------------------- % Copyright (c) 1995-1999 Andreas Dolzmann and Thomas Sturm % ---------------------------------------------------------------------- % $Log: lto.red,v $ % Revision 1.7 2003/01/29 10:44:08 sturm % Moved list2set and list2vector to lto.red. % % Revision 1.6 1999/03/24 12:29:57 dolzmann % Added the procedure lto_max for computing the maximum of a list of % integers. % % Revision 1.5 1999/03/22 15:26:15 dolzmann % Changed copyright information. % Added and reformatted comments. % % Revision 1.4 1997/11/05 06:35:10 dolzmann % Added comments. % Moved system dependent procedures to the end of the file. % Updated copyright message. % Replaced "written by" in the CVS header by the usual copyright message. % % Revision 1.3 1996/10/17 12:31:52 sturm % Moved sconcat2, sconcat, and at2str from qepcad.red to lto.red. % % Revision 1.2 1996/09/05 11:17:36 dolzmann % Added procedures delq, delqip, delqip1, and adjoin for non-PSL versions. % % Revision 1.1 1996/04/30 12:06:44 sturm % Merged ioto, lto, and sfto into rltools. % % Revision 1.1 1996/03/22 12:11:09 sturm % Moved. % % Revision 1.4 1996/02/18 13:52:15 sturm % Added procedure lto_natsoc. % % Revision 1.3 1996/02/18 12:39:18 dolzmann % Added procedure lto_cassoc. % % Revision 1.2 1995/06/21 07:35:47 sturm % Added procedures lto_nconcn, lto_alunion, and lto_almerge. % % Revision 1.1 1995/05/29 14:47:19 sturm % Initial check-in. % % ---------------------------------------------------------------------- lisp << fluid '(lto_rcsid!* lto_copyright!*); lto_rcsid!* := "$Id: lto.red,v 1.7 2003/01/29 10:44:08 sturm Exp $"; lto_copyright!* := "Copyright (c) 1995-1999 by A. Dolzmann and T. Sturm" >>; module lto; % List tools. procedure lto_insert(x,l); % List tools insert. [x] is any S-expression, [l] is a list. Conses % [x] to [l] if [x] is not already member of [l]. if x member l then l else x . l; procedure lto_insertq(x,l); % List tools insert testing with memq. [x] is any S-expression, [l] % is a list. Conses [x] to [l] if [x] is not already [memq]. if x memq l then l else x . l; procedure lto_mergesort(l,sortp); % List tools merge sort. [l] is a list; [sortp] is a function that % implements an ordering. Returns a list. [l] is sorted such that % [sortp] holds between each two adjacent elements. begin scalar crit,s1,s2; % Empty and one-element lists are already sorted. if null l or null cdr l then return l; % Construct two sets by comparing all others with the first one. crit := car l; for each entry in cdr l do if apply(sortp,{entry,crit}) then s1 := entry . s1 else s2 := entry . s2; % sort the two lists recursively and place crit in between return nconc(lto_mergesort(s1,sortp),crit . lto_mergesort(s2,sortp)) end; procedure lto_catsoc(key,al); % List tools conditional atsoc. [key] is an identifier; [al] is an % alist $((k_1 . e_1),...,(k_n . e_n))$. Returns $e_i$ if [key] is % [eq] to $k_i$, [nil] else. (if x then cdr x) where x=atsoc(key,al); procedure lto_natsoc(key,al); % List tools conditional number atsoc. [key] is an identifier; [al] % is an alist $((k_1 . e_1),...,(k_n . e_n))$. Returns $e_i$ if % $[key]=k_i$, 0 else. (if w then cdr w else 0) where w=atsoc(key,al); procedure lto_cassoc(key,al); % List tools conditional assoc. [key] is an identifier; [al] is an % alist $((k_1 . e_1),...,(k_n . e_n))$. Returns $e_i$ if % $[key]=k_i$, [nil] else. (if x then cdr x) where x=assoc(key,al); procedure lto_nconcn(l); % List tools non-constructive concatenate n-ary. [l] is a list of % lists. Returns a list. The returned list is the concatenation of % all lists in [l]. The lists in [l] are possibly modyfied. if cdr l then nconc(car l,lto_nconcn cdr l) else car l; procedure lto_alunion(all); % List tools assoc list union. [all] is a list of alists $((k1 . % e1) ... (kn . en))$, where all ki are unique and all ei are % lists. Merges all alists in [all] into one alist, where the keys % are the union of all ki appearing in the members of [all], and % the entry to each key is the union of the lists that are entries % to the key within the members of [all]. All members of [all] are % modified by this function. lto_almerge(all,'union); procedure lto_almerge(all,merge); % List tools assoc list merge. [all] is a list of alists $((k1 . % e1) ... (kn . en))$, where all ki are unique and all ei are % lists; [merge] is a function that maps two lists to another list. % Merges all alists in [all] into one alist, where the keys are the % union of all ki appearing in the members of [all], and the entry % to each key is obtained from the entries in [all] by applying % [merge]. All members of [all] are modified by this function. begin scalar l2,a; if null all then return nil; if null cdr all then return car all; if null cddr all then << l2 := cadr all; for each pair in car all do << a := assoc(car pair,l2); if a then cdr a := apply(merge,{cdr pair,cdr a}) else l2 := pair . l2 >>; return l2 >>; return lto_almerge({car all,lto_almerge(cdr all,merge)},merge) end; procedure lto_sconcat2(s1,s2); % List tools string concatenation 2. [s1] and [s2] are strings. % Returns a string. The returned string is the concatenation % [s1][s2]. compress append(reversip cdr reversip explode s1,cdr explode s2); procedure lto_sconcat(l); % List tools string concatenation. [l] is a list of strings. % Returns a string. The returned string is the concatenation of all % strings in [l]. if l then if cdr l then lto_sconcat2(car l,lto_sconcat cdr l) else car l; procedure lto_at2str(s); % List tools atom to string. [s] is an atom. Returns the print name % of the atom [s] as a string. compress('!" . reversip('!" . reversip explode s)); procedure lto_max(l); % List tools maximum of a list. [l] is a list of integers. Rerurns % the maximum of [l]. if null cdr l then car l else max(car l,lto_max cdr l); !#if (not (memq 'psl lispsystem!*)) procedure delq(x,l); % Delete with memq. [x] is ANY; [l] is a list. Returns a list. % The first occurence of an element identical to [x] in [l] is % deleted. if l then if car l eq x then cdr l else car l . delq(x,cdr l); !#endif !#if (not (memq 'psl lispsystem!*)) procedure delqip(u,v); % Delete with memq in place. [u] is ANY; [v] is a list. Returns % a list. The first occurence of an element identical to [u] in % [v] is deleted [v] is possibly modified. if not pairp v then v else if u eq car v then cdr v else << delqip1(u,v); v >>; !#endif !#if (not (memq 'psl lispsystem!*)) procedure delqip1(u,v); % Delete with memq in place subroutine. [u] is ANY; [v] is a % list, such that [not(car v eq u)]. Returns a list. The first % occurence of an element identical to [u] in [v] is deleted [v] % is possibly modified. if not pairp cdr v then nil else if u eq cadr v then rplacd(v,cddr v) else delqip1(u,cdr v); !#endif !#if (not (memq 'psl lispsystem!*)) procedure adjoin(x,l); % Adjoin. [x] is any S-expression, [l] is a list. Conses [x] to % [l] if [x] is not already member of [l]. if x member l then l else x . l; !#endif !#if (not (memq 'psl lispsystem!*)) procedure list2set(l); % Remove redundant elements from L. if not pairp l then nil else if car l member cdr l then list2set cdr l else car l . list2set cdr l; !#endif !#if (not (memq 'psl lispsystem!*)) procedure list2vector(l); % Create a vector and store the list l into it. begin integer i; scalar v; v := mkvect sub1 length l; i := 0; for each vl in l do << putv(v,i,vl); i := i+1 >>; return v end; !#endif endmodule; % [lto] end; % of file