Qbasicnews.com › General › General/Misc v
Hehehehehe

Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Threaded Mode
Hehehehehe
relsoft Offline
Posting Freak
*****
Posts: 3,288
Threads: 167
Joined: Nov 2001
#1
02-19-2004, 11:02 AM
Code:
'Run this....
'Relsoft 2004
'Thanks to:
'Plasma for LIST2OP. Love the util my friend!!!
'Gradius for Multikey

'I remember Nek having a challenge of this type. :*)


DECLARE SUB AF.Cls (DestSeg%, c%)
DECLARE SUB AF.Mode7 (Layer%, x1%, y1%, x2%, y2%, Angle%, Scalex%, Scaley%, Scalez%, Horz%, camx!, camy!, Texture%(), TextureOffset%)
DECLARE FUNCTION MULTIKEY% (T%)
DECLARE SUB AF.Pcopy (DestSeg%, SRCSEG%)



DEFINT A-Z
REM $DYNAMIC


DEFINT A-Z

RANDOMIZE TIMER

TYPE KartType                   'our camera
    x       AS SINGLE
    y       AS SINGLE
    dx      AS SINGLE
    dy      AS SINGLE
    Angle   AS INTEGER
    speed   AS SINGLE
    accel   AS SINGLE
END TYPE


CONST FALSE = 0, TRUE = NOT FALSE
CONST VIDEO = &HA000

'KEY CONSTANTS
CONST KEYESC = 1, KEYENTER = 28, KEYSPACE = 57, KEYTAB = &HF
CONST KEYUP = 72, KEYDOWN = 80, KEYLEFT = 75, KEYRIGHT = 77

'not needed but used for easy reference
CONST PI = 3.141593
CONST FRICTION = .016                       'for pseudo physics
CONST TSIZE = 32                            'tilesize try to change this...
CONST TSIZESQUARED = TSIZE * TSIZE
CONST MAPTILEXMAX = 128
CONST MAPMAXPIXELX = MAPTILEXMAX * TSIZE
CONST MAPTILEYMAX = 64
CONST MAPMAXPIXELY = MAPTILEYMAX * TSIZE


'$DYNAMIC

DIM SHARED Vpage%(0 TO 31999)           'our buffer
DIM SHARED Layer%

'$STATIC
DIM SHARED Lcos!(359)                   'fast Lookups
DIM SHARED Lsin!(359)
DIM SHARED Texture%((((TSIZESQUARED%) + 4) \ 2))    'calc array size for
                                                    'GET array

Layer% = VARSEG(Vpage%(0))                          'set layer address
                                                    'for reference

DIM SHARED Mario AS KartType                        'needs a better name


Mario.x = MAPMAXPIXELX \ 2                  'center our camera
Mario.y = MAPMAXPIXELY \ 2
Mario.dx = 0
Mario.dy = 0
Mario.Angle = 0
Mario.accel = .1                        'acceleration
Mario.speed = 0



'calc lookup tables

FOR i% = 0 TO 359
    RA! = i% * (3.141593 / 180)
    Lcos!(i%) = COS(RA!)
    Lsin!(i%) = SIN(RA!)
NEXT i%


CLS
SCREEN 0

PRINT "Vsynch?"
PRINT "[Y]es/[N]o"; ""

k$ = INPUT$(1)

IF UCASE$(k$) = "Y" THEN
    WAITON = TRUE
ELSE
    WAITON = FALSE
END IF

CLS
SCREEN 13



j! = 255 / 360 * 3
k! = 255 / 360 * 2
l! = 255 / 360 * 4
FOR i% = 0 TO 255
    OUT &H3C8, i%
    m% = INT(a!)
    n% = INT(b!)
    o% = INT(c!)
    r% = 63 * ABS(SIN(m% * PI / 180))
    g% = 63 * ABS(SIN(n% * PI / 180))
    IF i < 128 THEN g% = 0
    a! = a! + j!
    b! = b! + k!
    c! = c! + l!
    OUT &H3C9, r%
    OUT &H3C9, g%
    OUT &H3C9, b%
NEXT


'do some nice texture
'Generate texture
FOR y% = -TSIZE% \ 2 TO TSIZE% \ 2 - 1
    yy% = ABS(y%)
    FOR x% = -TSIZE% \ 2 TO TSIZE% \ 2 - 1
        xx% = ABS(x%)
        c% = SIN(xx% / 12) * 132 + SIN(yy% / 12) * 256 + SIN((yy% + xx%) / 8) * 64
        PSET (x% + TSIZE% \ 2, y% + TSIZE% \ 2), c%
    NEXT x%
