Ascii 3d Starfield
Original post in FreeBASIC Forums
''There's a code challenge to code the best ascii demo effect in Freebasic going on over at the dbf/gvy forum, so I made a 3D starfield out of ascii, it's the first ever ascii text demo I've made. Here's the code.''
'
' 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