Crazy Delerium source.

[Shockwave]

An old routine I didn't do anything with....

Code: [Select]


'Crazy Delerium.
'By Shockwave
'

'--------------------------------------------------------------------------

            OPTION STATIC
            OPTION EXPLICIT
            Print "PRECALCULATING"
'-------------------------------------------------------------------------
'Please ditch the defs below, they are for the shit fps counter.
'Benchmark reading when nothing is happening is;
'
'-------------------------------------------------------------------------
        declare sub millisecs()
        DIM SHARED AS DOUBLE oldtime,newtime
        dim shared ticks,t as integer
       
'-------------------------------------------------------------------------
' The stuff below is needed to set up the circles;
'-------------------------------------------------------------------------
       
        declare sub dcircle(BYVAL CX AS INTEGER , BYVAL CY AS INTEGER , BYVAL R AS INTEGER, BYVAL CLR AS INTEGER)
        declare sub generate()       
        Dim Shared As uInteger Buffer( 640 * 480 ):  ' Screen Buffer. (or your texture buffer)
        Dim Shared As ubyte C_Buffer( 1280 * 1280 ):' Circles Buffer.
        dim shared as Uinteger C_Palette(512): ' Circles Palette.
       
        declare sub Make_circle_palette()
        declare sub render_delerium1(BYVAL XCX AS uINTEGER , BYVAL XCY AS uINTEGER)
        declare sub render_delerium2(BYVAL XCX AS uINTEGER , BYVAL XCY AS uINTEGER)
        dim shared cwobble as integer
        MAKE_CIRCLE_PALETTE()
        GENERATE()

'-------------------------------------------------------------------------
' Includes.
'-------------------------------------------------------------------------
            '#define PTC_WIN
            #Include Once "tinyptc.bi"

'-------------------------------------------------------------------------
' Open Screen;
'-------------------------------------------------------------------------

        If( ptc_open( "FAST DELERIUM", 640, 480 ) = 0 ) Then
        End -1
        End If
   
'-------------------------------------------------------------------------
' Main Loop;
'-------------------------------------------------------------------------

DIM SHARED GADD AS INTEGER

    DO
       
       
       
    gadd=gadd+1
   
    render_delerium1(320+200*sin(gadd/33),420+200*sin(gadd/63))
    render_delerium2(320+200*sin(gadd/43),420+200*sin(gadd/53))
   
   
    millisecs()
    ptc_update@buffer(0)   
    ticks=ticks+1 :' <-- Ditch this (FPS Counter)
   
    LOOP UNTIL INKEY$ = CHR$(27)


'-------------------------------------------------------------------------
' Make some nice colours!.
'-------------------------------------------------------------------------

sub make_circle_palette()
    dim as integer a
    dim as double RD,GR,BL
    RD=0
    GR=0
    BL=0   
    FOR A=1 TO 250
       
        If A<125 and RD<250 then RD=RD+2.1
        if A<125 AND GR<250 then GR=GR+2.2
        if A<125 and BL<250 then BL=BL+2.3       
       
        If A>=125 and RD>3 then RD=RD-2.4
        if A>=125 AND GR>3 then GR=GR-2.3
        if A>=125 and BL>3 then BL=BL-2.2       

       
        C_palette(A) = RGB (int(RD),int(GR),int(BL))
    NEXT

FOR A=251 TO 500
       
        If A<375 and RD<249 then RD=RD+2.3
        if A<375 AND GR<249 then GR=GR+2.2
        if A<375 and BL<249 then BL=BL+2.1       
       
        If A>=375 and RD>6 then RD=RD-2.4
        if A>=375 AND GR>6 then GR=GR-2.3
        if A>=375 and BL>6 then BL=BL-3.2       

       
        C_palette(A) = RGB (int(RD),int(GR),int(BL))
    NEXT

end sub


'-------------------------------------------------------------------------
' Render 1st circle set, clearing the buffer as we go.
'-------------------------------------------------------------------------

sub render_delerium1(BYVAL XCX AS uINTEGER , BYVAL XCY AS uINTEGER)
    dim as uinteger x,y,xrs,yrs,bpos,ppos,yppre1,yppre2
   
   cwobble=cwobble+5
    ' 573
    for y=0 to 479       
        yppre1 = 640*y
        yppre2 = (1280*(y+XCY))+(16+15*sin((y+cwobble))/163)
    for x=0 to 639
        bpos=yppre1+x
        ppos=yppre2+(x+XCX)
        buffer(bpos) = C_buffer(ppos)       
    next
    next
       
end sub

'-------------------------------------------------------------------------
' Render 2nd circle set and convert buffer to colours
'-------------------------------------------------------------------------

sub render_delerium2(BYVAL XCX AS uINTEGER , BYVAL XCY AS uINTEGER)
    dim as uinteger x,y,xrs,yrs,bpos,ppos,yppre1,yppre2
   
   
   
    for y=0 to 479       
        yppre1 = 640*y
        yppre2 = (1280*(y+XCY))+(50+49*sin((y+cwobble)/53))
    for x=0 to 639
        bpos=YPPRE1+x
        ppos=YPPRE2+(x+XCX)
        buffer(bpos) = C_PALETTE(buffer(bpos) + C_buffer(ppos))
    next
    next
       
end sub

'-------------------------------------------------------------------------
' Circle routine;
'-------------------------------------------------------------------------

SUB dCIRCLE(BYVAL CX AS INTEGER , BYVAL CY AS INTEGER , BYVAL R AS INTEGER, BYVAL CLR AS INTEGER)
DIM  as integer r2,cc,loopy,ww,l
r2=r*r
cc=-r
for loopy = cc to r       
        ww = Sqr(r2-loopy*loopy)
        for l = CX-ww to CX+ww                   
                       C_buffer((1280*(loopy+CY))+l)=CLR                   
        next   
       
next
END SUB

'-------------------------------------------------------------------------
' Create circle pattern
'-------------------------------------------------------------------------

sub GENERATE()
    dim rr,lame,ccl as integer
    lame=0
        ccl=0
        for rr=639 to 1 step-1
        dcircle (640,640,rr,ccl)
        if lame = 0 then ccl = ccl+1
        if lame = 1 then ccl = ccl-1
        if ccl>=250 then lame=1
        if ccl<=2 then lame=0
        next
END SUB

'-------------------------------------------------------------------------
' Shit FPS Counter, discard.
'-------------------------------------------------------------------------

SUB Millisecs()
    dim as double t   
    t=timer
if  t-oldtime >=1 then
    newtime = ticks
    ticks=0
    oldtime=timer
    print str( (newtime) )               
end if   
end sub


[rdc]

Cool one man.

[Shockwave]

Cheers Rick, it's old but kind of funky!