'
'
'   [ BMModule.BAS ]
'
'   Модуль для загрузки BMP.
'   Не использует встроенный в FB функционал.
'   Работает только с форматами без сжатия.
'
'   > Quiet Snow <  2025
'   Совместимость: FBC 0.23.0
'                  FBC 1.10.1
'

NAMESPACE BMP

'    Тип заголовка *.BMP

TYPE BMFile   FIELD = 1
    BmID AS SHORT = 19778
    FileSize AS ULONG
    Reserved AS LONG
    BmOFFSET AS ULONG = 54
END TYPE

'    Старый заголовок( 40 байт )
TYPE BMHead   FIELD = 1
    HeadSize AS ULONG = 40
    BmpSizeX AS ULONG
    BmpSizeY AS ULONG
    BmSlices AS USHORT = 1
    BitDepth AS USHORT = 32
    Compress AS LONG
    DataSize AS ULONG
    BmHorRes AS ULONG
    BmVerRes AS ULONG
    UseColor AS ULONG
    SignColr AS ULONG
END TYPE

'    Новый заголовок( 56 байт )
TYPE BMHeadv5   FIELD = 1
    HeadSize AS ULONG = 40
    BmpSizeX AS ULONG
    BmpSizeY AS ULONG
    BmSlices AS USHORT = 1
    BitDepth AS USHORT = 32
    Compress AS LONG
    DataSize AS ULONG
    BmHorRes AS ULONG
    BmVerRes AS ULONG
    UseColor AS ULONG
    SignColr AS ULONG
    RedMask  AS ULONG
    GrnMask  AS ULONG
    BlueMask AS ULONG
    AlphMask AS ULONG
END TYPE

'    Дополненный новый заголовок (Не реализован)
'TYPE CIEXYZ   FIELD = 1
'   ciexyzX AS ULONG
'   ciexyzY AS ULONG
'   ciexyzZ AS ULONG
'END TYPE

'TYPE CIEXYZTRIPLE    FIELD = 1
'   ciexyzRed AS CIEXYZ  
'   ciexyzGreen AS CIEXYZ
'   ciexyzBlue AS CIEXYZ
'END TYPE

'TYPE BMHeadv5Add
'   CSType   AS ULONG
'   bV5Endpoints AS CIEXYZTRIPLE
'   GammaRed AS ULONG
'   GammaGrn AS ULONG
'   GammaBlu AS ULONG
'   Intent   AS ULONG
'   PrflData AS ULONG
'   ProfSize AS ULONG
'   Reserved AS ULONG
'END TYPE

   '  Заголовки
DIM FHead AS BMFile, BMPHead AS BMHead
DIM BMPHeadv5 AS BMHeadv5

'    Прототипы

DECLARE SUB  Load  (FName AS STRING)
DECLARE SUB  Save  (FName AS STRING)
DECLARE SUB  TakePix (x AS INTEGER, y AS INTEGER)
DECLARE FUNCTION TakePointer () AS ANY PTR
DECLARE SUB  ClosePic ()

'    Массивы

   DIM RAWMem AS BYTE PTR                       '    Память под файл целиком
   DIM BMMem AS BYTE PTR, BMLoaded AS SHORT     '    Указатель на загр. BMP и флаг того, что он загружен

   DIM BMSzX AS LONG, BMSzY AS LONG             '    Размер изображения
   DIM SvBMF AS INTEGER                         '    Свободный дескриптор
   
   DIM YMuls() AS BYTE PTR                      '    Предрасчитанный адрес для GetPix

   DIM PixCV AS ULONG                           '    Полученный GetPix-ом пиксель цвета

   DIM PalR(255) AS ULONG                       '    Палитра для 256 цветного BMP
   DIM PalG(255) AS ULONG
   DIM PalB(255) AS ULONG
   DIM Cv256(255) AS ULONG                      '    Готовый цвет из палитры

'
'    Загрузка *.BMP*
'

