home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e050 / 1.ddi / SHELL.OPS < prev    next >
Encoding:
Text File  |  1986-06-15  |  14.8 KB  |  692 lines
  1. module shell () {
  2.  
  3. -----------------------------------------------------------------------
  4. -----------------------------------------------------------------------
  5. --                                     --
  6. --     An interactive top-level for use with OPS83 programs          --
  7. --                                     --
  8. -----------------------------------------------------------------------
  9. -----------------------------------------------------------------------
  10.  
  11.  
  12. --
  13. -- DEFINITIONS
  14. --
  15.  
  16. global 
  17.     &RUNFLG : logical,            -- set to 0B to halt firings
  18.     &LINE : name,            -- the current input line
  19.     &LNDX : integer,            -- next char in &LINE to process
  20.     &COM : char,            -- the current command
  21.     &ARGS : array(20 : name),        -- the arguments
  22.     &ACNT : integer,            -- how many arguments there are
  23.     &TLEV : integer;            -- current trace level
  24.  
  25.  
  26. type start = element(task:integer);
  27.  
  28.  
  29. --
  30. -- FIRING RULES
  31. --
  32.  
  33.  
  34. procedure wmtrace()
  35. -- print trace info about wm changes
  36.   {
  37.     if (wmcadd())
  38.     write() |=>wm:|
  39.     else
  40.     write() |<=wm:|;
  41.     write() wmctype(), '\n';
  42.   };
  43.  
  44. procedure notrace()
  45. -- print no trace information
  46.   {
  47.   };
  48.  
  49.  
  50. function select():integer
  51. -- select the dominant instantiation and return its number; return 0 if
  52. -- there are no unfired instantiations
  53.   {
  54.     local
  55.         &C:integer,        -- current best choice
  56.     &CTAG:integer,         -- time tag of goal of &C
  57.     &CLEN:integer,        -- length of inst &C
  58.     &CUSE:integer,        -- number of times &C has fired
  59.     &CRANK:real,        -- rank order of &C
  60.     &CCNT:integer,        -- number of CEs in &C
  61.     &N:integer,        -- next inst to look at
  62.     &NTAG:integer,        -- time tag of goal of &T
  63.     &NLEN:integer,        -- length of inst &N
  64.     &NUSE:integer,        -- number of times &C has fired
  65.     &NRANK:real,        -- rank number for &N
  66.     &NCNT:integer,        -- number of CEs in &N
  67.     &CSS:integer;        -- CS size
  68.  
  69.     -- get the first unfired inst
  70.     &CSS = cssize();
  71.     &C=0;
  72.     &N=&CSS;
  73.     while (&C=0)
  74.       {
  75.         if (instance(&N,&CTAG,&CUSE,&CRANK,&CLEN,&CCNT) = 0b)
  76.         return(0);
  77.         if (&CUSE=0)
  78.         &C=&N
  79.     else
  80.         &N=&N-1;
  81.       };
  82.  
  83.     -- check the rest to find the dominant one
  84.     &N = &C-1;
  85.     while(1b)
  86.       {
  87.         if (instance(&N,&NTAG,&NUSE,&NRANK,&NLEN,&NCNT) = 0b)
  88.         return(&C);
  89.         if (&NUSE = 0)
  90.       {
  91.         if (&NTAG>&CTAG \/ (&NTAG=&CTAG /\ &NLEN>&CLEN))
  92.           {&C=&N; &CLEN=&NLEN; &CTAG=&NTAG;};
  93.       };
  94.     &N = &N-1;
  95.       };
  96.   };
  97.  
  98.  
  99.  
  100.  
  101. procedure run(&L:integer)
  102. -- fire rules for up to &L cycles.  if &L is less than 0, run for an
  103. -- indeterminate number of cycles.
  104.   {
  105.     local &I:integer,&C:integer,&NL:integer,&N:name,&TMP:integer;
  106.  
  107.     &RUNFLG = 1B;
  108.     &I = 1;
  109.     while(&L < 0 \/ &I <= &L)
  110.       {
  111.         &C = select();
  112.     if (&C < 1) return;
  113.     if (&TLEV > 0)
  114.       {
  115.         write() |fire:|;
  116.         &NL = irule(&N,&C);
  117.             for &TMP = (1 to &NL) write() &N[&TMP];
  118.             write() '\n';
  119.       };
  120.     fire &C;
  121.         if (&RUNFLG = 0B) return;
  122.     &I = &I + 1;
  123.       };
  124.   };
  125.  
  126.  
  127. --
  128. -- UTILITIES
  129. --
  130.  
  131. procedure error(&MSG:symbol)
  132. -- writes out an error message and sets the value of &COM to null
  133. -- to cause this input line to be ignored
  134.   {
  135.     write() '?', &MSG, '\n';
  136.     &COM = '\0';
  137.   };
  138.  
  139.  
  140.  
  141. function printing(&C:char):logical
  142. -- returns 1B if its argument is a printing character
  143.   {
  144.     local &O:integer;
  145.  
  146.     &O = ord(&C);
  147.     if (&O > 32 /\ &O < 127) return(1B);
  148.   };
  149.  
  150.  
  151.  
  152. procedure span()
  153. -- skip over blanks, tabs, etc in the input line
  154.   {
  155.     while (1B)
  156.       {
  157.           if (&LINE[&LNDX] = '\0') 
  158.         return
  159.     else if (printing(&LINE[&LNDX]))
  160.         return
  161.         else
  162.         &LNDX = &LNDX + 1;
  163.       };
  164.   };
  165.  
  166.  
  167.  
  168.  
  169. procedure getarg()
  170. -- read the next argument from the command line
  171.   {
  172.     local
  173.     &C:char,
  174.     &J:integer;
  175.  
  176.     &ACNT = &ACNT + 1;
  177.     if (&ACNT > 20)
  178.         {call error(|too many arguments|); return};
  179.     &J = 1;
  180.     while (1B)
  181.       {
  182.         &C = &LINE[&LNDX];
  183.     if (~printing(&C))
  184.         {&ARGS[&ACNT][&J] = '\0'; return};
  185.     &ARGS[&ACNT][&J] = &C;
  186.     &J = &J + 1;
  187.     &LNDX = &LNDX + 1;
  188.       };
  189.   };
  190.  
  191.  
  192.  
  193. function getline(&FILE:integer):logical
  194. -- read in the next command line from &FILE
  195. -- return 0B if the file was empty
  196.   {
  197.     local &Z, &EOL:integer, &C:char;
  198.  
  199.     --
  200.     -- get prepared for errors
  201.     --
  202.     &COM = '\0'; &ACNT = 0;
  203.  
  204.     --
  205.     -- read the input line
  206.     --
  207.     if (&FILE = 0) write() |>> |;
  208.     &C = '\0';
  209.     while (~printing(&C))
  210.       {
  211.     if (peek(&FILE) < 0) return(0B);
  212.         read(&FILE) &C;
  213.       };
  214.     &LNDX = 1; &LINE[1] = &C;
  215.     &Z = 0; &EOL = ord('\n');
  216.     while ((&Z <> &EOL) /\ (&Z >= 0))
  217.       {
  218.     &Z = peek(&FILE);
  219.     if ((&Z = &EOL) \/ (&Z < 0))
  220.         &C = '\0'
  221.     else
  222.         read(&FILE) &C;
  223.     &LNDX = &LNDX + 1;
  224.     if (&LNDX > 127)
  225.       {
  226.         call error(|input line is too long|); 
  227.         while (1B)
  228.           {
  229.             if (peek(&FILE) < 0) return(1B);
  230.         read(&FILE) &C;
  231.         if (&C = '\n') return(1B);
  232.           };
  233.       };
  234.     &LINE[&LNDX] = &C;
  235.       };
  236.  
  237.     --
  238.     -- find the command
  239.     --
  240.     &LNDX = 1;
  241.     call span();
  242.     if (&LINE[&LNDX] = '\0')
  243.         {&COM = ' '; return(1B)}
  244.     else
  245.         &COM = &LINE[&LNDX];
  246.     &LNDX = &LNDX + 1;
  247.  
  248.     --
  249.     -- get the individual arguments if this is not a comment
  250.     --
  251.     if (&COM <> ';')
  252.       {
  253.         while (1B)
  254.           {
  255.         call span();
  256.         if (&LINE[&LNDX] = '\0') return(1B);
  257.         call getarg();
  258.           };
  259.       };
  260.     return(1B);
  261.     
  262.   };
  263.  
  264.  
  265.  
  266. --
  267. -- ROUTINES TO PROCESS INDIVIDUAL COMMANDS
  268. --
  269.  
  270. procedure comsemi()
  271.   {
  272.   };
  273.  
  274.  
  275. procedure comx()
  276.   {
  277.     local
  278.         &X:integer;
  279.  
  280.     if (&ACNT = 0)
  281.         call run(1)
  282.     else if (&ACNT > 1)
  283.         call error(|x command takes only one argument|)
  284.     else if (&ARGS[1][1] = 'x' /\ &ARGS[1][2] = '\0')
  285.         call run(-1)
  286.     else if (cvinteger(&X, &ARGS[1]) = 0B)
  287.         call error(|illegal argument|)
  288.     else
  289.         call run(&X);
  290.   };
  291.  
  292.  
  293.  
  294. procedure comf()
  295.   {
  296.     local
  297.         &FLDS:array(20:symbol),
  298.     &FLG:logical,
  299.     &TYP:symbol,
  300.     &FN:symbol,
  301.     &X,&Y:integer;
  302.  
  303.     --
  304.     -- get the list of types
  305.     --
  306.     for &X = (1 to &ACNT)
  307.           if (cvsymbol(&FLDS[&X], &ARGS[&X]) = 0B)
  308.         {call error(|illegal argument|); return};
  309.  
  310.     --
  311.     -- loop through wm printing the requested information
  312.     --
  313.     for &X = (1 to wsize())
  314.       {
  315.         &TYP = wtype(&X);
  316.         if (&ACNT = 0)
  317.             &FLG = 1B
  318.         else
  319.             &FLG = 0B;
  320.     &Y = 1;
  321.     while (&FLG = 0B /\ &Y <= &ACNT)
  322.       {
  323.         if (&FLDS[&Y] = &TYP) &FLG = 1B;
  324.         &Y = &Y + 1;
  325.       };
  326.           if (&FLG)
  327.         write() &X, |. |, &TYP, '\n';
  328.       };
  329.   };
  330.  
  331.  
  332.  
  333. procedure comw()
  334.   {
  335.     local
  336.         &WNDX:integer,
  337.     &Z:integer;
  338.  
  339.     if (&ACNT = 0)
  340.       {
  341.           for &Z = (1 to wsize()) call wput(1, &Z);
  342.     return;
  343.       };
  344.     for &Z = (1 to &ACNT)
  345.       {
  346.         if (cvinteger(&WNDX, &ARGS[&Z]) = 0B)
  347.         {call error(|illegal argument|); return};
  348.         if (&WNDX < 1 \/ &WNDX > wsize())
  349.             {call error(|working memory index out of bounds|); return};
  350.         call wput(1, &WNDX);
  351.       };
  352.   };
  353.  
  354.  
  355.  
  356. procedure comd()
  357.   {
  358.     local
  359.         &FILE:integer,
  360.     &FNAME:symbol,
  361.     &Z:integer;
  362.  
  363.     if (&ACNT = 0)
  364.         &FILE = 1
  365.     else if (&ACNT > 1)
  366.         {call error(|wrong number of arguments|); return}
  367.     else
  368.       {
  369.         if (cvsymbol(&FNAME, &ARGS[1]) = 0B)
  370.         {call error(|illegal argument|); return};
  371.         &FILE = create(&FNAME);
  372.         if (&FILE < 0)
  373.         {call error(|could not open file|); return};
  374.       };
  375.     for &Z = (1 to wsize())
  376.         call wput(&FILE,&Z);
  377.     if (&FILE <> 1) 
  378.         call close(&FILE);
  379.   };
  380.  
  381.  
  382. procedure toplev(&FILE:integer) forward;
  383.  
  384. procedure comat()
  385.   {
  386.     local
  387.         &FILE:integer,
  388.     &FNAME:symbol;
  389.  
  390.     if (&ACNT <> 1)
  391.         call error(|wrong number of arguments|)
  392.     else
  393.       {
  394.         if (cvsymbol(&FNAME, &ARGS[1]) = 0B)
  395.         {call error(|illegal argument|); return};
  396.         &FILE = open(&FNAME);
  397.         if (&FILE < 0)
  398.         {call error(|could not open file|); return};
  399.     call toplev(&FILE);
  400.         call close(&FILE);
  401.       };
  402.   };
  403.  
  404.  
  405. procedure comm()
  406.   {
  407.     local
  408.         &RULE:symbol,
  409.     &M:integer,
  410.         &Z:integer,
  411.     &C:integer;
  412.  
  413.     for &Z = (1 to &ACNT)
  414.       {
  415.         if (cvsymbol(&RULE, &ARGS[&Z]) = 0B)
  416.         {call error(|illegal argument|); return};
  417.     write() &RULE, ':', '\n';
  418.     write() |....:....1....:....2....:....3....:|, '\n';
  419.     &C = 0; &M = 0;
  420.     while (&M >= 0)
  421.       {
  422.         &C = &C + 1;
  423.         &M = cmatches(&RULE, &C);
  424.         if (&M > 0)
  425.             write() '*'
  426.         else
  427.             write() ' ';
  428.       };
  429.         write() '\n';
  430.     &C = 0; &M = 0;
  431.     while (&M >= 0)
  432.       {
  433.         &C = &C + 1;
  434.         &M = pmatches(&RULE, &C);
  435.         if (&M > 0)
  436.             write() '*'
  437.         else
  438.             write() ' ';
  439.       };
  440.         write() '\n', '\n';
  441.       };
  442.   };
  443.  
  444.  
  445. procedure comc()
  446.   {
  447.     local
  448.         &SIZE:integer,
  449.     &NAME:name,
  450.     &LEN:integer,
  451.     &T:integer,
  452.     &NDX:integer,
  453.     &Z:integer;
  454.  
  455.     &SIZE = cssize();
  456.     if (&SIZE = 0) return;
  457.     for &Z = (1 to &SIZE)
  458.       {
  459.     write() &Z, |. |;
  460.         &LEN = irule(&NAME, &Z);
  461.     for &T = (1 to &LEN)
  462.         write() &NAME[&T];
  463.     write() |    |;
  464.     &T = 0; &NDX = 0;
  465.     while (&NDX >= 0)
  466.       {
  467.         &T = &T + 1;
  468.         &NDX = iindex(&Z, &T);
  469.         if (&NDX >= 0) write() ' ', &NDX;
  470.       };
  471.     write() '\n';
  472.       };
  473.     write() '[', select(), | dominates]|, '\n';
  474.   };
  475.  
  476.  
  477. procedure domods(&WMNDX:integer, &NXT:integer)
  478. -- make the modifications required for "+" and "#" commands
  479. --    &WMNDX : the wme to modify
  480. --    &NXT : the next attribute to process
  481.   {
  482.     local
  483.     &FN:symbol,
  484.     &R:real,
  485.     &C:char,
  486.     &L:logical,
  487.     &S:symbol;
  488.  
  489.     --
  490.     -- do initial checks
  491.     --
  492.     if (&NXT > &ACNT) return;
  493.     if (&NXT + 1 > &ACNT)
  494.         {call error(|no value provided for attribute|); return};
  495.     if (&WMNDX < 1 \/ &WMNDX > wsize())
  496.         {call error(|working memory index out of bounds|); return};
  497.     if (cvsymbol(&FN, &ARGS[&NXT]) = 0B)
  498.         {call error(|illegal argument|); return};
  499.     --
  500.     -- change the specified values
  501.     --
  502.     if (wextract(&S, &WMNDX, &FN))
  503.       {
  504.           if (cvsymbol(&S, &ARGS[&NXT+1]) = 0B)
  505.             {call error(|illegal value|); return};
  506.     if (wstore(&S, &WMNDX, &FN) = 0B)
  507.             {call error(|could not store value|); return};
  508.       }
  509.     else if (wextract(&R, &WMNDX, &FN))
  510.       {
  511.           if (cvreal(&R, &ARGS[&NXT+1]) = 0B)
  512.             {call error(|illegal value|); return};
  513.     if (wstore(&R, &WMNDX, &FN) = 0B)
  514.             {call error(|could not store value|); return};
  515.       }
  516.     else if (wextract(&L, &WMNDX, &FN))
  517.       {
  518.           if (cvlogical(&L, &ARGS[&NXT+1]) = 0B)
  519.             {call error(|illegal value|); return};
  520.     if (wstore(&L, &WMNDX, &FN) = 0B)
  521.             {call error(|could not store value|); return};
  522.       }
  523.     else if (wextract(&C, &WMNDX, &FN))
  524.       {
  525.           &C = &ARGS[&NXT+1][1];
  526.     if (wstore(&C, &WMNDX, &FN) = 0B)
  527.             {call error(|could not store value|); return};
  528.       }
  529.     else
  530.     {call error(|illegal field name|); return};
  531.  
  532.     --
  533.     -- do the rest of the mods (note that the wme is now the last one in
  534.     -- wm because it was just modified)
  535.     --
  536.     call domods(wsize(), &NXT+2);
  537.   };
  538.  
  539.  
  540. procedure commod()
  541.   {
  542.     local
  543.     &WMNDX:integer;
  544.  
  545.     if (&ACNT < 1)
  546.         {call error(|# command requires at least one argument|); return};
  547.     if (cvinteger(&WMNDX, &ARGS[1]) = 0B)
  548.     {call error(|illegal argument|); return};
  549.     call domods(&WMNDX, 2);
  550.   };
  551.  
  552.  
  553. procedure comadd()
  554.   {
  555.     local
  556.     &TYPE:symbol;
  557.  
  558.     if (&ACNT < 1)
  559.         {call error(|+ command requires at least one argument|); return};
  560.     if (cvsymbol(&TYPE, &ARGS[1]) = 0B)
  561.     {call error(|illegal argument|); return};
  562.     if (make(&TYPE) = 0B)
  563.     {call error(|not a working memory type|); return};
  564.     call domods(wsize(), 2);
  565.   };
  566.  
  567.  
  568.  
  569. procedure comrem()
  570.   {
  571.     local &WMNDX,&Z:integer;
  572.  
  573.     if (&ACNT <> 1)
  574.         {call error(|- command requires one argument|); return};
  575.     if (&ARGS[1][1] = '-' /\ &ARGS[1][2] = '\0')
  576.       {
  577.           for &Z = (wsize() downto 1)
  578.         call wremove(&Z);
  579.       }
  580.     else
  581.       {
  582.         if (cvinteger(&WMNDX, &ARGS[1]) = 0B)
  583.         {call error(|illegal argument|); return};
  584.     if (wremove(&WMNDX) = 0B)
  585.             {call error(|working memory index out of bounds|); return};
  586.       };
  587.   };
  588.  
  589.  
  590. procedure comt()
  591.   {
  592.     local &Z:integer;
  593.  
  594.     if (&ACNT < 1)
  595.         {write() |Current trace level: |, &TLEV, '\n'; return;};
  596.     if (cvinteger(&Z, &ARGS[1]) = 0B)
  597.     {call error(|illegal argument|); return};
  598.     if (&Z < 0 \/ &Z > 2)
  599.     {call error(|illegal argument|); return};
  600.     &TLEV = &Z;
  601.     if (&TLEV = 2)
  602.         on wmchange call wmtrace
  603.     else
  604.         on wmchange call notrace;
  605.   };
  606.  
  607.  
  608. procedure comhelp()
  609.   {
  610.     write() |?                Display this information|, '\n';
  611.     write() |@ <file>            Read commands from a file|, '\n';
  612.     write() |+ <type> { <att> <val> }...    Make a wme|, '\n';
  613.     write() |# <index> { <att> <val> }...    Modify a wme|, '\n';
  614.     write() |- <index>            Remove a wme|, '\n';
  615.     write() |- -                Remove all wmes|, '\n';
  616.     write() |;                Comment|, '\n';
  617.     write() |c                Display the conflict set|, '\n';
  618.     write() |d                Display the contents of wm|, '\n';
  619.     write() |d <file>            Dump wm to a file|, '\n';
  620.     write() |f                Display types of all wmes|, '\n';
  621.     write() |f <type>...            Find wmes of specified types|, '\n';
  622.     write() |m <rule>...            Display the lhs matches|, '\n';
  623.     write() |Q                Quit|, '\n';
  624.     write() |t                Display current trace level|, '\n';
  625.     write() |t <level>            Set the new trace level|, '\n';
  626.     write() |w                Print all wmes|,'\n';
  627.     write() |w <index>...            Print specified wmes|,'\n';
  628.     write() |x                Execute one rule|, '\n';
  629.     write() |x <count>            Execute <count> rules|, '\n';
  630.     write() |x x                Execute rules until system halts|, '\n';
  631.   };
  632.  
  633.  
  634.  
  635. --
  636. -- TOP LEVEL ROUTINES
  637. --
  638.  
  639.  
  640. procedure shellinit()
  641. -- must be called to initialize the shell variables
  642. -- before toplev() is called the first time
  643.   {
  644.     &TLEV = 0;
  645.   };
  646.  
  647.  
  648.  
  649. body toplev
  650. -- the top level of the interactive shell
  651.   {
  652.     if (status(&FILE) <> |read|) 
  653.         {call error(|illegal input file|); return};
  654.     if (&FILE = 0)
  655.         write() |OPS83 interactive top level.  Type '?' for help|, '\n', '\n';
  656.     while (1B)
  657.       {
  658.           if (~getline(&FILE)) return;
  659.     if (&COM = ';')
  660.         call comsemi()
  661.     else if (&COM = 'x')
  662.         call comx()
  663.     else if (&COM = '+')
  664.         call comadd()
  665.     else if (&COM = '-')
  666.         call comrem()
  667.     else if (&COM = '#')
  668.         call commod()
  669.     else if (&COM = '@')
  670.         call comat()
  671.     else if (&COM = 'f')
  672.         call comf()
  673.     else if (&COM = 'w')
  674.         call comw()
  675.     else if (&COM = 'd')
  676.         call comd()
  677.     else if (&COM = 'm')
  678.         call comm()
  679.     else if (&COM = 'c')
  680.         call comc()
  681.     else if (&COM = 't')
  682.         call comt()
  683.     else if (&COM = '?')
  684.         call comhelp()
  685.     else if (&COM = 'Q')
  686.         return
  687.         else if (&COM <> '\0')
  688.         write() |Enter ? for help|, '\n'
  689.       };
  690.   };
  691. }
  692.