'===========================================================================
' Subject: PB MODEX ROUTINES                 Date: Unknown Date           
' Author:  Jonathan Leger                    Code: PB                     
' Origin:  leger@pc2.pc.maricopa.edu       Packet: GRAPHICS.ABC
'===========================================================================
'*********************************
'*** PowerBasic Mode-X Routines **
'*****************************************************
'All routines (except SavePal, LoadPal, and ScrollPal)
'converted by Jonathan Leger from the VGA Trainer
'TurboPascal 6.0 code.
'*******************************************************
'If something doesn't work, or if you have any questions
'or comments about any of these routines (especially if
'you have written some additions to it!!!) _please_ let
'me know.  I read the comp.lang.basic.misc newsgroup
'often, or you can e-mail me at leger@pc2.pc.maricopa.edu
'********************************************************

Declare Sub SetMCGA()       
				'move to 320x200x256c mode
Declare Sub SetText()       
				'go back to 80x25 text mode
Declare Sub ClsMCGA(colr%)  
				'clear the screen with color colr%
Declare Sub SetPixel(x%, y%, colr%)
				'same as PSET
Declare Sub GetPal(colr%, r%, g%, b%)
				'return the RGB color
				'values for color colr%
				'into variables r%, g%, & b%
Declare Sub SetPal(colr%, r%, g%, b%)
				'set the RGB values for colr%
Declare Sub Blackout()      
				'Set all palette entries to RGB 000
Declare Sub SavePal(pal())  
				'Save the palette into an array of
				'p(255, 3) dimensions
Declare Sub LoadPal(pal())  
				'Load the palette to be used from
				'pal()
Declare Sub FadeIn(pal())   
				'Fade from current palette into new
				'palette.  To fade from black into
				'a palette, use SavePal(), then
				'Blackout(), then FadeIn()
Declare Sub FadeOut(pal())  
				'Fade from current palette down to
				'black.
Declare Sub WaitForRetrace()    
				'Waits for verticle retrace to remove
				'flicker/fuzz from display.  To see
				'the effects of this, try taking out
				'WaitForRetrace() in the example program.
Declare Sub CircleMCGA (x%, y%, r%, colr%)
				'draw a circle at x%, y%
				'with radius r% and color colr%
Declare Sub LineMCGA (x1%, y1%, x2%, y2%, colr%)
				'draw a line from (x1,y1) to (x2,y2)
				'with color colr%
Declare Sub ScrollPal (p(), stp, startp, endp)
				'rotate the palette over STP entries
				'starting with entry startp and ending
				'with entry endp.  See main program
				'for an example of how to use this.

$CPU 80386      'For extra speed.  You can change this if
			'you don't have a 386+

DEFINT A-Z


DIM p(255, 3)       'Make some space for the palette

SetMCGA
SavePal p()

colr = 1
for r = 1 to 150
   CircleMCGA 160, 100, r, r
next r
FlipScreen
end

do
  ScrollPal p(), 1, 1, 255
  WaitForRetrace
  LoadPal p()
loop until inkey$ <> ""
end

DEFINT a-z
sub SetMCGA ()
'---------------------------------------------
'--- Go into MCGA (320x200x256) Video Mode ---
'---------------------------------------------
! mov   ax, &h13        ;13h Video Mode (320x200x256)
! int   &h10            ;Bang! We're there.
end sub

DEFINT a-z
sub SetText ()
'-------------------------
'--- Go into text mode ---
'-------------------------
! mov   ax, &h03        ;03h Video Mode (text)
! int   &h10            ;Bang! We're there.
end sub

DEFINT a-z
sub ClsMCGA (colr%)
'------------------------------------------
'--- Clear the screen using color COLR% ---
'------------------------------------------
   Clrs$ = STRING$(32000, colr%)
   def seg = ActivePage%    'MCGA page mem location
   POKE$ 0, Clrs$       'Fill half of screen (160*100 = 32000 bytes)
   POKE$ 32000, Clrs$       'Fill second half of screen
   def seg          'with the specified color.
end sub

DEFINT a-z
sub SetPixel (x%, y%, colr%)
'------------------------------------------------
'--- Set a pixel on the screen (the fast way) ---
'--- (x% = x-co, y% = y-co, colr% = color [0- ---
'--- 255])                    ---
'------------------------------------------------
   def seg = ActivePage%    'MCGA page mem location
   POKE (x%+(y%*320)), colr%    'Set the pixel to colr%
   def seg
end sub

DEFINT a-z
sub GetPal (colr%, r%, g%, b%)
'------------------------------------------------
'--- Reads the red/green/blue values for the  ---
'--- specified color (colr%) and returns them ---
'------------------------------------------------
OUT &h3c7, colr%
r% = INP(&h3c9)
g% = INP(&h3c9)
b% = INP(&h3c9)
end sub

DEFINT a-z
sub SetPal(colr%, r%, g%, b%)
'---------------------------------------------------------
'--- Assign the RGB values for a pallete entry (colr%) ---
'---------------------------------------------------------
OUT &h3c8, colr%
OUT &h3c9, r%
OUT &h3c9, g%
OUT &h3c9, b%
end sub