NEXT y%


c$ = INPUT$(1)

'duh!
GET (0, 0)-STEP(TSIZE - 1, TSIZE - 1), Texture%(0)

x1 = 0              'window dimensions for Mode7
y1 = 60
x2 = 319
y2 = 199

'mode 7 parameters
Angle = 0               'Look forward
Scalex = 256            '200 looks good
Scaley = 256
Scalez = 15             'height
Horz = 10               'eyeview
camx! = 0
camy! = 0
Finished = FALSE
Dummy = MULTIKEY(-1)    'Install MULTIKEY Keyboard handler
T# = TIMER
DO
    F& = (F& + 1) AND &H7FFFFFFF
    IF MULTIKEY(KEYLEFT) THEN             'rotate angle
       Mario.Angle = (Mario.Angle - 1)
       IF Mario.Angle < 0 THEN Mario.Angle = 360 + Mario.Angle
       KoopaFrame% = 2
    END IF
    IF MULTIKEY(KEYRIGHT) THEN            'rotate angle
       Mario.Angle = (Mario.Angle + 1)
       IF Mario.Angle > 359 THEN Mario.Angle = 360 - Mario.Angle
       KoopaFrame% = 3
    END IF
    IF MULTIKEY(KEYDOWN) THEN             'move backwards
        Mario.speed = Mario.speed - Mario.accel
    END IF
    IF MULTIKEY(KEYUP) THEN               'move forvard
        Mario.speed = Mario.speed + Mario.accel
    END IF

    IF MULTIKEY(&H1E) THEN            'A  'increase height
        Scalez = Scalez + 1
    END IF
    IF MULTIKEY(&H2C) THEN            'z  decrease height
        Scalez = Scalez - 1
    END IF
    IF MULTIKEY(&H1F) THEN            's
        Scalex = Scalex + 1
    END IF
    IF MULTIKEY(&H2D) THEN            'x
        Scalex = Scalex - 1
    END IF
    IF MULTIKEY(&H20) THEN            'd
        Scaley = Scaley + 1
    END IF
    IF MULTIKEY(&H2E) THEN            'c
        Scaley = Scaley - 1
    END IF

    IF MULTIKEY(&H21) THEN            'F  'decrease eyeview
        Horz = Horz + 1
        y1 = y1 - 1
        IF y1 < 0 THEN y1 = 0
    END IF
    IF MULTIKEY(&H2F) THEN            'v  increase eyeview
        Horz = Horz - 1
        y1 = y1 + 1
        IF y1 > 199 THEN y1 = 199
    END IF

    IF MULTIKEY(KEYENTER) THEN
       Finished = TRUE
    END IF
    IF MULTIKEY(KEYESC) THEN
        Finished = TRUE
    END IF

    'calc physics
    Mario.speed = Mario.speed - Mario.speed * FRICTION
    dx! = (Lcos!(Mario.Angle)) * Mario.speed
    dy! = (Lsin!(Mario.Angle)) * Mario.speed

    Mario.x = Mario.x + dx!
    IF Mario.x < 0 THEN
        Mario.x = 0
    ELSEIF Mario.x >= MAPMAXPIXELX THEN
        Mario.x = MAPMAXPIXELX
    END IF

    Mario.y = Mario.y + dy!
    IF Mario.y < 0 THEN
        Mario.y = 0
    ELSEIF Mario.y >= MAPMAXPIXELY THEN
        Mario.y = MAPMAXPIXELY
    END IF

    Angle% = Mario.Angle
    px! = Mario.x
    py! = Mario.y
    AF.Cls Layer, 0
    AF.Mode7 Layer%, x1, y1, x2, y2, Angle%, Scalex, Scaley, Scalez, Horz, px!, py!, Texture%(), 0
    IF WAITON THEN WAIT &H3DA, 8
    AF.Pcopy VIDEO, Layer
LOOP UNTIL Finished


