home *** CD-ROM | disk | FTP | other *** search
/ Hráč 1997 December / Hrac_16_1997-12_cd.bin / PCMANIAK.5 / DATA / PCMANIAK.ORG / ZDRAJAKY / J_SVGA3.PAS < prev   
Pascal/Delphi Source File  |  1997-11-09  |  16KB  |  589 lines
  1. {$I-}
  2. Unit J_SVGA3;
  3.  
  4. Interface
  5.  
  6. uses Graph, mouse, dos;
  7.  
  8. Procedure InitSVGA;
  9. Procedure downSVGA;
  10. Procedure SetFarba(CisloFarby,RC,GC,BC:byte);
  11. procedure loadpcx(nazov:string; x,y:integer; farby: boolean);
  12. procedure loadpcx_FromLeft(nazov:string; x,y:integer; farby: boolean);
  13. procedure loadpcx_FromRight(nazov:string; x,y:integer; farby: boolean);
  14. procedure loadpcx_FromDown(nazov:string; x,y:integer; farby: boolean);
  15. Procedure LoadFont(meno: string; var error: boolean);
  16. Procedure WriteText(x,y:word;Str : String);
  17. procedure set_mouse;
  18. Procedure loadmouse;
  19. procedure mouse_put;
  20. Procedure NastavAktualFarba(f: byte);
  21. Procedure Put_cas(x,y: word);
  22. Procedure Vysviet(x,y, x2,y2: word; farba1, farba2: byte);
  23. Procedure Put_Strana(x,y: word;AK_STR,POCET_STR:byte);
  24. Procedure cistaobrazovka;
  25. Procedure aktualizuj_mouse;
  26. Procedure Put_iFObrazky(x,y: word;cislo:byte);
  27.  
  28. var fdata : array [0..255,0..15] of byte;
  29.     Otext: array[1..200] of string;
  30.     podklad, mys: pointer;
  31.     button, horiz, vert: Word;
  32.     horiz2, vert2: Word;
  33.  
  34.     JE_MYS: boolean;
  35.     Z_mys: boolean;
  36.     First_Time: boolean;
  37.     mys_cursorEnable: boolean;
  38.  
  39.     CENTRALIZE: boolean;
  40.  
  41. implementation
  42.  
  43. procedure VESA256driver; external;
  44. {$L VESA256.OBJ}
  45.  
  46. procedure InitSVGA;
  47. var VESA256, gm : integer;
  48. begin
  49. asm
  50.  mov ah,0
  51.  mov al,13h
  52.  int 10h
  53. end;
  54.  VESA256 := InstallUserDriver('VESA256', @VESA256driver);
  55.  RegisterBGIdriver(@vesa256driver);
  56.  Gm:= 2;
  57.  InitGraph(VESA256, GM, 'data');
  58.  if GraphResult <> grOk then
  59.   begin
  60.     asm
  61.      mov ah,0
  62.      mov al,13h
  63.      int 3h
  64.     end;
  65.     Write('Chyba pri inicializacii grafiky');
  66.     Halt(1);
  67.   end;
  68. end;
  69.  
  70. Procedure WriteText(x,y:word;Str : String);
  71.  
  72. Procedure PisChr(Charr : Char);
  73. var I : Byte;
  74. begin
  75.  For I:=0 to 15 do begin
  76.   SetLineStyle(UserBitLn,FData[Ord(Charr),I],0);
  77.   Line(GetX,GetY+I,GetX+16,GetY+I);
  78.  end;
  79.  SetLineStyle(SolidLn,0,0);
  80. end;
  81.  
  82. var I : Byte;
  83. begin
  84.  MoveTo(X-7,Y);
  85.  For I := 1 to Length(Str) do begin
  86.   PisChr(Str[I]);
  87.   MoveTo(GetX+9,GetY);
  88.  end;
  89. end;
  90.  
  91. Procedure downSVGA;
  92. begin
  93.  closegraph;
  94.  asm
  95.   mov ah, 0
  96.   mov al, 3
  97.   int 10h
  98.  end;
  99. end;
  100.  
  101. Procedure SetFarba(CisloFarby,RC,GC,BC:byte);assembler;
  102. {nastavi jednu farbu}
  103. asm
  104.  mov dx,03c8h
  105.  mov al,CisloFarby
  106.  out dx,al
  107.  mov dx,03c9h
  108.  mov al,RC
  109.  out dx,al
  110.  mov al,GC
  111.  out dx,al
  112.  mov al,BC
  113.  out dx,al
  114. end;
  115.  
  116. procedure loadpcx(nazov:string; x,y:integer; farby: boolean);
  117. var PCX: file;
  118.     buffer: array[0..128] of byte;
  119.     n,pomocna2,pomocna3: integer;
  120.     sirka,vyska, i,j: integer;
  121.     Xsirka, Yvyska: integer;
  122.     RGB: array[1..3] of byte;
  123. begin
  124.  Z_mys:=true;
  125.  putimage(horiz,vert,podklad^,normalput);
  126.  assign(PCX,nazov);
  127.  if farby then begin
  128.                 reset(PCX,1);
  129.                 seek(PCX, filesize(PCX)-768);
  130.                 for pomocna2:=0 to 255 do begin
  131.                                            for pomocna3:=1 to 3 do blockread(PCX,RGB[pomocna3],1);
  132.                                            setfarba(pomocna2,RGB[1] div 4,RGB[2] div 4,RGB[3] div 4);
  133.                                           end;
  134.                 close(PCX);
  135.                end;
  136.  reset(PCX, 128);
  137.  if ioresult<>0 then begin
  138.                       downSVGA;
  139.                       writeln('Chyba pri otvarani suboru ',nazov);
  140.                       halt(2);
  141.                      end;
  142.  blockread(PCX,buffer,1,n);
  143.  sirka:=buffer[8]+buffer[9]*256-(buffer[4]+buffer[5]*256);
  144.  vyska:=buffer[10]+buffer[11]*256-(buffer[6]+buffer[7]*256);
  145.  Xsirka:=0; Yvyska:=0;
  146.  iF CENTRALIZE then
  147.   begin
  148.    x:=(799-sirka) div 2;
  149.    y:=(599-vyska) div 2;
  150.   end;
  151.  repeat
  152.    blockread(PCX,buffer,1,n);
  153.    for i:=0 to 127 do
  154.     begin
  155.       if Xsirka=sirka+1 then
  156.        begin
  157.          inc(Yvyska);
  158.          Xsirka:=0;
  159.          if Yvyska=vyska+1 then
  160.          begin
  161.           getimage(horiz,vert,horiz+10,vert+15,podklad^);
  162.           Close(pcx);
  163.           exit;
  164.          end;
  165.        end;
  166.  
  167.       if buffer[i]<$C1 then begin
  168.                              putpixel(Xsirka+x, Yvyska+y, buffer[i]);
  169.                              inc(Xsirka);
  170.                             end else begin
  171.                                       pomocna2:=buffer[i]-$C1;
  172.                                       inc(i);
  173.                                       if i=128 then begin
  174.                                                      blockread(PCX,buffer,1,n);
  175.                                                      i:=0;
  176.                                                     end;
  177.                                       for j:=0 to pomocna2 do putpixel(Xsirka+x+j, Yvyska+y, buffer[i]);
  178.                                       inc(Xsirka,j+1);
  179.                                      end;
  180.     end;
  181.  until n=0;
  182.  Z_mys:=true;
  183.  close(PCX);
  184.  getimage(horiz,vert,horiz+10,vert+15,podklad^);
  185. end;
  186.  
  187. procedure loadpcx_FromLeft(nazov:string; x,y:integer; farby: boolean);
  188. var PCX: file;
  189.     buffer: array[0..128] of byte;
  190.     n,pomocna2,pomocna3: integer;
  191.     sirka,vyska, i,j, k: integer;
  192.     Xsirka, Yvyska: integer;
  193.     RGB: array[1..3] of byte;
  194. label  EXIT;
  195. begin
  196.  putimage(horiz,vert,podklad^,normalput);
  197.  Z_mys:=true;
  198.  assign(PCX,nazov);
  199.  if farby then begin
  200.                 reset(PCX,1);
  201.                 seek(PCX, filesize(PCX)-768);
  202.                 for pomocna2:=0 to 255 do begin
  203.                                            for pomocna3:=1 to 3 do blockread(PCX,RGB[pomocna3],1);
  204.                                            setfarba(pomocna2,RGB[1] div 4,RGB[2] div 4,RGB[3] div 4);
  205.                                           end;
  206.                 close(PCX);
  207.                end;
  208.  reset(PCX, 128);
  209.  if ioresult<>0 then begin
  210.                       downSVGA;
  211.                       writeln('Chyba pri otvarani suboru ',nazov);
  212.                       halt(2);
  213.                      end;
  214.  blockread(PCX,buffer,1,n);
  215.  sirka:=buffer[8]+buffer[9]*256-(buffer[4]+buffer[5]*256);
  216.  vyska:=buffer[10]+buffer[11]*256-(buffer[6]+buffer[7]*256);
  217.  for k:=sirka downto 0 do
  218.  begin
  219.  close(pcx);
  220.  reset(PCX, 128);
  221.  blockread(PCX,buffer,1,n);
  222.  Xsirka:=0; Yvyska:=0;
  223.  k:=k-6;
  224.  if k<1 then k:=0;
  225.  repeat
  226.    blockread(PCX,buffer,1,n);
  227.    for i:=0 to 127 do
  228.     begin
  229.       if Xsirka=sirka+1 then
  230.        begin
  231.          Yvyska:=Yvyska+1;
  232.          Xsirka:=0;
  233.          if Yvyska=vyska+1 then begin n:=0; goto exit; end;
  234.        end;
  235.  
  236.       if buffer[i]<$C1 then begin
  237.                              if (Xsirka>=k-Xsirka) and (Xsirka-k>=0)  then putpixel(Xsirka+x-k, Yvyska+y, buffer[i]);
  238.                              inc(Xsirka);
  239.                             end;
  240.       if buffer[i]>$C0 then begin
  241.                              pomocna2:=buffer[i]-$C1;
  242.                              inc(i);
  243.                              if i=128 then begin
  244.                                             blockread(PCX,buffer,1,n);
  245.                                             i:=0;
  246.                                            end;
  247.                              for j:=0 to pomocna2 do
  248.                               if (Xsirka+j>=k-Xsirka) and (Xsirka+j-k>=0) then putpixel(Xsirka+x+j-k, Yvyska+y, buffer[i]);
  249.                              Xsirka:=Xsirka+j+1;
  250.                             end;
  251.     end;
  252.  until n=0;
  253.   EXIT:
  254. end;
  255.  close(PCX);
  256.  getimage(horiz,vert,horiz+10,vert+15,podklad^);
  257. end;
  258.  
  259. procedure loadpcx_FromRight(nazov:string; x,y:integer; farby: boolean);
  260. var PCX: file;
  261.     buffer: array[0..128] of byte;
  262.     n,pomocna2,pomocna3: integer;
  263.     sirka,vyska, i,j, k: integer;
  264.     Xsirka, Yvyska: integer;
  265.     RGB: array[1..3] of byte;
  266. label EXIT;
  267. begin
  268.  putimage(horiz,vert,podklad^,normalput);
  269.  Z_mys:=true;
  270.  assign(PCX,nazov);
  271.  if farby then begin
  272.                 reset(PCX,1);
  273.                 seek(PCX, filesize(PCX)-768);
  274.                 for pomocna2:=0 to 255 do begin
  275.                                            for pomocna3:=1 to 3 do blockread(PCX,RGB[pomocna3],1);
  276.                                            setfarba(pomocna2,RGB[1] div 4,RGB[2] div 4,RGB[3] div 4);
  277.                                           end;
  278.                 close(PCX);
  279.                end;
  280.  reset(PCX, 128);
  281.  if ioresult<>0 then begin
  282.                       downSVGA;
  283.                       writeln('Chyba pri otvarani suboru ',nazov);
  284.                       halt(2);
  285.                      end;
  286.  blockread(PCX,buffer,1,n);
  287.  sirka:=buffer[8]+buffer[9]*256-(buffer[4]+buffer[5]*256);
  288.  vyska:=buffer[10]+buffer[11]*256-(buffer[6]+buffer[7]*256);
  289.  Xsirka:=0; Yvyska:=0;
  290. for k:=x downto x-sirka do
  291. begin
  292.  k:=k-6;
  293.  if k<x-sirka then k:=x-sirka;
  294.  close(pcx);
  295.  reset(PCX, 128);
  296.  blockread(PCX,buffer,1,n);
  297.  Xsirka:=0; Yvyska:=0;
  298.  repeat
  299.    blockread(PCX,buffer,1,n);
  300.    for i:=0 to 127 do
  301.     begin
  302.       if Xsirka=sirka+1 then
  303.        begin
  304.          inc(Yvyska);
  305.          Xsirka:=0;
  306.          if Yvyska=vyska+1 then
  307.          begin
  308.            goto exit;
  309.          end;
  310.        end;
  311.  
  312.       if buffer[i]<$C1 then begin
  313.                              if k+xsirka<X then putpixel(Xsirka+k, Yvyska+y, buffer[i]);
  314.                              inc(Xsirka);
  315.                             end else begin
  316.                                       pomocna2:=buffer[i]-$C1;
  317.                                       inc(i);
  318.                                       if i=128 then begin
  319.                                                      blockread(PCX,buffer,1,n);
  320.                                                      i:=0;
  321.                                                     end;
  322.                                       for j:=0 to pomocna2 do if k+xsirka+j<X then putpixel(Xsirka+k+j, Yvyska+y, buffer[i]);
  323.                                       inc(Xsirka,j+1);
  324.                                      end;
  325.     end;
  326.  until n=0;
  327.  EXIT:
  328. end;
  329.  close(PCX);
  330.  getimage(horiz,vert,horiz+10,vert+15,podklad^);
  331. end;
  332.  
  333. procedure loadpcx_FromDown(nazov:string; x,y:integer; farby: boolean);
  334. var PCX: file;
  335.     buffer: array[0..128] of byte;
  336.     n,pomocna2,pomocna3: integer;
  337.     sirka,vyska, i,j, k: integer;
  338.     Xsirka, Yvyska: integer;
  339.     RGB: array[1..3] of byte;
  340. label EXIT;
  341. begin
  342.  putimage(horiz,vert,podklad^,normalput);
  343.  Z_mys:=true;
  344.  assign(PCX,nazov);
  345.  if farby then begin
  346.                 reset(PCX,1);
  347.                 seek(PCX, filesize(PCX)-768);
  348.                 for pomocna2:=0 to 255 do begin
  349.                                            for pomocna3:=1 to 3 do blockread(PCX,RGB[pomocna3],1);
  350.                                            setfarba(pomocna2,RGB[1] div 4,RGB[2] div 4,RGB[3] div 4);
  351.                                           end;
  352.                 close(PCX);
  353.                end;
  354.  reset(PCX, 128);
  355.  if ioresult<>0 then begin
  356.                       downSVGA;
  357.                       writeln('Chyba pri otvarani suboru ',nazov);
  358.                       halt(2);
  359.                      end;
  360.  blockread(PCX,buffer,1,n);
  361.  sirka:=buffer[8]+buffer[9]*256-(buffer[4]+buffer[5]*256);
  362.  vyska:=buffer[10]+buffer[11]*256-(buffer[6]+buffer[7]*256);
  363.  Xsirka:=0; Yvyska:=0;
  364.  x:=(800-sirka) div 2;
  365. for k:=0 to vyska do
  366. begin
  367.  k:=k+6;
  368.  if k>vyska then k:=vyska;
  369.  close(pcx);
  370.  reset(PCX, 128);
  371.  blockread(PCX,buffer,1,n);
  372.  Xsirka:=0; Yvyska:=0;
  373.  repeat
  374.    blockread(PCX,buffer,1,n);
  375.    for i:=0 to 127 do
  376.     begin
  377.       if Xsirka=sirka+1 then
  378.        begin
  379.          inc(Yvyska);
  380.          Xsirka:=0;
  381.          if Yvyska=vyska+1 then
  382.          begin
  383.            goto exit;
  384.          end;
  385.        end;
  386.  
  387.       if buffer[i]<$C1 then begin
  388.                              if Yvyska+y-k<y then putpixel(Xsirka+x, Yvyska+y-k, buffer[i]);
  389.                              inc(Xsirka);
  390.                             end else begin
  391.                                       pomocna2:=buffer[i]-$C1;
  392.                                       inc(i);
  393.                                       if i=128 then begin
  394.                                                      blockread(PCX,buffer,1,n);
  395.                                                      i:=0;
  396.                                                     end;
  397.                                       for j:=0 to pomocna2 do if Yvyska+y-k<y then putpixel(Xsirka+x+j, Yvyska+y-k, buffer[i]);
  398.                                       inc(Xsirka,j+1);
  399.                                      end;
  400.     end;
  401.  until n=0;
  402.  EXIT:
  403. end;
  404.  close(PCX);
  405.  getimage(horiz,vert,horiz+10,vert+15,podklad^);
  406. end;
  407.  
  408. Procedure LoadFont(meno: string; var error: boolean);
  409. var i,j: byte;
  410.     f: file;
  411.     readed: word;
  412. begin
  413.  Assign(f,meno);
  414.  Reset(f,1);
  415.  error:=true;
  416.  if ioresult=0 then
  417.  begin
  418.    blockread(f,FData[0,0],filesize(f),readed);
  419.    Close(f);
  420.    if readed=4096 then error:=false;
  421.  end;
  422. end;
  423.  
  424. Procedure loadmouse;
  425. var si: integer;
  426. begin
  427.  setcolor(255);
  428.  si:=imagesize(0,0,8,15);
  429.  getmem(podklad,si);
  430.  getmem(mys,si);
  431.  {sprosty kurzor mysi --- ALA FUCK JoJo}
  432.  line(0,100,0,113);
  433.  line(1,101,1,112);
  434.  line(2,102,2,111);
  435.  line(3,103,3,112);
  436.  line(4,104,4,114);
  437.  line(5,105,5,115);
  438.  line(6,106,6,109);
  439.  line(6,112,6,115);
  440.  line(7,107,7,108);
  441.  line(8,108,8,108);
  442.  line(7,115,7,115);
  443.  {koniec SPROSTEHO KURZORA mysi -  .... like a monkey }
  444.  getimage(0,100,8,115,mys^);
  445.  clearviewport;
  446. end;
  447.  
  448. procedure set_mouse;
  449. begin
  450.  MouseEnable;
  451.  CursorDisable;
  452.  horizrozsah(789*2,0);
  453.  vertrozsah(599*2,0);
  454.  NastavSour(399, 299);
  455.  Sensimouse(4,4);
  456. end;
  457.  
  458. procedure mouse_put;
  459. begin
  460.  horiz2:=horiz; vert2:=vert;
  461.  CtiStav(button, horiz, vert);
  462.  if (horiz<>horiz2) or (vert<>vert2) or Z_mys then
  463.  begin
  464.   if not Z_mys then putimage(horiz2,vert2,podklad^,normalput);
  465.   getimage(horiz,vert,horiz+10,vert+15,podklad^);
  466.   putimage(horiz,vert,mys^,orput);
  467.   if Z_mys then Z_mys:=false;
  468.  end;
  469. end;
  470.  
  471. Procedure aktualizuj_mouse;
  472. begin
  473.  CtiStav(button, horiz, vert);
  474.  getimage(horiz,vert,horiz+10,vert+15,podklad^);
  475. end;
  476.  
  477. Procedure NastavAktualFarba(f: byte);
  478. begin
  479. setcolor(f);
  480. end;
  481.  
  482. Function ByteString(cislo: byte): string;
  483. var x: string;
  484. begin
  485.  x:='';
  486.  if cislo div 100 <> 0 Then
  487.   begin
  488.    x:=chr(cislo div 100 + 48);
  489.    cislo:=cislo - (cislo div 100)*100;
  490.   end;
  491.  if cislo div 10 <> 0 then
  492.   begin
  493.    x:=x+chr(cislo div 10 + 48);
  494.    cislo:=cislo - (cislo div 10)*10;
  495.   end;
  496.  x:=x+chr(cislo + 48);
  497.  ByteString:=x;
  498. end;
  499.  
  500. Procedure Put_Cas(x,y: word);
  501. var sec100, sec, min,hod: word;
  502.     xx,cas: string;
  503.     i: integer;
  504.     a,b: integer;
  505. begin
  506.  gettime(hod, min, sec, sec100);
  507.  if (first_time) then
  508.   begin
  509.     first_time:=false;
  510.     cas:=ByteString(hod)+':'+ByteString(min);
  511.     if length(ByteString(hod))=1 then cas:=' '+cas;
  512.     if length(ByteString(min))=1 then
  513.     begin
  514.      xx:=cas;
  515.      cas:='';
  516.      for i:=1 to length(xx) do
  517.       if i=length(xx) then
  518.        cas:=cas+'0'+xx[i]
  519.         else cas:=cas+xx[i];
  520.     end;
  521.     for a:=x to x+47 do for b:=y+2 to y+14 do putpixel(a,b,0);
  522.     setcolor(255);
  523.     WriteText(x,y,cas);
  524.     WriteText(x+1,y,cas);
  525.   end;
  526.  if (sec=0) then
  527.   begin
  528.     cas:=ByteString(hod)+':'+ByteString(min);
  529.     if length(ByteString(hod))=1 then cas:=' '+cas;
  530.     if length(ByteString(min))=1 then
  531.     begin
  532.      xx:=cas;
  533.      cas:='';
  534.      for i:=1 to length(xx) do
  535.       if i=length(xx) then
  536.        cas:=cas+'0'+xx[i]
  537.         else cas:=cas+xx[i];
  538.     end;
  539.     for a:=x to x+47 do for b:=y+2 to y+14 do putpixel(a,b,0);
  540.     setcolor(255);
  541.     WriteText(x,y,cas);
  542.     WriteText(x+1,y,cas);
  543.   end;
  544. end;
  545.  
  546. Procedure Vysviet(x,y, x2,y2: word; farba1, farba2: byte);
  547. var a,b: integer;
  548. begin
  549.  putimage(horiz,vert,podklad^,normalput);
  550.  if farba1=1 then
  551.  for a:=x to x2 do
  552.   for b:=y to y2 do
  553.    if getpixel(a,b)=0 then else putpixel(a,b,farba2)
  554.  else
  555.  for a:=x to x2 do
  556.   for b:=y to y2 do
  557.    if getpixel(a,b)=farba1 then putpixel(a,b,farba2);
  558.  getimage(horiz,vert,horiz+10,vert+15,podklad^);
  559. end;
  560.  
  561. Procedure Put_Strana(x,y: word;AK_STR,POCET_STR:byte);
  562. var strany:string;
  563. begin
  564.  strany:=chr(ak_str+49)+'-'+chr(pocet_str+49);
  565.  setcolor(255);
  566.  WriteText(x,y,strany);
  567.   WriteText(x+1,y,strany);
  568. end;
  569.  
  570. Procedure Put_iFObrazky(x,y: word;cislo:byte);
  571. var strany:string;
  572. begin
  573.  setcolor(255);
  574.  WriteText(x,y,chr(cislo+48));
  575.   WriteText(x+1,y,chr(cislo+48));
  576. end;
  577.  
  578. Procedure CistaObrazovka;
  579. begin
  580. clearviewport;
  581. end;
  582.  
  583. begin
  584.  mys_cursorEnable:= true;
  585.  Je_mys:=existmouse;
  586.  First_time:=true;
  587.  Z_mys:=false;
  588.  CENTRALIZE:=FALSE;
  589. end.