DEFINT a-z
sub Blackout()
'-----------------------------------------------------------------
'--- Blacks out the screen by setting all palette entries to 0 ---
'-----------------------------------------------------------------
for p = 0 to 255
   SetPal p, 0, 0, 0    'Set each entry to red=0, green=0, blue=0
next p
end sub

DEFINT a-z
sub SavePal(p())
'----------------------------------------------
'--- Stores the palette entries to an array ---
'----------------------------------------------
for p = 0 to 255
   GetPal p, p(p,1), p(p,2), p(p,3)     'Save each entry
next p
end sub

DEFINT a-z
sub LoadPal(p())
'-------------------------------------------------------
'--- Loads the palette with entires in the array P() ---
'-------------------------------------------------------
for p = 0 to 255
   SetPal p, p(p,1), p(p,2), p(p,3)     'Change each entry
next p
end sub

DEFINT a-z
sub FadeIn(p())
'------------------------------
'--- Fade in to palette P() ---
'------------------------------
dim tmp(3)

for p = 1 to 64     'A color value for R/G/B is 0 to 63, so we only
			'need to loop 64 times

   WaitForRetrace   'Keep the program synched with the monitor

   for e = 0 to 255 'Loop once for each palette entry
	   GetPal e, tmp(1), tmp(2), tmp(3)

	   'If the current R/G/B values are lower than they should be,
	   'increase them!
	   if tmp(1) < p(e, 1) then incr tmp(1)
	   if tmp(2) < p(e, 2) then incr tmp(2)
	   if tmp(3) < p(e, 3) then incr tmp(3)

	   'Set the palette to reflect the changes
	   SetPal e, tmp(1), tmp(2), tmp(3)

   next e
next p
end sub

DEFINT a-z
sub FadeOut ()
'-------------------------
'--- Fade out to black ---
'-------------------------
dim tmp(3)

for p = 1 to 64     'A color value for R/G/B is 0 to 63, so we only
			'need to loop 64 times

   WaitForRetrace   'Keep the program synched with the monitor

   for e = 0 to 255 'Loop once for each palette entry
	   GetPal e, tmp(1), tmp(2), tmp(3)

	   'If the current R/G/B values are greater than zero,
	   'decrease them!
	   if tmp(1) > 0 then decr tmp(1)
	   if tmp(2) > 0 then decr tmp(2)
	   if tmp(3) > 0 then decr tmp(3)

	   'Set the palette to reflect the changes
	   SetPal e, tmp(1), tmp(2), tmp(3)

   next e
next p
end sub

DEFINT a-z
sub WaitForRetrace()
'----------------------------------------------------------------------
'--- Wait for verticle retrace before continuing, that way when the ---
'--- screen is changed, no fuzz or flicker occurs.          ---
'----------------------------------------------------------------------
!    mov dx,&h3da
l1:
!    in al,dx
!    and al,&h08
!    jnz l1
l2:
!    in al,dx
!    and al,&h08
!    jz  l2
end sub

DEFINT a-z
sub CircleMCGA (x%, y%, r%, colr%)
'-------------------------------------------------------------
'--- Draw a circle at (x%, y%) with radius r%, color colr% ---
'-------------------------------------------------------------
do
   tx = cint(r%*cos(rad!))
   ty = cint(r%*sin(rad!))
   SetPixel x%+tx, y%+ty, colr%
   rad! = rad! + .006
loop until rad! > 6.4
end sub

defint a-z
sub LineMCGA (x1%, y1%, x2%, y2%, colr%)
'----------------------------------------------------------------
'--- Draw a line from (x1%, y1%) to (x2%, y2%) in color colr% ---
'----------------------------------------------------------------
u% = x2% - x1%
v% = y2% - y1%
d1x = sgn(u%)
d1y = sgn(v%)
d2x = sgn(u%)
d2y = 0
m = abs(u%)
n = abs(v%)

if not(m > n) then
   d2x = 0
   d2y = sgn(v%)
   m = abs(v%)
   n = abs(u%)
end if

s = m / 2

for i = 0 to m
   SetPixel a, b, colr%
   s = s + n
   if not(s < m) then
	  s = s - m
	  a = a + d1x
	  b = b + d1y
   else
	  a = a + d2x
	  b = b + d2y
   end if
next i
end sub

defint a-z
sub ScrollPal (p(), stp, startp, endp)
'-------------------------------------------------------------------
'--- Scroll the palette up one color so that pal(1) = pal(255),  ---
'--- pal(2) = pal(1), pal(3) = pal(2) ... pal(255) = pal(254)    ---
'-------------------------------------------------------------------
incr endp

for cnt = startp to startp+(stp-1)
   for rgb = 1 to 3
	  swap p(cnt, rgb), p((endp+cnt)-stp, rgb)
   next rgb
next cnt

for p = startp+stp to endp
   'Switch all 3 values: red, green, and blue
   for rgb = 1 to 3
	  swap p(p, rgb), p(p-stp, rgb)
   next rgb
next p

'LoadPal(p())   'Make the changes take effect

end sub