drawu.pas

运筹学演示程序之运输问题

    for i:=1 to sc-1 do
    begin
      moveto(left+wt+(i*w),top+ht);   lineto(left+wt+(i*w),top+height-25);
    end;
    for i:=1 to pc-1 do
    begin
      moveto(left+wt,top+ht+(i*h));   lineto(left+wt+(sc*w),top+ht+(i*h));
    end;
    font.size:=round(13*rate);
    font.Color:=clfuchsia;
    if (title<>'') then
      textout(left+(width-round(9*rate)*length(title))div 2,top-30,title);
  end;
end;
}

procedure TShowForm.FormCreate(Sender: TObject);
begin
  left:=0;
  top:=0;
  Width:=screen.width;
  height:=screen.height;
  showing:=false;
  SecPnlOpen:=false;
  SecPnlEnable:=false;
  rec.data_type:=0;
  old_rec.data_type:=0;
  if (screen.width=800) then rate:=1
  else
  begin
    if (messagedlg('当前显示分辨率为'+inttostr(screen.width)+'X'
          +inttostr(screen.height)+'，'+'该演示只有'+chr(13)
          +'在800X600的分辨率下才能达到最佳效果。'+chr(13)
          +'是否在当前分辨率下运行演示程序？',mtconfirmation,
          [mbyes,mbno],1)=mryes) then
    begin
      rate:=(screen.width /800);
    end
    else
      application.terminate;
  end;
end;

procedure TShowForm.redraw;
begin
  if (rec.label2<>'') then
  begin
    case rec.type1 of
      1: drawcost(drawdesk.canvas,18,120,380,200,rec.sc,rec.pc,rec.sale,
                  rec.produce,rec.c,rec.label1,rec.sw1,rec.ne1);
      2: drawcheck(drawdesk.canvas,18,120,380,200,rec.sc,rec.pc,rec.sale,
                  rec.produce,rec.c,rec.add,rec.label1);
      3: drawadjust(drawdesk.canvas,18,120,380,200,rec.sc,rec.pc,rec.sale,
                  rec.produce,rec.c,rec.label1,rec.st);
    end;
    case rec.type2 of
      1: drawcost(drawdesk.canvas,402,120,380,200,rec.sc,rec.pc,rec.s2,
                  rec.p2,rec.ma1,rec.label2,rec.sw2,rec.ne2);
      2: drawcheck(drawdesk.canvas,402,120,380,200,rec.sc,rec.pc,rec.s2,
                  rec.p2,rec.ma1,rec.add,rec.label2);
      3: drawadjust(drawdesk.canvas,402,120,380,200,rec.sc,rec.pc,rec.s2,
                  rec.p2,rec.ma1,rec.label2,rec.st);
    end;
  end
  else
  begin
    case rec.type1 of
      1: drawcost(drawdesk.canvas,220,120,380,200,rec.sc,rec.pc,rec.sale,
                  rec.produce,rec.c,rec.label1,rec.sw1,rec.ne1);
      2: drawcheck(drawdesk.canvas,220,120,380,200,rec.sc,rec.pc,rec.sale,
                  rec.produce,rec.c,rec.add,rec.label1);
      3: drawadjust(drawdesk.canvas,220,120,380,200,rec.sc,rec.pc,rec.sale,
                  rec.produce,rec.c,rec.label1,rec.st);
    end;
  end;
  with drawdesk.canvas do
  begin
    font.color:=cllime;
    font.size:=round(12*rate);
    textout(round(80*rate),round(380*rate),rec.txt1);
    textout(round(80*rate),round(410*rate),rec.txt2);
    textout(round(80*rate),round(440*rate),rec.txt3);
    textout(round(80*rate),round(470*rate),rec.txt4);
  end;
end;

procedure TShowForm.show;
begin
  cleanup(drawdesk.canvas);
  redraw;
end;

function TShowForm.readdata:byte;
                   // 0 -> no error; 1 -> 已经到文件末尾; 2 -> 读取错误
var error:byte;
begin
  error:=0;
  assignfile(f,filename);
  reset(f);
  try
   try
    seek(f,showstep);
    if(not eof(f)) then
    begin
      old_rec:=rec;
      if (showstep>0)then SecPnlEnable:=true;
      read(f,rec);
      if (eof(f)) then
        n1.enabled:=false;
    end
    else error:=1;
   except
    error:=2;
   end;
  finally
   closefile(f);
  end;
  result:=error;
