Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!Code-Beispiel
TextureLoad
| Lizenz: | Erster Autor: | Letzte Bearbeitung: |
| k. A. |  Eternal_Pain |  04.11.2010 |
TextureLoad habe ich geschrieben um das laden von Bitmaps und GIF Dateien (ohne Libs) zu vereinfachen...
Naehere beschreibungen im Code selbst:
Dateiname:"[Function]TextureLoad.bi"
'Benotigt:
'[neu]LoadGif
'ReSize
'EPut
#Include once "[Function]GifLoad.bi"
#Include once "[Function]ReSize.bi"
#Include once "[Sub]EPut.bi"
#IfNDef NullBuffer
#Define IMGpitch(WIDTH,heigth) ((WIDTH+IIF(WIDTH MOD 4, 4-(WIDTH MOD 4),0))*4)
#Define NullBuffer(WIDTH,heigth) CALLOCATE(32+(IMGpitch(WIDTH,heigth)*heigth)+(WIDTH*4))
#EndIf
#Define HeaderGIFFile mid(Header,1,3)="GIF"
#Define HeaderBMPFile mid(Header,1,2)="BM"
#Define TextureCenter -1
#Define TextureStretch 0
#Define TexturePattern 1
#Define TextureAuto 2
/'
TextureLoader laedt eine Bitmap und gibt die
Adresse zu einem "Any PTR"-POINTER zurueck.
(Funktioniert nur mit einem vorher gesetzten SCREEN Modus ab 24BPP
Example:
DIM TextureOriginal AS ANY PTR
TextureOriginal=TextureLoad ("Picture.BMP")
'Laedt das Bild "Picture.BMP"
'und gibt es in einem 'Image-Buffer' zurueck
DIM TextureStretch AS ANY PTR
TextureStretch=TextureLoad ("Picture.BMP",640,480,0)
'Laedt das Bild "Picture.BMP"
'und vergroessert das Bild auf 640x480 Pixel
DIM TextureTile AS ANY PTR
TextureTile=TextureLoad ("Picture.BMP",640,480,1)
'Laedt das Bild "Picture.BMP"
'und fuellt eine flaeche von 640x480 Pixel damit
'Die jeweiligen 'Buffer' koennen einfach mit Put oder auch
'EPut auf den Screen bzw. anderen 'Buffer' 'gesetzt' werden.
Hinweis:
'Speicher wieder Freigeben!
kann mit "ImageDestroy" oder DEALLOCATE gemacht werden
'/
'Textur-[BMP/GIF]-Loader (Optimiert fuer 24/32BPP Buffer)
FUNCTION TextureLoad (BYVAL FileName AS STRING, _
BYVAL OutSizeX AS INTEGER=-1, _
BYVAL OutSizeY AS INTEGER=-1, _
BYVAL mode AS BYTE=-1, _
BYVAL BGColor AS INTEGER=-1) AS ANY PTR
/'
2010-02-09:
Mit "LoadGif" erweitert koennen jetzt auch GIFs geladen werden.
Dateierkennung nun durch HeaderInformation
FileName - Dateiname der Bitmap/GIF
OutSizeX - Breite des auszugebenen Buffers (-1 = Originalbreite)
OutSizeY - Hoehe des auszugebenen Buffers (-1 = Originalhoehe)
mode - Texturmode (-1 = Center, 0 = Stretch, 1 = Tile)
'/
DIM Header AS String*3
DIM SizeX AS UINTEGER
DIM SizeY AS UINTEGER
Dim THndl As Integer 'Hndl fuer den Umgang verschiedener Formate
'Pruefen ob Datei vorhanden und ggf. Header und groessen-Informationen laden
DIM F AS INTEGER=FREEFILE
If Dir(Filename)<>"" Then
OPEN FileName FOR BINARY ACCESS READ AS #F
GET #F, , Header
'Pruefen ob es sich um ein Bitmap handelt...
If HeaderBMPFile Then
GET #F, 19, SizeX
GET #F, , SizeY
THndl=1
'Pruefen ob es sich um eine GIF handelt...
ElseIf HeaderGIFFile Then
THndl=2
Else
Close #F
Return 0
End If
Close #F
ELSE
RETURN 0
END IF
'Ueberpruefen ob ein Screen gesetzt und Farbtiefe bei 24/32BPP ist...
DIM Buffer AS ANY PTR
DIM ScrD AS INTEGER
SCREENINFO ,,ScrD
IF SCREENPTR>0 AND ScrD>23 THEN
Select Case THndl
Case 1 'BMP
'Buffer Dimensionieren und Bitmap laden...
Buffer=NullBuffer (SizeX,SizeY)
BLOAD FileName,Buffer
If Peek(UInteger,Buffer)<>&h7 Then Return 0
Case 2 'GIF
Buffer=GIFLoad(FileName)
If Peek(UInteger,Buffer)<>&h7 Then Return 0
SizeX=Peek(UInteger,Buffer+8)
SizeY=Peek(UInteger,Buffer+12)
Case Else
Return 0
End Select
'Wenn keine Angabe zum 'Output' gemacht wurde, zurueckgeben wie geladen
IF OutSizeX<0 AND OutSizeY<0 THEN RETURN Buffer
ELSE
RETURN 0
END IF
'Wenn 'Output' Angaben gemacht wurden...
'OutPut-Buffer erstellen
DIM OutBuffer AS ANY PTR=ImageCreate (OutSizeX,OutSizeY,IIF(BGColor=-1,&hFFFF00FF,BGColor))
DIM IMode AS INTEGER=mode
IF mode>1 THEN
IF SizeX>OutSizeX AND SizeY>OutSizeY THEN IMode=0
IF SizeX<OutSizeX OR SizeY<OutSizeY THEN IMode=1
END IF
SELECT CASE IMode
'Bei mode -1 geladenen Buffer in OutPut-Buffer Zentrieren
CASE -1
EPut ((OutSizeX-SizeX)/2,(OutSizeY-SizeY)/2,Buffer,OutBuffer,1)
DEALLOCATE Buffer
RETURN OutBuffer
'Bei mode 0 geladenen Buffer auf die groesse des OutPut-Buffer ReDimensionieren
CASE 0
OutBuffer=Resize(Buffer,OutSizeX,OutSizeY)
DEALLOCATE Buffer
RETURN OutBuffer
'Bei mode 1 OutPut-Buffer mit geladenen Buffer 'fuellen'
CASE 1
FOR YP AS INTEGER=0 TO OutSizeY/SizeY
FOR XP AS INTEGER=0 TO OutSizeX/SizeX
EPut (XP*SizeX,YP*SizeY,Buffer,OutBuffer,1)
NEXT XP
NEXT YP
DEALLOCATE Buffer
RETURN OutBuffer
'Moeglich auftretene Fehler behandeln
CASE ELSE
DEALLOCATE OutBuffer
DEALLOCATE Buffer
RETURN 0
END SELECT
END FUNCTION
Datainame:"[Function]GifLoad.bi"
/'
[FUNCTION]GIFLoad: (beta .2 E)
-Erweiterung [Function]TextureLoad (1.1)
Projektstart : 2010-02-03
Letzte Aenderung : 2010-02-11 GIFLoad (beta .2 E)
Programmierer: [M. [Eternal [Black-Heart] Pain] A.]
"Liest 87a und 89a GIF Dateien und gibt das erste"
"gefundene Bild in einem Image zurueck"
Unterstuetzt:
- Alle Farbtiefen bis 8 BIT
- Interlaced
- GCM
- LCM
Nicht Unterstuetzt:
- PAR (mangels moeglichkeit zum testen weil ich kein Grafikprogramm
zur verfuegung hatte das diese option anbietet)
ToDo:
"- Speicher und Geschwindigkeitsoptimierung"
+Ueberlaeufe beseitigt, Reallocates weitgehend vermieden,
geschwindigkeit mit memcopy, trotz zusaetzlicher optionen
und abfragen ~20% verbessert
- Moeglichkeiten zur Optimierung der LZW Dekodierung finden
"- Auslesen/Nutzen der Informationsbloecke"
+Extensions koennen nun ausgegeben werden, bisher ist die rueckgabe
ein ZString PTR mit seinem Inhalt.
Application und Comment Extensions werden fehlerfrei ausgegeben
bei der Rueckgabe der anderen muss ich erst noch ein wenig testen...
-GCEs auslesen und verarbeiten um Transparenz zu nutzen
"- Moeglichkeit zum laden weiterer Bilder innerhalb der Gif einbauen"
" evtl. Ganze Animationen auslesen"
+Jetzt ist es moeglich jedes beliebige Bild in der Gif auszugeben.
Ist die Angabe groesser als Bilder Vorhanden sind, wird das zuletzt
gefundene bild zurueckgegeben.
- Die PAR (Pixel-Ratio-Aspekt) unterstuetzung noch mit einbinden
- Aufgabensplitting (Header,IBlock,PBlock,LZWDecode)
"!" ---------------------------------- "!"
Bisher wird ohne weitere Ueberpruefungen in ein Image geschrieben,
davon ausgehend das es ein 24/32BPP Buffer ist, da die FUNCTION Teil
einer uebergeordneten FUNCTION ist die diese Ueberpruefungen vorab erledigt
und vorraussetzt.
'/
#IfNDef MemCopy
Declare sub MemCopy cdecl alias "memcpy" (dest As Any Ptr, src As Any Ptr, length As ushort)
#EndIf
Declare Function GIFLoad (Byval FileName as String, Byval Entry as Integer=0, Byval EType as Integer=0) as any ptr
Declare Function GetStandardPal as Uinteger ptr
#Define GIFVersion87a "87a"
#Define GIFVersion89a "89a"
'Gibt ein Imagebuffer zurueck
#Define GetGIF_Image &h2C
'Gibt eine ZString ptr zurueck
#Define GetGIF_Extension &h21
#Define GetGIF_Plain_Text_Extension &h01
#Define GetGIF_Comment_Extension &hFE
#Define GetGIF_Graphic_Control_Extension &hF9
#Define GetGIF_Application_Extension &hFF
#Define GetGIF_Version &h100
'Gibt eine Integer ptr zurueck
#Define GetGIF_Width &h101
#Define GetGIF_Height &h102
Public Function GIFLoad (Byval FileName as String, Byval Entry as Integer=0, Byval EType as Integer=0) as any ptr
Scope
Dim FF as Integer = FreeFile
Dim ReadByte as UByte
'Suche bestimmen...
Dim SeperatorSearch as Integer
Select Case EType
Case &h00, &h2C 'Image
SeperatorSearch=&h2C
Case &h01, &h21, &hF9, &hFE, &hFF 'Information
SeperatorSearch=&h21
Case &h100 'Version
SeperatorSearch=&h100
Case &h101 'Breite/Width
SeperatorSearch=&h101
Case &h102 'Hoehe/Height
SeperatorSearch=&h102
Case Else
Return 0
End Select
'-----------------------------------------'
Open FileName for Binary access Read as #FF
Dim Version as Integer
'Version (7/9)
Dim VReturn as ZString ptr
Get #FF, 5,ReadByte
Version = ReadByte
If SeperatorSearch=&h100 Then
Close #FF
Select Case Version
Case 55
VReturn=Callocate(4)
*VReturn=GIFVersion87a
Return VReturn
Case 57
VReturn=Callocate(4)
*VReturn=GIFVersion89a
Return VReturn
Case Else
Return 0
End Select
End If
'GIFWidth (0-16000)
Dim WReturn as Integer ptr
Dim GIFWidth as Integer
Get #FF, 7,ReadByte
GIFWidth = ReadByte
Get #FF, 8,ReadByte
GIFWidth += ReadByte SHL 8
If SeperatorSearch=&h101 Then
Close #FF
WReturn=Callocate(4)
WReturn[0]=GIFWidth
Return WReturn
End If
'GIFHeight (0-16000)
Dim HReturn as Integer ptr
Dim GIFHeight as Integer
Get #FF, 9,ReadByte
GIFHeight = ReadByte
Get #FF,10,ReadByte
GIFHeight += ReadByte SHL 8
If SeperatorSearch=&h102 Then
Close #FF
HReturn=Callocate(4)
HReturn[0]=GIFHeight
Return HReturn
End If
'GCM and BGColor
Dim ColorFlag as UByte
Dim ColorCount as Integer
Dim Backgroundcol as UByte
Dim GIFGCMPal as UInteger ptr
Dim RGBEntry as UByte PTR
Get #FF,11,ColorFlag
Get #FF,12,BackgroundCol
If Bit(ColorFlag,7) Then
ColorCount=2^((ColorFlag and &b00000111)+1)
GIFGCMPal=Callocate(ColorCount*4)
RGBEntry=Callocate(4)
'Dummy
Get #FF,13,ReadByte
For C as Integer=0 to ColorCount-1
Get #FF,,*RGBEntry,3
GIFGCMPal[C]=RGB(RGBEntry[0],RGBEntry[1],RGBEntry[2])
Next C
Deallocate (RGBEntry)
End If
'SeperatorSearch
Dim Seperator as UByte
Dim InfCount as Integer
Dim InfPos as UInteger
Dim NextPos as Integer
Get #FF,13+(ColorCount*3),ReadByte 'Dummy zur Positions bestimmtung
while not EOF(FF)
Get #FF,,Seperator
If Seperator=0 or Seperator=&h3B Then
Exit while
End If
Select Case Seperator
Case &h2C
'Image
'---------------------------------'
If SeperatorSearch=&h2C Then
InfPos=Loc(FF)
InfCount+=1
If Entry=IIF(Entry=0,(InfCount-1),InfCount) Then Exit While
End If
'Block ueberspringen
Get #FF,Loc(FF)+9,ReadByte
'Lokale Farbtabelle
If Bit(ReadByte,7) Then
ColorCount=2^((ReadByte and &b00000111)+1)
Get #FF,Loc(FF)+(ColorCount*3),ReadByte
End If
'Image Daten
Get #FF,Loc(FF)+2,ReadByte
NextPos=ReadByte
Do
Get #FF,Loc(FF)+NextPos+1,ReadByte
NextPos=ReadByte
Loop While ReadByte>0
Case &h21
'Informationsblock
'---------------------------------'
Get #FF,,ReadByte 'BlockType
If SeperatorSearch=&h21 Then
If EType=&h21 or ReadByte=EType Then
InfPos=Loc(FF)-1
InfCount+=1
If Entry=IIF(Entry=0,(InfCount-1),InfCount) Then Exit While
End If
End If
'Block ueberspringen
GET #FF,LOC(FF)+1,ReadByte
DO
GET #FF,LOC(FF)+ReadByte+1,ReadByte
LOOP UNTIL ReadByte=0
'---------------------------------'
Case Else
InfPos=0
Exit While
End Select
Wend
If InfPos=0 Then
Close #FF
If GIFGCMPal Then Deallocate (GIFGCMPal)
Return 0
End If
'-----------------------'
Dim InfType as UByte
Dim CodeSize as UByte
Dim GIFLeft as Integer
Dim GIFTop as Integer
Dim Interlaced as Integer
Get #FF,InfPos,InfType
If InfType=&h2C Then
'Left
Get #FF,,ReadByte
GIFLeft = ReadByte
Get #FF,,ReadByte
GIFLeft += ReadByte SHL 8
'Top
Get #FF,,ReadByte
GIFTop = ReadByte
Get #FF,,ReadByte
GIFTop += ReadByte SHL 8
'Width
Get #FF,,ReadByte
GIFWidth = ReadByte
Get #FF,,ReadByte
GIFWidth += ReadByte SHL 8
'Height
Get #FF,,ReadByte
GIFHeight = ReadByte
Get #FF,,ReadByte
GIFHeight += ReadByte SHL 8
'LCM
Get #FF,,ColorFlag
If Bit(ColorFlag,6) Then Interlaced=1
If Bit(ColorFlag,7) Then
ColorCount=2^((ColorFlag and &b00000111)+1)
If GIFGCMPal Then
Deallocate (GIFGCMPal)
GIFGCMPal=0
End If
GIFGCMPal=Callocate(ColorCount*4)
RGBEntry=Callocate(3)
For C as Integer=0 to ColorCount-1
Get #FF,,*RGBEntry,3
GIFGCMPal[C]=RGB(RGBEntry[0],RGBEntry[1],RGBEntry[2])
Next C
Deallocate (RGBEntry)
End If
'CodeSize
GET #FF,,ReadByte
CodeSize=ReadByte
ElseIf InfType=&h21 Then
GET #FF,,ReadByte
CodeSize = 7
End If
'-----------------------'
Dim BlockLen as UByte
Dim Block as Ubyte PTR
Dim LZWPos as UInteger
Dim LZWBuffer as UByte PTR
'Temporal ausreichend speicher reservieren um
'Reallocate sowenig wie noetig zu nutzen
Dim TempSize as UInteger=(GIFWidth*GIFHeight)
Dim TempMem as any ptr
LZWBuffer=Callocate(TempSize)
'gesmmte LZW Daten vom angefragten/gefundenen Block auslesen
Dim LZWAdr as any ptr
Dim BlockAdr as any ptr
WHILE Not Eof(FF)
Get #FF,,BlockLen
IF BlockLen=0 THEN EXIT WHILE
Block=Callocate(256)
GET #FF,,*Block,BlockLen
'Falls Temporal reservierter speicher nicht ausreichen sollte
If LZWPos+BlockLen > TempSize-1 Then
TempMem=Reallocate(LZWBuffer,TempSize*2)
TempSize=TempSize*2
End If
LZWAdr = LZWBuffer+LZWPos
BlockAdr = Block
MemCopy (LZWAdr,BlockAdr,255)
'for l as integer=0 to BlockLen-1
' LZWBuffer[LZWPos]=Block[l]
' LZWPos+=1
'next l
Deallocate (Block)
Block = 0
LZWPos+=BlockLen
WEND
Close #FF
If Block Then Deallocate (Block)
Dim LZWData as UByte PTR
Dim Splitter as UInteger
Dim SplitterLen as UShort
Dim LZWDataAdr as any ptr
Dim LZWBufferAdr as any ptr
If LZWPos Then
LZWData=Callocate(LZWPos)
Do
'for l as integer=0 to LZWPos-1
' LZWData[l]=LZWBuffer[l]
'next l
If LZWPos-Splitter>&hFFFF Then
SplitterLen=&hFFFF
Else
SplitterLen=LZWPos-Splitter
End If
LZWDataAdr = @LZWData[Splitter]
LZWBufferAdr = @LZWBuffer[Splitter]
MemCopy (LZWDataAdr,LZWBufferAdr,SplitterLen-1)
Splitter+=SplitterLen-1
Loop While SplitterLen=&hFFFF
Deallocate (LZWBuffer)
Else
Deallocate (LZWBuffer)
If GIFGCMPal Then Deallocate (GIFGCMPal)
Return 0
End If
Dim nBit as Integer
nBit = CodeSize+1
Dim ByteNow as Integer
Dim BitPos as Integer
Dim Value as Integer
'CodeTableInit
Dim LZWTable as Ubyte ptr ptr = Callocate(&h1000*4)
Dim LZWTableLen as UInteger ptr = Callocate(&h1000*4)
Dim LZWTemp as any ptr
TempSize = (GIFWidth*GIFHeight)
Dim DecodeBytes as UByte ptr=Callocate(TempSize)
For CT as Integer=0 to (2^CodeSize)-1
LZWTable[CT]=Callocate(1)'
LZWTable[CT][0]=CT
LZWTableLen[CT]=1
Next CT
Dim BytePos as UInteger
WHILE 1
FOR RB AS INTEGER=((2^CodeSize)+2) TO &hFFF
IF LEN(BIN(RB-1))>nBit THEN
nBit=LEN(BIN(RB-1))
END IF
'BitReader:
'-------------------------------------------------------'
Value=0
FOR B AS INTEGER=0 TO nBit-1
IF BIT(LZWData[ByteNow],BitPos) THEN Value += (1 SHL B)
BitPos+=1
IF BitPos=8 THEN
BitPos=0
ByteNow+=1
IF ByteNow=LZWPos-1 THEN
Exit While
END IF
END IF
NEXT B
'-------------------------------------------------------'
SELECT CASE Value
CASE IS < (2^CodeSize)
If LZWTable[RB] Then Deallocate (LZWTable[RB])
LZWTable[RB]=Callocate(1)
LZWTable[RB][0]=LZWTable[Value][0]
LZWTableLen[RB]=1
CASE IS = (2^CodeSize)
nBit=CodeSize+1
EXIT FOR
CASE IS = (2^CodeSize)+1
EXIT WHILE
CASE IS > (2^CodeSize)+1
If LZWTable[RB] Then Deallocate LZWTable[RB]
LZWTableLen[RB]=LZWTableLen[Value]+1
LZWTable[RB]=Callocate(LZWTableLen[RB])
If LZWTable[Value] Then
'for l as integer=0 to LZWTableLen[Value]-1
MemCopy (LZWTable[RB],LZWTable[Value],LZWTableLen[Value])
'LZWTable[RB][l]=LZWTable[Value][l]
'next l
End If
If LZWTableLen[Value+1]>0 and Value<&hFFF Then
LZWTable[RB][LZWTableLen[RB]-1]=LZWTable[Value+1][0]
Else
LZWTable[RB][LZWTableLen[RB]-1]=0
End If
END SELECT
If LZWTableLen[RB] Then
If BytePos+LZWTableLen[RB]>TempSize-1 Then
TempMem=Reallocate(DecodeBytes,TempSize+4000)
DecodeBytes=TempMem
TempSize+=4000
End If
'for l as integer=0 to LZWTableLen[RB]-1
' DecodeBytes[BytePos]=LZWTable[RB][l]
' BytePos+=1
'Next l
MemCopy (@DecodeBytes[BytePos],LZWTable[RB],LZWTableLen[RB])
BytePos+=LZWTableLen[RB]
End If
Next RB
Wend
'Decodierten Daten verarbeiten....
Dim GIFImage as any ptr
Dim ImagePitch as UInteger
Dim InfoBlock as UByte ptr
Dim ILStep as Integer
Dim RY as Integer
If InfType=&h2C Then
If GIFGCMPal=0 Then GIFGCMPal=GetStandardPal
GIFImage=ImageCreate(GIFWidth,GIFHeight,GIFGCMPal[BackgroundCol])
ImagePitch=Peek (Uinteger,GIFImage+16)
For Y as Integer=GIFTop to GIFHeight-1
If Interlaced=0 Then RY=Y
If Interlaced Then
Select Case ILStep
Case 0,1
If Y>0 Then RY+=8
Case 2
RY+=4
Case 3,4
RY+=2
End Select
If RY>GIFHeight-1 Then
ILStep+=1
Select Case ILStep
Case 0,1
RY=GIFTop+4
Case 2
RY=GIFTop+2
Case 3,4
RY=GIFTop+1
End Select
End If
End If
For X as Integer=GIFLeft to GIFWidth-1
Poke UInteger,GIFImage+32+(X*4)+(RY*ImagePitch),GIFGCMPal[DecodeBytes[X+(Y*GIFWidth)]]
Next X
next Y
ElseIf InfType=&h21 Then
InfoBlock=Callocate(BytePos+1)
'MemCopy (@InfoBlock[0],@DecodeBytes[0],BytePos)
for l as integer=0 to BytePos
InfoBlock[l]=DecodeBytes[l]
next l
End If
Deallocate (DecodeBytes)
For CT as Integer=0 to &hFFF
If LZWTable[CT] Then Deallocate (LZWTable[CT])
Next CT
Deallocate (LZWTable)
Deallocate (LZWTableLen)
If GIFGCMPal Then Deallocate (GIFGCMPal)
Deallocate (LZWData)
If InfType=&h2C Then Return GIFImage
If InfType=&h21 Then Return InfoBlock
return 0
End Scope
End Function
Private Function GetStandardPal as Uinteger ptr
Dim GSP as UInteger PTR=Callocate(256*4)
GSP[&h00]=&hFF000000
GSP[&h01]=&hFF0000AA
GSP[&h02]=&hFF00AA00
GSP[&h03]=&hFF00AAAA
GSP[&h04]=&hFFAA0000
GSP[&h05]=&hFFAA00AA
GSP[&h06]=&hFFAA5500
GSP[&h07]=&hFFAAAAAA
GSP[&h08]=&hFF555555
GSP[&h09]=&hFF5555FF
GSP[&h0A]=&hFF55FF55
GSP[&h0B]=&hFF55FFFF
GSP[&h0C]=&hFFFF5555
GSP[&h0D]=&hFFFF55FF
GSP[&h0E]=&hFFFFFF55
GSP[&h0F]=&hFFFFFFFF
GSP[&h10]=&hFF000000
GSP[&h11]=&hFF141414
GSP[&h12]=&hFF202020
GSP[&h13]=&hFF2C2C2C
GSP[&h14]=&hFF383838
GSP[&h15]=&hFF444444
GSP[&h16]=&hFF505050
GSP[&h17]=&hFF616161
GSP[&h18]=&hFF717171
GSP[&h19]=&hFF818181
GSP[&h1A]=&hFF919191
GSP[&h1B]=&hFFA1A1A1
GSP[&h1C]=&hFFB6B6B6
GSP[&h1D]=&hFFCACACA
GSP[&h1E]=&hFFE2E2E2
GSP[&h1F]=&hFFFFFFFF
GSP[&h20]=&hFF0000FF
GSP[&h21]=&hFF4000FF
GSP[&h22]=&hFF7D00FF
GSP[&h23]=&hFFBE00FF
GSP[&h24]=&hFFFF00FF
GSP[&h25]=&hFFFF00BE
GSP[&h26]=&hFFFF007D
GSP[&h27]=&hFFFF0040
GSP[&h28]=&hFFFF0000
GSP[&h29]=&hFFFF4000
GSP[&h2A]=&hFFFF7D00
GSP[&h2B]=&hFFFFBE00
GSP[&h2C]=&hFFFFFF00
GSP[&h2D]=&hFFBEFF00
GSP[&h2E]=&hFF7DFF00
GSP[&h2F]=&hFF40FF00
GSP[&h30]=&hFF00FF00
GSP[&h31]=&hFF00FF40
GSP[&h32]=&hFF00FF7D
GSP[&h33]=&hFF00FFBE
GSP[&h34]=&hFF00FFFF
GSP[&h35]=&hFF00BEFF
GSP[&h36]=&hFF007DFF
GSP[&h37]=&hFF0040FF
GSP[&h38]=&hFF7D7DFF
GSP[&h39]=&hFF9D7DFF
GSP[&h3A]=&hFFBE7DFF
GSP[&h3B]=&hFFDE7DFF
GSP[&h3C]=&hFFFF7DFF
GSP[&h3D]=&hFFFF7DDE
GSP[&h3E]=&hFFFF7DBE
GSP[&h3F]=&hFFFF7D9D
GSP[&h40]=&hFFFF7D7D
GSP[&h41]=&hFFFF9D7D
GSP[&h42]=&hFFFFBE7D
GSP[&h43]=&hFFFFDE7D
GSP[&h44]=&hFFFFFF7D
GSP[&h45]=&hFFDEFF7D
GSP[&h46]=&hFFBEFF7D
GSP[&h47]=&hFF9DFF7D
GSP[&h48]=&hFF7DFF7D
GSP[&h49]=&hFF7DFF9D
GSP[&h4A]=&hFF7DFFBE
GSP[&h4B]=&hFF7DFFDE
GSP[&h4C]=&hFF7DFFFF
GSP[&h4D]=&hFF7DDEFF
GSP[&h4E]=&hFF7DBEFF
GSP[&h4F]=&hFF7D9DFF
GSP[&h50]=&hFFB6B6FF
GSP[&h51]=&hFFC6B6FF
GSP[&h52]=&hFFDAB6FF
GSP[&h53]=&hFFEAB6FF
GSP[&h54]=&hFFFFB6FF
GSP[&h55]=&hFFFFB6EA
GSP[&h56]=&hFFFFB6DA
GSP[&h57]=&hFFFFB6C6
GSP[&h58]=&hFFFFB6B6
GSP[&h59]=&hFFFFC6B6
GSP[&h5A]=&hFFFFDAB6
GSP[&h5B]=&hFFFFEAB6
GSP[&h5C]=&hFFFFFFB6
GSP[&h5D]=&hFFEAFFB6
GSP[&h5E]=&hFFDAFFB6
GSP[&h5F]=&hFFC6FFB6
GSP[&h60]=&hFFB6FFB6
GSP[&h61]=&hFFB6FFC6
GSP[&h62]=&hFFB6FFDA
GSP[&h63]=&hFFB6FFEA
GSP[&h64]=&hFFB6FFFF
GSP[&h65]=&hFFB6EAFF
GSP[&h66]=&hFFB6DAFF
GSP[&h67]=&hFFB6C6FF
GSP[&h68]=&hFF000071
GSP[&h69]=&hFF1C0071
GSP[&h6A]=&hFF380071
GSP[&h6B]=&hFF550071
GSP[&h6C]=&hFF710071
GSP[&h6D]=&hFF710055
GSP[&h6E]=&hFF710038
GSP[&h6F]=&hFF71001C
GSP[&h70]=&hFF710000
GSP[&h71]=&hFF711C00
GSP[&h72]=&hFF713800
GSP[&h73]=&hFF715500
GSP[&h74]=&hFF717100
GSP[&h75]=&hFF557100
GSP[&h76]=&hFF387100
GSP[&h77]=&hFF1C7100
GSP[&h78]=&hFF007100
GSP[&h79]=&hFF00711C
GSP[&h7A]=&hFF007138
GSP[&h7B]=&hFF007155
GSP[&h7C]=&hFF007171
GSP[&h7D]=&hFF005571
GSP[&h7E]=&hFF003871
GSP[&h7F]=&hFF001C71
GSP[&h80]=&hFF383871
GSP[&h81]=&hFF443871
GSP[&h82]=&hFF553871
GSP[&h83]=&hFF613871
GSP[&h84]=&hFF713871
GSP[&h85]=&hFF713861
GSP[&h86]=&hFF713855
GSP[&h87]=&hFF713844
GSP[&h88]=&hFF713838
GSP[&h89]=&hFF714438
GSP[&h8A]=&hFF715538
GSP[&h8B]=&hFF716138
GSP[&h8C]=&hFF717138
GSP[&h8D]=&hFF617138
GSP[&h8E]=&hFF557138
GSP[&h8F]=&hFF447138
GSP[&h90]=&hFF387138
GSP[&h91]=&hFF387144
GSP[&h92]=&hFF387155
GSP[&h93]=&hFF387161
GSP[&h94]=&hFF387171
GSP[&h95]=&hFF386171
GSP[&h96]=&hFF385571
GSP[&h97]=&hFF384471
GSP[&h98]=&hFF505071
GSP[&h99]=&hFF595071
GSP[&h9A]=&hFF615071
GSP[&h9B]=&hFF695071
GSP[&h9C]=&hFF715071
GSP[&h9D]=&hFF715069
GSP[&h9E]=&hFF715061
GSP[&h9F]=&hFF715059
GSP[&hA0]=&hFF715050
GSP[&hA1]=&hFF715950
GSP[&hA2]=&hFF716150
GSP[&hA3]=&hFF716950
GSP[&hA4]=&hFF717150
GSP[&hA5]=&hFF697150
GSP[&hA6]=&hFF617150
GSP[&hA7]=&hFF597150
GSP[&hA8]=&hFF507150
GSP[&hA9]=&hFF507159
GSP[&hAA]=&hFF507161
GSP[&hAB]=&hFF507169
GSP[&hAC]=&hFF507171
GSP[&hAD]=&hFF506971
GSP[&hAE]=&hFF506171
GSP[&hAF]=&hFF505971
GSP[&hB0]=&hFF000040
GSP[&hB1]=&hFF100040
GSP[&hB2]=&hFF200040
GSP[&hB3]=&hFF300040
GSP[&hB4]=&hFF400040
GSP[&hB5]=&hFF400030
GSP[&hB6]=&hFF400020
GSP[&hB7]=&hFF400010
GSP[&hB8]=&hFF400000
GSP[&hB9]=&hFF401000
GSP[&hBA]=&hFF402000
GSP[&hBB]=&hFF403000
GSP[&hBC]=&hFF404000
GSP[&hBD]=&hFF304000
GSP[&hBE]=&hFF204000
GSP[&hBF]=&hFF104000
GSP[&hC0]=&hFF004000
GSP[&hC1]=&hFF004010
GSP[&hC2]=&hFF004020
GSP[&hC3]=&hFF004030
GSP[&hC4]=&hFF004040
GSP[&hC5]=&hFF003040
GSP[&hC6]=&hFF002040
GSP[&hC7]=&hFF001040
GSP[&hC8]=&hFF202040
GSP[&hC9]=&hFF282040
GSP[&hCA]=&hFF302040
GSP[&hCB]=&hFF382040
GSP[&hCC]=&hFF402040
GSP[&hCD]=&hFF402038
GSP[&hCE]=&hFF402030
GSP[&hCF]=&hFF402028
GSP[&hD0]=&hFF402020
GSP[&hD1]=&hFF402820
GSP[&hD2]=&hFF403020
GSP[&hD3]=&hFF403820
GSP[&hD4]=&hFF404020
GSP[&hD5]=&hFF384020
GSP[&hD6]=&hFF304020
GSP[&hD7]=&hFF284020
GSP[&hD8]=&hFF204020
GSP[&hD9]=&hFF204028
GSP[&hDA]=&hFF204030
GSP[&hDB]=&hFF204038
GSP[&hDC]=&hFF204040
GSP[&hDD]=&hFF203840
GSP[&hDE]=&hFF203040
GSP[&hDF]=&hFF202840
GSP[&hE0]=&hFF2C2C40
GSP[&hE1]=&hFF302C40
GSP[&hE2]=&hFF342C40
GSP[&hE3]=&hFF3C2C40
GSP[&hE4]=&hFF402C40
GSP[&hE5]=&hFF402C3C
GSP[&hE6]=&hFF402C34
GSP[&hE7]=&hFF402C30
GSP[&hE8]=&hFF402C2C
GSP[&hE9]=&hFF40302C
GSP[&hEA]=&hFF40342C
GSP[&hEB]=&hFF403C2C
GSP[&hEC]=&hFF40402C
GSP[&hED]=&hFF3C402C
GSP[&hEE]=&hFF34402C
GSP[&hEF]=&hFF30402C
GSP[&hF0]=&hFF2C402C
GSP[&hF1]=&hFF2C4030
GSP[&hF2]=&hFF2C4034
GSP[&hF3]=&hFF2C403C
GSP[&hF4]=&hFF2C4040
GSP[&hF5]=&hFF2C3C40
GSP[&hF6]=&hFF2C3440
GSP[&hF7]=&hFF2C3040
GSP[&hF8]=&hFF000000
GSP[&hF9]=&hFF000000
GSP[&hFA]=&hFF000000
GSP[&hFB]=&hFF000000
GSP[&hFC]=&hFF000000
GSP[&hFD]=&hFF000000
GSP[&hFE]=&hFF000000
GSP[&hFF]=&hFF000000
Return GSP
End Function
Dateiname:"[Function]ReSize.bi"
'Benoetigt:
'IMGCreate
'#Include once "[Function]IMGCreate.bi"
/'
ReSize vergroessert/verkleinert einen 'ImageBuffer'
Example:
NeuesBildBuffer=ReSize (OriginalBildBuffer,NeueBreite,NeueHoehe,AusgangsOption)
Mit der AusgangsOption kann das neu Dimensionierte Bild in der selben Buffergroesse
zurueckgegeben werden, dabei gehen Bildinhalte ausserhalb dieses Bereiches verloren.
'/
'ReSize
'Dimensioniert einen Buffer und seinen Inhalt neu
Function ReSize (byref InBuffer as any ptr, byval NSizeX as Integer, _
NSizeY as Integer, Byval InOut as Integer=0) as any ptr
'InOut - 0=Inhalt und Buffer vergroessern
' 1=Bufferinhalt vergroessern und Buffergroesse beibehalten
If InBuffer=0 Then Return 0
Dim GetInteger as Integer Ptr=InBuffer
Dim BufferVersion as Integer=GetInteger[0]
If BufferVersion <> &h7 Then Return 0
Dim BufferSizeX as Integer=GetInteger[2]
Dim BufferSizeY as Integer=GetInteger[3]
Dim SBuffer as any ptr
Dim XStep as Double
Dim YStep as Double
Dim XS as Integer
Dim YS as Integer
Dim XE as Integer
Dim YE as Integer
XStep=(NSizeX-1)/(BufferSizeX)
YStep=(NSizeY-1)/(BufferSizeY)
SBuffer=IMaGeCreate(NSizeX,NSizeY)
Dim SCol as Integer
For Y as Integer=0 to BufferSizeY-1
For X as Integer=0 to BufferSizeX-1
SCol=Point (X,Y,InBuffer)
XS=XStep*X
YS=YStep*Y
XE=XStep+(XStep*X)
YE=YStep+(YStep*Y)
'XE=XStep*(X+1)
'YE=YStep*(Y+1)
Line SBuffer,(XS,YS)-(XE,YE),SCol,bf
Next X
Next Y
If InOut<>0 Then
'hinzugefuegt um das vergroesserte/verkleinertebild in selber buffergroesse
'zurueck zu liefern
Dim NBuffer as any ptr=IMaGeCreate(BufferSizeX,BuffersizeY,&hFFFF00FF)
Dim PCX as Integer
Dim PCY as Integer
If NSizeX>BufferSizeX Then
PCX=int((NSizeX-(BufferSizeX-1))/2)
PCY=int((NSizeY-(BufferSizeY-1))/2)
Get SBuffer,(PCX,PCY)-(PCX+BufferSizeX-1,PCY+BufferSizeY-1),NBuffer
Deallocate (SBuffer)
Return NBuffer
Else
PCX=((BufferSizeX-NSizeX)/2)
PCY=((BufferSizeY-NSizeY)/2)
Put NBuffer,(PCX,PCY),SBuffer,PSet
Deallocate (SBuffer)
Return NBuffer
End If
Else
Return SBuffer
End If
End Function
Dateiname:"[Sub]EPut.bi"
/'
EPut dient als "Erweiterung" zu Put
EPut prueft vor Ausgabe ob der Buffer Innerhalb des zu schreibenenen Screens/Buffer
liegt und gibt ggfl. nur einen Teil aus ohne das es dabei zu Speicherueberschreitungen
fuehrt.
'/
Sub EPut (Byval PosX as Integer, _
Byval PosY as Integer, _
Byref Buffer as Any Ptr, _
ByRef DrawBuffer as any ptr=0, _
Byval mode as integer=0)
/'
'PosX - Horizontale Position
'PosY - Vertikale Position
'Buffer - Quellbuffer
'DrawBuffer - Ziel-(Buffer) 0=Screen
'mode - 0=Trans(parent) / 1=pset
'/
If Buffer=0 Then Exit Sub
''Objekt/Buffergroesse ermitteln
'Dim GetInteger as Integer Ptr=Buffer
'Dim BufferVersion as integer=GetInteger[0]
If peek(Integer,Buffer)<>&h07 Then Exit Sub
'BufferVersion<>&h7 Then Exit Sub
Dim BufferSizeX as Integer=Peek (Integer,Buffer+8)'GetInteger[2]
Dim BufferSizeY as Integer=Peek (Integer,Buffer+12)'GetInteger[3]
'Groesse des Buffer in den Gezeichnet werden soll
Dim DrawBufferSizeX as Integer
Dim DrawBufferSizeY as Integer
'Wenn DrawBuffer=0 dann direkt auf den Screen zeichnen
If DrawBuffer=0 or DrawBuffer=ScreenPTR Then
ScreenInfo DrawBufferSizeX,DrawBufferSizeY
DrawBuffer=0
Else
'..sonst Groesse des Buffers ermitteln in den gezeichnet werden soll
'GetInteger=DrawBuffer+8
If Peek(Integer,DrawBuffer)<>&h07 Then Exit Sub
DrawBufferSizeX=Peek (Integer,DrawBuffer+8)'GetInteger[0]
DrawBufferSizeY=Peek (Integer,DrawBuffer+12)'GetInteger[1]
End If
'Ausserhalb des bereichs
If PosX>DrawBufferSizeX or PosY>DrawBufferSizeY Then Exit Sub
If PosX+BufferSizeX<0 or PosY+BufferSizeY<0 Then Exit Sub
'Wenn das Objekt vollstaendig innerhalb der Buffer grenzen liegt, direktes
'Einfuegen
If PosX>-1 and PosY>-1 and _
PosX+BufferSizeX<DrawBufferSizeX and PosY+BufferSizeY<DrawBufferSizeY Then
If mode=0 Then
Put DrawBuffer,(PosX,PosY),Buffer,Trans
Else
Put DrawBuffer,(PosX,PosY),Buffer,PSet
End If
Exit Sub
End If
'Variablen zum ermitteln welcher Teil des Objektes ausserhalb
'des Bufferbbereichs liegt
's-start,e-ende
Dim as Integer Xs,Xe
Dim as Integer Ys,Ye
'Wenn Objekt links ausserhalb des Bereichs...
Xs=IIF(PosX<0,(0-PosX),0)
'Wenn Obbjekt Oben ausserhalb des Bereichs...
Ys=IIF(PosY<0,(0-PosY),0)
'Wenn Objekt rechts ausserhalb des bereichs...
Xe=IIF(IIF(PosX>-1,PosX,0)+(BufferSizeX-Xs)>DrawBufferSizeX-1,(DrawBufferSizeX-1)+Xs,BufferSizeX-1)
'Wenn Objekt unten ausserhalb des Bereichs...
Ye=IIF(IIF(PosY>-1,PosY,0)+(BufferSizeY-Ys)>DrawBufferSizeY-1,(DrawBufferSizeY-1)+Ys,BufferSizeY-1)
'Sichbaren teil des Objekts zeichnen
if mode=0 Then
Put DrawBuffer,(IIF(PosX>-1,PosX,0),IIF(PosY>-1,PosY,0)),Buffer,(Xs,Ys)-(Xe,Ye),Trans
Else
Put DrawBuffer,(IIF(PosX>-1,PosX,0),IIF(PosY>-1,PosY,0)),Buffer,(Xs,Ys)-(Xe,Ye),Pset
End If
End Sub
| Zusätzliche Informationen und Funktionen | |||||||
|---|---|---|---|---|---|---|---|
|
|
||||||
Bearbeiten
Versionen