'' ---------------------------------
'  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