Qbasicnews.com

Full Version: Weird....
You're currently viewing a stripped down version of our content. View the full version with proper formatting.
Code:
'Crystal snake

'Another AF.Lib GFX demo
'Special thanks to Plasma for Lens2Op
'By Relsoft="Illegal coder"

DECLARE SUB AF.Lens (Dest%, Src%, x%, y%, Radius%, sheight%)
DECLARE SUB AF.Pset (DestSeg%, x%, y%, c%)
DECLARE SUB AF.Pcopy (DestSeg%, SRCSEG%)
DECLARE SUB AF.Sphere (Layer%, x%, y%, xoff%, yoff%, Radius%, sheight%, Image%(), ImageOffs%)
DECLARE SUB AF.Cls (DestSeg%, c%)

DEFINT A-Z
REM $DYNAMIC

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


RANDOMIZE TIMER


'QB code Starts here.......
DIM SHARED Vpage(31999)
DIM SHARED Layer

DIM TextPage(31999) AS INTEGER          'Texture for lens

DIM Image(((64 * 64) + 4) \ 2)          'for spheremapping

Layer = VARSEG(Vpage(0))                'Setup segments for
TextSeg = VARSEG(TextPage(0))           'Easy reference
ImageSeg = VARSEG(Image(0))

CLS
SCREEN 0
WIDTH 80

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
RANDOMIZE TIMER


'Nifty gradient

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))
    IF r% > 63 THEN r% = 63
    g% = 63 * ABS(SIN(n% * PI / 180))
    IF i < 128 THEN g% = 0
    b% = 32 * ABS(SIN(o% * PI / 180))
    a! = a! + j!
    b! = b! + k!
    c! = c! + l!
    OUT &H3C9, r%
    OUT &H3C9, g%
    OUT &H3C9, b%
NEXT


'Nicetexture

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

GET (0, 0)-(63, 63), Image(0)           'prep image

FOR y% = 0 TO 199                       'texturepage
FOR x% = 0 TO 319
    AF.Pset TextSeg, x%, y%, x XOR y
NEXT x%
NEXT y%

Radius% = 20                    'lens start radius
sheight% = 30                   'height

T# = TIMER
DO
    F& = (F& + 1) AND &H7FFFFFFF

    AF.Pcopy Layer, TextSeg
    FOR i% = 1 TO 6
        xx% = SIN(F& / 30 * .8 * i%) * (i% * 20) + 120      'Move the balls
        yy% = COS(F& / 25 * .9 * i%) * (i% * 15) + 60
        AF.Lens Layer, TextSeg, xx%, yy%, Radius% + i% * 7, sheight%
    NEXT i%

    IF WAITON THEN WAIT &H3DA, 8
    AF.Pcopy VIDEO, Layer
LOOP UNTIL INKEY$ <> ""


