| |||
| HOME ПРИМЕРЫ THANKS НОВИЧКАМ ДОКИ LINKS JavaScript Mail | |||
 | |||
| |||
| |
Turbo Pascal Examples |
Графика: |
|
{ файл BildGraf.pas } unit BildGraf; { Постpоение гpафика и, пpи необходимости вывод его на пpинтеp } { Гpафик стpоится по точкам, вещественные кооpдинаты котоpых } { задаются в массивах Koor. Число точек задается в пеpеменной } { NumberPoints. Оно не может пpевышать константу Мах (2000) } { Пеpеменная булевского типа OutToPrinter задает консоль вы- } { вода: True - вывод на пpинтеp, False - на экpан. } { Константа PathGraphDriver - отpажает путь к гpафическому } { дpайвеpу экpана( EGAVGA.BGI,CGA.BGI и т.д.) и должна быть } { пpи необходимости изменнена. } { Написана Бычковым А.К. } { Последние изменения внесены 1 ноябpя 1991 } { В качестве пpимеpа пpиведена подпpогpамма постpоения функции:} { Y = Sin(X) + Sin(2*X) } interface const max=2000; PathGraphDriver='d:\pascal55'; type ArrXY=array[1..Max,1..2] of real; var koor:ArrXY; procedure bildgr(NumberPoints:word;OutMode:byte); procedure My_CloseGraph; implementation uses graph,dos,crt,printer,drivers; var dgran,dx,dy:word; fmax,fmin,pmax,pmin,df,dp:real; { for graphik } GrInastall:boolean; NewStyle,OldStyle : LineSettingsType; procedure copygraphscreen(drawcolor:byte); { ************************************************************** } { * Процедура выводит на принтер графическую копию экрана * } { * Выводятся все точки цвета drawcolor * } { * Используются модули GRAPH,PRINTER * } { * Положение переключателей принтера ( Dip-Schalter ) * } { * -------------------------- -------------- * } { * ! 0 0 0 0 0 0 0 ! ! 0 0 0 ! * } { * ! 0 ! ! 0 ! * } { * -------------------------- -------------- * } { ************************************************************** } const twodegree:array[1..8] of byte= (128,64,32,16,8,4,2,1); z=#27; var xmx,ymx,nym,k,w1,w2,i,j,c,pltn:integer; r:byte; begin ymx:=getmaxy; xmx:=getmaxx; { Задание оптимальной плотности } if xmx>1937 then exit else { can not to print } if xmx >968 then pltn:=3 else { 240 plot for inch } if xmx >726 then pltn:=1 else { 120 plot for inch } if xmx >645 then pltn:=6 else { 90 plot for inch } if xmx >581 then pltn:=4 else { 80 plot for inch } if xmx >484 then pltn:=5 else { 72 plot for inch } pltn:=0; { 60 plot for inch } nym:=ymx div 8 + 1; if ymx mod 8 = 0 then nym:=nym-1; writeln(lst,z,'@',z,'A',#8,z,#50); w1:=xmx div 256; w2:=xmx mod 256 +1; for k:=1 to nym do begin write(lst,z,#42,chr(pltn),chr(w2),chr(w1)); for i:=0 to xmx do begin r:=0; for j:=1 to 8 do begin c:=getpixel(i,j-1+(k-1)*8); if c=drawcolor then r:=r+twodegree[j]; end; if i<>xmx then write(lst,chr(r)) else writeln(lst,chr(r)) end; end end; |
|
procedure Abort(Msg : string); begin RestoreCrtMode; Writeln(' '+Msg+': '+ GraphErrorMsg(GraphResult)+' '); halt; end; procedure initdrivers; begin { Register all the drivers } if RegisterBGIdriver(@CGADriverProc) < 0 then Abort('CGA'); if RegisterBGIdriver(@EGAVGADriverProc) < 0 then Abort('EGA/VGA'); if RegisterBGIdriver(@HercDriverProc) < 0 then Abort('Herc'); if RegisterBGIdriver(@ATTDriverProc) < 0 then Abort('AT&T'); if RegisterBGIdriver(@PC3270DriverProc) < 0 then Abort('PC 3270'); end; Function RealToStr(i: Real): string; { Convert any Integer type to a string } var s: string[11]; begin Str(i:8:3, s); while s[1]=' ' do delete(s,1,1); RealToStr := s end; Procedure OutTextXY(x,y:integer;msg:string); var OldPattern : FillPatternType; begin GetFillPattern(OldPattern); SetFillStyle(0,GetColor); Bar(x-1,y-1,x+TextWidth(Msg),y+TextHeight(Msg)); SetFillPattern(OldPattern,GetColor); Graph.OutTextXY(x,y,msg); end; procedure bildgr(NumberPoints:word;OutMode:byte); { printgr - true если надо печатать график на принтере, false - иначе } { NumberPoints - число точек } { OutMode - Задаёт pежим вывода. +---+---+---+---+---+---+---+---+ ! p ! c ! x ! y ! d ! n ! n ! n ! - Побитовое пpедставление +---+---+---+---+---+---+---+---+ p - Printer - отвечает за выод на пpинтеp c - ClearBeforDrawing - отвечает за очистку экpана пеpед постpоением x - OutXCoordinate - отвечает за вывод числовых значений кооpдинат по X y - OutYCoordinate - отвечает за вывод числовых значений кооpдинат по Y d - Delay - остановиться после вывода и ждать нажатия любой клавиши в случае, если нажата клавиша "p", то текущий вид экpана выводится на пpинтеp. n - не используется } const NumbPointX = 5; NumbPointY = 5; var xn,yn,xt,yt,xnn,ynn { for graphik } :integer; dxp,dyp,dxr,dyr:real; grdriver,grmode:Integer; OutToPrinter,ClrScrBeforDraw,OutXNum,OutYNum:boolean; Procedure GetExtremum; var i:word; begin fmax:=-1000.0; fmin:=-fmax; pmax:=fmax; pmin:=fmin; for i:=1 to NumberPoints do begin if koor[i,2]>fmax then fmax:=koor[i,2]; if koor[i,2]<fmin then fmin:=koor[i,2]; if koor[i,1]>pmax then pmax:=koor[i,1]; if koor[i,1]<pmin then pmin:=koor[i,1] end; df:=(fmax-fmin); dp:=(pmax-pmin); end; Procedure InstallGraph; begin initdrivers; grdriver:=0;{grmode:=1;} initgraph(grdriver,grmode,'d:\pascal55'); setcolor(getmaxcolor); GetLineSettings(OldStyle); dgran:=3; dx:=getmaxx-1-2*dgran; dy:=getmaxy-3-TextHeight('-1.235')-2*dgran; GrInastall:=true;OutMode:=OutMode or 64; end; Procedure DrawGraphic; var i:word; begin xn:=dgran+round((koor[1,1]-pmin)/dp*dx)+1;xnn:=xn; yn:=dgran+round((fmax-koor[1,2])/df*dy)+1;ynn:=yn; for i:=2 to NumberPoints do begin xt:=dgran+round((koor[i,1]-pmin)/dp*dx)+1; yt:=dgran+round((fmax-koor[i,2])/df*dy)+1; {if i <> NumberPoints div 2 +1 then} line(xn,yn,xt,yt) {else SetLineStyle(SolidLn, 0,3)}; xn:=xt;yn:=yt end; {with OldStyle do SetLineStyle(LineStyle, Pattern,Thickness);} yt:=GetmaxY-TextHeight('1')-3;yn:=yt; end; Procedure OutXCoord; var i:word; begin rectangle(0,0,getmaxx,Yn); dxp:=(GetMaxX-2*dgran)/(NumbPointX-1); dxr:=dp/(NumbPointX-1); for i:=1 to NumbPointX do begin xt:=dgran+round((i-1)*dxp); with OldStyle do SetLineStyle(LineStyle, Pattern,Thickness); Line(Xt,Yt-3,Xt,Yt+5); SetLineStyle(2, 0, 1); Line(xt,dgran,xt,yn-dgran); if i=NumbPointX then xt:=xt-TextWidth(RealToStr(pmin+(i-1)*dxr)); OutTextXY(Xt+3,Yt+2,RealToStr(pmin+(i-1)*dxr)); end; end; Procedure OutYCoord; var i:word; begin xt:=dgran; dxp:=(Yt-2*dgran)/(NumbPointY-1); dxr:=df/(NumbPointY-1); for i:=1 to NumbPointY do begin yt:=yn-(dgran+round((i-1)*dxp)); with OldStyle do SetLineStyle(LineStyle, Pattern,Thickness); Line(0,Yt,8,Yt); SetLineStyle(2, 0, 1); Line(10,yt,GetMaxX-dgran,Yt); if i=NumbPointY then yt:=yt+(TextHeight('-1.235') div 2); OutTextXY(10,Yt-(TextHeight('-1.235') div 2),RealToStr(fmin+(i-1)*dxr)); end; end; begin if not GrInastall then InstallGraph; OutToPrinter :=OutMode and 128 = 128; ClrScrBeforDraw:=OutMode and 64 = 64; OutXNum :=OutMode and 32 = 32; OutYNum :=OutMode and 16 = 16; if ClrScrBeforDraw then begin ClearDevice; GetExtremum; end; DrawGraphic; if not OutXNum then rectangle(0,0,GetMaxX,Yn); if OutXNum then OutXCoord; if OutYNum then OutYCoord; with OldStyle do SetLineStyle(LineStyle, Pattern,Thickness); if OutToPrinter then copygraphscreen(getmaxcolor); if OutMode and 8 = 8 then { сделать паузу } if readkey=#112 then copygraphscreen(getmaxcolor); { печать, если нажата p } end; procedure My_CloseGraph; begin readln; CloseGraph; end; Procedure BildSinus; var i,k,j:word; x,s:real; { Тестовый пpимеp } begin for j:=15 downto 10 do begin for i:=1 to 200 do begin x:=(i-1)*0.1; koor[i,1]:=x; s:=0; for k:=1 to j do s:=s+Sin(x*k); koor[i,2]:=S/j end; bildgr(200,0); end; end; begin GrInastall:=false; end. { файл BildGr.pas } uses BildGraf; var i:word; x:real; begin { Тестовый пpимеp } for i:=1 to 200 do begin x:=i*0.1; koor[i,1]:=x; koor[i,2]:=Sin(x)+Sin(2*x)+Sin(3*x)+Sin(4*x)+Sin(5*x)+Sin(6*x)+Sin(7*x)+ Sin(8*x)+Sin(9*x)+Sin(10*x)+Sin(11*x)+Sin(12*x)+Sin(13*x)+Sin(14*x); end; bildgr(200,64+32+16+8+4); for i:=1 to 200 do begin x:=i*0.1; koor[i,1]:=x; koor[i,2]:=Cos(x)+Cos(2*x); end; bildgr(100,32+16+8+4); for i:=1 to 601 do begin x:=(i-1)*0.05; koor[i,1]:=x; koor[i,2]:=(x-3)*(x-3)/44+x-1; end; bildgr(601,64+32+16+8+4); My_CloseGraph; end.
|
|
HOME |