Платные хостинги     Раскрутка сайта     Книги по программированию

Просмотр BMP файла в Паскаль-программах, Это интересно!

- Помогите, пожалуйста, с таким вопросом! Нужно написать мне курсовик, в котором использовались бы графические файлы: либо BMP, либо PCX. Какие именно - не важно. Количество цветов: либо 16, либо 256 - разницы не имеет. У меня получается воспроизвести картинки на экране, но не получается нормальный цвет установить, все время какой-то искаженный цвет! Может у кого есть классные модули или просто процедуры для работы с такими изображениями. Буду очень благодарен за помощь! Не дайте умереть!

- хосподи причем тут класс?проблема в том что он палитру для 256 цветов не ставитвот и искажения цветас 16 цветами еще геморойнейкстати нада смотреть че за ВМР и под какую ось пишетсяк примеру в досе для цвета отдано 6 бит из 8тоесть можно получить мах 64 градации 1 цвета к примеруфотошоп может запросто делать 8 битные ВМР которые в виндосе выглядят нормально в досе фиг тамкароче в любом случае для коректного вывода 256 и 16 цветных картинок нада сначала установить необходимую им палитруможно использовать 16.24.32 битные картинки тогда и палитра не нужнаMacTep ты уточни ось тогда и конкретный совет дать можно

- тода все простопалитра занимает 768 байт (3 байта на цвет)на асме так выглядитmov dx,3c8hmov cx,0ffhmov si,pal <- адрес палитрыxor ax,axout dx,alinc dxmet:mov al,[si]out dx,alinc simov al,[si]out dx,alinc simov al,[si]out dx,alinc siloop metможно укоротить кодесли outsb использовать