Fps1% = F& / (TIMER - T#)


Radius% = 32
sheight% = 30

F& = 0
T# = TIMER
DO
    F& = (F& + 1) AND &H7FFFFFFF
    AF.Pcopy Layer, TextSeg
    FOR i% = 1 TO 6
        xx% = SIN(F& / 30 * .8 * i%) * (i% * 20) + 120      'Move the balls
        yy% = COS(F& / 25 * .9 * i%) * (i% * 15) + 60
        xt% = (COS(xx% * 3.1415 / 180) * 128) AND 63
        yt% = (COS(yy% * 3.1415 / 180) * 128) AND 63
        AF.Sphere Layer, xx%, yy%, xt%, yt%, Radius% + i% * 7, sheight%, Image(), 0
    NEXT i%

    IF WAITON THEN WAIT &H3DA, 8
    AF.Pcopy VIDEO, Layer

LOOP UNTIL INKEY$ <> ""

Fps2% = F& / (TIMER - T#)
CLS
SCREEN 0
WIDTH 80

PRINT "Lens="; Fps1%, "Sphere="; Fps2%
c$ = INPUT$(1)

END

REM $STATIC
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.Lens (Dest%, Src%, x%, y%, Radius%, sheight%) STATIC

STATIC Asm.Lens%(), InitDone%

IF InitDone% = 0 THEN
    DIM Sqrt%((128 * 128) \ 2)
    j% = 0
    FOR i% = 0 TO UBOUND(Sqrt%)
        a% = SQR(j%)
        j% = j% + 1
        b% = SQR(j%)
        c% = 0
        DEF SEG = VARSEG(c%)
        POKE VARPTR(c%), a%
        POKE VARPTR(c%) + 1, b%
        Sqrt%(i%) = c%
        j% = j% + 1
    NEXT i%

    Asm$ = ""
    Asm$ = "C81A000006571E568B460AC1E0038B5E0C0FAFDB895EFC2BD8895EFA8B46"
    Asm$ = Asm$ + "0CD1E08946F88946F6C746F40000C746F200008B56F68B5EF88B46"
    Asm$ = Asm$ + "103D3F010F8F23013D00000F8C24018B4E0E81F9C7000F8F110183"
    Asm$ = Asm$ + "F9000F8C200103D881FB3F010F8F24012BD803D181FAC7000F8F20"
    Asm$ = Asm$ + "012BD1894610894E0E895EF88956F686E9BB40018BF92B5EF8C1EF"
    Asm$ = Asm$ + "0203F9895EFE03F88E5E128E66088E4614C746EE0000C746F00000"
    Asm$ = Asm$ + "8B46F08B5EEE2B460C2B5E0C0346F4035EF28946EC895EEA0FAFC0"
    Asm$ = Asm$ + "0FAFDB03C33B46FA7D7C90908B5EFC2BD833C9648A0F8B460A2BC1"
    Asm$ = Asm$ + "8946E88946E68B46EC8B5EEA33D2C1E00799F7F90FAF46E8C1F807"
    Asm$ = Asm$ + "8946E833D28BC3C1E00799F7F90FAF46E6C1F80703460E0346EE3D"
    Asm$ = Asm$ + "00007C3190903DC7007F2A909086C48BF0C1EE0203F08B5EE8035E"
    Asm$ = Asm$ + "10035EF083FB007C11909081FB3F017F09909003F38A0426880547"
    Asm$ = Asm$ + "8B46F8FF46F03946F00F8C51FF037EFE8B5EF6FF46EE395EEE0F8C"
    Asm$ = Asm$ + "3CFF5E1F5F07C9CA1000F7D82BD87EF28946F433C0E9CEFEF7D92B"
    Asm$ = Asm$ + "D17EE4894EF233C9E9D2FEBB40012BD8E9D6FE03CA81E9C8002BD1"
    Asm$ = Asm$ + "8B4E0EE9D4FE"

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

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

    InitDone% = -1
END IF

    DEF SEG = VARSEG(Asm.Lens%(0))
    CALL ABSOLUTE(BYVAL Dest%, BYVAL Src%, BYVAL x%, BYVAL y%, BYVAL Radius%, BYVAL sheight%, BYVAL VARSEG(Sqrt%(0)), BYVAL VARPTR(Sqrt%(0)), VARPTR(Asm.Lens%(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

SUB AF.Pset (DestSeg%, x%, y%, c%)
'Same as QB's PSET command
'Paramenters:
'Dest seg=See AF.Box
'X,Y:coordinates of the pixel
'C:color of the pixel to draw

STATIC Asm.Pset%(), InitDone%

IF InitDone% = 0 THEN
    Asm$ = ""
    Asm$ = Asm$ + "5589E58B460C8B56087C288EC081FAC7007F208B5E0A83FB007C1881FB3F01"
    Asm$ = Asm$ + "7F1267668D1492C1E20689D701DF8A4E0626880D5DCA0800"

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

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

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

END SUB

SUB AF.Sphere (Layer%, x%, y%, xoff%, yoff%, Radius%, sheight%, Image%(), ImageOffs%) STATIC

STATIC Asm.Sphere%(), InitDone%

IF InitDone% = 0 THEN
    DIM Sqrt%((128 * 128) \ 2)
    j% = 0
    FOR i% = 0 TO UBOUND(Sqrt%)
        a% = SQR(j%)
        j% = j% + 1
        b% = SQR(j%)
        c% = 0
        DEF SEG = VARSEG(c%)
        POKE VARPTR(c%), a%
        POKE VARPTR(c%) + 1, b%
        Sqrt%(i%) = c%
        j% = j% + 1
    NEXT i%

    Asm$ = ""
    Asm$ = "C820000006571E568B460EC1E0048B5E100FAFDB895EFC2BD8895EFA8E5E"
    Asm$ = Asm$ + "0C8B760A8B04C1E8038946F88B5C02484B8946F6895EF48B4610D1"
    Asm$ = Asm$ + "E08946F28946F0C746EE0000C746EC00008B56F08B5EF28B46183D"
    Asm$ = Asm$ + "3F010F8F04013D00000F8C05018B4E1681F9C7000F8FF20083F900"
    Asm$ = Asm$ + "0F8C040103D881FB3F010F8F0B012BD803D181FAC7000F8F07012B"
    Asm$ = Asm$ + "D1895EF28956F086E9BB40018BF92B5EF2C1EF0203F9895EFE03F8"
    Asm$ = Asm$ + "8E66088E461AC746E80000C746EA00008B46EA8B5EE82B46102B5E"
    Asm$ = Asm$ + "100346EE035EEC8946E6895EE40FAFC00FAFDB03C33B46FA7D6690"
    Asm$ = Asm$ + "908B5EFC2BD833C9648A0F8B460E2BC18946E28946E08B46E68B5E"
    Asm$ = Asm$ + "E433D2C1E00799F7F90FAF46E2C1F8078946E233D28BC3C1E00799"
    Asm$ = Asm$ + "F7F90FAF46E0C1F8070346120346E82346F40FAF46F88BF08B5EE2"
    Asm$ = Asm$ + "035E14035EEA235EF603F303760A8A4404268805478B46F2FF46EA"
    Asm$ = Asm$ + "3946EA0F8C67FF037EFE8B5EF0FF46E8395EE80F8C52FF5E1F5F07"
    Asm$ = Asm$ + "C9CA1600F7D82BD87EF28946EE01461433C0E9EAFEF7D92BD17EE1"
    Asm$ = Asm$ + "894EEC014E1233C9E9EBFEBB40012BD8E9EFFE03CA81E9C8002BD1"
    Asm$ = Asm$ + "8B4E16E9EDFE"

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

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

    InitDone% = -1
END IF

    DEF SEG = VARSEG(Asm.Sphere%(0))
    CALL ABSOLUTE(BYVAL Layer%, BYVAL x%, BYVAL y%, BYVAL xoff%, BYVAL yoff%, BYVAL Radius%, BYVAL sheight%, BYVAL VARSEG(Image%(0)), BYVAL VARPTR(Image%(ImageOffs%)), BYVAL VARSEG(Sqrt%(0)), BYVAL VARPTR(Sqrt%(0)), VARPTR(Asm.Sphere%(0)))
    DEF SEG


END SUB

Relsoft getting better but dumber by the day....
Dumber? Uh-uh.
(although I'm still getting out-of-memory, but only after a while).
Lets see...Do you juggle, Rel? It kinda looks like someone juggling...textured bubblin' bouncin' balls...
I like it. Big Grin
cool
How do you do these things, Rel?!

Getting ~30 FPS, 40-50 FPS on piece of crap 200 Mhz, in case you're curious.
I converted my QB code(optimized as it is already) to ASM and used List2OP by Plasma to generate hex opcodes so that we could use Call Absolute.

Big Grin

Zack: "Juggle"?
Quote:I converted my QB code(optimized as it is already) to ASM and used List2OP by Plasma to generate hex opcodes so that we could use Call Absolute.

Big Grin

Zack: "Juggle"?
I dunno, it looks like a wicked juggler to me. Confusedhifty:
One word: respect 8)

Ps. Now get your ass into the bunker! King-Joe has set a price on your head :wink:
LOL!!!! Joe King? j/k
Quote:How do you do these things, Rel?!

Getting ~30 FPS, 40-50 FPS on piece of crap 200 Mhz, in case you're curious.

Joe King? Quite an honour! your raycasting tut's are easily the easiest and best for qb there is.
Uhhh, I have just seen Ld3d!!!!

Joe?

The King I mean. :*)