Dummy = MULTIKEY(-2)    'Install MULTIKEY Keyboard handler
Fps% = F& / (TIMER - T#)
CLS
SCREEN 0
WIDTH 80
PRINT "FPS:"; Fps%
c$ = INPUT$(1)
END

SUB AF.Cls (DestSeg%, c%)
'Clears the Layer to a specified color
'Parameters:
'Destseg=Layer or page to clear(use VARSEG or VIDEO/&HA000)

STATIC Asm.Cls%(), InitDone%

IF InitDone% = 0 THEN
    Asm$ = ""
    Asm$ = Asm$ + "5589E58B46088CDA8EC031FF8A460688C489C166C1E01089C8B9803EF366AB8EDA5DCA0400"

    CodeLen% = LEN(Asm$)
    IF (CodeLen% MOD 2) <> 0 THEN CodeLen% = CodeLen% + 1
    Size% = CodeLen% \ 4
    REDIM Asm.Cls%(Size%)

    DEF SEG = VARSEG(Asm.Cls%(0))
    FOR i% = 0 TO CodeLen% \ 2
            Byte% = VAL("&H" + MID$(Asm$, (i% * 2) + 1, 2))
            POKE VARPTR(Asm.Cls%(0)) + i%, Byte%
    NEXT i%
    DEF SEG
    InitDone% = 1
END IF


    DEF SEG = VARSEG(Asm.Cls%(0))
    CALL ABSOLUTE(BYVAL DestSeg%, BYVAL c%, VARPTR(Asm.Cls%(0)))
    DEF SEG

END SUB

SUB AF.Mode7 (Layer%, x1%, y1%, x2%, y2%, Angle%, Scalex%, Scaley%, Scalez%, Horz%, camx!, camy!, Texture%(), TextureOffset%)
'Just converted my mode7 render usin List2op by Plasma
'Relsoft

STATIC Asm.Mode7%(), InitDone%

IF InitDone% = 0 THEN
    Asm$ = ""
    Asm$ = "C834000006571E568B4E228B561E3BCA0F8F0302"
    Asm$ = Asm$ + "81F9C7000F8FF30183F9000F8CF90183FA"
    Asm$ = Asm$ + "000F8CE50181FAC7000F8FFD012BD1420F"
    Asm$ = Asm$ + "84D60186E98BF9C1EF0203F98B46248B5E"
    Asm$ = Asm$ + "203BC30F8FE7013D3F010F8FBA013D0000"
    Asm$ = Asm$ + "0F8CDD0183FB000F8CAC0181FB3F010F8F"
    Asm$ = Asm$ + "DE012BD84303F8B940012BCB894ED6895E"
    Asm$ = Asm$ + "D4D1EB8BC36698668946CE8956D28B4614"
    Asm$ = Asm$ + "6698668946FC8B46126698668946F86633"
    Asm$ = Asm$ + "C08B46188B5E1A0FAFC366C1E008668946"
    Asm$ = Asm$ + "E4C746E200008E46268E5E088B76068B04"
    Asm$ = Asm$ + "C1E8038946DE488946DA8B44028946DC48"
    Asm$ = Asm$ + "8946D88B46DE3D020075099090C646CC01"
    Asm$ = Asm$ + "EB60903D040075099090C646CC02EB5290"
    Asm$ = Asm$ + "3D080075099090C646CC03EB44903D1000"
    Asm$ = Asm$ + "75099090C646CC04EB36903D2000750990"
    Asm$ = Asm$ + "90C646CC05EB28903D400075099090C646"
    Asm$ = Asm$ + "CC06EB1A903D800075099090C646CC07EB"
    Asm$ = Asm$ + "0C903D00010F85D100C646CC088B46E203"
    Asm$ = Asm$ + "46166698668BD8668B46E46633D266F7FB"
    Asm$ = Asm$ + "668BD8668BC86633D28B461C6698669166"
    Asm$ = Asm$ + "F7F9668BC8668BD166F7DA660FAF56F866"
    Asm$ = Asm$ + "8956F4660FAF4EFC66894EF0668BC3660F"
    Asm$ = Asm$ + "AF5EFC660FAF56CE662BDA66895EEC668B"
    Asm$ = Asm$ + "560E660156EC660FAF46F8660FAF4ECE66"
    Asm$ = Asm$ + "2BC1668946E8668B4E0A66014EE88A4ECC"
    Asm$ = Asm$ + "8B5ED4895EE0668B46EC66C1F8102346DA"
    Asm$ = Asm$ + "668B5EE866C1FB10235ED8D3E38BF303F0"
    Asm$ = Asm$ + "0376068A4404268805668B56F4668B46F0"
    Asm$ = Asm$ + "660156EC660146E847FF4EE075C5037ED6"
    Asm$ = Asm$ + "8B46D28346E2013946E20F8C33FF5E1F5F"
    Asm$ = Asm$ + "07C9CA220087CAE9F8FD8BC22BC103C883"
    Asm$ = Asm$ + "F9007CE833C9E9F7FDE9F4FDBAC700E9FD"
    Asm$ = Asm$ + "FD93E915FE8BCB2BC803C13D00007CCB33"
    Asm$ = Asm$ + "C0E913FEBB3F01E91CFE"

    CodeLen% = LEN(Asm$)
    IF (CodeLen% MOD 2) <> 0 THEN CodeLen% = CodeLen% + 1
    Size% = CodeLen% \ 4
    REDIM Asm.Mode7%(Size%)

    DEF SEG = VARSEG(Asm.Mode7%(0))
    FOR i% = 0 TO CodeLen% \ 2
            Byte% = VAL("&H" + MID$(Asm$, (i% * 2) + 1, 2))
            POKE VARPTR(Asm.Mode7%(0)) + i%, Byte%
    NEXT i%
    DEF SEG
    InitDone% = 1
END IF

'This Draws ;*)

'xRelMode7   Proc  Uses es di ds si,\
'            Layer:word,scalex:word, scaley:word, scalez:word, horz:word,\
'            cosa: word, sina: word, camx: word, camy: word, TextSeg: word, TextOff: word
a! = (Angle% * 3.141593) / 180
cosa% = COS(a!) * 256
sina% = SIN(a!) * 256
camx& = camx! * 65536
camy& = camy! * 65536
IF Horz% < 1 THEN Horz% = 1


DEF SEG = VARSEG(Asm.Mode7%(0))
CALL ABSOLUTE(BYVAL Layer%, BYVAL x1%, BYVAL y1%, BYVAL x2%, BYVAL y2%, BYVAL Scalex%, BYVAL Scaley%, BYVAL Scalez%, BYVAL Horz%, BYVAL cosa%, BYVAL sina%, BYVAL camx&, BYVAL camy&, BYVAL VARSEG(Texture%(TextureOffset%)), BYVAL VARPTR(Texture%( _
TextureOffset%)), VARPTR(Asm.Mode7%(0)))
DEF SEG


END SUB

SUB AF.Pcopy (DestSeg%, SRCSEG%)
'copies the sourceseg to destseg
'this acheives double buffering to eliminate flicker
'same as QB's PCOPY command
'Parameters:
'Destseg=Layer or page to copy to(usually VIDEO)
'srcseg=the source layer to copy from



STATIC Asm.Pcopy%(), InitDone%

IF InitDone% = 0 THEN
    Asm$ = ""
    Asm$ = Asm$ + "5589E58CD88B4E088B56068EC18EDA31FF31F6B9803EF366A58ED85DCA0400"

    CodeLen% = LEN(Asm$)
    IF (CodeLen% MOD 2) <> 0 THEN CodeLen% = CodeLen% + 1
    Size% = CodeLen% \ 4
    REDIM Asm.Pcopy%(Size%)

    DEF SEG = VARSEG(Asm.Pcopy%(0))
    FOR i% = 0 TO CodeLen% \ 2
            Byte% = VAL("&H" + MID$(Asm$, (i% * 2) + 1, 2))
            POKE VARPTR(Asm.Pcopy%(0)) + i%, Byte%
    NEXT i%
    DEF SEG
    InitDone% = 1
END IF

    DEF SEG = VARSEG(Asm.Pcopy%(0))
    CALL ABSOLUTE(BYVAL DestSeg%, BYVAL SRCSEG%, VARPTR(Asm.Pcopy%(0)))
    DEF SEG

END SUB

FUNCTION MULTIKEY (T)
'Milo Sedlacek's multikey

STATIC kbcontrol%(), kbmatrix%(), Firsttime, StatusFlag

IF Firsttime = 0 THEN          'Initalize
DIM kbcontrol%(128)
DIM kbmatrix%(128)
code$ = ""
code$ = code$ + "E91D00E93C00000000000000000000000000000000000000000000000000"
code$ = code$ + "00001E31C08ED8BE24000E07BF1400FCA5A58CC38EC0BF2400B85600FAAB"
code$ = code$ + "89D8ABFB1FCB1E31C08EC0BF2400BE14000E1FFCFAA5A5FB1FCBFB9C5053"
code$ = code$ + "51521E560657E460B401A8807404B400247FD0E088C3B700B0002E031E12"
code$ = code$ + "002E8E1E100086E08907E4610C82E661247FE661B020E6205F075E1F5A59"
code$ = code$ + "5B589DCF"
DEF SEG = VARSEG(kbcontrol%(0))
FOR i% = 0 TO 155                     ' Load ASM
     d% = VAL("&h" + MID$(code$, (i% * 2) + 1, 2))
     POKE VARPTR(kbcontrol%(0)) + i%, d%
NEXT i%
i& = 16       ' I think this stuff connects the interrupt with kbmatrix%()
n& = VARSEG(kbmatrix%(0)): l& = n& AND 255: h& = ((n& AND &HFF00) \ 256): POKE i&, l&: POKE i& + 1, h&: i& = i& + 2
n& = VARPTR(kbmatrix%(0)): l& = n& AND 255: h& = ((n& AND &HFF00) \ 256): POKE i&, l&: POKE i& + 1, h&: i& = i& + 2
DEF SEG
Firsttime = 1
END IF

SELECT CASE T
CASE -1
  IF StatusFlag = 0 THEN
   DEF SEG = VARSEG(kbcontrol%(0))
   CALL ABSOLUTE(0)                     ' Run interrupt
   DEF SEG
   StatusFlag = 1
  END IF
CASE -2
  IF StatusFlag = 1 THEN
   DEF SEG = VARSEG(kbcontrol%(0))      ' Turn off interrupt
   CALL ABSOLUTE(3)
   DEF SEG
   StatusFlag = 0
  END IF
CASE 1 TO 128
  MULTIKEY = kbmatrix%(T)               ' Return status
CASE ELSE
  MULTIKEY = 0                          ' User Supidity Error
END SELECT


END FUNCTION
y smiley is 24 bit.
[Image: anya2.jpg]

Genso's Junkyard:
http://rel.betterwebber.com/
Website Find
Reply
Plasma Offline
Posting Freak
*****
Posts: 1,752
Threads: 21
Joined: Jun 2002
#2
02-19-2004, 11:27 AM
Very nice. Smile
Website Find
Reply
Diroga Offline
Posting Freak
*****
Posts: 1,057
Threads: 156
Joined: Aug 2003
#3
02-19-2004, 11:32 AM
FPS:69 Big Grin very nice, a bit epileptic when moving fast Big Grin
Find
Reply
relsoft Offline
Posting Freak
*****
Posts: 3,288
Threads: 167
Joined: Nov 2001
#4
02-19-2004, 11:37 AM
yeah that's why you are prompted to use Vsynch or not.

Try [N]o and report the FPS.:*)
BTW.