SUB Load (FName AS STRING)

   DIM  xp  AS INTEGER, yp    AS INTEGER
   DIM  Adr AS BYTE PTR, Adr2 AS BYTE PTR, PalAdr AS BYTE PTR
   DIM  OneLine AS INTEGER, TwoLine AS INTEGER
   DIM  Cv  AS ULONG, RCmp AS UBYTE, GCmp AS UBYTE, BCmp AS UBYTE, ACmp AS UBYTE

   DIM CvZam(3) AS INTEGER
   DIM RPosit AS INTEGER, GPosit AS INTEGER, BPosit AS INTEGER, APosit AS INTEGER

   DIM  Plus   AS INTEGER

   DIM  BMFLn AS UINTEGER                        '  Длина файла
   DIM  MaxColors AS USHORT

  '   Если уже загружен, то освободим память
   IF BMLoaded THEN ClosePic ()

  '   Откроем файл
   SvBMF = FREEFILE
   IF OPEN(FName, FOR BINARY, ACCESS READ, AS #SvBMF) THEN EXIT SUB

  '   Получим длину файла
   BMFLn = LOF(SvBMF)
   IF BMFLn = 0 THEN CLOSE SvBMF : EXIT SUB      '  Если файл пуст - выход

   GET #SvBMF, , FHead                           '  Загрузим заголовок

   IF FHead.BmID <> 19778 THEN CLOSE SvBMF : EXIT SUB   '  Если это не BMP файл - выход

   GET #SvBMF, , BMPHead                         '  Следующий заголовок ( 40 байт )

   '  Если новый заголовок v5 - тогда читаем его
   IF BMPHead.HeadSize >= 56 THEN
     SEEK #SvBMF, SEEK(SvBMF) - 40
     GET #SvBMF, , BMPHeadv5
      BMPHead.HeadSize = BMPHeadv5.HeadSize
      BMPHead.BmpSizeX = BMPHeadv5.BmpSizeX
      BMPHead.BmpSizeY = BMPHeadv5.BmpSizeY
      BMPHead.BmSlices = BMPHeadv5.BmSlices
      BMPHead.BitDepth = BMPHeadv5.BitDepth
      BMPHead.Compress = BMPHeadv5.Compress
      BMPHead.DataSize = BMPHeadv5.DataSize
      BMPHead.BmHorRes = BMPHeadv5.BmHorRes
      BMPHead.BmVerRes = BMPHeadv5.BmVerRes
      BMPHead.UseColor = BMPHeadv5.UseColor
      BMPHead.SignColr = BMPHeadv5.SignColr

      '   Определяем позиции каналов по маскам каналов
      FOR i AS INTEGER = 0 TO 3
         IF ((BMPHeadv5.RedMask AND 255) = 255) THEN
           RPosit = i            
         END IF
         BMPHeadv5.RedMask = BMPHeadv5.RedMask SHR 8
      NEXT

      FOR i AS INTEGER = 0 TO 3
         IF ((BMPHeadv5.GrnMask AND 255) = 255) THEN
           GPosit = i            
         END IF
         BMPHeadv5.GrnMask = BMPHeadv5.GrnMask SHR 8
      NEXT

      FOR i AS INTEGER = 0 TO 3
         IF ((BMPHeadv5.BlueMask AND 255) = 255) THEN
           BPosit = i            
         END IF
         BMPHeadv5.BlueMask = BMPHeadv5.BlueMask SHR 8
      NEXT

      FOR i AS INTEGER = 0 TO 3
         IF ((BMPHeadv5.AlphMask AND 255) = 255) THEN
           APosit = i            
         END IF
         BMPHeadv5.AlphMask = BMPHeadv5.AlphMask SHR 8
      NEXT

   END IF

  '   Получим размерность картинки
   BMSzX = BMPHead.BmpSizeX:   BMSzY = BMPHead.BmpSizeY

  '   Если размеры изображения нулевые, значит не будем грузить
   IF (BMSzX = 0) OR (BMSzY = 0) THEN CLOSE SvBMF : EXIT SUB

       '  Переходим в начало файла
         SEEK #SvBMF, 1

       '  Заводим память
         RAWMem = ALLOCATE(BMFLn)

       '  Грузим весь файл в память
         GET #SvBMF, , *RAWMem, BMFLn

  '   Закроем файл т.к. уже загрузили его
   CLOSE #SvBMF

  '   Теперь нужно распарсить файл в памяти    

  '   Посчитаем пропуск байт на строку
  Plus = BMSzX AND 3
  Adr = RAWMem + FHead.BmOFFSET' + 1

  '   Заводим память под 32 битное изображение
  BMMem  = ALLOCATE(BMSzX * BMSzY * 4)
  OneLine = BMSzX * 4
  TwoLine = OneLine SHL 1

  '   Перезаводим массив предрасчитанных Y для TakePix
  REDIM YMuls(BMSzY)
  '   Заполняем
  FOR yp = 0 TO BMSzY - 1
      YMuls(yp) = BMMem + (yp * OneLine)
  NEXT

  Adr2 = CINT(BMMem) + CINT(BMSzX * BMSzY * 4) - OneLine ' - 100

  ' __________________________________________
  '
  '     Обрабатываем согласно битности
  ' __________________________________________

   SELECT CASE  BMPHead.BitDepth

  '    8 БИТ
    CASE 8
    'PRINT "----------8 BIT------------"

    '   Сколько цветов в 256-цветной палитре
     MaxColors = BMPHead.UseColor
     IF BMPHead.SignColr > MaxColors THEN MaxColors = BMPHead.SignColr
     PalAdr =  RAWMem + BMPHead.HeadSize + 14

      FOR QPal AS INTEGER = 0 TO MaxColors       '  Читаем палитру
         PalB(QPal) = PEEK(UBYTE, PalAdr)
         PalG(QPal) = PEEK(UBYTE, PalAdr + 1)
         PalR(QPal) = PEEK(UBYTE, PalAdr + 2)
         Cv256(QPal) = RGB(PalR(QPal), PalG(QPal), PalB(QPal))
         PalAdr += 4
      NEXT

     '   Идём в цикле по Y
     FOR yp = 0 TO BMSzY - 1

        '   Идём в цикле по X
        FOR xp = 0 TO BMSzX - 1
           '  Считываем цвет
           Cv = PEEK(UBYTE, Adr)
           POKE ULONG, Adr2, Cv256(Cv)' SHL 5' OR &HFF000000
           Adr += 1
           Adr2 += 4
        NEXT
        Adr += Plus
        Adr2 -= TwoLine
     NEXT

  '   15 БИТ
    CASE 15
    PRINT "----------15 BIT------------"

  '   16 БИТ
    CASE 16

     FOR yp = 0 TO BMSzY - 1

        FOR xp = 0 TO BMSzX - 1
           #IFNDEF __FB_64BIT__
            ASM
               MOV ESI,                   [Adr]'   AX = 16 Bit Color   RRRRRGGG GGGBBBBB
               LODSW

               MOV EBX, EAX                    '   BX = AX         RRRRRGGG GGGBBBBB
               AND EAX, &B1111100000011111     '   EAX =           RRRRR000 000BBBBB
               SHL BX, 5                       '   EBX =           GGGGGGBB BBB00000
               SHL EAX, 8                      '   EAX =  RRRRR000 000BBBBB 00000000
               AND BX, &B1111110000000000      '   EBX =  00000000 GGGGGG00 00000000
               SHR AX, 5                       '   EAX =  RRRRR000 00000000 BBBBB000
               OR  EAX, EBX
               MOV DWORD PTR[Cv], EAX
                     
            END ASM
           #ELSE
            ASM
               MOV RSI,                   [Adr]'   AX = 16 Bit Color   RRRRRGGG GGGBBBBB
               LODSW

               MOV EBX, EAX                    '   BX = AX         RRRRRGGG GGGBBBBB
               AND EAX, &B1111100000011111     '   EAX =           RRRRR000 000BBBBB
               SHL BX, 5                       '   EBX =           GGGGGGBB BBB00000
               SHL EAX, 8                      '   EAX =  RRRRR000 000BBBBB 00000000
               AND BX, &B1111110000000000      '   EBX =  00000000 GGGGGG00 00000000
               SHR AX, 5                       '   EAX =  RRRRR000 00000000 BBBBB000
               OR  EAX, EBX
               MOV DWORD PTR[Cv], EAX
                     
            END ASM           
           #ENDIF

           POKE ULONG, Adr2, Cv

           Adr += 2
           Adr2 += 4
        NEXT
        Adr += Plus
        Adr2 -= TwoLine
     NEXT

  '   24 БИТ
    CASE 24

     '   Идём в цикле по Y
     FOR yp = 0 TO BMSzY - 1

        '   Идём в цикле по X
        FOR xp = 0 TO BMSzX - 1
           '  Считываем цвет
           Cv = PEEK(ULONG, Adr) AND &H00FFFFFF
           POKE ULONG, Adr2, Cv OR &HFF000000
           Adr += 3
           Adr2 += 4
        NEXT
        Adr += Plus
        Adr2 -= TwoLine
     NEXT

  '   32 БИТ
    CASE 32

     IF BMPHead.HeadSize = 40 THEN

       '   Идём в цикле по Y
       FOR yp = 0 TO BMSzY - 1

          '   Идём в цикле по X
          FOR xp = 0 TO BMSzX - 1
             Cv = PEEK(ULONG, Adr)     '  Считываем цвет
             POKE ULONG, Adr2, Cv      '  В память его
             Adr += 4
             Adr2 += 4
          NEXT
          Adr += Plus
          Adr2 -= TwoLine
       NEXT
       
     ELSEIF BMPHead.HeadSize >= 56 THEN

       '   Идём в цикле по Y
       FOR yp = 0 TO BMSzY - 1

          '   Идём в цикле по X
          FOR xp = 0 TO BMSzX - 1

             '  Считываем компоненты
             RCmp = PEEK(UBYTE, Adr + RPosit)
             GCmp = PEEK(UBYTE, Adr + GPosit)
             BCmp = PEEK(UBYTE, Adr + BPosit)
             ACmp = PEEK(UBYTE, Adr + APosit)

             '  Складываем в память
             POKE ULONG, Adr2, RGBA(RCmp, GCmp, BCmp, ACmp)             
             Adr += 4
             Adr2 += 4
          NEXT
          Adr += Plus
          Adr2 -= TwoLine
       NEXT

     END IF

   END SELECT
   BMLoaded = -1
   DEALLOCATE (RAWMem)
  ' __________________________________________
  '
  '     Конец обработки битностей
  ' __________________________________________

END SUB

'
'    Взять пиксель с загруженного в память *.BMP*
'

SUB TakePix (x AS INTEGER, y AS INTEGER)
     
    PixCV = PEEK (ULONG, (x SHL 2 + YMuls(y) ) )
     
END SUB

'
'    Получить указатель на пиксели картинки
'

FUNCTION TakePointer () AS ANY PTR
     
    TakePointer = BMMem
     
END FUNCTION

'
'   Выгрузить *.BMP* из памяти.
'

SUB ClosePic ()
    IF BMLoaded = 0 THEN EXIT SUB
    DEALLOCATE (BMMem)
    BMMem = 0
    BMLoaded = 0
END SUB

END NAMESPACE