home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume10 / ifp / part03 / interp / F_seq.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-07-05  |  9.9 KB  |  451 lines
  1.  
  2. /****** F_seq.c *******************************************************/
  3. /**                                                                  **/
  4. /**                    University of Illinois                        **/
  5. /**                                                                  **/
  6. /**                Department of Computer Science                    **/
  7. /**                                                                  **/
  8. /**   Tool: IFP                         Version: 0.5                 **/
  9. /**                                                                  **/
  10. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  11. /**                                                                  **/
  12. /**   Revised by: Arch D. Robison       Date:   Aug 5, 1986          **/
  13. /**                                                                  **/
  14. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  15. /**                            Prof. W. J. Kubitz                    **/
  16. /**                                                                  **/
  17. /**                                                                  **/
  18. /**------------------------------------------------------------------**/
  19. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  20. /**                       All Rights Reserved.                       **/
  21. /**********************************************************************/
  22.  
  23. /******************* sequence (structural) functions ******************/
  24.  
  25. #include <stdio.h>
  26. #include "struct.h"
  27. #include "node.h"
  28.  
  29. /*
  30.  * F_Cat
  31.  *
  32.  * Sequence catenation
  33.  */
  34. private F_Cat (InOut)
  35.    register ObjectPtr InOut;
  36.    {
  37.       register MetaPtr E;
  38.       register ListPtr P;
  39.  
  40.       if (InOut->Tag != LIST) {
  41.      FunError (ArgNotSeq,InOut);
  42.      return;
  43.       }
  44.       P = InOut->List;
  45.       if (P == NULL) return;
  46.  
  47.       do
  48.      if (P->Val.Tag != LIST) {
  49.         FunError ("elements not sequences",InOut);
  50.         return;
  51.      }
  52.       while ((P=P->Next)!=NULL);
  53.  
  54.       Copy2Top (& InOut->List);
  55.       if (SysError) return;
  56.  
  57.       P = InOut->List;
  58.       E = &P->Val.List;
  59.       for (P=P->Next; P!=NULL; P=P->Next) {
  60.      while (*E!=NULL) E = &(*E)->Next;
  61.      *E = P->Val.List;
  62.      P->Val.Tag = BOTTOM;
  63.       }
  64.       E = &InOut->List;
  65.       RepLPtr (E,(*E)->Val.List);
  66.    }
  67.  
  68.  
  69. /*
  70.  * F_Iota
  71.  *
  72.  * Generate <1...id>
  73.  */
  74. private F_Iota (InOut)
  75.    register ObjectPtr InOut;
  76.    {
  77.       FPint N;
  78.       register FPint K;
  79.       register ListPtr Pr;
  80.  
  81.       switch (GetFPInt (InOut,&N)) {
  82.      case 1: FunError ("not an integer",InOut); return;
  83.      case 2: FunError ("too big"       ,InOut); return;
  84.      case 0:
  85.         if (N < 0) FunError ("negative",InOut);
  86.         else {
  87.            InOut->Tag = LIST;
  88.            InOut->List = NULL;  
  89.            NewList (&InOut->List,N);
  90.            if (SysError) return;
  91.            for (Pr=InOut->List,K=0; Pr!=NULL; Pr=Pr->Next) 
  92.           Pr->Val.Tag = INT,
  93.           Pr->Val.Int = ++K;
  94.         }
  95.         return;
  96.       }
  97.    }
  98.  
  99.  
  100. /*
  101.  * F_Id
  102.  */
  103. private F_Id ()
  104.    {
  105.       return; /* do nothing */;
  106.    }
  107.  
  108.  
  109. /*
  110.  * F_Length
  111.  *
  112.  * Find sequence length
  113.  */
  114. private F_Length (InOut)
  115.    ObjectPtr InOut;
  116.    {
  117.       register FPint N;
  118.  
  119.       switch (InOut->Tag) {
  120.      default:
  121.         FunError (ArgNotSeq,InOut);
  122.         return;
  123.      case LIST:
  124.         N = ListLength (InOut->List);
  125.         break;
  126.       }
  127.       RepTag (InOut,INT);
  128.       InOut->Int = N;
  129.    }
  130.  
  131. /*
  132.  * F_LApnd
  133.  *
  134.  *           +--------+
  135.  * InOut --->|  list  |
  136.  *           +----+---+ A
  137.  *                |     |
  138.  *                V     V
  139.  *           +------------+      +------------+
  140.  *           | object | o-+----->|  list  |///|
  141.  *           +------------+      +---+--------+
  142.  *                                   |
  143.  *                                   V
  144.  *                                  ...
  145.  */
  146. private F_LApnd (InOut)
  147.    ObjectPtr InOut;
  148.    {
  149.       MetaPtr A;
  150.       if (! PairTest (InOut, ~0, SEQUENCE))
  151.      FunError (ArgObSeq,InOut);
  152.       else {
  153.      CopyTop (&InOut->List);
  154.      A = & InOut->List->Next;
  155.      RepLPtr (A,(*A)->Val.List);
  156.       }
  157.    }
  158.  
  159.  
  160. /*
  161.  * F_RApnd
  162.  *
  163.  *           +--------+
  164.  * InOut --->|  list  |
  165.  *           +----+---+
  166.  *                |
  167.  *                V
  168.  *           +------------+      +------------+
  169.  *           |  list  | o-+----->| object |///|
  170.  *           +------------+      +------------+
  171.  *                |
  172.  *                V
  173.  *               ...
  174.  *
  175.  */
  176. private F_RApnd (InOut)
  177.    ObjectPtr InOut;
  178.    {
  179.       register MetaPtr E;
  180.       ListPtr P;
  181.  
  182.       if (! PairTest (InOut,1 << LIST,~0))
  183.      FunError (ArgSeqOb,InOut);
  184.  
  185.       else {
  186.      Copy2Top (& InOut->List);
  187.      if (SysError) return;
  188.      P = InOut->List;
  189.      for (E = &P->Val.List; (*E)!=NULL; E = &(*E)->Next) continue;
  190.      *E = P->Next;
  191.      P->Next=NULL;
  192.      RepLPtr (&InOut->List,P->Val.List);
  193.      /* No system error possible since source is fresh list */
  194.       }
  195.    }
  196.  
  197. /*
  198.  * F_LDist
  199.  *
  200.  * Distribute from left
  201.  */
  202. private F_LDist (InOut)
  203.    ObjectPtr InOut;
  204.    {
  205.       ListPtr R=NULL;
  206.       register ListPtr P1,P2,P3,PT;
  207.       long N;
  208.  
  209.       if (!PairTest (InOut, ~0, SEQUENCE))
  210.  
  211.      FunError (ArgObSeq,InOut);
  212.  
  213.       else {
  214.  
  215.      Copy2Top (&InOut->List);
  216.      if (SysError) return;
  217.      P1 = InOut->List;             /* P1 = pointer to arg list     */
  218.      P2 = P1->Next;
  219.      P3 = P2->Val.List;         /* P3 = pointer to 2nd arg list */
  220.      P2->Val.List = NULL;
  221.      N = ListLength (P3); 
  222.      NewList (&R,N);        /* R = pointer to result list   */
  223.      if (SysError) return;
  224.      P2 = Repeat (&P1->Val,N);    /* P2 = pointer to 1st arg list */
  225.      if (SysError) {DelLPtr (R); return;}
  226.  
  227.      for (P1=R; P1!=NULL; P1=P1->Next) {
  228.         P1->Val.Tag = LIST;
  229.         P1->Val.List = P2;
  230.         PT = P2;
  231.         P2 = P2->Next;
  232.         PT->Next = P3;
  233.         PT = P3;
  234.         P3 = P3->Next;
  235.         PT->Next = NULL;
  236.      }
  237.  
  238.      DelLPtr (InOut->List);
  239.      InOut->List = R;
  240.       }
  241.    }
  242.  
  243.  
  244. /*
  245.  * F_RDist
  246.  *
  247.  * Distribute from right
  248.  */
  249. private F_RDist (InOut)
  250.    ObjectPtr InOut;
  251.    {
  252.       ListPtr R,P,P1,P2;
  253.       long N;
  254.  
  255.       if (! PairTest (InOut, SEQUENCE, ~0))
  256.  
  257.      FunError (ArgSeqOb,InOut);
  258.  
  259.       else {
  260.  
  261.      Copy2Top (&InOut->List);
  262.      if (SysError) return;
  263.      P = InOut->List;            /* P = pointer to arg list */
  264.      P2 = P->Val.List;        /* P2 = pointer to first arg list */
  265.      P->Val.Tag = BOTTOM;
  266.      P = P->Next;                     /* P = pointer to 2nd arg */
  267.      N = ListLength (P2);
  268.      R = NULL; NewList (&R,N);        /* R = pointer to result list */
  269.      if (SysError) return;
  270.  
  271.      for (P1=R; P1!=NULL; P1=P1->Next) {
  272.         P1->Val.Tag = LIST;
  273.         P1->Val.List = CopyLPtr (P);
  274.         if (SysError) {DelLPtr (R); return;}
  275.         Rot3 (&P1->Val.List,&P2,&P2->Next);
  276.      }
  277.      RepLPtr (&InOut->List,R);
  278.      DelLPtr (R);
  279.       }
  280.    }
  281.  
  282.  
  283. /*
  284.  * F_Reverse
  285.  *
  286.  * Reverse a list
  287.  */
  288. F_Reverse (InOut)     /* Imported by F_RInsert in forms.c */
  289.    ObjectPtr InOut;
  290.    {
  291.       ListPtr P,Q;
  292.  
  293.       switch (InOut->Tag) {
  294.      default:
  295.         FunError (ArgNotSeq,InOut);
  296.         break;
  297.      case LIST:
  298.         P = InOut->List;
  299.         CopyTop (&P);
  300.         if (SysError) return;
  301.         for (Q=NULL; P!=NULL; Rot3 (&P,&P->Next,&Q)) continue; 
  302.         InOut->List = Q;
  303.         break;
  304.       }
  305.    }
  306.  
  307.  
  308. /*
  309.  * TransCheck
  310.  *
  311.  * Check that InOut is matrix
  312.  *
  313.  * Input
  314.  *     InOut = pointer to object
  315.  *
  316.  * Output
  317.  *     result = NULL iff a matrix, error code otherwise.
  318.  *     *Cols = number of columns
  319.  */
  320. private char *TransCheck (InOut,Cols)
  321.    ObjectPtr InOut;
  322.    long *Cols;
  323.    {
  324.       register ListPtr V,VR;
  325.  
  326.       if (InOut->Tag != LIST)
  327.      return "argument not a sequence.";
  328.       else if (NULL == (VR = InOut->List))
  329.      return "argument is empty sequence.";
  330.       else
  331.      for (V = VR; V !=NULL; V = V->Next)
  332.         if (V->Val.Tag != LIST)
  333.            return "argument subelements must be sequences.";
  334.         else if (V==VR) *Cols = ListLength (V->Val.List);
  335.         else if (*Cols != ListLength (V->Val.List))
  336.            return "argument not rectangular.";
  337.         else continue;
  338.       return NULL;
  339.    }
  340.  
  341.  
  342. /*
  343.  * F_Trans
  344.  *
  345.  * Transpose a matrix (sequence of sequences)
  346.  */
  347. private F_Trans (InOut)
  348.    ObjectPtr InOut;
  349.    {
  350.       char *E; long Cols;
  351.       ListPtr VR,HR,H;
  352.       register ListPtr U,V;
  353.       register MetaPtr A;
  354.  
  355.       /* Check for rectangularness */
  356.       if (NULL != (E = TransCheck (InOut,&Cols))) {
  357.      FunError (E,InOut);
  358.      return;
  359.       }
  360.  
  361.       /* Make fresh copy of vertical top level  and rows */
  362.       Copy2Top (&InOut->List);
  363.       if (SysError) return;
  364.       else VR = InOut->List;
  365.     
  366.       /* Make horizontal top level */
  367.       HR = NULL;
  368.       NewList (&HR,Cols);
  369.  
  370.       /* Transpose matrix column by column */
  371.       for (H=HR; H!=NULL; H=H->Next) {
  372.      H->Val.Tag = LIST;
  373.      H->Val.List = VR->Val.List;
  374.  
  375.      /* Relink the column and advance the VR list to the next column */
  376.      for (V=VR; V!=NULL; V=U) {
  377.         U = V->Next;
  378.         A = &V->Val.List->Next;
  379.         V->Val.List = *A;
  380.         *A = U==NULL ? NULL : U->Val.List;
  381.      }
  382.       }
  383.       /* Delete the old vertical top level and return new matrix */
  384.       DelLPtr (VR); InOut->List = HR;
  385.    }
  386.  
  387.  
  388. /*
  389.  * F_Tail
  390.  */
  391. private F_Tail (InOut)
  392.    ObjectPtr InOut;
  393.    {
  394.       register ListPtr P;
  395.       switch (InOut->Tag) {
  396.      default:
  397.         FunError (ArgNotSeq,InOut);
  398.         break;
  399.      case LIST:
  400.         if (NULL == (P = InOut->List)) FunError (ArgNull,InOut);
  401.         else RepLPtr (&InOut->List,P->Next);
  402.         break;
  403.       }
  404.    }
  405.  
  406.  
  407. /*
  408.  * F_RTail
  409.  *
  410.  * Drop last element
  411.  */
  412. private F_RTail (InOut)
  413.    ObjectPtr InOut;
  414.    {
  415.       register MetaPtr A;
  416.       if (InOut->Tag != LIST)
  417.      FunError (ArgNotSeq,InOut);
  418.       else if (NULL == InOut->List)
  419.      FunError (ArgNull,InOut);
  420.       else {
  421.      CopyTop (A = &InOut->List);
  422.      if (SysError) return;
  423.      while ((*A)->Next != NULL) A = &(*A)->Next;
  424.      RepLPtr (A,(ListPtr) NULL);
  425.       }
  426.    }
  427.  
  428.  
  429. OpDef SeqOps [] = {
  430.    {"apndl",    -1,     F_LApnd},
  431.    {"apndr",    -1,     F_RApnd},
  432.    {"cat",      -1,     F_Cat},
  433.    {"distl",    -1,     F_LDist},
  434.    {"distr",    -1,     F_RDist},
  435.    {"id",       -1,     F_Id},
  436.    {"iota",     -1,     F_Iota},
  437.    {"length",   -1,     F_Length},
  438.    {"reverse",  -1,     F_Reverse},
  439.    {"tl",       -1,     F_Tail},
  440.    {"tlr",      -1,     F_RTail},
  441.    {"trans",    -1,     F_Trans}
  442. };
  443.  
  444. void D_seq ()
  445.    {
  446.       GroupDef (SeqOps, OpCount (SeqOps), SysNode);
  447.    }  
  448.  
  449. /************************** end of F_seq **************************/
  450.  
  451.