Topics

1

Projects / Annual 20

« on: June 09, 2007 »

Hiya!

Today 20 years ago i made my first 'real' C64 (Demo). Thats the reason i made something new. It's noting spectacular, just basic stuff (except the (ripped) music). It includes the original one as a hidden part. To see the part you need a real machine with a connected Datasette (Yeah ).
It works on CCS but sound emulation is incorrect and it doesn't works on Vice. 

Now i'll grab a beer and watch some good old C64 Demos.

Cheers 
Røly

2

Freebasic / Stars With Camera (ez)

« on: May 17, 2006 »

Original post from Clyde, taken from the ezboard forum


Here's an adaption of Thygrions BB source example of "Stars With Camera" converted to Freebasic using GFXLib.

And Im quite suprised in the difference in executable sizes. Over TinyPtc / gfx lib. Later I will modify and post serperately a tinyPTC version. Im guessing that gfx lib has more functionality included with it, to be producing the larger compiled exe size. UPXing results in compressing to half what ever the end result is.

Another thing it shows how simplish it is to convert over your BB source codes to FB.

Hope its of some benefit and use, so here goes:

 

Code: [Select]

'
' Stars with Camera
' Original BB Source by Thrygrion..
' FB adaption by Clyde Radcliffe April 06.
'

Chdir Exepath
Option Static
Option Explicit

Const XRES=640
Const YRES=480

Randomize Timer

Const PI = 3.141593

Const MAXSTARS=25000

Dim Shared ScreenBuffer As UByte Ptr

Dim Shared As Double StarX( MAXSTARS ), StarY( MAXSTARS ), StarZ( MAXSTARS ), StarZV( MAXSTARS )
Dim Shared RGBScreen( XRES, YRES )

Dim Shared move     As Double = .05
Dim Shared damping  As Double = .99
Dim Shared zoom     As Double = 5

Dim Shared camx     As Double= 0
Dim Shared camy     As Double= 0
Dim Shared camz     As Double= 0
Dim Shared camxv    As Double= 0
Dim Shared camyv    As Double= 0

Declare Sub InitializeStars()
Declare Sub StarPositions( ByVal StarNo )
Declare Sub RunStars()
Declare Sub RenderScreen( Buffer As UByte Ptr )
Declare Sub UpdateStars()

InitializeStars()
RunStars()
End

Sub InitializeStars()
   
    Dim i
   
    ScreenRes XRES,YRES,32,1,1
    ScreenSet 1,0
   
    SetMouse ,,0
   
    ScreenBuffer = screenptr()
   
   
    For i = 1 To MAXSTARS
       
        StarPositions(i)
       
    Next
   
End Sub


Sub RunStars()
   
    Dim Key As String
   
    While Key<>Chr(27)
       
        Key=Inkey()
       
        UpdateStars()

        ScreenLock()
            RenderScreen( ScreenBuffer )
        ScreenUnlock()
       
        'ScreenCopy()
       
    Wend
   
   
End Sub


Sub StarPositions( ByVal StarNo )
   
    StarX( StarNo ) = (Rnd(1)*2000)-1000 ')
    StarY( StarNo ) = (Rnd(1)*2000)-1000 ')
    StarZ( StarNo ) = (Rnd(1)*2000)-1000 ')
       
    StarZV( StarNo ) = Rnd(1)*5.0

End Sub


Sub RenderScreen( Buffer As UByte Ptr)

    Dim PosX, PosY

    For PosY=1 to YRES-1
        for PosX=1 to XRES-1
       
             Poke Integer, Buffer+( (PosY)*XRES+(PosX)) Shl 2, RGBScreen( PosX, PosY )
           
             RGBScreen( PosX, PosY )=0

        Next
    Next

End Sub


Sub UpdateStars()
   
    Dim i
   
    Dim As Double cx,sx,cy,sy,cz,sz
    Dim As Double sxsx, sxsy
   
    Dim As Double m00,m01,m02
    Dim As Double m10,m11,m12
    Dim As Double m20,m21,m22
   
    Dim As Double cxsx, cxsy
   
    Dim As Double tx, ty, tz
    Dim As Double rx,ry,rz
    Dim As Double nx,ny
   
    Dim As Double c,c2,c3
    Dim As Double ARGB2, ARGB3
   
    cx = Cos(camx * PI/180.00 )
    sx = Sin(camx * PI/180.00 )
    cy = Cos(camy * PI/180.00 )
    sy = Sin(camy * PI/180.00 )

        cz = Cos(camz * PI/180.00 )
        sz = Sin(camz * PI/180.00 )
       
        sxsy = cdbl(sx * sy)
        cxsy = cdbl(cx * sy)

        m00 = cdbl( cy * cz)
        m01 = cdbl(-cy * sz)
        m02 = sy

        m10 = cdbl(cx * sz) + cdbl(sxsy * cz)
        m11 = cdbl(cx * cz) - cdbl(sxsy * sz)
        m12 = cdbl(-sx * cy)

        m20 = cdbl(sx * sz) - cdbl(cxsy * cz)
        m21 = cdbl(sx * cz) + cdbl(cxsy * sz)
        m22 = cdbl(cx * cy)

        For i = 1 To MAXSTARS
   
            starz(i) = starz(i) - starzv(i)
   
            tx = starx(i)
        ty = stary(i)
        tz = starz(i)
       
                rx = cdbl(tx * m00) + cdbl(ty * m10) + cdbl(tz * m20)
        ry = cdbl(tx * m01) + cdbl(ty * m11) + cdbl(tz * m21)
        rz = cdbl(tx * m02) + cdbl(ty * m12) + cdbl(tz * m22)
       
                nx = (( cdbl(rx / rz) * 100) * zoom) + (XRES Shr 1)
        ny = ((-cdbl(ry / rz) * 100) * zoom) + (YRES Shr 1)
       
                If starz(i) <= -1000 then
                       starpositions(i)
            starz(i) = 1000
       
                ElseIf nx> 1 And nx <XRES  - 2 And ny > 1 And ny < YRES - 2 And rz > 0 And rz <= 1000 then
               
                        c  = 255 * csng(1.0 - csng(rz / 1000.0))
            c2 = c * .66
            c3 = c * .33
           
                        argb2 = (c2 Shl 16) + (c2 Shl 8)  + c2
            argb3 = (c3 Shl 16) + (c3 Shl 8)  + c3
           
            RGBScreen( nx, ny )=( c shl 16 ) or ( c shl 8 ) or c
           
            RGBScreen( nx-1,ny) =argb2
            RGBScreen( nx+1,ny) =argb2
           
            RGBScreen( nx,ny-1)=argb2
            RGBScreen( nx,ny+1)=argb2
           
            RGBScreen( nx-2,ny)=argb3
            RGBScreen( nx+2,ny)=argb3
           
            RGBScreen( nx,ny-2)=argb3
            RGBScreen( nx,ny+2)=argb3
       
        EndIf
        Next
   
    camx = camx + .25
    camy = camy + .5
    camz = camz + .25

End Sub

rbraz

Stars With Camera Work fine here, but a bit slowly.

3

Freebasic / Bobs (ez)

« on: May 17, 2006 »

Original post from Shockwave, taken from the ezboard forum


Mainly for the benefit of those who are trying to learn this language like me, I decided to have a go at making bobs in FB with tinyPCT, since the only way is pixelwise, here's a program with a hard coded bob routine with clipping.

 

Code: [Select]

' Hard Coded Bob Starfield
' Entirely Using TintPCT.
' Small Exe And A Rough Example Of A Way To Do A Bob Routine Of Sorts.
' Hopefully This Will Become An Intro Maybe.
'
' By Shockwave / DBF 2006
'
'*** Only 12.5kb When Crunched!!!!!! ***
'
'-------------------------------------------------------------------------

'-------------------------------------------------------------------------
' Includes.
'-------------------------------------------------------------------------

        #Include Once "tinyptc.bi"

'-------------------------------------------------------------------------
' Open 640 X 480 Screen.
'-------------------------------------------------------------------------

        If( ptc_open( "Stars", 640, 480 ) = 0 ) Then
        End -1
        End If
   
'-------------------------------------------------------------------------
' Variable Definitions.
'-------------------------------------------------------------------------
        Dim Shared LP As Integer: ' Used In Loops.
        Dim Shared As Integer Buffer( 640 * 480 ):' Screen Buffer.
        DIM SHARED AS INTEGER CPAL (255):' Holds Palette.
        Dim Shared GADD As Integer:' General Purpose Variable Just Ticks Up.
        Dim Shared SMSIN As DOUBLE:' Holds X Movement.
        DIM SHARED SMCOS As DOUBLE:' Holds Y Movement.
        DIM SHARED ZMCOS As DOUBLE:' Holds Z Movement.
        DIM SHARED STPTR AS INTEGER:' Pointer Used When Looping Through Stars.
        DIM SHARED STST AS INTEGER:' Holds Deepest Star Pos.
        DIM SHARED A AS INTEGER:' Holds Colour Multiplier.
       
        '--------------------------
        ' Read In Our Star Bobs;---
        '--------------------------
       
        dim shared BOB (36*4) AS INTEGER
        FOR LP=1 TO (36*3)
            READ BOB(LP)
        NEXT
       
'-------------------------------------------------------------------------
' Subroutine Definitions.
'-------------------------------------------------------------------------
        Declare Sub STARFIELD()
        DECLARE SUB DRAWBOB (BYVAL BX AS INTEGER , BYVAL BY AS INTEGER , BYVAL BNM AS INTEGER , BYVAL CL AS INTEGER)
        Declare Sub Clearscreen()
       
'----------------------------
'---    Set Up Starfield; ---
'----------------------------

        Dim Shared STARS As Integer:' Holds Max Number Of Stars
        Dim Shared INZP As Double:' Used When Defining Stars To Hold ZP
        Dim Shared INZPA As Double:' Used When Defining Stars (ZP Increment)
        Dim Shared TX AS INTEGER:' Holds Translated Star X
        Dim Shared TY As Integer:' Holds Translated Star Y
       
        STARS = 2000:' How Many Stars?
       
        DIM SHARED STX (1 TO STARS) AS DOUBLE: ' Hold X Pos Of Star
        DIM SHARED STY (1 TO STARS) AS DOUBLE: ' Hold Y Pos Of Star
        DIM SHARED STZ (1 TO STARS) AS DOUBLE: ' Hold Z Pos Of Star
        INZP=30:' Initial Z = 0.
        INZPA = 30 / STARS:' Calculate Increment.
        STPTR=1:' Holds Star Number During Starfield Sub Loop.
        STST=1:' Used To Store Starting Star (deepest).
        For LP = 1 To Stars
            STX (LP) = ((RND(1) * 20000)-10000 )
            STY (LP) = ((RND(1) * 20000)-10000 )
            STZ (LP) = INZP
            INZP=INZP-INZPA
        next
       
        '-----------------------
        ' Generate A Palette;---
        '-----------------------
       
        DIM SHARED R1,G1,B1 AS integer
        FOR LP=1 TO 255
            CPAL(LP) =RGB(R1,G1,B1)
            IF R1<255 THEN R1=R1+3
            IF G1<255 THEN G1=G1+2
            IF B1<255 THEN B1=B1+1
           
        NEXT LP

'--------------------------------------------------
'---    Main Loop, Repeat Until Escape Pressed. ---
'--------------------------------------------------

DO
   
       
    Clearscreen():' Clear The Screen.
    STARFIELD():' Do The Starfield.
   
    '----------------------------
    ' Draw White Lines On Screen;
    '----------------------------
   
    FOR LP = 0 TO 639
        Buffer ((50*640)+LP)=RGB (255,155,55)
        Buffer ((430*640)+LP)=RGB (255,155,55)
    NEXT
   
    Ptc_Update @Buffer(0):' Update The Buffer.
   
LOOP UNTIL INKEY$ = CHR$(27)
Ptc_Close()
END


'---------------------------------------
'---    MULTI DIRECTIONAL STARFIELD. ---
'---------------------------------------

SUB STARFIELD()
    GADD=GADD+1
   
    '---------------
    ' Movements; ---
    '---------------
   
    SMSIN=30*SIN(GADD/470)
    SMCOS=40*COS(GADD/777)
    ZMCOS=0.1*COS(GADD/907)
   
    '---------------------------
    ' Get Deepest Star First;---
    '---------------------------
   
    STPTR=STST
   
    for LP = 1 To STARS
       
        '---------------------------------
        ' Translate Star To 2D Co-Ords ---
        '---------------------------------
       
        TX = INT((STX(STPTR) / STZ(STPTR))+320)
        TY = INT((STY(STPTR) / STZ(STPTR))+240)
       
        '--------------------
        ' Is It Onscreen? ---
        '--------------------
       
        if TX>-5 and TX<639 AND TY>-5 And TY<479 THEN
           
            '--------------------------------
            ' Calculate Colour Multiplier;---
            '--------------------------------
           
            A=INT(-STZ(STPTR) + 32)
            '-------------------------------------
            ' Draw Bob Size According To Depth;---
            '-------------------------------------
            IF STZ(STPTR) < 10 THEN DRAWBOB (TX,TY,3,A)
            IF STZ(STPTR >= 10) AND (STZ(STPTR) <20 ) THEN DRAWBOB (TX,TY,2,A)
            IF STZ(STPTR) >= 20 THEN DRAWBOB (TX,TY,1,A)
        ENDIF
       
        '---------------
        ' Move Star; ---
        '---------------
       
        STX(STPTR)=STX(STPTR)+SMSIN
        STY(STPTR)=STY(STPTR)+SMCOS
        STZ(STPTR)=STZ(STPTR)+ZMCOS
       
        '------------------
        ' Bounds Checks;---
        '------------------
        ' X Checks;
        IF SMSIN>0 THEN
            IF STX(STPTR)>=10000 THEN STX(STPTR)=STX(STPTR)-20000
        ENDIF
        IF SMSIN<0 THEN
            IF STX(STPTR)<=-10000 THEN STX(STPTR)=STX(STPTR)+20000
        ENDIF
        ' Y Checks;
        IF SMCOS>0 THEN
            IF STY(STPTR)>=10000 THEN STY(STPTR)=STY(STPTR)-20000
        ENDIF
        IF SMCOS<0 THEN
            IF STY(STPTR)<=-10000 THEN STY(STPTR)=STY(STPTR)+20000
        ENDIF
        ' Z Checks;
        IF ZMCOS>0 THEN
            IF STZ(STPTR)>=30 THEN STZ(STPTR)=STZ(STPTR)-30
            STST=STST-1
            IF STST<1 THEN STST=STARS
        ENDIF
        IF ZMCOS<0 THEN
            IF STZ(STPTR)<=0 THEN STZ(STPTR)=STZ(STPTR)+30
            STST=STST+1
            IF STST>STARS THEN STST=1
           
        ENDIF
        STPTR=STPTR+1:' Update Pointer.
        IF STPTR>STARS THEN STPTR=1:'Bounds Check.
    next
   
   
END SUB

'-------------------------------------------------------------------------
' Sub To Draw A Bob Anywhere On The Screen;
'-------------------------------------------------------------------------

SUB DRAWBOB (BYVAL BX AS INTEGER , BYVAL BY AS INTEGER, BYVAL BNM AS INTEGER , BYVAL CL AS INTEGER)
   
    DIM BLX , BLY AS INTEGER
   
    '-------------------------------------
    ' Shit Code To Set Offset In Bob Bank;
    '-------------------------------------
   
    IF BNM=1 THEN BM=0
    IF BNM=2 THEN BM=36
    IF BNM=3 THEN BM=72
   
    FOR BLY=0 TO 5
    FOR BLX=1 TO 6
        '---------
        'CLIPPING;
        '---------
        IF (BX+BLX>0) AND (BX+BLX<639) AND (BY+BLY>0) AND (BY+BLY<479) THEN
            '-------------
            'COLOUR VALUE;
            '-------------
            if (by+BLY> 50) and (by+bly<430) then
                MM= (BOB(((BLY*6)+BLX)+BM))*CL
            else
                MM= ((BOB(((BLY*6)+BLX)+BM))*CL) shr 1
            endif
            '------------------
            'DRAW PIXEL OF BOB;
            '------------------
            IF MM >0 THEN BUFFER (((BY+BLY)*640)+BX+BLX)=CPAL(MM)
        END IF
    NEXT
    NEXT

END SUB

'--------------------------------------------------------
' Clear Out Old Screen Buffer With Our Fake "Copperlist"
'--------------------------------------------------------

Sub ClearScreen()
Dim i as integer
for i = 0 to 640*480
    IF i <640*50 or i>640*430 then
    Buffer(i) = &h100401
    else
    Buffer(i) = h100000
    endif
next
End Sub

'--------------------------------------------------------
' Our "Bobs"
' 0's are not blitted.
' The Higher The Number, The Brighter The Pixel.
'--------------------------------------------------------

'small;
data 0,0,1,1,0,0
data 0,1,2,2,1,0
data 1,1,0,5,2,1
data 1,2,3,0,2,1
data 0,1,2,1,1,0
data 0,0,1,1,0,0
'middle;
data 0,1,2,2,1,0
data 1,1,0,2,3,1
data 2,0,1,7,2,2
data 2,3,0,1,0,2
data 1,3,3,0,1,1
data 0,1,2,2,1,0
'close;
data 0,1,2,3,1,0
data 1,0,0,3,4,1
data 2,2,0,9,3,3
data 3,3,1,0,0,2
data 1,0,3,2,0,1
data 0,1,3,2,1,0

Clyde Radcliffe

Bobs Nice one mate

5H0CKW4VE

Thanks Clyde, I got some text done as well now and I posted it in a new topic. Hope it helps some people.

rbraz

Bobs Nice effect and colors dude

4

Freebasic / FPS Limiter (ez)

« on: May 17, 2006 »

Original post from Rbraz, taken from the ezboard forum

This is a code that I'm using to limit the max fps in C++/OGL and now converted it to FB, it use a high performance counter (QueryPerformanceCounter) and frequency performance (QueryPerformanceFrequency) to limit the max. frame rate. Feel free to use it in your next productions

Code: [Select]

'----------------------
'   FPS Limiter
'----------------------
'   by Rbraz - 2006
'----------------------

Option Explicit

' Includes
#Include Once "windows.bi"

'Sub Routines
Declare Sub FPS_Count()
'FPS Counter
Dim Shared iFPS, bSettime,iSecStart,iFrameCount,iFrameStart as integer


'--------------------------------------------------
Const MAX_FPS = 60             'Max FPS Desired
Dim Freq    as LARGE_INTEGER
Dim cTimer1 as LARGE_INTEGER
Dim cTimer2 as LARGE_INTEGER
Dim Interval as double
'--------------------------------------------------

    QueryPerformanceFrequency(@Freq)                'Get Frequency
    Interval = CDBL(Freq.QuadPart) / CDBL(MAX_FPS)  'Calculate interval based on MAX_FPS and Frequency

'Main Loop
While Inkey$() <> Chr$( 27 )
       
    QueryPerformanceCounter(@cTimer2)
    if(cTimer2.QuadPart >= cTimer1.QuadPart + Interval) then
       
        QueryPerformanceCounter(@cTimer1)
               
        locate 8,30
        print "Desired FPS: " & MAX_FPS
        locate 10,30
        print "Current FPS: " & iFPS
   
        FPS_Count()
       
    end if
   
 
Wend
'End Main

Sub FPS_Count()
         If bSettime = 1 then
          iSecStart = Timer() * 1000.0
          iFrameStart = iFrameCount
          bSettime = 0
     EndIf 
     If (Timer()*1000.0) >= iSecStart + 1000 then
          iFPS = iFrameCount - iFrameStart
          bSettime = 1
     EndIf
     iFrameCount = iFrameCount + 1     
End Sub


5H0CKW4VE

I may well pinch this, will credit you of course.. Thanks Rbraz

5

Freebasic / Text Using TinyPTC (ez)

« on: May 17, 2006 »

Original post from Shockwave, taken from the ezboard forum

Here's a new version of the intro I am working on, this now has a text routine and a binary font

All 100% TinyPTC.
Compresses down to about 15kb.

 

Code: [Select]

'
' By Shockwave / DBF 2006
'
' THIS INTRO IS UNFINISHED, BUT WILL BE FINISHED IN THE NEXT WEEK OR TWO.
' IT IS POSTED TO HELP THOSE WHO ARE TRYING TO LEARN HOW TO USE THE TINYPTC LIB
' IN FREEBASIC.
'
'*** Only ABOUT 15KB When Crunched!!!!!! ***
'
'-------------------------------------------------------------------------

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

'-------------------------------------------------------------------------
' Open 640 X 480 Screen.
'-------------------------------------------------------------------------

        If( ptc_open( "Stars", 640, 480 ) = 0 ) Then
        End -1
        End If
   
'-------------------------------------------------------------------------
' Variable Definitions.
'-------------------------------------------------------------------------
        Dim Shared LP As Integer: ' Used In Loops.
        Dim Shared As Integer Buffer( 640 * 480 ):' Screen Buffer.
        DIM SHARED AS INTEGER CPAL (255):' Holds Palette.
        Dim Shared GADD As Integer:' General Purpose Variable Just Ticks Up.
        Dim Shared SMSIN As DOUBLE:' Holds X Movement.
        DIM SHARED SMCOS As DOUBLE:' Holds Y Movement.
        DIM SHARED ZMCOS As DOUBLE:' Holds Z Movement.
        DIM SHARED STPTR AS INTEGER:' Pointer Used When Looping Through Stars.
        DIM SHARED STST AS INTEGER:' Holds Deepest Star Pos.
        DIM SHARED A AS INTEGER:' Holds Colour Multiplier.
       
        '--------------------------
        ' Read In Our Star Bobs;---
        '--------------------------
       
        dim shared BOB (36*5) AS INTEGER
        FOR LP=1 TO (36*5)
            READ BOB(LP)
        NEXT
       
        '-----------------------------------------------------------------
        'Read In Our Font;
        '-----------------------------------------------------------------
        dim shared FONT (81 * 59) as integer
        FOR LP=1 TO (81*59)
                READ FONT(LP)
        NEXT
       
'-------------------------------------------------------------------------
' Subroutine Definitions.
'-------------------------------------------------------------------------
        Declare Sub STARFIELD()
        DECLARE SUB DRAWBOB (BYVAL BX AS INTEGER , BYVAL BY AS INTEGER , BYVAL BNM AS INTEGER , BYVAL CL AS INTEGER)
        Declare Sub Clearscreen()
        declare sub DBFTEXT(BYVAL BX AS INTEGER , BYVAL BY AS INTEGER , BYVAL CH AS INTEGER , BYVAL CLR AS INTEGER)
        DECLARE SUB MESSAGE()
        declare SUB Millisecs()
       
'----------------------------
'---    Set Up Starfield; ---
'----------------------------

        Dim Shared STARS As Integer:' Holds Max Number Of Stars
        Dim Shared INZP As Double:' Used When Defining Stars To Hold ZP
        Dim Shared INZPA As Double:' Used When Defining Stars (ZP Increment)
        Dim Shared TX AS INTEGER:' Holds Translated Star X
        Dim Shared TY As Integer:' Holds Translated Star Y
        dim shared customcop (640*480) as integer:' Holds Custom Fake "Copperlist"
       
        STARS = 1500:' How Many Stars?
       
        DIM SHARED STX (1 TO STARS) AS DOUBLE: ' Hold X Pos Of Star
        DIM SHARED STY (1 TO STARS) AS DOUBLE: ' Hold Y Pos Of Star
        DIM SHARED STZ (1 TO STARS) AS DOUBLE: ' Hold Z Pos Of Star
        INZP=30:' Initial Z = 0.
        INZPA = 30 / STARS:' Calculate Increment.
        STPTR=1:' Holds Star Number During Starfield Sub Loop.
        STST=1:' Used To Store Starting Star (deepest).
        For LP = 1 To Stars
            STX (LP) = ((RND(1) * 20000)-10000 )
            STY (LP) = ((RND(1) * 20000)-10000 )
            STZ (LP) = INZP
            INZP=INZP-INZPA
        next
       
        '-----------------------
        ' Generate A Palette;---
        '-----------------------
       
        DIM SHARED R1,G1,B1 AS integer
        FOR LP=1 TO 255
            CPAL(LP) =RGB(R1,G1,B1)
            IF R1<255 THEN R1=R1+1
            IF G1<255 THEN G1=G1+1
            IF B1<254 THEN B1=B1+2
           
        NEXT LP

        '------------------------------
        ' Generate Fake Copperlist; ---
        '------------------------------
       
        for LP=1 to 640*480
            customcop(LP)=&h020004
            SELECT CASE LP
            CASE 0 TO 640*10
                customcop(LP)=&h0a000b
            CASE 640*10 TO 640*20
                customcop(LP)=&h0c000d
            CASE 640*20 TO 640*30
                customcop(LP)=&h0e000f
            CASE 640*30 TO 640*40
                customcop(LP)=&h110012
            CASE 640*40 TO 640*50
                customcop(LP)=&h130014
            CASE 640*470 TO 640*480
                customcop(LP)=&h0a000b
            CASE 640*460 TO 640*470
                customcop(LP)=&h0c000d
            CASE 640*450 TO 640*460
                customcop(LP)=&h0e000f
            CASE 640*440 TO 640*450
                customcop(LP)=&h110012
            CASE 640*430 TO 640*440
                customcop(LP)=&h130014                                   
            END SELECT
        next

'===============================================================================
'       Scroller Stuff;
'===============================================================================
        DIM SHARED SCPTR AS INTEGER:' Letter Pointer In Scroll String.
        DIM SHARED SCOFF AS DOUBLE:' Offset Used To Scroll Text
       
        Dim Shared scrolltext as string:' Holds Text.
        '=======================================================================
        'Our Text;
        '=======================================================================
scrolltext="                                                                 "
scrolltext=scrolltext+"                                                           "
scrolltext=scrolltext+"DARK BIT FACTORY ARE BACK WITH A LITTLE INTRO..........       "
scrolltext=scrolltext+"THIS ONE WAS CODED BY SHOCKWAVE!!          ALTHOUGH IT LOOKS PRETTY "
scrolltext=scrolltext+"BORING IT IS QUITE COOL.....                      IT IS ALL MADE USING THE TINYPTC LIB, "
scrolltext=scrolltext+"WHICH IS IN ITS SELF A PAIN IN THE ASS!!                 EVERYTHING YOU SEE "
scrolltext=scrolltext+"HERE IS HARD CODED...                   EVEN THE FONT IS CONSTRUCTED IN THE SOURCE!!! "
scrolltext=scrolltext+"...OUT OF BINARY...             AAAARRRGGGHHHH!!!!            FOR ALL THE HARD WORK IT COMPRESSES DOWN TO ABOUT 15KB SO "
 scrolltext=scrolltext+"THAT CAN'T BE TOO BAD!"
scrolltext=scrolltext+"         OH WELL....        I GUESS I HAD BETTER ADD SOME MORE EFFECTS......   AND THEN DO SOMETHING USEFUL LIKE SOME"

scrolltext=scrolltext+""OPENGL STUFF "
scrolltext=scrolltext+"INSTEAD??!!       THATS ALL FOR NOW.........              "
scrolltext=scrolltext+"                                                           "
scrolltext=scrolltext+"                                                           "
scrolltext=scrolltext+"                                                           "

SCOFF=0
SCPTR=0
'---------------
'-Debug Stuff; -
'---------------
    dim shared oldtime,newtime as double
    dim shared TST as string
    dim shared ticks as integer
    ticks=0

'--------------------------------------------------
'---    Main Loop, Repeat Until Escape Pressed. ---
'--------------------------------------------------
oldtime=timer

DO
   
           
    Clearscreen():' Clear The Screen.
    STARFIELD():' Do The Starfield. 
    '----------------------------
    ' Draw White Lines On Screen;
    '----------------------------
    FOR LP = 0 TO 639
        Buffer ((50*640)+LP)=RGB (155,55,155)
        Buffer ((430*640)+LP)=RGB (155,55,155)
    NEXT
    MESSAGE():' Do Scroller.
    MILLISECS()
       
    Ptc_Update @Buffer(0):' Update The Buffer.
    ticks=ticks+1
   
LOOP UNTIL INKEY$ = CHR$(27)
Ptc_Close()
END

'-------------------------------------------------------------------------------
' Display FPS.
'-------------------------------------------------------------------------------
SUB Millisecs()
    t=timer

if  t-oldtime >=1 then
    newtime = ticks
    ticks=0
    oldtime=timer
end if

    TST = str( (newtime) )
    TST = "FPS "+TST
    for LP=1 to len(tst)
        CH=(ASC(MID(TST,LP,1)))-31
        DBFTEXT((LP*10),1,CH,&h443333)
    NEXT
   
