FreeBasic

Данный код позволяет загружать изображения в формате PCX для вывода в буфер так же просто как и изображения BMP.

Платформы: Linux, Windows
Автор: dafhi

'' ---------------------------------
'  PCX Loader by dafhi - 2012 06 22
' ----------------------------------

Type RGBTriple
    As Ubyte  red,grn,blu
End Type

Type RGBQUAD
    As Ubyte  Blu
    As Ubyte  Grn
    As Ubyte  Red
    As Ubyte  Alp
End Type

Type ImageInfo
    As Any Ptr                      img
    As Any Ptr                      pixels
    As Any Ptr                      botleft
    As Integer                      pitchm
    As Integer                      pitch
    As Integer                      wid
    As Integer                      hgt
    As Integer                      widM
    As Integer                      hgtM
    As Single                       midx
    As Single                       midy
    As Single                       diagonal
    As Integer                      bypp
    As Integer                      pitchBy4
    As Integer                      UB1D
    As Integer                      w_plus_h
    Declare Operator Cast() As Any Ptr
    Declare Function Create(Byval pWid As UShort=1,Byval pHgt As UShort=1,Byval pRed As UByte=127,Byval pGrn As UByte=127,Byval pBlu As UByte=127,Byval pAph As UByte=255,Byval bpp_ As UInteger=32) As Any Ptr
    Declare Function ScrInit(Byval pWid As UShort=640,Byval pHgt As UShort=480,Byval bpp_ As UInteger=32,Byval pRed As UByte=127,Byval pGrn As UByte=127,Byval pBlu As UByte=127,Byval pAph As UByte=255) As Any Ptr
    Declare Sub ScrInfo
    Declare Sub Cls( Byval pColor As UInteger=RGBA(0,0,0,0) )
    Declare Sub Destroy
    Declare Destructor
    Private:
    Declare Sub varsCommon
End Type
Operator ImageInfo.Cast () As Any Ptr
    Return  img
End Operator
Destructor ImageInfo
Destroy
End Destructor
Sub ImageInfo.varsCommon
    widM = wid - 1
    hgtM = hgt - 1
    midx = widM * 0.5
    midy = hgtM * 0.5
    UB1D = wid * hgt - 1
    botleft = pixels + pitch * hgtm
    pitchm = pitch - 1
    pitchBy4 = pitch \ 4
    w_plus_h = wid + hgt
    diagonal = Sqr(widM * widM + hgtM * hgtM)
End Sub
Function ImageInfo.Create(Byval pWid As Ushort, Byval pHgt As Ushort, _
    Byval pRed As Ubyte, _
    Byval pGrn As Ubyte, _
    Byval pBlu As Ubyte, _
    Byval pAph As Ubyte, _
    Byval bpp_ As Uinteger) As Any Ptr

    Destroy
    img = Imagecreate( pWid, pHgt, Rgba(pRed,pGrn,pBlu,pAph), bpp_ )
    ImageInfo img, wid, hgt, bypp, pitch, pixels
    varsCommon
    Return img

End Function
Sub ImageInfo.ScrInfo
    Screeninfo wid ,hgt  , , bypp, pitch
    pixels = Screenptr
    varsCommon
End Sub
Function ImageInfo.ScrInit(Byval pWid As Ushort,Byval pHgt As Ushort,Byval bpp_ As Uinteger,Byval pRed As Ubyte,Byval pGrn As Ubyte,Byval pBlu As Ubyte,Byval pAph As Ubyte) As Any Ptr
    Screenres pWid,pHgt,bpp_
    ScrInfo
    Return pixels
End Function
Sub ImageInfo.Destroy()
    If img = 0 Then Exit Sub
    Imagedestroy img
End Sub
Sub ImageInfo.Cls( Byval pColor As Uinteger )
''http://www.freebasic.net/forum/viewtopic.php?t=15809&
Dim As Uinteger cpy_ = (pitch * hgt) Shr 2
Dim As Uinteger Ptr dest = pixels
Asm mov eax, [pcolor]
Asm mov edi, [dest]
Asm mov ecx, [cpy_]
Asm rep stosd
End Sub

Type pcxHeader Field = 1
As Byte  manufacturer = &H0A
As Byte  version              '' 0 = 2.5
'' 2 = 2.8 w/ palette
'' 3 = 2.8 w/o palette
'' 5 = 3.0 or better

As Byte  Encoding             '' 1 = run-length
As Byte  bitsPerPlane         '' 1 2 4 8
As Ushort Xmin
As Ushort YMin
As Ushort Xmax
As Ushort YMax
As Ushort VertDPI             '' can also be img width
As Ushort HorzDPI             '' can also be img height.  Can be absent
As Ubyte  Pal(1 To 48)        '' 16x r,g,b + padding
As Ubyte  reserved
As Ubyte  colorPlanes         ''
As Ushort bytesPerScanLine    ''
As Ushort paltype             '' 1=Color/BW, 2 = Grayscale(ignored in ver 4+)
As Byte  pad(1 To 58)         '' fill header to 128 bytes
End Type

'' http://planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=2303&lngWId=1

Sub Read24Bit(Byref fileName As String,Byref pImg As ImageInfo)

Dim nFreeFile As Integer
Dim hPCX As PCXHeader
Dim bytes() As Ubyte

nFreeFile = Freefile
Open Filename For Binary Lock Write As #nFreeFile
Seek #nFreeFile, 1
Get #nFreeFile, , hPCX
Redim bytes(Lof(nFreeFile) - Len(hPCX) - 1)
Get #nFreeFile, , bytes()
Close #nFreeFile

