gsort: fix tests after decomplexification
[scilab.git] / scilab / modules / elementary_functions / macros / %gsort_multilevel.sci
1 // Scilab ( http://www.scilab.org/ ) - This file is part of Scilab
2 // Copyright (C) 2020 - Samuel GOUGEON
3 //
4 // This file is hereby licensed under the terms of the GNU GPL v2.0,
5 // pursuant to article 5.3.4 of the CeCILL v.2.1.
6 // This file was originally licensed under the terms of the CeCILL v2.1,
7 // and continues to be available under such terms.
8 // For more information, see the COPYING file which you should have
9 // received along with this program.
10
11 function [sorted, K] = %gsort_multilevel(array, sortype, sortdir, criteria)
12     // This internal overload sorts only dense matrices.
13     // For hypermatrices, %hm_gsort() is called upstream
14     //   - to reformat the input as a matrix
15     //   - to call %_gsort() with the equivalent input matrix
16     //   - to reformat the output as expected
17     //   There is nothing specific to complex numbers with hypermatrices
18     // For sparse matrices, %sp_gsort() is called upstream.
19     //
20     // array   : vector or matrix to be sorted.
21     //           Hypermatrices are pre- and post-processed by %hm_gsort()
22     // sortype : "g" "r" "c" "lr" "lc". Default "g"
23     // sortdir: [], or vector of "i" or "d". Default = "d"
24     // criteria: list of Scilab functions or primitives handles, or :.
25     //           When a function fun requires some additional parameters
26     //           a, b, c, ... list(fun, a, b, c,..) must be provided
27     //           instead of only fun.
28
29     sa = size(array)
30
31     // CHECKING INPUT PARAMETERS
32     // -------------------------
33     // array:
34     // This overload is called only when array is defined and are complex numbers
35
36     // sortype:
37     if ~isdef("sortype", "l") || sortype==[] || (type(sortype)==10 && sortype(1)=="")
38         sortype = "g"
39     elseif type(sortype)~=10
40         msg = _("%s: Argument #%d: Text(s) expected.\n")
41         error(msprintf(msg, "gsort", 2))
42     else
43         sortype = convstr(sortype(1))
44         if ~or(sortype==["g" "r" "c" "lr" "lc"])
45             msg = _("%s: Argument #%d: Must be in the set {%s}.\n")
46             error(msprintf(msg, "gsort", 2, "''g'',''r'',''c'',''lc'',''lr''"))
47         end
48     end
49
50     // sortdir:
51     if ~isdef("sortdir", "l") || sortdir==[]
52         sortdir = "d"           // for back-compatibility
53     elseif type(sortdir)~=10
54         msg = _("%s: Argument #%d: Text(s) expected.\n")
55         error(msprintf(msg, "gsort", 3))
56     else
57         sortdir = convstr(sortdir)
58         k = find(sortdir <> "i" & sortdir <> "d")
59         if k <> []
60             msg = _("%s: Argument #%d: Must be in the set {%s}.\n")
61             error(msprintf(msg, "gsort", 3, "''i'',''d''"))
62         end
63     end
64
65     // criteria:
66     if type(criteria) <> 15 then
67         msg = _("%s: Argument #%d: List expected.\n")
68         error(msprintf(msg, "gsort", 4))
69     end
70     if size(criteria) <> size(sortdir,"*") then
71         msg = _("%s: Arguments #%d and #%d: Same numbers of elements expected.\n")
72         error(msprintf(msg, "gsort", 3, 4))
73     end
74     for c = criteria
75         t = type(c)==13 || typeof(c)=="fptr" || ..
76            (typeof(c)=="implicitlist" && (1:1:$)==c)
77         if ~t & type(c)==15
78             if length(c) > 0
79                 t = type(c(1))==13 || typeof(c(1))=="fptr" || ..
80                    (typeof(c(1))=="implicitlist" && (1:1:$)==c(1))
81             end
82         end
83         if ~t
84             msg = _("%s: Argument #%d: List of functions identifiers expected.\n")
85             error(msprintf(msg, "gsort", 4))
86         end
87     end
88
89     // ONLY ONE LEVEL => SIMPLE DIRECT PROCESSING
90     // ------------------------------------------
91     if size(criteria)==1 then
92         fun = criteria(1)
93         if typeof(fun)=="implicitlist" & fun==(1:1:$)
94             [sorted, K] = gsort(array, sortype, sortdir)
95         else
96             v = %gsort_eval(array, fun)
97             [sorted, K] = gsort(v, sortype, sortdir)
98             select sortype
99             case "g"
100                 sorted = matrix(array(K), size(array))
101             case "r"
102                 C = ones(sa(1),1) * (1:sa(2))
103                 sorted = matrix(array(K+(C-1)*sa(1)), sa)
104             case "c"
105                 R = (1:sa(1))' * ones(1,sa(2))
106                 sorted = matrix(array(R+(K-1)*sa(1)), sa)
107             case "lr"
108                 sorted = array(K, :)
109             case "lc"
110                 sorted = array(:, K)
111             end
112         end
113         if type(array)==1 & ~isreal(array) & isreal(sorted)
114             sorted = complex(sorted, 0)
115         end
116         return
117     end
118
119     // OTHERWISE:
120     // BUILDING THE MATRIX OF SEPARATE RANKS
121     // -------------------------------------
122     nbcrit = length(criteria)
123     a = array(:)
124     kk = []
125     for i = 1:nbcrit
126         fun = criteria(i)
127         v = %gsort_eval(a, fun)
128         [vs, k0] = gsort(v(:), "g", sortdir(i))
129         [?, k2] = gsort(k0,"g","i")
130         // The k(i) of equal elements following the first one must be
131         //  set to the heading index:
132         b = [%T ; vs(2:$) <> vs(1:$-1)];
133         k = cumsum(b);  // Done!
134         kk = [kk k(k2)];
135     end
136
137     // SORTING
138     // -------
139     if sortype=="g" then
140         [?, K] = gsort(kk, "lr", "i");
141         K = matrix(K, sa)
142         sorted = matrix(array(K), sa)
143
144     elseif or(sortype==["c" "r"]) then
145         [?, K] = gsort(kk, "lr", "i");
146         K = matrix(K, sa)
147         z = zeros(sa(1),sa(2))
148         z(K) = 1:prod(sa)
149         [?, K] = gsort(z, sortype, "i")
150         if sortype=="c" then
151             R = (1:sa(1))' * ones(1,sa(2))
152             sorted = matrix(array(R+(K-1)*sa(1)), sa)
153         else // "r"
154             C = ones(sa(1),1) * (1:sa(2))
155             sorted = matrix(array(K+(C-1)*sa(1)), sa)
156         end
157
158     elseif sortype=="lr" then
159         tmp = ones(nbcrit,1)*(1:sa(2))+(0:nbcrit-1)'*ones(1,sa(2))*sa(2)
160         tmp = matrix(kk, sa(1), -1)(:,tmp)
161         [?, K] = gsort(tmp, "lr", "i");
162         sorted = array(K, :)
163
164     else // sortype=="lc"
165         tmp = matrix(kk',nbcrit*sa(1), -1)'
166         [?, K] = gsort(tmp, "lr", "i");
167         K = K'
168         sorted = array(:,K)
169     end
170
171     if type(array)==1 & ~isreal(array) & isreal(sorted)
172         sorted = complex(sorted, 0)
173     end
174 endfunction
175 // ------------------------------------------------------
176 function v = %gsort_eval(a, fun)
177     if type(fun)==15
178         params = fun
179         params(1) = null()
180         fun = fun(1)
181         if typeof(fun)=="fptr" & fun==atan & type(a)==1 & ~isreal(a)
182             v = fun(imag(a), real(a)) + params(1)
183         else
184             v = fun(a, params(:))
185         end
186     elseif typeof(fun)=="fptr" & fun==atan & type(a)==1 & ~isreal(a)
187         v = atan(imag(a), real(a))
188     elseif typeof(fun)=="implicitlist" & (1:1:$)==fun
189         v = a
190     else
191         v = fun(a)
192     end
193 endfunction