home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / bs_hwscr.zip / HSCROLL.PAS < prev    next >
Pascal/Delphi Source File  |  1993-04-18  |  15KB  |  570 lines
  1. {*****************************************************************************
  2.  example 
  3.  
  4.  Hardware Scroll in Tweaked Video Mode 320*200*256*4
  5.  Scroll uses * Start Adress Register to perform scroll.
  6.              * Input Status Port for Vertical Retrace.
  7.              * Logical Screen Width to alter the screen width.
  8.              * PCX-pictures for the fonts (thx the GFX Man or make
  9.                some yourself...)
  10.              * Independ width for the fonts, this means that your're able to
  11.                put logo's in the scroll , let's say 200 pixels or more large,
  12.                and max 50 in height.But you propably be able to do better... .
  13.  
  14. ******************************************************************************}
  15.  
  16. {$G+,S-,L-,R-}
  17. uses Crt;
  18. const   Crtadress:word=$3d4;
  19.         Inputstatus:word=$3DA;
  20. Type    ColorValue = Record R,G,B: Byte; End;
  21.         Palette    = Array [0..255] Of ColorValue;
  22.  
  23. var as,ao,cs,co,bs,bo:word;
  24.     tp,tp1,tp2:pointer;
  25.     P:palette;
  26.  
  27. {$I example.hdw}  {include text}
  28.  
  29. Procedure LoadPcxbuf(Fname:String;var as,ao:word;var q:palette);
  30. Const
  31.   DataBuffer = $2800;                                      { 10K Data Buffer Area}
  32. type
  33.     Pal        = array[0..767] of byte;
  34.  
  35. Var
  36.   ScrOff,Buf,HowMany : LongInt;                            { Decompress Variables }
  37.   PcxBuffer : Array[1..DataBuffer] Of Byte;                { Declare DataBuffer Size }
  38.   RGBs : Array[0..767] of Byte;                            { Temp Colour Palette Storage }
  39.   DataByte : Byte;                                         { Current Byte Being Processed }
  40.   NumRead : Word;                                          { Temporary Variable }
  41.   F : File;                                                { File Variable }
  42.   p:Pal;
  43.  
  44. Procedure MoveIt(SSeg,SOfs,TSeg,TOfs,L: Word);
  45. Begin
  46.  Asm
  47.   cld
  48.   push  ds
  49.   mov   si,SOfs
  50.   mov   di,TOfs
  51.   mov   cx,l
  52.   mov   es,[tseg]
  53.   mov   ds,[sseg]
  54.   shr   cx,1
  55.   rep  movsw
  56.   jnb  @even
  57.   movsb
  58. @even:
  59.   pop ds
  60.  End;
  61. End;
  62.  
  63.  
  64. procedure Fillarea(as,ao,l,color:word);assembler;
  65. Asm
  66.     push es
  67.     mov  es,[as]               { Point es to screen segment }
  68.     mov  di,ao
  69.     mov  ax,color
  70.     mov  cx,l
  71.     cld
  72.     rep  stosb               { use a fast 8088 instruction to store al }
  73. @even:
  74.     pop  es
  75. end;
  76.  
  77.  
  78. Procedure ShiftPcxPalette(var p:pal);
  79. var loop:integer;
  80. Begin
  81.   For Loop:=0 To 767 Do p[Loop]:=RGBs[Loop] SHR 2;      { Helps Set Colours Correctly }
  82. End;
  83.  
  84. Procedure FillBuffer;
  85. Begin
  86.   If (Buf> DataBuffer) Then                             { Refresh Buffer ? }
  87.   Begin
  88.     Buf:=1;
  89.     BlockRead(F,PcxBuffer,SizeOf(PcxBuffer),NumRead);    { Read Chunk Of Data From .Pcx File }
  90.   End;
  91.   DataByte:=PcxBuffer[Buf];                             { Take A Byte From The Buffer }
  92.   Inc(Buf,1);
  93. End;
  94.  
  95. Begin
  96.   Assign(F,FName+'.pcx');
  97.   Reset(F,1);                                              { Use records with length 1}
  98.   Seek(F,128);                                             { Ignore .Pcx Header }
  99.   HowMany:=0;  ScrOff:=0;
  100.   Buf:=DataBuffer + 1;
  101.   While (ScrOff < $fa00) Do
  102.   Begin
  103.     FillBuffer;
  104.     HowMany:=1;                                            { Contiguous Bytes Set To 1 }
  105.     If (DataByte AND $C0) = $C0 Then                       { If DataByte's Top 2 Bits Are 1 }
  106.     Begin
  107.       HowMany:=DataByte AND $3F;                           { It's An RLE (Run Length Encoded) Byte }
  108.       FillBuffer;                                          { Refresh Buffer If Need Be }
  109.     End;
  110.     Fillarea(AS,AO+ScrOff,HowMany,DataByte);          { Write DataByte(s) Directly To Video Memory }
  111.     Inc(ScrOff,HowMany);                                   { Increase Video Memory OffSet }
  112.   End;
  113.   Seek(F,FileSize(F) - 768);
  114.   BlockRead(F,RGBs,SizeOf(RGBs),NumRead);
  115.   ShiftPcxPalette(p);
  116.   Close(F);
  117.   Moveit(seg(p),ofs(p),seg(q),ofs(q),768)
  118. End;
  119.  
  120.  
  121. procedure Fntoffs;assembler;
  122. Asm     {Font height is 50, offset the first word, the width is the second word }
  123.         {offset 48260 = not defined (black pix)!! }
  124.         DW 18092,0018; {! : 33}
  125.         DW 48260,0010; {" : 34}
  126.         DW 48260,0010; {# : 35}
  127.         DW 48260,0010; {  : 36}
  128.         DW 48260,0010; {% : 37}
  129.         DW 18050,0035; {& : 38}
  130.         DW 35690,0020; {' : 39}
  131.         DW 48260,0010; {( : 40}
  132.         DW 48260,0010; {) : 41}
  133.         DW 18020,0020; {* : 42}
  134.         DW 18115,0020; {+ : 43}
  135.         DW 17920,0021; {, : 44}
  136.         DW 18141,0030; {- : 45}
  137.         DW 17941,0020; {. : 46}
  138.         DW 35560,0035; {/ : 47}
  139.  
  140.         DW 19235,0030; {0 : 48}
  141.         DW 00640,0030; {1 : 49}
  142.         DW 00673,0030; {2 : 50}
  143.         DW 00713,0030; {3 : 51}
  144.         DW 00752,0030; {4 : 52}
  145.         DW 00788,0030; {5 : 53}
  146.         DW 00825,0030; {6 : 54}
  147.         DW 00861,0030; {7 : 55}
  148.         DW 00897,0030; {8 : 56}
  149.         DW 19200,0030; {9 : 57}
  150.  
  151.  
  152.         DW 17960,0018; {: : 58}
  153.         DW 17983,0018; {; : 59}
  154.         DW 35607,0030; {< : 60}
  155.         DW 18177,0030; {= : 61}
  156.         DW 35653,0030; {> : 62}
  157.         DW 35520,0030; {? : 63}
  158.         DW 48260,0010; {@ : 64}
  159.  
  160.  
  161.         DW 03850,0025; {A : 65}
  162.         DW 03879,0025; {B}
  163.         DW 03908,0025; {C}
  164.         DW 03937,0025; {D}
  165.         DW 03966,0025; {E}
  166.         DW 03995,0022; {F}
  167.         DW 04022,0024; {G}
  168.         DW 04052,0021; {H}
  169.         DW 04082,0020; {I}
  170.         DW 04102,0022; {J}
  171.         DW 04128,0025; {K}
  172.         DW 22410,0024; {L}
  173.         DW 22439,0026; {M}
  174.         DW 22475,0022; {N}
  175.         DW 22504,0024; {O}
  176.         DW 22535,0024; {P}
  177.         DW 22562,0028; {Q}
  178.         DW 22595,0026; {R}
  179.         DW 22627,0022; {S}
  180.         DW 22655,0021; {T}
  181.         DW 22687,0026; {U}
  182.  
  183.         DW 00001,0028; {V}
  184.         DW 00033,0040; {W}
  185.         DW 00080,0025; {X}
  186.         DW 00113,0024; {Y}
  187.         DW 00145,0025; {Z}
  188. end;
  189.  
  190. PROCEDURE SetGraph;
  191. BEGIN
  192.  
  193.  ASM            {Let us see if we have a color or a monochorme display?}
  194.    MOV DX,3CCh
  195.    IN AL,DX
  196.    TEST AL,1    {Is it a color display?    }
  197.    MOV CX,3DAh
  198.    MOV DX,3D4h
  199.    JNZ @L1      {Yes  }
  200.    MOV DX,3B4h  {No  }
  201.    MOV CX,3BAh
  202.   @L1:
  203.    MOV CRTAdress,DX
  204.    MOV Inputstatus,CX
  205.     MOV AX,0013h   {Use BIOS to set graphic mode 13H (320x200x256)   }
  206.     INT 10h
  207.     MOV DX,03C4h   {Select memory-mode-register at sequencer port    }
  208.     MOV AL,04
  209.     OUT DX,AL
  210.     INC DX         {Read in data via the according data register     }
  211.     IN  AL,DX
  212.     AND AL,0F7h    { $F7=11110111B bit 3:=0 -> don't chain planes }
  213.     OR  AL,04      { $04=00000100B bit 2:=1 -> no odd/even-scheme }
  214.     OUT DX,AL      {Activate new settings... .}
  215.     MOV DX,03C4h   {Enable the map-mask for planing}
  216.     MOV AL,02
  217.     OUT DX,AL
  218.     INC DX
  219.     MOV AL,0Fh     { $0F=00001111B ...and allow access to all 4 bit maps            }
  220.     OUT DX,AL
  221.     MOV AX,0A000h  {Starting in segment A000h, set 8000h logical     }
  222.     MOV ES,AX      {Words = 4*8000h physical words (because of 4     }
  223.     SUB DI,DI      {Bitplanes) to 0                                  }
  224.     MOV AX,DI
  225.     MOV CX,8000h
  226.     CLD
  227.     REP STOSW
  228.  
  229.     MOV DX,CRTAdress  {Address the underline-location-register at   }
  230.     MOV AL,14h        {The CRT-controller port, read out the according  }
  231.     OUT DX,AL         {Data register:                                   }
  232.     INC DX
  233.     IN  AL,DX
  234.     AND AL,0BFh    { $BF=10111111B bit 6:=0 -> disable double word addressing}
  235.     OUT DX,AL      {Video ram                                        }
  236.     DEC DX
  237.     MOV AL,17h     {Select mode control register                     }
  238.     OUT DX,AL
  239.     INC DX
  240.     IN  AL,DX
  241.     OR  AL,40h     { $40=01000000B bit 6:=1 -> address memory as a linear bit array  }
  242.     OUT DX,AL
  243.  END;
  244. END;
  245.  
  246. Procedure SetHPages(P: Byte);assembler;
  247. asm
  248.    mov   ax,40
  249.    mov   bl,p           {p*40 ex. 160 words or 4 pages from 80 bytes hor.}
  250.    mul   bl
  251.    mov   dx,Crtadress
  252.    mov   ah,al
  253.    mov   al,$13
  254.    out   dx,ax
  255. end;
  256.  
  257. Procedure Pan(X,Y: Word);assembler;
  258. asm
  259.     mov    bx,320
  260.     mov    ax,y
  261.     mul    bx
  262.     add    ax,x
  263.     push   ax
  264.     pop    bx
  265.     mov    dx,INPUTSTATUS
  266. @WaitDE:
  267.     in     al,dx
  268.     test   al,01h
  269.     jnz    @WaitDE       {display enable is active?}
  270.     mov    dx,Crtadress
  271.     mov    al,$0C
  272.     mov    ah,bh
  273.  
  274.     out    dx,ax
  275.     mov    al,$0D
  276.     mov    ah,bl
  277.     out    dx,ax
  278.     MOV    dx,inputstatus
  279. @wait:
  280.     in      al,dx
  281.     test    al,8                    {?End Vertical Retrace?}
  282.     jz     @wait
  283.  
  284. End;
  285.  
  286.  
  287. Procedure Movescrtopage(SSeg,SOfs,TOFS: Word);assembler;
  288. Asm           {Put the scroll on in vram (out of screen) plane 0 1 2 3 }
  289.   push   ds
  290.   cld
  291.   mov   si,SOfs
  292.   add   Tofs,150*320+80
  293.   mov   di,TOfs
  294.   mov   ax,$0A000
  295.   mov   es,ax
  296.   mov   ds,[sseg]
  297.   mov   dx,$3c4
  298.   mov   al,02
  299.   out   dx,al
  300.   inc   dx
  301.  
  302.   mov   cx,50
  303.   in    al,dx
  304.   and   al,11110000B           {Do not affect the other bit settings}
  305.   or    al,1                   {This not really necesary! ex. mov  al,01}
  306.   out   dx,al                  {                              out  dx,al}
  307. @plane0:
  308.   lodsb
  309.   or   al,al
  310.   jnz   @j0
  311.   mov   ax,cx
  312. @j0:
  313.   stosb
  314.   add   di,319
  315.   add   si,319
  316.   loop  @plane0
  317.  
  318.   inc   sofs
  319.   mov   si,SOfs
  320.   mov   di,TOfs
  321.  
  322.   mov   cx,50
  323.   in    al,dx
  324.   and   al,11110000B
  325.   or    al,2
  326.   out   dx,al
  327. @plane1:
  328.   lodsb
  329.   or   al,al
  330.   jnz   @j1
  331.   mov   ax,cx
  332. @j1:
  333.   stosb
  334.   add   di,319
  335.   add   si,319
  336.   loop  @plane1
  337.  
  338.   inc   sofs
  339.   mov   si,SOfs
  340.   mov   di,TOfs
  341.  
  342.   mov   cx,50
  343.   in    al,dx
  344.   and   al,11110000B
  345.   or    al,4
  346.   out   dx,al
  347. @plane2:
  348.   lodsb
  349.   or    al,al
  350.   jnz   @j2
  351.   mov   ax,cx
  352. @j2:
  353.   stosb
  354.   add   di,319
  355.   add   si,319
  356.   loop  @plane2
  357.  
  358.   inc   sofs
  359.   mov   si,SOfs
  360.   mov   di,TOfs
  361.  
  362.   mov   cx,50
  363.   in    al,dx
  364.   and   al,11110000B
  365.   or    al,8
  366.   out   dx,al
  367. @plane3:
  368.   lodsb
  369.   or    al,al
  370.   jnz   @j3
  371.   mov   ax,cx
  372. @j3:
  373.   stosb
  374.   add   di,319
  375.   add   si,319
  376.   loop  @plane3
  377.  
  378.   pop  ds
  379. End;
  380.  
  381. function Keypressed:boolean;assembler;
  382. Asm
  383.    mov   ah,01
  384.    int   $16            {Read keyboard buffer status}
  385.    jz    @false         {No keystroke}
  386.    mov   al,1
  387.    jmp   @true
  388. @false:
  389.    mov  al,0
  390. @true:
  391. end;
  392.  
  393.  
  394. procedure Dohscroll;
  395. const Blankpos :word=8;
  396.       Page0    :word=0;
  397.       Page1    :word=80;
  398.       Page2    :word=160;
  399.       Page3    :word=240;
  400.  
  401. var y:integer;
  402.     zs,tmp:word;
  403.     Winxpos,Winypos,Font,let,Hblank:word;
  404.     Yhlp:integer;
  405.  
  406. begin
  407.  Yhlp:=-1;
  408.  Winypos:=50;
  409.  let:=0;
  410.  repeat
  411.      Asm
  412.         mov  ax,maxtxt
  413.         cmp  let,ax
  414.         jle  @nope
  415.         mov  let,0
  416.      @nope:                                   {Avoid the overflow of the text buffer.}
  417.         cmp  winxpos,240
  418.         jl   @exit                            {Scroll on page 0 - 1 - 2 and 3 }
  419.         mov  winxpos,0
  420.      @exit:
  421.      end;
  422.  
  423.      y:=txt[let];
  424.  
  425.      if y<15 then                          {Thx the GFX-man for this}
  426.      begin                                   {greate confusion!!}
  427.           as:=cs;                            {First fonts he ever made, see the}
  428.           ao:=co;                            {result the coder has to do all the shit!}
  429.      end
  430.      else if y<25 then
  431.           begin
  432.                as:=bs;
  433.                ao:=bo;
  434.           end
  435.           else if y>52 then
  436.                begin
  437.                     as:=cs;
  438.                     ao:=co;
  439.                end
  440.                else if y<32 then
  441.                     begin
  442.                          as:=cs;
  443.                          ao:=co;
  444.                     end
  445.                     else
  446.                         begin
  447.                            as:=seg(tp^);
  448.                            ao:=ofs(tp^);
  449.                         end;
  450.  
  451.      Asm
  452.         push  ds
  453.         mov   cx,font
  454.         mov   ax,seg fntoffs
  455.         mov   ds,ax
  456.         mov   si,offset fntoffs
  457.         mov   ax,y
  458.         shl   ax,2     {*4}
  459.         add   si,ax
  460.         inc   si
  461.         inc   si       {-2b = 1W get the length of the current font.}
  462.         lodsw
  463.         cmp   ax,cx
  464.         jg    @nonext
  465.         mov   tmp,0
  466.         jmp   @exit
  467. @nonext:
  468.         mov  tmp,1
  469. @exit:
  470.         sub   si,4
  471.         lodsw
  472.         sub   ax,4
  473.         mov   zs,ax              {zs:=offset fntoffs[txt[let]]}
  474.         pop   ds
  475.           cmp   y,250
  476.           jle   @exit2
  477.           mov   zs,48250         {A Black font on the pic... .}
  478.           mov   font,0
  479.           mov   ax,hblank
  480.           or    ax,ax
  481.           jnz   @selse
  482.           add   ax,blankpos
  483.           mov   hblank,ax
  484.           inc   let
  485.           jmp   @exit3
  486.        @selse:
  487.           dec   hblank
  488.           jmp   @exit3
  489.        @exit2:
  490.           mov  ax,tmp
  491.           or   ax,ax
  492.           jnz  @selse2
  493.           mov  font,0
  494.           inc  let
  495.           jmp  @exit3
  496.        @selse2:
  497.           add  font,4
  498.        @exit3:
  499.      end;
  500.      if Winxpos>Page2 then Movescrtopage(as,ao+zs+Font,Winxpos-Page3);
  501.      Movescrtopage(as,ao+zs+Font,Winxpos);
  502.      Pan(Winxpos,Winypos);
  503.      inc(Winxpos);
  504.      inc(Winypos,Yhlp);
  505.      if (Winypos>=150)  or (Winypos<=1)then Yhlp:=-Yhlp;
  506.  until Keypressed;
  507. end;
  508.  
  509.  
  510. Procedure SetVGApalette(Var tp: Palette);
  511. var Sofs:word;
  512. begin
  513.      Sofs:=ofs(tp);
  514. Asm
  515.   mov si,Sofs
  516.   xor ax,ax
  517.   mov cx,3*256
  518.   mov dx,$03c8
  519.   out dx,al
  520.   inc dx
  521.   rep outsb
  522.   end;
  523. End;
  524.  
  525.  
  526. procedure arrangepal;
  527. var tel:byte;
  528. begin
  529.     p[128]:=p[128];                        {Bizarr neh??}
  530.     for tel:=1 to 50 do With p[tel] do     {Make background}
  531.     begin
  532.          r:=tel;
  533.          b:=tel;
  534.          g:=tel;
  535.     end;
  536. end;
  537.  
  538.  
  539. begin
  540.     Getmem(tp,$fa00);
  541.     Getmem(tp1,$fa00);
  542.     Getmem(tp2,$fa00);                    {Reserve memory for fonts..}
  543.  
  544.     as:=seg(tp^);ao:=ofs(tp^);
  545.     bs:=seg(tp1^);bo:=ofs(tp1^);
  546.     cs:=seg(tp2^);co:=ofs(tp2^);          {Get adresses for fast access}
  547.  
  548.     Fillchar(p,Sizeof(p),0);              {Clear palette to reduce flicker while}
  549.     SetVGApalette(p);                     {Setting up GFX mode}
  550.     Setgraph;                             {Set unchained VGA mode}
  551.     Fillchar(p,Sizeof(p),0);
  552.     Setvgapalette(p);
  553.  
  554.     Sethpages(4);                         {Set logical screen with at 160 words, }
  555.                                           {Or Set 4 Horz. pages}
  556.  
  557.     Loadpcxbuf('multv-',cs,co,p);
  558.     Loadpcxbuf('cijf',bs,bo,p);
  559.     Loadpcxbuf('multa-u',as,ao,p);        {Load the pix in mem}
  560.  
  561.     Arrangepal;                           {Fix the color palette... .}
  562.  
  563.     Setvgapalette(p);                     {Set the color palette}
  564.  
  565.     Dohscroll;                            {Run the Hardware scrolly... .}
  566.  
  567.     textmode (lastmode);                  {Warping back to DOS.}
  568. end.
  569.  
  570.