end sub
'-------------------------------------------------------------------------------
' Scrolling Message Routine By Shockwave / DBF
'-------------------------------------------------------------------------------
SUB MESSAGE()
    dim hop,ecl as integer
   
    HOP=0:' Used to jumpto next letter pos
    ECL=0:' Used For Colour.
   
    FOR LP=1 TO 66
        IF LP<20 THEN ECL=ECL+10:' Change Colours
        IF LP>46 THEN ECL=ECL-10
       
        CH=(ASC(MID(SCROLlTEXT,LP+SCPTR,1)))-31:' Get Ascii for char
        '-----------------------------------------------------------------------
        ' Call DBF Custom Text Routine;
        '-----------------------------------------------------------------------
        DBFTEXT (HOP-scoff,455+12*SIN((LP+GADD)/30),CH,RGB(ECL+30,ECL,ECL+40))
        HOP=HOP+10
    NEXT
    '--------------------------------
    'Scroll And Update If Needed; ---
    '--------------------------------
    scoff=scoff+1
    if scoff> 10 then
        scptr=scptr+1
        if scptr>(len(scrolltext)-66) then scptr=0
        scoff=scoff-10
    end if
   
END SUB

'---------------------------------------
'---    MULTI DIRECTIONAL STARFIELD. ---
'---------------------------------------

SUB STARFIELD()
    GADD=GADD+1
    dim bb as integer
    '---------------
    ' Movements; ---
    '---------------
   
    SMSIN=30*SIN(GADD/470)
    SMCOS=40*COS(GADD/777)
    ZMCOS=0.1*COS(GADD/907)
   
    '---------------------------
    ' Get Deepest Star First;---
    '---------------------------
   
    STPTR=STST
   
    for LP = 1 To STARS
       
        '---------------------------------
        ' Translate Star To 2D Co-Ords ---
        '---------------------------------
       
        TX = INT((STX(STPTR) / STZ(STPTR))+320)
        TY = INT((STY(STPTR) / STZ(STPTR))+240)
       
        '--------------------
        ' Is It Onscreen? ---
        '--------------------
       
        if TX>-5 and TX<639 AND TY>-5 And TY<479 THEN
           
            '--------------------------------
            ' Calculate Colour Multiplier;---
            '--------------------------------
           
            A=INT(-STZ(STPTR) + 32) shl 1
            '-------------------------------------
            ' Draw Bob Size According To Depth;---
            '-------------------------------------
            bb=((int(STZ(STPTR)))/6)+1
            'if bb<1 then bb=1
           
            DRAWBOB (TX,TY,5,A)
            'IF STZ(STPTR) < 10 THEN DRAWBOB (TX,TY,BB,A)
            'IF STZ(STPTR >= 10) AND (STZ(STPTR) <20 ) THEN DRAWBOB (TX,TY,2,A)
            'IF STZ(STPTR) >= 20 THEN DRAWBOB (TX,TY,1,A)
        ENDIF
       
        '---------------
        ' Move Star; ---
        '---------------
       
        STX(STPTR)=STX(STPTR)+SMSIN
        STY(STPTR)=STY(STPTR)+SMCOS
        STZ(STPTR)=STZ(STPTR)+ZMCOS
       
        '------------------
        ' Bounds Checks;---
        '------------------
        ' X Checks;
        IF SMSIN>0 THEN
            IF STX(STPTR)>=10000 THEN STX(STPTR)=STX(STPTR)-20000
        ENDIF
        IF SMSIN<0 THEN
            IF STX(STPTR)<=-10000 THEN STX(STPTR)=STX(STPTR)+20000
        ENDIF
        ' Y Checks;
        IF SMCOS>0 THEN
            IF STY(STPTR)>=10000 THEN STY(STPTR)=STY(STPTR)-20000
        ENDIF
        IF SMCOS<0 THEN
            IF STY(STPTR)<=-10000 THEN STY(STPTR)=STY(STPTR)+20000
        ENDIF
        ' Z Checks;
        IF ZMCOS>0 THEN
            IF STZ(STPTR)>=30 THEN STZ(STPTR)=STZ(STPTR)-30
            STST=STST-1
            IF STST<1 THEN STST=STARS
        ENDIF
        IF ZMCOS<0 THEN
            IF STZ(STPTR)<=0 THEN STZ(STPTR)=STZ(STPTR)+30
            STST=STST+1
            IF STST>STARS THEN STST=1
           
        ENDIF
        STPTR=STPTR+1:' Update Pointer.
        IF STPTR>STARS THEN STPTR=1:'Bounds Check.
    next
   
   
END SUB

'-------------------------------------------------------------------------
'Sub To Draw A Letter AnyWhere On The Screen (With Clipping);
'-------------------------------------------------------------------------
sub DBFTEXT(BYVAL BX AS INTEGER , BYVAL BY AS INTEGER , BYVAL CH AS INTEGER , BYVAL CLR AS INTEGER)
dim blx,bly as integer
    '---------------------------------
    'Calculate Offset In Font Data;---
    '---------------------------------
    bm=(ch*81)-81
    FOR BLY=0 TO 8
    FOR BLX=1 TO 9
        '--------
        'Clip;---
        '--------
        IF (BX+BLX>0) AND (BX+BLX<639) AND (BY+BLY>0) AND (BY+BLY<479) THEN
           
            '----------------------------------------------------
            'Draw Pixel In Buffer If Onscreen And If Binary 1 ---
            '----------------------------------------------------
           
            MM= FONT(((BLY*9)+BLX)+BM)
            IF MM >0 THEN BUFFER (((BY+BLY)*640)+BX+BLX)=CLR
        END IF
    NEXT
    NEXT
END SUB

'-------------------------------------------------------------------------
' Sub To Draw A Bob Anywhere On The Screen;
'-------------------------------------------------------------------------

SUB DRAWBOB (BYVAL BX AS INTEGER , BYVAL BY AS INTEGER, BYVAL BNM AS INTEGER , BYVAL CL AS INTEGER)
   
    DIM BLX , BLY AS INTEGER
   
    '-----------------------
    'Set Offset In Bob Bank;
    '-----------------------
    BM=(BNM*36)-36
   
    FOR BLY=0 TO 5
    FOR BLX=1 TO 6
        '---------
        'CLIPPING;
        '---------
        IF (BX+BLX>0) AND (BX+BLX<639) AND (BY+BLY>0) AND (BY+BLY<479) THEN
            '-------------
            'COLOUR VALUE;
            '-------------
            if (by+BLY> 50) and (by+bly<430) then
                MM= (BOB(((BLY*6)+BLX)+BM))*CL
            else
                MM= ((BOB(((BLY*6)+BLX)+BM))*CL) shr 1
            endif
            if MM>255 then MM=255
            '------------------
            'DRAW PIXEL OF BOB;
            '------------------
            IF MM >0 THEN BUFFER (((BY+BLY)*640)+BX+BLX)=CPAL(MM)
        END IF
    NEXT
    NEXT

END SUB

'--------------------------------------------------------
' Clear Out Old Screen Buffer With Our Fake "Copperlist"
'--------------------------------------------------------

Sub ClearScreen()
Dim i as integer
for i = 0 to 640*480
    buffer(i)=customcop(i)
next
End Sub

'--------------------------------------------------------
' Our "Bobs"
' 0's are not blitted.
' The Higher The Number, The Brighter The Pixel.
'--------------------------------------------------------

'tiny
data 0,0,0,0,0,0
data 0,0,0,0,0,0
data 0,0,1,1,0,0
data 0,0,1,1,0,0
data 0,0,0,0,0,0
data 0,0,0,0,0,0
'small
data 0,0,0,0,0,0
data 0,0,1,1,0,0
data 0,1,2,2,1,0
data 0,1,2,2,1,0
data 0,0,1,1,0,0
data 0,0,0,0,0,0
'medium
data 0,0,1,1,0,0
data 0,0,2,2,0,0
data 1,2,3,3,2,1
data 1,2,3,3,2,1
data 0,0,2,2,0,0
data 0,0,1,1,0,0
'large
data 0,0,1,1,0,0
data 0,2,3,3,2,0
data 1,3,4,4,3,1
data 1,3,4,4,3,1
data 0,2,3,3,2,0
data 0,0,1,1,0,0
'Maximum
data 0,1,2,2,1,0
data 1,2,3,3,2,1
data 2,3,5,5,3,2
data 2,3,5,5,3,2
data 1,2,3,3,2,1
data 0,1,2,2,1,0

'==============================================================================
' Binary Font By Shockwave / DBF; (59 Chars)
'==============================================================================

'space
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
'!
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
'"
data 0,1,1,0,1,1,0,0,0
data 0,1,1,0,1,1,0,0,0
data 0,1,1,0,1,1,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
'#
data 0,0,0,0,0,0,0,0,0
data 0,1,1,0,0,0,1,1,0
data 1,1,1,1,1,1,1,1,1
data 0,1,1,0,0,0,1,1,0
data 0,1,1,0,0,0,1,1,0
data 0,1,1,0,0,0,1,1,0
data 1,1,1,1,1,1,1,1,1
data 0,1,1,0,0,0,1,1,0
data 0,0,0,0,0,0,0,0,0
'£
data 0,0,1,1,1,1,0,0,0
data 0,1,1,1,1,1,0,0,0
data 0,1,1,0,0,0,0,0,0
data 0,1,1,0,0,0,0,0,0
data 0,1,1,1,1,0,0,0,0
data 0,1,1,0,0,0,0,0,0
data 0,1,1,0,0,0,0,0,0
data 1,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,0
'%
data 0,0,0,0,0,0,0,0,0
data 0,1,1,0,0,0,0,0,0
data 0,1,1,0,0,0,1,0,0
data 0,0,0,0,0,1,0,0,0
data 0,0,0,0,1,0,0,0,0
data 0,0,0,1,0,0,0,0,0
data 0,0,1,0,0,0,1,1,0
data 0,0,0,0,0,0,1,1,0
data 0,0,0,0,0,0,0,0,0
'&
data 0,0,0,1,1,1,0,0,0
data 0,0,1,1,1,1,1,0,0
data 0,0,1,1,0,1,1,0,0
data 0,0,0,1,1,1,0,0,0
data 0,0,1,1,0,1,1,0,0
data 0,1,1,0,0,1,1,1,1
data 0,1,1,1,0,0,1,1,0
data 0,0,1,1,1,1,1,0,0
data 0,0,0,0,1,1,0,0,0
''
data 0,1,1,0,0,0,0,0,0
data 0,1,1,0,0,0,0,0,0
data 0,1,1,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
'(
data 0,0,0,0,0,1,1,1,0
data 0,0,0,0,1,1,1,1,0
data 0,0,0,0,1,1,0,0,0
data 0,0,0,0,1,1,0,0,0
data 0,0,0,0,1,1,0,0,0
data 0,0,0,0,1,1,0,0,0
data 0,0,0,0,1,1,0,0,0
data 0,0,0,0,1,1,1,1,0
data 0,0,0,0,0,1,1,1,0
')
data 0,1,1,1,0,0,0,0,0
data 0,1,1,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,1,1,1,1,0,0,0,0
data 0,1,1,1,0,0,0,0,0
'*
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
'+
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
''
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,0,1,0,0,0,0
'-
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
'.
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
'/
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
'0
data 0,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,0
'1
data 0,0,0,1,1,0,0,0,0
data 0,0,1,1,1,0,0,0,0
data 0,0,1,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,1,1,1,1,1,0,0,0
data 0,1,1,1,1,1,0,0,0
'2
data 0,0,1,1,1,1,1,1,0
data 0,0,1,1,1,1,1,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 0,1,1,1,1,1,1,1,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1
'3
data 1,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,0
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,1,1,1,1,0
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,0
'4
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,1,1,0,0,0
data 1,1,0,0,1,1,0,0,0
data 1,1,1,1,1,1,1,1,1
data 0,0,0,0,0,1,1,0,0
data 0,0,0,0,0,1,1,0,0
data 0,0,0,0,0,1,1,0,0
data 0,0,0,0,0,1,1,0,0
'5
data 0,1,1,1,1,1,1,0,0
data 0,1,1,1,1,1,1,0,0
data 0,1,1,0,0,0,0,0,0
data 0,1,1,0,0,0,0,0,0
data 0,1,1,1,1,1,1,1,0
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,0
'6
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,1,1,1,1,1,1,0
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,0
'7
data 0,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,1,1,1,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,1,1,0
data 0,0,0,0,0,0,1,1,0
data 0,0,0,0,0,0,1,1,0
'8
data 0,0,1,1,1,1,1,0,0
data 0,1,1,1,1,1,1,1,0
data 0,1,1,0,0,0,1,1,0
data 0,1,1,0,0,0,1,1,0
data 0,0,1,1,1,1,1,0,0
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,0
'9
data 0,0,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,1
data 0,1,1,0,0,0,0,1,1
data 0,1,1,0,0,0,0,1,1
data 0,0,1,1,1,1,1,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
':
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
';
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
'<
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
'=
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
'>
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
'?
data 0,0,1,1,1,1,1,0,0
data 0,1,1,1,1,1,1,1,0
data 0,1,1,0,0,0,1,1,0
data 0,0,0,0,0,0,1,1,0
data 0,0,0,1,1,1,1,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,1,1,0,0,0,0
data 0,0,0,1,1,0,0,0,0
'@
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
data 0,0,0,0,0,0,0,0,0
'a
data 0,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,0
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
'b
data 1,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,0
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1
'c
data 0,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,1
'd
data 1,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,0
'e
data 0,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,1,1,1,1,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,1
'f
data 0,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,1,1,1,1,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
'g
data 0,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,0
'h
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
'i
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1
data 0,0,0,0,1,0,0,0,0
data 0,0,0,0,1,0,0,0,0
data 0,0,0,0,1,0,0,0,0
data 0,0,0,0,1,0,0,0,0
data 0,0,0,0,1,0,0,0,0
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1
'j
data 1,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,0
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,0
'k
data 1,1,0,0,0,0,1,1,0
data 1,1,0,0,0,0,1,1,0
data 1,1,0,0,0,0,1,1,0
data 1,1,0,0,0,0,1,1,0
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
'l
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,1
'm
data 0,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,1,0,0,1,1
data 1,1,0,0,1,0,0,1,1
data 1,1,0,0,1,0,0,1,1
data 1,1,0,0,1,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
'n
data 0,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1

'o
data 0,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,0
'p
data 1,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
'q
data 0,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,1,0,1,1
data 1,1,0,0,0,0,1,1,1
data 1,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,0
'r
data 1,1,1,1,1,1,1,1,0
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,0
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
's
data 0,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,0,0,0,0,0,0,0
data 1,1,0,0,0,0,0,0,0
data 0,1,1,1,1,1,1,1,0
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,0
't
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1
data 0,0,0,0,1,0,0,0,0
data 0,0,0,0,1,0,0,0,0
data 0,0,0,0,1,0,0,0,0
data 0,0,0,0,1,0,0,0,0
data 0,0,0,0,1,0,0,0,0
data 0,0,0,0,1,0,0,0,0
data 0,0,0,0,1,0,0,0,0
'u
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,0
'v
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,1,0,0,0,1,1,1
data 0,1,1,1,1,1,1,1,0
data 0,0,1,1,1,1,1,0,0
'w
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,1,0,0,1,1
data 1,1,0,0,1,0,0,1,1
data 1,1,0,0,1,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 0,1,1,1,1,1,1,1,0
'x
data 0,1,1,0,0,0,1,1,0
data 0,1,1,0,0,0,1,1,0
data 0,1,1,0,0,0,1,1,0
data 0,1,1,0,0,0,1,1,0
data 0,1,1,1,1,1,1,1,0
data 1,1,1,0,0,0,1,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
'y
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 1,1,0,0,0,0,0,1,1
data 0,1,1,1,1,1,1,1,1
data 0,0,0,0,0,0,0,1,1
data 0,0,0,0,0,0,0,1,1
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,0
'z
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1
data 0,0,0,0,0,0,1,1,1
data 0,0,0,0,1,1,1,0,0
data 0,0,0,1,1,1,0,0,0
data 0,0,1,1,1,0,0,0,0
data 1,1,1,0,0,0,0,0,0
data 1,1,1,1,1,1,1,1,1
data 1,1,1,1,1,1,1,1,1

'===============================================================================
'                                     ***END***
'===============================================================================

Clyde Radcliffe
Grand work - Looking nice mate, real nice.

rbraz
Cool, but will be more cool with the bob sprite and first color palette

5H0CKW4VE
I've made a few tweaks, I will be releasing it as an intro when I've got some more stuff done.. Got to code a triangle routine for it today

6

Freebasic / Crap plasma using tinypct (ez)

« on: May 17, 2006 »

Original post from Shockwave, taken from the ezboard forum


Use it if you want, though it's a bit shit.

Code: [Select]


'
' Simple Plasma Test By Shockwave / DBF 2006.
'
' THIS PROGRAM WAS JUST A TEST TO SEE IF A 640 X 480 SCREEN CAN BE RENDERED
' IN PIXELS QUICK ENOUGH TO DO STUFF.
'
' A SLOW PLASMA ROUTINE WAS ADDED IN TO SIMULATE SOME OF THE CALCULATIONS THAT
' WOULD BE NEEDED TO MAKE TEXTURED VECTORS OR PARTICLE EFFECTS ETC.
' SEEMS TO RUN QUITE QUICK AND THE SINE TABLES / COLOUR TABLES ARE NOT EVEN
' PRECALCULATED WHICH IS A GOOD OMEN.
'
' WILL WORK ON SOME FAST PLASMA ROUTINES IN THE NEXT FEW DAYS.
' IT IS A LOT FASTER THAN BLITZ THOUGH EVEN AS IT STANDS.
'
'--------------------------------------------------------------------------


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

'--------------------------------------------------------------------------
' Open 640 X 480
'--------------------------------------------------------------------------
If( ptc_open( "DBF SIMPLE PLASMA", 640, 480 ) = 0 ) Then
End -1
End If


'--------------------------------------------------------------------------
' Define Storage;
'--------------------------------------------------------------------------
Dim Shared As Integer Buffer( 640 * 480 )
DIM SHARED  R,G,B AS INTEGER
DIM SHARED L1,L2 AS INTEGER
DIM SHARED COMBINED AS INTEGER
DIM SHARED F1,F2,F3 AS INTEGER
DIM SHARED PM AS DOUBLE
PM=3.14/180
'--------------------------------------------------------------------------
' Declare sub-routines
'--------------------------------------------------------------------------
Declare Sub ClearScreen ()

DO
    F1=F1+4
    F2=F2+2
    F3=F3+3
        CLEARSCREEN()
        FOR L1=1 TO 479
            AV2=30+20*SIN(F3 / 20)
            AV=50+AV2*COS((L1-F3)*PM  )
            G=100+AV*COS((F1+L1) * PM )
            B=100+AV*SIN((L1+F3)*PM)
            FOR L2=1 TO 639           
                R=100+AV*SIN((L2+L1+F2) * PM )                     
                COMBINED= RGB (R,G,B)
                Buffer(L2 + (L1 * 640)) = COMBINED
            NEXT
        NEXT


ScreenLock()
'Update PTC screen with temp buffer
Ptc_Update @Buffer(0)
ScreenUnlock()
       
LOOP UNTIL INKEY$<>""
END

'--------------------------------------------------------------------------
' Subs;
'--------------------------------------------------------------------------

Sub ClearScreen()

Dim i as integer
for i = 0 to 640*480
Buffer(i) = 0
next

End Sub

All part of the learning process I guess.
I'll get there.

¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

rbraz

Nice plasma

I'll recode one BB version to FB and post it here later

5H0CKW4VE

Thanks Rbraz, looking forward to seeing your plasma too.

Here's a little re-hash with nicer colours.

 

Code: [Select]

'
' Simple Plasma Test By Shockwave / DBF 2006.
'
' THIS PROGRAM WAS JUST A TEST TO SEE IF A 640 X 480 SCREEN CAN BE RENDERED
' IN PIXELS QUICK ENOUGH TO DO STUFF.
'
' Same again but with prettier colours.
'
'
'--------------------------------------------------------------------------


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

'--------------------------------------------------------------------------
' Open 640 X 480
'--------------------------------------------------------------------------
If( ptc_open( "DBF SIMPLE PLASMA", 640, 480 ) = 0 ) Then
End -1
End If


'--------------------------------------------------------------------------
' Define Storage;
'--------------------------------------------------------------------------
Dim Shared As Integer Buffer( 640 * 480 )
DIM SHARED  R,G,B AS INTEGER
DIM SHARED L1,L2 AS INTEGER
DIM SHARED COMBINED AS INTEGER
DIM SHARED F1,F2,F3 AS INTEGER
DIM SHARED PM AS DOUBLE
PM=3.14/180
'--------------------------------------------------------------------------
' Declare sub-routines
'--------------------------------------------------------------------------
Declare Sub ClearScreen ()

DO
    F1=F1+1
    F2=F2-7
    F3=F3+3
        CLEARSCREEN()
        FOR L1=1 TO 479
            av=50*sin((l1+f1)*PM)
            av2=60+av*cos((f2+l1)*pm)
            av3=100+10*sin((f1+l1)/10)
            bl=100+70*(cos(av2+l1 )) shr 2
            FOR L2=1 TO 639           
                R=140+AV2*SIN((L2+av2+l1) /av3 )                     
                COMBINED= RGB (r,av2,bl)
                Buffer(L2 + (L1 * 640)) = COMBINED
            NEXT
        NEXT



'Update PTC screen with temp buffer
Ptc_Update @Buffer(0)

       
LOOP UNTIL INKEY$<>""
END

'--------------------------------------------------------------------------
' Subs;
'--------------------------------------------------------------------------

Sub ClearScreen()

Dim i as integer
for i = 0 to 640*480
Buffer(i) = 0
next

End Sub


Clyde Radcliffe

Nice mate, it totally rocks with commenting out the bl calculation.
One thing that might be of use to you is that FB uses radians and not degrees. sin( a * PI/180.00 ) is a little converter example. But you probably knew that allready.

I really like the type of movement of the plasma. Cool mate

Cheers and all the best,
Clyde

7

Projects / Test of new 3D engine.

« on: May 17, 2006 »

Original post from Blitz Amateur, taken from the ezboard forum

After ages of being out of the game, I've whipped up a simple triangle rendering engine with z-buffering, and a full rotation/movement camera system. (Even though I locked the camera in this version)

I still need to implement z clipping however. My last routine to do that was clunky, and very slow. And buggy to boot. So I'll be thinking about how to do it differently so I can implement that.
If I'm lucky, it should be bugless. I spent a while making sure it worked flawlessly.

3D Engine Test

This should count up to 1064 triangles. On my laptop (400MHZ P3, 186 megs of RAM with a crappy video accelerator) I get 20 FPS.

It'd be really helpful to know what speeds everyone gets, thanks =)

~Chris

System specs:
P4 3.0 GHZ, 510mb ram, Radeon X300 128mb.

Steady 58 fps. Nice one.

In the window mode Im getting 22-23 fps and my system is:

Nvidia FX5500 with 128Mb
Pentium4 3.66 Ghz

I'm getting 20 ~ 22 fps.

Specs:
P4 2.8Ghz 512Mb ram, Nvidia Gforce 6600GT 128MB video

Hmm, odd results. Not entirely unexpected. So, I compiled a fullscreen version to see if that helps anything.

http://www.geocities.com/dantthegreat/3DTestFS.zip

3D Enginge Fullscreen Test ( I get the same results fullscreen as windowed )

Getting 38-43 fps here
AMD 1.2ghz ,512 ram, Radeon 9600 256 vram

With that fullscreen version i get between 43-47 fps.

And thats also using a different spec machine:
Pentium 4 1.50 Ghz and 512 MB Ram
Nvidia Vanta

fps flicks around a bit but seems to be around 76 for the most

amd @1.7GHz , 512Mb, Radeon 9600

fps 62-64fps

3Ghz, 512ram, Radeon X300

fps still same for me

8

Blitz / The diffrence between Sin() and Cos() (ez)[BB2D]

« on: May 17, 2006 »

Original post from Phoenix, taken from the ezboard forum

Hello everybody!

Whats the diffrence between Sin() and Cos()? I know how to use Sin(), and I use it often, but I don't know what Cos() does. I use Cos() sometimes, when for example moving a space ship, but I use it without knowing what it does. I looked in the command reference, but I didn't really understand... Can anyone help me?

Thanks in advance!

Phoenix

Try here see if this helps

www.dbfinteractive.com/tutorialindex.htm

To my understanding, Cos() does basically the same thing as Sin(), but with slightly different results.

Where sin(0) = 0, cos(0) = 1.0, and when sin(90) = 1.0 then cos(90) = 0.

So they do sorta the same thing, but with opposite results. Kinda .

Hope that helps.

Ahh. Okay, I think I understand. Thanks!

Phoenix

Cos is inverse sine.

9

Blitz / Need some help with an algorithm please (ez)[BB2D]

« on: May 17, 2006 »

Original post from Grim123, taken from the ezboard forum


Hey Guys,

Long time no see I know I haven't posted here in ages - years in fact, But I figured someone here would probably be better equipped to help me with my latest problem than over at Coders Workshop.


Anywayz, As you may or may not know, I have been working on a raycast engine which is basically like Doom. What I am having a problem with is as follows -- This is cut-and pasted from the topic I started over at Coder's Workshop(Btw a sector is just a polygon for this discussion):



You know how with a Doom map editor you create the map sector by sector right? And basically, You draw these sectors, And then you can click somewhere inside the sector you just made and use the 'create sector' option -- And the map editor somehow detects which lines are making up that sector right?

Well, That is what I'm trying to figure out. How to make an algorithm where the person who is creating the map can just draw the map how they like, And then click within a closed set of lines, And have the map-editor automatically detect which lines make up that sector/polygon. I know I can do it manually, But this would make it tedious for making maps, I would much rather take the extra step to get the map-editor to do it automatically. Trouble is -- How do you get it to detect which lines make up 1 sector when ALL of the lines of the map are connected?

If anyone has any ideas, I'd love to hear them! Or if you could point me to some information you might know of that exists on the net. If I can implement this technique, It will make the map-editor much easier to use, And save a lot of time.

My map editor is already capable of making maps, With Zoom in/Out capability etc, I just want it to autodetect sectors when I click inside a completed one. Basically, All the routine needs to do is to define which lines belong to each sector/polygon... I can define them manually, But that defeats the purpose of 'ease of use' - Cause the rest of the map editor is pretty easy to use so far. I hope this makes more sense!


Anyway, With the old dos map editor for Doom called Waded, You don't have to create the sector right after drawing it. The program will allow you to draw a whole map first if you want -- And then later click inside an area that you want to make a sector, And Somehow, The map editor can distinguish which particular lines make up that closed sector.

So...I'm stumped. Anyone have any ideas on how to accomplish this? I just want ideas/algo's, Not actual code, Because I want to do my own programming.


Thanks in advance!


And it feels good to be back here




5H0CKW4VE
*Administrator*

Posts: 7947
(4/10/05 14:32)
Reply | Edit | Del
ezSupporter

   New Post Re: Need some help with an algorithm please Got to have a think about this, nice to see you back Grim



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

VISIT DARK BIT FACTORY INTERACTIVE! (please!)

Grim123
ZX SPECTRUM

Posts: 50
(4/10/05 23:08)
Reply | Edit | Del    New Post Re: Need some help with an algorithm please Thanks Shockwave -- Good to see you too

This one is a toughie, heh. I've been thinking about it some more, And the only solution I could come up with is using raycasting within the map editor to determine the linedefs making up a sector. However, This would require the sectors to all be convex -- Which I can see causing lots of problems. I dunno... But there has to be a way to do this, Well, I know there is because 'Waded' does it. Sorry, I always seem to ask the hard questions lol!


If all else fails, I will just have to make it so the user manually clicks on each line in succession that they want added to a sector. That will be a last resort though.



-Grim-





zawran
Zawran / TTD

Posts: 2092
(4/10/05 23:10)
Reply | Edit | Del
   New Post Re: Need some help with an algorithm please I am having a bit of a problem visualizing it. Can sectors be of any shape? Like a L-shape, a U-shape, or are they all made up of maximum 4 points / 4 walls?

http://zac-interactive.dk
Grim123
VECTREX

Posts: 51
(5/10/05 0:09)
Reply | Edit | Del    New Post Re: Need some help with an algorithm please Hey Zawran,


Yes, Sectors can be any shape - Well, That is convex or concave at least, And use any number of points, That is why I am having so much difficulty in figuring out a solution :/

Basically, Picture it like this: The user making the map draws out their entire map line by line. Then, After the map is drawn, They start creating sectors by clicking inside each area of the map that forms a closed polygon. The map editor should be able to automatically add the correct lines that belong to that polygon. Does this make more sense?


-Grim-

Grim123
VECTREX

Posts: 53
(5/10/05 4:18)
Reply | Edit | Del    New Post Re: Need some help with an algorithm please Hey guys,