- Код unit NPCX;interfaceuses NGlob,     Crt,     NGraph;procedure DisplayPCX (FileName: String);procedure SetPCXPal (FileName: String);procedure NormPalette;type  { Структура заголовка PCX файла }  TPCXHeader = record    Manuf          : Byte;                  { Всегда = 10 }    Hard           : Byte;                  { Version information         }    Cod            : Byte;                  { Run-length encoding (=1)    }    BitPrePix      : Byte;                  { Bits per pixel              }    X1             : Word;                  { Picture dimensions (incl)   }    Y1             : Word;                  {                             }    X2             : Word;                  {                             }    Y2             : Word;                  {                             }    HorizRes       : Word;                  { Display horiz resolution    }    VertRes        : Word;                  { Display vert  resolution    }    Pal            : array[1..48] of Byte;  { Pallete                     }    VMode          : Byte;                  { (ignored)                   }    NUmbOFPlan     : Byte;                  { Number of planes (ver 2.5=0)}    BytePerLine    : Word;                  { Bytes per line              }    Col            : Word;                  { Palette Info (1=col, 2=gray)}    ScanHor        : Word;                  { Scanner resolution          }    ScanVer        : Word;                  {                             }    Extra          : array[1..54] of Byte;  { Extra space (filler)        }  end;implementationprocedure DisplayPCX (FileName: String);var  PCXFile: File;  Header: TPCXHeader;  Body: Pointer;  NumRead, ByteCnt,  DispStr, DispByte, CurShift: Word;  Plan, Numb, RealCount: Byte;  Value: Byte;  DataP, CarPtr: ^Byte;  Change: Boolean;  BuffSize, i: Word;procedure PCXEnd;begin  Close (PCXFile);  FreeMem (Body, BuffSize);end;procedure PCXBegin;begin  Assign (PCXFile, FileName);  Reset (PCXFile, 1);  BlockRead (PCXFile, Header, SizeOf (TPCXHeader), NumRead);  BuffSize := 10000;  GetMem (Body, BuffSize);  CarPtr := ActBlPtr;  DispByte := 0;  Plan := 0;  DispStr := 0;end;procedure UnPack;begin  if (DataP^ >= $C0) then begin    Numb := DataP^ - $C0;    Inc (LongInt (DataP)); Inc (ByteCnt);    if (ByteCnt >= NumRead) then begin      Seek (PCXFile, FilePos (PCXFile) - 1);      Numb := 0;    end;    Value := DataP^;    Inc (LongInt (DataP)); Inc (ByteCnt);  end  else begin    Numb := 1;    Value := DataP^;    Inc (LongInt (DataP)); Inc (ByteCnt);  end;end;procedure ChangePlan;begin  DispByte := 0;  Inc (Plan);  if (Plan = Header.NumbOfPlan) then begin    Plan := 0;    Inc (DispStr);    Inc (LongInt (CarPtr), Header.HorizRes);  end;end;procedure EOLControl;begin  if (DispByte + Numb < Header.BytePerLine) then begin    RealCount := Numb;    Numb := 0;    Change := False;  end  else begin    RealCount := Header.BytePerLine - DispByte;    Numb := Numb - RealCount;    Change := True;  end;end;begin  PCXBegin;  while (NumRead <> 0) do begin    BlockRead (PCXFile, Body^, BuffSize, NumRead);    DataP := Addr (Body^);    ByteCnt := 0;    while (ByteCnt < NumRead) do begin      UnPack;      while (Numb > 0) do begin        EOLControl;          for i:=1 to RealCount do begin            CurShift := DispByte;            asm              les   di, CarPtr              add   di, CurShift              mov   al, Value              mov   byte ptr es:[di], al            end;            Inc (DispByte);          end;        if Change then begin          ChangePlan;          if (DispStr = Header.VertRes) then begin            PCXEnd;            Exit;          end;        end;      end;    end;  end;  PCXEnd;end;procedure NormPalette;var  Pal: array [1..768] of Byte absolute Palette;  i: Word;begin  for i:=1 to 768 do Pal[i] := Pal[i] shr 2;end;procedure SetPCXPal (FileName: String);var  PCXFile: File;  NumRead: Word;  Ident, i: Byte;begin  Assign (PCXFile, FileName);  Reset (PCXFile, 1);  Seek (PCXFile, FileSize (PCXFile) - 769);  BlockRead (PCXFile, Ident, 1, NumRead);  BlockRead (PCXFile, Palette, 768, NumRead);  Close (PCXFile);  NormPalette;end;end.highlightSyntax('delphiYjc1ZW','delphi'); Добавлено @ 02:53 Код unit NGlob;interfaceconst{================= Переменные для экрана и блоков =================}  ActBlPtr: Pointer = Ptr ($A000, 0);  ActBX: Word = 320;  ActBY: Word = 200;  VisBlPtr: Pointer = Ptr ($A000, 0);  VisBX: Word = 320;  VisBY: Word = 200;  VBlockNum = 20;  ActBlock: Byte = 1;  VisBlock: Byte = 1;  ActXMin: Word = 0;  ActXMax: Word = 320;  ActYMin: Word = 0;  ActYMax: Word = 200*320;  VisXMin: Word = 0;  VisXMax: Word = 320;  VisYMin: Word = 0;  VisYMax: Word = 200*320;  ScrDelay: LongInt = 0;  { Переменная для отсчета времени }  OScrTime: LongInt = 0;type  TRGB = record R, G, B: Byte end;  TVBlock = record    Free: Boolean;    PutX, PutY: Integer;    SizeX, SizeY: Word;    BlPtr: Pointer;  end;  TPtr = record Offs, Segm: Word end;  THead = record X, Y: Word end;  PHead = ^THead;  PWord = ^Word;  PByte = ^Byte;  PPointer = ^Pointer;  TPalette = array [0..255] of TRGB;var  Palette: TPalette;  VMCount: Byte;  VBlock: array [1..VBlockNum] of TVBlock;implementationend.highlightSyntax('delphiMjgzOTE','delphi'); Добавлено @ 02:54 Код unit NGraph;interfaceuses NGlob,     Dos;function  SetGraph: Boolean;procedure ClsGraph;procedure SetRGBColor (Color: Word; R, G, B: Byte);procedure SetPalette (var Pal);procedure Line (X1, Y1, X2, Y2: Integer; Color: Byte);procedure Bar (X1, Y1, X2, Y2: Integer; Color: Byte);procedure PutPixel (X1, Y1: Integer; Color: Byte);function  GetPixel (X1, Y1: Integer): Byte;procedure InitBlocks;procedure GetBlock (var NBlock: Byte; SzX, SzY: Word);procedure FreeBlock (var NBlock: Byte);procedure PutBlock (NBlock: Byte);procedure PutBlockXY (NBlock: Byte; X, Y: Integer);procedure CutBlock (NBlock: Byte);procedure CutBlockXY (NBlock: Byte; X, Y: Integer);procedure FillBlock (NBlock, Color: Byte);procedure SetActBlock (NBlock: Byte);procedure TGetMem (var P: Pointer; Size: Word);procedure ErrMsg (Msg: String);procedure ScrOFF;procedure ScrSlowOFF;procedure ScrON;procedure ScrSlowON;procedure Wait;procedure Sync;implementationfunction SetGraph: Boolean;label NotVGA;begin  SetGraph := FALSE;  asm    mov   ax, 1A00h    int   10h    cmp   al, 1Ah    jne   NotVGA    mov bl, 10h    mov ah, 12h    int 10h    mov VMCount, bl    mov ax, 0013h    int 10h  end;  SetGraph := TRUE;  ScrOFF;NotVGA:end;procedure ClsGraph; assembler;asm  mov ax, 0003h  int 10h  mov ax, 1202h  mov bl, 30h  int 10hend;procedure SetRGBColor (Color: Word; R, G, B: Byte); assembler;asm  mov  ax, 1010h  mov  bx, Color  mov  dh, R  mov  ch, G  mov  cl, B  int  10hend;procedure SetPalette (var Pal); assembler;asm  mov   dx, 3C8h  mov   al, 0  out   dx, al  push  ds  lds   si, Pal  mov   bx, 2@@Nxt:  cli  mov   dx, 3DAh@@Wait2:  in    al, dx  test  al, 08h  jz    @@Wait2  mov   cx, 128*3  mov   dx, 3C9h@@PalLoop:  lodsb  out   dx, al  loop  @@PalLoop  dec   bx  cmp   bx, 0  jne   @@Nxt  sti  pop   dsend;procedure Line (X1, Y1, X2, Y2: Integer; Color: Byte); assembler;var  DiagYInc, DiagXInc, Diag_count,  StrXInc, StrYInc, StrCount,  ShortDist: Word;asm  mov  cx, 1  mov  dx, 1  mov  di, Y2  sub  di, Y1  jge  @@Keep_Y  neg  dx  neg  di@@Keep_Y:  mov  DiagYInc, dx  mov  si, X2  sub  si, X1  jge  @@Keep_X  neg  cx  neg  si@@Keep_X:  mov  DiagXInc,cx  cmp  si, di  jge  @@Horz_seg  mov  cx, 0  xchg si, di  jmp  @@Save_values@@Horz_seg:  mov  dx, 0@@Save_values:  mov  ShortDist, di  mov  StrXInc,   cx  mov  StrYInc,   dx  {Вычисление вы равнивания}  mov  ax, ShortDist  shl  ax, 1  mov  StrCount, ax        {  SD*2 -> столько раз прямая }  sub  ax, si  mov  bx, ax              {  BX - (SD*2-LD) }  sub  ax, si  mov  Diag_count, ax      {  (SD-LD)*2 -> столько раз диагональ }  mov  cx, X1  mov  dx, Y1  inc  si              {  SI - длинная дистанция }  mov  es, word ptr ActBlPtr[2]  { Основной цикл }@@MainLoop:  dec  si  jl   @@Done  { Выводится точка X-CX Y-DX }  cmp  cx, ActBX  jae  @@Hole  cmp  dx, ActBY  jae  @@Hole  push dx  mov  di, word ptr ActBlPtr  mov  ax, ActBX  mul  dx  add  di, ax  add  di, cx  mov  al, Color  mov  byte ptr es:[di], al  pop  dx@@Hole:  cmp  bx, 0  jge  @@Diag_line  add  cx, StrXInc  add  dx, StrYInc  add  bx, StrCount  jmp  @@MainLoop@@Diag_line:  add  cx, DiagXInc  add  dx, DiagYInc  add  bx, Diag_count  jmp  @@MainLoop@@Done:end;procedure Bar (X1, Y1, X2, Y2: Integer; Color: Byte);var  XCount, YCount, XInc: Integer;begin  XCount := X2 - X1;  YCount := Y2 - Y1;  XInc := ActBX - XCount;  asm    les  di, ActBlPtr    mov  ax, Y1    mov  bx, ActBX    mul  bx    add  ax, X1    add  di, ax    mov  dx, YCount@@NxtStr:    mov  al, Color    mov  cx, XCount    rep  stosb    dec  dx    add  di, XInc    cmp  dx, 0    jg   @@NxtStr  end;end;procedure PutPixel (X1, Y1: Integer; Color: Byte); assembler;asm  les  di, ActBlPtr  mov  ax, Y1  mov  bx, ActBX  mul  bx  add  ax, X1  add  di, ax  mov  al, Color  stosbend;function GetPixel (X1, Y1: Integer): Byte; assembler;asm  les  di, ActBlPtr  mov  ax, Y1  mov  bx, ActBX  mul  bx  add  ax, X1  add  di, ax  mov  al, byte ptr es:[di]end;procedure InitBlocks;var  i: Byte;begin  for i:=1 to VBlockNum do    with VBlock[i] do  Free := TRUE;  with VBlock [VisBlock] do begin    Free := FALSE;    SizeX := 320;    SizeY := 200;    BlPtr := VisBlPtr;  end;  SetActBlock (VisBlock);end;procedure GetBlock (var NBlock: Byte; SzX, SzY: Word);var  i: Byte;  Size: Word;begin  i:=0;  repeat    Inc (i);  until VBlock[i].Free or (i > VBlockNum);  if i > VBlockNum then ErrMsg ('Not enough VBlocks');  NBlock := i;  with VBlock[i] do begin    Free := FALSE;    SizeX := SzX;    SizeY := SzY;    TGetMem (BlPtr, SizeX*SizeY);  end;end;procedure FreeBlock (var NBlock: Byte);begin  with VBlock[NBlock] do begin    FreeMem (BlPtr, SizeX*SizeY);    Free := TRUE;  end;end;procedure FillBlock (NBlock, Color: Byte);var  Count: Word;  DstPtr: Pointer;begin  with VBlock [NBlock] do begin    Count := SizeX*SizeY;    DstPtr := BlPtr;  end;  asm    les  di, DstPtr    mov  al, Color    mov  ah, al    mov  cx, Count    shr  cx, 1    rep  stosw  end;end;procedure PutBlock (NBlock: Byte);var  Count: Word;  SrcPtr, DstPtr: Pointer;  SzX, SzY, XInc: Word;begin  with VBlock [NBlock] do begin    SzX := SizeX;    SzY := SizeY;    SrcPtr := BlPtr;    XInc := ActBX - SizeX;    DstPtr := Pointer (LongInt (ActBlPtr) + PutY * ActBX + PutX);  end;  if (SzX=0) or (SzY=0) then Exit;  asm    push ds    les  di, DstPtr    lds  si, SrcPtr    mov  dx, SzY@@NxtStr:    mov  cx, SzX    rep  movsb    add  di, XInc    dec  dx    cmp  dx, 0    jg   @@NxtStr    pop  ds  end;end;procedure PutBlockXY (NBlock: Byte; X, Y: Integer);var  Count: Word;  SrcPtr, DstPtr: Pointer;  SzX, SzY, XInc: Word;begin  with VBlock [NBlock] do begin    SzX := SizeX;    SzY := SizeY;    SrcPtr := BlPtr;    XInc := ActBX - SzX;    DstPtr := Pointer (LongInt (ActBlPtr) + Y * ActBX + X);  end;  if (SzX=0) or (SzY=0) then Exit;  asm    push ds    les  di, DstPtr    lds  si, SrcPtr    mov  dx, SzY@@NxtStr:    mov  cx, SzX    rep  movsb    add  di, XInc    dec  dx    cmp  dx, 0    jg   @@NxtStr    pop  ds  end;end;procedure CutBlock (NBlock: Byte);var  SrcPtr, DstPtr: Pointer;  SzX, SzY, PX, PY, XInc: Integer;begin  with VBlock [NBlock] do begin    SzX := SizeX; SzY := SizeY;    DstPtr := BlPtr;    XInc := ActBX - SzX;    SrcPtr := Pointer (LongInt (ActBlPtr) + PutY * ActBX + PutX);  end;  if (SzX=0) or (SzY=0) then Exit;  asm    push ds    les  di, DstPtr    lds  si, SrcPtr    mov  dx, SzY@@NxtStr:    mov  cx, SzX    rep  movsb    add  si, XInc    dec  dx    cmp  dx, 0    jg   @@NxtStr    pop  ds  end;end;procedure CutBlockXY (NBlock: Byte; X, Y: Integer);var  SrcPtr, DstPtr: Pointer;  SzX, SzY, XInc: Word;begin  with VBlock [NBlock] do begin    SzX := SizeX;    SzY := SizeY;    DstPtr := BlPtr;    XInc := ActBX - SzX;    SrcPtr := Pointer (LongInt (ActBlPtr) + Y * ActBX + X);  end;  if (SzX=0) or (SzY=0) then Exit;  asm    push ds    les  di, DstPtr    lds  si, SrcPtr    mov  dx, SzY@@NxtStr:    mov  cx, SzX    rep  movsb    add  si, XInc    dec  dx    cmp  dx, 0    jg   @@NxtStr    pop  ds  end;end;procedure SetActBlock (NBlock: Byte);begin  ActBlock := NBlock;  with VBlock [ActBlock] do begin    ActBlPtr := BlPtr;    ActBX := SizeX;    ActBY := SizeY;    ActXMin := 0;    ActXMax := ActBX;    ActYMin := TPtr (BlPtr).Offs;    ActYMax := TPtr (BlPtr).Offs + SizeY * ActBX;  end;end;procedure TGetMem (var P: Pointer; Size: Word);var  St: String [11];  TstSize, TstAvail: LongInt;begin  TstSize := Size;  TstAvail := MaxAvail;  if TstAvail < TstSize then begin    Str (TstSize - TstAvail, St);    ErrMsg ('Not enough memory :' + St + ' Byte');  end;  GetMem (P, Size);end;procedure ErrMsg (Msg: String);begin  ClsGraph;  WriteLn (Msg);  Halt (1);end;procedure ScrOFF;var  TmpPal: array [0..255] of TRGB;  i: Byte;begin  for i:=0 to 255 do    with TmpPal[i] do begin      R := 0; G := 0; B:=0;    end;  SetPalette (TmpPal);end;procedure ScrSlowOFF;var  TmpPal: array [0..255] of TRGB;  i, j: Byte;  NScrTime: LongInt absolute $0040:$006C;begin  for j:=64 downto 1 do begin    for i:=0 to 255 do      with TmpPal[i] do begin        R := Palette[i].R * j div 64;        G := Palette[i].G * j div 64;        B := Palette[i].B * j div 64;      end;    repeat until NScrTime - OScrTime > 0;    OScrTime := NScrTime;    SetPalette (TmpPal);  end;end;procedure ScrON;var  TmpPal: array [0..255] of TRGB;  i: Byte;begin  for i:=0 to 255 do    with TmpPal[i] do begin      R := 0; G := 0; B:=0;    end;  SetPalette (Palette);end;procedure ScrSlowON;var  TmpPal: array [0..255] of TRGB;  i, j: Byte;  NScrTime: LongInt absolute $0040:$006C;begin  for j:=1 to 64 do begin    for i:=0 to 255 do      with TmpPal[i] do begin        R := Palette[i].R * j div 64;        G := Palette[i].G * j div 64;        B := Palette[i].B * j div 64;      end;    repeat until NScrTime - OScrTime > 0;    OScrTime := NScrTime;    SetPalette (TmpPal);  end;end;procedure Wait;var  NScrTime: LongInt absolute $0040:$006C;begin  if NScrTime > 5 then    repeat    until  NScrTime - OScrTime > ScrDelay;  OScrTime := NScrTime;end;procedure Sync; assembler;asm  mov  dx, 3DAh@@Wait:  in   al, dx  test al, 08h  jz @@Waitend;end.highlightSyntax('delphimZhZTJhZ','delphi');

- Парни, огромное спасибо и oleg1973 ,и pascal . Вы мне очень классно помогли! Огромное спасибо! Теперь все ок! Благодарю парни!

Интернет казино     Онлайн игры     Увеличение члена     Купить DVD