old/PAS/BINSUM.PAS

uses Graph,CRT;


Var
  a,b : integer;
  aa,ab,res : String;

{------------------------------------}
Function GetValue(text:string;x1,y1,MinValue,MaxValue,dl1:integer):integer;
Var
 p1                   : pointer;
 s1                   : word;
 x,y,StartX,StartY,xk : integer;
 k                    : real;
 length               : integer;
 ch,tmpch             : char;
 st                   : string;
 value                : integer;
 code                 : integer;
 LastColor,LastBk     : integer;

{--------------------------------------}
Procedure EnterVal;
Var
  FillInfo :FillSettingsType;
Begin
  GetFillSettings(FillInfo);
  SetFillStyle(CloseDotFill,LightBlue);
  Bar(Startx,starty,Startx+length,Starty+60);
  SetColor(White);
  Rectangle(Startx,starty,Startx+length,Starty+60);
  SetColor(LightGray);
  SetTextJustify(CenterText,TopText);
  OutTextXY(startx + length div 2, Starty+15,Text);
  SetColor(Yellow);
  SetTextJustify(LeftText,TopText);
  x := Startx+20;
  y := Starty+35;
  st := '';
  Repeat
    ch := readkey;
    if ch <> #13 then
    begin
      if ch = #8 then
        if ord(st[0]) <> 0 then
          begin
            delete(st,ord(st[0]),1);
            SetFillStyle(black,CloseDotFill);
            Bar(x-TextWidth(tmpch),y,x,y+TextHeight(tmpch));
            x := x - TextWidth(tmpch);
            SetFillStyle(FillInfo.color,FillInfo.pattern);
          End
        else
      else
        begin
          st := st + ch;
          OutTextXY(x,y,ch);
          x := x + TextWidth(ch);
          if x > startx+length-40 then x := x - TextWidth(ch);
          tmpch := ch;
        end;
    end;
  Until ch = #13;
End;{EnterVal}
{-----------------------------------}
Procedure WriteBox(x,y:Integer);
Begin
  SetColor(White);
  SetFillStyle(CloseDotFill,LightBlue);
  Bar(StartX+length div 2 - x,StartY+30-y,StartX+length div 2+x,StartY+30+y);
  Rectangle(StartX+length div 2 - x,StartY+30-y,StartX+length div 2+x,StartY+30+y);
  Delay(Dl1);
End;{WriteBox}
{-------------------------------------}
Begin
  LastColor := GetColor;
  LastBK := GetBkColor;
  If MinValue > MaxValue then begin
    GetValue := 0;
    Exit;
  end;
  length := TextWidth(text) + 50;
  StartX := x1 - length div 2;
  StartY := y1 - 30;
  if length div 2 > x1 then startX := 2;
  if y1 - 30 < 2 then Starty := 1;
  if length div + x1 > 639 then Startx := 639 - length;
  if y1 + 30 > 479 then StartY := 419;
  s1 := ImageSize(Startx,Starty,startx+length,Starty+60);
  GetMem(p1,s1);
  GetImage(Startx,Starty,startx+length,Starty+60,p1^);
  value :=0 ;
  xk := 1;
  k :=60/length;
  for xk := 1 to length div 2 do WriteBox(xk,round(xk*k));
  Repeat
    EnterVal;
    val(st,value,code);
  Until (code = 0) and (value in [MinValue..MaxValue]);
  PutImage(Startx,Starty,p1^,NormalPut);
  GetValue := Value;
  SetColor(LastColor);
  SetBkColor(LastBk);
End;{GetValue}

Procedure InitG;
var
  grDriver: Integer;
  grMode: Integer;
  ErrCode: Integer;
  i,j:word;
begin
  grDriver := Detect;
  InitGraph(grDriver, grMode,'');
  ErrCode := GraphResult;
  if ErrCode <> grOk then
   begin
    Writeln('Graphics error:', GraphErrorMsg(ErrCode));
    Halt(1);
   end;
  SetColor(Blue);
  SetTextJustify(CenterText,CenterText);
  for j := 1 to 15 do
    begin
      Line(115+j*15,100,115+j*15+15,100);
      Line(115+j*15,100,115+j*15,115);
      Line(115+j*15,115,115+j*15+15,115);
    end;
  Line(115+16*15,100,115+16*15,115);
  SetColor(Red);
  Line(115,100,130,100);
  Line(115,100,115,115);
  Line(115,115,130,115);
  Line(130,100,130,115);
  SetColor(Blue);
  for j := 1 to 15 do
    begin
      Line(115+j*15,150,115+j*15+15,150);
      Line(115+j*15,150,115+j*15,165);
      Line(115+j*15,165,115+j*15+15,165);
    end;
  Line(115+16*15,150,115+16*15,165);
  SetColor(Red);
  Line(115,150,130,150);
  Line(115,150,115,165);
  Line(115,165,130,165);
  Line(130,150,130,165);
