Posts: 65
Threads: 12
Joined: May 2003
Yoo, thanks
I don't think I need the pal saver because I scan in some scetches and then edit them further in pp256. So it doesnt matter if the colors get mixed up if the shape of the image is (dammit how do you say that in englisch hmmm ... think ... think ... got it (At least I hope so)) still vissible (is this right).[/img]
Posts: 3,288
Threads: 167
Joined: Nov 2001
Your Email addy?
Code: '/This converts a BMP tileset to pp256 compatible put format
'/MAX size of each tile is 100*100
'/This example uses 16*16.
'/Run the proram and it would create 2 file called:
'/1. Sultan.Put=pp256 tileset
'/2. sultan.Pal=Pal to be loaded in pp256
'/Put sultan.put in pp256\images\
'/put sultan.pal in pp256\palettes\
'/Then load sultan.put in pp256 and load sultan pal in pp256
'/You may have to modify this prog to get a single tile
'/I also have a converter that uses any pal(including) the default
'/VGA pal is you have your pal of choice. Just ask. :*)
'Relsoft
DECLARE SUB Rel.LoadPalPP256 (File$)
DECLARE SUB Rel.SaveBMP (Layer%, File$)
DECLARE SUB Rel.SwitchToPal (PalString$)
DECLARE SUB Rel.ReadPal (PalString$)
DECLARE SUB ConvertToPal (Layer%, PalString$)
DECLARE SUB Rel.LoadBMP (DestSeg%, File$, SwitchPal%)
'Note: Find this variables and change the values:
'Path$, OrigBMP$, NewBMP$
'Only supports 256 colors and up to 320*256
DEFINT A-Z
'Our BMP header
TYPE BMPHeaderType 'All values are for 320*200*256 bmp
ID AS STRING * 2 '"BM"
Size AS LONG 'width*heigth+1078= 65078
RSV1 AS INTEGER '0 Reserved
RSV2 AS INTEGER '0 Reserved
offset AS LONG '1078 First Pixel(Scanline order)
HORZ AS LONG '40
WID AS LONG '320
HEI AS LONG '200
PLANES AS INTEGER '1 num of Planes
BPP AS INTEGER '8 Bits per Plane
COMPRESSION AS LONG '0
IMAGESIZE AS LONG '64000 Width *Height
XRES AS LONG '3790 X pels
YRES AS LONG '3780 Y pels
CLRUSED AS LONG '0 Colors used
CLRIMPORT AS LONG '0 Colors Important
Pal AS STRING * 1024 'Order=Blue*4, Green*4, Red*4, 0 * 4
END TYPE
CONST FALSE = 0, TRUE = NOT FALSE
'Lookuo table for speed
DIM SHARED Ylut(199) AS LONG
'Pal
'Bmp Header
DIM SHARED BMP AS BMPHeaderType
DIM SHARED BMPpal AS STRING * 1024
'Filenames
DIM SHARED OrigBMP$ 'the original BMP
DIM SHARED Path$ 'the folder where the files reside
DIM SHARED TileName$ 'The Name of the pp256 tile
DIM SHARED Palname$ 'The pla in pp256 format
'INITIALIZE
'Init LookUp table for Y
FOR Y = 0 TO 199
Ylut(Y) = 320& * Y
NEXT Y
'IMPORTANT!!!!!!!
Path$ = "C:\Qbasic\Bmp2pp\" 'Change this to the folder your BMPs reside
OrigBMP$ = "Sultan.BMP" 'Bmp to convert
TileName$ = "Sultan.Put" 'Name of the Put file in pp256 format
Palname$ = "Sultan.Pal" 'the pp256 compatible pal
CLS
SCREEN 13
'Load the BMP to be converted
Rel.LoadBMP &HA000, Path$ + OrigBMP$, TRUE
Size = ((16 * 16) + 4) \ 2 'size of each 16*16 tile
MaxSize = Size * 198 '198 tiles
DIM Bmps(MaxSize) AS INTEGER 'array to hold the tiles
''''Get all the tiles in in a get put array
YY = 1
offset = 0
FOR Y = 1 TO 11
XX = 1
FOR X = 1 TO 18
'''''LINE (XX, YY)-(XX + 15, YY + 15), 15, B
GET (XX, YY)-(XX + 15, YY + 15), Bmps(offset * Size)
XX = XX + 17
offset = offset + 1
NEXT X
YY = YY + 17
NEXT Y
'''Save the BMP to pp256 format
Leng& = MaxSize& * 2&
DEF SEG = VARSEG(Bmps(0))
BSAVE Path$ + TileName$, VARPTR(Bmps(0)), UBOUND(Bmps) * 2&
DEF SEG
''''Save the pal to be loaded in pp256
FileNo = FREEFILE
Filename$ = Palname$
OPEN Path$ + Filename$ FOR BINARY AS #FileNo
OUT &H3C7, 0
FOR n = 0 TO 255
Colour& = 0
R = INP(&H3C9)
G = INP(&H3C9)
b = INP(&H3C9)
F = 0
Colour& = b * 65536 + G * 256 + R
PUT #FileNo, , Colour&
NEXT n
CLOSE #FileNo
C$ = INPUT$(1)
CLS
SCREEN 0
WIDTH 80
PRINT "Finished"
PRINT "Press any key"
C$ = INPUT$(1)
END
SUB ConvertToPal (Layer%, PalString$)
'Converts a bmp to the palette specified
'useful in ripping sprites
'closest color algo by Joakim AR of DK.
TempPal$ = SPACE$(768)
Rel.ReadPal TempPal$
REDIM TempPalArray(2, 255) AS INTEGER 'Current pal
REDIM TempPalArray2(2, 255) AS INTEGER 'PalString$ pal
ColorVal = 0
FOR I% = 1 TO 768 STEP 3
TempPalArray(0, ColorVal) = ASC(MID$(TempPal$, I%, 1))
TempPalArray(1, ColorVal) = ASC(MID$(TempPal$, I% + 1, 1))
TempPalArray(2, ColorVal) = ASC(MID$(TempPal$, I% + 2, 1))
ColorVal = ColorVal + 1
NEXT I%
ColorVal = 0
FOR I% = 1 TO 768 STEP 3
TempPalArray2(0, ColorVal) = ASC(MID$(PalString$, I%, 1))
TempPalArray2(1, ColorVal) = ASC(MID$(PalString$, I% + 1, 1))
TempPalArray2(2, ColorVal) = ASC(MID$(PalString$, I% + 2, 1))
ColorVal = ColorVal + 1
NEXT I%
'TempPalArray=DAC pal
'TempPalArray2=FJpal pal
DEF SEG = Layer%
FOR Y = 0 TO 199
FOR X = 0 TO 319
REM Pix = RelPoint(Layer, X, Y)
Pix = PEEK(Ylut(Y) + X)
Red = TempPalArray(0, Pix)
Green = TempPalArray(1, Pix)
Blue = TempPalArray(2, Pix)
'===
'Finds a color in the palfile
Almost = 768
FOR IC = 0 TO 255
R = TempPalArray2(0, IC)
G = TempPalArray2(1, IC)
b = TempPalArray2(2, IC)
HowClose = ABS(Red - R) + ABS(Green - G) + ABS(Blue - b)
IF HowClose <= Almost THEN FCol = IC: Almost = HowClose
NEXT IC
Cfound = FCol
'===
IF Cfound THEN
REM RelPset Layer, X, Y, Cfound
POKE Ylut(Y) + X, Cfound
END IF
NEXT X
NEXT Y
DEF SEG
ERASE TempPalArray
ERASE TempPalArray2
END SUB
SUB Rel.LoadBMP (DestSeg%, File$, SwitchPal%) STATIC
'Loads a BMP to a layer or directly to the screen
'if you want it to be on screen pass &HA000 as DestSeg%
'only supports 256 color BMPs.
F% = FREEFILE 'Get free filenum
OPEN File$ FOR BINARY AS #F% 'Binary read
GET #F%, , BMP 'Get header
'Our File Pointer points to 55 byte seek 55, first byte
'Pal should be 1024 in length
Pall$ = BMP.Pal
IF SwitchPal% THEN 'if we switch to pal then
IF LEN(Pall$) = 1024 THEN
OUT &H3C8, 0 'color zero start
FOR I% = 1 TO 1024 STEP 4
b% = ASC(MID$(Pall$, I%, 1)) \ 4 'div by 4
G% = ASC(MID$(Pall$, I% + 1, 1)) \ 4 'div by 4
R% = ASC(MID$(Pall$, I% + 2, 1)) \ 4 'div by 4
'Byte 4 unused. Just for padding 32 bit regs
OUT &H3C9, R%
OUT &H3C9, G%
OUT &H3C9, b%
NEXT I%
END IF
END IF
'Read and Write time!!!
'Notes: Bad MS(I don't get it why they stored it backwards?)
Byte$ = SPACE$(BMP.WID)
DEF SEG = DestSeg%
Wide% = BMP.WID - 1 'Sub 1 since we start at zero
Hite% = BMP.HEI - 1
FOR Y% = Hite% TO 0 STEP -1
GET #F%, , Byte$
FOR X% = 0 TO Wide%
POKE Ylut(Y%) + X%, ASC(MID$(Byte$, X + 1, 1))
NEXT X%
NEXT Y%
CLOSE #F%
DEF SEG
END SUB
SUB Rel.LoadPalPP256 (File$) STATIC
'Loads and Switches the pal to PP256's pal
'Special thanks goes to Kackurot for this one. LOL
IF File$ = "" THEN
FOR n = 0 TO 255
READ C&
b = C& \ 65536: C& = C& - b * 65536
G = C& \ 256: C& = C& - G * 256
R = C&
OUT &H3C8, n
OUT &H3C9, R
OUT &H3C9, G
OUT &H3C9, b
NEXT n
ELSE
IF INSTR(File$, ".") = 0 THEN
File$ = LEFT$(File$, 8) + ".Pal"
END IF
OPEN File$ FOR BINARY AS #1
FOR n = 0 TO 255
GET #1, , C&
b = C& \ 65536: C& = C& - b * 65536
G = C& \ 256: C& = C& - G * 256
R = C&
OUT &H3C8, n
OUT &H3C9, R
OUT &H3C9, G
OUT &H3C9, b
NEXT n
CLOSE
END IF
END SUB
SUB Rel.ReadPal (PalString$) STATIC
'Reads the DAC register and saves the value to palstring$
TempPal$ = SPACE$(768)
OUT &H3C7, 0
FOR I% = 0 TO 255
MID$(TempPal$, (I% * 3) + 1, 1) = CHR$(INP(&H3C9))
MID$(TempPal$, (I% * 3) + 2, 1) = CHR$(INP(&H3C9))
MID$(TempPal$, (I% * 3) + 3, 1) = CHR$(INP(&H3C9))
NEXT I%
PalString$ = TempPal$
END SUB
SUB Rel.SaveBMP (Layer%, File$) STATIC
'Saves the BMP from a layer to a file.
'Pass &ha000 as a layer if the GFX you want to save is on screen.
'only supports 256 color BMPs.
F% = FREEFILE 'Get free filenum
OPEN File$ FOR BINARY AS #F% 'Binary read
PUT #F%, , BMP 'Get header
DIM Byte AS STRING * 1
'Read and Write time!!!
'Notes: Bad MS(I don't get it why they stored it backwards?)
Byte$ = SPACE$(BMP.WID)
DEF SEG = Layer%
Wide% = BMP.WID - 1 'Sub 1 since we start at zero
Hite% = BMP.HEI - 1
FOR Y% = Hite% TO 0 STEP -1
FOR X% = 0 TO Wide%
Byte = CHR$(PEEK(Ylut(Y%) + X%))
PUT #F%, , Byte
NEXT X%
NEXT Y%
CLOSE #F%
DEF SEG
END SUB
SUB Rel.SwitchToPal (PalString$) STATIC
'Instantaneous pal switch
TempPal$ = SPACE$(768)
TempPal$ = PalString$
OUT &H3C8, 0
FOR I% = 1 TO 768 STEP 3
OUT &H3C9, ASC(MID$(TempPal$, I%, 1))
OUT &H3C9, ASC(MID$(TempPal$, I% + 1, 1))
OUT &H3C9, ASC(MID$(TempPal$, I% + 2, 1))
NEXT I%
END SUB
Posts: 65
Threads: 12
Joined: May 2003
Yes, this was just what I needed thanks Rel. Now i can go design graphics for my game.
Posts: 773
Threads: 71
Joined: Mar 2002
I'll email you the version I have. It converts GIF files into one 100*100 tile. With the original converter I encountered problem when changeing tile sizes. Later the BMP loader died on me( didn't want to work anymore) so I had to add my own GIF loader.
Acctually this is it...
Code: DECLARE SUB GifLoad (a$)
DECLARE FUNCTION FindColor% (Red%, Green%, Blue%)
'This File Does the converting of GIF to pp256 format
'using the palette specified.
'you may have to edit the damn thing :*)
'Huh?!!!!
'This saves 100*100 hahahahahaahaha!
'$INCLUDE: 'Rellib.BI'
'$DYNAMIC
CLS
SCREEN 13
DIM SHARED PAL AS STRING * 768
DIM SHARED FJpal AS STRING * 768
'RelReadPal TempPal$
path$ = "c:\convert\"
'RelLoadPalPP256 Path$ + "Town.Pal"
RelReadPal FJpal
GifLoad path$ + "YOURPIC.GIF"
'ConvertToPal VIDEO, FJpal
'RelSwitchtoPal FJpal
Size = RelSize(0, 0, 99, 99) '100*100(its zero based so 0-99
MaxSize = Size
DIM BMPS(MaxSize) AS INTEGER
GET (0, 0)-(99, 99), BMPS(0)
DEF SEG = VARSEG(BMPS(0))
BSAVE path$ + "YOURSPR.Put", VARPTR(BMPS(0)), UBOUND(BMPS) * 2&
DEF SEG
'GOTO Jumper2 'Rem This to save the Palette
'This Saves the current pal to pp256 format.
FileNo = FREEFILE
'Filename$ = "yourpal.Pal"
'KILL path$ + Filename$
OPEN path$ + "yourpal.pal" FOR BINARY AS #FileNo
OUT &H3C7, 0
FOR n = 0 TO 255
Colour& = 0
R = INP(&H3C9)
G = INP(&H3C9)
B = INP(&H3C9)
F = 0
Colour& = B * 65536 + G * 256 + R
PUT #FileNo, , Colour&
NEXT n
CLOSE #FileNo
Jumper2:
C$ = INPUT$(1)
CLS
SCREEN 0
WIDTH 80
END
REM $STATIC
SUB ConvertToPal (Layer, PalString$)
TempPal$ = SPACE$(768)
RelReadPal TempPal$
REDIM TempPalArray(2, 255) AS INTEGER 'Current pal
REDIM TempPalArray2(2, 255) AS INTEGER 'PalString$ pal
ColorVal = 0
FOR I% = 1 TO 768 STEP 3
TempPalArray(0, ColorVal) = ASC(MID$(TempPal$, I%, 1))
TempPalArray(1, ColorVal) = ASC(MID$(TempPal$, I% + 1, 1))
TempPalArray(2, ColorVal) = ASC(MID$(TempPal$, I% + 2, 1))
ColorVal = ColorVal + 1
NEXT I%
ColorVal = 0
FOR I% = 1 TO 768 STEP 3
TempPalArray2(0, ColorVal) = ASC(MID$(PalString$, I%, 1))
TempPalArray2(1, ColorVal) = ASC(MID$(PalString$, I% + 1, 1))
TempPalArray2(2, ColorVal) = ASC(MID$(PalString$, I% + 2, 1))
ColorVal = ColorVal + 1
NEXT I%
'TempPalArray=DAC pal
'TempPalArray2=FJpal pal
FOR Y = 0 TO 199
FOR X = 0 TO 319
Pix = RelPoint(Layer, X, Y)
Red = TempPalArray(0, Pix)
Green = TempPalArray(1, Pix)
Blue = TempPalArray(2, Pix)
'===
'Finds a color in the palfile
Almost = 768
FOR IC = 0 TO 255
R = TempPalArray2(0, IC)
G = TempPalArray2(1, IC)
B = TempPalArray2(2, IC)
HowClose = ABS(Red - R) + ABS(Green - G) + ABS(Blue - B)
IF HowClose <= Almost THEN FCol = IC: Almost = HowClose
NEXT IC
Cfound = FCol
'===
IF Cfound THEN
RelPset Layer, X, Y, Cfound
END IF
NEXT X
NEXT Y
DEF SEG
ERASE TempPalArray
ERASE TempPalArray2
END SUB
FUNCTION FindColor (Red, Green, Blue)
Almost = 768
FOR I = 1 TO 255
RelReadRGB I, R, G, B
HowClose = ABS(Red - R) + ABS(Green - G) + ABS(Blue - B)
IF HowClose <= Almost THEN FCol = I: Almost = HowClose
NEXT
FindColor = FCol
END FUNCTION
DEFSNG A-Z
SUB GifLoad (a$)
DEFINT A-Z
DIM Prefix(4095), Suffix(4095), OutStack(4095), shiftout%(8)
DIM Ybase AS LONG, powersof2(11) AS LONG, WorkCode AS LONG
FOR a% = 0 TO 7: shiftout%(8 - a%) = 2 ^ a%: NEXT a%
FOR a% = 0 TO 11: powersof2(a%) = 2 ^ a%: NEXT a%
IF a$ = "" THEN INPUT "GIF file"; a$: IF a$ = "" THEN END
IF INSTR(a$, ".") = 0 THEN a$ = a$ + ".gif"
OPEN a$ FOR BINARY AS #1
a$ = " ": GET #1, , a$
IF a$ <> "GIF87a" THEN PRINT "Not a GIF87a file.": END
GET #1, , TotalX: GET #1, , TotalY: GOSUB GetByte
NumColors = 2 ^ ((a% AND 7) + 1): NoPalette = (a% AND 128) = 0
GOSUB GetByte: Background = a%
GOSUB GetByte: IF a% <> 0 THEN PRINT "Bad screen descriptor.": END
IF NoPalette = 0 THEN p$ = SPACE$(NumColors * 3): GET #1, , p$
DO
GOSUB GetByte
IF a% = 44 THEN
EXIT DO
ELSEIF a% <> 33 THEN
PRINT "Unknown extension type.": END
END IF
GOSUB GetByte
DO: GOSUB GetByte: a$ = SPACE$(a%): GET #1, , a$: LOOP UNTIL a% = 0
LOOP
GET #1, , XStart: GET #1, , YStart: GET #1, , XLength: GET #1, , YLength
XEnd = XStart + XLength: YEnd = YStart + YLength: GOSUB GetByte
IF a% AND 128 THEN PRINT "Can't handle local colormaps.": END
Interlaced = a% AND 64: PassNumber = 0: PassStep = 8
GOSUB GetByte
ClearCode = 2 ^ a%
EOSCode = ClearCode + 1
FirstCode = ClearCode + 2: NextCode = FirstCode
StartCodeSize = a% + 1: CodeSize = StartCodeSize
StartMaxCode = 2 ^ (a% + 1) - 1: MaxCode = StartMaxCode
BitsIn = 0: BlockSize = 0: BlockPointer = 1
X% = XStart: Y% = YStart: Ybase = Y% * 320&
SCREEN 13: DEF SEG = &HA000
IF NoPalette = 0 THEN
'OUT &H3C7, 0: OUT &H3C8, 0
'FOR a% = 1 TO NumColors * 3: OUT &H3C9, ASC(MID$(p$, a%, 1)) \ 4: NEXT a%
END IF
LINE (0, 0)-(319, 199), Background, BF
DO
GOSUB GetCode
IF Code <> EOSCode THEN
IF Code = ClearCode THEN
NextCode = FirstCode
CodeSize = StartCodeSize
MaxCode = StartMaxCode
GOSUB GetCode
CurCode = Code: LastCode = Code: LastPixel = Code
IF X% < 320 THEN POKE X% + Ybase, LastPixel
X% = X% + 1: IF X% = XEnd THEN GOSUB NextScanLine
ELSE
CurCode = Code: StackPointer = 0
IF Code > NextCode THEN EXIT DO
IF Code = NextCode THEN
CurCode = LastCode
OutStack(StackPointer) = LastPixel
StackPointer = StackPointer + 1
END IF
DO WHILE CurCode >= FirstCode
OutStack(StackPointer) = Suffix(CurCode)
StackPointer = StackPointer + 1
CurCode = Prefix(CurCode)
LOOP
LastPixel = CurCode
IF X% < 320 THEN POKE X% + Ybase, LastPixel
X% = X% + 1: IF X% = XEnd THEN GOSUB NextScanLine
FOR a% = StackPointer - 1 TO 0 STEP -1
IF X% < 320 THEN POKE X% + Ybase, OutStack(a%)
X% = X% + 1: IF X% = XEnd THEN GOSUB NextScanLine
NEXT a%
IF NextCode < 4096 THEN
Prefix(NextCode) = LastCode
Suffix(NextCode) = LastPixel
NextCode = NextCode + 1
IF NextCode > MaxCode AND CodeSize < 12 THEN
CodeSize = CodeSize + 1
MaxCode = MaxCode * 2 + 1
END IF
END IF
LastCode = Code
END IF
END IF
LOOP UNTIL DoneFlag OR Code = EOSCode
'BEEP
'A$ = INPUT$(1)
EXIT SUB
GetByte: a$ = " ": GET #1, , a$: a% = ASC(a$): RETURN
NextScanLine:
IF Interlaced THEN
Y% = Y% + PassStep
IF Y% >= YEnd THEN
PassNumber = PassNumber + 1
SELECT CASE PassNumber
CASE 1: Y% = 4: PassStep = 8
CASE 2: Y% = 2: PassStep = 4
CASE 3: Y% = 1: PassStep = 2
END SELECT
END IF
ELSE
Y% = Y% + 1
END IF
X% = XStart: Ybase = Y% * 320&: DoneFlag = Y% > 199
RETURN
GetCode:
IF BitsIn = 0 THEN GOSUB ReadBufferedByte: LastChar = a%: BitsIn = 8
WorkCode = LastChar \ shiftout%(BitsIn)
DO WHILE CodeSize > BitsIn
GOSUB ReadBufferedByte: LastChar = a%
WorkCode = WorkCode OR LastChar * powersof2(BitsIn)
BitsIn = BitsIn + 8
LOOP
BitsIn = BitsIn - CodeSize
Code = WorkCode AND MaxCode
RETURN
ReadBufferedByte:
IF BlockPointer > BlockSize THEN
GOSUB GetByte: BlockSize = a%
a$ = SPACE$(BlockSize): GET #1, , a$
BlockPointer = 1
END IF
a% = ASC(MID$(a$, BlockPointer, 1)): BlockPointer = BlockPointer + 1
RETURN
END SUB
Posts: 2,020
Threads: 24
Joined: Jun 2002
speaking of which: rel... what happened to the junkyard? there was another site in its place awhile ago and now there's nothing!
i]"I know what you're thinking. Did he fire six shots or only five? Well, to tell you the truth, in all this excitement, I've kinda lost track myself. But being as this is a .44 Magnum ... you've got to ask yourself one question: 'Do I feel lucky?' Well, do ya punk?"[/i] - Dirty Harry
Posts: 3,288
Threads: 167
Joined: Nov 2001
The JunkYard is Dead. ;*(
But ressurection time is near.
BTW, I haven't had time to code this weekend cuz I was coding reports. But I've already finished the reports and coding time this weekend and you bet I'll put it on DW3 as Ive just finished most of what I've added to Rellib. :*)
|
![[Image: anya2.jpg]](http://rel.betterwebber.com/Mypics/anya2.jpg)
