Hao's profile电子小虫 PlusBlogListsGuestbook Tools Help

Blog


    Pascalc Alpha Test 4 (2008.11.22)

    program PasCalc;

    uses math;

    const VARNAME:set of char=['A'..'Z'];
          NUMNAME:set of char=['0'..'9','.'];
          OPRNAME:set of char=['+','-','*','/','^','(',')',','];
          FUNNAME2:set of char=['%','''','"','!'];
          HOW_MANY_FUN=24;
          FUNNAME:array[1..HOW_MANY_FUN]of string=
          ('abs','sin','cos','tan','cot','asin','acos','atan','sinh','cosh','tanh',
           'asinh','acosh','atanh','log','ln','exp','evo','sqr','sqrt','int','rnd',
           'frac','hypot');

    var str_in:string;
        len:byte;
        rd:array[0..100]of string;
        va:array['A'..'Z']of float;

    function isfun(s:string):boolean;
     var i:byte;
     begin
      isfun:=true;
      for i:=1 to HOW_MANY_FUN do
       if s=FUNNAME[i] then exit;
      isfun:=false;
     end;

    function fc(s:string; a,b:float):float;
     begin
      if s='abs' then fc:=abs(a);

      if s='sin' then fc:=sin(a);
      if s='cos' then fc:=cos(a);
      if s='tan' then fc:=tan(a);
      if s='cot' then fc:=cotan(a);

      if s='asin' then fc:=arcsin(a);
      if s='acos' then fc:=arccos(a);
      if s='atan' then fc:=arctan(a);

      if s='sinh' then fc:=sinh(a);
      if s='cosh' then fc:=cosh(a);
      if s='tanh' then fc:=tanh(a);

      if s='asinh' then fc:=arcsinh(a);
      if s='acosh' then fc:=arccosh(a);
      if s='atanh' then fc:=arctanh(a);

      if s='evo' then fc:=power(b,1/a);
      if s='log' then fc:=logn(a,b);
      if s='ln' then fc:=ln(a);
      if s='exp' then fc:=exp(a);
      if s='sqr' then fc:=sqr(a);
      if s='sqrt' then fc:=sqrt(a);

      if s='int' then fc:=int(a);
      if s='rnd' then
       if frac(a)>=0.5 then
        fc:=int(a)+1 else fc:=int(a);
      if s='frac' then fc:=frac(a);
      if s='hypot' then fc:=hypot(a,b);
     end;

    function yxj(s:string):shortint;
     var y:shortint;
     begin
      if (s='')or(s=')')or(s=',') then y:=-1 else
       if (s='+')or(s='-')then y:=0 else
        if (s='*')or(s='/') then y:=1 else
         if s='^' then y:=2 else y:=3;

      yxj:=y;
     end;

    procedure til(s:string; var num:float);
     var i:byte;
         tmp:float;
     begin
      tmp:=0;

      if s='%' then tmp:=num/100;
      if s='''' then tmp:=degtorad(num);
      if s='"' then tmp:=gradtorad(num);
      if s='!' then
      begin
       tmp:=1;
       for i:=1 to trunc(num) do
        tmp:=tmp*i;
      end;

      num:=tmp;
     end;

    procedure readexp(s:string);
     var i:byte;
         tmp:string;
         ischar:boolean;
     begin
      len:=0;
      tmp:='';
      for i:=0 to 100 do
       rd[i]:='';

      if s[1] in VARNAME+NUMNAME then
       ischar:=false else ischar:=true;

      for i:=1 to length(s) do
      begin
       if s[i] in (OPRNAME+FUNNAME2) then
       begin
        if tmp<>'' then
        begin
         inc(len);

         if tmp[1] in VARNAME then
          str(va[tmp[1]],rd[len]) else
          rd[len]:=tmp;

         tmp:='';
        end;

        inc(len);
        rd[len]:=s[i];

        if (s[i+1] in VARNAME+NUMNAME) then
         ischar:=false else ischar:=true;

        continue;
       end;

       if s[i] in VARNAME+NUMNAME then
       begin
        if ischar then
        begin
         ischar:=false;
         inc(len);

         if tmp[1] in VARNAME then
          str(va[tmp[1]],rd[len]) else
          rd[len]:=tmp;

         tmp:='';
        end;
       end else
        if not(ischar) then
        begin
         ischar:=true;
         inc(len);

         if tmp[1] in VARNAME then
          str(va[tmp[1]],rd[len]) else
          rd[len]:=tmp;

         tmp:='';
        end;

       tmp:=tmp+s[i];
      end;

      if tmp<>'' then
      begin
       inc(len);

       if tmp[1] in VARNAME then
        str(va[tmp[1]],rd[len]) else
        rd[len]:=tmp;
      end;
     end;

    function calc(b,f:integer):float;
     var num:array[0..50]of float;
         sym:array[0..50]of string;
         i,j,kuo,k2,nm,sm:byte;
         code:integer;
         ktmp,ktmp2,n:float;

     procedure pop;
      begin
       dec(nm);

       if sym[sm]='+' then
        num[nm]:=num[nm]+num[nm+1];

       if sym[sm]='-' then
        if nm=0 then
         num[nm+1]:=num[nm]-num[nm+1]
        else
         num[nm]:=num[nm]-num[nm+1];

       if sym[sm]='*' then
        num[nm]:=num[nm]*num[nm+1];

       if sym[sm]='/' then
        num[nm]:=num[nm]/num[nm+1];

       if sym[sm]='^' then
        num[nm]:=power(num[nm],num[nm+1]);

       sym[sm]:=chr(0);
       if nm>0 then num[nm+1]:=0;
       dec(sm);
      end;

     begin
      nm:=0;
      sm:=0;
      fillchar(num,sizeof(num),0);

      for i:=0 to 50 do
       sym[i]:='';

      i:=b;
      while i<f do
      begin
       inc(i);

       if rd[i]='(' then
       begin
        j:=i;
        kuo:=1;
        k2:=0;

        repeat
         inc(j);

         if rd[j]='(' then inc(kuo);
         if rd[j]=')' then dec(kuo);
         if (rd[j]=',')and(kuo=1)then k2:=j;
        until (kuo=0)or(j>f);

        if k2=0 then
         ktmp:=calc(i,j-1) else
         begin
          ktmp:=calc(i,k2-1);
          ktmp2:=calc(k2,j-1);
         end;

        i:=j;
        if isfun(sym[sm]) then
        begin
         ktmp:=fc(sym[sm],ktmp,ktmp2);
         sym[sm]:='';
         dec(sm);
        end;

        inc(nm);
        num[nm]:=ktmp;
       end else
       begin
        val(rd[i],n,code);

        if code=0 then
        begin
         inc(nm);
         num[nm]:=n;
        end else
        begin
         if not((isfun(rd[i]))or(rd[i][1] in FUNNAME2)) then
          while (yxj(rd[i])<=yxj(sym[sm]))and(sm>0) do
           pop;

         if (length(rd[i])=1)and(rd[i][1] in FUNNAME2) then
          til(rd[i],num[nm]) else
          begin
           inc(sm);
           sym[sm]:=rd[i];
          end;
        end;
       end;
      end;

      while sm<>0 do pop;

      calc:=num[1];
     end;

    procedure comp(s:string);
     begin
      readexp(s);
      va['M']:=calc(0,len);
      writeln(va['M']);
     end;

    procedure dim;
     var ch:char;
         s:string;
     begin
      write('Var:');
      readln(ch);
      write(ch,'=');

      if ch in VARNAME then
      begin
       readln(s);
       readexp(s);
       va[ch]:=calc(0,len);
       writeln(ch,'=',va[ch]);
      end else
       writeln('Error');
     end;

    procedure show;
     var i:char;
     begin
      for i:='A' to 'Z' do
       writeln(i,'=',va[i]);
     end;

    begin
     writeln;
     writeln('##################################################');
     writeln('# Pascalc Alpha Test 4                           #');
     writeln('#  by Cui Hao                                    #');
     writeln('#     2008.11.22                                 #');
     writeln('#                                                #');
     writeln('# Please read "README.TXT"(Chinese) before use.  #');
     writeln('##################################################');

     va['P']:=pi;
     va['E']:=exp(1);

     repeat;
      write('> ');

      readln(str_in);

      if (str_in<>'')and(str_in<>'quit') then
       if str_in='dim' then
        dim else
        if str_in='show' then
         show else
         if str_in='clr' then
         begin
          fillchar(va,sizeof(va),0);
          va['P']:=pi;
          va['E']:=exp(1);
         end else comp(str_in);
     until str_in='quit';
    end.

    Comments

    Please wait...
    Sorry, the comment you entered is too long. Please shorten it.
    You didn't enter anything. Please try again.
    Sorry, we can't add your comment right now. Please try again later.
    To add a comment, you need permission from your parent. Ask for permission
    Your parent has turned off comments.
    Sorry, we can't delete your comment right now. Please try again later.
    You've exceeded the maximum number of comments that can be left in one day. Please try again in 24 hours.
    Your account has had the ability to leave comments disabled because our systems indicate that you may be spamming other users. If you believe that your account has been disabled in error please contact Windows Live support.
    Complete the security check below to finish leaving your comment.
    The characters you type in the security check must match the characters in the picture or audio.

    To add a comment, sign in with your Windows Live ID (if you use Hotmail, Messenger, or Xbox LIVE, you have a Windows Live ID). Sign in


    Don't have a Windows Live ID? Sign up

    Trackbacks

    The trackback URL for this entry is:
    http://cuihao1994.spaces.live.com/blog/cns!6732B11C7630DE83!203.trak
    Weblogs that reference this entry
    • None