controls are:

AZSXDCFV. :*)
y smiley is 24 bit.
[Image: anya2.jpg]

Genso's Junkyard:
http://rel.betterwebber.com/
Website Find
Reply
TheBigBasicQ Offline
Posting Freak
*****
Posts: 4,307
Threads: 63
Joined: May 2003
#5
02-19-2004, 01:22 PM
I'm dizzy =S

Got 75FPS on a PIII 450MHz
Website Find
Reply
na_th_an Offline
Posting Freak
*****
Posts: 6,419
Threads: 74
Joined: Mar 2002
#6
02-19-2004, 06:47 PM
500+ fps in this XP 2000+
SCUMM (the band) on Myspace!
ComputerEmuzone Games Studio
underBASIC, homegrown musicians
[img]http://www.ojodepez-fanzine.net/almacen/yoghourtslover.png[/i
Website Find
Reply
Zap Offline
Posting Freak
*****
Posts: 838
Threads: 17
Joined: Jan 2002
#7
02-19-2004, 09:15 PM
500+ compiled and 600+ uncompiled :???: on my XP 2000+.
url=http://www.copy-pasta.com]CopyPasta[/url] - FilePasta
Find
Reply
Zack Offline
Posting Freak
*****
Posts: 3,616
Threads: 287
Joined: Jan 2003
#8
02-19-2004, 10:03 PM
70 FPS on my 2.4 ghz with XP, vsync on. Almost 500 with vsync off.
But anyway...beatiful! 3D plasma/move around thing...upload this to The Geekery! Beatiful [/shameless plug]
f only life let you press CTRL-Z.
--------------------------------------
Freebasic is like QB, except it doesn't suck.
Website Find
Reply
Agamemnus Offline
Posting Freak
*****
Posts: 3,368
Threads: 195
Joined: Jan 2003
#9
02-19-2004, 10:26 PM
185FPS compiled 400mhz P2.
Peace cannot be obtained without war. Why? If there is already peace, it is unnecessary for war. If there is no peace, there is already war."

Visit www.neobasic.net to see rubbish in all its finest.
Find
Reply
KiZ Offline
Posting Freak
*****
Posts: 2,771
Threads: 96
Joined: Oct 2003
#10
02-19-2004, 11:41 PM
.... :o .....

i am amazed! Breathtaking!

500+fps uncompiled!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

~65 with vsync

That is the most amazing piece of 3D... er um.... 3D stuff I have seen =D

Well done!!
Website Find
Reply


Forum Jump:


Users browsing this thread: 1 Guest(s)