home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / programs / spredsht / qsolve11.lbr / QS5.IZC / QS5.INC
Text File  |  1987-04-26  |  6KB  |  311 lines
  1.  
  2. procedure ReadIn(var X,Y,N: integer; var S: str80);
  3. var
  4.   P: integer;
  5. begin
  6.   P:=0;
  7.   repeat
  8.     gotoxy(X+P,Y);
  9.     read(kbd,Ch);
  10.     if (Ch in [' '..'~']) then
  11.     begin
  12.       if InsertOn then
  13.       begin
  14.         if Ord(S[0])<N then
  15.         begin
  16.           P:=P+1;
  17.           insert(Ch,S,P);
  18.         end else Bell;
  19.       end else
  20.       if P<N then
  21.       begin
  22.         P:=P+1;
  23.         if P<=Ord(S[0]) then S[P]:=Ch else S:=S+Ch;
  24.       end else Bell;
  25.       gotoxy(X,Y);
  26.       write(S);
  27.     end;
  28.     if Ch=^V then
  29.     if InsertOn=True then InsertOn:=False else InsertOn:=True;
  30.     if ((Ch=#8) or (Ch=#127)) and (P>0) then
  31.     begin
  32.       delete(S,P,1);
  33.       P:=P-1;
  34.       gotoxy(X,Y);
  35.       write(S+' ');
  36.     end;
  37.     if Ch=^G then
  38.     begin
  39.       delete(S,P+1,1);
  40.       gotoxy(X,Y);
  41.       write(S+' ');
  42.     end;
  43.     if (Ch=^S) and (P>0) then
  44.       P:=P-1;
  45.     if (Ch=^D) and (P<Ord(S[0])) then
  46.       P:=P+1;
  47.   until Ch=#13;
  48. end;
  49.  
  50. procedure ReadText;
  51. label
  52.   Exit;
  53. var
  54.   X,Y,L,N: integer;
  55. begin
  56.   CurOn;
  57.   X:=XCol(Col);
  58.   Y:=(Row-CR)+2;
  59.   N:=CWidth[Col];
  60.   if CA[Col,Row]<>0 then
  61.   begin
  62.     GetCell(Col,Row);
  63.     if ((Ch='`')   and (CType<>1)) or
  64.        ((Ch='~')   and (CType<>2)) or
  65.        ((CType<>1) and (CType<>2)) then
  66.     begin
  67.       Bell;
  68.       goto Exit;
  69.     end;
  70.     S:=CText;
  71.   end else
  72.   begin
  73.     S:='';
  74.     if Ch='`' then CType:=1;
  75.     if Ch='~' then CType:=2;
  76.   end;
  77.   if CType=2 then Gon;
  78.   ReadIn(X,Y,N,S);
  79.   if CType=2 then Goff;
  80.   if S='' then goto Exit;
  81.   CText:=S;
  82.   PutCell(Col,Row);
  83.   Exit:
  84.   CurOff;
  85. end;
  86.  
  87. procedure ReadFor;
  88. label
  89.   Exit;
  90. var
  91.   P,X,Y,L,N:   integer;
  92. begin
  93.   CurOn;
  94.   X:=1;
  95.   Y:=24;
  96.   N:=80;
  97.   P:=0;
  98.   if CA[Col,Row]<>0 then
  99.   begin
  100.     GetCell(Col,Row);
  101.     if CType<3 then
  102.     begin
  103.       Bell;
  104.       goto Exit;
  105.     end;
  106.     AddFormSuffix;
  107.     S:=CFor;
  108.   end else
  109.     S:='';
  110.   gotoxy(1,24);
  111.   write(S);
  112.   ReadIn(X,Y,N,S);
  113.   if S='' then goto Exit;
  114.   P:=Pos('&',S);
  115.   if P=0 then CForm:=1
  116.   else
  117.   begin
  118.     TS:=Copy(S,P,6);
  119.     UpperCase(TS);
  120.     S:=Copy(S,1,Pred(P));
  121.     if TS='&HIDE' then CForm:=4 else
  122.     if TS='&BAR'  then CForm:=3 else
  123.     if TS='&SCI'  then CForm:=2 else
  124.     if Copy(TS,1,3)='&FD'  then CForm:=0 else
  125.     if Copy(TS,1,4)='&DOL' then CForm:=1 else CForm:=1;
  126.     if CForm<2 then
  127.     begin
  128.       if pos('$',TS)>0 then CForm:=CForm+10 else
  129.       if pos('%',TS)>0 then CForm:=CForm+20 else
  130.       if pos('#',TS)>0 then CForm:=CForm+30;
  131.       if pos('^',TS)>0 then CForm:=CForm+100 else
  132.       if pos('<',TS)>0 then CForm:=CForm+200;
  133.     end;
  134.   end;
  135.   CFor:=S;
  136.   CVal:=0;
  137.   if ThisCalc=1 then CType:=13 else CType:=3;
  138.   PutCell(Col,Row);
  139.   if CalcOn then
  140.   begin
  141.     LookUpCells;
  142.     ShowCells;
  143.   end else ShowStr(Col,Row,CellText(Col,Row));
  144. Exit:
  145.   CurOff;
  146.   gotoxy(1,24);
  147.   ClrEol;
  148. end;
  149.  
  150. procedure Block;
  151. label
  152.   Start,Exit;
  153. var
  154.   TS:                string[40];
  155.   S1:                string[255];
  156.   C,R,
  157.   C1,R1:             integer;
  158.   FileName:          str14;
  159.   F:                 text;
  160. begin
  161.   Read(kbd,Ch);
  162.   if Ch=^B then
  163.   begin
  164.     Hide:=False;
  165.     SC:=Col;
  166.     SR:=Row;
  167.     ShowCells;
  168.   end;
  169.   if Ch=^K then
  170.   begin
  171.     Hide:=False;
  172.     FC:=Col;
  173.     FR:=Row;
  174.     ShowCells;
  175.   end;
  176.   if Ch=^H then
  177.   begin
  178.     if Hide=True then Hide:=False else Hide:=True;
  179.     ShowCells;
  180.   end;
  181.   if Ch in [^V,^C,^Y,^P,^W] then
  182.   begin
  183.     Hide:=False;
  184.     DC:=Col;
  185.     DR:=Row;
  186.     C1:=FC-SC;
  187.     R1:=FR-SR;
  188.     if Ch in [^P,^W] then
  189.     begin
  190.       C:=0;
  191.       for R:=SC to FC do
  192.       begin
  193.         C:=C+CWidth[R];
  194.         if C>80 then
  195.         begin
  196.           Error(51);
  197.           goto exit;
  198.         end;
  199.       end;
  200.     end;
  201.     if Ch=^P then
  202.     begin
  203.       TS:='';
  204.       CurOn;
  205.       UlCur;
  206.       gotoxy(1,24);
  207.       clreol;
  208.       write('center print-out <Y>/N ? ');
  209.       repeat read(kbd,Ch1); Ch1:=UpCase(Ch1); until Ch1 in ['Y','N',#13];
  210.       if Ch1<>'N' then TS:=StringOf(40-(C div 2),' ');
  211.       message('press return to start print-out ? ');
  212.       read(kbd,Ch1);
  213.       message('');
  214.       CurOff;
  215.     end;
  216.     if Ch=^W then
  217.     begin
  218.       CurOn;
  219.       UlCur;
  220.     Start:
  221.       gotoxy(1,24);
  222.       clreol;
  223.       FileName:='';
  224.       write('file''s name ? ');
  225.       read(FileName);
  226.       if FileName='' then goto Exit;
  227.       if Exist(FileName) then
  228.       begin
  229.         write(#13);
  230.         clreol;
  231.         HighVideo;
  232.         write('file exists, erase (Y/N) ? ');
  233.         LowVideo;
  234.         repeat read(kbd,Ch1); Ch1:=Upcase(Ch1); until Ch1 in ['Y','N'];
  235.         write(#13);
  236.         clreol;
  237.         if Ch1='N' then goto Start;
  238.       end;
  239.       Assign(F,FileName);
  240.       ReWrite(F);
  241.     end;
  242.     if Ch in [^V,^C] then
  243.     begin
  244.       if (((C1+DC in [SC..FC]) and
  245.          (R1+DR in [SR..FR])) or
  246.          ((DC in [SC..FC]) and
  247.          (DR in [SR..FR]))) or
  248.          (DC+C1>26) or
  249.          (DR+R1>99) then
  250.       begin
  251.         Bell;
  252.         goto Exit;
  253.       end;
  254.     end;
  255.     Err:=0;
  256.     S1:='';
  257.     for R:=SR to FR do
  258.     begin
  259.       for C:=SC to FC do
  260.       begin
  261.         case Ch of
  262.           ^V,^C:
  263.           begin
  264.             if CA[C,R]<>0 then
  265.             begin
  266.               GetCell(C,R);
  267.               PutCell((C-SC)+DC,(R-SR)+DR);
  268.               if Err<>0 then
  269.               begin
  270.                 ShowCells;
  271.                 Goto Exit;
  272.               end;
  273.               if Ch=^V then DelCell(C,R);
  274.             end;
  275.           end;
  276.           ^Y:
  277.           DelCell(C,R);
  278.           ^P,^W:
  279.           begin
  280.             S:=CellText(C,R);
  281.             while ord(S[0])<CWidth[C] do S:=S+' ';
  282.             S1:=S1+S;
  283.           end;
  284.         end;
  285.       end;
  286.       if Ch in [^P,^W] then
  287.         while S1[Ord(S1[0])]=' ' do S1[0]:=chr(pred(ord(S1[0])));
  288.       if Ch=^P then
  289.         writeln(lst,TS+S1);
  290.       if Ch=^W then
  291.         writeln(F,S1);
  292.       S1:='';
  293.     end;
  294.     if Ch=^W then close(F);
  295.     if Ch in [^Y,^P,^W] then
  296.     begin
  297.       FC:=Pred(SC);
  298.       FR:=Pred(SR);
  299.     end else
  300.     begin
  301.       SC:=DC;
  302.       SR:=DR;
  303.       FC:=DC+C1;
  304.       FR:=DR+R1;
  305.     end;
  306.     LookUpCells;
  307.     ShowCells;
  308.   end;
  309. Exit:
  310. end;
  311.