07-02-2003, 10:27 AM
2 Hours. Half hours just to animate that darn bubble. ;*)
Setvideoseg by Plasma357
Setvideoseg by Plasma357
Code:
'/////Bubble Fight!!!!///////
'June 2,2003
'Another stupid creation of Relsoft
'Coded in exactly 2 hours
'cuz the one-hour version's GFX sucked BIG.
'OBJECTIVE
'Stay away from mines and stay alive as long as you can
'CONTROLS:
'CTRL=Move left
'ALT=Move Right
'Right Shift= Add Height
'Left Shift=Toggle Vsynch
DECLARE SUB GFX (Size%, x1%, y1%, x2%, y2%)
DECLARE SUB ReInit ()
DECLARE SUB AF.Print (Xpos%, Ypos%, Text$, col%)
DECLARE FUNCTION DoCollision% ()
DECLARE FUNCTION Collide% (Frame%)
DECLARE SUB DoMines ()
DECLARE SUB AddMine ()
DECLARE SUB GenMask (Array%(), ArrayIndex%(), Mask%())
DECLARE SUB InitImageData (FileName$, ImageArray%())
DECLARE SUB MakeImageIndex (ImageArray%(), IndexArray%())
DECLARE SUB DoStars ()
DECLARE SUB INIT ()
DECLARE SUB SetVideoSeg (Segment%)
DEFINT A-Z
'$DYNAMIC
TYPE MineType
x AS SINGLE
y AS SINGLE
xv AS SINGLE
yv AS SINGLE
cx AS INTEGER
cy AS INTEGER
Hei AS INTEGER
Wid AS INTEGER
id AS INTEGER
angle AS INTEGER
Active AS INTEGER
Counter AS INTEGER
Frame AS INTEGER
END TYPE
TYPE BubbleType
x AS SINGLE
y AS SINGLE
xv AS SINGLE
yv AS SINGLE
Frame AS INTEGER
END TYPE
TYPE StarType
x AS SINGLE
y AS SINGLE
xv AS SINGLE
yv AS SINGLE
c AS INTEGER
END TYPE
CONST FALSE = 0, TRUE = NOT FALSE
CONST VIDEO = &HA000
CONST PI = 3.14151693#
CONST MAXMINES = 50
CONST MAXSTARS = 50
CONST xFRICTION = .008
CONST yFRICTION = .008
CONST GRAVITY = .012
CONST ACCEL = .02
DIM SHARED Mine(MAXMINES) AS MineType
DIM SHARED Stars(MAXSTARS) AS StarType
DIM SHARED LutCOS(359) AS SINGLE
DIM SHARED LutSIN(359) AS SINGLE
DIM SHARED VPAGE(32009) AS INTEGER 'SetVideoSeg Buffer
REDIM SHARED BubbleSpr(1 TO 1) AS INTEGER
REDIM SHARED BubbleIdx(1 TO 1) AS INTEGER
REDIM SHARED BubbleMask(1 TO 1) AS INTEGER
REDIM SHARED MineSpr(1 TO 1) AS INTEGER
REDIM SHARED MineIdx(1 TO 1) AS INTEGER
REDIM SHARED MineMask(1 TO 1) AS INTEGER
DIM SHARED Bubble AS BubbleType
DIM SHARED LAYER AS INTEGER
DIM SHARED Score&
DIM SHARED Lives
CLS
SCREEN 13
RANDOMIZE TIMER
INIT
WaitON = TRUE
DO
FINISHED = FALSE
ReInit
DO
Anicount = (Anicount AND 7) + 1
MineCount = (MineCount AND 127) + 1
IF MineCount = 1 THEN
AddMine
END IF
DEF SEG = 0
IF PEEK(1047) AND 4 THEN 'CTRL
Bubble.xv = Bubble.xv - ACCEL
END IF
IF PEEK(1047) AND 8 THEN 'ALT
Bubble.xv = Bubble.xv + ACCEL
END IF
IF PEEK(1047) AND 2 THEN 'LShift
WaitON = NOT WaitON
END IF
IF (PEEK(1047) AND 1) THEN 'RShift
Bubble.yv = Bubble.yv - ((ACCEL * 255) * yFRICTION)
END IF
IF Anicount = 1 THEN
Bubble.Frame = (Bubble.Frame AND 1) + 1
END IF
Bubble.xv = Bubble.xv - Bubble.xv * xFRICTION
Bubble.yv = Bubble.yv + GRAVITY
Bubble.yv = Bubble.yv - (Bubble.yv * yFRICTION)
Bubble.x = Bubble.x + Bubble.xv
Bubble.y = Bubble.y + Bubble.yv
IF Bubble.x < 8 THEN
Bubble.x = 8
ELSEIF Bubble.x > 291 THEN
Bubble.x = 291
END IF
IF Bubble.y < 8 THEN
Bubble.y = 8
ELSEIF Bubble.y > 171 THEN
Bubble.y = 171
END IF
cx% = Bubble.x
cy% = Bubble.y
cf% = Bubble.Frame
SetVideoSeg LAYER
LINE (0, 0)-(319, 199), 0, BF
DoStars
DoMines
IF DoCollision THEN
FINISHED = TRUE
Lives = Lives - 1
END IF
PUT (cx%, cy%), BubbleMask(BubbleIdx(cf%)), AND
PUT (cx%, cy%), BubbleSpr(BubbleIdx(cf%)), OR
'Erase stuff
LINE (0, 0)-(8, 199), 0, BF 'Left
LINE (0, 0)-(319, 8), 0, BF 'top
LINE (312, 0)-(319, 199), 0, BF 'right
LINE (0, 192)-(319, 199), 0, BF 'bottom
AF.Print 0, 0, "Score:" + LTRIM$(STR$(Score&)), 35
AF.Print 0, 10, "Lives:" + LTRIM$(STR$(Lives)), 67
'Calc FPS
FPS = FPS + 1
IF StartTime& + 1 < TIMER THEN
FPS2 = FPS
FPS = 0
StartTime& = TIMER
END IF
AF.Print 0, 192, "FPS:" + STR$(FPS2), 23
SetVideoSeg VIDEO
IF WaitON THEN
WAIT &H3DA, 8
END IF
PUT (0, 0), VPAGE(6), PSET
IF INKEY$ = CHR$(27) THEN END
LOOP UNTIL FINISHED
SetVideoSeg LAYER
FOR I = 0 TO 199 STEP 10
AF.Print 30, I + 0, "*****Y-O-U S-U-C-K !!!!!*****", 67
NEXT I
SetVideoSeg VIDEO
PUT (0, 0), VPAGE(6), PSET
c$ = INPUT$(1)
SetVideoSeg VIDEO
FOR I = 2 TO 9
GFX I + 0, 0, 0, 319, 199
WAIT &H3DA, 8
NEXT I
LOOP WHILE Lives >= 0
DEF SEG
CLS
SCREEN 0
WIDTH 80
END
BUBBLEDATA:
DATA 404
DATA 160,20,0,4352,5395,6166,6425,6425,5656,4885,17,0,0,5393,6424,5656,5397,5397,6166,6169
DATA 4373,0,4352,5909,5398,4627,5395,4371,4881,5653,5399,17,5393,5399,4369,5907,6938,4889,0,4352
DATA 5909,4373,6163,4374,5649,7451,6427,4888,0,0,5649,4888,6421,21,6931,7198,4630,4370,0,0
DATA 5376,5401,6166,4371,7447,5660,17,0,0,0,4864,5656,5656,4881,6938,4374,0,0,0,0
DATA 4352,6166,5401,5905,5915,17,0,0,0,0,0,6421,5401,6418,5403,0,0,0,0,0
DATA 0,6421,5401,5649,4888,0,0,0,0,0,0,6421,5401,4352,4370,0,0,0,0,4625
DATA 17,6421,5656,17,4352,4370,0,0,4352,6166,4371,6166,6166,19,4608,5398,17,0,5393,6425
DATA 4883,5656,6421,21,4352,5909,4373,0,5650,4886,5393,5401,6163,4374,0,5393,4630,0,4625,17
DATA 5649,4888,5393,5399,17,4352,4370,0,0,4352,5909,4373,4352,5909,5398,4371,0,0,4881,5653
DATA 5399,17,0,5393,6424,5656,5397,5397,6166,6169,4373,0,0,4352,5395,6166,6425,6425,5656,4885
DATA 17,0,160,20,0,0,0,4881,5397,5397,4371,0,0,0,0,0,4881,6166,6425,6425
DATA 5656,4371,0,0,0,4881,6166,5656,5397,5397,6166,5656,4371,0,0,6419,5657,5397,4885,17
DATA 4881,6422,4889,0,4352,6422,5399,6935,6685,19,0,5649,5657,17,4864,5656,6677,7709,6685,19
DATA 0,4352,6166,19,5649,5400,7447,7198,4887,17,0,0,6163,4374,6163,5398,7707,5660,17,0
DATA 0,0,5649,4888,6421,5397,7196,4374,0,0,0,0,5376,5401,6421,4885,5656,17,0,0
DATA 0,0,5376,5401,6421,4373,4370,0,0,0,0,4625,5393,5401,6421,21,4352,4370,0,0
DATA 0,5907,5395,5401,6163,4374,4608,5398,17,0,4352,6166,5653,4888,5649,4888,4352,5909,4373,0
DATA 0,5656,6165,4374,4864,5656,17,5393,4630,4352,0,5376,6166,19,4352,6422,4374,4352,4370,4608
DATA 0,5910,5657,17,0,6419,5657,4371,0,4352,5909,6423,4889,0,0,4881,6166,5656,5397,5397
DATA 6166,5656,4371,0,0,0,4881,6166,6425,6425,5656,4371,0,0,0,0,0,4881,5397,5397
DATA 4371,0,0,0
MINEDATA:
DATA 68
DATA 64,8,23808,12032,47,93,93,22297,6487,23808,6400,6426,6681,25,22365,23833,6495,23895,22365,24345
DATA 6493,23895,6400,6426,6681,25,93,22297,6487,23808,23808,12032,47,93,64,8,12032,26368,103,47
DATA 47,10047,16167,12032,16128,11831,14126,63,10087,16174,11833,26407,10087,14638,11839,26407,16128,11831,14126,63
DATA 47,10047,16167,12032,12032,26368,103,47
REM $STATIC
SUB AddMine
'id
'0=Static
'1=verical
'2=Horz
'3=Circular
FOR I = 0 TO MAXMINES
IF NOT Mine(I).Active THEN
Mine(I).id = INT(RND * 5)
Mine(I).x = 304
Mine(I).y = INT(RND * 184)
Mine(I).xv = .12 + (RND * 2) / 5
Mine(I).yv = .12 + (RND * 2) / 5
Mine(I).Hei = 10 + (Int20)
Mine(I).Wid = 10 + (20)
Mine(I).angle = INT(RND * 359)
Mine(I).Active = TRUE
Mine(I).Counter = 0
Mine(I).Frame = 1
SELECT CASE Mine(I).id
CASE 0
Score& = Score& + 10
CASE 1
Score& = Score& + 20
CASE 2
Score& = Score& + 30
CASE 3
Score& = Score& + 70
CASE 4
Score& = Score& + 100
CASE ELSE
END SELECT
EXIT FOR
END IF
NEXT I
END SUB
SUB AF.Print (Xpos%, Ypos%, Text$, col%)
'Prints the standard 8*8 CGA font
'Paramenters:
'Segment=the Layer to print to
'Xpos,Ypos=the coordinates of the text
'Text$=the string to print
'col= is the color to print(gradient)
x% = Xpos%
y% = Ypos%
Spacing% = 8
FOR I% = 0 TO LEN(Text$) - 1
x% = x% + Spacing%
Offset% = 8 * ASC(MID$(Text$, I% + 1, 1)) + 14
FOR J% = 0 TO 7
DEF SEG = &HFFA6
Bit% = PEEK(Offset% + J%)
IF Bit% AND 1 THEN PSET (x%, y% + J%), col% + J%
IF Bit% AND 2 THEN PSET (x% - 1, y% + J%), col% + J%
IF Bit% AND 4 THEN PSET (x% - 2, y% + J%), col% + J%
IF Bit% AND 8 THEN PSET (x% - 3, y% + J%), col% + J%
IF Bit% AND 16 THEN PSET (x% - 4, y% + J%), col% + J%
IF Bit% AND 32 THEN PSET (x% - 5, y% + J%), col% + J%
IF Bit% AND 64 THEN PSET (x% - 6, y% + J%), col% + J%
IF Bit% AND 128 THEN PSET (x% - 7, y% + J%), col% + J%
NEXT J%
NEXT I%
DEF SEG
END SUB
FUNCTION DoCollision
DoCollision = FALSE
bx% = Bubble.x
by% = Bubble.y
BR% = 9 * 9
db! = SQR(BR%)
bcx% = bx% + 10
bcy% = by% + 10
FOR I = 0 TO MAXMINES
IF Mine(I).Active THEN
cx% = Mine(I).cx
cy% = Mine(I).cy
IF cx% < bcx% + db! THEN
IF cx% > bcx% - db! THEN
IF cy% < bcy% + db! THEN
IF cy% > bcy% - db! THEN
DoCollision = TRUE
EXIT FOR
END IF
END IF
END IF
END IF
END IF
NEXT I
END FUNCTION
SUB DoMines
Anicount = (Anicount AND 64) + 1
FOR I = 0 TO MAXMINES
IF Mine(I).Active THEN
GOSUB Checkid
IF cx% >= 0 AND cy% >= 0 AND cx% < 305 AND cy% < 184 THEN
IF Anicount = 1 THEN
Mine(I).Frame = (Mine(I).Frame AND 1) + 1
cf% = Mine(I).Frame
END IF
PUT (cx%, cy%), MineMask(MineIdx(cf%)), AND
PUT (cx%, cy%), MineSpr(MineIdx(cf%)), OR
END IF
IF Mine(I).x < 0 THEN
Mine(I).Active = FALSE
END IF
END IF
NEXT I
EXIT SUB
Checkid:
'id
'0=Static
'1=vert
'2=Horz
'3=Circular
id = Mine(I).id
SELECT CASE id
CASE 0
Mine(I).x = Mine(I).x - Mine(I).xv
cx% = Mine(I).x
cy% = Mine(I).y
Mine(I).cx = cx%
Mine(I).cy = cy%
CASE 1
Mine(I).x = Mine(I).x - .55
Mine(I).angle = Mine(I).angle - 1
IF Mine(I).angle < 0 THEN Mine(I).angle = 360 + Mine(I).angle
Mine(I).yv = LutSIN(Mine(I).angle) * 50
cx% = Mine(I).x
cy% = Mine(I).y + Mine(I).yv
Mine(I).cx = cx%
Mine(I).cy = cy%
CASE 2
Mine(I).x = Mine(I).x - .55
Mine(I).angle = Mine(I).angle - 1
IF Mine(I).angle < 0 THEN Mine(I).angle = 360 + Mine(I).angle
Mine(I).xv = LutSIN(Mine(I).angle) * 50
cx% = Mine(I).x + Mine(I).xv
cy% = Mine(I).y
Mine(I).cx = cx%
Mine(I).cy = cy%
CASE 3
Mine(I).x = Mine(I).x - .55
Mine(I).angle = Mine(I).angle - 1
IF Mine(I).angle < 0 THEN Mine(I).angle = 360 + Mine(I).angle
Mine(I).xv = LutCOS(Mine(I).angle) * 50
Mine(I).yv = LutSIN(Mine(I).angle) * 50
cx% = Mine(I).x + Mine(I).xv
cy% = Mine(I).y + Mine(I).yv
Mine(I).cx = cx%
Mine(I).cy = cy%
CASE 4
Mine(I).x = Mine(I).x - .55
Mine(I).angle = (Mine(I).angle + 1) MOD 360
Mine(I).xv = LutCOS(Mine(I).angle) * 50
Mine(I).yv = LutSIN(Mine(I).angle) * 50
cx% = Mine(I).x + Mine(I).xv
cy% = Mine(I).y + Mine(I).yv
Mine(I).cx = cx%
Mine(I).cy = cy%
CASE ELSE
END SELECT
RETURN
END SUB
SUB DoStars
FOR S% = 0 TO MAXSTARS
Stars(S%).x = Stars(S%).x + Stars(S%).xv
Stars(S%).y = Stars(S%).y + Stars(S%).yv
IF Stars(S%).x < 0 OR Stars(S%).y > 180 THEN
Stars(S%).x = INT(RND * 520)
Stars(S%).y = 0
Stars(S%).xv = -(.001 + (RND * 1))
Stars(S%).yv = (.001 + (RND * 1))
Stars(S%).c = 16 + INT(RND * 16)
END IF
PSET (Stars(S%).x, Stars(S%).y), Stars(S%).c
NEXT S%
END SUB
SUB GenMask (Array(), ArrayIndex(), Mask())
'Creats masks for our sprites as we ain't using a LIB
'so we have to make use od masks for transparency
REDIM Mask(1 TO UBOUND(Array))
FOR I = 1 TO UBOUND(Array) 'Recopy values
Mask(I) = Array(I)
NEXT I
FOR I = 1 TO UBOUND(ArrayIndex) 'mask em. ;*)
W% = Array(ArrayIndex(I)) \ 8
H% = Array(ArrayIndex(I) + 1)
foo& = 0
FOR y = 0 TO H% - 1
FOR x = 0 TO W% - 1
DEF SEG = VARSEG(Array(1))
c% = PEEK(VARPTR(Array(ArrayIndex(I) + 2)) + foo&)
IF c <> 0 THEN
DEF SEG = VARSEG(Mask(1))
POKE VARPTR(Mask(ArrayIndex(I) + 2)) + foo&, 0
ELSE
DEF SEG = VARSEG(Mask(1))
POKE VARPTR(Mask(ArrayIndex(I) + 2)) + foo&, 255
END IF
foo& = foo& + 1
NEXT x
NEXT y
NEXT I
DEF SEG
END SUB
SUB GFX (Size%, x1, y1, x2, y2)
FOR Xsize = x1 TO x2 STEP Size%
FOR Ysize = y1 TO y2 STEP Size%
P = POINT(Xsize, Ysize)
LINE (Xsize - 1, Ysize - 1)-(Xsize + Size% - 1, Ysize + Size% - 1), P, BF
NEXT Ysize
NEXT Xsize
END SUB
SUB INIT
FOR A% = 0 TO 359
LutCOS(A%) = COS(A% * PI / 180)
LutSIN(A%) = SIN(A% * PI / 180)
NEXT A%
FOR S% = 0 TO MAXSTARS
Stars(S%).x = INT(RND * 520)
Stars(S%).y = INT(RND * 180)
Stars(S%).xv = -(.01 + (RND * 1))
Stars(S%).yv = (.01 + (RND * 1))
Stars(S%).c = 16 + INT(RND * 16)
NEXT S%
RESTORE BUBBLEDATA
InitImageData "", BubbleSpr()
MakeImageIndex BubbleSpr(), BubbleIdx()
GenMask BubbleSpr(), BubbleIdx(), BubbleMask()
RESTORE MINEDATA
InitImageData "", MineSpr()
MakeImageIndex MineSpr(), MineIdx()
GenMask MineSpr(), MineIdx(), MineMask()
VPAGE(6) = 2560 'Width 320*8
VPAGE(7) = 200 'Height
LAYER = VARSEG(VPAGE(0)) + 1 'Buffer Seg(Ask Plasma)
'======
Bubble.x = 150
Bubble.y = 90
Bubble.xv = 0
Bubble.yv = 0
Bubble.Frame = 1
Score& = 0
Lives = 2
END SUB
SUB InitImageData (FileName$, ImageArray())
IF FileName$ <> "" THEN
'***** Read image data from file *****
'Establish size of integer array required.
FileNo = FREEFILE
OPEN FileName$ FOR BINARY AS #FileNo
Ints = (LOF(FileNo) - 7) \ 2
CLOSE #FileNo
REDIM ImageArray(1 TO Ints)
'Load image data directly into array memory.
DEF SEG = VARSEG(ImageArray(1))
BLOAD FileName$, 0
DEF SEG
ELSE
'***** Read image data from DATA statements *****
'Establish size of integer array required.
READ IntCount
REDIM ImageArray(1 TO IntCount)
'READ image DATA into array.
FOR n = 1 TO IntCount
READ x
ImageArray(n) = x
NEXT n
END IF
END SUB
SUB MakeImageIndex (ImageArray(), IndexArray())
'The index will initially be built in a temporary array, allowing
'for the maximum 1000 images per file.
DIM Temp(1 TO 1000)
ptr& = 1: IndexNo = 1: LastInt = UBOUND(ImageArray)
DO
Temp(IndexNo) = ptr&
IndexNo = IndexNo + 1
'Evaluate descriptor of currently referenced image to
'calculate the beginning of the next image.
x& = (ImageArray(ptr&) \ 8) * (ImageArray(ptr& + 1)) + 4
IF x& MOD 2 THEN x& = x& + 1
ptr& = ptr& + (x& \ 2)
LOOP WHILE ptr& < LastInt
LastImage = IndexNo - 1
'Copy the image index values into the actual index array.
REDIM IndexArray(1 TO LastImage)
FOR n = 1 TO LastImage
IndexArray(n) = Temp(n)
NEXT n
END SUB
SUB ReInit
Bubble.x = 150
Bubble.y = 90
Bubble.xv = 0
Bubble.yv = 0
Bubble.Frame = 1
FOR I = 0 TO MAXMINES
Mine(I).id = 0
Mine(I).x = 0
Mine(I).y = 0
Mine(I).cx = 0
Mine(I).cy = 0
Mine(I).xv = 0
Mine(I).yv = 0
Mine(I).Hei = 0
Mine(I).Wid = 0
Mine(I).angle = 0
Mine(I).Active = FALSE
Mine(I).Counter = 0
Mine(I).Frame = 0
NEXT I
END SUB
SUB SetVideoSeg (Segment) STATIC
DEF SEG
IF VideoAddrOff& = 0 THEN ' First time the sub is called
' We need to find the location of b$AddrC, which holds the graphics
' offset (b$OffC) and segment (b$SegC). Since b$AddrC is in the default
' segment, we can find it by setting it to a certain value, and then
' searching for that value.
SCREEN 13 ' Set b$SegC to A000 (00A0 in memory)
PSET (160, 100), 0 ' Set b$OffC to 7DA0 (not needed in the IDE)
FOR Offset& = 0 TO 32764 ' Search for b$AddrC, which is
IF PEEK(Offset&) = &HA0 THEN ' in the default segment and
IF PEEK(Offset& + 1) = &H7D THEN ' should have a value of
IF PEEK(Offset& + 2) = &H0 THEN ' A0 7D 00 A0.
IF PEEK(Offset& + 3) = &HA0 THEN
VideoAddrOff& = Offset& + 2 ' If we found it, record the
EXIT FOR ' offset of b$SegC and quit
END IF ' looking. (Oddly, changing
END IF ' the b$OffC doesn't seem to
END IF ' do anything, so this is why
END IF ' this sub only changes b$SegC)
NEXT
END IF
' Change b$SegC to the specified Segment
POKE VideoAddrOff&, Segment AND &HFF
POKE VideoAddrOff& + 1, (Segment AND &HFF00&) \ &H100
END SUB![[Image: anya2.jpg]](http://rel.betterwebber.com/Mypics/anya2.jpg)