Qbasicnews.com › General › General/Misc v
Weird....

Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
Threaded Mode
Weird....
relsoft Offline
Posting Freak
*****
Posts: 3,288
Threads: 167
Joined: Nov 2001
#1
02-26-2004, 12:40 PM
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....
y smiley is 24 bit.
[Image: anya2.jpg]

Genso's Junkyard:
http://rel.betterwebber.com/
Website Find
Reply
Zack Offline
Posting Freak
*****
Posts: 3,616
Threads: 287
Joined: Jan 2003
#2
02-26-2004, 07:13 PM
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
f only life let you press CTRL-Z.
--------------------------------------
Freebasic is like QB, except it doesn't suck.
Website Find
Reply
Radical Raccoon Offline
Senior Member
****
Posts: 508
Threads: 49
Joined: May 2002
#3
02-27-2004, 02:23 AM
cool
CATLOAF 2600
Website Find
Reply
RST Offline
Senior Member
****
Posts: 292
Threads: 31
Joined: Apr 2003
#4
02-27-2004, 05:44 AM
How do you do these things, Rel?!

Getting ~30 FPS, 40-50 FPS on piece of crap 200 Mhz, in case you're curious.
Find
Reply
relsoft Offline
Posting Freak
*****
Posts: 3,288
Threads: 167
Joined: Nov 2001
#5
02-27-2004, 11:19 AM
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"?
y smiley is 24 bit.
[Image: anya2.jpg]

Genso's Junkyard:
http://rel.betterwebber.com/
Website Find
Reply
Zack Offline
Posting Freak
*****
Posts: 3,616
Threads: 287
Joined: Jan 2003
#6
02-27-2004, 07:31 PM
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:
f only life let you press CTRL-Z.
--------------------------------------
Freebasic is like QB, except it doesn't suck.
Website Find
Reply
Jocke The Beast Offline
Senior Member
****
Posts: 672
Threads: 27
Joined: Aug 2001
#7
02-28-2004, 05:05 AM
One word: respect 8)

Ps. Now get your ass into the bunker! King-Joe has set a price on your head :wink:
[Image: jocke.gif]
Website: http://jocke.phatcode.net
"Some men get the world, other men get ex hookers and a trip to Arizona."
Website Find
Reply
relsoft Offline
Posting Freak
*****
Posts: 3,288
Threads: 167
Joined: Nov 2001
#8
02-28-2004, 10:39 AM
LOL!!!! Joe King? j/k
y smiley is 24 bit.
[Image: anya2.jpg]

Genso's Junkyard:
http://rel.betterwebber.com/
Website Find
Reply
barok Offline
Posting Freak
*****
Posts: 1,688
Threads: 119
Joined: Jun 2003
#9
02-28-2004, 11:29 AM
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.
Jumping Jahoolipers!
Find
Reply
relsoft Offline
Posting Freak
*****
Posts: 3,288
Threads: 167
Joined: Nov 2001
#10
03-01-2004, 11:12 AM
Uhhh, I have just seen Ld3d!!!!

Joe?

The King I mean. :*)
y smiley is 24 bit.
[Image: anya2.jpg]

Genso's Junkyard:
http://rel.betterwebber.com/
Website Find
Reply


Forum Jump:


Users browsing this thread: 1 Guest(s)