End;{InitG}
Function ToBinSimple(inp:integer):String;
Const
  n : array [0..1] of string[1] = ('0','1');
Var
 rc   : string;
 a    : integer;
 flag : boolean;
Begin
  rc := '';
  if inp < 0 then flag := true else flag := false;
  a := abs(inp);
  repeat
    rc := rc + n[a mod 2];
    a := a div 2;
  until a < 2;
  rc := rc + n[a];
  for a := length(rc) to 15 do insert('0',rc,length(rc)+1);
  if flag then rc[16] := '1' else rc[16] := '0';
  ToBinSimple := rc;
End;{ToBinSimple}
{----------------------------}
Procedure Invert(var inp:string);
Var
 i: byte;
Begin
  for i := 1 to 15 do if inp[i] = '0' then inp[i] := '1' else inp[i] :='0';
End; {Invert}
{---------------------------}
Procedure WriteA(inp : string);
Var i : byte;
Begin
  setColor(White);
  SetTextJustify(1,1);
  for i := 1 to 16 do OutTextXY(362-i*15,108,inp[i]);
End;{WriteA}
{---------------------------}
Procedure WriteB(inp : string);
Var i : byte;
Begin
  setColor(White);
  SetTextJustify(1,1);
  for i := 1 to 16 do OutTextXY(362-i*15,159,inp[i]);
End;{WriteB}
{---------------------------}
Procedure WriteTextA(pos : byte; text:string);
Begin
  SetTextJustify(1,1);
  SetColor(Yellow);
  OutTextXY(360-pos*15,90,'');
  OutTextXY(360-pos*15,80,text);
End;{WriteTextA}
{---------------------------}
Procedure WriteTextB(pos : byte; text:string);
Begin
  SetTextJustify(1,1);
  SetColor(Yellow);
  OutTextXY(360-pos*15,172,'');
  OutTextXY(360-pos*15,182,text);
End;{WriteTextA}
{---------------------------}
Function BinSum(inA,inB : string):string;
Var i,numA,numB,last,tm:byte;code : integer;rc:string;
Begin
  i := 1;
  last := 0;
  fillChar(rc,sizeof(rc),'0');
  rc[0] := #17;
  while i <> 18 do begin
    val(inA[i],numA,code);
    val(inB[i],numB,code);
    tm := numA+numB+last;
    case tm of
      3: begin
           rc[i] := '1';
           last := 1;
         end;
      2: begin
           rc[i] := '0';
           last := 1;
         end;
      1: begin
           rc[i] := '1';
           last := 0;
         end;
      0: begin
           rc[i] := '0';
           last := 0;
         end;
    end;
    inc(i);
  end;
  BinSum := rc;
End;{BinSum}
{---------------------------}
Procedure InAdd(var inp : string);
Begin
  inp := BinSum(inp,'1000000000000000');
End;{InAdd}
{---------------------------}
Procedure ClearNumA;
Var i:byte;
Begin
  SetColor(black);
  setfillstyle(SolidFill,Black);
  for i := 1 to 16 do Bar(116+i*15,101,116+i*15+13,114);
End;{ClearNumA}
{---------------------------}
Procedure ClearNumB;
Var i:byte;
Begin
  SetColor(black);
  setfillstyle(SolidFill,Black);
  for i := 1 to 16 do Bar(116+i*15,151,116+i*15+13,164);
End;{ClearNumB}
{---------------------------}
Procedure ClearText(pos:byte);
Var i:byte;
Begin
  SetColor(black);
  setfillstyle(SolidFill,black);
  if pos = 1 then
    Bar(1,75,640,92)
  else
    Bar(1,167,640,187);
End;{ClearPos}
{---------------------------}
Procedure ClearResNum;
Var j : integer;
Begin
  SetColor(black);
  setfillstyle(SolidFill,Black);
  for j := 1 to 16 do Bar(116+j*15,181,116+j*15+13,194);
End;
{------------------------------------------}
Procedure WriteResText(text : string;pos:integer);
Begin
  SetColor(Yellow);
  OutTextXY(360-pos*15,202,'');
  OutTextXY(360-pos*15,212,text);
End;
{---------------------------------------}
Procedure ClearResText;
Begin
  SetFillStyle(SolidFill,Black);
  SetColor(Black);
  Bar(1,197,640,215);
End;
{----------------------------------------------------------}

