home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 18 / CD_ASCQ_18_111294_W.iso / dos / prg / pas / gfxfx / hscroll.pas < prev    next >
Pascal/Delphi Source File  |  1994-06-22  |  3KB  |  147 lines
  1. {$g+}
  2. program mode_x;
  3. { First real Hardware scroll try, by Bas van Gaalen, Holland, PD }
  4. uses crt;
  5. const
  6.   vidseg:word=$a000;
  7.   width:word=0;
  8.   heigth:word=0;
  9.   bytesperline:word=0;
  10. type
  11.   str80=string[40];
  12. var
  13.   txtfile:text;
  14.   txt:array[1..100] of str80;
  15.   virscr:pointer;
  16.   fofs,fseg:word;
  17.  
  18. procedure getfont; assembler; asm
  19.   mov ax,1130h
  20.   mov bh,1
  21.   int 10h
  22.   mov fseg,es
  23.   mov fofs,bp
  24. end;
  25.  
  26. procedure setpal(col,r,g,b:byte); assembler;
  27. asm
  28.   mov dx,03c8h
  29.   mov al,col
  30.   out dx,al
  31.   inc dx
  32.   mov al,r
  33.   out dx,al
  34.   mov al,g
  35.   out dx,al
  36.   mov al,b
  37.   out dx,al
  38. end;
  39.  
  40. procedure settextmode; assembler;
  41. asm
  42.   mov ax,3
  43.   int 10h
  44. end;
  45.  
  46. procedure setmodex; assembler;
  47. asm
  48.   mov ax,0013h
  49.   int 10h
  50.   mov dx,03c4h
  51.   mov ax,0604h
  52.   out dx,ax
  53.   mov ax,0f02h
  54.   out dx,ax
  55.   mov cx,320*200
  56.   mov es,vidseg
  57.   xor ax,ax
  58.   mov di,ax
  59.   rep stosw
  60.   mov dx,03d4h
  61.   mov ax,0014h
  62.   out dx,ax
  63.   mov ax,0e317h
  64.   out dx,ax
  65. end;
  66.  
  67. procedure putpixel(x,y:word; col:byte); assembler;
  68. asm
  69.   mov dx,03c4h
  70.   mov al,2
  71.   mov cx,[x]
  72.   and cx,3
  73.   mov ah,1
  74.   shl ah,cl
  75.   out dx,ax
  76.   mov es,vidseg
  77.   mov ax,80
  78.   mul [y]
  79.   mov dx,[x]
  80.   shr dx,2
  81.   add ax,dx
  82.   mov di,ax
  83.   mov al,[col]
  84.   mov [es:di],al
  85. end;
  86.  
  87. procedure setaddress(ad:word); assembler;
  88. asm
  89.   mov dx,3d4h
  90.   mov al,0ch
  91.   mov ah,[byte(ad)+1]
  92.   out dx,ax
  93.   mov al,0dh
  94.   mov ah,[byte(ad)]
  95.   out dx,ax
  96. end;
  97.  
  98. procedure retrace; assembler;
  99. asm
  100.   mov dx,3dah
  101.  @vert1:
  102.   in al,dx
  103.   test al,8
  104.   jnz @vert1
  105.  @vert2:
  106.   in al,dx
  107.   test al,8
  108.   jz @vert2
  109. end;
  110.  
  111. procedure writeline(nr:byte; sy:word);
  112. var i,j,k:byte;
  113. begin
  114.   for i:=1 to 40 do for j:=0 to 7 do for k:=0 to 7 do
  115.     if ((mem[fseg:fofs+ord(txt[nr][i]) shl 3+j] shl k) and 128) <> 0 then
  116.       putpixel(((i-1) shl 3)+k,sy+j,10) else putpixel(((i-1) shl 3)+k,sy+j,0);
  117. end;
  118.  
  119. var x,y,smty:word; txty:byte;
  120. begin
  121.   setmodex;
  122.   getfont;
  123.   fillchar(txt,sizeof(txt),0);
  124.   assign(txtfile,'hscroll.pas');
  125.   reset(txtfile);
  126.   for y:=1 to 100 do readln(txtfile,txt[y]);
  127.   for x:=1 to 127 do setpal(127+x,128-x div 2,128-x div 2,10);
  128.   for x:=1 to 128 do setpal(x,128-x div 3,128-x div 2,30);
  129.  
  130.   txty:=1; smty:=200;
  131.   repeat
  132.     retrace;
  133.     if (smty mod 8)=0 then begin
  134.       writeline(txty,smty mod 400);
  135.       txty:=1+txty mod 100;
  136.     end;
  137.     setaddress((smty-200)*80);
  138.     inc(smty); if smty>600 then smty:=200;
  139.   until keypressed;
  140.  
  141.   settextmode;
  142. end.
  143.  
  144. { Did work on other computers, not on my own. ;-(
  145.   I guess the ET-4000 has a major bug!
  146.   Or maybe it just aint downwards compatible... }
  147.