Black and white BMP, size limit is your memory

Share your advanced PureBasic knowledge/code with the community.
Post Reply
infratec
Always Here
Always Here
Posts: 6874
Joined: Sun Sep 07, 2008 12:45 pm
Location: Germany

Black and white BMP, size limit is your memory

Post by infratec »

Hi,

I saw it as a small challenge :wink:
I don't know how many make use of it ...

Save it as "BlackAndWhiteBMP.pbi"

Code: Select all

CompilerIf #PB_Compiler_IsMainFile
  EnableExplicit
CompilerEndIf


Structure BlackAndWhiteBMPStructure
  Width.i
  Height.i
  BackgroundColor.i
  ForegroundColor.i
  BytesPerRow.i
  *Buffer
  Valid.i
EndStructure


Procedure.i LoadBlackAndWhiteBMP(Filename$)
  
  Protected SizeOfFile.i, File.i
  Protected BMPFileHeader.BITMAPFILEHEADER
  Protected BMPInfoHeader.BITMAPINFOHEADER
  Protected Dim BMPPalette.RGBQUAD(1)
  Protected *BlackAndWhiteBMP.BlackAndWhiteBMPStructure
  
  
  File = ReadFile(#PB_Any, Filename$)
  If File
    If ReadData(File, @BMPFileHeader, SizeOf(BITMAPFILEHEADER)) = SizeOf(BITMAPFILEHEADER)
      If BMPFileHeader\bfType = 'B' | 'M' << 8
        If BMPFileHeader\bfOffBits = SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER) + SizeOf(RGBQUAD) * 2
          If ReadData(File, @BMPInfoHeader, SizeOf(BITMAPINFOHEADER)) = SizeOf(BITMAPINFOHEADER)
            If ReadData(File, @BMPPalette(0), SizeOf(RGBQUAD) * 2) = SizeOf(RGBQUAD) * 2
              *BlackAndWhiteBMP = AllocateMemory(SizeOf(BlackAndWhiteBMPStructure))
              If *BlackAndWhiteBMP
                *BlackAndWhiteBMP\Width = BMPInfoHeader\biWidth
                *BlackAndWhiteBMP\Height = BMPInfoHeader\biHeight
                *BlackAndWhiteBMP\BytesPerRow = ((*BlackAndWhiteBMP\Width + 31) / 32) * 4
                *BlackAndWhiteBMP\ForegroundColor = BMPPalette(0)\rgbRed
                *BlackAndWhiteBMP\BackgroundColor = BMPPalette(1)\rgbRed
                
                *BlackAndWhiteBMP\Buffer = AllocateMemory(BMPFileHeader\bfSize - BMPFileHeader\bfOffBits, #PB_Memory_NoClear)
                If *BlackAndWhiteBMP\Buffer
                  If ReadData(File, *BlackAndWhiteBMP\Buffer, MemorySize(*BlackAndWhiteBMP\Buffer)) = MemorySize(*BlackAndWhiteBMP\Buffer)
                    *BlackAndWhiteBMP\Valid = #True
                  Else
                    FreeMemory(*BlackAndWhiteBMP\Buffer)
                    FreeMemory(*BlackAndWhiteBMP)
                    *BlackAndWhiteBMP = #Null
                  EndIf
                Else
                  FreeMemory(*BlackAndWhiteBMP)
                  *BlackAndWhiteBMP = #Null
                EndIf
              EndIf
            EndIf
          EndIf
        EndIf
      EndIf
    EndIf
  EndIf
  
  ProcedureReturn *BlackAndWhiteBMP
  
EndProcedure  




Procedure.i SaveBlackAndWhiteBMP(Filename$, *BlackAndWhiteBMP.BlackAndWhiteBMPStructure)
  
  Protected Result.i, File.i, Index.i
  Protected BMPFileHeader.BITMAPFILEHEADER
  Protected BMPInfoHeader.BITMAPINFOHEADER
  Protected Dim BMPPalette.RGBQUAD(1)
    
  
  BMPInfoHeader\biSize= SizeOf(BITMAPINFOHEADER)
  BMPInfoHeader\biWidth = *BlackAndWhiteBMP\Width
  BMPInfoHeader\biHeight = *BlackAndWhiteBMP\Height
  BMPInfoHeader\biPlanes = 1
  BMPInfoHeader\biBitCount = 1
  BMPInfoHeader\biCompression = 0
  BMPInfoHeader\biClrUsed = 2
  
  If *BlackAndWhiteBMP\BackgroundColor = #White
    Index = 1
  Else
    Index = 0
  EndIf
  
  BMPPalette(Index)\rgbRed = $00
  BMPPalette(Index)\rgbGreen = $00
  BMPPalette(Index)\rgbBlue = $00
  BMPPalette(Index)\rgbReserved = $00
  
  If *BlackAndWhiteBMP\BackgroundColor = #White
    Index = 0
  Else
    Index = 1
  EndIf
  
  BMPPalette(Index)\rgbRed = $FF
  BMPPalette(Index)\rgbGreen = $FF
  BMPPalette(Index)\rgbBlue = $FF
  BMPPalette(Index)\rgbReserved = $00
  
  ;Debug SizeOf(BITMAPFILEHEADER)
  ;Debug SizeOf(BITMAPINFOHEADER)
  
  BMPFileHeader\bfType = 'B' | 'M' << 8
  BMPFileHeader\bfOffBits = SizeOf(BITMAPFILEHEADER) + SizeOf(BITMAPINFOHEADER) + SizeOf(RGBQUAD) * 2
  BMPFileHeader\bfSize = BMPFileHeader\bfOffBits + MemorySize(*BlackAndWhiteBMP\Buffer)
  
  File = CreateFile(#PB_Any, Filename$)
  If File
    If WriteData(File, @BMPFileHeader, SizeOf(BITMAPFILEHEADER))
      If WriteData(File, @BMPInfoHeader, SizeOf(BITMAPINFOHEADER))
        If WriteData(File, @BMPPalette(0), SizeOf(RGBQUAD) * 2)
          If WriteData(File, *BlackAndWhiteBMP\Buffer, MemorySize(*BlackAndWhiteBMP\Buffer))
            Result = #True
          EndIf
        EndIf
      EndIf
    EndIf
    CloseFile(File)
  EndIf
  
  ProcedureReturn Result
  
EndProcedure




Procedure.i CreateBlackAndWhiteBMP(Width.i, Height.i, BackgroundColor.i=#White)
  
  Protected *BlackAndWhiteBMP.BlackAndWhiteBMPStructure
  
  *BlackAndWhiteBMP = AllocateMemory(SizeOf(BlackAndWhiteBMPStructure))
  If *BlackAndWhiteBMP
    If BackgroundColor = #White
      *BlackAndWhiteBMP\BackgroundColor = #White
      *BlackAndWhiteBMP\ForegroundColor = #Black
    Else
      *BlackAndWhiteBMP\BackgroundColor = #Black
      *BlackAndWhiteBMP\ForegroundColor = #White
    EndIf
    *BlackAndWhiteBMP\Width = Width
    *BlackAndWhiteBMP\Height = Height
    *BlackAndWhiteBMP\BytesPerRow = ((Width + 31) / 32) * 4
    *BlackAndWhiteBMP\Buffer = AllocateMemory(*BlackAndWhiteBMP\BytesPerRow * Height)
    If *BlackAndWhiteBMP\Buffer
      *BlackAndWhiteBMP\Valid = #True
    Else
      FreeMemory(*BlackAndWhiteBMP)
      *BlackAndWhiteBMP = #Null
    EndIf
  EndIf
  
  ProcedureReturn *BlackAndWhiteBMP
  
EndProcedure



Procedure FreeBlackAndWhiteBMP(*BlackAndWhiteBMP.BlackAndWhiteBMPStructure)
  If *BlackAndWhiteBMP\Buffer
    FreeMemory(*BlackAndWhiteBMP\Buffer)
  EndIf
  FillMemory(*BlackAndWhiteBMP, SizeOf(BlackAndWhiteBMPStructure))
  FreeMemory(*BlackAndWhiteBMP)
EndProcedure




Procedure.i IsBlackAndWhiteBMP(*BlackAndWhiteBMP.BlackAndWhiteBMPStructure)
  
  Protected Result.i
  
  If *BlackAndWhiteBMP
    Result = *BlackAndWhiteBMP\Valid
    If Result
      If MemorySize(*BlackAndWhiteBMP) <> SizeOf(BlackAndWhiteBMPStructure)
        Result = #False
      EndIf
    EndIf
  Else
    Result = #False
  EndIf
  
  ProcedureReturn Result
  
EndProcedure




Procedure SetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP.BlackAndWhiteBMPStructure, X.i, Y.i)
  
  Protected Byte.a, Ptr.i
  
  
  Ptr = X / 8 + (*BlackAndWhiteBMP\Height - Y - 1) * *BlackAndWhiteBMP\BytesPerRow
  Byte = PeekA(*BlackAndWhiteBMP\Buffer + Ptr)
  
  Byte | (1 << (7 - (X % 8)))
  
  PokeA(*BlackAndWhiteBMP\Buffer + Ptr, Byte)
  
EndProcedure




Procedure ResetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP.BlackAndWhiteBMPStructure, X.i, Y.i)
  
  Protected Byte.a, Ptr.i
  
  
  Ptr = X / 8 + (*BlackAndWhiteBMP\Height - Y - 1) * *BlackAndWhiteBMP\BytesPerRow
  Byte = PeekA(*BlackAndWhiteBMP\Buffer + Ptr)
  
  Byte & ~(1 << (7 - (X % 8)))
  
  PokeA(*BlackAndWhiteBMP\Buffer + Ptr, Byte)
  
EndProcedure




Procedure.i GetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP.BlackAndWhiteBMPStructure, X.i, Y.i)
  
  Protected Byte.a, Ptr.i
  
  
  Ptr = X / 8 + (*BlackAndWhiteBMP\Height - Y - 1) * *BlackAndWhiteBMP\BytesPerRow
  Byte = PeekA(*BlackAndWhiteBMP\Buffer + Ptr)
  
  ProcedureReturn Bool(Byte & (1 << (7 - (X % 8))))
  
