home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / graphics.swg / 0140_Bitmap Scaler.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-03-26  |  5.6 KB  |  175 lines
  1. {
  2. Here is a version of a bitmap scaler. It is rather old and isn't very
  3. optimized. Please do not send improvements to me, as I don't want them.
  4. The unit IMAGE is included in the next message.
  5.  
  6. }
  7. Program ScaleImage;
  8. { A bitmap scaler }
  9. { Alex Chalfin    achalfin@uceng.uc.edu }
  10. { About 1 1/2 years old. It works and its pretty fast }
  11. { Sorry about the Pascal only, bungled, uncommented code }
  12.  
  13. Uses Crt,Image;
  14. Var
  15.   Pic, Bit : Pointer;
  16.   X, y, z, A1, A12 : Integer;
  17.  
  18.  
  19. Procedure Scale(Factor : Real; Var Image, Scaled : Pointer);
  20.  
  21. Var
  22.   NewLength, NewWidth, Segment, Offset, ScaleSeg, ScaleOfs : Word;
  23.   ScaleSize, Count3, Count2, Count, Orig, Orig2, TallStep, SideStep : Word;
  24.   Msb, Lsb, TallLeft, SideLeft, TallSkip, SideSkip : Byte;
  25.  
  26. Begin
  27.   Segment := Seg(Image^); Offset := Ofs(Image^);
  28.   Msb := Mem[Segment:Offset + 2]; Lsb := Mem[SegMent:Offset + 3];
  29.   Orig2 := (Msb ShL 8) + Lsb;
  30.   ScaleSize := Trunc((Factor * Factor) * ((MsB ShL 8) + LsB));
  31.   GetMem(Scaled, (ScaleSize) + 4);
  32.   ScaleSeg := Seg(Scaled^); ScaleOfs := Ofs(Scaled^);
  33.   Msb := Mem[Segment:Offset]; Lsb := Mem[Segment:Offset + 1];
  34.   Orig := ((Msb ShL 8) + LsB);
  35.   NewWidth := Trunc(Factor * Orig);
  36.   NewLength := Trunc(Factor * (Orig2 div Orig));
  37.   A1 := newwidth; A12 := newlength;
  38.   TallStep := Trunc(NewLength / (Orig2 div Orig));
  39.   SideStep := NewWidth Div Orig; TallLeft := NewLength Mod TallStep;
  40.   SideLeft := NewWidth Mod SideStep;
  41.   Mem[ScaleSeg:ScaleOfs] := NewWidth Shr 8;
  42.   Mem[ScaleSeg:ScaleOfs + 1] := NewWidth and 255;
  43.   Mem[ScaleSeg:ScaleOfs + 2] := (NewLength * NewWidth + 4) Shr 8;
  44.   Mem[ScaleSeg:ScaleOfs + 3] := (NewLength * NewWidth + 4) and 255;
  45.   ScaleOfs := ScaleOfs + 4;
  46.   Offset := Offset + 4;
  47.   If TallLeft > 0
  48.     Then TallSkip := TallSkip + 1;
  49.   If SideLeft > 0
  50.     Then SideSkip := SideSkip + 1;
  51.   For Count := 1 to (Orig2 Div Orig) do
  52.     Begin
  53.       For Count2 := 1 to Orig do
  54.         Begin
  55.           FillChar(Mem[ScaleSeg:ScaleOfs], SideStep, Mem[Segment:Offset]);
  56.           ScaleOfs := ScaleOfs + SideStep;
  57.           Offset := Offset + 1;
  58.         End;
  59.       For Count3 := 1 to (TallStep - 1) do
  60.         Begin
  61.           Move(Mem[ScaleSeg:ScaleOfs - NewWidth], Mem[ScaleSeg:ScaleOfs], NewWi
  62.           ScaleOfs := ScaleOfs + NewWidth;
  63.         End;
  64.    End;
  65. End;
  66.  
  67. Begin
  68.   Asm
  69.     mov  ax,13h
  70.     int  10h
  71.   End;
  72.   For X := 0 to 199 do
  73.     FillChar(Mem[$A000:X*320], 320, X);
  74.   z := ImageSize(1, 1, 10, 10);
  75.   Getmem(Pic, z);
  76.   Getimage(1, 1, 10, 10, Pic^);
  77.   for z := 1 to 15 do
  78.     begin
  79.       Scale(z, Pic, Bit);
  80.       Putimage((320 div 2) - (A1 div 2), (200 div 2) - (A12 div 2), Bit^);
  81.     {  Delay(200);}
  82.     end;
  83.   Readln;
  84.   Asm
  85.     mov  ax,3
  86.     int  10h
  87.   End;
  88. End.
  89.  
  90. {
  91. Here is the IMAGE unit required for the bitmap scaler.
  92. Again, don't send me improvements.
  93. }
  94.  
  95. Unit Image;
  96.  
  97. Interface
  98.  
  99. Function ImageSize(X1, Y1, X2, Y2 : Word): Word;
  100. Procedure GetImage(X1, Y1, X2, Y2 : Word; Var BitMap);
  101. Procedure Putimage(X1, Y1 : Word; Var BitMap);
  102.  
  103. Implementation
  104.  
  105. Function ImageSize(X1, Y1, X2, Y2 : Word) : Word;
  106.  
  107. Begin
  108.   ImageSize := 4 + ((1 + (Y2 - Y1)) * (1 + (X2 - X1)));
  109. End;
  110.  
  111. Procedure GetImage(X1, Y1, X2, Y2 : Word; Var BitMap);
  112.  
  113. Var
  114.   BitMapPicSize : Word;  {size of bitmap to be saved}
  115.   Count : Word;          {counting variable}
  116.   TempOfs : Word;        {length of a line in bitmap}
  117.   Offset : Word;         {offset to move move memory to}
  118.   Msb, Lsb : Byte;       {most and least significant bytes of a word}
  119.  
  120. Begin
  121.   BitMapPicSize := ImageSize(X1, Y1, X2, Y2);
  122.   OffSet := Ofs(BitMap);
  123.   TempOfs := (X2 - X1) + 1;
  124.   Msb := TempOfs ShR 8;            {\                                 }
  125.   Lsb := TempOfs and 255;          {  \                               }
  126.   MemW[Seg(BitMap):OffSet] := Msb; {   | Save line length in pointer  }
  127.   Offset := OffSet + Sizeof(Msb);  {   |                              }
  128.   MemW[Seg(BitMap):OffSet] := Lsb; {  /                               }
  129.   Offset := OffSet + Sizeof(Msb);  {/                                 }
  130.   Msb := BitMapPicSize ShR 8;      {\                                 }
  131.   Lsb := BitMapPicSize and 255;    {  \                               }
  132.   MemW[Seg(BitMap):OffSet] := Msb; {   | Save imagesize in pointer    }
  133.   Offset := OffSet + Sizeof(Msb);  {   |                              }
  134.   MemW[Seg(BitMap):OffSet] := Lsb; {  /                               }
  135.   OffSet := OffSet + Sizeof(Lsb);  {/                                 }
  136.   For Count := Y1 to Y2 do                     {\                         }
  137.     Begin                                      {  \                       }
  138.       Move(MemW[$A000:X1 + (320 * Count)],    {    \  Save picture info  }
  139.            MemW[Seg(BitMap):Offset], TempOfs); {    /                     }
  140.       OffSet := OffSet + TempOfs;              {  /                       }
  141.     End;                                       {/                         }
  142. End;
  143.  
  144. Procedure Putimage(X1, Y1 : Word; Var BitMap);
  145.  
  146. Var
  147.   OffSet : Word;
  148.   BitLength : Word;
  149.   BitSize : Word;
  150.   VGAOffSet : Word;
  151.   Msb : Byte;
  152.   Lsb : Byte;
  153.   BitCount : Word;
  154.  
  155. Begin
  156.   VGAOffSet := X1 + (Y1 * 320);
  157.   OffSet := Ofs(BitMap);
  158.   Msb := MemW[Seg(BitMap):Offset];
  159.   Lsb := MemW[Seg(BitMap):Offset + 1];
  160.   BitLength := (Msb ShL 8) + Lsb;
  161.   Msb := MemW[Seg(BitMap):Offset + 2];
  162.   Lsb := MemW[Seg(BitMap):Offset + 3];
  163.   OffSet := OffSet + 4;
  164.   BitSize := (Msb Shl 8) + Lsb;
  165.   BitSize := ((BitSize - 2) div BitLength);
  166.   For BitCount := 1 to BitSize do
  167.     Begin
  168.       Move(MemW[Seg(BitMap):OffSet], MemW[$A000:VGAOffSet], BitLength);
  169.       OffSet := OffSet + BitLength;
  170.       VgaOffSet := VGAOffSet + 320;
  171.     End;
  172. End;
  173.  
  174. End.
  175.