home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG039.ARC / CONVERT.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  4KB  |  158 lines
  1. (**from Colin Mc Carthy    date 17/11/84
  2. The following program written in Turbo Pascal
  3. will convert from any base to another.
  4. For example hex to another bases, type
  5.            $3C00 <RETURN>**)
  6.  
  7. (** Program convert dec/hex/octal/binary **)
  8. var c,a,h,o,b,x:string[32];
  9.     tsave,num,num1,r,k,t,nn:real;
  10.     i,n,result:integer;
  11.     error,err,start,flag:boolean;
  12.     q:array[1..20] of real;
  13.     p:array[1..20] of char;
  14.     ident:char;
  15. procedure errors;
  16. begin
  17.     write(^g,^g,^g,'Input error! ');
  18.     delay(1300);
  19.     error:=true;
  20.     flag:=true;
  21.     err:=false;
  22.     a:='';
  23. end;
  24. procedure cstring;
  25. begin
  26.     a:='';
  27.     for i:=1 to n do
  28.     begin
  29.         if q[i]>9 then c:=chr(trunc(q[i])+55)
  30.         else str(trunc(q[i]),c);
  31.         a:=a+' '+c;
  32.    end;
  33. end;
  34. procedure def;
  35. begin
  36.     q[i]:=int(t/nn);
  37.     t:=t-int(t/nn)*nn;
  38. end;
  39. procedure calc;
  40. var dm:string[32];
  41.     aa,xp,m:integer;
  42.     l:real;
  43. begin
  44.     t:=0;
  45.     a:=copy(a,2,length(a));
  46.     xp:=length(a)-1;l:=r;
  47.     for i:=1 to length(a) do
  48.     begin
  49.         if xp=0 then r:=1;
  50.         for m:=1 to xp-1 do r:=r*l;
  51.         dm:=copy(a,i,1);
  52.         if dm>=upcase('A') then str(ord(upcase(dm))-55,dm);
  53.         val(dm,aa,result);
  54.         t:=t+aa*r;xp:=xp-1;r:=l;
  55.     end;
  56. end;
  57. begin
  58.     start:=true;
  59.     while start do begin
  60.     error:=true;
  61.     err:=false;
  62.     while error do
  63.     begin
  64.         ident:=' ';
  65.         flag:=false;
  66.         clrscr;
  67.         writeln('This program converts numbers into other bases.');
  68.         writeln('Input your numbers in the following form:-  <RETURN> to end.');
  69.         writeln;
  70.         writeln('<Decimal> or <-Decimal>, <$Hexadecimal>, <#Octal>, <%Binary>');
  71.         writeln;
  72.         readln(a);
  73.         if a='' then halt;
  74.         val(a,k,result);
  75.         if result=1 then k:=0;
  76.         if not flag then
  77.          begin
  78.              if abs(k)>65535.0 then errors;
  79.              if result>1 then errors;
  80.              if copy(a,1,1)>'9' then errors;
  81.          end;
  82.          if copy(a,1,1)='$' then
  83.          begin
  84.              if length(a)>5 then errors;
  85.              for i:=1 to length(a) do
  86.              begin
  87.                  if copy(a,i+1,1)>'Z' then
  88.                  if copy(a,i+1,1)>'f' then err:=true;
  89.                  if copy(a,i+1,1)<'Z' then
  90.                  if copy(a,i+1,1)>'F' then err:=true;
  91.              end;
  92.          end;
  93.          if err then errors;
  94.          val(copy(a,2,length(a)),num,result);
  95.          if a<>'' then ident:=copy(a,1,1);
  96.          if (ident='#') then
  97.          begin
  98.              if num>177777.0 then errors;
  99.              for i:=2 to length(a) do if copy(a,i,1)>'0' then errors;
  100.          end;
  101.          if ident='%' then
  102.          begin
  103.              if length(a)>17 then errors;
  104.              for i:=2 to length(a) do if copy(a,i,1)>'1' then errors;
  105.          end;
  106.          if not flag then error:=false;
  107.          val(a,t,result);
  108.     end;
  109.     if ident='#' then
  110.     begin
  111.         r:=8;calc;
  112.     end;
  113.     if ident='%' then
  114.     begin
  115.         r:=2;calc;
  116.     end;
  117.     if ident='$' then
  118.     begin
  119.         r:=16;calc;
  120.     end;
  121.     if t<0 then t:=65536.0+t;tsave:=t;
  122.     nn:=65536.0;
  123.     for i:=1 to 3 do
  124.     begin
  125.         nn:=nn/16;def;
  126.     end;
  127.     q[4]:=t;n:=4;
  128.     cstring;h:=a;t:=tsave;
  129.     nn:=262144.0;
  130.     for i:=1 to 5 do
  131.     begin
  132.         nn:=nn/8;def;
  133.     end;
  134.     q[6]:=t;o:='';n:=6;cstring;
  135.     o:=a;t:=tsave;
  136.     nn:=65536.0;
  137.     for i:=1 to 15 do
  138.     begin
  139.         nn:=nn/2;def;
  140.     end;
  141.     q[16]:=t;n:=16;cstring;b:=a;
  142.     clrscr;
  143.     writeln('Decimal=');
  144.     writeln(tsave:5:0,'    (',tsave-65536.0:5:0,')');
  145.     writeln;
  146.     writeln('Hexadecimal=');
  147.     writeln(h);
  148.     writeln;
  149.     writeln('Octal=');
  150.     writeln(o);
  151.     writeln;
  152.     writeln('Binary=');
  153.     writeln(b);
  154.     writeln;writeln;
  155.     write('Press <RETURN> ');
  156.     repeat until keypressed;
  157.  end;(* start *)
  158. end.