home *** CD-ROM | disk | FTP | other *** search
/ Magazyn Amiga 13 / MA_Cover_13.bin / source / c / apl / a5.c < prev    next >
Encoding:
C/C++ Source or Header  |  1999-11-23  |  2.6 KB  |  193 lines
  1. #include "apl.h"
  2.  
  3. ex_rav()
  4. {
  5.     struct item *p, *r;
  6.  
  7.     p = fetch1();
  8.     if(p->rank == 0) {
  9.         r = newdat(p->type, 1, 1);
  10.         putdat(r, getdat(p));
  11.         pop();
  12.         *sp++ = r;
  13.         return;
  14.     }
  15.     rav0(p->rank-1);
  16. }
  17.  
  18. ex_ravk()
  19. {
  20.     int i;
  21.  
  22.     i = topfix() - thread.iorg;
  23.     fetch1();
  24.     rav0(i);
  25. }
  26.  
  27. rav0(k)
  28. {
  29.     struct item *p, *r, *param[2];
  30.     int rav1();
  31.  
  32.     p = sp[-1];
  33.     bidx(p);
  34.     colapse(k);
  35.     r = newdat(p->type, 1, p->size);
  36.     param[0] = p;
  37.     param[1] = r;
  38.     forloop(rav1, param);
  39.     pop();
  40.     *sp++ = r;
  41. }
  42.  
  43. rav1(param)
  44. struct item *param[];
  45. {
  46.     struct item *p;
  47.     int i, n;
  48.  
  49.     p = param[0];
  50.     n = access();
  51.     for(i=0; i<idx.dimk; i++) {
  52.         p->index = n;
  53.         putdat(param[1], getdat(p));
  54.         n += idx.delk;
  55.     }
  56. }
  57.  
  58. ex_cat()
  59. {
  60.     struct item *p, *q, *r;
  61.     int k;
  62.  
  63.     p = fetch2();
  64.     q = sp[-2];
  65.     k = p->rank;
  66.     if(q->rank > k) k = q->rank;
  67.     if(k == 0) {
  68.         r = newdat(p->type, 1, 2);
  69.         putdat(r, getdat(p));
  70.         putdat(r, getdat(q));
  71.         pop();
  72.         pop();
  73.         *sp++ = r;
  74.     }
  75.     else cat0(k-1);
  76. }
  77.  
  78. ex_catk()
  79. {
  80.     int k;
  81.     double d, top();
  82.  
  83.     d = top();
  84.     k = fix(d);
  85.     fetch2();
  86.     if (0 == fuzz(d, (double)k)) cat0(k-1);
  87.     else lam0(d);
  88. }
  89.  
  90. cat0(k)
  91. {
  92.     struct item *p, *q, *r;
  93.     int i, a, b;
  94.  
  95.     p = sp[-1];
  96.     q = sp[-2];
  97.     i = k;
  98.     if(p->rank >=  q->rank) {
  99.         bidx(p);
  100.         b = cat1(q, i);
  101.         a = idx.dim[i];
  102.     }
  103.     else {
  104.         bidx(q);
  105.         a = cat1(p, i);
  106.         b = idx.dim[i];
  107.     }
  108.     idx.dim[i] = a+b;
  109.     size();
  110.     r = newdat(p->type, idx.rank, idx.size);
  111.     copy(IN, idx.dim, r->dim, idx.rank);
  112.     i = idx.del[i];
  113.     a *= i;
  114.     b *= i;
  115.     while(r->index < r->size) {
  116.         for(i=0; i<a; i++) putdat(r, getdat(p));
  117.         for(i=0; i<b; i++) putdat(r, getdat(q));
  118.     }
  119.     pop();
  120.     pop();
  121.     *sp++ = r;
  122. }
  123.  
  124. cat1(ip, k)
  125. struct item *ip;
  126. {
  127.     struct item *p;
  128.     int i, j, a;
  129.  
  130.     if(k < 0 || k >= idx.rank) error("cat X");
  131.     p = ip;
  132.     a = 1;
  133.     if(p->rank == 0) return(a);
  134.     j = 0;
  135.     for(i=0; i<idx.rank; i++) {
  136.         if(i == k) {
  137.             if(p->rank == idx.rank) {
  138.                 a = p->dim[i];
  139.                 j++;
  140.             }
  141.             continue;
  142.         }
  143.         if(idx.dim[i] != p->dim[j]) error("cat C");
  144.         j++;
  145.     }
  146.     return(a);
  147. }
  148.  
  149.  
  150. double
  151. top()
  152. {
  153.     struct item *p;
  154.     double d;
  155.  
  156.     p = fetch1();
  157.     if (p->type != DA || p->size != 1) error("topval C");
  158.     d = p->datap[0];
  159.     pop();
  160.     return d;
  161. }
  162.  
  163.  
  164. lam0(d)
  165. double d;
  166. {
  167.     struct item *p, *q, *r;
  168.     int i, j, k;
  169.  
  170.     p = sp[-1];
  171.     q = sp[-2];
  172.     if (q->rank > p->rank) p = q;
  173.     if (p->rank >= MRANK) error("lam X");
  174.     idx.type = p->type;
  175.     idx.rank = p->rank + 1;
  176.     k = fix(d) - thread.iorg;
  177.     if (k < 0 || k >= p->rank+1) error("lam X");
  178.     j = 0;
  179.     for (i=0; i<p->rank; i++) {
  180.         if (i == k) idx.dim[j++] = 1;
  181.         idx.dim[j++] = p->dim[i];
  182.     }
  183.     if (i == k) idx.dim[j] = 1;
  184.     size();
  185.     r = newdat(idx.type, idx.rank, idx.size);
  186.     copy(IN, idx.dim, r->dim, idx.rank);
  187.     copy(idx.type, p->datap, r->datap, r->size);
  188.     if (p == sp[-1]) sp[-1] = r;
  189.     else sp[-2] = r;
  190.     aplfree(p);
  191.     cat0(k);
  192. }
  193.