If it would help, I can also send you a copy of the 'Waded' map-editor for Doom. Although, You will need one of Doom's Iwad's (Doom.wad or Doom2.wad) to run it.



-Grim-


zawran
Zawran / TTD

Posts: 2101
(7/10/05 15:46)
Reply | Edit | Del
   New Post Re: Need some help with an algorithm please I am not really sure how to go about this one. I remember trying something similar way back when I was working on a doom clone with B3D and wanting to keep the editor 2D with just lines. But I didn't find any solutions on it back then and had to stick with manually making the room connections.

http://zac-interactive.dk
Grim123
VECTREX

Posts: 62
(7/10/05 23:21)
Reply | Edit | Del    New Post No big deal That's allright man,


I've been trying to figure this one out, And nothing seems to be the right answer, So I'm probably going to just make it so that the person making the map has to manually create sectors by clicking on each linedef seperately -- Unless Shockwave pops in here with a brilliant idea to save the day,lol Or someone else.

Thanks anywayz guys!


-Grim-


jimshawx
ZX SPECTRUM

Posts: 35
(8/10/05 5:25)
Reply | Edit | Del    New Post subject When you define the level, it just looks like a maze? Are there doors separating the sectors? How do you decide manually what a sector is? Is there a mathematical definition, or is it just a look-and-feel thing for a user to do it?

Any algorithm you might pick would probably start with any random unused line (wall), and then recursively add walls until it links back up again. If it doesn't link up again down one branch, you have to recurse down another branch until it does. At any time where more than 2 lines meet, you might want to use a heuristic to, say, always go round in a clockwise direction first. That's more likely to bring you back to where you started. Use a cross product to find out the direction of the new line with respect to the last two.
Once you have a circuit, remove it from the map and start again.
Obviously, depending on how the maps are drawn there might be gaps or L shapes or doors that need to be used twice or only one circuit, etc, etc. You could try fixing that by adding dummy walls to the map before you start looking for circuits/sectors/areas whatever you call them.
That's how I'd approach it anyway.

Jim

Grim123
VECTREX

Posts: 63
(8/10/05 7:06)
Reply | Edit | Del    New Post Well,

In this case, The sectors are just like Doom's -- Any set of lines that form a polygon which is either convex or concave - Without overlapping lines.When I say manually adding the lines to a sector, I mean that after the user draws out the map, They would then go into sector mode by pressing a button, And then click on the lines they wish to define a sector. If they do it incorrectly, The engine will crash - Simple as that. But sectors are not difficult at all to draw - It's just a fancy name for a 2d polygon really. I thought about the clockwise thing -- But there are a lot of times that you would end up with a sector that doesn't have all of the lines going in a clockwise motion -- such as a concave sector. Anywayz, I guess I can try to tackle this problem later, Manually creating the sectors is just more tedious, But it will work just fine too. I don't know how 'Waded' does it, But they're map editor does the automatic technique very well.



-Grim-

jimshawx
ZX SPECTRUM

Posts: 36
(9/10/05 0:07)
Reply | Edit | Del    New Post crash?

    Quote:If they do it incorrectly, The engine will crash - Simple as that


If both convex and concave polygons are allowed, how can a sector be incorrect? Is it just if the polygon is incomplete or has lines that cross?

    Quote:I thought about the clockwise thing -- But there are a lot of times that you would end up with a sector that doesn't have all of the lines going in a clockwise motion -- such as a concave sector


That's what a heuristic is. A rule that isn't hard-and-fast, it's just true sometimes and gives you a better result than blind random choice. For instance, in the classic Travelling Salesman problem, a heuristic choice might be preferentially to visit a town you haven't been to before instead of going back somewhere you've already been. But that doesn't always help since some towns are up dead ends.
Clearly if you want your algorithm to join up the sectors more rapidly then the higher the ratio of right turns over left turns, the better.
Travelling Salesman if often solved by an algorithm called Djikstra's Algorithm. You'd be wanting to use something very similar to that to work our your sectors automatically. Another name for it is the A* algorithm.

I haven't seen Waded, but I take it the kind of sectors you're talking about are the ones that appear when you go from one area to another on the ingame maps in Doom?
If so, it's the doors that are the key to working out where the sectors are, because they are the boundary between one sector and another.

Jim

Grim123
VECTREX

Posts: 64
(13/10/05 8:34)
Reply | Edit | Del    New Post Re: Quote:
--------------------------------------------------------------------------------
If both convex and concave polygons are allowed, how can a sector be incorrect? Is it just if the polygon is incomplete or has lines that cross?
--------------------------------------------------------------------------------



Yes, Either incomplete, Or crossing lines.




Quote:
--------------------------------------------------------------------------------
That's what a heuristic is. A rule that isn't hard-and-fast, it's just true sometimes and gives you a better result than blind random choice. For instance, in the classic Travelling Salesman problem, a heuristic choice might be preferentially to visit a town you haven't been to before instead of going back somewhere you've already been. But that doesn't always help since some towns are up dead ends.
Clearly if you want your algorithm to join up the sectors more rapidly then the higher the ratio of right turns over left turns, the better.
Travelling Salesman if often solved by an algorithm called Djikstra's Algorithm. You'd be wanting to use something very similar to that to work our your sectors automatically. Another name for it is the A* algorithm.
--------------------------------------------------------------------------------




Yes, I know about the A* algorithm, And I also know what a heuristic is. I don't want an algorithm that is only right part of the time though, Or, Basically making guesses -- It should be able to make a sector correctly every time, Providing the person drawing the polygon abides by the rules stated above.



Quote:
--------------------------------------------------------------------------------
I haven't seen Waded, but I take it the kind of sectors you're talking about are the ones that appear when you go from one area to another on the ingame maps in Doom?
If so, it's the doors that are the key to working out where the sectors are, because they are the boundary between one sector and another.
--------------------------------------------------------------------------------




Yes, Just like the ones in Doom -- I take it you haven't used a Doom map editor before then? Because, Doors are not what makes the boundary between one sector and another, It's a two-sided Linedef that decides the boundary -- There are several sectors that are connected in many maps that don't use a door to seperate them. A door in Doom is simply a sector which moves up and down, You can make any sector in Doom into a door. Anywayz, Never mind -- I appreciate the suggestions, But it's clear that we aren't quite on the same page. The heuristic was a good suggestion, But I need something that will work all the time - without fail, Not just sometimes.

So, I am just going to make the sectors a manual operation until I figure it out for myself.


-Grim-



Grim123
VECTREX

Posts: 67
(14/10/05 7:52)
Reply | Edit | Del    New Post Found a solution!! :grnpep :grnpep :grnpep

Hey guys, I have good news!

I just saved a ton of money on my car insurance by switching to Geiko. Just kidding, Lol






I came up with another way of automatically creating sectors which I have now implemented in the map editor. There is a small amount of manual operation required, But it is very easy to create a sector now, And they are created the same time that the walls/Linedefs are drawn. Anywayz, This is what I came up with: I have 2 fields in the type for the
Linedef(wall type) that store the sector that the linedef belongs to. Why 2? Because in situations where 2 sectors share one Linedef. Anywayz, It works as follows:


1> the person drawing the map presses the 'N' key to start a new sector.

2> They then begin placing lines, The lines are red until placed, They then become green after the second vertex of the linedef is placed -- Denoting that this line is now a part of the current new sector.

3> after drawing a sector, The person then hits the 'N' key again to start a new sector. The sector that was just finished turns blue to show that it is finished. So all sectors that are completed will be blue lines -- This makes it easy to tell which lines are being added to the current sector.

4> during the drawing of the linedefs, The vertex's of the current line being placed are compared to all of the previous lines already placed, And if the start and end vertex's match to the start and end vertex's of any line previously placed, The map-editor knows that this is a line that is shared between 2 sectors, And doesn't create a new line, So no lines overlap. The line that is shared then turns green to show that it is a part of the new sector. You will have to draw a line over the top of an existing line if it's needed to close off a sector, But it doesn't make a line when you do this, Just turns the line underneath into a 2 sided linedef basically


I will also have a feature where you can cycle between the different sectors, So that you can visually make sure they are all correct. But, So far, The editor works flawlessly It is really pretty easy using this method. All the person making the map editor has to do is make sure to press 'N' to create a new sector, And then create a closed polygon shape out of linedefs for a new sector.

Well, I appreciate everyone's help!!

:nanasplit

-Grim-


zawran
Zawran / TTD

Posts: 2108
(14/10/05 9:51)
Reply | Edit | Del
   New Post Re: Found a solution!! That sounds like a very good solution to me. I might even use that idea if I one day return to making a 3d game.

http://zac-interactive.dk
Grim123
VECTREX

Posts: 70
(14/10/05 22:34)
Reply | Edit | Del    New Post Re: Thanks, And feel free to use it!


-Grim-

10

Blitz / Algorithm bug (ez)[BMAX]

« on: May 17, 2006 »

Original post from zparticle, taken from the ezboard forum


I'm try to adapt this code to bmax from java. I shows a bar twisting back and forth. I've almost got it but the polygons in the back ground look like they are getting blended with the polygons in the foreground and I can't figure out why. any help you can give would be nice.

Code: [Select]

[quote]' this code adapted from one of ETROMIC's (Olof HÃ¥nell) effects
Strict

Framework BRL.GlMax2D

Import BRL.System
Import BRL.Basic
Import BRL.pngloader
Import BRL.Retro

?Win32
SetGraphicsDriver(GLMax2DDriver())
?
Graphics 640,480,0'32,60

Const NUM_DEGREES:Int = 20
Const NUM_SECTIONS:Int = 45
Const NUM_POINTS:Int = 5
Const ROTATION_SCALE:Int = 2
'Global baseColor:Int = 2895943
Global baseColor:Int = 13412915
Const bgColor:Int = 2895943
Global cylinderWidth:Int = 150
Global XZ_SCALE:Int = cylinderWidth Shr 1
Global circle_y_step:Int = GraphicsHeight()/NUM_SECTIONS
Global variation_speed:Float = 0.00021
Global cycledifference:Float = 0.022
Global fm:Float = 0.0
Global CP:CirclePlane[] = New CirclePlane[NUM_SECTIONS]
setupSections()

Global frames:Long = 0
Global fps:Long = 0
Global lastTime:Long = MilliSecs()

SetClsColor(44,48,71)

While Not KeyHit(KEY_ESCAPE)
Cls ' clear the screen
update()
DoFPS()
Flip() ' flip the buffers
FlushMem() ' garbage collection
Wend

Type Point
Field x:Float
Field y:Float
'Field z:Float

Method Set(x1:Float,y1:Float)',z1:Float)
x=x1
y=y1
'z=z1
End Method
End Type

Type Polygon
Field points:Point[] = New Point[4]
Field c:Color = New Color
Field array:Float[] = New Float[6]

Function Create:Polygon()
Local p:Polygon= New Polygon
For Local c:Int = 0 To 3
p.points[c] = New Point
Next
Return p
End Function

Method firstPoints()
array[0] = points[0] .x
array[1] = points[0] .y
array[2] = points[1].x
array[3] = points[1].y
array[4] = points[2].x
array[5] = points[2].y
End Method

Method secondPoints()
array[0] = points[2].x
array[1] = points[2].y
array[2] = points[3].x
array[3] = points[3].y
array[4] = points[0] .x
array[5] = points[0] .y
End Method

End Type

Type Color
Field r:Int=255
Field g:Int=255
Field b:Int=255

Method Set(r1:Float,g1:Float,b1:Float)
r=r1
g=g1
b=b1
End Method
End Type

Function rotPoints()
Local diff:Float = 0
For Local i:Int=0 Until NUM_SECTIONS
'CP[i].rotateBy(Float(Float(ROTATION_SCALE)*Sin((fm+diff)*0.0174532925)))
CP[i].rotateBy(Float(Float(ROTATION_SCALE)*Sin(fm+diff)))
diff:+cycledifference
fm:+variation_speed
Next
End Function

Function update()
rotPoints()

Local yStep:Float = Float(GraphicsHeight()) / Float(NUM_SECTIONS-1)
Local yp:Float = 0
Local xPush:Int = (GraphicsWidth() Shr 1) - (XZ_SCALE Shr 1)

Local pts:Polygon[] = New Polygon[(NUM_SECTIONS-1) * (NUM_POINTS)]
Local ptsZ:Int[] = New Int[pts.length]
Local colors:Color[] = New Color[pts.length]
Local order:Int[] = New Int[pts.length]

Local n:Int = 0;
Local p:Polygon;
For Local i:Int=0 Until NUM_SECTIONS-1
For Local j:Int=0 Until NUM_POINTS
p = Polygon.Create();
Local p0:Float[] = CP[i].GetPoint(j)
Local p1:Float[] = CP[i].GetPoint(j+1)
Local p2:Float[] = CP[i+1].GetPoint(j+1)
Local p3:Float[] = CP[i+1].GetPoint(j)
p.points[0] .Set(Int(p0[0] + xPush +.5), Int(yp+.5))
p.points[1].Set(Int(p1[0] + xPush +.5), Int(yp+.5))
p.points[2].Set(Int(p2[0] + xPush +.5), Int(yp+yStep+.5))
p.points[3].Set(Int(p3[0] + xPush +.5), Int(yp+yStep+.5))

pts[n] = p;
ptsZ[n] = Int(p0[1] + p1[1] + p2[1] + p3[1]) Shr 2

Local c:Int = Int( ptsZ[n] - XZ_SCALE )
Local base_r:Int = ((baseColor Shr 16) & 255) + c
Local base_g:Int = ((baseColor Shr 8) & 255) + c
Local base_b:Int = ((baseColor ) & 255) + c

If base_r>255 Then base_r = 255
If base_g>255 Then base_g = 255
If base_b>255 Then base_b = 255

colors[n] = New Color
colors[n].Set(base_r,base_g,base_b)
n:+1
Next
yp:+yStep
Next
order = zSort(ptsZ)

SetBlend(SOLIDBLEND)
SetColor(255,255,255)
SetAlpha(1)

Local nu:Int = order.length
For Local i:Int=0 Until nu

SetColor(colors[order[i]].r,colors[order[i]].g,colors[order[i]].b);

pts[order[i]].firstPoints()
DrawPoly(pts[order[i]].array);

pts[order[i]].secondPoints()
DrawPoly(pts[order[i]].array);
Next
End Function

Function zSort:Int[](ptsZ:Int[])
Local sorted:Byte = False
Local num:Int = ptsZ.length - 1
Local back:Int[] = New Int[ptsZ.length]
For Local i:Int=0 Until back.length
back[i] = i
Next
' Rem
While sorted=False
sorted = True
For Local i:Int=0 Until num
If ptsZ[i] > ptsZ[i+1] Then
Local backTemp:Int = back[i]
Local tmp:Int = ptsZ[i]
back[i] = back[i+1]
ptsZ[i] = ptsZ[i+1]
back[i+1] = backTemp
ptsZ[i+1] = tmp
sorted = False
EndIf
Next
Wend
'EndRem
Return back
End Function

Function DoFPS()
SetBlend(SOLIDBLEND)
SetColor(255,255,255)
SetAlpha(1)
DrawText "FPS: "+fps,0,0
frames:+1
If MilliSecs()-lastTime>=1000 Then
fps=frames
frames=0
lastTime=MilliSecs()
EndIf
End Function

Function setupSections()
Local sAngle:Int = 0
Local aStep:Int = Int(Float(NUM_DEGREES) / Float(NUM_SECTIONS))
For Local i:Int=0 Until NUM_SECTIONS
CP[i] = CirclePlane.Create(NUM_POINTS, XZ_SCALE, sAngle)
sAngle:+aStep
Next
End Function

Type CirclePlane
Field numPoints:Int = 0
Field rotation:Float = 0
Field degreeStep:D ouble = 0
Field ps:Float[,]
Field psb:Float[,]
Field scale:Int = 0
Const X:Int = 0
Const Z:Int = 1

Function Create:CirclePlane(pointCount:Int, scale:Int, sRotation:Int)
Local cp:CirclePlane = New CirclePlane
cp.numPoints = pointCount
cp.rotation = Float(sRotation)
cp.scale = scale
cp.degreeStep = Double(360) / Double(pointCount)
cp.ps = New Float[pointCount,2]
cp.rot()
Return cp
End Function

Method rotateBy(deg:Float)
rotation :+ deg
rot()
End Method

Method GetPoint:Float[](which:Int)
Local back:Float[] = New Float[2]
back[0] = ps[which Mod numPoints,0]
back[1] = ps[which Mod numPoints,1]
Return back
End Method

Method rot()
Local ang:D ouble = 0
For Local i:Int=0 Until numPoints
ps[i,X] = Int(Float(scale) * Cos(rotation + ang) + .5)
ps[i,Z] = Int(Float(scale) * Cos(rotation + ang - (3.1416/2.0)) + Float(scale)+.5)
ang:+degreeStep
Next
End Method
End Type[/quote]

Edited by: zparticle at: 17/10/05 22:03
zawran
Zawran / TTD

Posts: 2114
(18/10/05 5:34)
Reply | Edit | Del
   New Post Re: Algorithm bug I will take a look at it tonight when I get home from work. Do you have a link to the original java source ?

zac.interactive | Blog | Tutorials | Demos | Tools
zparticle
AMSTRAD CPC

Posts: 77
(18/10/05 15:46)
Reply | Edit | Del    New Post Re: Algorithm bug www.scottshaver2000.com/b...tromic.bmx (my version)

www.scottshaver2000.com/b...ect02.java (java version)

www.scottshaver2000.com/b...cialfx.jar ( java program using it, java -jar specialfx.jar)

Edited by: zparticle at: 18/10/05 15:48
zawran
Zawran / TTD

Posts: 2115
(18/10/05 16:18)
Reply | Edit | Del
   New Post Re: Algorithm bug Not really sure whats wrong here. It must be the setBlend command that doesn't work right as the polys gets blended. Or the setAlpha. Perhaps someone else have a similar problem. I will do a seach on the official forum and see if something comes up.

Does that guy have a website with these effects shown?

zac.interactive | Blog | Tutorials | Demos | Tools
zparticle
AMSTRAD CPC

Posts: 78
(18/10/05 16:23)
Reply | Edit | Del    New Post Re: Algorithm bug it's on my site he added some fx to a program I wrote: www.scottshaver2000.com/t...=specialfx


here is what it originally looked like

www.scottshaver2000.com/b...omic02.png

zawran
Zawran / TTD

Posts: 2116
(18/10/05 16:31)
Reply | Edit | Del
   New Post Re: Algorithm bug Ah yes, now I know what the effect is supposed to look like I did one of these, just textured a while back. Pure pixel pushing stuff though, not polygons.

I don't have much experience using the bmax 2d commands as I have so far kept to pure openGL stuff. I will experiment a bit and see if I can't figure out whats going wrong.

zac.interactive | Blog | Tutorials | Demos | Tools
zparticle
AMSTRAD CPC

Posts: 79
(18/10/05 16:48)
Reply | Edit | Del    New Post Re: Algorithm bug I'm wondering if it loooks odd because I have to use 2 trianlge for each section where he was able to use a 4 sided polygon for each one. Also I'm thinking I might have the z sort screwed up. I can't find anything wrong with the blend mode. very frustrating.

zparticle
AMSTRAD CPC

Posts: 80
(18/10/05 16:54)
Reply | Edit | Del    New Post Re: Algorithm bug another possibility is that I've got it building the polygons around more than once, more the 360 degrees so that they overlap. I don't see it though.

zparticle
AMSTRAD CPC

Posts: 81
(18/10/05 17:09)
Reply | Edit | Del    New Post Re: Algorithm bug definately not a blending problem I can draw other polygon behind it and not see them.

zawran
Zawran / TTD

Posts: 2117
(18/10/05 17:14)
Reply | Edit | Del
   New Post Re: Algorithm bug Could be something with the z ordering as you were suggesting. Looks like its drawing the polys that is supposed to be hidden.

zac.interactive | Blog | Tutorials | Demos | Tools
zparticle
AMSTRAD CPC

Posts: 82
(18/10/05 17:16)
Reply | Edit | Del    New Post Re: Algorithm bug I'm over in the chat room if you would care to join.

zawran
Zawran / TTD

Posts: 2118
(18/10/05 17:28)
Reply | Edit | Del
   New Post Re: Algorithm bug Its a java based chat client, so it won't work on this computer. I don't have any java vm installed or anything. My internet connection is payed by my employer, and they don't want us to install stuff like that onto computer connected through their equipment. On the plus side, I get the 2mbit connection for free.

zac.interactive | Blog | Tutorials | Demos | Tools
zparticle
AMSTRAD CPC

Posts: 83
(18/10/05 17:34)
Reply | Edit | Del    New Post Re: Algorithm bug cool , I looked a bit closer. removed the sorting and then watching it run I think I may be missing a side. That would cause the strange visual that is happening

zawran
Zawran / TTD

Posts: 2119
(18/10/05 17:44)
Reply | Edit | Del
   New Post Re: Algorithm bug For what its doing, the code looks a bit overly complex I think. I am almost certain that it could be done much simpler. At least, I am having problems figuring out what different parts of the code does.

I might try and re-create the effect in a different way if I get time during the week.

A bit off topic, I saw that you are working on a RPG game. I have almost always wanted to make one, but just never got anywhere as its a huge thing to create. How are progress on it? Looks like its based on the D20 game rules.

zac.interactive | Blog | Tutorials | Demos | Tools
zparticle
AMSTRAD CPC

Posts: 84
(18/10/05 17:53)
Reply | Edit | Del    New Post Re: Algorithm bug I haven't done anything on it in a week or two. I've got all of the character creation, equipment/inventory, classes, races, help system, money system, dice system (D20) done. I'm going to use my SAS Map Editor for the maps, so that is done. I've been playing with LUA for the scripting engine. I'm hoping I'll get motivated to get a basic module up and running so you can enter it and walk around soon. You'll be able to create you own modules when it is finished.

Edited by: zparticle at: 18/10/05 17:54
zparticle
AMSTRAD CPC

Posts: 85
(18/10/05 20:51)
Reply | Edit | Del    New Post Re: Algorithm bug Well I thought I had it figured out, for a minute I thought maybe the winding of the polygon points was causing problems since bmax uses ogl. But alas it doesn't seem to make a difference.

zawran
Zawran / TTD

Posts: 2120
(19/10/05 19:20)
Reply | Edit | Del
   New Post Re: Algorithm bug I have just made this alternative way of making the effect based on the 3D code from one of my tutorials and a custom cylinder function. Its coded with BlitzPlus, but should be easy enough to convert to bmax if you don't have BlitzPlus or Blitz3D.

 

Graphics 640, 480, 32, 2

; setup vector variables
Global maxpoints = 10000
Global screenXcenter = 320
Global screenYcenter = 240
Global distance# = 20 ; distance of viewing
Dim points#( maxpoints, 2 ) ; original points
Dim tpoints#( maxpoints, 2 ) ; transformed points
Global maxquads = 1000
Dim quads( maxquads, 3 )
Dim quadRGB( maxquads )
Global pointCount = 0
Global quadCount = 0

; quad fill dims
Dim xval(20)
Dim yval(20)

SetBuffer BackBuffer()
While Not KeyHit( 1 )

