перевод из 2-ичной в 16-ичную с.с., прога нехо работать правильно :( Опции

[MiX]

Вообщем нужна перевести из 2 в 16 с.с. из Double Word-a в Double Word.
Я вот силами несилами вот такое склеил, но она недоконца работает. Мне препод говорит что бя ввел тридцать две единицы а она непашет правильно. Помогите пожалуста, может ее можно както упростить.

Код

uses crt;
var s:string;
b,c,d,h,i,t:longint;   a:word;
n:array [1..255] of longint;
f:Boolean;
begin
  clrscr;
  writeln('vvetite chislo v formate DOUBLE WORD ');
  readln(s);
  if length(s) > 32  then
  writeln('4islo bolwe Double word')
  else
  f:=true;
  for i:=1 to length(s) do
    if (s[i]<>'1') and (s[i]<>'0') then
    begin
      clrscr;
      writeln('ERROR');
     f:=false;
     readkey;
  end;
  if f then begin
  a:=0; b:=1;
  for i:=length(s) downto 1 do
    begin
      a:=a+((ord(s[i]))-ord('0'))*b;
      b:=b*2;
    end;
   writeln('desyatkove chislo  ',a);
   write('16 chislo- ');
   if (a<=9) and (a>=1) then writeln(a) else
      case a of
      10:write('A');
      11:write('B');
      12:write('C');
      13:write('D');
      14:write('E');
      15:write('F');
      end;
   while a>=16 do
   begin
     d:=a div 16;
     h:=a mod 16;
     n[i]:=h;
     i:=i+1;
     if d<16 then
     begin
       n[i]:=d;
       i:=i+1;
       a:=d;
     end
     else
       a:=d;
        end;
        for i:=i-1 downto 1 do
        begin
          a:=n[i];
          if (a>=0)and(a<=9) then
          write(a)
          else
            begin
              case a of
              10:write('A');
              11:write('B');
              12:write('C');
              13:write('D');
              14:write('E');
              15:write('F');
             end
             end;
end;
writeln;
readln;
end;
end.

[volvo]

может ее можно както упростить.

Можно попробовать:

uses crt;
var
  s, st, _result: string;
  i: integer;

const
  hexs: array[0 .. $F] of char = (
    '0', '1', '2', '3', '4', '5', '6', '7',
    '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'
  );
  bins: array[0 .. $F] of string[4] = (
    '0000', '0001', '0010', '0011', '0100', '0101', '0110', '0111',
    '1000', '1001', '1010', '1011', '1100', '1101', '1110', '1111'
  );
begin
  clrscr;
  writeln('vvetite chislo v formate DOUBLE WORD ');
  readln(s);
  if length(s) > 32  then writeln('4islo bolwe Double word')
  else begin
    _result := '';
    repeat

      if length(s) < 4 then
        while length(s) < 4 do begin
          s := '0' + s;
          writeln(s);
        end;

      st := copy(s, length(s) - 3, 4);
      delete(s, length(s) - 3, 4);

      for i := 0 to $f do
        if bins[i] = st then _result := hexs[i] + _result;

    until s = '';
  end;
  writeln(_result);
  readln;
end.

[Айра]

Эх, volvo, опередил, а я так старалась )

Один момент:
а вот тут разве не должно быть наоборот:

   if length(s) < 4 then
        while length(s) < 4 do begin
          s := '0' + s;   \\s:=s+'0';
          writeln(s);
        end;

по-моему нули дописываются в конец числа..

Сообщение отредактировано: Айра - 22.09.2007 1:42

[volvo]

по-моему нули дописываются в конец числа

То есть, ты хочешь сказать, что '11' не должно переводиться, как '0011', а должно - как '1100'?

[Айра]

это если число дробное.. мы же с целыми работаем.. сорри..

[MiX]

Спасибо за помощь, вы ме очень помогли