Dim As Integer wid = hPCX.XMax - hPCX.XMin + 1
Dim As Integer hgt = hPCX.YMax - hPCX.YMin + 1

pImg.Create(wid,hgt)

Dim scan(wid * 3 - 1) As Ubyte
Dim As Integer ScanUB = Ubound(scan)
Dim As Integer cScanBytes = hPCX.colorPlanes * hPCX.BytesPerScanLine

Dim As Integer palByte, cRead

For Y As Integer = 0 To hgt - 1

Dim As Integer X, cScan
Do

Dim As Integer runLen = bytes(cRead)
If (runLen And &B11000000) = &B11000000 Then
runLen And= &B00111111
cRead += 1
Else
runLen = 1
End If

palbyte = bytes(cRead)

Dim As Integer ResultX = X + runLen
Dim As Integer end_ = ResultX - 1
If end_ > scanUB Then end_ = scanUB

For X = X To end_
scan(x) = palByte
Next
X = ResultX

cRead += 1
cScan += runLen
Loop While cScan < cScanBytes

Dim As Uinteger Ptr pix = pImg.pixels + Y * pImg.pitch
Dim As Integer      src1 = hPCX.bytesPerScanLine
Dim As Integer      src2 = 2*hPCX.bytesPerScanLine
Dim As RGBQUAD Ptr  rgbq = pImg.pixels + Y * pImg.pitch

For x = 0 To pImg.widM
rgbq[x].Red = scan(x)
rgbq[x].Grn = scan(x+src1)
rgbq[x].Blu = scan(x+src2)
rgbq[x].Alp = 255
Next

Next

End Sub
Sub Read8Bit(Byref fileName As String,Byref pImg As ImageInfo)

Dim nFreeFile As Integer
Dim hPCX As PCXHeader
Dim bytes() As Ubyte
Dim Pal(0 To 255) As RGBTriple
Dim PaletteRGB(0 To 255) As Uinteger
Dim PalByte As Ubyte

nFreeFile = Freefile

Open Filename For Binary Lock Write As #nFreeFile

Get #nFreeFile, , hPCX

Redim bytes(Lof(nFreeFile) - Len(hPCX) - Len(Pal) - Len(palByte) - 1)
Get #nFreeFile, , bytes()

Seek #nFreeFile, Lof(nFreeFile) - 768
Get #nFreeFile, , PalByte

Const PalHeader = 12

If PalByte = PalHeader Then
Seek #nFreeFile, Lof(nFreeFile) - 767
Get #nFreeFile, , Pal()
Close #nFreeFile
Else
Close #nFreeFile
? "The PCX that was passed didn't have a 256 colour palette! Can't read it!"
Exit Sub
End If

Dim As Integer wid = hPCX.XMax - hPCX.XMin + 1
Dim As Integer hgt = hPCX.YMax - hPCX.YMin + 1

Dim As Integer cScanBytes = hPCX.colorPlanes * hPCX.BytesPerScanLine

pImg.Create(wid,hgt)

Dim As Integer nBmpPos
Dim As Integer nBytePos

Dim As Integer printy

For Y  As Integer = 0 To hgt - 1

Dim As Integer      BmpX
Dim As Uinteger Ptr pix = pImg.pixels + Y * pImg.pitch

Do

Dim As Integer runLen = bytes(nBytePos)
If (runLen And &B11000000) = &B11000000 Then
runLen And= &B00111111
nBytePos += 1
Else
runLen = 1
End If

palbyte = bytes(nBytePos)

Dim As Integer ResultX = BmpX + runLen
Dim As Integer end_ = ResultX - 1
If end_ > pImg.widM Then end_ = pImg.widM

For BmpX = BmpX To end_
pix[BmpX] = palbyte
Next
BmpX = ResultX

nBytePos += 1

Loop While BmpX < cScanBytes

If nBytePos >= Ubound(bytes) Then
Exit For
Endif

Next Y

For Y As Integer = 0 To pImg.hgtM
Dim As RGBQUAD Ptr  dst = pImg.pixels + y * pImg.pitch
Dim As Uinteger Ptr udst = dst
For X As Integer = 0 To pImg.widM
Dim As Ubyte c_ = dst[x].Blu
dst[x].red = Pal(c_).red
dst[x].grn = Pal(c_).grn
dst[x].blu = Pal(c_).blu
Next
Next
End Sub

Sub LoadPCX(Byref fileName As String,Byref pImg As ImageInfo)

If Lcase(Right(filename,4)) <> ".pcx" Then filename += ".PCX"

'' http://planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=2303&lngWId=1

Dim nFreeFile As Integer
Dim hPCX As PCXHeader

nFreeFile = Freefile
Open Filename For Binary Lock Write As #nFreeFile

Seek #nFreeFile, 1
Get #nFreeFile, , hPCX
Close #nFreeFile

If hPCX.BitsPerPlane = 8 Then
If hPCX.colorPlanes = 1 Then
Read8Bit(Filename,pImg)
Elseif hPCX.colorPlanes = 3 Then
Read24Bit(Filename,pImg)
End If
Else
? "Sorry, can't load that pcx file!"
End If

End Sub


'' ------------
'   Main
' -------------

Screenres 320,240,32

Dim As ImageInfo  Buf

LoadPCX("test.pcx", Buf)
Put (110,80),Buf.img, Pset

Sleep