home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / grafik / mcgatpu / mcga.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-05-25  |  11.5 KB  |  528 lines
  1. unit mcga;
  2. interface
  3.  
  4. USES Graph,Dos,Crt;
  5.  
  6. const maxx=64;
  7.       maxy=64;
  8.       maxpage=12;
  9.       cr=#13#10;
  10.  
  11. TYPE  ShapeDaten=Array[1..maxx,1..maxy,1..maxpage] of Byte;
  12.       st80=String[40];
  13.       LineBuffer=^OneLine;
  14.       OneLine=RECORD
  15.            Next:LineBuffer;
  16.            Data:Array[0..319] of Byte
  17.           END;
  18.       Buttontype=(Left,Right,None,Midd);
  19.  
  20. const mcgam =$13;
  21.       vgalo =$2d;
  22.       vgamed=$2e;
  23.       vgahi =$2e;
  24.       vgamax=$30;
  25.       apa   =$0d;       {320*200 Grafik mit 8 Seiten}
  26.       text  =$03;
  27.       mono  =$03;
  28.  
  29. var     x,y,n         : Integer;
  30.     VgaColor,r,g,b: Byte;
  31.     regs          : Registers;
  32.     Shapes        : ShapeDaten;
  33.     f             : file of word;
  34.     Meldung       : st80;
  35.     page          : byte;  {Bezieht sich auf Shapedatenfelder}
  36.     col,gpage     : byte;  {In 256 Farbmodi nur Hintergrundfarbe}
  37.     txt           : string;
  38.     ch            : char;
  39.     lastx,lasty   : Word;
  40.     Buffer,Merker : LineBuffer;
  41.     Button        : Buttontype;{aktuelle Maustaste}
  42.     a             : POINTER;
  43.     bytesperrow   : integer;
  44.  
  45. procedure ClearScreen;
  46. procedure screenorigin(x,y:word);
  47. procedure printpixelat(color:byte;column,row:word);
  48. function  getpixelat(Column,Row:word):byte;
  49. procedure line(x1,y1,x2,y2:word;col:byte);
  50. procedure setcrsr(x,y:integer);
  51. procedure outtextxy(x,y:integer;text:st80;color:byte);
  52. procedure ClrShapes;
  53. procedure savescreen(x1,y1,x2,y2:word;Name:String);
  54. procedure LoadScreen(xn,yn:integer;Name:String);
  55. procedure Save(dateiname:string);
  56. procedure Load(dateiname:string);
  57. procedure Screen_into_Buffer;
  58. procedure Buffer_into_Screen;
  59. procedure SetMode(mode:byte);
  60. function  GetMode:byte;
  61. procedure PrintPalette;
  62. procedure SetIndividualPalette(Reg,r,g,b:byte);
  63. procedure Raute(x1,y1,x2,y2:integer;col:byte);
  64. procedure Ellipse(mx,my,a,b:Integer;col:Byte);
  65. procedure MoveScreen(x1,y1,x2,y2,xd,yd:integer;move:boolean);
  66. procedure Copyin(x1,y1:Integer;var Feld:Shapedaten;Page:ShortInt);
  67. procedure Copyout(x1,y1:Integer;var Feld:Shapedaten;Page:ShortInt);
  68. procedure ShiftLeft(var feld:Shapedaten;Page:ShortInt);
  69. procedure ShiftRight(var feld:Shapedaten;Page:ShortInt);
  70. procedure ShiftUp(var feld:Shapedaten;Page:ShortInt);
  71. procedure ShiftDown(var feld:Shapedaten;Page:ShortInt);
  72. procedure Copy (var feld:Shapedaten; Source,Dest:ShortInt);
  73. procedure ShapeSave(feld:Shapedaten;Start,SEnd:byte;Name:String);
  74. procedure ShapeLoad(var feld:Shapedaten;Name:String);
  75. procedure Box(x1,y1,x2,y2:integer;col:Byte);
  76. procedure GetMousePos (var x,y:Integer;var Button:ButtonType);
  77. procedure SetMousePos (x,y:Integer);
  78. procedure GraphMouse;
  79. procedure HideMouse;
  80. procedure ShowMouse;
  81.  
  82.  
  83. IMPLEMENTATION
  84. {$l d:\object\mcgatool}
  85. {$l d:\object\screen}
  86. {$f+}
  87. procedure ClearScreen;external;
  88. procedure printpixelat(color:byte;column,row:word);external;
  89. function  getpixelat(Column,Row:word):byte;external;
  90. procedure line(x1,y1,x2,y2:word;col:byte);external;
  91. procedure screenorigin(x,y:word);external;
  92. {$f-}
  93.  
  94. procedure data;
  95. begin
  96.  inline($ff / $f3 /  {Beginn der UND- Verknüpfung}
  97.         $ff / $f3 /
  98.         $ff / $ff /
  99.         $ff / $ff /
  100.         $ff / $ff /
  101.         $ff / $ff /
  102.         $ff / $ff /
  103.         $ff / $ff /
  104.         $ff / $ff /
  105.         $ff / $ff /
  106.         $ff / $ff /
  107.         $ff / $ff /
  108.         $ff / $ff /
  109.         $ff / $ff /
  110.         $ff / $ff /
  111.         $ff / $ff /
  112.         $00 / $00 /  {Beginn der R- Verknüpfung}
  113.         $00 / $00 /
  114.         $00 / $00 /
  115.         $00 / $00 /
  116.         $00 / $00 /
  117.         $00 / $00 /
  118.         $00 / $00 /
  119.         $00 / $00 /
  120.         $00 / $00 /
  121.         $00 / $00 /
  122.         $00 / $00 /
  123.         $00 / $00 /
  124.         $00 / $00 /
  125.         $00 / $00 /
  126.         $00 / $00 /
  127.         $00 / $00 )
  128. end;
  129. procedure graphmouse;
  130. begin
  131.  with regs do begin
  132.   ax:=0;
  133.   intr($33,regs);
  134.   if ah=0 then begin
  135.    setmode(mono);
  136.    writeln('Es ist ein nicht behebbarer Fehler aufgetreten.',#13#10,
  137.            'Es ist kein Maustreiber installiert.');
  138.    readln;
  139.    halt
  140.   end;
  141.  
  142.   ax:=$7;
  143.   cx:=1;
  144.   dx:=639;
  145.   intr($33,regs);
  146.  
  147.   ax:=$8;
  148.   cx:=1;
  149.   dx:=199;
  150.   intr($33,regs);
  151.  
  152.   ax:=$9;
  153.   bx:=3;
  154.   cx:=0;
  155.   es:=seg(mcga.data);
  156.   dx:=ofs(mcga.data)+10;
  157.   intr($33,regs)
  158.  end;
  159.   showmouse
  160. end;
  161.  
  162. procedure GetMousePos (var x,y:Integer;var Button:ButtonType);
  163. var mousekey:ShortInt;
  164. begin
  165.  button:=none;
  166.  
  167.  regs.ax:=3;
  168.  intr($33,regs);
  169.  x:=regs.cx;
  170.  y:=regs.dx;
  171.  
  172.  mousekey:=regs.bx;
  173.  
  174.  if (mousekey and 1)=1 then button:=left;
  175.  if (mousekey and 2)=2 then button:=right;
  176.  if (mousekey and 4)=4 then button:=midd
  177. end;
  178.  
  179. procedure  SetMousePos (x,y:Integer);
  180. begin
  181.  regs.ax:=4;
  182.  regs.dx:=y;
  183.  regs.cx:=x;
  184.  intr($33,regs)
  185. end;
  186.  
  187. procedure hidemouse;
  188. begin
  189.  with regs do begin
  190.   ax:=$2;
  191.   intr($33,regs)
  192.  end
  193. end;
  194.  
  195. procedure showmouse;
  196. begin
  197.  with regs do begin
  198.   ax:=$1;
  199.   intr($33,regs)
  200.  end
  201. end;
  202.  
  203. procedure setcrsr(x,y:integer);
  204. var regs:registers;
  205. begin
  206.  if (x>79) or (y>24) then exit;
  207.  regs.ah:=$02;
  208.  regs.bh:=gpage;
  209.  regs.dh:=y;
  210.  regs.dl:=x;
  211.  intr($10,regs)
  212. end;
  213.  
  214. procedure outtextxy(x,y:integer;text:st80;color:byte);
  215. var n:shortint;
  216.     a,b:integer;
  217.  
  218.     {Schreibt einen Text im aktuellen Grafikmodus an eine Position}
  219.  
  220. begin
  221.    for n:=1 to length(text) do begin
  222.     setcrsr(x,y);
  223.    with regs do begin
  224.     al:=ord(text[n]);
  225.     bh:=gpage;
  226.     bl:=color;
  227.     cx:=$1;
  228.     ah:=$9;
  229.     intr($10,regs);
  230.     inc(x);
  231.    end
  232.   end
  233. end;
  234.  
  235. PROCEDURE ClrShapes;
  236.      {Loescht das Shapedatenfeld}
  237. VAR x,y,z : ShortInt;
  238. BEGIN
  239.    FOR x:=1 TO 64 DO
  240.     FOR y:=1 TO 64 DO
  241.      FOR z:=1 TO 12 DO Shapes[x,y,z]:=0
  242. END;
  243. procedure Screen_into_Buffer;
  244. begin
  245.     getmem(a,$ffff);
  246.     move(mem[$a000:0000],a^,$ffff);
  247. end;
  248.  
  249. procedure Buffer_into_Screen;
  250. begin
  251.     move(a^,mem[$a000:$0000],$ffff);
  252.     freemem(a,$ffff)
  253. end;
  254.  
  255. procedure savescreen(x1,y1,x2,y2:word;Name:String);
  256. var  x,y,n:word;
  257.      m:byte;
  258.      data,temp:word;
  259.       {Speichern eines beliebigen Bildschirmbereichs
  260.        Dateiformat:
  261.               WORDS 0-4 Koordinaten des Bereichs.
  262.               Der REST jeweils 1 WORD = 2 Farbpixel}
  263.  
  264. begin
  265.   assign(f,name);
  266.   rewrite(f);
  267.    write(f,x1,y1,x2,y2);   {Koordinaten merken}
  268.    for x:=x1 to x2 do
  269.     for y:=y1 to y2 do begin
  270.      data:=getpixelat(x,y);
  271.      data:=data shl 8;
  272.      temp:=getpixelat(x,y+1);
  273.      data:=data or temp;
  274.      write(f,data);
  275.      inc(y);
  276.      if y>y2 then y:=y2
  277.     end;
  278.   close(f)
  279. end;
  280.  
  281. procedure LoadScreen(xn,yn:integer;Name:String);
  282. var  x,y,x1,y1,x2,y2,n :word;
  283.      data :word;
  284.      {Laden eines Bildausschnitts an eine Position}
  285. begin
  286.   assign(f,name);
  287.   reset(f);
  288.    read(f,x1,y1,x2,y2);   {Koordinaten merken}
  289.  
  290.    for x:=x1 to x2 do
  291.     for y:=y1 to y2 do begin
  292.      read(f,data);
  293.      printpixelat(data,x,y+1);
  294.      data:=data shr 8;
  295.      printpixelat(data,x,y);
  296.      inc(y);
  297.      if y>y2 then y:=y2
  298.     end;
  299.   close(f)
  300. end;
  301.  
  302. Procedure Save(dateiname:string);
  303.      {VIDEO RAM Modus 13h sichern}
  304. var f:file;
  305. BEGIN
  306.    Assign(f,dateiname);
  307.    Rewrite(f,1);
  308.    BlockWrite(f,mem[$a000:0],$fa00);
  309.    Close(f);
  310. END;
  311.  
  312. Procedure Load(dateiname:string);
  313.      {VIDEO RAM Modus 13h mit Dateiinhalt fuellen}
  314. var f:file;
  315. BEGIN
  316.    assign(f,dateiname);
  317.    Reset(f,1);
  318.    BlockRead(f,mem[$a000:0],$fa00);
  319.    Close(f);
  320. END;
  321.  
  322. Procedure SetMode(mode:byte);
  323. Begin
  324.       regs.ah:=0;
  325.       regs.al:=mode;
  326.       intr($10,regs)
  327. End;
  328.  
  329. function getmode:byte;
  330. begin
  331.  regs.ah:=$f;
  332.  intr($10,regs);
  333.  getmode:=regs.al
  334. end;
  335.  
  336. procedure printpalette;
  337. var x,y : integer;
  338.     col : byte;
  339.  
  340. PROCEDURE colorrec(colnum:Byte);
  341. var x1,y1:integer;
  342. begin
  343.    FOR x1:=75+x*10 to 84+x*10 do
  344.     FOR y1:=1+y*10 to 10+y*10 do
  345.      printpixelat(colnum,x1,y1)
  346. END;
  347.  
  348. BEGIN
  349.    col:=0;
  350.    for x:=0 to 19 do
  351.     for y:=0 to 9 do begin
  352.      colorrec(col);
  353.      inc(col)
  354.     end
  355. end;
  356.  
  357.  
  358. Procedure SetIndividualPalette(Reg,r,g,b:byte);
  359. BEGIN
  360.       regs.ah:=$10;
  361.       regs.al:=$10;
  362.       regs.dh:=r;
  363.       regs.ch:=g;
  364.       regs.cl:=b;
  365.       regs.bx:=reg;
  366.       intr($10,regs)
  367. END;
  368.  
  369.  
  370.  
  371. procedure box(x1,y1,x2,y2:integer;col:Byte);
  372. begin
  373.    line(x1,y1,x2,y1,col);
  374.    line(x1,y1,x1,y2,col);
  375.    line(x2,y1,x2,y2,col);
  376.    line(x1,y2,x2,y2,col);
  377. end;
  378.  
  379. procedure raute(x1,y1,x2,y2:integer;col:byte);
  380. begin
  381.    line(x1,y1,x2,y2,col);
  382.    line(x1,y1,x2,y1+y1-y2,col);
  383.    line(x2+x2-x1,y1,x2,y2,col);
  384.    line(x2+x2-x1,y1,x2,y1+y1-y2,col)
  385. end;
  386.  
  387.  
  388. Procedure Ellipse(mx,my,a,b:Integer;col:Byte);
  389. var x,y : integer;
  390.     qr1,qr2,dx,dy,da:Real;
  391. begin
  392.  
  393.   x:=0;
  394.   y:=b;
  395.   qr1:=2*a*a; qr2:=2*b*b;
  396.   dx:=1;dy:=qr1*b-1;
  397.   da:=int(dy/2);
  398.   repeat
  399.    printpixelat(col,mx+x,my+y);
  400.    printpixelat(col,mx+x,my-y);
  401.    printpixelat(col,mx-x,my+y);
  402.    printpixelat(col,mx-x,my-y);
  403.    if da >= 0 then
  404.     begin
  405.      da:=da-dx-1;
  406.      dx:=dx+qr2;
  407.      x:=succ(x);
  408.     end
  409.    else
  410.     begin
  411.     da:=da+dy-1;
  412.     dy:=dy-qr1;
  413.     y:=pred(y);
  414.     end;
  415.   until y<0;
  416. end;
  417.  
  418. procedure movescreen(x1,y1,x2,y2,xd,yd:integer;move:boolean);
  419. var x,y:integer;
  420.     data:byte;
  421. begin
  422.   x:=0;
  423.   y:=0;
  424.   box(x1,y1,x2,y2,0);
  425.   for y:=y1 to y2 do
  426.    for x:=x1 to x2 do begin
  427.       data:=getpixelat(x,y);
  428.       if move then printpixelat(0,x,y);
  429.       printpixelat(data,xd+x-x1,yd+y-y1)
  430.    end
  431. end;
  432.  
  433. procedure copyin(x1,y1:Integer;var Feld:Shapedaten;Page:ShortInt);
  434. var x,y :integer;
  435. begin
  436.     for x:=1 to maxx do
  437.      for y:=1 to maxy do FELD[x,y,page]:=GetPixelAt(x1+x,y+y1)
  438. end;
  439.  
  440. procedure copyout(x1,y1:Integer;var Feld:Shapedaten;Page:ShortInt);
  441. var x,y :integer;
  442. begin
  443.     for x:=1 to maxx do
  444.      for y:=1 to maxy do printpixelat(feld[x,y,page],x+x1,y+y1)
  445. end;
  446.  
  447. procedure shiftleft(var feld:Shapedaten;Page:ShortInt);
  448. var x,y:Integer;
  449.     buffer:array[1..64]of byte;
  450. begin
  451.     for y:=1 to maxy do buffer[y]:=feld[1,y,page];
  452.      for x:=1 to maxx do
  453.      for y:=1 to maxy do feld[x,y,page]:=feld[x+1,y,page];
  454.     for y:=1 to maxy do feld[maxx,y,page]:=buffer[y]
  455. end;
  456.  
  457. procedure shiftright(var feld:Shapedaten;Page:ShortInt);
  458. var x,y:Integer;
  459.     buffer:array[1..64]of byte;
  460. begin
  461.     for y:=1 to maxy do buffer[y]:=feld[maxx,y,page];
  462.      for x:=maxx downto 1 do
  463.      for y:=maxy downto 1 do feld[x,y,page]:=feld[x-1,y,page];
  464.     for y:=1 to maxy do feld[1,y,page]:=buffer[y]
  465. end;
  466.  
  467. procedure shiftup(var feld:Shapedaten;Page:ShortInt);
  468. var x,y:Integer;
  469.     buffer:array[1..64]of byte;
  470. begin
  471.     for x:=1 to maxx do buffer[x]:=feld[x,1,page];
  472.      for x:=1 to maxx do
  473.      for y:=1 to maxy do feld[x,y,page]:=feld[x,y+1,page];
  474.     for x:=1 to maxx do feld[x,maxy,page]:=buffer[x]
  475. end;
  476.  
  477. procedure shiftdown(var feld:Shapedaten;Page:ShortInt);
  478. var x,y:Integer;
  479.     buffer:array[1..64]of byte;
  480. begin
  481.     for x:=1 to maxx do buffer[x]:=feld[x,maxy,page];
  482.      for x:=maxx downto 1 do
  483.      for y:=maxy downto 1 do feld[x,y,page]:=feld[x,y-1,page];
  484.     for x:=1 to maxx do feld[x,1,page]:=buffer[x]
  485. end;
  486.  
  487. procedure copy (var feld:Shapedaten; Source,Dest:ShortInt);
  488. var x,y:Integer;
  489. begin
  490.   for x:=1 to maxx do
  491.    for y:=1 to maxy do feld[x,y,dest]:=feld[x,y,source]
  492. end;
  493.  
  494. procedure Shapesave(feld:Shapedaten;Start,SEnd:byte;Name:String);
  495. var x,y,z : Integer;
  496.     f : file of byte;
  497. begin
  498.      assign(f,name);
  499.      rewrite(f);
  500.  
  501.     write(f,start,send);
  502.  
  503.       for x:=1 to maxx do
  504.        for y:=1 to maxy do
  505.     for z:=Start to sEnd do write(f,feld[x,y,z]);
  506.  
  507.      close(f)
  508. end;
  509. procedure Shapeload(var feld:Shapedaten;Name:String);
  510. var x,y,z : Integer;
  511.     f : file of byte;
  512.     start, send : byte;
  513. begin
  514.      assign(f,name);
  515.      rewrite(f);
  516.     read(f,start,send);
  517.       for x:=1 to maxx do
  518.        for y:=1 to maxy do
  519.     for z:=Start to sEnd do read(f,feld[x,y,z]);
  520.      close(f)
  521. end;
  522. BEGIN
  523.  bytesperrow:=80
  524. END.
  525.  
  526.  
  527.  
  528.