end;

function TShowForm.getfilename:string;
var nm:string;
begin
{
  if (filelistbox1.filename<>'') then
    result:=filelistbox1.filename
  else
    result:='';
}
  if radiobutton1.checked then nm:='demo1'
  else nm:='demo2';
  if radiobutton4.checked then nm:=nm+'1'
  else if radiobutton5.checked then nm:=nm+'2'
  else nm:=nm+'3';
  result:=directorylistbox1.Directory+'\'+nm+'.sdt';
end;

procedure TShowForm.BitBtn1Click(Sender: TObject);
var i:integer;
begin
  if (filename='') then filename:=getfilename;
  if (filename<>'') then
  begin
    if (fileexists(filename)) then
    begin
      showstep:=0;
      if (readdata>0)then
      begin
        messagedlg('文件读取错误，该文件可能已损坏。',mterror,[mbok],0);
        filename:='';
      end
      else if (rec.data_type<>1) then
      begin
        messagedlg('文件存储的数据无法演示！'+chr(13)+'请确认指定的路径无误。',
             mterror,[mbok],0);
        filename:='';
      end
      else
      begin
        showing:=true;
        with showpanel do
        begin
          height:=0;
          width:=screen.width;
          left:=0;
          top:=0;
          visible:=true;
          bringtofront;
          for i:=1 to (screen.height div 5) do
            showpanel.height:=showpanel.Height+5;
          height:=screen.height;
          setfocus;
          refresh;
        end;
        with secpnl do
        begin
          height:=200;
          width:=10;
          left:=screen.width-5;
          bringtofront;
          visible:=true;
        end;
        pause(100);
        show;
      end;
    end
    else
    begin
      messagedlg('该路径下找不到数据文件！'+chr(13)+'请确认指定的路径无误。',
             mterror,[mbok],0);
      filename:='';
    end;
  end
  else
  begin
    messagedlg('程序内部产生了一个 I/O 错误。'+chr(13)+'请与作者联系。',
             mterror,[mbok],0);
    filename:='';
  end;
end;

procedure TShowForm.OpenSecPnl;
var kuang:integer;
begin
  SecPnlOpen:=true;
  if (old_rec.label2<>'') then
    kuang:=620
  else
    kuang:=330;
  with SecPnl do
  begin
    left:=screen.width-5;
    width:=kuang+10;
    repeat
      left:=left-(kuang div 30);
      refresh;
    until left<=(screen.width-kuang);
    pause(50);
    cleansecpnl;
    if (old_rec.label2<>'') then
    begin
     case old_rec.type1 of
      1: drawcost(SecPB.canvas,19,20,285,150,old_rec.sc,old_rec.pc,old_rec.sale,
                  old_rec.produce,old_rec.c,'',old_rec.sw1,old_rec.ne1);
      2: drawcheck(SecPB.canvas,19,20,285,150,old_rec.sc,old_rec.pc,old_rec.sale,
                  old_rec.produce,old_rec.c,old_rec.add,'');
      3: drawadjust(SecPB.canvas,19,20,295,150,old_rec.sc,old_rec.pc,old_rec.sale,
                  old_rec.produce,old_rec.c,'',old_rec.st);
     end;
     case old_rec.type2 of
      1: drawcost(SecPB.canvas,316,20,285,150,old_rec.sc,old_rec.pc,old_rec.s2,
                  old_rec.p2,old_rec.ma1,'',old_rec.sw2,old_rec.ne2);
      2: drawcheck(SecPB.canvas,316,20,285,150,old_rec.sc,old_rec.pc,old_rec.s2,
                  old_rec.p2,old_rec.ma1,old_rec.add,'');
      3: drawadjust(SecPB.canvas,316,20,285,150,old_rec.sc,old_rec.pc,old_rec.s2,
                  old_rec.p2,old_rec.ma1,'',old_rec.st);
     end;
    end
    else
    begin
     case old_rec.type1 of
      1: drawcost(SecPB.canvas,20,20,285,150,old_rec.sc,old_rec.pc,old_rec.sale,
                  old_rec.produce,old_rec.c,'',old_rec.sw1,old_rec.ne1);
      2: drawcheck(SecPB.canvas,20,20,285,150,old_rec.sc,old_rec.pc,old_rec.sale,
                  old_rec.produce,old_rec.c,old_rec.add,'');
      3: drawadjust(SecPB.canvas,20,20,285,150,old_rec.sc,old_rec.pc,old_rec.sale,
                  old_rec.produce,old_rec.c,'',old_rec.st);
     end;
    end;
  end;
