share/contrib/noninteractive/expand_branches.mac

   1 /* evaluate branches of "if" assuming conditions */
   2
   3 matchdeclare (ii, ifp);
   4 ifp (e) := not atom(e) and (op(e) = "if" or op(e) = nounify("if"));
   5
   6 defrule
   7  (expand_branches,
   8   ii,
   9   block
  10    ([aa : args (ii)],
  11     makelist ([aa[2*jj - 1], aa[2*jj]], jj, 1, length(aa)/2),
  12     map (lambda ([pp], [pp[1], apply (assuming, [[pp[1]], buildq ([e : pp[2]], expand_branches1 (e))])]), %%),
  13     subst (expand_branches1 = ?mprogn, %%), /* DON'T YET UNDERSTAND HOW EXPAND_BRANCHES1 APPEARS ... REMOVE IT ANYWAY !! */
  14     apply (append, %%),
  15     apply ("if", %%)));
  16
  17 expand_branches1 (u) := (expand_branches(u), if %% = false then u else %%);
  18
  19 defrule
  20  (merge_branches,
  21   ii,
  22   block
  23    ([aa : args (ii), conditions, expressions, new_conditions, new_expressions, j, k],
  24     conditions : makelist (aa[2*i - 1], i, 1, length (aa) / 2),
  25     expressions : makelist (aa[2*i], i, 1, length (aa) / 2),
  26     new_conditions : [first (conditions)],
  27     new_expressions : [first (expressions)],
  28     for i:2 thru length (conditions) do
  29       if (j : find_index (expressions [i], new_expressions)) # false
  30       then
  31         new_conditions [j] : new_conditions [j] or (conditions [i] and not apply ("or", sublist_elements (new_conditions, 1, j)))
  32       else
  33        (push (conditions [i], new_conditions),
  34         push (expressions [i], new_expressions)),
  35     apply (op (ii), join (reverse (new_conditions), reverse (new_expressions)))));
  36
  37 find_index (x, L) := catch (block (for i thru length (L) do if L[i] = x then throw (i), false));
  38
  39 delete_element (L, i) :=
  40   if i < 1 or i > length (L)
  41     then L
  42     else append (makelist (L[j], j, 1, i - 1), makelist (L[j], j, i + 1, length (L)));
  43
  44 sublist_elements (L, m, n) := if m < n then makelist (L[i], i, m, n - 1) else [];
  45
  46 tabulate (e) := block ([v : sort (listofvars (e))], makelist (block ([l : bits (i, length (v))], map ("=", v, l), ev (e, %%)), i, 0, 2^length(v) - 1));
  47
  48 bits (m, n) := block ([b : []], for j thru n do (if oddp (m) then push (true, b) else push (false, b), m : floor (m/2)), b);
  49
  50 defrule
  51  (flatten_branches,
  52   ii,
  53   block
  54    ([aa : args (ii), conditions, expressions, new_conditions, new_expressions],
  55     conditions : makelist (aa[2*i - 1], i, 1, length (aa) / 2),
  56     expressions : makelist (aa[2*i], i, 1, length (aa) / 2),
  57     new_conditions : [],
  58     new_expressions : [],
  59     for i thru length (expressions)
  60       do
  61         if ifp (expressions [i])
  62         then
  63           block
  64            ([aa1 : args (expressions [i])],
  65             while aa1 # [] do
  66              (push (conditions [i] and pop (aa1), new_conditions),
  67               push (pop (aa1), new_expressions)))
  68         else
  69            (push (conditions [i], new_conditions),
  70             push (expressions [i], new_expressions)),
  71      apply (op (ii), join (reverse (new_conditions), reverse (new_expressions)))));
  72
  73 defrule
  74  (subst_branches,
  75   ii,
  76   block
  77    ([aa : args (ii), conditions, expressions, new_conditions, new_expressions],
  78     conditions : makelist (aa[2*i - 1], i, 1, length (aa) / 2),
  79     expressions : makelist (aa[2*i], i, 1, length (aa) / 2),
  80     new_conditions : [],
  81     new_expressions : [],
  82     for i thru length (expressions)
  83       do
  84         block ([cc : conditions [i], ee : expressions [i]],
  85           if not atom(cc) and (op(cc) = "=" or op(cc) = 'equal)
  86             then
  87              (push (cc, new_conditions),
  88               push (subst (if op(cc) = 'equal then subst ('equal = "=", cc) else cc, ee), new_expressions))
  89             else
  90              (push (cc, new_conditions),
  91               push (ee, new_expressions))),
  92     apply (op (ii), join (reverse (new_conditions), reverse (new_expressions)))));
  93