EndProcedure




Procedure.i GrabBlackAndWhiteBMP(*BlackAndWhiteBMP.BlackAndWhiteBMPStructure, Image2.i, X.i, Y.i, Width.i, Height.i)
  
  Protected Result.i, XPos.i, YPos.i
  
  
  If Image2 = #PB_Any
    Result = CreateImage(#PB_Any, Width, Height)
  Else
    If CreateImage(Image2, Width, Height)
      Result = Image2
    EndIf
  EndIf
  
  If Result
    If StartDrawing(ImageOutput(Result))
      For YPos = Y To Y + Height - 1
        For XPos = X To X + Width - 1
          If GetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, XPos, YPos)
            Plot(XPos - X, YPos - Y, *BlackAndWhiteBMP\ForegroundColor)
          Else
            Plot(XPos - X, YPos - Y, *BlackAndWhiteBMP\BackgroundColor)
          EndIf
        Next XPos
      Next YPos
      StopDrawing()
    Else
      FreeImage(Result)
      Result = 0
    EndIf
  EndIf
  
  ProcedureReturn Result
  
EndProcedure




Procedure InsertImageIntoBlackAndWhiteBMP(*BlackAndWhiteBMP.BlackAndWhiteBMPStructure, Image.i, X.i, Y.i)
  
  Protected Width.i, Height.i, XPos.i, YPos.i
  
  
  If IsImage(Image)
    Width = ImageWidth(Image) - 1 
    Height = ImageHeight(Image) - 1
    If StartDrawing(ImageOutput(Image))
      
      For YPos = 0 To Height
        For XPos = 0 To Width
          If Point(XPos, YPos) = *BlackAndWhiteBMP\ForegroundColor
            SetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, X + XPos, Y + YPos)
          Else
            ResetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, X + XPos, Y + YPos)
          EndIf
        Next XPos
      Next YPos
      
      StopDrawing()
    EndIf
  EndIf
  
