sofs.erl

来自「OTP是开放电信平台的简称」· ERL 代码 · 共 2,315 行 · 第 1/5 页

%% ``The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
%% compliance with the License. You should have received a copy of the
%% Erlang Public License along with this software. If not, it can be
%% retrieved via the world wide web at http://www.erlang.org/.
%% 
%% Software distributed under the License is distributed on an "AS IS"
%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
%% the License for the specific language governing rights and limitations
%% under the License.
%% 
%% The Initial Developer of the Original Code is Ericsson Utvecklings AB.
%% Portions created by Ericsson are Copyright 2000, Ericsson Utvecklings
%% AB. All Rights Reserved.''
%% 
%%     $Id $
%%
-module(sofs).

-export([from_term/1, from_term/2, from_external/2, empty_set/0,
         is_type/1, set/1, set/2, from_sets/1, relation/1, relation/2,
         a_function/1, a_function/2, family/1, family/2,
         to_external/1, type/1, to_sets/1, no_elements/1,
         specification/2, union/2, intersection/2, difference/2,
         symdiff/2, symmetric_partition/2, product/1, product/2,
         constant_function/2, is_equal/2, is_subset/2, is_sofs_set/1,
         is_set/1, is_empty_set/1, is_disjoint/2]).

-export([union/1, intersection/1, canonical_relation/1]).

-export([relation_to_family/1, domain/1, range/1, field/1,
	 relative_product/1, relative_product/2, relative_product1/2,
	 converse/1, image/2, inverse_image/2, strict_relation/1,
	 weak_relation/1, extension/3, is_a_function/1]).

-export([composite/2, inverse/1]).

-export([restriction/2, restriction/3, drestriction/2, drestriction/3,
         substitution/2, projection/2, partition/1, partition/2,
         partition/3, multiple_relative_product/2, join/4]).

-export([family_to_relation/1, family_specification/2, 
         union_of_family/1, intersection_of_family/1,
         family_union/1, family_intersection/1,
         family_domain/1, family_range/1, family_field/1,
         family_union/2, family_intersection/2, family_difference/2, 
         partition_family/2, family_projection/2]).

-export([family_to_digraph/1, family_to_digraph/2,
         digraph_to_family/1, digraph_to_family/2]).

%% Shorter names of some functions.
-export([fam2rel/1, rel2fam/1]).

-import(lists,
        [any/2, append/1, flatten/1, foreach/2,
         keysort/2, last/1, map/2, mapfoldl/3, member/2, merge/2,
         reverse/1, reverse/2, sort/1, umerge/1, umerge/2, usort/1]).

-compile({inline, [{family_to_relation,1}, {relation_to_family,1}]}).

-compile({inline, [{rel,2},{a_func,2},{fam,2},{term2set,2}]}).

-compile({inline, [{external_fun,1},{element_type,1}]}).

-compile({inline, 
          [{unify_types,2}, {match_types,2},
           {test_rel,3}, {symdiff,3}, 
           {subst,3}]}).

-compile({inline, [{fam_binop,3}]}).

%% Nope, no is_member, del_member or add_member.
%%
%% See also "Naive Set Theory" by Paul R. Halmos.
%%
%% By convention, erlang:fault/2 is called from exported functions.

-define(TAG, 'Set').
-define(ORDTAG, 'OrdSet').

-record(?TAG, {data = [], type = type}).
-record(?ORDTAG, {orddata = {}, ordtype = type}).

