'
' Gfxlib Ascii Demo Coded By Shockwave ^ DBF
'
'-------------------------------------------------------------------------------

    Option Static
    Option Explicit
   
'-------------------------------------------------------------------------------
' SET SCREEN MODE
'-------------------------------------------------------------------------------

    Const XR = 640: ' XRES
    Const YR = 480: ' YRES
    windowtitle ""   
    SCREENRES XR , YR , 32 , 2 ,  , 60
    setmouse 0,0,0
'
'176 177 178 219
'


Dim Shared gfxbuffer(80,60) As Ubyte :' Will be used to store the ascii character
Dim Shared ACbuffer(80,60) As Ubyte :' Will be used to store the colour weight in ascii
Dim Shared screenbuffer(160,120):' Will hold the render of the screen to be broken down into 2*2 blocks
Dim Shared GSbuffer(160,120):' Will hold the colour weight in screen.

Declare Sub render()
Declare Sub DB()

'-------------------------------------------------------------------------------
' Init Double Buffering Stuff;
'-------------------------------------------------------------------------------

Dim Shared As Integer workpage,vispage
workpage=0
vispage=1

'-------------------------------------------------------------------------------
' Initialise starfield;
'-------------------------------------------------------------------------------

Dim Shared As Integer a,starnum
starnum = 8000
Dim Shared As Double stx(starnum),sty(starnum),stz(starnum)

For a=1 To starnum
     stx(a)=-3000+Rnd*(6000)
     sty(a)=-3000+Rnd*(6000)
     stz(a)=Rnd*32
Next
Declare Sub stars()
Declare Sub convert()

'-------------------------------------------------------------------------------
' Initialise Window Scroller;
'-------------------------------------------------------------------------------

Dim Shared winscroll As String
winscroll="                                               "
winscroll=winscroll+"THIS LITTLE INTRO IS MY FIRST EVER ASCII / ANSII THING... "
winscroll=winscroll+"AS YOU CAN SEE IT IS QUITE BASIC.. GREETS TO ALL THE GUYZ "
winscroll=winscroll+"ON THIS FORUM, SHOCKWAVE^DBF SIGNING OUT!!!"
winscroll=winscroll+"                                                        "
Dim Shared As Integer winscrollp
Dim Shared As Double oldtime
winscrollp=0
Declare Sub scroller()
'-------------------------------------------------------------------------------
' Main Loop;
'-------------------------------------------------------------------------------
oldtime=Timer
Do
    If timer-oldtime> . 05 Then scroller()
    stars()
    convert()
    render()   
    DB()
   
Loop Until Inkey$=Chr$(27)
End


Sub scroller()
    oldtime=Timer
    WINDOWTITLE "(C) SW^DBF >"+Mid$(winscroll,winscrollp,40)+"<"+"ALT+ENTER FOR FULLSCREEN"
    WINSCROLLP=WINSCROLLP+1
    If winscrollp>len(winscroll)-20 Then winscrollp=0
End Sub

'-------------------------------------------------------------------------------
' Convert Faux screen into ascii;
'-------------------------------------------------------------------------------


Sub convert()
Dim As Integer xx,yy,tally,flx,fly
fly=0
For yy=1 To 118 Step 2
    flx=0
For xx=1 To 158 Step 2
    flx=flx+1
    tally=0
   
    If screenbuffer(xx,yy)     =1 Then tally=tally+1
    If screenbuffer(xx+1,yy)   =1 Then tally=tally+1
    If screenbuffer(xx+1,yy+1) =1 Then tally=tally+1
    If screenbuffer(xx,yy+1)   =1 Then tally=tally+1
   
    If tally=1 Then gfxbuffer(flx,fly)=176
    If tally=2 Then gfxbuffer(flx,fly)=177
    If tally=3 Then gfxbuffer(flx,fly)=178
    If tally=4 Then gfxbuffer(flx,fly)=219
    ACbuffer(flx,fly) = GSbuffer(xx,yy)+GSbuffer(xx+1,yy)+GSbuffer(xx+1,yy+1)+GSbuffer(xx,yy+1)
   
Next
fly=fly+1
Next

End Sub

'-------------------------------------------------------------------------------
' This Will Render The Stars To Our Faux 160 * 120 Screen Ready For Conversion!
'-------------------------------------------------------------------------------

Sub stars()
    Dim As Integer tx,ty
   
    For a=1 To starnum
        tx=(Int(stx(a)/stz(a)))+80
        ty=(Int(sty(a)/stz(a)))+60
       
        If tx>0 And tx<160 And ty>0 And ty<120 Then
            screenbuffer(tx,ty)=1
            gsbuffer(tx,ty)=(Int(-stz(a)+32))*5
        End If       
        stz(a)=stz(a)-.3
        If stz(a)<0 Then
     stx(a)=-3000+Rnd*(6000)
     sty(a)=-3000+Rnd*(6000)
     stz(a)=32
        End If
    Next
End Sub

'-------------------------------------------------------------------------------
' Sub to do Double Buffer;
'-------------------------------------------------------------------------------

Sub DB()
   
    '===============
    '=DOUBLE BUFFER=
    '===============
   
    SCREENSET WORKPAGE,VISPAGE   
    SCREENSYNC
    WORKPAGE  Xor = 1
    VISPAGE  Xor  = 1

End Sub

'-------------------------------------------------------------------------------
' Sub to render the ascii and also empty out the old ascii buffer;
'-------------------------------------------------------------------------------


Sub render()
    Dim As Integer x,y
    For x=2 To 79
        For y=2 To 59

            '===================
            '=Render gfxbuffer;=
            '===================
           
            Color (rgb(ACbuffer(x,y),ACbuffer(x,y),ACbuffer(x,y)))
            Locate y,x
            Print Chr$(gfxbuffer(x,y))
           
            '==================
            '=Clear gfxbuffer;=
            '==================
           
            gfxbuffer(x,y)=0
            ACbuffer(x,y)=0
           
        Next
    Next
    For x=1 To 160
    For y=1 To 120
        screenbuffer(x,y)=0
        GSbuffer(x,y)=0
    Next
    Next
End Sub