EndProcedure






;- Demo
CompilerIf #PB_Compiler_IsMainFile
  
  Define *BlackAndWhiteBMP.BlackAndWhiteBMPStructure, GrabedImage.i, Filename$
  
  Debug IsBlackAndWhiteBMP(*BlackAndWhiteBMP)
  
  *BlackAndWhiteBMP = CreateBlackAndWhiteBMP(80, 80, #Black)
  If *BlackAndWhiteBMP
    
    Debug IsBlackAndWhiteBMP(*BlackAndWhiteBMP)
    
    SetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 0, 0)
    SetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 7, 0)
    SetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 8, 0)
    SetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 79, 0)
    SetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 0, 79)
    SetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 79, 79)
    
    Debug "GetPixel"
    
    Debug GetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 78, 79)
    Debug GetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 79, 79)
    
    Debug "Setted"
    Debug GetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 8, 0)
    ResetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 8, 0)
    Debug "Resetted"
    Debug GetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 8, 0)
    
    Filename$ = SaveFileRequester("Save black and white BMP", "", "BMP|*.bmp", 0)
    If Filename$ <> ""
      Filename$ = GetPathPart(Filename$) + GetFilePart(Filename$, #PB_FileSystem_NoExtension) + ".bmp"
      If SaveBlackAndWhiteBMP(Filename$, *BlackAndWhiteBMP)
        MessageRequester("Info", "Writing b/w BMP ok.")
      Else
        MessageRequester("Error", "Writing b/w BMP failed.")
      EndIf
    EndIf
    
    FreeBlackAndWhiteBMP(*BlackAndWhiteBMP)
    
    Debug IsBlackAndWhiteBMP(*BlackAndWhiteBMP)
    
  EndIf
  
  Debug "LoadBlackAndWhiteBMP"
  *BlackAndWhiteBMP = LoadBlackAndWhiteBMP("C:\tmp\bw.bmp")
  If *BlackAndWhiteBMP
    Debug IsBlackAndWhiteBMP(*BlackAndWhiteBMP)
    Debug "Loaded"
    Debug GetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 78, 79)
    Debug GetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 79, 79)
    FreeBlackAndWhiteBMP(*BlackAndWhiteBMP)
    Debug IsBlackAndWhiteBMP(*BlackAndWhiteBMP)
  EndIf
  
  *BlackAndWhiteBMP = CreateBlackAndWhiteBMP(80000, 80000)
  If *BlackAndWhiteBMP
    Debug "Big BMP Created"
    Debug MemorySize(*BlackAndWhiteBMP\Buffer)
    
    Debug GetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 40000, 40000)
    SetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 40000, 40000)
    Debug GetPixelBlackAndWhiteBMP(*BlackAndWhiteBMP, 40000, 40000)
    
    
    OpenWindow(0, 0, 0, 830, 420, "Test BlackAndWhiteBMP", #PB_Window_SystemMenu|#PB_Window_ScreenCentered)
    
    ImageGadget(0, 10, 10, 0, 0, 0)
    ImageGadget(1, 420, 10, 0, 0, 0)
    
    GrabedImage = GrabBlackAndWhiteBMP(*BlackAndWhiteBMP, #PB_Any, 39800, 39800, 400, 400)
    SetGadgetState(0, ImageID(GrabedImage))
    
    If StartDrawing(ImageOutput(GrabedImage))
      DrawText(100, 100, "Hello World", *BlackAndWhiteBMP\ForegroundColor, *BlackAndWhiteBMP\BackgroundColor)
      StopDrawing()
      
      InsertImageIntoBlackAndWhiteBMP(*BlackAndWhiteBMP, GrabedImage, 39800, 39800)
      
      FreeImage(GrabedImage)
      
      GrabedImage = GrabBlackAndWhiteBMP(*BlackAndWhiteBMP, #PB_Any, 39800, 39800, 400, 400)
      SetGadgetState(1, ImageID(GrabedImage))
      
      FreeImage(GrabedImage)
    EndIf
    
    
    Repeat
    Until WaitWindowEvent() = #PB_Event_CloseWindow
    
    
    Filename$ = SaveFileRequester("Save black and white BMP", "", "BMP|*.bmp", 0)
    If Filename$ <> ""
      Filename$ = GetPathPart(Filename$) + GetFilePart(Filename$, #PB_FileSystem_NoExtension) + ".bmp"
      If SaveBlackAndWhiteBMP(Filename$, *BlackAndWhiteBMP)
        MessageRequester("Info", "Writing b/w BMP ok.")
      Else
        MessageRequester("Error", "Writing b/w BMP failed.")
      EndIf
    EndIf
    
    FreeBlackAndWhiteBMP(*BlackAndWhiteBMP)
  EndIf
  
CompilerEndIf
In the Demo I created a 80000 by 80000 pixel picture with a dot in the center.
If you use IrfanView to show the saved picture, then you can set the scaling to 100%.
It centers the picture and you can see the dot. Also the 'Hello world' of course.

Bernd
Top
Post Reply

Return to “Tricks 'n' Tips”