Interplay's Learn to Program Basic (Review Copy)/Learn to Program Basic Review Copy (Interplay)(June 23, 1998).ISO/pc/ltpbasic/projects/sprmaker.bas

BASIC Source File | 1998-03-12 | 5.6 KB | 259 lines

CLS
TextColor 167 'Blue Hawaii
Print "This program can be used to"
Print "help you build sprite sets"
Print "of your own!"
Print
Print "To do this, create your sprites"
Print "using a separate paint program."
Print "Put your sprite images against"
Print "a solid color background, and"
Print "draw a rectangle around each"
Print "individual sprite cell."
Print
TextColor 21 'Black Is Black
Print "Name of .BMP file to load:"
Input Bitmap$
Print "Name for the resulting SpriteSet:"
Input SpriteSet$

CLS
Background Bitmap$
xStart = 0
yStart = 0

TextColor 96 'Red
Position 2,13
Print "Scanning rectangles...Please Wait"

Rem Set up a list of rectangles
maxRects = 200
Dim RectList(maxRects,4)
Rem Identify the meanings of each
Rem value for the second subscript of
Rem the rectangle array
rcLeft = 1
rcTop = 2
rcRight = 3
rcBottom = 4
Rem The number of rectangles we have
numRects = 0

Rem Get the background pixel value
Rem it is always assumed that the
Rem color at 0,0 is transparent!
empty = PGet(0,0)

Rem Fill the screen to this color
Rem then load the background again
Rem this is to avoid problems that
Rem occur if BMP is less than 320x240
Color empty
FillRect 0,0 to 320,240
Background Bitmap$

Rem Load a sound we'll use as a beep
beep = LoadSound("Pop")
doneSnd = LoadSound("Payoff")

Rem ------------------------
Rem Main Process
Rem ------------------------

Rem Gather up all the rectangles
result = TRUE
While result = TRUE
Gosub GetNextRect
if result = TRUE Then
Rem if we find a rectangle,
Rem change the color of it's
Rem outline so we know it was
Rem found, and make a sound
Color PGet(left,top) % 255
Rect left,top To right,bottom
PlaySound(beep)
Endif
Wend

Rem Now, go through the list
Rem and make them into sprites
For i = 1 To numRects
If i = 1 Then
Rem First time, we use the REPLACE option!
Rem Get the rectangle INSIDE the frame!
MakeSprite SpriteSet$ Rect RectList(i,rcLeft)+1,RectList(i,rcTop)+1 To RectList(i,rcRight)-1,RectList(i,rcBottom)-1 TRANSPARENT=empty REPLACE
Else
Rem For remaining sprite cells, we just append to the existing file
Rem Get the rectangle INSIDE the frame!
MakeSprite SpriteSet$ Rect RectList(i,rcLeft)+1,RectList(i,rcTop)+1 To RectList(i,rcRight)-1,RectList(i,rcBottom)-1 TRANSPARENT=empty
EndIf
Rem To give some visual feedback,
Rem let's 'erase' the image from the screen
Rem after we process it
Color empty
FillRect RectList(i,rcLeft),RectList(i,rcTop) To RectList(i,rcRight),RectList(i,rcBottom)
Next i

Rem All done!
PlaySound(doneSnd)
Rem Now, cycle through the sprites
Position 2,12
Print "Processed ";SpriteSet$;" into ";numRects;" frames."
Print "                                   "
Position 10,13
Print "Press a key to exit"
spr = LoadSprite(SpriteSet$)
SetSprite spr to 0,0
CycleSprite spr Speed 2
While Inkey$ <> ""
Wend
While Inkey$ = ""
Wend
HideSprite spr
CLS
END

Rem --------------------
Rem Find a rectangle
Rem If found, add to list
Rem
Rem result will be TRUE if
Rem a rectangle was added
Rem ----------------------
GetNextRect:
Gosub Scan
If result = TRUE Then
numRects = numRects + 1
Rem See if we went too far!
If numRects > maxRects Then
CLS
Print "There are too many"
Print "rectangles in this picture."
Print
Print "Scanning aborted."
End
Endif

RectList(numRects,rcLeft) = left
RectList(numRects,rcTop) = top
RectList(numRects,rcRight) = right
RectList(numRects,rcBottom) = bottom
Endif
Return


Rem --------------------------
Rem Check to see if a given x,y
Rem exists in any of the rectangles
Rem in the rectangle list
Rem
Rem result will be TRUE if the
Rem point is contain within one
Rem of the recorded rectangles
Rem ---------------------------
CheckPoint:
For i = 1 to numRects
If x >= RectList(i,rcLeft) AND x <= RectList(i,rcRight) Then
If y >= RectList(i,rcTop) AND y <= RectList(i,rcBottom) Then
Rem X and Y are part of this rect.
Rem return with left,top,right,bottom = the rect we're in
left = RectList(i,rcLeft)
top = RectList(i,rcTop)
right = RectList(i,rcRight)
bottom = RectList(i,rcBottom)
result = TRUE
return
EndIf
EndIf
Next i
result = FALSE
return


Rem ---------------------
Rem Scan for a rectangle
Rem
Rem start scanning at
Rem xStart,yStart
Rem result will be TRUE if
Rem a rectangle was found
Rem and left,top,right,bottom
Rem will contain the coordinates
Rem --------------------
Scan:
Rem Look for upper left
x = xStart
y = yStart
foundStart = FALSE
While foundStart = FALSE AND y < 238
Rem Find a non-transparent pixel
If PGet(x,y) <> empty then
Rem see if it looks like a rectangle starts here
If PGet(x,y+1) AND PGet(x+1,y) <> empty Then
Rem see if this is part of another rectangle
Gosub CheckPoint
If Result = TRUE then
Rem if it is within another rect, skip to the right edge and continue
x = right+1
Else
foundStart = TRUE
Endif
Else
Rem Doesn't appear to be a rectangle start. Keep looking
x = x+1
Rem If we get to the edge, wrap to next line
If x > 317 Then
x = 0
y = y + 1
EndIf
EndIf
Else
Rem Just found background color here. Keep looking.
x = x + 1
Rem If we get to the edge, wrap to next line
If x > 317 Then
x = 0
y = y + 1
EndIf
Endif
Wend
If FoundStart Then
Rem This may or may not be a real rectangle
Rem we have to scan it to find out
left = x
top = y
right = left
bottom = top
While PGet(x,y) <> empty AND x < 320
x = x + 1
Wend
right = x - 1
While PGet(left,y) <> empty AND PGet(right,y) <> empty AND y < 240
y = y + 1
Wend
bottom = y - 1

Rem Now check the rectangle to see if it makes sense
Rem Rectangles must contain at least one enclosed pixel
If right - left > 1 AND bottom - top > 1 Then
result = TRUE
else
Rem Not really a rectangle
xStart = right+1
yStart = top
Rem Keep Looking
Goto Scan
Endif

Else
result = FALSE
EndIf
Return