-define(LIST(S), (S)#?TAG.data).
-define(TYPE(S), (S)#?TAG.type).
%-define(SET(L, T), 
%       case is_type(T) of 
%           true -> #?TAG{data = L, type = T};
%           false -> erlang:fault(badtype, [T])
%       end
%       ).
-define(SET(L, T), #?TAG{data = L, type = T}).
-define(IS_SET(S), is_record(S, ?TAG)).
-define(IS_UNTYPED_SET(S), ?TYPE(S) =:= ?ANYTYPE).

%% Ordered sets and atoms:
-define(ORDDATA(S), (S)#?ORDTAG.orddata).
-define(ORDTYPE(S), (S)#?ORDTAG.ordtype).
-define(ORDSET(L, T), #?ORDTAG{orddata = L, ordtype = T}).
-define(IS_ORDSET(S), is_record(S, ?ORDTAG)).
-define(ATOM_TYPE, atom).
-define(IS_ATOM_TYPE(T), is_atom(T)). % true for ?ANYTYPE...

%% When IS_SET is true:
-define(ANYTYPE, '_').
-define(BINREL(X, Y), {X, Y}).
-define(IS_RELATION(R), is_tuple(R)).
-define(REL_ARITY(R), size(R)).
-define(REL_TYPE(I, R), element(I, R)).
-define(SET_OF(X), [X]).
-define(IS_SET_OF(X), is_list(X)).
-define(FAMILY(X, Y), ?BINREL(X, ?SET_OF(Y))).

%%
%%  Exported functions
%%

%%% 
%%% Create sets
%%% 

from_term(T) ->
    Type = case T of
               _ when is_list(T) -> [?ANYTYPE];
               _ -> ?ANYTYPE
           end,
    case catch setify(T, Type) of
        {'EXIT', _} ->
            erlang:fault(badarg, [T]);
        Set ->
            Set
    end.

from_term(L, T) ->
    case is_type(T) of
        true ->
            case catch setify(L, T) of
                {'EXIT', _} ->
                    erlang:fault(badarg, [L, T]);
                Set ->
                    Set
            end;
        false  ->
            erlang:fault(badarg, [L, T])
    end.

from_external(L, ?SET_OF(Type)) ->
    ?SET(L, Type);
from_external(T, Type) ->
    ?ORDSET(T, Type).

empty_set() ->
    ?SET([], ?ANYTYPE).

is_type(Atom) when ?IS_ATOM_TYPE(Atom), Atom =/= ?ANYTYPE ->
    true;
is_type(?SET_OF(T)) ->
    is_element_type(T);
is_type(T) when is_tuple(T), size(T) > 0 ->
    is_types(size(T), T);
is_type(_T) ->
    false.

set(L) ->
    case catch usort(L) of
        {'EXIT', _} ->
            erlang:fault(badarg, [L]);
        SL -> 
            ?SET(SL, ?ATOM_TYPE)
    end.

set(L, ?SET_OF(Type) = T) when ?IS_ATOM_TYPE(Type), Type =/= ?ANYTYPE ->
    case catch usort(L) of
        {'EXIT', _} ->
            erlang:fault(badarg, [L, T]);
        SL -> 
            ?SET(SL, Type)
    end;
set(L, ?SET_OF(_) = T) ->
    case catch setify(L, T) of
        {'EXIT', _} ->
            erlang:fault(badarg, [L, T]);
        Set ->
            Set
    end;
set(L, T) ->
    erlang:fault(badarg, [L, T]).

from_sets(Ss) when is_list(Ss) ->
    case set_of_sets(Ss, [], ?ANYTYPE) of
        {error, Error} ->
            erlang:fault(Error, [Ss]);
        Set ->
            Set
    end;
from_sets(Tuple) when is_tuple(Tuple) ->
    case ordset_of_sets(tuple_to_list(Tuple), [], []) of
        error ->
            erlang:fault(badarg, [Tuple]);
        Set ->
            Set
    end;
from_sets(T) ->
    erlang:fault(badarg, [T]).

relation([]) ->
    ?SET([], ?BINREL(?ATOM_TYPE, ?ATOM_TYPE));
relation(Ts = [T | _]) when is_tuple(T) ->
    case catch rel(Ts, size(T)) of
        {'EXIT', _} ->
            erlang:fault(badarg, [Ts]);
        Set ->
            Set
    end;
relation(E) ->
    erlang:fault(badarg, [E]).

relation(Ts, TS) ->
    case catch rel(Ts, TS) of
        {'EXIT', _} ->
            erlang:fault(badarg, [Ts, TS]);
	Set ->
	    Set
    end.

a_function(Ts) ->
    case catch func(Ts, ?BINREL(?ATOM_TYPE, ?ATOM_TYPE)) of
        {'EXIT', _} ->
            erlang:fault(badarg, [Ts]);
        Bad when is_atom(Bad) ->
            erlang:fault(Bad, [Ts]);
	Set ->
	    Set
    end.

a_function(Ts, T) ->
    case catch a_func(Ts, T) of
	{'EXIT', _} ->
	    erlang:fault(badarg, [Ts, T]);
	Bad when is_atom(Bad) ->
	    erlang:fault(Bad, [Ts, T]);
	Set ->
	    Set
    end.

family(Ts) ->
    case catch fam2(Ts, ?FAMILY(?ATOM_TYPE, ?ATOM_TYPE)) of
        {'EXIT', _} ->
            erlang:fault(badarg, [Ts]);
        Bad when is_atom(Bad) ->
            erlang:fault(Bad, [Ts]);
        Set ->
	    Set
    end.

family(Ts, T) ->
    case catch fam(Ts, T) of
	{'EXIT', _} ->
	    erlang:fault(badarg, [Ts, T]);
	Bad when is_atom(Bad) ->
	    erlang:fault(Bad, [Ts, T]);
	Set ->
	    Set
    end.

%%% 
%%% Functions on sets.
%%% 

to_external(S) when ?IS_SET(S) ->
    ?LIST(S);
to_external(S) when ?IS_ORDSET(S) ->
    ?ORDDATA(S).

type(S) when ?IS_SET(S) ->
    ?SET_OF(?TYPE(S));
type(S) when ?IS_ORDSET(S) ->
    ?ORDTYPE(S).

to_sets(S) when ?IS_SET(S) ->
    case ?TYPE(S) of
        ?SET_OF(Type) -> list_of_sets(?LIST(S), Type, []);
        Type -> list_of_ordsets(?LIST(S), Type, [])
    end;
to_sets(S) when ?IS_ORDSET(S), is_tuple(?ORDTYPE(S)) ->
    tuple_of_sets(tuple_to_list(?ORDDATA(S)), tuple_to_list(?ORDTYPE(S)), []);
to_sets(S) when ?IS_ORDSET(S) ->
    erlang:fault(badarg, [S]).

no_elements(S) when ?IS_SET(S) ->
    length(?LIST(S));
no_elements(S) when ?IS_ORDSET(S), is_tuple(?ORDTYPE(S)) ->
    size(?ORDDATA(S));
no_elements(S) when ?IS_ORDSET(S) ->
    erlang:fault(badarg, [S]).

specification(Fun, S) when ?IS_SET(S) ->
    Type = ?TYPE(S),
    R = case external_fun(Fun) of
	    false ->
		spec(?LIST(S), Fun, element_type(Type), []);
	    XFun ->
		specification(?LIST(S), XFun, [])
	end,
    case R of
	SL when is_list(SL) ->
	    ?SET(SL, Type);
	Bad ->
	    erlang:fault(Bad, [Fun, S])
    end.

union(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
    case unify_types(?TYPE(S1), ?TYPE(S2)) of
        [] -> erlang:fault(type_mismatch, [S1, S2]);
        Type ->  ?SET(umerge(?LIST(S1), ?LIST(S2)), Type)
    end.

intersection(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
    case unify_types(?TYPE(S1), ?TYPE(S2)) of
        [] -> erlang:fault(type_mismatch, [S1, S2]);
        Type ->  ?SET(intersection(?LIST(S1), ?LIST(S2), []), Type)
    end.

difference(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
    case unify_types(?TYPE(S1), ?TYPE(S2)) of
        [] -> erlang:fault(type_mismatch, [S1, S2]);
        Type ->  ?SET(difference(?LIST(S1), ?LIST(S2), []), Type)
    end.

symdiff(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
    case unify_types(?TYPE(S1), ?TYPE(S2)) of
        [] -> erlang:fault(type_mismatch, [S1, S2]);
        Type ->  ?SET(symdiff(?LIST(S1), ?LIST(S2), []), Type)
    end.

symmetric_partition(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
    case unify_types(?TYPE(S1), ?TYPE(S2)) of
        [] -> erlang:fault(type_mismatch, [S1, S2]);
        Type ->  sympart(?LIST(S1), ?LIST(S2), [], [], [], Type)
    end.

product(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
    if
        ?TYPE(S1) =:= ?ANYTYPE -> S1;
        ?TYPE(S2) =:= ?ANYTYPE -> S2;
        true ->
	    F = fun(E) -> {0, E} end,
	    T = ?BINREL(?TYPE(S1), ?TYPE(S2)),
	    ?SET(relprod(map(F, ?LIST(S1)), map(F, ?LIST(S2))), T)
    end.

product({S1, S2}) ->
    product(S1, S2);
product(T) when is_tuple(T) ->
    Ss = tuple_to_list(T),
    case catch sets_to_list(Ss) of
        {'EXIT', _} ->
            erlang:fault(badarg, [T]);
        [] ->
            erlang:fault(badarg, [T]);
        L ->
            Type = types(Ss, []),
            case member([], L) of
                true ->
		    empty_set();
                false -> 
                    ?SET(reverse(prod(L, [], [])), Type)
            end
    end.

constant_function(S, E) when ?IS_SET(S) ->
    case {?TYPE(S), is_sofs_set(E)} of
	{?ANYTYPE, true} -> S;
	{Type, true} ->
	    NType = ?BINREL(Type, type(E)),
	    ?SET(constant_function(?LIST(S), to_external(E), []), NType);
	_ -> erlang:fault(badarg, [S, E])
    end;
constant_function(S, E) when ?IS_ORDSET(S) ->
    erlang:fault(badarg, [S, E]).

is_equal(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
    case match_types(?TYPE(S1), ?TYPE(S2)) of
        true  -> ?LIST(S1) == ?LIST(S2);
        false -> erlang:fault(type_mismatch, [S1, S2])
    end;
is_equal(S1, S2) when ?IS_ORDSET(S1), ?IS_ORDSET(S2) ->
    case match_types(?ORDTYPE(S1), ?ORDTYPE(S2)) of
        true  -> ?ORDDATA(S1) == ?ORDDATA(S2);
        false -> erlang:fault(type_mismatch, [S1, S2])
    end;
is_equal(S1, S2) when ?IS_SET(S1), ?IS_ORDSET(S2) ->
    erlang:fault(type_mismatch, [S1, S2]);
is_equal(S1, S2) when ?IS_ORDSET(S1), ?IS_SET(S2) ->
    erlang:fault(type_mismatch, [S1, S2]).

is_subset(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
    case match_types(?TYPE(S1), ?TYPE(S2)) of
        true  -> subset(?LIST(S1), ?LIST(S2));
        false -> erlang:fault(type_mismatch, [S1, S2])
    end.

is_sofs_set(S) when ?IS_SET(S) ->
    true;
is_sofs_set(S) when ?IS_ORDSET(S) ->
    true;
is_sofs_set(_S) ->
    false.

is_set(S) when ?IS_SET(S) ->
    true;
is_set(S) when ?IS_ORDSET(S) ->
    false.

is_empty_set(S) when ?IS_SET(S) -> 
    ?LIST(S) =:= [];
is_empty_set(S) when ?IS_ORDSET(S) ->
    false.

is_disjoint(S1, S2) when ?IS_SET(S1), ?IS_SET(S2) ->
    case match_types(?TYPE(S1), ?TYPE(S2)) of
        true ->
            case ?LIST(S1) of
                [] -> true;
                [A | As] -> disjoint(?LIST(S2), A, As)
            end;
        false -> erlang:fault(type_mismatch, [S1, S2])
    end.

%%%
%%% Functions on set-of-sets.
%%%

union(Sets) when ?IS_SET(Sets) ->
    case ?TYPE(Sets) of
        ?SET_OF(Type) -> ?SET(lunion(?LIST(Sets)), Type);
        ?ANYTYPE -> Sets;
        _ -> erlang:fault(badarg, [Sets])
    end.

intersection(Sets) when ?IS_SET(Sets) ->
    case ?LIST(Sets) of
        [] -> erlang:fault(badarg, [Sets]);
        [L | Ls] ->
            case ?TYPE(Sets) of
                ?SET_OF(Type) ->
                    ?SET(lintersection(Ls, L), Type);
                _ -> erlang:fault(badarg, [Sets])
            end
    end.

canonical_relation(Sets) when ?IS_SET(Sets) ->
    ST = ?TYPE(Sets),
    case ST of
        ?SET_OF(?ANYTYPE) -> empty_set();
        ?SET_OF(Type) -> 
            ?SET(can_rel(?LIST(Sets), []), ?BINREL(Type, ST));
        ?ANYTYPE -> Sets;
        _ -> erlang:fault(badarg, [Sets])
    end.

%%%