home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / programs / spredsht / qsolve11.lbr / QS4.IZC / QS4.INC
Text File  |  1987-04-26  |  11KB  |  508 lines
  1.  
  2. function ArcSin(X: real): real;
  3. begin
  4.   if X=1  then ArcSin:= pi/2 else
  5.   if X=-1 then ArcSin:=-pi/2 else
  6.   ArcSin:=Arctan(X/sqrt(-X*X+1));
  7. end;
  8.  
  9. function ArcCos(X: real): real;
  10. begin
  11.   if X=1  then ArcCos:=0  else
  12.   if X=-1 then ArcCos:=pi else
  13.   ArcCos:=-Arctan(X/sqrt(-X*X+1))+1.570796327;
  14. end;
  15.  
  16. function IsAlpha(ch: char): boolean;
  17. begin
  18.   IsAlpha := (Upcase(ch) in ['A'..'Z'])
  19. end;
  20.  
  21. function IsWhite(ch: char): boolean;
  22. begin
  23.   IsWhite := (ch= ' ') or (ch=chr(9)) or (ch=chr(13));
  24. end;
  25.  
  26. function IsDelim(ch: char): boolean;
  27. begin
  28.   if pos(ch,' +-/*%^=()$')<>0 then IsDelim := true
  29.     else IsDelim := false;
  30. end;
  31.  
  32. function Isdigit(ch: char): boolean;
  33. begin
  34.   Isdigit := ch in ['0'..'9'];
  35. end;
  36.  
  37. {$A-}
  38.  
  39. procedure GetToken;
  40. begin
  41.   token := '';
  42.   while (IsWhite(prog[t])) do t := succ(t);
  43.   if prog[t]='$' then token := '$';
  44.   if pos(prog[t],'+-*/%^=()')<>0 then
  45.   begin
  46.     TokType := Delimiter;
  47.     token := prog[t];
  48.     t := succ(t);
  49.   end else
  50.   if IsAlpha(prog[t]) then
  51.   begin
  52.     while (not IsDelim(prog[t])) do
  53.     begin
  54.       token := token + prog[t];
  55.       t := succ(t)
  56.     end;
  57.     TokType := Funct;
  58.   end else
  59.   if IsDigit(prog[t]) then
  60.   begin
  61.     while (not IsDelim(prog[t])) do
  62.     begin
  63.       token := token + prog[t];
  64.       if (prog[t+1]='E') and (prog[t+2] in ['+','-']) then
  65.       begin
  66.         token := token + copy(prog,t+1,2);
  67.         t := t + 2;
  68.       end;
  69.       t := succ(t);
  70.       Toktype := number;
  71.     end;
  72.   end;
  73. end;
  74.  
  75. function Pwr(a,b: real) : real;
  76. var
  77.   t:    integer;
  78.   temp: real;
  79. begin
  80.   if a= 0 then pwr := 1
  81.   else
  82.   begin
  83.     temp := a;
  84.     for t := trunc(b) downto 2 do a := a * temp;
  85.     Pwr := a;
  86.   end;
  87. end;
  88.  
  89. procedure Arith(op: str3; var result,operand: real);
  90. begin
  91.   if Op[0]>#1 then
  92.   begin
  93.     if (abs(result)>32767) or (abs(operand)>32767) then
  94.     begin
  95.       result:=0;
  96.       error(4);
  97.     end;
  98.   end;
  99.   if Op = 'OR'  then result := trunc(result) or  trunc(operand);
  100.   if Op = 'XOR' then result := trunc(result) xor trunc(operand);
  101.   if Op = 'AND' then result := trunc(result) and trunc(operand);
  102.   if Op = 'MOD' then result := trunc(result) mod trunc(operand);
  103.   if Op = '+'   then result := result + operand;
  104.   if Op = '-'   then result := result - operand;
  105.   if Op = '*'   then result := result * operand;
  106.   if Op = '/'   then
  107.   begin
  108.     if operand<>0 then result := result / operand
  109.   else
  110.     begin
  111.       result:=0;
  112.       error(3);
  113.     end;
  114.   end;
  115.   if Op = '^'   then result := Pwr(result,operand);
  116. end;
  117.  
  118. procedure Level0(var result: real); forward;
  119. procedure Level1(var result: real); forward;
  120. procedure Level2(var result: real); forward;
  121. procedure Level3(var result: real); forward;
  122. procedure Level4(var result: real); forward;
  123. procedure Level5(var result: real); forward;
  124. procedure Primitive(var result: real); forward;
  125.  
  126. procedure GetExp(var result: real);
  127. begin
  128.   t:=1;
  129.   GetToken;
  130.   if length(token) <> 0 then Level0(result) else Error(3);
  131. end;
  132.  
  133. procedure Level0;
  134. var
  135.   op:   string[3];
  136.   hold: real;
  137. begin
  138.   Level1(result);
  139.   op := token;
  140.   while ((op='OR') or (op='XOR') or (op='AND') or (op='MOD')) do
  141.   begin
  142.     Gettoken;
  143.     Level1(hold);
  144.     arith(op, result, hold);
  145.     op := token;
  146.   end;
  147. end; {Level0}
  148.  
  149. procedure Level1;
  150. var
  151.   op:   char;
  152.   hold: real;
  153. begin
  154.   Level2(result);
  155.   op := token[1];
  156.   while ((op='+') or (op='-')) do
  157.   begin
  158.     Gettoken;
  159.     Level2(hold);
  160.     arith(op, result, hold);
  161.     op := token[1]
  162.   end;
  163. end; {Level1}
  164.  
  165. procedure Level2;
  166. var
  167.   op:   char;
  168.   hold: real;
  169. begin
  170.   Level3(result);
  171.   op := token[1];
  172.   while ((op='*') or (op='/')) do
  173.   begin
  174.     Gettoken;
  175.     level3(hold);
  176.     arith(op, result, hold);
  177.     op := token[1];
  178.   end;
  179. end; {Level2}
  180.  
  181. procedure Level3;
  182. var
  183.   hold: real;
  184. begin
  185.   Level4(result);
  186.   if token[1] = '^' then
  187.   begin
  188.     GetToken;
  189.     Level4(hold);
  190.     arith('^',result, hold);    {exponent}
  191.   end;
  192. end; {Level3}
  193.  
  194. procedure Level4;
  195. label
  196.   Exit;
  197. var
  198.   Op,L: byte;
  199. const
  200.   Rad=57.29577951;
  201.   NumFun=15;
  202.   Fun: array[1..NumFun] of string[5] =
  203.   ('SIN','COS','TAN','ASIN','ACOS','ATAN',
  204.    'SQRT','LOG','LN','INT','TRUNC','FRAC','ABS','RAND','SIGN');
  205. begin
  206.   Op:=0;
  207.   if tokType=Funct then
  208.     for L:=1 to NumFun do
  209.       if Token=Fun[L] then
  210.         op:=L;
  211.   if Op<>0 then GetToken;
  212.   Level5(result);
  213.   case Op of
  214.     4,5: if abs(result)>1 then
  215.          begin
  216.            result:=0;
  217.            error(4);
  218.            goto Exit;
  219.          end;
  220.     7:   if result<0  then
  221.          begin
  222.            result:=0;
  223.            error(4);
  224.            goto Exit;
  225.          end;
  226.     8,9: if result<=0 then
  227.          begin
  228.            result:=0;
  229.            error(4);
  230.            goto Exit;
  231.          end;
  232.     14:  if abs(result)>32767 then
  233.          begin
  234.            result:=0;
  235.            error(4);
  236.            goto Exit;
  237.          end;
  238.   end;
  239.   case Op of
  240.     1:  result:=sin(result/Rad);
  241.     2:  result:=cos(result/Rad);
  242.     3:  result:=sin(result/Rad)/cos(result/Rad);
  243.     4:  result:=arcsin(result)*Rad;
  244.     5:  result:=arccos(result)*Rad;
  245.     6:  result:=arctan(result)*Rad;
  246.     7:  result:=sqrt(result);
  247.     8:  result:=ln(result)/ln(10);
  248.     9:  result:=ln(result);
  249.     10: result:=int(result);
  250.     11: result:=trunc(result);
  251.     12: result:=frac(result);
  252.     13: result:=abs(result);
  253.     14: result:=random(trunc(result));
  254.     15: begin
  255.           if result<0 then result:=-1;
  256.           if result>0 then result:=1;
  257.         end;
  258.   end;
  259. Exit:
  260. end; {level4}
  261.  
  262. procedure Level5;
  263. var
  264.   op: char;
  265. begin
  266.   op := ' ';
  267.   if ((tokType=Delimiter) and ((token[1]='+') or (token[1]= '-'))) then
  268.   begin
  269.     op := token[1];
  270.     Gettoken;
  271.     Level4(result);
  272.   end else
  273.     Primitive(result);
  274.   if op='-' then result := -result;
  275. end; {level5}
  276.  
  277. procedure Primitive;
  278. begin
  279.   if TokType=Number then val(token, result, code)
  280.     else Error(1);
  281.   GetToken;
  282. end; {Primitive}
  283.  
  284. procedure Calc(var result: real);
  285. label
  286.   Exit;
  287. var
  288.   TS1:             str255;
  289.   CPos,Count,
  290.   MaxPos,MaxCount: integer;
  291. begin
  292.   TS1:=Prog;
  293.   repeat
  294.     Count   :=0;
  295.     MaxCount:=0;
  296.     MaxPos  :=0;
  297.     for CPos:=1 to Ord(Prog[0]) do
  298.     begin
  299.       Ch:=Prog[CPos];
  300.       if Ch='(' then Count:=Count+1;
  301.       if Ch=')' then Count:=Count-1;
  302.       if Count>MaxCount then
  303.       begin
  304.         MaxCount:=Count;
  305.         MaxPos  :=CPos;
  306.       end;
  307.     end;
  308.     if Count<>0 then
  309.     begin
  310.       Error(1);
  311.       result:=0;
  312.       goto Exit;
  313.     end;
  314.     if MaxCount<>0 then
  315.     begin
  316.       Prog:=copy(Prog,Succ(MaxPos),255);
  317.       Prog:=copy(Prog,1,Pred(pos(')',Prog)))+'$';
  318.       delete(TS1,MaxPos,Ord(Prog[0])+1);
  319.       GetExp(result);
  320.       str(result,Prog);
  321.       insert(prog,TS1,MaxPos);
  322.     end;
  323.     Prog:=TS1;
  324.   until MaxCount=0;
  325.   GetExp(result);
  326. Exit:
  327. end;
  328.  
  329. function LookUp(C,R: integer): real;
  330. label
  331.   Exit;
  332. var
  333.   F:       str255;
  334.   L,
  335.   C1,R1,
  336.   SC,SR,
  337.   FC,FR,
  338.   Func:    integer;
  339.   V,FV:    real;
  340. begin
  341.   C1:=C;
  342.   R1:=R;
  343.   GetCell(C,R);
  344.   UpperCase(CFor);
  345.   F:=CFor;
  346.   LookUp:=0;
  347.   if CType<3 then goto Exit;
  348.   if CType=13 then LastCalc:=1 else LastCalc:=0;
  349.   if LastCalc=ThisCalc then
  350.   begin
  351.     move(mem[CA[C1,R1]+5],V,6);
  352.     LookUp:=V;
  353.     goto Exit;
  354.   end;
  355.   L:=1;
  356.   while L<Ord(F[0]) do
  357.   begin
  358.     S:=copy(F,L,3);
  359.     if (S='SUM') or (S='MAX') or (S='MIN') then
  360.     begin
  361.       if S='SUM' then Func:=1;
  362.       if S='MAX' then Func:=2;
  363.       if S='MIN' then Func:=3;
  364.       delete(F,L,3);
  365.       if F[L]<>'[' then
  366.       begin
  367.         Error(1);
  368.         goto Exit;
  369.       end;
  370.       delete(F,L,1);
  371.       StrRC(Copy(F,L,3),C,R);
  372.       if R>9 then
  373.         delete(F,L,1);
  374.       delete(F,L,2);
  375.       SC:=C;
  376.       SR:=R;
  377.       if F[L]<>'>' then
  378.       begin
  379.         Error(1);
  380.         goto Exit;
  381.       end;
  382.       delete(F,L,1);
  383.       StrRC(Copy(F,L,3),C,R);
  384.       if R>9 then
  385.         delete(F,L,1);
  386.       delete(F,L,2);
  387.       if F[L]<>']' then
  388.       begin
  389.         Error(1);
  390.         goto Exit;
  391.       end;
  392.       delete(F,L,1);
  393.       FC:=C;
  394.       FR:=R;
  395.       case Func of
  396.         1: FV:=0;
  397.         2: FV:=-1E+36;
  398.         3: FV:=+1E+36;
  399.       end;
  400.       if ((SC<>FC) and (SR<>FR)) or
  401.          (SC<1)  or (FC<1)  or (SR<1)  or (FR<1)  or
  402.          (SC>26) or (FC>26) or (SR>99) or (FR>99) or
  403.          (SC>FC) or (SR>FR) then
  404.       begin
  405.         Error(1);
  406.         goto Exit;
  407.       end;
  408.       if SC=FC then
  409.       begin
  410.         C:=SC;
  411.         for R:=SR to FR do
  412.         begin
  413.           if HeapPtr+512>RecurPtr then
  414.           begin
  415.             V:=LookUp(C,R);
  416.             case Func of
  417.               1: FV:=FV+V;
  418.               2: if V>FV then FV:=V;
  419.               3: if V<FV then FV:=V;
  420.             end;
  421.           end else
  422.           begin
  423.             Error(2);
  424.             Goto Exit;
  425.           end;
  426.         end;
  427.       end else
  428.       begin
  429.         R:=SR;
  430.         for C:=SC to FC do
  431.         begin
  432.           if HeapPtr+512>RecurPtr then
  433.           begin
  434.             V:=LookUp(C,R);
  435.             case Func of
  436.               1: FV:=FV+V;
  437.               2: if V>FV then FV:=V;
  438.               3: if V<FV then FV:=V;
  439.             end;
  440.           end else
  441.           begin
  442.             Error(2);
  443.             Goto Exit;
  444.           end;
  445.         end;
  446.       end;
  447.       str(FV,S);
  448.       if Ord(S[0])+Ord(F[0])>255 then
  449.       begin
  450.         Error(4);
  451.         goto Exit;
  452.       end;
  453.       insert(S,F,L);
  454.       L:=L+Pred(Ord(S[0]));
  455.     end;
  456.     if (F[L] in ['A'..'Z']) and (F[L+1] in ['0'..'9']) then
  457.     begin
  458.       StrRC(Copy(F,L,3),C,R);
  459.       if R>9 then
  460.         delete(F,L,1);
  461.       delete(F,L,2);
  462.       if HeapPtr+512>RecurPtr then
  463.         V:=LookUp(C,R)
  464.       else
  465.       begin
  466.         Error(2);
  467.         Goto Exit;
  468.       end;
  469.       str(V,S);
  470.       if Ord(S[0])+Ord(F[0])>255 then
  471.       begin
  472.         Error(4);
  473.         goto Exit;
  474.       end;
  475.       insert(S,F,L);
  476.       L:=L+Pred(Ord(S[0]));
  477.     end;
  478.     L:=Succ(L);
  479.   end;
  480.   Prog:=F+'$';
  481.   Calc(V);
  482.   LookUp:=V;
  483.   move(V,mem[CA[C1,R1]+5],6);
  484.   CType:=ThisCalc*10+3;
  485.   mem[CA[C1,R1]+3]:=CType;
  486. Exit:
  487.   C:=C1;
  488.   R:=R1;
  489. end;
  490.  
  491. {$A+}
  492.  
  493. procedure LookUpCells;
  494. var
  495.   C,R: integer;
  496.   V:   real;
  497. begin
  498.   if CalcOn then
  499.   begin
  500.     if ThisCalc=1 then ThisCalc:=0 else ThisCalc:=1;
  501.     for R:=1 to 99 do
  502.       for C:=1 to 26 do
  503.         if CA[C,R]<>0 then
  504.           V:=LookUp(C,R);
  505.   end;
  506. end;
  507.  
  508.