pointCount = 0
quadCount = 0
createCylinder( 15, 5, 6, 40, 3+Sin( ang1# ) * 3 )

Cls

rotate3Dpoints( 0,ang1#,0 )
draw3Dquads()
ang1# = ang1# + 0.7
ang2# = ang2# + 1.3
ang3# = ang3# + 0.4

Color 255,255,255
Text 10,10,pointCount
Text 10,30,quadCount

Flip

Wend
End

Function createCylinder( HEIGHT, RADIUS#, SIDES, SECTIONS, TWIST# )
        Local yOff# = Float ( HEIGHT / 2 ) - HEIGHT
        Local yAdd# = Float HEIGHT / SECTIONS
        Local stepsize# = Float 360 / SIDES
        Local twisted# = 0
        Local RED, GREEN, BLUE

        i = 0
        For b = 0 To SECTIONS
                For a = 0 To SIDES-1
                        addPoint( Float Cos(a*stepsize#+twisted#)* RADIUS#, yOff#, Float Sin(a*stepsize#+twisted#) * RADIUS#  )
                        i = i + 1
                Next
                twisted# = twisted# + TWIST#
                yOff# = yOff# + yAdd#
        Next

        i = 0
        For a=0 To SECTIONS-1
                For b=0 To SIDES-2
                        If i = 0 Then
                                RED = 255
                                GREEN = 255
                                BLUE = 255
                        Else
                                RED = 0
                                GREEN = 0
                                BLUE = 255
                        End If
                        i = 1 - i
                        addQuad( b+a*SIDES, b+a*SIDES+1, b+(a+1)*SIDES+1, b+(a+1)*SIDES, RED, GREEN, BLUE )
                Next
                addQuad( b+a*SIDES, a*SIDES, (a+1)*SIDES, b+(a+1)*SIDES, RED, GREEN, BLUE )
        Next
End Function

Function addPoint( x#, y#, z# )
        points#( pointCount, 0 ) = x#
        points#( pointCount, 1 ) = y#
        points#( pointCount, 2 ) = z#
        pointCount = pointCount + 1
End Function

Function addQuad( p1, p2, p3, p4, R, G, B )
        quads( quadCount, 0 ) = p1
        quads( quadCount, 1 ) = p2
        quads( quadCount, 2 ) = p3
        quads( quadCount, 3 ) = p4
        quadRGB( quadCount ) = R Shl 16 + G Shl 8 + B
        quadCount = quadCount + 1
End Function

Function draw3Dquads()
For i = 0 To quadCount-1
normal1 = ( tpoints#( quads( i, 1 ), 0 ) - tpoints#( quads( i, 0 ), 0 ) ) * ( tpoints#( quads( i, 0 ), 1 ) - tpoints#( quads( i, 2 ), 1 ) )
normal2 = ( tpoints#( quads( i, 1 ), 1 ) - tpoints#( quads( i, 0 ), 1 ) ) * ( tpoints#( quads( i, 0 ), 0 ) - tpoints#( quads( i, 2 ), 0 ) )
normalcheck = normal1 - normal2
If normalcheck < 0 Then
Quad( tpoints#( quads( i, 0 ), 0 ), tpoints#( quads( i, 0 ), 1 ), tpoints#( quads( i, 1 ), 0 ), tpoints#( quads( i, 1 ), 1 ), tpoints#( quads( i, 2 ), 0 ), tpoints#( quads( i, 2 ), 1 ), tpoints#( quads( i, 3 ), 0 ), tpoints#( quads( i, 3 ), 1 ), quadRGB( i ) )
End If
Next
End Function

Function rotate3Dpoints( XROT#, YROT#, ZROT# )
sx# = Sin( XROT# )
cx# = Cos( XROT# )
sy# = Sin( YROT# )
cy# = Cos( YROT# )
sz# = Sin( ZROT# )
cz# = Cos( ZROT# )
For i = 0 To pointCount-1
x# = points#( i, 0 )
y# = points#( i, 1 )
z# = points#( i, 2 )
; rotation around x
xy# = cx# * y# - sx# * z#
xz# = sx# * y# + cx# * z#
; rotation around y
yz# = cy# * xz# - sy# * x#
yx# = sy# * xz# + cy# * x#
; rotation around z
zx# = cz# * yx# - sz# * xy#
zy# = sz# * yx# + cz# * xy#
; perspective correction
tpoints#( i, 0 ) = zx# / ( distance# + yz# ) * 512 + screenXcenter
tpoints#( i, 1 ) = zy# / ( distance# + yz# ) * 512 + screenYcenter
tpoints#( i, 2 ) = yz#
Next
End Function

; triangle and rect fill code from Skidracer and Swift
; can be found at: www.blitzbasic.com/codear...p?code=136

Function Triangle(x0,y0,x1,y1,x2,y2)
xval(0)=x0
yval(0)=y0
xval(1)=x1
yval(1)=y1
xval(2)=x2
yval(2)=y2
FastPoly(3, RGB)
End Function

Function Quad(x0,y0,x1,y1,x2,y2,x3,y3,RGB)
xval(0)=x0
yval(0)=y0
xval(1)=x1
yval(1)=y1
xval(2)=x2
yval(2)=y2
xval(3)=x3
yval(3)=y3
FastPoly(4,RGB)
End Function

Function FastPoly(vcount,RGBColor)

; get clipping region
width=GraphicsWidth()
height=GraphicsHeight()

; Lock the current drawing buffer.
LockBuffer()

; find top verticy
b=vcount-1
y=yval(0)
While c<>b
c=c+1
yy=yval(c)
If yy<y y=yy d=c
Wend
c=d
t=c

; draw top to bottom
While y<height

; get left gradient
If y=yval(c)
While y=yval(c)
x0=xval(c) Shl 16
c=c+1
If c>b c=a
If c=t Goto Finish
If y>yval(c) Goto Finish
Wend
h=yval(c)-y
g0=((xval(c) Shl 16)-x0)/h
EndIf

; get right gradient
If y=yval(d)
While y=yval(d)
x1=xval(d) Shl 16
d=d-1
If d<a d=b
If y>yval(d) Goto Finish
Wend
h=yval(d)-y
g1=((xval(d) Shl 16)-x1)/h
EndIf

; calc horizontal span
x=x1 Sar 16
w=((x0 Sar 16)-x)+1

; draw down to next vert
If (w > 0) And (y > -1) And (x < width) And ((x+w) > 0)

;crop left
If x < 0
w=w+x
x=0
EndIf

;crop right
If (x+w) > width
w=width-x
EndIf

; Draw scanline.
For Lx = x To (x+w)
WritePixelFast Lx, y, RGBColor
Next

EndIf

; next
x0=x0+g0
x1=x1+g1
y=y+1

Wend

.Finish

; Unlock the draw buffer.
UnlockBuffer()

End Function

zac.interactive | Blog | Tutorials | Demos | Tools
zparticle
AMSTRAD CPC

Posts: 86
(21/10/05 15:43)
Reply | Edit | Del    New Post Re: Algorithm bug Thanks, I got it fixed. I was do the rotation is radians and not degress so it wrapping around more than once.

The code is available at

www.scottshaver2000.com/b...tromic.bmx

zawran
Zawran / TTD

Posts: 2121
(21/10/05 15:50)
Reply | Edit | Del
   New Post Re: Algorithm bug Yes, looks like it works just fine now.

zac.interactive | Blog | Tutorials | Demos | Tools
zawran
Zawran / TTD

Posts: 2133
(25/10/05 16:30)
Reply | Edit | Del
   New Post Re: Algorithm bug Is this effect part of some kind of demo, or just something you are working on to play around with Bmax and figure things out?

I still haven't picked up where I left Bmax last. But I am getting there, its just been difficult finding the motivation to code again.

zac.interactive | Blog | Tutorials | Demos | Tools
zparticle
AMSTRAD CPC

Posts: 89
(26/10/05 16:29)
Reply | Edit | Del    New Post Re: Algorithm bug I was thinking about putting it into a demo, maybe the mirror thing. Mainly I wanted to see if I could make it work in BMax.

11

Blitz / Screen selector[BPLUS]

« on: May 17, 2006 »

Original post from Codeman, taken from the ezboard forum

Could anybody help me out with a screen selector
id like to start by asking full screen or windowed b4 i start the intro

Code: [Select]

Graphics 640,480 , 16 ,2

selected=1
SetBuffer BackBuffer()

While Not KeyHit(1)
Cls

If selected-1
EndIf
EndIf


If KeyHit(208) Then
If selected=2 Then
selected=1
Else
selected=selected +1
EndIf
EndIf


If selected=1 Then

Text 250,330, "> Full screen 250,345, " Windowed "
Text 210,370,"Use cursor up/down then press"
Text 210,380,"enter to choose screen size"
Text 210,390,"Then hit ESC to start demo"
If KeyHit(28) Or KeyHit(156) Then choice = 1

EndIf


If selected=2 Then

Text 250,330, " Full screen "
Text 250,345, "> Windowed 210,370, "Use cursor up/down then press"
Text 210,380, "enter to choose screen size"
Text 210,390, "Then hit ESC to start demo"

If KeyHit(28) Or KeyHit(156) Then choice = 2
EndIf


Flip
Wend

This is the code i have but after selecting screen size you press enter and then have to press escape to continue. how could i just select option then hit enter and continue ?

Code: [Select]

Graphics 800,600,16,choice
SetBuffer BackBuffer()
While Not KeyHit(1)
Text 300,300,"HELLO"
Flip
Wend


Try this out. It probably does more than you need but you can just use the window selection gadget. Hope this helps.

Code: [Select]

intModes=CountGfxModes()
Dim scn_width( 255 )
Dim scn_height( 255 )
Dim scn_depth( 255 )
window = 1
i = 1
For t = 1 To intModes
scn_width(t) = GfxModeWidth(t)
scn_height(t)= GfxModeHeight(t)
scn_depth(t) = GfxModeDepth(t)
Next
SetBuffer BackBuffer()
 ClsColor 155,100,100:Flip:Cls
 While Not KeyDown( 28 )
   
    If KeyHit( 200 )  Then
        i = i + 1 
         If i > intModes i = 1
         Cls
          End If
     If KeyHit( 208 ) Then
     i = i - 1
     If  i  < 1 i = intModes
     Cls
        End If
         If KeyHit( 205 ) Then         window = window + 1:Cls
         If window = 1 Then onoff$ = "full            "
         If window = 2 Then onoff$ =  "window         "
         If window = 3 Then onoff$ = "scaled window   "
         If window > 3 window = 1: onoff$ = "full" :Cls
Color 0,0,0       
Text 10,3,"Use u/d arrow keys for res and color depth"
Text 10,23,"Use rt arrow key for window modes"
Text 10,40,"Enter to select"
Text 10,60,"Width=  "  + scn_width(i)
Text 10,80,"Height= "  + scn_height(i)
Text 10,100,"Depth=  "  + scn_depth(i)
Text 10,120,"Window= " + onoff$
Color 255,255,255
Text 11,2,"Use u/d arrow keys for res and color depth"
Text 10,22,"Use rt arrow key for window modes"
Text 11,39,"Enter to select"
Text 11,59,"Width=  " + scn_width(i)
Text 11,79,"Height= " + scn_height(i)
Text 11,99,"Depth=  " + scn_depth(i)
Text 11,119,"Window= " + onoff$

  demo_sw                 = scn_width(i)
  demo_sh                 = scn_height(i)
  demo_depth         = scn_depth(i)
  demo_window         = window 
Flip
Wend


Code: [Select]

Graphics demo_sw,demo_sh,demo_depth,demo_window
 
SetBuffer  BackBuffer()
 ClsColor 155,100,100:Flip:Cls
 
While Not KeyDown(1)


Text 20,20,"NEW SCREEN----------------------"
Text 20,40," fantastic demo goes here :)  "

Flip
Cls
Wend

End


Hi codeman, check this code to see if it can help you.

Code: [Select]

Graphics 640,480,32,2
SetBuffer BackBuffer()

choice = 1

While Not KeyHit( 28 )

 Cls

 Select choice
 Case 1:
  Text 250,330, "> Full Screen"
  Text 250,345, "  Windowed"
 Case 2:
  Text 250,330, "  Full Screen"
  Text 250,345, "> Windowed"
 End Select

 Text 210,370,"Use cursor up/down then press"
 Text 210,380,"enter to choose screen size"

 If KeyHit( 200 ) Then choice = 1
 If KeyHit( 208 )  Then choice = 2

 Flip

Wend


Code: [Select]

Graphics 800,600,32,choice
SetBuffer BackBuffer()

While Not KeyHit(1)
 Text 300,300,"HELLO"
 Flip
Wend


Cheers guys for the reply

@ Alieneye0 ...
cheers for ya help m8 but couldnt get it to work , just crashed me blitz .. Appreciate the help thou m8

@ Rbraz .. Excellent m8 just what i wanted ...

CoDeMaN

12

Blitz / Hang-man game.[BB2D]

« on: May 17, 2006 »

Original post from The Lost Coder, taken from the ezboard forum.

Hey I'm new here and was wondering could ya help me out with something. I'm trying to make a game but I don't know how to make the slash for the letter to appear under. Here is a function I have made but I don't know if it is good.

Repentance function

Code: [Select]

Function Repentance()

FadeScreen_1()

Quit=input("Do you wish to continue (y/n): ";)

If Quit="n" or Quit="N"

Continue=False

Else

Hell()

EndIf

End Function
Also I want to have a fading screen that words fade in and about a couple of millisecs later the words (do you wish to continue) will pop up. And will wait until the user press y or n then slowly fade the screen out. How do I accomplish this task or can one of ya do this part for me and I will put you in my credit slide

Hang-man game Hi there, I think your after a flashing cursor after the input message.

Take a look around the code archives and see if any of the fader routines in there are of any use to you.

Okay I found one but I want to do it with a picture and I how do I make an accurate loading bar while showing my LOGO for the game.

As for a blinker after the text, what you'll want to do is have a timer and a boolean (3 variables all together). You will have variable "time = millisecs()", "timer = [some number of milliseconds, preferably 100-200] ", and "flash", all integers. Now, instead of the dreaded Quit() command which makes things sloppy and unprofessional, write your own. This isn't hard. Basically you have a loop going until the enter/return key is hit. Inside the loop you will have code to add characters to a string variable. Also, with the timers and "flash" variables mentioned earlier, here's what you do. Inside the loop, just before the question being asked followed by the answer is displayed, you will check if millisecs() is greater than or equal to time + timer. If so, make time = millisecs() and flash = not flash. Then, when you're writing the question passed to the routine, you'll write a string with a space on the end if flash = 0, else if flash = 1 you'll have a slash on the end instead of a space. Apologies if that was a bit vague, it's very late

For the loading bar, I haven't come up with an efficient and smooth running one in Blitz.

13

Blitz / Fake 3D Track (ez)[BB2D]

« on: May 17, 2006 »

Original post from Thygrion, taken from the ezboard forum


Hey guys, I figured you guys would want to have a look at some code from my game. But be warned, this will probably be the only code you'll get!!!

Also if you uncomment all the "bgimage" lines you can have a tiled bg. I took it out so I wouldn't have to go through all the trouble of zipping, emailing, & waiting for this to be hosted.

 

; Fake 3D Track Test

AppTitle "Fake 3D Track Test"

Const width = 640
Const height = 480

Graphics width,height,0,2
SetBuffer BackBuffer()

Type seg
        Field x#
        Field y#
        Field z#
        Field cx#
        Field cy#
        Field cz#
        Field an#
        Field can#
        Field sx1#
        Field sx2#
        Field sy#
        Field lw#
        Field c
End Type

Dim track.seg(1)

Global segments

;Global bgimage = LoadImage("bg1.bmp")
Global trackimage = CreateImage(256,256)
;If ImageWidth(bgimage) <> width Or ImageHeight(bgimage) <> height Then ResizeImage bgimage,width,height

Global segwidth# = Float(Float(Float(width) / 640.0) * 400.0)
Global linewidth# = Float(Float(segwidth# / 500.0) * 22.0)

Global lex#
Global grz#

Global maxvel# = .6;.97
Global gforce# = .7

Global bgx

Global px#
Global py# = .4
Global pz#
Global pan#
Global pvel#
Global pseg
Global psegs#
Global plan#

;Global audio = PlayMusic("race.xm")
;ChannelVolume audio,.6

setuptrack(30)
setuptrackimage()

While Not KeyDown(1)
Cls

;TileBlock bgimage,bgx,0
drawtrack()
DrawImage trackimage,7,7

;pseg = pseg + 1
psegs# = psegs# + pvel#
If psegs# >= 1.0
        psegs# = psegs# - 1.0
        pseg = pseg + 1
EndIf
pseg2 = pseg + 1
If pseg < 0 Then pseg = pseg + segments
If pseg >= segments Then pseg = pseg - segments
If pseg2 >= segments Then pseg2 = pseg2 - segments
ps# = Float(1.0 - psegs#)
psx# = Float(track(pseg)\x# * ps#) + Float(track(pseg2)\x# * psegs#)
psz# = Float(track(pseg)\z# * ps#) + Float(track(pseg2)\z# * psegs#)
Color 200,200,200
Oval Int(Float(psx# - lex#) * 2.0) + 7,Int(-Float(psz# - grz#) * 2.0) + 7,5,5
Color 0,0,0
Oval Int(Float(psx# - lex#) * 2.0) + 7,Int(-Float(psz# - grz#) * 2.0) + 7,5,5,0
aan# = track(pseg)\an#
ban# = track(pseg2)\an#
If aan# >= 270.0 And ban# <= 0 Then aan# = aan# - 360.0
plan# = pan#
pan# = Float(aan# * Float(1.0 - psegs#)) + Float(ban# * psegs#)
If plan# >= 270.0 And pan# <= 0 Then plan# = plan# - 360.0
v# = Float(pvel# * .06)
If KeyDown(203) Then px# = px# - v#
If KeyDown(205) Then px# = px# + v#
px# = px# + Float(Float(Float(plan# - pan#) * v#) * gforce#)
If px# < -1.0 Then px# = -1.0
If px# > 1.0 Then px# = 1.0
If KeyDown(200)
        pvel# = pvel# + .01
        If pvel# > maxvel# Then pvel# = maxvel#
ElseIf pvel# > 0
        pvel# = pvel# - .006
        If pvel# < 0 Then pvel# = 0
EndIf

bgx = bgx + Int(Float(Float(plan# - pan#) * v#) * width)

Color 255,255,255
Text 2,2,pseg + "/" + segments

Flip
Wend
For i = 0 To segments - 1
        Delete track(i)
Next
;FreeImage bgimage
FreeImage trackimage
End

Function setuptrack(div)
Restore trackdata
Read segs
segments = segs * div
Dim track.seg(segments)
For i = 0 To segs - 1
        j = i * div
        track.seg(j) = New seg
        Read track(j)\x#
        Read track(j)\y#
        Read track(j)\z#
        Read track(j)\an#
        Read track(j)\cx#
        Read track(j)\cy#
        Read track(j)\cz#
        Read track(j)\can#
        track(j)\x# = Float(track(j)\x# * 10.0)
        track(j)\y# = Float(track(j)\y# * 10.0)
        track(j)\z# = Float(track(j)\z# * 10.0)
        track(j)\cx# = Float(track(j)\cx# * 10.0)
        track(j)\cy# = Float(track(j)\cy# * 10.0)
        track(j)\cz# = Float(track(j)\cz# * 10.0)
Next
c = False
For i = 0 To segs - 1
        j = i * div
        ax# = track(j)\x#
        ay# = track(j)\y#
        az# = track(j)\z#
        aan# = track(j)\an#
        bx# = track(j)\cx#
        by# = track(j)\cy#
        bz# = track(j)\cz#
        ban# = track(j)\can#
        j = i + 1
        If j >= segs Then j = j - segs
        j = j * div
        cx# = track(j)\x#
        cy# = track(j)\y#
        cz# = track(j)\z#
        can# = track(j)\an#
        If aan# >= 270.0 And can# <= 0 Then aan# = aan# - 360.0
;        bx# = Float(Float(ax# + cx#) * .5)
;        by# = Float(Float(ay# + cy#) * .5)
;        bz# = Float(Float(az# + cz#) * .5)
        ban# = Float(Float(aan# + can#) * .5)
        For j = 0 To div - 1
                k = (i * div) + j
                b# = Float(Float(j) / div)
                a# = Float(1.0 - b#)
                as# = Float(a# * a#)
                bs# = Float(b# * b#)
                track.seg(k) = New seg
                track(k)\x# = Float(ax# * as#) + Float(bx# * 2.0 * a# * b#) + Float(cx# * bs#)
                track(k)\y# = Float(ay# * as#) + Float(by# * 2.0 * a# * b#) + Float(cy# * bs#)
                track(k)\z# = Float(az# * as#) + Float(bz# * 2.0 * a# * b#) + Float(cz# * bs#)
                track(k)\an# = Float(aan# * as#) + Float(ban# * 2.0 * a# * b#) + Float(can# * bs#)
                track(k)\c = c
                c = Not c
        Next
Next
End Function

Function drawtrack()
m00# = Cos(pan#)
m01# = -Sin(pan#)
m10# = -m01#
m11# = m00#
ps# = Float(1.0 - psegs#)
pseg2 = pseg + 1
If pseg2 >= segments Then pseg2 = pseg2 - segments
psx# = Float(track(pseg)\x# * ps#) + Float(track(pseg2)\x# * psegs#)
psy# = Float(track(pseg)\y# * ps#) + Float(track(pseg2)\y# * psegs#)
psz# = Float(track(pseg)\z# * ps#) + Float(track(pseg2)\z# * psegs#)
For i = 0 To segments - 1
        tx# = track(i)\x# - psx#
        ty# = track(i)\y# - psy#
        tz# = track(i)\z# - psz#
        rx# = Float(tx# * m00#) + Float(tz# * m01#) - px#
        ry# = ty# - py#
        rz# = Float(tx# * m10#) + Float(tz# * m11#) - pz#
        w# = Float(segwidth# / rz#)
        sx = Int(Float(rx# / rz#) * 500.0) + (width Shr 1)
        track(i)\sy# = -Float(Float(ry# / rz#) * 500.0) + Float(height Shr 1)
        track(i)\sx1# = sx - Float(w# * .5)
        track(i)\sx2# = sx + Float(w# * .5)
        track(i)\lw# = Float(linewidth# / rz#)
Next
For i = pseg + 30 To pseg + 1 Step -1
        j = i
        If j >= segments Then j = j - segments
        k = j + 1
        If k >= segments Then k = k - segments
        If track(k)\c
                Color 0,125,0;200,110,140
        Else
                Color 0,150,0;200,160,200
        EndIf
        Rect 0,Int(track(k)\sy#),width,Int(track(j)\sy) - Int(track(k)\sy)
Next
LockBuffer
For i = pseg + 30 To pseg + 1 Step -1
        j = i
        If j >= segments Then j = j - segments
        k = j + 1
        If k >= segments Then k = k - segments
        If track(k)\c
                argb = $808080
        Else
                argb = $606060
        EndIf
        sx1# = Float(Float(track(k)\sx1# + track(j)\sx1#) * .5)
        sx2# = Float(Float(track(k)\sx2# + track(j)\sx2#) * .5)
        sy1# = track(k)\sy#
        sy2# = track(j)\sy#
        sy3# = Float(Float(sy1# + sy2#) * .5)
        lw1# = Float(track(k)\lw# * .5)
        lw2# = Float(track(j)\lw# * .5)
        lw3# = Float(Float(lw1# + lw2#) * .5)
        drawquad track(k)\sx1#,track(k)\sx2#,sy1#,track(j)\sx1#,track(j)\sx2#,sy2#,argb
        drawquad track(k)\sx1# - lw1#,track(k)\sx1#,sy1#,sx1# - lw3#,sx1#,sy3#,$FF0000
        drawquad track(k)\sx2#,track(k)\sx2# + lw1#,sy1#,sx2#,sx2# + lw3#,sy3#,$FF0000
        drawquad sx1# - lw3#,sx1#,sy3#,track(j)\sx1# - lw2#,track(j)\sx1#,sy2#,$FFFFFF
        drawquad sx2#,sx2# + lw3#,sy3#,track(j)\sx2#,track(j)\sx2# + lw2#,sy2#,$FFFFFF
Next
UnlockBuffer
End Function

Function setuptrackimage()
For i = 0 To segments - 1
        If track(i)\x# < lex# Then lex# = track(i)\x#
        If track(i)\z# > grz# Then grz# = track(i)\z#
Next
SetBuffer ImageBuffer(trackimage)
For i = 0 To segments - 1
        x = Int(Float(track(i)\x# - lex#) * 2.0)
        y = Int(-Float(track(i)\z# - grz#) * 2.0)
        Color 60,60,60
        Rect x + 3,y + 3,5,5
Next
For i = 0 To segments - 1
        x = Int(Float(track(i)\x# - lex#) * 2.0)
        y = Int(-Float(track(i)\z# - grz#) * 2.0)
        Color 130,130,130
        Rect x,y,5,5
Next
SetBuffer BackBuffer()
End Function

Function drawquad(x1#,x2#,y1#,x3#,x4#,y2#,argb)
sy1 = Int(y1#)
sy2 = Int(y2#)
h = sy2 - sy1
If h < 1 Then Return
sx1# = x1#
sx2# = x2#
sxi1# = Float(Float(x3# - x1#) / h)
sxi2# = Float(Float(x4# - x2#) / h)
If sy1 < 0 Then sy1 = 0
If sy2 >= height Then sy2 = height - 1
For y = sy1 To sy2
        lx = Int(sx1#)
        rx = Int(sx2#)
        If lx < 0 Then lx = 0
        If rx >= width Then rx = width - 1
        For x = lx To rx
                WritePixelFast x,y,argb
        Next
        sx1# = sx1# + sxi1#
        sx2# = sx2# + sxi2#
Next
End Function

.trackdata ; Basic Oval
Data 8
Data 0,0,0,0 ; 0
Data 0,0,.5,0
Data 0,0,1.0,0 ; 1
Data 0,0,2.0,45.0
Data 1.0,0,2.0,90.0 ; 2
Data 1.5,0,2.0,90.0
Data 2.0,0,2.0,90.0 ; 3
Data 3.0,0,2.0,135.0
Data 3.0,0,1.0,180.0 ; 4
Data 3.0,0,.5,180.0
Data 3.0,0,0,180.0 ; 5
Data 3.0,0,-1.0,225.0
Data 2.0,0,-1.0,270.0 ; 6
Data 1.5,0,-1.0,270.0
Data 1.0,0,-1.0,270.0 ; 7
Data 0,0,-1.0,-45.0

Hope you guys like it.


I just may be the best 13-year-old coder you've ever seen!

zawran
Zawran / TTD

Posts: 2136
(26/10/05 5:54)
Reply | Edit | Del
   New Post Re: Fake 3D Track Nice coding there. Brings back memories of outrun and games like it. I am guessing that you will be having scaling trees, signs and such on the side of the track every now and then, and that you are working on simulating hills and such.

Good work so far, keep at it. Looking forward to see where this one is going, could be really cool.

zac.interactive | Blog | Tutorials | Demos | Tools
zparticle
AMSTRAD CPC

Posts: 90
(26/10/05 16:32)
Reply | Edit | Del    New Post Re: Fake 3D Track That is very very cool. Thanks for sharing.

Thygrion
DBF: Coder

Posts: 299
(26/10/05 23:15)
Reply | Edit | Del    New Post Re: Fake 3D Track Right now I am working on hills, I have to get another angle of rotation into the mix which means a 3rd dimension in my rotational matrix and other things.

But if you don't want the angle, it is coded above to render tracks with hills, the camera just doesn't rotate to look up/down in front of you.

Yes, there will be scaled sprites around the track, also multi-laned tracks and other cars.

Really this should be a game to remember, if I can remember to finish it.

Glad you guys liked it!!!

Also, here's a new track to play with. Put this code after the lable .trackdata and before all other data statements:

 

Data 24
Data 0,0,0,90.0 ; 0
Data .5,0,0,0
Data 1.0,0,0,90.0 ; 1
Data 1.5,0,0,0
Data 2.0,0,0,90.0 ; 2
Data 2.5,0,0,0
Data 3.0,0,0,90.0 ; 3
Data 3.5,0,0,0
Data 4.0,0,0,90.0 ; 4
Data 4.5,0,0,0
Data 5.0,0,0,90.0 ; 5
Data 6.0,0,0,0
Data 6.0,0,-1.0,180.0 ; 6
Data 6.0,0,-1.5,0
Data 6.0,0,-2.0,180.0 ; 7
Data 6.0,0,-2.5,0
Data 6.0,0,-3.0,180.0 ; 8
Data 6.0,0,-4.0,0
Data 5.0,0,-4.0,270.0 ; 9
Data 4.0,0,-4.0,0
Data 4.0,0,-3.0,360.0 ; 10
Data 4.0,0,-2.5,0
Data 4.0,0,-2.0,360.0 ; 11
Data 4.0,0,-1.0,0
Data 3.0,0,-1.0,270.0 ; 12
Data 2.0,0,-1.0,0
Data 2.0,0,-2.0,180.0 ; 13
Data 2.0,0,-3.0,0
Data 1.0,0,-3.0,270.0 ; 14
Data .5,0,-3.0,0
Data 0,0,-3.0,270.0 ; 15
Data -.5,0,-3.0,0
Data -1.0,0,-3.0,270.0 ; 16
Data -1.5,0,-3.0,0
Data -2.0,0,-3.0,270.0 ; 17
Data -2.5,0,-3.0,0
Data -3.0,0,-3.0,270.0 ; 18
Data -4.0,0,-3.0,0
Data -4.0,0,-2.0,360.0 ; 19
Data -4.0,0,-1.5,0
Data -4.0,0,-1.0,0 ; 20
Data -4.0,0,0,0
Data -3.0,0,0,90.0 ; 21
Data -2.5,0,0,0
Data -2.0,0,0,90.0 ; 22
Data -1.5,0,0,0
Data -1.0,0,0,90.0 ; 23
Data -.5,0,0,0

Also you may wish to mess with the variable gforce#, which decides how much to push the car to the outside of the track around corners.


I just may be the best 13-year-old coder you've ever seen!

Hotshot1
GEFORCE 4

Posts: 768
(27/10/05 5:10)
Reply | Edit | Del    New Post Re: Fake 3D Track that is most impressive coding there and I knew it was hard to do Mode 7 in 2D blitzbasic.

This game you making remind me of OUTRUN ( Sega Saturn is best version for OUTRUN and yes I have got it =) )

Keep good work up and looking forward seeing you finish this master coding!

cheers

5H0CKW4VE
*Administrator*

Posts: 7968
(10/4/06 16:17)
Reply | Edit | Del
ezSupporter

   New Post Re: Fake 3D Track Nice and fast, reminds me of Pole Position but much smoother!



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

14

Blitz / Fireworks (ez)[BPLUS]

« on: May 17, 2006 »

Original post from Thygrion, taken from the ezboard forum

Yesterday was my birthday. I turned 14. Woo-hoo. I hate birthdays; I don't like throwing parties or receiving gifts I'll never use.
Anyway, I decided to code some Fireworks. to "celebrate".

Code: [Select]

AppTitle "Sweet Fireworks"

Const width = 640
Const height = 480

Graphics width,height,32,2
SetBuffer BackBuffer()

SeedRnd MilliSecs()

Type rocket
        Field x#
        Field y#
        Field z#
        Field xv#
        Field yv#
        Field zv#
        Field argb
        Field time
        Field timer
End Type

Type frag
        Field x#
        Field y#
        Field z#
        Field xv#
        Field yv#
        Field zv#
        Field r
        Field g
        Field b
        Field f#
        Field fv#
End Type

Dim stab(width,height)

Global sbank

Global camx#
Global camy#
Global camz# = -500.0

Global grav# = .01
Global damp# = .999

createrocket(camx#,camy#,camz# - 20.0)

For y = 0 To height - 1
        yi = y * width
        For x = 0 To width - 1
                stab(x,y) = (yi + x) Shl 2
        Next
Next

LockBuffer
sbank = LockedPixels()
UnlockBuffer

While Not KeyDown(1)
Cls

LockBuffer
fireworks()
UnlockBuffer

If KeyDown(203) Then camx# = camx# - 20.0
If KeyDown(205) Then camx# = camx# + 20.0
If KeyDown(200) Then camy# = camy# + 20.0
If KeyDown(208) Then camy# = camy# - 20.0
If KeyDown(30) Then camz# = camz# + 20.0
If KeyDown(44) Then camz# = camz# - 20.0
If KeyHit(57) Then createrocket(camx#,camy#,camz# - 20.0)
If KeyHit(28) Then createfrags(camx#,camy#,camz# + 20.0,Rand(-$FF000,$FFFFFF))

Flip
Wend
Delete Each rocket
Delete Each frag
End

Function createrocket(x#,y#,z#)
r.rocket = New rocket
r\x# = x#
r\y# = y#
r\z# = z#
txan# = Rnd(-5.0,15.0)
tyan# = Rnd(-10.0,10.0)
tzan# = 0;Rnd(360.0)
cx# = Cos(txan#)
sx# = Sin(txan#)
cy# = Cos(tyan#)
sy# = Sin(tyan#)
cz# = Cos(tzan#)
sz# = Sin(tzan#)
cxsy# = Float(cx# * sy#)
m20# = Float(sx# * sz#) - Float(cxsy# * cz#)
m21# = Float(sx# * cz#) + Float(cxsy# * sz#)
m22# = Float(cx# * cy#)
tz# = 6.0
r\xv# = Float(tz# * m20#)
r\yv# = Float(tz# * m21#)
r\zv# = Float(tz# * m22#)
r\argb = Rand(-$FF000,$FFFFFF)
r\timer = Rand(100,2000)
r\time = MilliSecs()
End Function

Function createfrags(x#,y#,z#,argb)
If argb > 0 And argb < $686868 Then argb = $686868
For i = 0 To 699
        f.frag = New frag
        f\x# = x#
        f\y# = y#
        f\z# = z#
        txan# = Rnd(360.0)
        tyan# = Rnd(360.0)
        tzan# = Rnd(360.0)
        cx# = Cos(txan#)
        sx# = Sin(txan#)
        cy# = Cos(tyan#)
        sy# = Sin(tyan#)
        cz# = Cos(tzan#)
        sz# = Sin(tzan#)
        cxsy# = Float(cx# * sy#)
        m20# = Float(sx# * sz#) - Float(cxsy# * cz#)
        m21# = Float(sx# * cz#) + Float(cxsy# * sz#)
        m22# = Float(cx# * cy#)
        tz# = Rnd(.5,1.0)
        f\xv# = Float(tz# * m20#)
        f\yv# = Float(tz# * m21#)
        f\zv# = Float(tz# * m22#)
        If argb < 0
                targb = Rand($686868,$FFFFFF)
        Else
                targb = argb
        EndIf
        f\r = (targb Shr 16) And %11111111
        f\g = (targb Shr 8) And %11111111
        f\b = targb And %11111111
        f\f# = 1.0
        f\fv# = Rnd(.0025,.025)
Next
End Function

Function fireworks()
For r.rocket = Each rocket
        r\x# = r\x# + r\xv#
        r\y# = r\y# + r\yv#
        r\z# = r\z# + r\zv#
        r\xv# = r\xv# * damp#
        r\yv# = r\yv# * damp#
        r\zv# = r\zv# * damp#
;        r\yv# = r\yv# + grav#
        rx# = r\x# - camx#
        ry# = r\y# - camy#
        rz# = r\z# - camz#
        If rz# > 1.0
                sx# = Float(Float(rx# / rz#) * 300.0) + Float(width Shr 1)
                sy# = Float(-Float(ry# / rz#) * 300.0) + Float(height Shr 1)
                wupixel(sx#,sy#,128)
                wupixel(sx# - 1.0,sy#,128)
                wupixel(sx# + 1.0,sy#,128)
                wupixel(sx#,sy# - 1.0,128)
                wupixel(sx#,sy# + 1.0,128)
        EndIf
        If MilliSecs() >= r\time + r\timer
                createfrags(r\x#,r\y#,r\z#,r\argb)
                Delete r
        EndIf
Next
For f.frag = Each frag
        f\x# = f\x# + f\xv#
        f\y# = f\y# + f\yv#
        f\z# = f\z# + f\zv#
        f\xv# = f\xv# * damp#
        f\yv# = f\yv# * damp#
        f\zv# = f\zv# * damp#
        f\yv# = f\yv# - grav#
        fx# = f\x# - camx#
        fy# = f\y# - camy#
        fz# = f\z# - camz#
        If fz# > 1.0
                sx# = Float(Float(fx# / fz#) * 300.0) + Float(width Shr 1)
                sy# = Float(-Float(fy# / fz#) * 300.0) + Float(height Shr 1)
                wupixel2(sx#,sy#,((f\r * f\f#) Shl 16) + ((f\g * f\f#) Shl 8) + (f\b * f\f#))
        EndIf
        f\f# = f\f# - f\fv#
        If f\f# <= 0 Then Delete f
Next
End Function

Function wupixel(wx#,wy#,c)
Local x = Floor(wx#)
Local y = Floor(wy#)
Local xd# = Float(wx# - Float(x))
Local yd# = Float(wy# - Float(y))
Local c1# = Float(Float(1.0 - xd#) * Float(1.0 - yd#))
Local c2# = Float(xd# * Float(1.0 - yd#))
Local c3# = Float(Float(1.0 - xd#) * yd#)
Local c4# = Float(xd# * yd#)
pixel x,y,c1# * c
pixel x + 1,y,c2# * c
pixel x,y + 1,c3# * c
pixel x + 1,y + 1,c4# * c
End Function

Function wupixel2(wx#,wy#,argb)
Local x = Floor(wx#)
Local y = Floor(wy#)
Local xd# = Float(wx# - Float(x))
Local yd# = Float(wy# - Float(y))
Local c1# = Float(Float(1.0 - xd#) * Float(1.0 - yd#))
Local c2# = Float(xd# * Float(1.0 - yd#))
Local c3# = Float(Float(1.0 - xd#) * yd#)
Local c4# = Float(xd# * yd#)
Local r = (argb Shr 16) And %11111111
Local g = (argb Shr 8) And %11111111
Local b = argb And %11111111
Local r1 = r * c1#
Local g1 = g * c1#
Local b1 = b * c1#
Local r2 = r * c2#
Local g2 = g * c2#
Local b2 = b * c2#
Local r3 = r * c3#
Local g3 = g * c3#
Local b3 = b * c3#
Local r4 = r * c4#
Local g4 = g * c4#
Local b4 = b * c4#
pixel2 x,y,(r1 Shl 16) + (g1 Shl 8) + b1
pixel2 x + 1,y,(r2 Shl 16) + (g2 Shl 8) + b2
pixel2 x,y + 1,(r3 Shl 16) + (g3 Shl 8) + b3
pixel2 x + 1,y + 1,(r4 Shl 16) + (g4 Shl 8) + b4
End Function

Function pixel(x,y,c)
If x < 0 Or x >= width Or y < 0 Or y >= height Or c <= 0 Then Return
bi = stab(x,y)
argb = PeekInt(sbank,bi)
If argb > 0
        r = ((argb Shr 16) And %11111111) + c
        g = ((argb Shr 8) And %11111111) + c
        b = (argb And %11111111) + c
        If r > 255 Then r = 255
        If g > 255 Then g = 255
        If b > 255 Then b = 255
        argb = (r Shl 16) + (g Shl 8) + b
Else
        If c > 255 Then c = 255
        argb = (c Shl 16) + (c Shl 8) + c
EndIf
If argb > $000000 Then PokeInt sbank,bi,argb
End Function

Function pixel2(x,y,argb)
If x < 0 Or x >= width Or y < 0 Or y >= height Or argb <= $000000 Then Return
r = (argb Shr 16) And %11111111
g = (argb Shr 8) And %11111111
b = argb And %11111111
bi = stab(x,y)
argb = PeekInt(sbank,bi)
If argb > 0
        r = ((argb Shr 16) And %11111111) + r
        g = ((argb Shr 8) And %11111111) + g
        b = (argb And %11111111) + b
EndIf
If r > 255 Then r = 255
If g > 255 Then g = 255
If b > 255 Then b = 255
argb = (r Shl 16) + (g Shl 8) + b
If argb > $000000 Then PokeInt sbank,bi,argb
End Function

Have fun, happy new year.

P.S. Please nobody steal those wu pixel routines!!

Thygrion: Fireworks Here's for all of you who choose not to buy B+. Like that style!

 

Code: [Select]

AppTitle "Sweet Fireworks"

Const width = 640
Const height = 480

Graphics width,height,32,2
SetBuffer BackBuffer()

SeedRnd MilliSecs()

Type rocket
        Field x#
        Field y#
        Field z#
        Field xv#
        Field yv#
        Field zv#
        Field argb
        Field time
        Field timer
End Type

Type frag
        Field x#
        Field y#
        Field z#
        Field xv#
        Field yv#
        Field zv#
        Field r
        Field g
        Field b
        Field f#
        Field fv#
End Type

Dim screen(width,height)

Global camx#
Global camy#
Global camz# = -500.0

Global grav# = .01
Global damp# = .999

createrocket(camx#,camy#,camz# - 20.0)

While Not KeyDown(1)
Cls

LockBuffer
fireworks()
UnlockBuffer

If KeyDown(203) Then camx# = camx# - 20.0
If KeyDown(205) Then camx# = camx# + 20.0
If KeyDown(200) Then camy# = camy# + 20.0
If KeyDown(208) Then camy# = camy# - 20.0
If KeyDown(30) Then camz# = camz# + 20.0
If KeyDown(44) Then camz# = camz# - 20.0
If KeyHit(57) Then createrocket(camx#,camy#,camz# - 20.0)
If KeyHit(28) Then createfrags(camx#,camy#,camz# + 20.0,Rand(-$FF000,$FFFFFF))

Flip
Wend
Delete Each rocket
Delete Each frag
End

Function createrocket(x#,y#,z#)
r.rocket = New rocket
r\x# = x#
r\y# = y#
r\z# = z#
txan# = Rnd(-5.0,15.0)
tyan# = Rnd(-10.0,10.0)
tzan# = 0;Rnd(360.0)
cx# = Cos(txan#)
sx# = Sin(txan#)
cy# = Cos(tyan#)
sy# = Sin(tyan#)
cz# = Cos(tzan#)
sz# = Sin(tzan#)
cxsy# = Float(cx# * sy#)
m20# = Float(sx# * sz#) - Float(cxsy# * cz#)
m21# = Float(sx# * cz#) + Float(cxsy# * sz#)
m22# = Float(cx# * cy#)
tz# = 6.0
r\xv# = Float(tz# * m20#)
r\yv# = Float(tz# * m21#)
r\zv# = Float(tz# * m22#)
r\argb = Rand(-$FF000,$FFFFFF)
r\timer = Rand(100,2000)
r\time = MilliSecs()
End Function

Function createfrags(x#,y#,z#,argb)
If argb > 0 And argb < $686868 Then argb = $686868
For i = 0 To 699
        f.frag = New frag
        f\x# = x#
        f\y# = y#
        f\z# = z#
        txan# = Rnd(360.0)
        tyan# = Rnd(360.0)
        tzan# = Rnd(360.0)
        cx# = Cos(txan#)
        sx# = Sin(txan#)
        cy# = Cos(tyan#)
        sy# = Sin(tyan#)
        cz# = Cos(tzan#)
        sz# = Sin(tzan#)
        cxsy# = Float(cx# * sy#)
        m20# = Float(sx# * sz#) - Float(cxsy# * cz#)
        m21# = Float(sx# * cz#) + Float(cxsy# * sz#)
        m22# = Float(cx# * cy#)
        tz# = Rnd(.5,1.0)
        f\xv# = Float(tz# * m20#)
        f\yv# = Float(tz# * m21#)
        f\zv# = Float(tz# * m22#)
        If argb < 0
                targb = Rand($686868,$FFFFFF)
        Else
                targb = argb
        EndIf
        f\r = (targb Shr 16) And %11111111
        f\g = (targb Shr 8) And %11111111
        f\b = targb And %11111111
        f\f# = 1.0
        f\fv# = Rnd(.0025,.025)
Next
End Function

Function fireworks()
For r.rocket = Each rocket
        r\x# = r\x# + r\xv#
        r\y# = r\y# + r\yv#
        r\z# = r\z# + r\zv#
        r\xv# = r\xv# * damp#
        r\yv# = r\yv# * damp#
        r\zv# = r\zv# * damp#
;        r\yv# = r\yv# + grav#
        rx# = r\x# - camx#
        ry# = r\y# - camy#
        rz# = r\z# - camz#
        If rz# > 1.0
                sx# = Float(Float(rx# / rz#) * 300.0) + Float(width Shr 1)
                sy# = Float(-Float(ry# / rz#) * 300.0) + Float(height Shr 1)
                wupixel(sx#,sy#,128)
                wupixel(sx# - 1.0,sy#,128)
                wupixel(sx# + 1.0,sy#,128)
                wupixel(sx#,sy# - 1.0,128)
                wupixel(sx#,sy# + 1.0,128)
        EndIf
        If MilliSecs() >= r\time + r\timer
                createfrags(r\x#,r\y#,r\z#,r\argb)
                Delete r
        EndIf
Next
For f.frag = Each frag
        f\x# = f\x# + f\xv#
        f\y# = f\y# + f\yv#
        f\z# = f\z# + f\zv#
        f\xv# = f\xv# * damp#
        f\yv# = f\yv# * damp#
        f\zv# = f\zv# * damp#
        f\yv# = f\yv# - grav#
        fx# = f\x# - camx#
        fy# = f\y# - camy#
        fz# = f\z# - camz#
        If fz# > 1.0
                sx# = Float(Float(fx# / fz#) * 300.0) + Float(width Shr 1)
                sy# = Float(-Float(fy# / fz#) * 300.0) + Float(height Shr 1)
                wupixel2(sx#,sy#,((f\r * f\f#) Shl 16) + ((f\g * f\f#) Shl 8) + (f\b * f\f#))
        EndIf
        f\f# = f\f# - f\fv#
        If f\f# <= 0 Then Delete f
Next
For y = 0 To height - 1
        For x = 0 To width - 1
                argb = screen(x,y)
                If argb > $000000 Then WritePixelFast x,y,argb : screen(x,y) = 0
        Next
Next
End Function

Function wupixel(wx#,wy#,c)
Local x = Floor(wx#)
Local y = Floor(wy#)
Local xd# = Float(wx# - Float(x))
Local yd# = Float(wy# - Float(y))
Local c1# = Float(Float(1.0 - xd#) * Float(1.0 - yd#))
Local c2# = Float(xd# * Float(1.0 - yd#))
Local c3# = Float(Float(1.0 - xd#) * yd#)
Local c4# = Float(xd# * yd#)
pixel x,y,c1# * c
pixel x + 1,y,c2# * c
pixel x,y + 1,c3# * c
pixel x + 1,y + 1,c4# * c
End Function

Function wupixel2(wx#,wy#,argb)
Local x = Floor(wx#)
Local y = Floor(wy#)
Local xd# = Float(wx# - Float(x))
Local yd# = Float(wy# - Float(y))
Local c1# = Float(Float(1.0 - xd#) * Float(1.0 - yd#))
Local c2# = Float(xd# * Float(1.0 - yd#))
Local c3# = Float(Float(1.0 - xd#) * yd#)
Local c4# = Float(xd# * yd#)
Local r = (argb Shr 16) And %11111111
Local g = (argb Shr 8) And %11111111
Local b = argb And %11111111
Local r1 = r * c1#
Local g1 = g * c1#
Local b1 = b * c1#
Local r2 = r * c2#
Local g2 = g * c2#
Local b2 = b * c2#
Local r3 = r * c3#
Local g3 = g * c3#
Local b3 = b * c3#
Local r4 = r * c4#
Local g4 = g * c4#
Local b4 = b * c4#
pixel2 x,y,(r1 Shl 16) + (g1 Shl 8) + b1
pixel2 x + 1,y,(r2 Shl 16) + (g2 Shl 8) + b2
pixel2 x,y + 1,(r3 Shl 16) + (g3 Shl 8) + b3
pixel2 x + 1,y + 1,(r4 Shl 16) + (g4 Shl 8) + b4
End Function

Function pixel(x,y,c)
If x < 0 Or x >= width Or y < 0 Or y >= height Or c <= 0 Then Return
;bi = stab(x,y)
argb = screen(x,y);PeekInt(sbank,bi)
If argb > 0
        r = ((argb Shr 16) And %11111111) + c
        g = ((argb Shr 8) And %11111111) + c
        b = (argb And %11111111) + c
        If r > 255 Then r = 255
        If g > 255 Then g = 255
        If b > 255 Then b = 255
        argb = (r Shl 16) + (g Shl 8) + b
Else
        If c > 255 Then c = 255
        argb = (c Shl 16) + (c Shl 8) + c
EndIf
If argb > $000000 Then screen(x,y) = argb;PokeInt sbank,bi,argb
End Function

Function pixel2(x,y,argb)
If x < 0 Or x >= width Or y < 0 Or y >= height Or argb <= $000000 Then Return
r = (argb Shr 16) And %11111111
g = (argb Shr 8) And %11111111
b = argb And %11111111
;bi = stab(x,y)
argb = screen(x,y);PeekInt(sbank,bi)
If argb > 0
        r = ((argb Shr 16) And %11111111) + r
        g = ((argb Shr 8) And %11111111) + g
        b = (argb And %11111111) + b
EndIf
If r > 255 Then r = 255
If g > 255 Then g = 255
If b > 255 Then b = 255
argb = (r Shl 16) + (g Shl 8) + b
If argb > $000000 Then screen(x,y) = argb;PokeInt sbank,bi,argb
End Function

Thygrion: Much slower though.

AlienEye0: Nice one dude!

5H0CKW4VE: Belated birthday greetings oh and the 3D fireworks rock

15

Blitz / Blitz2D / BMAX: Raytraced Bouncy Balls!!![BB2D]

« on: May 17, 2006 »

Original post from Thygrion, taken from the ezboard forum

Hey guys!

Last night, I started on a new project - Raytracing.

Originally, it only supported spheres, but then today I added planes into the mix.

Now what I have here are some raytraced spheres bouncing off a plane.

 

Code: [Select]

;
; Raytraced Bouncy Balls
;

AppTitle "Raytraced Bouncy Balls"

Const width = 320
Const height = 240

Graphics width,height,32,2
SetBuffer BackBuffer()

SeedRnd MilliSecs()

Type plane
        Field nx#
        Field ny#
        Field nz#
        Field dis#
        Field argb
End Type

Type sphere
        Field x#
        Field y#
        Field z#
        Field xv#
        Field yv#
        Field zv#
        Field argb
End Type

Dim p.plane(1)

Dim s.sphere(1)

Dim normalx#(width,height)
Dim normaly#(width,height)
Dim normalz#(width,height)

Global planes = 1

Global spheres = 3

Global sphererad# = 100.0
Global sphererad2# = Float(sphererad# * sphererad#)

Global camerax#
Global cameray#
Global cameraz# = -800.0

Global lightx#
Global lighty# = 800.0
Global lightz#

Global spec# = 10.0

Global grav# = .3
Global fric# = .25

setupplanes()

setupspheres()
s(0)\argb = $FF0000
s(1)\argb = $00FF00
s(2)\argb = $0000FF

setupnormals()

While Not KeyDown(1)
Cls

LockBuffer
raytrace()
UnlockBuffer

For i = 0 To spheres - 1
        s(i)\x# = s(i)\x# + s(i)\xv#
        s(i)\y# = s(i)\y# + s(i)\yv#
        s(i)\z# = s(i)\z# + s(i)\zv#
        s(i)\yv# = s(i)\yv# - grav#
        If s(i)\y# - sphererad# < -p(0)\dis#
                s(i)\y# = -p(0)\dis# + sphererad#
                s(i)\xv# = Float(s(i)\xv# * fric#)
                s(i)\yv# = Float(-s(i)\yv# * fric#)
                s(i)\zv# = Float(s(i)\zv# * fric#)
                If s(i)\xv# > -fric# Or s(i)\xv# < fric# Then s(i)\xv# = 0
                If s(i)\zv# > -fric# Or s(i)\zv# < fric# Then s(i)\zv# = 0
        EndIf
Next

If KeyDown(203) Then camerax# = camerax# - 50.0
If KeyDown(205) Then camerax# = camerax# + 50.0
If KeyDown(200) Then cameraz# = cameraz# + 50.0
If KeyDown(208) Then cameraz# = cameraz# - 50.0

Flip
Wend
For i = 0 To planes - 1
        Delete p(i)
Next
For i = 0 To spheres - 1
        Delete s(i)
Next
End

Function setupplanes()
Dim p.plane(planes)
For i = 0 To planes - 1
        p.plane(i) = New plane
        p(i)\ny# = 1.0
        p(i)\dis# = Float(sphererad# * 4.0)
        p(i)\argb = $686868;Rand($686868,$FFFFFF)
Next
End Function

Function setupspheres()
Dim s.sphere(spheres)
Local sr# = Float(sphererad# * 2.5)
;Local an# = Rnd(360.0)
;Local ani# = Float(360.0 / spheres)
For i = 0 To spheres - 1
        s.sphere(i) = New sphere
        s(i)\x# = Rnd(-sr#,sr#)
        s(i)\y# = Rnd(0,sphererad#)
        s(i)\z# = Rnd(-sr#,sr#)
        s(i)\xv# = Rnd(-5.0,5.0)
        s(i)\yv# = Rnd(-2.0,7.0)
        s(i)\zv# = Rnd(-5.0,5.0)
        s(i)\argb = Rand($686868,$FFFFFF)
;        an# = an# + ani#
Next
End Function

Function setupnormals()
Local nx#
Local ny#
Local nz# = 200.0
Local dis#
For y = 0 To height - 1
        ny# = Float(height Shr 1) - Float(y)
        For x = 0 To width - 1
                nx# = Float(width Shr 1) - Float(x)
                dis# = Sqr(Float(nx# * nx#) + Float(ny# * ny#) + Float(nz# * nz#))
                normalx#(x,y) = -Float(nx# / dis#)
                normaly#(x,y) = Float(ny# / dis#)
                normalz#(x,y) = Float(nz# / dis#)
        Next
Next
End Function

Function raytrace()
Local argb
For y = 0 To height - 1
        For x = 0 To width - 1
                argb = ray(camerax#,cameray#,cameraz#,normalx#(x,y),normaly#(x,y),normalz#(x,y),256)
                If argb <> $000000 Then WritePixelFast x,y,argb
        Next
Next
End Function

Function ray(ex#,ey#,ez#,evx#,evy#,evz#,c)
If c <= 32 Then Return
Local plane.plane
Local sphere.sphere
Local z# = 10000
Local svx#
Local svy#
Local svz#
Local ix#
Local iy#
Local iz#
Local nx#
Local ny#
Local nz#
Local rnx#
Local rny#
Local rnz#
Local lvx#
Local lvy#
Local lvz#
Local dxis#
Local ydis#
Local zdis#
Local dxis2#
Local ydis2#
Local zdis2#
Local dis#
Local dis2#
Local l#
Local c1
Local c2
Local c3
Local r
Local g
Local b
For i = 0 To planes - 1
        plane.plane = p(i)
        nx# = plane\nx#
        ny# = plane\ny#
        nz# = plane\nz#
        dis# = Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#))
        If dis# < 0
                dis2# = Float(-Float(plane\dis# + Float(Float(nx# * ex#) + Float(ny# * ey#) + Float(nz# * ez#))) / dis#)
                ix# = ex# + Float(evx# * dis2#)
                iy# = ey# + Float(evy# * dis2#)
                iz# = ez# + Float(evz# * dis2#)
                lvx# = Float(lightx# - ix#)
                lvy# = Float(lighty# - iy#)
                lvz# = Float(lightz# - iz#)
                dis# = Sqr(Float(lvx# * lvx#) + Float(lvy# * lvy#) + Float(lvz# * lvz#))
                lvx# = Float(lvx# / dis#)
                lvy# = Float(lvy# / dis#)
                lvz# = Float(lvz# / dis#)
                l# = Float(Float(nx# * lvx#) + Float(ny# * lvy#) + Float(nz# * lvz#))
                dis# = Float(Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#)) * 2.0)
                rnx# = evx# - Float(nx# * dis#)
                rny# = evy# - Float(ny# * dis#)
                rnz# = evz# - Float(nz# * dis#)
                c1 = Int(l# * 256.0)
                c2 = Int(Float(Float(rnx# * lvx#) + Float(rny# * lvy#) + Float(rnz# * lvz#))^spec# * 256.0)
                argb = plane\argb
                z# = dis2#
        EndIf
Next
For i = 0 To spheres - 1
        sphere.sphere = s(i)
        svx# = sphere\x# - ex#
        svy# = sphere\y# - ey#
        svz# = sphere\z# - ez#
        dis2# = Float(Float(svx# * evx#) + Float(svy# * evy#) + Float(svz# * evz#))
        dis# = Float(Float(svx# * svx#) + Float(svy# * svy#) + Float(svz# * svz#)) - Float(dis2# * dis2#)
        If dis# <= sphererad2#
                dis2# = dis2# - Sqr(sphererad2# - dis#)
                If dis2# > 0 And dis2# < z#
                        ix# = ex# + Float(evx# * dis2#)
                        iy# = ey# + Float(evy# * dis2#)
                        iz# = ez# + Float(evz# * dis2#)
                        nx# = Float(Float(ix# - sphere\x#) / sphererad#)
                        ny# = Float(Float(iy# - sphere\y#) / sphererad#)
                        nz# = Float(Float(iz# - sphere\z#) / sphererad#)
                        lvx# = Float(lightx# - ix#)
                        lvy# = Float(lighty# - iy#)
                        lvz# = Float(lightz# - iz#)
                        dis# = Sqr(Float(lvx# * lvx#) + Float(lvy# * lvy#) + Float(lvz# * lvz#))
                        lvx# = Float(lvx# / dis#)
                        lvy# = Float(lvy# / dis#)
                        lvz# = Float(lvz# / dis#)
                        l# = Float(Float(nx# * lvx#) + Float(ny# * lvy#) + Float(nz# * lvz#))
                        dis# = Float(Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#)) * 2.0)
                        rnx# = evx# - Float(nx# * dis#)
                        rny# = evy# - Float(ny# * dis#)
                        rnz# = evz# - Float(nz# * dis#)
                        c1 = Int(l# * 256.0)
                        c2 = Int(Float(Float(rnx# * lvx#) + Float(rny# * lvy#) + Float(rnz# * lvz#))^spec# * 256.0)
                        argb = sphere\argb
                        z# = dis2#
                EndIf
        EndIf
Next
If shadowed(ix#,iy#,iz#)
        c1 = 30
        c2 = 0
Else
        If c1 < 30 Then c1 = 30
        If c2 < 0 Then c2 = 0
EndIf
c3 = (c1 * c) Shr 8
r = ((argb And $FF0000) * c3) Shr 8
g = ((argb And $00FF00) * c3) Shr 8
b = ((argb And $0000FF) * c3) Shr 8
r = r + (c2 Shl 16)
g = g + (c2 Shl 8)
b = b + c2
If argb <> $000000 Then argb = ray(ix#,iy#,iz#,rnx#,rny#,rnz#,c - 32)
r = r + (argb And $FF0000)
g = g + (argb And $00FF00)
b = b + (argb And $0000FF)
If r > $FF0000
        r = $FF0000
Else
        r = r And $FF0000
EndIf
If g > $00FF00
        g = $00FF00
Else
        g = g And $00FF00
EndIf
If b > $0000FF
        b = $0000FF
Else
        b = b And $0000FF
EndIf
Return r Or g Or b
End Function

Function shadowed(x#,y#,z#)
Local plane.plane
Local sphere.sphere
Local shad = False
Local evx# = Float(lightx# - x#)
Local evy# = Float(lighty# - y#)
Local evz# = Float(lightz# - z#)
Local dis# = Sqr(Float(evx# * evx#) + Float(evy# * evy#) + Float(evz# * evz#))
Local dis2#
evx# = Float(evx# / dis#)
evy# = Float(evy# / dis#)
evz# = Float(evz# / dis#)
For i = 0 To planes - 1
        plane.plane = p(i)
        nx# = plane\nx#
        ny# = plane\ny#
        nz# = plane\nz#
        dis# = Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#))
        If dis# < 0
                shad = True
                i = planes - 1
        EndIf
Next
If shad = False
        For i = 0 To spheres - 1
                sphere.sphere = s(i)
                svx# = sphere\x# - x#
                svy# = sphere\y# - y#
                svz# = sphere\z# - z#
                dis2# = Float(Float(svx# * evx#) + Float(svy# * evy#) + Float(svz# * evz#))
                dis# = Float(Float(svx# * svx#) + Float(svy# * svy#) + Float(svz# * svz#)) - Float(dis2# * dis2#)
                If dis2# > 0 And dis# < sphererad2#
                        shad = True
                        i = spheres - 1
                EndIf
        Next
EndIf
Return shad
End Function

I just thought I'd share this with you, since it's not really fast enough for a demo.

Now I'll probably implement ray-poly collisions.

Enjoy!
Thygrion

Man that's really sweet! Thanks for posting it Jake.
This is where Blitz struggles really, I'd bet it would be a lot faster in C++ or purebasic.

Or maybe Frebasic.

Next time I talk to Fryer maybe he could translate it for me.

- Thygrion

Wow, that's a great effect

About speeding it up, you may want to talk to StoneMonkey on CW
he's done quite a lot of raytracing and he's got it quite fast now

Really cool effect!

Looking forward to see the fast version.

Thanks, guys!
@Turkwoyz, Stonemonkey = Fryer
- Thygrion

I was drawn to this topic because it's what I have been trying to make for ages.

I have lost interest in programming three times because of ray tracing, I'd get quite far with it and then just give up, I just ran this program and it works really, really well.

Well done and it's great that you have put the source in here for everyone to see for themselves how it is done.

Your code is very good Thygrion, amongst the best I've seen.
Well done.

Let's hope you don't lose heart this time and stick around a bit longer?

Great piece of code !!! i have translate it under bmax
just for fun
But i have a question ? it is possible to change light color ? Camera pointing ?

Filax, is this much faster using Bmax?

I'd be really interested to know.. Unfortunately I don't have Bmax but I'm looking to find my next programming language, looking at C++ and Purebasic at the moment but maybe if Bmax has the speed it would be worth considering?

Yes it's more speed ! i think that bmax is more speed than purebasic
I have try the two version , blitz3D and bmax, bmax is winner.

Do you see my question about light color ?

My guess is that you could change the light intensities by changing these masks;

Code: [Select]

If r > $FF0000
        r = $FF0000
Else
        r = r And $FF0000
EndIf
If g > $00FF00
        g = $00FF00
Else
        g = g And $00FF00
EndIf
If b > $0000FF
        b = $0000FF
Else
        b = b And $0000FF
EndIf
Return r Or g Or b
End Function

Not my code though so there may be a more elegant way of doing it

Hi

I have made this change, because bmax use some different
mask for argb color, this mask include an alpha parameter

ALPHA => RED => GREEN => BLUE

For this reason i have made this

Code: [Select]

If r > $00FF0000
   r = $00FF0000
Else
   r = r & $00FF0000
EndIf

        If g > $0000FF00
g = $0000FF00
        Else
g = g & $0000FF00
        EndIf

        If b > $000000FF
b = $000000FF
        Else
b = b & $000000FF
        EndIf

        Return $FF000000 | r | g | b
End Function

I'm searching for the light color but the code is a little bit confusing
for me

I'm searching too a solution to change or add the camera pointing ?
any idea ?

I'll have to have a play with it and see if I can work out what does what for you... Unless Jake comes back in the meantime. I'll look at this today.

Ok, I've worked out the light
Now I'll work out the camera, will post an in depth answer for you later on this evening

Fantastic !!! i'm playing like a child with your great piece of code

I have added a little stuf to make balle rebounce with key space !

And i have clean a little bit my previous code

Blitzmax code :
---------------------

Code: [Select]

Type TBBType

        Field _list:TList
        Field _link:TLink

        Method Remove()
                _list.remove Self
        End Method

End Type

Global sphere_list:TList=New TList
Global plane_list:TList=New TList

Const width = 320
Const height = 240

Graphics width,height,32,75

SeedRnd MilliSecs()

Global RenderImage:Timage=CreateImage(width,height,DYNAMICIMAGE)

Type bbplane Extends TBBType
Field nx#
Field ny#
Field nz#
Field dis#
Field argb
End Type

Type bbsphere Extends TBBType
Field x#
Field y#
Field z#
Field xv#
Field yv#
Field zv#
Field argb
End Type

Global planes = 1
Global spheres = 3

Global p:bbplane[planes+1]
Global s:bbsphere[spheres+1]

Global normalx#[width+1,height+1]
Global normaly#[width+1,height+1]
Global normalz#[width+1,height+1]

Global sphererad# = 100.0
Global sphererad2# = Float(sphererad# * sphererad#)

Global camerax# =0
Global cameray# =0
Global cameraz# = -800.0

Global lightx# = 0
Global lighty# = 800.0
Global lightz# = 0

Global spec# = 100.0

Global grav# = .3
Global fric# = .25

setupplanes()
setupspheres()
setupnormals()

While Not KeyHit(KEY_ESCAPE)
        Cls

        raytrace()
       
        'SetScale 1.1,1.1
        DrawImage RenderIMage,0,0
        'SetScale 1,1
       
        ' -----------------------
        ' Apply gravity to sphere
        ' -----------------------
        For i = 0 To spheres - 1
        s(i).x# = s(i).x# + s(i).xv#
        s(i).y# = s(i).y# + s(i).yv#
        s(i).z# = s(i).z# + s(i).zv#
        s(i).yv# = s(i).yv# - grav#
        If s(i).y# - sphererad# + sphererad#
        s(i).xv# = Float(s(i).xv# * fric#)
        s(i).yv# = Float(-s(i).yv# * fric#)
        s(i).zv# = Float(s(i).zv# * fric#)
        If s(i).xv# > -fric# Or s(i).xv# -fric# Or s(i).zv# - 50.0
        If KeyDown(KEY_RIGHT) Then camerax# = camerax# + 50.0
        If KeyDown(KEY_UP) Then cameraz# = cameraz# + 50.0
        If KeyDown(KEY_DOWN) Then cameraz# = cameraz# - 50.0
       
        ' --------------------
        ' Made jump the sphere
        ' --------------------
        If KeyHit(KEY_SPACE)
                For i = 0 To spheres - 1
                        s(i).yv# = Rnd(16,20)
                Next
        EndIf
       
               
        Flip
Wend

' --------
' Quit app
' --------
For i = 0 To planes - 1
        p(i).Remove()
Next

For i = 0 To spheres - 1
        s(i).Remove()
Next

End

' ---------------------
' Setup plane primitive
' ---------------------
Function setupplanes()
        For i = 0 To planes - 1
p:bbplane(i) = New bbplane
p(i).ny# = 1.0
' p(i).dis# = Float(sphererad# * 4.0)
p(i).dis# = 200
p(i).argb = Rand($686868,$FFFFFF)
        Next
End Function

' ----------------------
' Setup sphere primitive
' ----------------------
Function setupspheres()
        Local sr# = Float(sphererad# * 2.5)
        'Local an# = Rnd(360.0)
        'Local ani# = Float(360.0 / spheres)
       
        For i = 0 To spheres - 1
s:bbsphere(i) = New bbsphere

s(i).x# = Rnd(-sr#,sr#)
s(i).y# = Rnd(0,sphererad#)
s(i).z# = Rnd(-sr#,sr#)

s(i).xv# = Rnd(-10.0,10.0)
s(i).yv# = Rnd(-2.0,7.0)
s(i).zv# = Rnd(-10.0,10.0)

s(i).argb = Rand($111111,$FFFFFF)
                'an# = an# + ani#
        Next
End Function

Function setupnormals()
        Local nx#
        Local ny#
        Local nz# = 200.0
        Local dis#
       
        For y = 0 To height - 1
ny# = Float(height Shr 1) - Float(y)

        For x = 0 To width - 1
nx# = Float(width Shr 1) - Float(x)
dis# = Sqr(Float(nx# * nx#) + Float(ny# * ny#) + Float(nz# * nz#))
normalx#(x,y) = -Float(nx# / dis#)
normaly#(x,y) = Float(ny# / dis#)
normalz#(x,y) = Float(nz# / dis#)
Next
        Next
End Function

' ------------------
' Raytrace the image
' ------------------
Function raytrace()
        Local argb

        RenderMap=LockImage(RenderImage)
       
        For y = 0 To height - 1
For x = 0 To width - 1
                        argb = ray(camerax#,cameray#,cameraz#,normalx#(x,y),normaly#(x,y),normalz#(x,y),256)

                        If argb $00000000 Then WritePixel RenderMap,x,y,argb
Next
        Next

        UnlockImage (RenderImage)
        RenderMap=Null
End Function

' ----------------------
' Raytracing computation
' ----------------------
Function ray(ex#,ey#,ez#,evx#,evy#,evz#,c)
        If c = 32 Then Return
        Local plane:bbplane
        Local sphere:bbsphere
       
        Local z# = 10000
        Local svx#
        Local svy#
        Local svz#
        Local ix#
        Local iy#
        Local iz#
        Local nx#
        Local ny#
        Local nz#
        Local rnx#
        Local rny#
        Local rnz#
        Local lvx#
        Local lvy#
        Local lvz#
        Local dxis#
        Local ydis#
        Local zdis#
        Local dxis2#
        Local ydis2#
        Local zdis2#
        Local dis#
        Local dis2#
        Local l#
        Local c1
        Local c2
        Local c3

        Local a
        Local r
        Local g
        Local b

        For i = 0 To planes - 1
plane:bbplane = p(i)
nx# = plane.nx#
ny# = plane.ny#
nz# = plane.nz#
dis# = Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#))
If dis# + Float(Float(nx# * ex#) + Float(ny# * ey#) + Float(nz# * ez#))) / dis#)
ix# = ex# + Float(evx# * dis2#)
iy# = ey# + Float(evy# * dis2#)
iz# = ez# + Float(evz# * dis2#)
lvx# = Float(lightx# - ix#)
lvy# = Float(lighty# - iy#)
lvz# = Float(lightz# - iz#)
dis# = Sqr(Float(lvx# * lvx#) + Float(lvy# * lvy#) + Float(lvz# * lvz#))
lvx# = Float(lvx# / dis#)
lvy# = Float(lvy# / dis#)
lvz# = Float(lvz# / dis#)
l# = Float(Float(nx# * lvx#) + Float(ny# * lvy#) + Float(nz# * lvz#))
dis# = Float(Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#)) * 2.0)
rnx# = evx# - Float(nx# * dis#)
rny# = evy# - Float(ny# * dis#)
rnz# = evz# - Float(nz# * dis#)
c1 = Int(l# * 256.0)
c2 = Int(Float(Float(rnx# * lvx#) + Float(rny# * lvy#) + Float(rnz# * lvz#))^spec# * 256.0)
argb = plane.argb
z# = dis2#
EndIf
        Next

        For i = 0 To spheres - 1
sphere:bbsphere = s(i)
svx# = sphere.x# - ex#
svy# = sphere.y# - ey#
svz# = sphere.z# - ez#
dis2# = Float(Float(svx# * evx#) + Float(svy# * evy#) + Float(svz# * evz#))
dis# = Float(Float(svx# * svx#) + Float(svy# * svy#) + Float(svz# * svz#)) - Float(dis2# * dis2#)

                If dis# = sphererad2#
dis2# = dis2# - Sqr(sphererad2# - dis#)
If dis2# > 0 And dis2# + Float(evx# * dis2#)
iy# = ey# + Float(evy# * dis2#)
iz# = ez# + Float(evz# * dis2#)
nx# = Float(Float(ix# - sphere.x#) / sphererad#)
ny# = Float(Float(iy# - sphere.y#) / sphererad#)
nz# = Float(Float(iz# - sphere.z#) / sphererad#)
lvx# = Float(lightx# - ix#)
lvy# = Float(lighty# - iy#)
lvz# = Float(lightz# - iz#)
dis# = Sqr(Float(lvx# * lvx#) + Float(lvy# * lvy#) + Float(lvz# * lvz#))
lvx# = Float(lvx# / dis#)
lvy# = Float(lvy# / dis#)
lvz# = Float(lvz# / dis#)
l# = Float(Float(nx# * lvx#) + Float(ny# * lvy#) + Float(nz# * lvz#))
dis# = Float(Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#)) * 2.0)
rnx# = evx# - Float(nx# * dis#)
rny# = evy# - Float(ny# * dis#)
rnz# = evz# - Float(nz# * dis#)
c1 = Int(l# * 256.0)
c2 = Int(Float(Float(rnx# * lvx#) + Float(rny# * lvy#) + Float(rnz# * lvz#))^spec# * 256.0)
argb = sphere.argb
z# = dis2#
EndIf
EndIf
        Next

        If shadowed(ix#,iy#,iz#)
c1 = 30
c2 = 0
        Else
If c1 * c) Shr 8

        r = ((argb & $00FF0000) * c3) Shr 8
        g = ((argb & $0000FF00) * c3) Shr 8
        b = ((argb & $000000FF) * c3) Shr 8

        r = r + (c2 Shl 16)
        g = g + (c2 Shl 8)
        b = b + c2

        If argb $00000000 Then argb = ray(ix#,iy#,iz#,rnx#,rny#,rnz#,c - 32)

        r = r + (argb & $00FF0000)
        g = g + (argb & $0000FF00)
        b = b + (argb & $000000FF)

        If r > $00FF0000
r = $00FF0000
        Else
r = r & $00FF0000
        EndIf

        If g > $0000FF00
g = $0000FF00
        Else
g = g & $0000FF00
        EndIf

        If b > $000000FF
b = $000000FF
        Else
b = b & $000000FF
        EndIf

        Return $FF000000 | r | g | b
End Function

' --------------
' Compute shadow
' --------------
Function shadowed(x#,y#,z#)
        Local plane:bbplane
        Local sphere:bbsphere
        Local shad = False
        Local evx# = Float(lightx# - x#)
        Local evy# = Float(lighty# - y#)
        Local evz# = Float(lightz# - z#)
        Local dis# = Sqr(Float(evx# * evx#) + Float(evy# * evy#) + Float(evz# * evz#))
        Local dis2#
       
        evx# = Float(evx# / dis#)
        evy# = Float(evy# / dis#)
        evz# = Float(evz# / dis#)
       
        For i = 0 To planes - 1
plane:bbplane = p(i)
nx# = plane.nx#
ny# = plane.ny#
nz# = plane.nz#
dis# = Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#))
If dis# - 1
EndIf
        Next
       
        If shad = False
For i = 0 To spheres - 1
sphere:bbsphere = s(i)
svx# = sphere.x# - x#
svy# = sphere.y# - y#
svz# = sphere.z# - z#
dis2# = Float(Float(svx# * evx#) + Float(svy# * evy#) + Float(svz# * evz#))
dis# = Float(Float(svx# * svx#) + Float(svy# * svy#) + Float(svz# * svz#)) - Float(dis2# * dis2#)
If dis2# > 0 And dis# - 1
EndIf
Next
        EndIf
       
        Return shad
End Function


You can download an example executable with height balls + code
for check the FPS value

www.blitz3dfr.com/tempo/Raytrace.zip

I'm very interrested to increase this piece of code

I get an error on decompressing the zip says it's missing some bytes

I have re-upload the file

I get 3fps (low) to 10 fps(high) and it locked up after a while

But it looked great

Athlon XP2000 + @ 1.7 Ghz
ATI Radeon 9600, 256M

Another guy made a raytracer with pure basic

forums.purebasic.com/engl...sc&start=0

www.flipcode.com/articles...e02-07.png

No gfx card on this PC I'm on right now, will look at it asap!

Got it working here, as it's just onboard graphics I'm getting a really poor 1fps, I'll try it on the computer at home as soon as I can.

Great job though Filax, it looks to be in a higher resolution with more balls.

I hope that Thygrion coming soon to talk about this great piece of code

You could try and PM him, I think he's been pretty busy with school lately.

I tried the code on my fast PC and got 4fps

On my pc i get 12 FPS in 320/240

That's not bad fps at all.

The best thing what I can do for this code (today ) is *Precalculate* everything, so, hope it's usefull for someone...
Run at 60 fps here.

Code: [Select]

; Raytraced Bouncy Balls

AppTitle "Raytraced Bouncy Balls"

;------------------------ "Frame Per Second" -------------------------
Global iFPS, bSettime,iSecStart,iFrameCount,iFrameStart
;---------------------------------------------------------------------

Const width = 320
Const height = 240

Graphics width,height,32,2
SetBuffer BackBuffer()

SeedRnd MilliSecs()

Type plane
        Field nx#
        Field ny#
        Field nz#
        Field dis#
        Field argb
End Type

Type sphere
        Field x#
        Field y#
        Field z#
        Field xv#
        Field yv#
        Field zv#
        Field argb
End Type

Dim p.plane(1)

Dim s.sphere(1)

Dim normalx#(width,height)
Dim normaly#(width,height)
Dim normalz#(width,height)

Global planes = 1

Global spheres = 3

Global sphererad# = 100.0
Global sphererad2# = Float(sphererad# * sphererad#)

Global camerax#
Global cameray#
Global cameraz# = -1200.0

Global lightx#
Global lighty# = 800.0
Global lightz#

Global spec# = 10.0

Global grav# = .3
Global fric# = .25

setupplanes()

setupspheres()
s(0)\argb = $FF0000
s(1)\argb = $00FF00
s(2)\argb = $0000FF

setupnormals()

;------------------------------------- Screen Buffer -----------------------------------------------
Dim buffer(101,320,240)

PreCalculate()

;---------------------------------------------------------------------------------------------------
While Not KeyHit(1)

 Cls

 LockBuffer BackBuffer()
 For y = 0 To height - 1
  For x = 0 To width - 1
   pixel = buffer(frame,x,y)
   WritePixelFast x,y,pixel,BackBuffer()
  Next
 Next
 UnlockBuffer BackBuffer()

 If cnt = 0 Then
  frame = frame + 1
  If frame > 99 Then cnt = 1
 Else
  frame = frame - 1
  If frame < 1 Then cnt = 0
 EndIf

 FPS_Count(10,10,255,255,255)

 Flip; False

Wend
;---------------------------------------------------------------------------------------------------

For i = 0 To planes - 1
        Delete p(i)
Next
For i = 0 To spheres - 1
        Delete s(i)
Next
End

Function setupplanes()
Dim p.plane(planes)
For i = 0 To planes - 1
        p.plane(i) = New plane
        p(i)\ny# = 1.0
        p(i)\dis# = Float(sphererad# * 4.0)
        p(i)\argb = $686868;Rand($686868,$FFFFFF)
Next
End Function

Function setupspheres()
Dim s.sphere(spheres)
Local sr# = Float(sphererad# * 2.5)
;Local an# = Rnd(360.0)
;Local ani# = Float(360.0 / spheres)
For i = 0 To spheres - 1
        s.sphere(i) = New sphere
        s(i)\x# = Rnd(-sr#,sr#)
        s(i)\y# = Rnd(0,sphererad#)
        s(i)\z# = Rnd(-sr#,sr#)
        s(i)\xv# = Rnd(-5.0,5.0)
        s(i)\yv# = Rnd(-2.0,7.0)
        s(i)\zv# = Rnd(-5.0,5.0)
        s(i)\argb = Rand($686868,$FFFFFF)
;        an# = an# + ani#
Next
End Function

Function setupnormals()
Local nx#
Local ny#
Local nz# = 200.0
Local dis#
For y = 0 To height - 1
        ny# = Float(height Shr 1) - Float(y)
        For x = 0 To width - 1
                nx# = Float(width Shr 1) - Float(x)
                dis# = Sqr(Float(nx# * nx#) + Float(ny# * ny#) + Float(nz# * nz#))
                normalx#(x,y) = -Float(nx# / dis#)
                normaly#(x,y) = Float(ny# / dis#)
                normalz#(x,y) = Float(nz# / dis#)
        Next
Next
End Function

Function raytrace()
Local argb
For y = 0 To height - 1
        For x = 0 To width - 1
                argb = ray(camerax#,cameray#,cameraz#,normalx#(x,y),normaly#(x,y),normalz#(x,y),256)
                If argb <> $000000 Then WritePixelFast x,y,argb
        Next
Next
End Function

Function ray(ex#,ey#,ez#,evx#,evy#,evz#,c)
If c <= 32 Then Return
Local plane.plane
Local sphere.sphere
Local z# = 10000
Local svx#
Local svy#
Local svz#
Local ix#
Local iy#
Local iz#
Local nx#
Local ny#
Local nz#
Local rnx#
Local rny#
Local rnz#
Local lvx#
Local lvy#
Local lvz#
Local dxis#
Local ydis#
Local zdis#
Local dxis2#
Local ydis2#
Local zdis2#
Local dis#
Local dis2#
Local l#
Local c1
Local c2
Local c3
Local r
Local g
Local b
For i = 0 To planes - 1
        plane.plane = p(i)
        nx# = plane\nx#
        ny# = plane\ny#
        nz# = plane\nz#
        dis# = Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#))
        If dis# < 0
                dis2# = Float(-Float(plane\dis# + Float(Float(nx# * ex#) + Float(ny# * ey#) + Float(nz# * ez#))) / dis#)
                ix# = ex# + Float(evx# * dis2#)
                iy# = ey# + Float(evy# * dis2#)
                iz# = ez# + Float(evz# * dis2#)
                lvx# = Float(lightx# - ix#)
                lvy# = Float(lighty# - iy#)
                lvz# = Float(lightz# - iz#)
                dis# = Sqr(Float(lvx# * lvx#) + Float(lvy# * lvy#) + Float(lvz# * lvz#))
                lvx# = Float(lvx# / dis#)
                lvy# = Float(lvy# / dis#)
                lvz# = Float(lvz# / dis#)
                l# = Float(Float(nx# * lvx#) + Float(ny# * lvy#) + Float(nz# * lvz#))
                dis# = Float(Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#)) * 2.0)
                rnx# = evx# - Float(nx# * dis#)
                rny# = evy# - Float(ny# * dis#)
                rnz# = evz# - Float(nz# * dis#)
                c1 = Int(l# * 256.0)
                c2 = Int(Float(Float(rnx# * lvx#) + Float(rny# * lvy#) + Float(rnz# * lvz#))^spec# * 256.0)
                argb = plane\argb
                z# = dis2#
        EndIf
Next
For i = 0 To spheres - 1
        sphere.sphere = s(i)
        svx# = sphere\x# - ex#
        svy# = sphere\y# - ey#
        svz# = sphere\z# - ez#
        dis2# = Float(Float(svx# * evx#) + Float(svy# * evy#) + Float(svz# * evz#))
        dis# = Float(Float(svx# * svx#) + Float(svy# * svy#) + Float(svz# * svz#)) - Float(dis2# * dis2#)
        If dis# <= sphererad2#
                dis2# = dis2# - Sqr(sphererad2# - dis#)
                If dis2# > 0 And dis2# < z#
                        ix# = ex# + Float(evx# * dis2#)
                        iy# = ey# + Float(evy# * dis2#)
                        iz# = ez# + Float(evz# * dis2#)
                        nx# = Float(Float(ix# - sphere\x#) / sphererad#)
                        ny# = Float(Float(iy# - sphere\y#) / sphererad#)
                        nz# = Float(Float(iz# - sphere\z#) / sphererad#)
                        lvx# = Float(lightx# - ix#)
                        lvy# = Float(lighty# - iy#)
                        lvz# = Float(lightz# - iz#)
                        dis# = Sqr(Float(lvx# * lvx#) + Float(lvy# * lvy#) + Float(lvz# * lvz#))
                        lvx# = Float(lvx# / dis#)
                        lvy# = Float(lvy# / dis#)
                        lvz# = Float(lvz# / dis#)
                        l# = Float(Float(nx# * lvx#) + Float(ny# * lvy#) + Float(nz# * lvz#))
                        dis# = Float(Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#)) * 2.0)
                        rnx# = evx# - Float(nx# * dis#)
                        rny# = evy# - Float(ny# * dis#)
                        rnz# = evz# - Float(nz# * dis#)
                        c1 = Int(l# * 256.0)
                        c2 = Int(Float(Float(rnx# * lvx#) + Float(rny# * lvy#) + Float(rnz# * lvz#))^spec# * 256.0)
                        argb = sphere\argb
                        z# = dis2#
                EndIf
        EndIf
Next
If shadowed(ix#,iy#,iz#)
        c1 = 30
        c2 = 0
Else
        If c1 < 30 Then c1 = 30
        If c2 < 0 Then c2 = 0
EndIf
c3 = (c1 * c) Shr 8
r = ((argb And $FF0000) * c3) Shr 8
g = ((argb And $00FF00) * c3) Shr 8
b = ((argb And $0000FF) * c3) Shr 8
r = r + (c2 Shl 16)
g = g + (c2 Shl 8)
b = b + c2
If argb <> $000000 Then argb = ray(ix#,iy#,iz#,rnx#,rny#,rnz#,c - 32)
r = r + (argb And $FF0000)
g = g + (argb And $00FF00)
b = b + (argb And $0000FF)
If r > $FF0000
        r = $FF0000
Else
        r = r And $FF0000
EndIf
If g > $00FF00
        g = $00FF00
Else
        g = g And $00FF00
EndIf
If b > $0000FF
        b = $0000FF
Else
        b = b And $0000FF
EndIf
Return r Or g Or b
End Function

Function shadowed(x#,y#,z#)
Local plane.plane
Local sphere.sphere
Local shad = False
Local evx# = Float(lightx# - x#)
Local evy# = Float(lighty# - y#)
Local evz# = Float(lightz# - z#)
Local dis# = Sqr(Float(evx# * evx#) + Float(evy# * evy#) + Float(evz# * evz#))
Local dis2#
evx# = Float(evx# / dis#)
evy# = Float(evy# / dis#)
evz# = Float(evz# / dis#)
For i = 0 To planes - 1
        plane.plane = p(i)
        nx# = plane\nx#
        ny# = plane\ny#
        nz# = plane\nz#
        dis# = Float(Float(nx# * evx#) + Float(ny# * evy#) + Float(nz# * evz#))
        If dis# < 0
                shad = True
                i = planes - 1
        EndIf
Next
If shad = False
        For i = 0 To spheres - 1
                sphere.sphere = s(i)
                svx# = sphere\x# - x#
                svy# = sphere\y# - y#
                svz# = sphere\z# - z#
                dis2# = Float(Float(svx# * evx#) + Float(svy# * evy#) + Float(svz# * evz#))
                dis# = Float(Float(svx# * svx#) + Float(svy# * svy#) + Float(svz# * svz#)) - Float(dis2# * dis2#)
                If dis2# > 0 And dis# < sphererad2#
                        shad = True
                        i = spheres - 1
                EndIf
        Next
EndIf
Return shad
End Function

;-------------------------------------- Pre-Calc ---------------------------------------------------
Function PreCalculate()
Cls:Flip
For frame = 0 To 101-1
 For y = 0 To height - 1
        For x = 0 To width - 1
                 argb = ray(camerax#,cameray#,cameraz#,normalx#(x,y),normaly#(x,y),normalz#(x,y),256)
                 If argb <> $000000 Then buffer(frame,x,y) = argb
           
        Next
 Next
 For i = 0 To spheres - 1
        s(i)\x# = s(i)\x# + s(i)\xv#
        s(i)\y# = s(i)\y# + s(i)\yv#
        s(i)\z# = s(i)\z# + s(i)\zv#
        s(i)\yv# = s(i)\yv# - grav#
        If s(i)\y# - sphererad# < -p(0)\dis#
                s(i)\y# = -p(0)\dis# + sphererad#
                s(i)\xv# =  (s(i)\xv# * fric#)
                s(i)\yv# =  (-s(i)\yv# * fric#)
                s(i)\zv# =  (s(i)\zv# * fric#)
                If s(i)\xv# > -fric# Or s(i)\xv# < fric# Then s(i)\xv# = 0
                If s(i)\zv# > -fric# Or s(i)\zv# < fric# Then s(i)\zv# = 0
        EndIf
 Next
 
 Cls
 cnt = cnt + 1
 Text 70,100,"Wait a moment..."
 Text 200,100,cnt + "%"
 Flip

Next
End Function


;------------------------ "Frame Per Second" -------------------------
Function FPS_Count(xpos,ypos,fr,fg,fb)
Color fr,fg,fb
If bSettime = True
          iSecStart = MilliSecs()
          iFrameStart = iFrameCount
          bSettime = False
     EndIf 
     If MilliSecs() >= iSecStart + 1000
          iFPS = iFrameCount - iFrameStart
          bSettime = True
     EndIf
     iFrameCount = iFrameCount + 1     
;     If KeyDown(57) Then
 Text xpos,ypos,"FPS: " + Str iFPS
End Function


Excellent !!!! lol i will try to convert it under bmax soon

Dang, good idea Rbraz.

Gives me food for thought.
Lots of demos have precalc stuff in them, you could show a picture or something, or calculate it during static text displays if you wanted to have a ray traced part to a demo.

Very good !!!!!!!! Very good Effort as it ran 20FPS on my computer...

welldone

Very good !!!!!!!! Thanks for the speedup RBraz!

But I will still refrain from precalc in my demos; I like the raw speed better.

Hey guys,

REALLY glad you all enjoyed looking at this dumb little thing!

Filax, sorry, no light color changes. PM me if you wanna know how to code some.

Same with camera rotation; none.

Also I'm having trouble adding triangles into the mix; there's so much math involved that I frequently get lost in code and forget what I'm doing .

Anyway, I'm thinking of writing a tutorial in a few weeks on the subject.

I hope To have your new one about this !!

I have One question : Is it possible to change the camera pointing and rotation ?

Finally got polygons into the tracer. I won't put the code up yet, as it's too files; I load the scene seperately now.

Filax: It is possible, but not with that code. I know exactly how, and could teach you, tho.

Just PM me.

Awesome Damn,

That is honestly one of the coolest programs I've ever seen! It's too bad real-time raytracing is so slow, I think the effect is much sharper than the standard 3d methods. This is definately one thing I would like to try my hand at! I think I could do it too -- Because as far as I know(correct me please if I'm wrong) Isn't ray tracing just like raycasting -- Except that you cast rays for the entire screen, Rather than just the width of the screen? Like with raycasting on a 320 by 240 screen, You would only cast 320 rays, Where-as with raytracing, You would cast 320 times 240 rays right? Of course to get the lighting effects I'm sure takes a lot more calculations, But the basic effect would be like I described correct? Anywayz, Awesome job!

-Grim-

Awesome Grim,

Yes, in raytracing you shoot a ray for every pixel on the screen, and if it hits an object, you figure out where it hit, the normal for that point, if it's shadowed, lighting, reflected rays, things like that. But the intersections are much more complicated in raytracing than raycasting, because in raycasting walls are always perpendicular to the floor.

But once you code a raycaster, it makes things like raytracing much simpler.

16

Freebasic / Glitchy Freebasic program (ez)

« on: May 17, 2006 »

Original post from Shockwave, taken from the ezboard forum


Here's my first ever Freebasic program;

 

' First Attempt At A Demo In FB!
' Some Stars Will Hopefully Result From This.
' By Shockwave / DBF 2006.
'--------------------------------------------------------------------------

'--------------------------------------------------------------------------
' Open 640 X 480 True Colour Full Screen With Refresh Rate Of 70hz.
'--------------------------------------------------------------------------

SCREEN 18,32,2,1,70

IF NOT SCREENPTR THEN
        PRINT "Cannot Set Video Mode!"
        END
END IF

SCREENSET 1,0
'--------------------------------------------------------------------------
' Hide Mouse Pointer;
'--------------------------------------------------------------------------

SETMOUSE 1,1,0

'--------------------------------------------------------------------------
' Define Storage;
'--------------------------------------------------------------------------
DIM BUFF AS LONG PTR
BUFF=SCREENPTR
DIM SHARED A AS INTEGER :' USED FOR KEYPRESS .
DIM SHARED LP AS INTEGER :' USED AS LOOP COUNTER.
DIM SHARED STARS AS INTEGER: ' USED TO HOLD MAX NUMBER OF STARS.

DIM SHARED TX AS INTEGER
DIM SHARED TY AS INTEGER

'--------------------------------------------------------------------------
'   Change The Amount Of Stars By Altering This Number;
'--------------------------------------------------------------------------

STARS = 50000

DIM SHARED STX (1 TO STARS) AS DOUBLE
DIM SHARED STY (1 TO STARS) AS DOUBLE
DIM SHARED STZ (1 TO STARS) AS DOUBLE

'--------------------------------------------------------------------------
'   Generate Some Star Positions;
'--------------------------------------------------------------------------

FOR LP = 1 TO STARS STEP 1
'   Generate Random Numbers And Pull Halfway Into Negative Values To Distribute
'   Stars Around Origin In Centre; ( X + Y )

    STX (LP) = ((RND(1) * 20000)-10000 )
    STY (LP) = ((RND(1) * 20000)-10000 )
'   Z Position;
    STZ (LP) = ((RND(1) * 31))+1
   
NEXT


'--------------------------------------------------------------------------
' Main Loop;
'--------------------------------------------------------------------------

DO

'--------------------------------------------------------------------------
'   Do Starfield;
'--------------------------------------------------------------------------
SCREENLOCK
    FOR LP = 1 TO STARS STEP 1
       
        TX = (STX(LP) / STZ(LP)) + 320
        TY = (STY(LP) / STZ(LP)) + 240   
        IF (TX>0) AND (TX<640) AND (TY>0) AND (TY<480) THEN
            POKE INTEGER, BUFF+(TY*640)+TX,&hFFFFFF
        ELSE
        STX (LP) = INT((RND(1) * 20000)-10000 )
        STY (LP) = INT((RND(1) * 20000)-10000 )
        STZ (LP) = 32
        END IF
       
        STZ (LP) = STZ(LP) -0.3
       
    NEXT LP
SCREENUNLOCK
'--------------------------------------------------------------------------
'   Wait For Vertical Retrace ;
'--------------------------------------------------------------------------

    WAIT &H3DA,8
    SCREENCOPY   
    CLS
LOOP UNTIL INKEY$<>""
'--------------------------------------------------------------------------
' Main Loop Ends.
'--------------------------------------------------------------------------
END

I'm happy with the speed of the program, it seems easily within the refresh rate, no difference to execution speed even if I reduce the amount of stars to say 100.

The program judders, I thought it was because I was using PSET so I have changed the listing to use direct memory access to draw the dots as you'll see above, it still glitches.

Is this typical of FB programs or can something be done to smooth things out?

Thygrion? Rbraz? Help appreciated!

Thanks,

Nick.



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

VISIT DARK BIT FACTORY INTERACTIVE! (please!)

Clyde Radcliffe
Fuzzy Wuzzy

Posts: 18236
(15/4/06 14:17)
Reply | Edit | Del
   New Post Re: Glitchy Freebasic Program For some reason theres a problem with clearing and buffering the screen from what I can make out mate. The Cls I narrowed down as the culprit.

Ive ever so slightly adapted the code for you it looks more like a Blitz approach, and I hope it helps you dude.

 

'
' Stars For Shockwave
' By Clyde April '06
'

Option Static
Option Explicit

Randomize Timer

Const XRES=640
Const YRES=480

Const XRES2=XRES/2
Const YRES2=YRES/2

Const STARS=100

Dim Shared ScreenBuffer As UByte Ptr
Dim Shared RGBScreen( XRES, YRES )

Dim Shared As Double STX( STARS ), STY( STARS ), STZ( STARS )

Dim Shared As Integer LP, TX, TY, Col
Dim Shared x,y

Declare Sub SetupStars()
Declare Sub RunStars()
Declare Sub UpdateStars( Buffer As Ubyte Ptr )

SetupStars()
RunStars()
End


Sub SetupStars()
   
    '
    ' Initialize Screen 640x480x32 with Double buffering and fullscreen
    '
    Screenres XRES,YRES,32,1,1
    ScreenSet 0,1
   
    Setmouse ,,0
   
    ScreenBuffer = Screenptr()
   
    For LP = 1 To STARS
        '   Generate Random Numbers And Pull Halfway Into Negative Values To Distribute
        '   Stars Around Origin In Centre; ( X + Y )
        STX (LP) = ((RND(1) * 20000)-10000 )
        STY (LP) = ((RND(1) * 20000)-10000 )
        '   Z Position;
        STZ (LP) = ((RND(1) * 31))+1
   
    Next
   
End Sub


Sub RunStars()

    Dim Key As String

    While Key<>Chr(27)

        ScreenLock()
            UpdateStars( ScreenBuffer )
        ScreenUnlock()
   
        ScreenCopy()
   
        Key=Inkey()
   
    Wend

End Sub


Sub UpdateStars( Buffer As Ubyte Ptr )
   
    For LP = 1 TO Stars
       
        TX = (STX(LP) / STZ(LP)) + XRES2
        TY = (STY(LP) / STZ(LP)) + YRES2 
       
        If (TX>0) And (TX<640) And (TY>0) And (TY<480) Then
           
            RGBScreen( TX, TY )=&HFFFFFF
           
        Else
           
            STX (LP) = Int((RND(1) * 20000)-10000 )
            STY (LP) = Int((RND(1) * 20000)-10000 )
            STZ (LP) = 32
       
        End If
       
        STZ (LP) = STZ(LP) -0.3
       
    Next
   
    For y=0 to YRES-1
        For x=0 to XRES-1
             
            Col = RGBScreen( x,y )
           
            'If Col>0 Then
           
                Poke Integer, Buffer+(( y )*XRES+( x )) shl 2, Col
                RGBScreen( x, y )=0

            'End If
           
        Next
    Next
   
End Sub

rbraz
CBM 128

Posts: 165
(15/4/06 14:57)
Reply | Edit | Del
   New Post Re: Glitchy Freebasic Program I think that FB with vga mode isn't that good, try to use tinyptc instead. Below, check your code converted to use tinyptc, at first time you will see some glitches (probably read/write disk access), after that it will run fine.

' First Attempt At A Demo In FB!
' Some Stars Will Hopefully Result From This.
' By Shockwave / DBF 2006.
' TinyPTC version by Rbraz
'--------------------------------------------------------------------------

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

'--------------------------------------------------------------------------
' Open 640 X 480
'--------------------------------------------------------------------------
If( ptc_open( "Stars", 640, 480 ) = 0 ) Then
End -1
End If

'--------------------------------------------------------------------------
' Hide Mouse Pointer;
'--------------------------------------------------------------------------
SETMOUSE 1,1,0

'--------------------------------------------------------------------------
' Declare sub-routines
'--------------------------------------------------------------------------
Declare Sub ClearScreen ()

'--------------------------------------------------------------------------
' Define Storage;
'--------------------------------------------------------------------------
Dim Shared As Integer Buffer( 640 * 480 )

DIM SHARED A AS INTEGER :' USED FOR KEYPRESS .
DIM SHARED LP AS INTEGER :' USED AS LOOP COUNTER.
DIM SHARED STARS AS INTEGER: ' USED TO HOLD MAX NUMBER OF STARS.

DIM SHARED TX AS INTEGER
DIM SHARED TY AS INTEGER

'--------------------------------------------------------------------------
' Change The Amount Of Stars By Altering This Number;
'--------------------------------------------------------------------------
STARS = 50000

DIM SHARED STX (1 TO STARS) AS DOUBLE
DIM SHARED STY (1 TO STARS) AS DOUBLE
DIM SHARED STZ (1 TO STARS) AS DOUBLE

'--------------------------------------------------------------------------
' Generate Some Star Positions;
'--------------------------------------------------------------------------
FOR LP = 1 TO STARS STEP 1
' Generate Random Numbers And Pull Halfway Into Negative Values To Distribute
' Stars Around Origin In Centre; ( X + Y )

STX (LP) = ((RND(1) * 20000)-10000 )
STY (LP) = ((RND(1) * 20000)-10000 )
' Z Position;
STZ (LP) = ((RND(1) * 31))+1

NEXT


'--------------------------------------------------------------------------
' Main Loop;
'--------------------------------------------------------------------------
DO

ClearScreen()

'--------------------------------------------------------------------------
' Do Starfield;
'--------------------------------------------------------------------------
FOR LP = 1 TO STARS STEP 1

TX = (STX(LP) / STZ(LP)) + 320
TY = (STY(LP) / STZ(LP)) + 240
IF (TX>0) AND (TX<640) AND (TY>0) AND (TY<480) THEN

'Update our temp buffer
Buffer(TX + (TY * 640)) = &hFFFFFF

ELSE
STX (LP) = INT((RND(1) * 20000)-10000 )
STY (LP) = INT((RND(1) * 20000)-10000 )
STZ (LP) = 32
END IF

STZ (LP) = STZ(LP) -0.3


NEXT LP

ScreenLock()
'Update PTC screen with temp buffer
Ptc_Update @Buffer(0)
ScreenUnlock()


LOOP UNTIL INKEY$<>""
'--------------------------------------------------------------------------
' Main Loop Ends.
'--------------------------------------------------------------------------
END

Sub ClearScreen()

Dim i as integer
for i = 0 to 640*480
Buffer(i) = 0
next

End Sub

Edited by: rbraz at: 15/4/06 14:59
5H0CKW4VE
*Administrator*

Posts: 7981
(15/4/06 16:08)
Reply | Edit | Del
ezSupporter

   New Post Re: Glitchy Freebasic Program Thanks fellas
The exe comes out at only 25kb with the tinyptc lib version too.



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

VISIT DARK BIT FACTORY INTERACTIVE! (please!)

5H0CKW4VE
*Administrator*

Posts: 7983
(15/4/06 18:35)
Reply | Edit | Del
ezSupporter

   New Post Re: Glitchy Freebasic Program Just Prettied it up ever so slightly..

' First Attempt At A Demo In FB!
' Some Stars Will Hopefully Result From This.
' By Shockwave / DBF 2006.
' TinyPTC version by Rbraz
'--------------------------------------------------------------------------

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

'--------------------------------------------------------------------------
' Open 640 X 480
'--------------------------------------------------------------------------
If( ptc_open( "Stars", 640, 480 ) = 0 ) Then
End -1
End If

'--------------------------------------------------------------------------
' Hide Mouse Pointer;
'--------------------------------------------------------------------------
SETMOUSE 1,1,0

'--------------------------------------------------------------------------
' Declare sub-routines
'--------------------------------------------------------------------------
Declare Sub ClearScreen ()

'--------------------------------------------------------------------------
' Define Storage;
'--------------------------------------------------------------------------
Dim Shared As Integer Buffer( 640 * 480 )

DIM SHARED CR , CR2 AS INTEGER : ' USED TO STORE COLOUR
DIM SHARED A , B AS INTEGER :' USED FOR KEYPRESS .
DIM SHARED LP AS INTEGER :' USED AS LOOP COUNTER.
DIM SHARED STARS AS INTEGER: ' USED TO HOLD MAX NUMBER OF STARS.

DIM SHARED TX AS INTEGER
DIM SHARED TY AS INTEGER

'--------------------------------------------------------------------------
' Change The Amount Of Stars By Altering This Number;
'--------------------------------------------------------------------------
STARS = 5000

DIM SHARED STX (1 TO STARS) AS DOUBLE
DIM SHARED STY (1 TO STARS) AS DOUBLE
DIM SHARED STZ (1 TO STARS) AS DOUBLE

'--------------------------------------------------------------------------
' Generate Some Star Positions;
'--------------------------------------------------------------------------
FOR LP = 1 TO STARS STEP 1
' Generate Random Numbers And Pull Halfway Into Negative Values To Distribute
' Stars Around Origin In Centre; ( X + Y )

STX (LP) = ((RND(1) * 20000)-10000 )
STY (LP) = ((RND(1) * 20000)-10000 )
' Z Position;
STZ (LP) = ((RND(1) * 31))+1

NEXT


'--------------------------------------------------------------------------
' Main Loop;
'--------------------------------------------------------------------------
DO

ClearScreen()

'--------------------------------------------------------------------------
' Do Starfield;
'--------------------------------------------------------------------------
FOR LP = 1 TO STARS STEP 1

TX = (STX(LP) / STZ(LP)) + 320
TY = (STY(LP) / STZ(LP)) + 240
IF (TX>1) AND (TX<639) AND (TY>1) AND (TY<479) AND (STZ(LP) > 0) THEN
A=INT(-STZ(LP) + 32) SHL 3
B=INT(-STZ(LP) + 32) SHL 1
CR=RGB ( A , A , A )
CR2=RGB ( B , B , B )

'Update our temp buffer

Buffer(TX + (TY * 640)) = CR
Buffer((TX-1) + (TY * 640)) = CR2
Buffer((TX+1) + (TY * 640)) = CR2
Buffer(TX + ((TY-1) * 640)) = CR2
Buffer(TX + ((TY+1) * 640)) = CR2

ELSE
STX (LP) = INT((RND(1) * 20000)-10000 )
STY (LP) = INT((RND(1) * 20000)-10000 )
STZ (LP) = 32
END IF

STZ (LP) = STZ(LP) -0.1


NEXT LP

ScreenLock()
'Update PTC screen with temp buffer
Ptc_Update @Buffer(0)
ScreenUnlock()


LOOP UNTIL INKEY$<>""
'--------------------------------------------------------------------------
' Main Loop Ends.
'--------------------------------------------------------------------------
END

Sub ClearScreen()

Dim i as integer
for i = 0 to 640*480
Buffer(i) = 0
next

End Sub

A few things I noticed when you changed the listing Rbraz, first there seems to be no wait for vertical retrace, second, what happened to the double buffering?

Is this now handled automatically by tinyptc?

Showing / Hiding the mouse seems to have no effect now, the mouse pointer is always hidden (not that it makes any difference!).

It runs totally smooth now with tinyptc, it's a very quick language, I like it already.

Does anyone know of any really small dlls to play tracker music? like smaller than fmod?

Thanks.



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

VISIT DARK BIT FACTORY INTERACTIVE! (please!)

Thygrion
DBF: Coder

Posts: 362
(16/4/06 5:04)
Reply | Edit | Del
   New Post Re: Glitchy Freebasic Program Try researching minifmod or email the Kolor or Exceed bunch.


Finally 14!!

5H0CKW4VE
*Administrator*

Posts: 7990
(16/4/06 16:04)
Reply | Edit | Del
ezSupporter

   New Post Re: Glitchy Freebasic Program Thanks dude.



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

VISIT DARK BIT FACTORY INTERACTIVE! (please!)

rbraz
CBM 128

Posts: 168
(16/4/06 20:56)
Reply | Edit | Del
   New Post Re: Glitchy Freebasic Program Tinyptc uses DirectDraw, and it doesn't need "ScreenLock() ScreenUnlock()" stuff (remove it), Tinyptc lock and unlock your directdraw surface automatically. About vertical retrace, I'm not sure, perhaps there be a way to do that, and lock the fps for a example to only 60 fps.



Oh, I was forgotten, use #define PTC_WIN above your tinyptc include to run into windowed mode.

#define PTC_WIN

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

Edited by: rbraz at: 16/4/06 21:05
5H0CKW4VE
*Administrator*

Posts: 7999
(16/4/06 23:13)
Reply | Edit | Del
ezSupporter

   New Post Re: Glitchy Freebasic Program Thanks for the tip



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

17

Freebasic / Tinypct question (ez)

« on: May 17, 2006 »

Original post from Shockwave, taken from the ezboard forum


Just a simple question about Tinypct, I've been playing with pixelwise stuff like starfields and plasmas, decided to see if I could combine it with some other stuff and fell flat.

It seems to me that tinypct simply provides a direct draw screen buffer. If this is the case, is there any way of using dd commands on it?

I am kind of hoping not and that everything will need to be poked into the buffer, this will give me a great excuse to develop a load of short routines to handle lines, sprites, polygons etc.

Probably if that's the case I'll release my sources here as I develop them.

In addition it may be a good time to start learning some gl and finally release some more demos.



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

VISIT DARK BIT FACTORY INTERACTIVE! (please!)

AlienEye0
*Administrator*

Posts: 172
(17/4/06 18:16)
Reply | Edit | Del
   New Post Re: Tinypct question. I think (there I go again) and I maybe wrong on this that once you link to dd through tinyptc you can make calls to any of the dd routines. I have looked at the stuff only since yesterday, so I might be waaaaaay off here. But if you look at the dd library you can see the routines - just like calling a function in basic or a standard .dll call I think.Someone let me know if I'm way off here as I'm interested too.


rbraz
CBM 128

Posts: 173
(17/4/06 19:43)
Reply | Edit | Del
   New Post Re: Tinypct question.

    Quote:..... is there any way of using dd commands on it?


    Quote:...link to dd through tinyptc you can make calls to any of the dd routines.


No, I'm sorry, Tinyptc have only pixel buffer to play with it.
You have only 3 commands:
1 - ptc_open
2 - ptc_update
3 - ptc_close

    Quote:I am kind of hoping not and that everything will need to be poked into the buffer, this will give me a great excuse to develop a load of short routines to handle lines, sprites, polygons etc.


Here's where the fun starts, we need to hard code all those stuff



Clyde Radcliffe
Fuzzy Wuzzy

Posts: 18249
(17/4/06 21:05)
Reply | Edit | Del
   New Post Re: Tinypct question. Ive had all sorts of problems myself with using TinyPTC, and have found that GFXLib the standard used graphics stuff that FB uses to be much better, its also alot better on FPS too.

I even used SDL to do a few things with, but its not that good. In my experience, as this maybe different for everyone, that it uses a different refresh rate, and gives me a borders at all sides of the screen. Asking questions on the official forums has resulted in not much cop, as many of them including the creator havent used many of the libs. Which i find a bit amusing.

There maybe some leaks and bug tweaking still left to do with the include binaries / libs for FB, as its still in beta form. They often state to visit the CVS Repositorty for updates to the libs etc. As what i find silly, is that they dont carry with new Freebasic updates.

rafryer
VIC 20

Posts: 11
(17/4/06 21:20)
Reply | Edit | Del    New Post tinyptc Basically all tiny_ptc does is copy (when ptc_update is called) data from an area of normal ram that you've set aside (Dimmed or allocated or whatever) to the page on the video card that's created when you called ptc_open.
In the ptc_test example program the @ in:

ptc_update @buffer(0)

means to copy starting from the memory address in normal ram of buffer element 0.

The area of memory you dim or allocate must be at least the size of a 32 bit instance of the screen you've opened (width*height*4 bytes) and you can make as many pages as memory'll allow. Some older gfx cards don't support 32 bit gfx and tinyptc will take the 32 bit data from your page and convert it appropriately for the display if that's the case so there's no need to make any changes to your code.

Fryer

5H0CKW4VE
*Administrator*

Posts: 8005
(17/4/06 23:29)
Reply | Edit | Del
ezSupporter

   New Post Re: tinyptc Thanks very much, that confirms what I thought.
Time to code a load of short stuff to do the mundane things.

Another advantage has got to be the smaller exe size too Clyde, tinyPCT exes are a good deal smaller. Speed wise it's faster than B+ so there's plenty of scope for textured vectors and alpha'd sprites etc I would think. That's just going from my tests where it can render a screen full of unoptimised plasma at full frame rate in 640 X 480.

B+ would struggle a little to do that... And the exe would be a few 100 k bigger too.



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

18

Freebasic / Squigly flower tunnel (ez)

« on: May 17, 2006 »

Original post from relsoft, taken from the ezboard forum


Squigly Flower Tunnel.... enjoy!

 

'squigly Flower tunnel
'relsoft 2006
'rel.betterwebber.com
defint a-z

OPTION EXPLICIT

'$include: 'tinyptc.bi'

declare sub DrawTunnel( Buffer() as integer, Texture() as integer,_
                       Tangle() as integer, Tdepth() as integer,_
                       byval addx as integer, byval addy as integer)
declare sub Init_Texture()
declare function wrapdist(x as single,y as single, px as single,py as single) as single
declare function dist (byval x as single,byval  y as single,_
                                            xc() as single, yc() as single,_
                                           byref nearest_dist as single        ) as single



const SCR_WIDTH = 320  * 1
const SCR_HEIGHT = 240 * 1
const SCR_SIZE = SCR_WIDTH * SCR_HEIGHT

const TWID = SCR_WIDTH
const THEI = SCR_HEIGHT
const TWIDM1 = TWID - 1
const THEIM1 = THEI - 1


const TEXT_XMAX = 256
const TEXT_YMAX = 256


const MAXPOINTS = 32

const XMID = SCR_WIDTH \ 2
const YMID = SCR_HEIGHT \ 2



const PI = 3.141593
const TWOPI = (2 * PI)


        dim shared Buffer( 0 to SCR_SIZE-1 ) as integer
        dim shared Tangle( TWID, THEI) as integer
        dim shared Tdepth( TWID, THEI) as integer
        dim shared Texture( 255, 255) as integer
        dim shared Distbuffer( 255, 255) as single
    dim shared xcoords(MAXPOINTS) as single
    dim shared ycoords(MAXPOINTS) as single



        if( ptc_open( "freeBASIC v0.01 - Blob demo(Relsoft)", SCR_WIDTH, SCR_HEIGHT ) = 0 ) then
                end -1
        end if

    randomize timer

    init_texture()
    dim t as single

    do
        t = timer
        DrawTunnel Buffer(), Texture(), Tangle(), Tdepth(), (TWID shr 1)* sin(t * .5),_
                   (t *. * (THEI shr 1)

        ptc_update @buffer(0)

    loop until inkey$""


        ptc_close

end


private sub DrawTunnel(Buffer() as integer, Texture() as integer,_
                       Tangle() as integer, Tdepth() as integer,_
                       byval addx as integer, byval addy as integer)

        dim pbuff, ptext as integer ptr
        dim x, y, tx, ty  as integer
   
    static as integer cx= 160, cy =120
    dim xdist as single
    dim cxmx, cymy, diamxscale as integer
    static frame as short
    static  as single fold_off = 0.02
    static  as single fold_scale = 0.07' * sin(timer / 512.0)
    static  as single fold_num = 5
    static  as single rad_factor = 0
    dim as integer diameter
    frame +=1
    diameter = 128
    diamxscale = 64 * diameter
    cx = (TWID\2)+ sin(addx/80)*70
        cy = (THEI\2)+ sin(addy/90)*70
    dim temp as short
    temp = 512/pi
    dim angle as single
    fold_off += 0.2   
    fold_scale = 0.5 * sin(frame / 40)   
   
        for y = 0 to THEIM1
        cymy = cy - y
                for x = 0 to TWIDM1
            cxmx = cx -x                         
            tx = int(angle * temp) + addx           
            xdist = sqr((cxmx*cxmx) + (cymy*cymy))
            angle = atan2(cymy,cxmx)
            'angle = angle + (((sin(fold_off + 7 * xdist/180)) * .5)+1)           
            angle = angle + (((sin(fold_off + 3 * xdist/180)) * .5)+1)
            xdist = xdist * ((sin(fold_off + fold_num * angle) * fold_scale)+1)           
            ty =  (diamxscale / xdist) + addy           
            tx = tx and 255
            ty = ty and 255
                        buffer( y * SCR_WIDTH + x) = texture(tx, ty)           
                next x
       
        next y


end sub

function dist ( byval x as single,byval  y as single,_
                                    xc() as single, yc() as single,_
                                byref nearest_dist as single        ) as single

    dim mindist as single
    dim max as integer
    dim d as single
    dim dx as single, dy as single
    dim diff as single
    dim i as integer
    mindist = 1D+32
    max = ubound(xc)
    for i = 0 to max
        dx = abs(xc(i) - x)
        dy = abs(yc(i) - y)
        if dx > TEXT_XMAX/2.0 then dx = TEXT_XMAX-dx
            if dy > TEXT_YMAX/2.0 then dy = TEXT_YMAX-dy
            d = sqr( dx*dx + dy*dy )
        if d * (TEXT_XMAX + 1)
        ycoords(i) = rnd * (TEXT_YMAX + 1)
    next i

    frame = 0

        dim mindist as single
        dim maxdist as single

          mindist = 1D+32
          maxdist = 0

                  dim tx as single
                  dim ty as single
                  dim x as integer
                  dim y as integer
                  dim distance as single
                  dim distance2 as single
                  dim nearest_dist as single
          for y = 0 to TEXT_YMAX - 1
          for x = 0 to TEXT_XMAX  - 1
              tx = x
              ty = y
              distance = dist(tx, ty, xcoords(), ycoords(), nearest_dist)
              distbuffer(x, y) = distance
              'distbuffer(x, y) = nearest_dist
              'distbuffer(x, y) = nearest_dist - distance
              'distbuffer(x, y) = sqr(nearest_dist * distance)
              'distbuffer(x, y) = sqr(nearest_dist^2 - distance^2)
              if distance  maxdist then maxdist = distance
          next x
          next y

                  dim c as single
                  dim as ubyte r,g, b
          for y = 0 to TEXT_YMAX - 1
          for x = 0 to TEXT_XMAX - 1
              c = (distbuffer(x, y) - mindist) / ((maxdist - mindist))
              'if c 'if c > 1.0 then c = 1.0
              r = 255 - (c * 255)
              g = (c * 255)
              b = 255 - (c * (r-255))
              texture(x , y) = r shl 16 or g shl 8 or b
          next x
          next y

end sub

[Edit - Smileys Edited out ~ SW]

Edited by: 5H0CKW4VE at: 23/4/06 16:06
5H0CKW4VE
*Administrator*

Posts: 8028
(23/4/06 16:12)
Reply | Edit | Del
ezSupporter

   New Post Re: Squigly Flower Tunnel.... Thanks for posting the source, I can't run it though.. I think that the smileys may have ruined it. I tried editing them out but still no joy :\
Going to turn off the emoticons in this forum, sorry.



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

VISIT DARK BIT FACTORY INTERACTIVE! (please!)

rbraz
CBM 128

Posts: 193
(23/4/06 17:21)
Reply | Edit | Del
   New Post Re: Squigly Flower Tunnel.... I can't run it too

AlienEye0
*Administrator*

Posts: 182
(23/4/06 18:00)
Reply | Edit | Del
   New Post Re: Squigly Flower Tunnel.... Can't run it either


jimshawx
ZX SPECTRUM

Posts: 40
(24/4/06 8:35)
Reply | Edit | Del    New Post is this it? I think it's supposed to look a bit like this (apologies if I messed it up) - cool psycho fx there from relsoft!

 

'squigly Flower tunnel
'relsoft 2006
'rel.betterwebber.com
defint a-z

OPTION EXPLICIT
'#define PTC_WIN
'$include: 'tinyptc.bi'

declare sub DrawTunnel( Buffer() as integer, Texture() as integer,_
                       Tangle() as integer, Tdepth() as integer,_
                       byval addx as integer, byval addy as integer)
declare sub Init_Texture()
declare function wrapdist(x as single,y as single, px as single,py as single) as single
declare function dist (byval x as single,byval  y as single,_
                                            xc() as single, yc() as single,_
                                           byref nearest_dist as single        ) as single



const SCR_WIDTH = 320  * 1
const SCR_HEIGHT = 240 * 1
const SCR_SIZE = SCR_WIDTH * SCR_HEIGHT

const TWID = SCR_WIDTH
const THEI = SCR_HEIGHT
const TWIDM1 = TWID - 1
const THEIM1 = THEI - 1


const TEXT_XMAX = 256
const TEXT_YMAX = 256


const MAXPOINTS = 32

const XMID = SCR_WIDTH \ 2
const YMID = SCR_HEIGHT \ 2



const PI = 3.141593
const TWOPI = (2 * PI)


        dim shared Buffer( 0 to SCR_SIZE-1 ) as integer
        dim shared Tangle( TWID, THEI) as integer
        dim shared Tdepth( TWID, THEI) as integer
        dim shared Texture( 255, 255) as integer
        dim shared Distbuffer( 255, 255) as single
    dim shared xcoords(MAXPOINTS) as single
    dim shared ycoords(MAXPOINTS) as single



        if( ptc_open( "freeBASIC v0.01 - Blob demo(Relsoft)", SCR_WIDTH, SCR_HEIGHT ) = 0 ) then
                end -1
        end if

    randomize timer

    init_texture()
    dim t as single

    do
        t = timer
        DrawTunnel Buffer(), Texture(), Tangle(), Tdepth(), (TWID shr 1)* sin(t * .5),_
                   (t *. * (THEI shr 1)

        ptc_update @buffer(0)

    loop until inkey$<>""


        ptc_close

end


private sub DrawTunnel(Buffer() as integer, Texture() as integer,_
                       Tangle() as integer, Tdepth() as integer,_
                       byval addx as integer, byval addy as integer)

        dim pbuff, ptext as integer ptr
        dim x, y, tx, ty  as integer
   
    static as integer cx= 160, cy =120
    dim xdist as single
    dim cxmx, cymy, diamxscale as integer
    static frame as short
    static  as single fold_off = 0.02
    static  as single fold_scale = 0.07' * sin(timer / 512.0)
    static  as single fold_num = 5
    static  as single rad_factor = 0
    dim as integer diameter
    frame +=1
    diameter = 128
    diamxscale = 64 * diameter
    cx = (TWID\2)+ sin(addx/80)*70
        cy = (THEI\2)+ sin(addy/90)*70
    dim temp as short
    temp = 512/pi
    dim angle as single
    fold_off += 0.2   
    fold_scale = 0.5 * sin(frame / 40)   
   
        for y = 0 to THEIM1
        cymy = cy - y
                for x = 0 to TWIDM1
            cxmx = cx -x                         
            tx = int(angle * temp) + addx           
            xdist = sqr((cxmx*cxmx) + (cymy*cymy))
            angle = atan2(cymy,cxmx)
            'angle = angle + (((sin(fold_off + 7 * xdist/180)) * .5)+1)           
            angle = angle + (((sin(fold_off + 3 * xdist/180)) * .5)+1)
            xdist = xdist * ((sin(fold_off + fold_num * angle) * fold_scale)+1)           
            ty =  (diamxscale / xdist) + addy           
            tx = tx and 255
            ty = ty and 255
                        buffer( y * SCR_WIDTH + x) = texture(tx, ty)           
                next x
       
        next y


end sub

function dist ( byval x as single,byval  y as single,_
                                    xc() as single, yc() as single,_
                                byref nearest_dist as single        ) as single
    dim mindist as single
    dim max as integer
    dim d as single
    dim dx as single, dy as single
    dim diff as single
    dim i as integer

    mindist = 1D+32
    max = ubound(xc)
    for i = 0 to max
        dx = abs(xc(i) - x)
        dy = abs(yc(i) - y)
        if dx > TEXT_XMAX/2.0 then dx = TEXT_XMAX-dx
            if dy > TEXT_YMAX/2.0 then dy = TEXT_YMAX-dy
            d = sqr( dx*dx + dy*dy )
'        if d > (TEXT_XMAX + 1) then
ycoords(i) = rnd * (TEXT_YMAX + 1)
    next i
return d
end function

sub init_texture()

        dim mindist as single
        dim maxdist as single

          mindist = 1D+32
          maxdist = 0

                  dim tx as single
                  dim ty as single
                  dim x as integer
                  dim y as integer
                  dim distance as single
                  dim distance2 as single
                  dim nearest_dist as single
          for y = 0 to TEXT_YMAX - 1
          for x = 0 to TEXT_XMAX  - 1
              tx = x
              ty = y
              distance = dist(tx, ty, xcoords(), ycoords(), nearest_dist)
              distbuffer(x, y) = distance
              'distbuffer(x, y) = nearest_dist
              'distbuffer(x, y) = nearest_dist - distance
              'distbuffer(x, y) = sqr(nearest_dist * distance)
              'distbuffer(x, y) = sqr(nearest_dist^2 - distance^2)
              if distance > maxdist then maxdist = distance
if distance < mindist then mindist = distance
          next x
          next y

                  dim c as single
                  dim as ubyte r,g, b
          for y = 0 to TEXT_YMAX - 1
          for x = 0 to TEXT_XMAX - 1
              c = (distbuffer(x, y) - mindist) / ((maxdist - mindist))
              'if c 'if c > 1.0 then c = 1.0
              r = 255 - (c * 255)
              g = (c * 255)
              b = 255 - (c * (r-255))
              texture(x , y) = r shl 16 or g shl 8 or b
          next x
          next y

end sub

Jim

5H0CKW4VE
*Administrator*

Posts: 8038
(24/4/06 16:23)
Reply | Edit | Del
ezSupporter

   New Post Re: is this it? Jim fixed it for you :-)

Looks pretty too.



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

VISIT DARK BIT FACTORY INTERACTIVE! (please!)

Clyde Radcliffe
Fuzzy Wuzzy

Posts: 18291
(24/4/06 20:48)
Reply | Edit | Del
   New Post Re: is this it? Awesome Squigly Tunnel biz Relsoft

rbraz
CBM 128

Posts: 196
(24/4/06 23:43)
Reply | Edit | Del
   New Post Re: is this it? Browsing the FB site, I found this :

www.freebasic.net/forum/viewtopic.php?t=3892

and this one:

www.freebasic.net/forum/viewtopic.php?t=3647

Nice work dude !

relsoft
ZX 81

Posts: 3
(25/4/06 14:17)
Reply | Edit | Del    New Post Re: is this it? Thanks guys. I've been nto tunnels ever since I could remember.

I've made tunnels using the method above, a fake method that used almost the same algo, a ratraced one, an opengl based one, etc.

I don't know why I liked tunnels so much. :*)
edit: added lighting and a better texture

Code: [Select]

[quote]'squigly Flower tunnel
'relsoft 2006
'rel.betterwebber.com
'added light ;*)
defint a-z

OPTION EXPLICIT

'$include: 'tinyptc.bi'

declare sub DrawTunnel( Buffer() as integer, Texture() as integer,_
Tangle() as integer, Tdepth() as integer,_
byval addx as integer, byval addy as integer)
declare sub Init_Texture()
declare function wrapdist(x as single,y as single, px as single,py as single) as single
declare function dist (byval x as single,byval y as single,_
xc() as single, yc() as single,_
byref nearest_dist as single ) as single



const SCR_WIDTH = 320 * 1
const SCR_HEIGHT = 240 * 1
const SCR_SIZE = SCR_WIDTH * SCR_HEIGHT

const TWID = SCR_WIDTH
const THEI = SCR_HEIGHT
const TWIDM1 = TWID - 1
const THEIM1 = THEI - 1


const TEXT_XMAX = 256
const TEXT_YMAX = 256


const MAXPOINTS = 32

const XMID = SCR_WIDTH \ 2
const YMID = SCR_HEIGHT \ 2



const PI = 3.141593
const TWOPI = (2 * PI)


dim shared Buffer( 0 to SCR_SIZE-1 ) as integer
dim shared Tangle( TWID, THEI) as integer
dim shared Tdepth( TWID, THEI) as integer
dim shared Texture( 255, 255) as integer
dim shared Distbuffer( 255, 255) as single
dim shared xcoords(MAXPOINTS) as single
dim shared ycoords(MAXPOINTS) as single



if( ptc_open( "freeBASIC v0.01 - Blob demo(Relsoft)", SCR_WIDTH, SCR_HEIGHT ) = 0 ) then
end -1
end if

randomize timer

init_texture()
dim t as single

do
t = timer
DrawTunnel Buffer(), Texture(), Tangle(), Tdepth(), (TWID shr 1)* sin(t * .5),_
(t *.8)* (THEI shr 1)

ptc_update @buffer(0)

loop until inkey$""


ptc_close

end


private sub DrawTunnel(Buffer() as integer, Texture() as integer,_
Tangle() as integer, Tdepth() as integer,_
byval addx as integer, byval addy as integer)

dim pbuff, ptext as integer ptr
dim x, y, tx, ty as integer

static as integer cx= 160, cy =120
dim xdist as single
dim cxmx, cymy, diamxscale as integer
static frame as short
static as single fold_off = 0.02
static as single fold_scale = 0.07' * sin(timer / 512.0)
static as single fold_num = 5
static as single rad_factor = 0
dim as integer diameter
frame +=1
diameter = 128
diamxscale = 64 * diameter
cx = (TWID\2)+ sin(addx/80)*70
cy = (THEI\2)+ sin(addy/90)*70
dim temp as short
temp = 512/pi
dim angle as single
fold_off += 0.2
fold_scale = 0.5 * sin(frame / 40)
dim as integer light
'dim as single maxdist=1/sqr(100*100+160*160)
for y = 0 to THEIM1
cymy = cy - y
for x = 0 to TWIDM1
cxmx = cx -x
xdist = sqr((cxmx*cxmx) + (cymy*cymy))
angle = atan2(cymy,cxmx)
tx = int(angle * temp) + addx
angle = angle + (((sin((fold_off+PI) + 3 * xdist/180)) * .3)+1)
xdist = xdist * ((sin(fold_off + fold_num * angle) * fold_scale)+1)
light = xdist * 5
if light > 255 then light = 255
light = 255 - light
ty = (diamxscale / xdist) + addy
tx = (tx) and 255
ty = (ty) and 255
buffer( y * SCR_WIDTH + x) = texture(tx, ty) or (light shl 16 or light shl 8 or light)
next x

next y


end sub

function dist ( byval x as single,byval y as single,_
xc() as single, yc() as single,_
byref nearest_dist as single ) as single

dim mindist as single
dim max as integer
dim d as single
dim dx as single, dy as single
dim diff as single
dim i as integer
mindist = 1D+32
max = ubound(xc)
for i = 0 to max
dx = abs(xc(i) - x)
dy = abs(yc(i) - y)
if dx > TEXT_XMAX/2.0 then dx = TEXT_XMAX-dx
if dy > TEXT_YMAX/2.0 then dy = TEXT_YMAX-dy
d = sqr( dx*dx + dy*dy )
if d * (TEXT_XMAX + 1)
ycoords(i) = rnd * (TEXT_YMAX + 1)
next i

frame = 0

dim mindist as single
dim maxdist as single

mindist = 1D+32
maxdist = 0

dim tx as single
dim ty as single
dim x as integer
dim y as integer
dim distance as single
dim distance2 as single
dim nearest_dist as single
for y = 0 to TEXT_YMAX - 1
for x = 0 to TEXT_XMAX - 1
tx = x
ty = y
distance = dist(tx, ty, xcoords(), ycoords(), nearest_dist)
distbuffer(x, y) = distance
'distbuffer(x, y) = nearest_dist
'distbuffer(x, y) = nearest_dist - distance
'distbuffer(x, y) = sqr(nearest_dist * distance)
'distbuffer(x, y) = sqr(nearest_dist^2 - distance^2)
if distance maxdist then maxdist = distance
next x
next y

dim c as single
dim as ubyte r,g, b
for y = 0 to TEXT_YMAX - 1
for x = 0 to TEXT_XMAX - 1
c = (distbuffer(x, y) - mindist) / ((maxdist - mindist))
'if c 'if c > 1.0 then c = 1.0
r = 255 - (c * 255)
g = (c * 255)
b = r'255 - (c * (r-255))
texture(x , y) = r shl 16 or g shl 8 or b
next x
next y

end sub[/quote]


Edited by: relsoft at: 25/4/06 15:57
5H0CKW4VE
*Administrator*

Posts: 8043
(25/4/06 16:02)
Reply | Edit | Del
ezSupporter

   New Post Re: is this it? Meh! I can't get that one working either!



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

VISIT DARK BIT FACTORY INTERACTIVE! (please!)

relsoft
ZX 81

Posts: 5
(25/4/06 16:09)
Reply | Edit | Del    New Post Re: is this it? Try this:

www.freebasic.net/forum/v...php?t=3892

5H0CKW4VE
*Administrator*

Posts: 8056
(27/4/06 15:47)
Reply | Edit | Del
ezSupporter

   New Post Re: is this it? It looks cool, but then I am a sucker for software rendered stuff.

btw, I think that the formatting tags of ezboard are messing up your source listings here. I can't think why it's happening to your source except that you may be posting the source and then going back in to edit the [ code ] tags in later? Just a thought because we appreciate any posts, especially those with code!



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

VISIT DARK BIT FACTORY INTERACTIVE! (please!)

Clyde Radcliffe
Fuzzy Wuzzy

Posts: 18309
(27/4/06 17:36)
Reply | Edit | Del
   New Post Re: is this it? And awesome work to boot. Any more where that came from Relsoft dude!

Wicked and Cheers,
Clyde.

19

Freebasic / Bitmap Text+Bitmap loader (ez)

« on: May 17, 2006 »

Original post from Rbraz, taken from the ezboard forum


 Here is a code to load your bitmap (256 color palette) font image and display it on screen, without any "dll".
This will help a lot of people, who are trying to code your first demo in FreeBasic.

Click here to get the source code + font example

 

'-------------------------
'  .: Bitmap Text :.
'         +
'  .: Font Loader :.
'
'  Using Bitmap 256 color
'  palette image
'
'  Whithout "DLL"s !!!
'
'-------------------------
'    by Rbraz 2006
'-------------------------

Option Explicit

'Windowed
#define PTC_WIN

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

'Screen constants
Const XRES=640                      'Screen Width
Const YRES=480                      'Screen Height
Const ARES=XRES * YRES              'Array Width

'BitmapFont constants
Const FontW=32                                                'Font Width
Const FontH=32                                                'Font Height
Const FontL=64                                                'Number Of letters in the font

'Sub Routines
Declare Sub Draw_Text(byval message as string, byval xpos as integer, byval ypos as integer, byval inc as integer)
Declare Sub LoadAnimImage( stringFilename As string, byval FrameW, byval FrameH )
Declare Sub DrawImage(byval xpos as integer, byval ypos as integer, byval character as integer, _
                      byval FrameW as integer, byval FrameH as integer)
Declare Sub Load_Bitmap(byval filename as string)
Declare Sub ClearScreen()
Declare Sub FPS_Count()

'Variables
Dim Shared Buffer(ARES) as integer                        'Tinyptc buffer
Dim Shared BitmapFont( FontW, FontH, FontL ) as integer   'Font buffer

'Bitmap (256 color palette) loader variables
ReDim Shared img_buffer(1) as ubyte                       'Bitmap Image buffer
Dim Shared img_r(256), img_g(256), img_b(256) as ubyte    'RGB color palette buffer
Dim Shared img_w, img_h as short                          'Image Width / Height

'FPS Counter
Dim Shared iFPS, bSettime,iSecStart,iFrameCount,iFrameStart as integer

'Image file name
Dim file_name as string
file_name="Media\Tilerred.bmp"

'Load our bitmap font
LoadAnimImage( file_name,FontW,FontH )
   
'Open TinyPTC window
If( ptc_open( "Bitmap Text + Font Loader", XRES, YRES ) = 0 ) Then
    End -1
End if

'Main Loop
While Inkey$() <> Chr$( 27 )
       
    ClearScreen()
   
    Draw_Text("FPS : "& iFPS,10,10,FontW)
   
    Draw_Text("BITMAP TEXT",132,150,FontW)
    Draw_Text("+",290,190,FontW)
    Draw_Text("FONT LOADER",132,230,FontW)
    Draw_Text("BY RBRAZ - 2006",90,320,FontW) 
   
    FPS_Count()
   
     
  Ptc_Update @Buffer(0)
 
Wend

'Close TinyPTC window
ptc_close()


'Draw text on screen
Sub Draw_Text(byval message as string, byval xpos as integer, byval ypos as integer, byval inc as integer)
    Dim a,i as integer
    Dim character as integer
    Dim char as string
    Dim alphatab as string

    For a=1 To Len(message)
        char = Mid$(message,a,1)
        character = Asc(char)-32  'Make sure that your font are into this range
        If (character>-1) And (character<FontL) then
            DrawImage(xpos,ypos,character,FontW,FontH)
        End If
        xpos=xpos+inc
    Next
End Sub

'Load frame images
Sub LoadAnimImage( Filename As string, _
                   byval FrameW, byval FrameH )
    Dim intX, intY, FrameWidth, FrameHeight, FrameNum
    Dim rect_x1, rect_x2, rect_y1, rect_y2, a, b
    Dim pixel
   
    'Load bitmap 256 color palette
    Load_Bitmap(Filename)

    FrameWidth   = img_w/FrameW
    FrameHeight  = img_h/FrameH
   
    FrameNum   = 0
    rect_x1    = 0
    rect_x2    = FrameW
    rect_y1    = 0
    rect_y2    = FrameH
   
    For b = 0 to FrameHeight-1
   
       For a = 0 to FrameWidth-1
       
         For intY = rect_y1 to rect_y2-1
       
             For intX = rect_x1 to rect_x2-1
         
                 pixel= img_buffer( intX + ( intY * img_w ) )
           
                 BitmapFont( intX Mod FrameW, intY Mod FrameH, FrameNum ) = (img_r(pixel) Shl 16) Or (img_g(pixel) Shl 8 )  Or img_b(pixel)
           
             Next 
             
         Next
   
         rect_x1 = rect_x2
         rect_x2 = rect_x2 + FrameW
         FrameNum = FrameNum + 1
         
       Next 
       
       rect_x1 = 0
       rect_x2 = FrameW
       rect_y1 = rect_y2
       rect_y2 = rect_y2 + FrameH
   
    Next   
End Sub

'Draw image into Buffer
Sub DrawImage(byval xpos as integer, byval ypos as integer, byval character as integer, _
              byval FrameW as integer, byval FrameH as integer)
Dim intX, intY As integer

    For intY=0 to FrameH-1
        For intX=0 to FrameW-1
           
            if (xpos+intX) < (XRES - 1) and (xpos+intX) > 0 then
               
                Buffer( ((intY+ypos) * XRES) + (intX+xpos)) = BitmapFont(intX, intY, character) 
           
            end if
        Next
    Next

end sub

'----------------------------------------
' For 256 color palette image only
'----------------------------------------
Sub Load_Bitmap(byval filename as string)
    Dim i,j,n,k,l,cnt as integer
    Dim Bmp_len, file as integer
    Dim byt as ubyte
 
    file = FreeFile
 
    OPEN filename FOR BINARY AS #file

    Get #file,19,img_w        ' bmp width
    Get #file,23,img_h        ' bmp height

    Bmp_len = img_w * img_h   ' Bmp size

    ReDim img_buffer(Bmp_len)
    Dim temp(Bmp_len)

    'Color palette
    cnt = 55
    For i = 0 To 255
        Get #file,cnt,byt
        img_b(i) = byt
        cnt+=1
        Get #file,cnt,byt
        img_g(i) = byt
        cnt+=1
        Get #file,cnt,byt
        img_r(i) = byt
        cnt+=2
    Next

    'Image pixels
    cnt = 1079
    For i = 0 To Bmp_len-1
        Get #file,cnt,byt
        img_buffer(i) = byt
        cnt+=1
    Next
 
    Close #file

    For i = -(Bmp_len-1)  To 0
        temp(j) = img_buffer(Abs(i))
        j = j + 1
    Next

    'Flip image
    Do
        For j = 0 To img_w
        k = (j + (n * img_w))
        l = ((img_w - j) + (n * img_w))
        img_buffer(l) = temp(k)
        Next
        n = n + 1
    Loop Until n = img_h

End Sub

Sub ClearScreen() 
    Dim i as integer
    for i = 0 to ARES
         Buffer(i) = 0
    next
End Sub

Sub FPS_Count()
         If bSettime = 1 then
          iSecStart = Timer() * 1000.0
          iFrameStart = iFrameCount
          bSettime = 0
     EndIf 
     If (Timer()*1000.0) >= iSecStart + 1000 then
          iFPS = iFrameCount - iFrameStart
          bSettime = 1
     EndIf
     iFrameCount = iFrameCount + 1     
End Sub

jimshawx
ZX SPECTRUM

Posts: 37
(22/4/06 3:01)
Reply | Edit | Del    New Post bmp loader Here's a little present. It should load any BMP file of any format into a 32bit texture. It uses Windows API and so it is very small.

 

' Jim's bmp decoder

option explicit

#define PTC_WIN

#include once "tinyptc.bi"
#include once "windows.bi"
#include once "crt.bi"

declare function LoadTexture(fname as string, byval tex as uinteger ptr) as Integer

dim buffer(640*480) as uinteger
loadtexture("monkeys.bmp", @buffer(0))

ptc_open("Bitmap Test", 640,480)

while inkey$ <> chr$(27)
        ptc_update @buffer(0)
wend

ptc_close()
end

type MYHEADER
      bmpi as BITMAPINFO
      masks(3) as RGBQUAD
end type

 
function LoadTexture(fname as string, byval tex as uinteger ptr) as Integer
        dim as HBITMAP bmp
        dim as HDC hdc
        DIM header AS MYHEADER

        memset(@header.bmpi, 0, sizeof(header.bmpi))
        header.bmpi.bmiHeader.biSize = sizeof(BITMAPINFOHEADER)
        bmp = cast(HBITMAP, LoadImage(NULL, fname, IMAGE_BITMAP, 0,0, LR_LOADFROMFILE))

        hdc = GetDC(NULL)

        GetDIBits(hdc, bmp, 0,0, NULL, @header.bmpi, 0)
        header.bmpi.bmiHeader.biBitCount = 32
        GetDIBits(hdc, bmp, 0, header.bmpi.bmiHeader.biHeight, tex, @header.bmpi, DIB_RGB_COLORS)

        ReleaseDC(NULL, hdc)
       
        rem only need this bit to flip it upside down
        dim line0 as uinteger ptr
        dim lineN as uinteger ptr
        lineN = tex+(header.bmpi.bmiHeader.biHeight-1)*header.bmpi.bmiHeader.biWidth
        line0 = tex
        dim as uinteger tmpln(1024)
        dim y as integer
        for y = 0 TO (header.bmpi.bmiHeader.biHeight/2)-1
                memcpy(@tmpln(0), line0, header.bmpi.bmiHeader.biWidth * sizeof(uinteger))
                memcpy(line0, lineN, header.bmpi.bmiHeader.biWidth * sizeof(uinteger))
                memcpy(lineN, @tmpln(0), header.bmpi.bmiHeader.biWidth * sizeof(uinteger))
                line0 = line0 + header.bmpi.bmiHeader.biWidth
                lineN = lineN - header.bmpi.bmiHeader.biWidth
        next
       
        return 1
end function

Jim

Clyde Radcliffe
Fuzzy Wuzzy

Posts: 18271
(22/4/06 9:38)
Reply | Edit | Del
   New Post Re: bmp loader Cool nice work there dudes.
Im trying to add bmps / pngs as a resource to the exe. So everythings more compact. Dont suppose you've sussed a solution out for that?

One again welldone,
Cheers - Clyde

jimshawx
ZX SPECTRUM

Posts: 38
(22/4/06 11:47)
Reply | Edit | Del    New Post resource loading It's a one-line change to make my example load bmp from resources, once you work out how to get them in. Shame Windows doesn't have any real image format support to draw on. Everyone uses jpeg6b and libpng libaries for image formats.

Jim

5H0CKW4VE
*Administrator*

Posts: 8016
(22/4/06 13:53)
Reply | Edit | Del
ezSupporter

   New Post Re: resource loading Thanks guys, I am sure these listings will be a huge help to people writing thier first FB stuff



¤´¨)
¸.·´¸.·*´¨) ¸.·*¨)
(¸.·´ (¸.·`¤... SHOCKWAVE / DBF...¤

VISIT DARK BIT FACTORY INTERACTIVE! (please!)

rbraz
CBM 128

Posts: 190
(22/4/06 17:41)
Reply | Edit | Del
   New Post Re: resource loading Nice one Jim

Yeah, to load it from resource it should be something like this:

    Quote:
    #define bmp1 115

    bmp = cast(HBITMAP, LoadImage(GetModuleHandle(NULL),MAKEINTRESOURCE(bmp1), IMAGE_BITMAP, 0, 0, LR_CREATEDIBSECTION))



    Quote:
    Resource.rc file
    bmp1 BITMAP "Image.bmp"



    Quote:
    And compile with:
    fbc Examples\LoadTexture.bas Examples\Resource.rc



But it doesn't work (Works fine in C++). Maybe there be an another way to do that...


Edited by: rbraz at: 22/4/06 17:49
jimshawx
ZX SPECTRUM

Posts: 39
(23/4/06 2:51)
Reply | Edit | Del    New Post load resources The problem is your .rc file doesn't know the value of bmp1. You need to add
#define bmp1 115
to the .rc file too.

Works fine after that.

Jim

Clyde Radcliffe
Fuzzy Wuzzy

Posts: 18286
(23/4/06 13:57)
Reply | Edit | Del
   New Post Re: load resources Im a tad confused with what 115 means and does.
Dont suppose you could knock up a listing of what to do for using resources please dudes?

And does that program also load in as anim images / tilesets?

Cheers and many thanks,
Clyde

Edited by: Clyde Radcliffe  at: 23/4/06 13:58
rbraz
CBM 128

Posts: 192
(23/4/06 17:18)
Reply | Edit | Del
   New Post Re: load resources Now it works fine Jim, thanks!

Just forgot when I create a resource file in C, i need to include the resource.h

And noticed that I need to remove quotes " " from the resouce file name.

To work you must run the compiled version (exe), doesn't work from IDE

----------------------Load Texture.bas ----------------------------------

 
' Jim's bmp decoder
'
' Added Loading from Resource
'

option explicit

#define PTC_WIN

#include once "tinyptc.bi"
#include once "windows.bi"
#include once "crt.bi"


declare function LoadTexture(byval tex as uinteger ptr) as Integer

dim buffer(640*480) as uinteger
loadtexture(@buffer(0))

ptc_open("Bitmap Test", 640,480)

while inkey$ <> chr$(27)
        ptc_update @buffer(0)
wend

ptc_close()
end

type MYHEADER
      bmpi as BITMAPINFO
      masks(3) as RGBQUAD
end type

 
function LoadTexture(byval tex as uinteger ptr) as Integer
        dim as HBITMAP bmp
        DIM header AS MYHEADER
       
        #define bmp1 115
       
        memset(@header.bmpi, 0, sizeof(header.bmpi))
        header.bmpi.bmiHeader.biSize = sizeof(BITMAPINFOHEADER)
        bmp = cast(HBITMAP, LoadImage(GetModuleHandle(NULL),MAKEINTRESOURCE(bmp1), IMAGE_BITMAP, 0, 0, LR_CREATEDIBSECTION))


        GetDIBits(GetDC(NULL), bmp, 0,0, NULL, @header.bmpi, 0)
        header.bmpi.bmiHeader.biBitCount = 32
        GetDIBits(GetDC(NULL), bmp, 0, header.bmpi.bmiHeader.biHeight, tex, @header.bmpi, DIB_RGB_COLORS)

       
        rem only need this bit to flip it upside down
        dim line0 as uinteger ptr
        dim lineN as uinteger ptr
        lineN = tex+(header.bmpi.bmiHeader.biHeight-1)*header.bmpi.bmiHeader.biWidth
        line0 = tex
        dim as uinteger tmpln(1024)
        dim y as integer
        for y = 0 TO (header.bmpi.bmiHeader.biHeight/2)-1
                memcpy(@tmpln(0), line0, header.bmpi.bmiHeader.biWidth * sizeof(uinteger))
                memcpy(line0, lineN, header.bmpi.bmiHeader.biWidth * sizeof(uinteger))
                memcpy(lineN, @tmpln(0), header.bmpi.bmiHeader.biWidth * sizeof(uinteger))
                line0 = line0 + header.bmpi.bmiHeader.biWidth
                lineN = lineN - header.bmpi.bmiHeader.biWidth
        next
       
        return 1
end function




-------------------- resource.rc --------------------------------

 
#define bmp1 115
bmp1 BITMAP C:\FreeBasic\Examples\Media\image.bmp



-------------------- Compile.bat --------------------------------
fbc Examples\LoadTexture.bas Examples\Resource.rc -s gui

pause

Clyde Radcliffe
Fuzzy Wuzzy

Posts: 18290
(23/4/06 19:15)
Reply | Edit | Del
   New Post Re: load resources Not yet tried all this out yet. Cool stuff dudes.

But what I'll tell you about getting it working in FBIDE, is that so long as you've got it associated with your .bas source code, if you double click from where the program listing is in Windows explorer, resources will work that way. And for some bug with FBIDE, not from opening up with it.

jimshawx
ZX SPECTRUM

Posts: 40
(23/4/06 23:47)
Reply | Edit | Del
   New Post Re: load resources 115 is just a number. Every resource needs a unique number, that's all. Valid numbers are 0 to 32767, or possibly 65535. I suspect Rbraz just plucked that one out of the ether.
You could change the function to pass in the resource number.

Jim