end;

procedure TShowForm.CloseSecPnl;
begin
  SecPnlOpen:=false;
  with SecPnl do
  begin
    repeat
      left:=left+30;
      refresh;
    until left>=(screen.width-5);
    left:=screen.width-5;
  end;
  drawdesk.refresh;
  redraw;
end;

procedure TShowForm.DrawDeskMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if ((x>=(screen.width-10))and(y<=200)) then
  begin
    if ((not SecPnlOpen)and(SecPnlEnable)) then
      OpenSecPnl;
  end
  else
  begin
    if (SecPnlOpen) then
      CloseSecPnl;
  end;
end;

procedure TShowForm.SecPnlMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
    if ((not SecPnlOpen)and(SecPnlEnable)) then
      OpenSecPnl;
end;

procedure TShowForm.SecPBMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (button=mbright) then
    if (SecPnlOpen) then
    begin
      CloseSecPnl;
    end;
end;

procedure TShowForm.BitBtn2Click(Sender: TObject);
begin
   close;
end;

procedure TShowForm.X1Click(Sender: TObject);
begin
  bitbtn2.click;
end;

procedure TShowForm.N1Click(Sender: TObject);
begin
  DrawDeskmousedown(Sender,mbleft,[],1,1);
end;

procedure TShowForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
 if MessageDlg('退出示例演示吗？', mtConfirmation,
    [mbYes, mbNo], 0) = mrYes then
 begin
    showing:=false;
    mainform.SetFocus;
    mainform.show.checked:=false;
    mainform.bshow.down:=false;
    Action := caFree;
 end
 else
    Action := caNone;
end;

procedure TShowForm.DrawDeskMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var i:byte;
begin
  if ((button=mbleft)and(n1.enabled)) then
  begin
    showstep:=showstep+1;
    if ((showstep>0)and(not b1.enabled)) then b1.enabled:=true;
    i:=readdata;
    if i=0 then show
    else if i=1 then
    begin
      showmessage('已经演示完毕。');
      redraw;
    end;
  end;
end;

procedure TShowForm.B1Click(Sender: TObject);
var i:byte;
begin
  showstep:=showstep-1;
  if ((showstep<1)and(b1.enabled)) then b1.enabled:=false;
  if (showstep>=0) then
  begin
    if (showstep=0) then
    begin
      SecPnlEnable:=false;
      old_rec.data_type:=0;
      i:=readdata;
      if i=0 then show
      else if i=1 then
      begin
        showmessage('已经演示完毕。');
        redraw;
      end;
    end
    else begin
      showstep:=showstep-1;
      readdata;
      showstep:=showstep+1;
      i:=readdata;
      if i=0 then show
      else if i=1 then
      begin
        showmessage('已经演示完毕。');
        redraw;
      end;
    end;
  end;
  n1.enabled:=true;
end;

procedure TShowForm.A1Click(Sender: TObject);
var i:integer;
begin
  if (messagedlg('退出当前的演示吗？',mtinformation,
       [mbyes,mbno],0)=mryes) then
  begin
     showing:=false;
     SecPnlEnable:=false;
     showstep:=0;
     filename:='';
     n1.enabled:=true;
     with secpnl do
     begin
          height:=20;
          width:=2;
          left:=screen.width+5;
          visible:=false;
     end;
     with showpanel do
     begin
       for i:=1 to (screen.height div 10) do
          showpanel.height:=showpanel.Height-10;
       height:=1;
       width:=screen.width;
       left:=0;
       top:=-5;
     end;
     refresh;
  end;
end;

procedure TShowForm.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (key=vk_escape) then
    close
  else if (((key=vk_space)or(key=13))and(showing)) then
  begin
      DrawDeskmousedown(Sender,mbleft,[],1,1);
  end;
end;

end.