Procedure WriteResNum(var inp : string;ask : boolean);
Var j : integer;
Begin
  SetCOlor(Yellow);
  for j := 1 to 16 do begin
    OutTextXY(362-j*15,189,inp[j]);
    if ask then ReadKey;
  end;
  if inp[17] = '1' then
    begin
      setcolor(White);
      OutTextXY(362-17*15,189,inp[17]);
      WriteResText('‹¨è­¨©!',17);
      ReadKey;
      ClearResText;
      SetFillStyle(SolidFill,Black);
      SetColor(Black);
      Bar(1,181,110,194);
      delete(inp,17,1);
    end;
End;
Procedure InitRes;
Var j : integer;
Begin
  SetColor(Blue);

  for j := 1 to 15 do
    begin
      Line(115+j*15,180,115+j*15+15,180);
      Line(115+j*15,180,115+j*15,195);
      Line(115+j*15,195,115+j*15+15,195);
    end;
  Line(115+16*15,180,115+16*15,195);
  SetColor(Red);
  Line(115,180,130,180);
  Line(115,180,115,195);
  Line(115,195,130,195);
  Line(130,180,130,195);
End;{InitRes}
{---------------------------------}
Function Step(inp : integer):integer;
Var j : integer;rc:integer;
Begin
  rc:=1;
  if inp = 0 then Step := 1 else
  begin
  for j := 1 to inp do rc:=rc*2;
  Step:=rc;
  end;
End;{Step}
{---------------------------------}
Procedure ToInt(inp : string;var out : integer);
Var j:integer;rc:integer;
Begin
  rc := 0;
  for j := 1 to 15 do if inp[j] = '1' then inc(rc,Step(j-1));
  out := rc;
End;{ToInt}
{-------------------------------}
Procedure WriteRes(var inp : string);
Var j : integer;otr : boolean;res:integer;tm:string;
Begin
  InitRes;
  SetCOlor(Yellow);
  WriteResNum(inp,true);
  if inp[16] = '1' then
    begin
      WriteResText('Žâà¨æ â¥«ì­®¥',16);
      ReadKey;
      ClearResText;
      WriteResText('ˆ­¢¥àâ¨àãî',16);
      ReadKey;
      Invert(inp);
      ClearResText;
      ClearResNum;
      WriteResNum(inp,false);
      WriteResText('+1',1);
      ReadKey;
      InAdd(inp);
      ClearResText;
      ClearResNum;
      WriteResNum(inp,false);
      WriteResText('‚ᥠŽŠ',1);
    end
  else
    begin
      WriteResText('‚ᥠŽŠ',1);
    end;
  if inp[16] = '1' then otr := true else otr := false;
  ToInt(inp,res);
  if otr then res := -res;
  str(res,tm);
  insert('�¥§ã«ìâ â: ',tm,1);
  SetColor(Green);
  OutTextXY(400,300,tm);
  ReadKey;
End;{WriteRes}
{----------------=======================---------------------------}
Begin
  InitG;
  a := GetValue('‚¢¥¤¨â¥ ¯¥à¢®¥ ç¨á«®',320,240,-MaxInt,MaxInt,2);
  b := GetValue('‚¢¥¤¨â¥ ¢â®à®¥ ç¨á«®',320,240,-MaxInt,MaxInt,2);
  aa := ToBinSimple(a);
  WriteA(aa);
  ab := ToBinSimple(b);
  WriteB(ab);
  if aa[16] = '1' then
   begin
    WriteTextA(16,'Žâà¨æ â¥«ì­®¥');
    ReadKey;
    ClearText(1);
    WriteTextA(16,'ˆ­¢¥àâ¨àãî');
    ReadKey;
    Invert(aa);
    ClearNumA;
    WriteA(aa);
    ClearText(1);
    WriteTextA(16,'‚ ¤®¯. ¢¨¤');
    ReadKey;
    InAdd(aa);
    ClearNumA;
    WriteA(aa);
    ClearText(1);
   end;
  if ab[16] = '1' then
   begin
    WriteTextB(16,'Žâà¨æ â¥«ì­®¥');
    ReadKey;
    ClearText(2);
    WriteTextB(16,'ˆ­¢¥àâ¨àãî');
    ReadKey;
    Invert(ab);
    ClearNumB;
    WriteB(ab);
    ClearText(2);
    WriteTextB(16,'‚ ¤®¯. ¢¨¤');
    ReadKey;
    InAdd(ab);
    ClearNumB;
    WriteB(ab);
    ClearText(2);
   end;
  WriteTextA(1,'⇴ OK');
  WriteTextB(1,'⇴ OK');
  ReadKey;
  ClearText(1);
  ClearText(2);
  SetColor(Magenta);
  MoveTo(115,170);
  For a := 1 to 120 do
    begin
      LineRel(2,0);
      Delay(20);
    end;
  ReadKey;
  res := BinSum(aa,ab);
  WriteRes(Res);
  CloseGraph;
End.