[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]

    { ROTATE.PAS }

    {
      Rotating textured surface.
      Coded by Mike Shirobokov(MSH) aka Mad Max / Queue members.
      You can do anything with this code until this comments
      remain unchanged.

      Bugs corrected by Alex Grischenko
    }

    {$G+,A-,V-,X+}
    {$M 16384,0,16384}

    uses Crt, Objects, Memory, VgaGraph;  { unit code at the end of program }

    const
    { Try to play with this constants }
      RotateSteps  = {64*5}65*10;
      AngleStep    = {3}1;
      MoveStep     = {10}1;
      ScaleStep    : Real =  0.02;

    type
      TBPoint = record X,Y: { Byte} Integer; end;
      TPointArray = array[ 1..500 ] of TBPoint;

      TRotateApp = object(TGraphApplication)
        StartTime,
        FramesNumber:LongInt;
        {Texture: TImage;}
        X,Y    : Integer;
        WSX,WSY: Integer;
        WSXR,
        WSYR   : Real;
        Angle  : Integer;
        Size   : TPoint;
        CurPage: Integer;
        Texture: TImage;
        constructor Init;
        procedure Run;      virtual;
        destructor Done;    virtual;
        procedure Draw;     virtual;
        procedure FlipPage; virtual;
        procedure Rotate( AngleStep: Integer );
        procedure Move( DeltaX, DeltaY: Integer );
        procedure Scale( Factor: Real );
        procedure Update;
      end;
    var
      Pal:  TRGBPalette;
      Time:  LongInt absolute $0:$46C;

    procedure TRotateApp.FlipPage;
    begin
      CurPage := 1-CurPage;
      ShowPage(1-CurPage);
    end;

    constructor TRotateApp.Init;
    var
      I, J: Integer;
    begin
      if not inherited Init(True) or not Texture.Load( ParamStr(1) ) then Fail;
      SetPalette( Texture.Palette );
      X := 0;
      Y := 0;
      WSX := 240;
      WSY := 360;
      WSXR := WSX;
      WSYR := WSY;
      Angle := 0;
      Size.X := HRes div 2;
      Size.Y := VRes div 2;
      FramesNumber := 0;
      StartTime := Time;  {     asm mov ax,13h; int 10h; end;}
      system.move (Texture.Data^,Screen,64000);
        SetPalette( Texture.Palette );
    {  readkey;}
    end;

    procedure TRotateApp.Rotate( AngleStep: Integer );
    begin
      Inc( Angle, AngleStep );
      Angle := Angle mod RotateSteps;
    end;

    procedure TRotateApp.Move( DeltaX, DeltaY: Integer );
    begin
      Inc( X, DeltaX );
      Inc( Y, DeltaY );
    end;

    procedure TRotateApp.Scale( Factor: Real );
    begin
      WSXR := WSXR*Factor;
      WSX := Round(WSXR);
      WSYR := WSYR*Factor;
      WSY := Round(WSYR);
    end;

    procedure TRotateApp.Update;
    begin
      Move( MoveStep, MoveStep );
      Rotate(AngleStep);
      Scale(1+ScaleStep);
      if (WSY >= 2000) or (WSY<=100) then ScaleStep := -ScaleStep;
    end;

    procedure TRotateApp.Draw;

    var
      I :  Integer;
      Border,
      LineBuf: TPointArray;
      BorderLen: Integer;
      X1RN,X1LN,
      Y1RN,Y1LN,
      X2RN,X2LN,
      Y2RN,Y2LN,
      X1R,X1L,
      Y1R,Y1L,
      X2R,X2L,
      Y2R,Y2L,
      XL,YL: Integer;

    { This function can be heavly optimized but I'm too lazy to do absoletely
      meaningless things :-) }
    function BuildLine( var Buffer: TPointArray; X1,Y1, X2,Y2: Integer;
          Len: Integer ): Integer;
    var
      I: Word;
      XStep,
      YStep: LongInt;
    begin
      XStep := (LongInt(X2-X1) shl 16) div Len;
      YStep := (LongInt(Y2-Y1) shl 16) div Len;
      for I := 1 to Len do
      begin
        Buffer[I].X := Integer( ((XStep*I) shr 16) - ((XStep*(I-1)) shr 16) );
        Buffer[I].Y := Integer( ((YStep*I) shr 16) - ((YStep*(I-1)) shr 16) );
      end;
    end;

    procedure DrawPicLine( var Buffer; BitPlane: Integer;
            StartX, StartY: Integer; Len: Integer; var LineBuf );
    var
      PD :  Pointer;
    begin
      PD := Texture.Data;           { pointer to unpacked screen image }
      Port[$3C4] := 2;
      if BitPlane = 0 then
        Port[$3C5] := 3
      else
        Port[$3C5] := 12;

      asm
        push  ds
        mov   bx,[StartX]             { bx = StartX }
        mov   dx,[StartY]             { dx = StartY }
        les   di,Buffer               { ES:DI = @Screen }
        add   di,VPageLen/2-Hres/4    { calc target page }
        mov   cx,Len                  { Drawing buffer length }
        lds   si,PD                   { DS:SI = pointer to data }
        push  bp                      { store BP }
        mov   bp,word ptr LineBuf     { BP = offset LineBuf }
        cld
    @loop:
          PUSH DX
          MOV  AX,320
          MUL  DX                     { AX = StartY*320 }
          POP  DX

          PUSH BX
          ADD  BX,AX
          mov  al,[bx+SI]
          POP  BX

          stosb
          sub  di,HRes/4+1{ add di,hres-1}
          add  BX,[bp]
          ADD  bp,2
          add  DX,[bp]
          ADD  bp,2

    {      CMP  BX,320
          JB   @@1
          XOR  BX,BX
    @@1:  CMP  DX,200
          JB   @@2
          XOR  DX,DX
    @@2:}
          loop @loop

          pop bp
          pop ds
      end;
    end;

    begin

    { Just imagine what can be if the next 8 lines would be more complex.
      I'm working around it. }
    {
         (X1L,Y1L)        (X2R,Y1R)
            +---------------+
            |               |
            |               |
            |               |
            +---------------+
         (X2L,Y2L)        (X2R,Y2R)

         (X1LN,Y1LN)        (X2RN,Y1RN)
            +---------------+
            |               |
            |               |
            |               |
            +---------------+
         (X2LN,Y2LN)        (X2RN,Y2RN)

    }
      X1L := 0;
      Y1L := 0;
      X2L := 0;
      Y2L := WSY;
      X1R := WSX;
      Y1R := 0;
      X2R := WSX;
      Y2R := WSY;
    { I call Cos and Sin instead of using tables!? Yeah, I do. So what?
      See comments near BuildLine ;-) }
    {  I just rotate the rectangle corners, but why I do no more? }
      X1RN := Round(
    (X1R*Cos(2*Pi/RotateSteps*Angle)+Y1R*Sin(2*Pi/RotateSteps*Angle)) );
      Y1RN := Round(
    (Y1R*Cos(2*Pi/RotateSteps*Angle)-X1R*Sin(2*Pi/RotateSteps*Angle)) );
      X1LN := Round(
    (X1L*Cos(2*Pi/RotateSteps*Angle)+Y1L*Sin(2*Pi/RotateSteps*Angle)) );
      Y1LN := Round(
    (Y1L*Cos(2*Pi/RotateSteps*Angle)-X1L*Sin(2*Pi/RotateSteps*Angle)) );
      X2RN := Round(
    (X2R*Cos(2*Pi/RotateSteps*Angle)+Y2R*Sin(2*Pi/RotateSteps*Angle)) );
      Y2RN := Round(
    (Y2R*Cos(2*Pi/RotateSteps*Angle)-X2R*Sin(2*Pi/RotateSteps*Angle)) );
      X2LN := Round(
    (X2L*Cos(2*Pi/RotateSteps*Angle)+Y2L*Sin(2*Pi/RotateSteps*Angle)) );
      Y2LN := Round(
    (Y2L*Cos(2*Pi/RotateSteps*Angle)-X2L*Sin(2*Pi/RotateSteps*Angle)) );

      XL := X+X1LN;
      YL := Y+Y1LN;

      BuildLine( Border, XL,YL, X+X2LN,Y+Y2LN, Size.X );
      BuildLine( LineBuf, 0, 0, X1RN-X1LN, Y1RN-Y1LN, Size.Y );

    {
      The only thing that can be optimized is the loop below. I think it should
      be completely in asm.
    }
      for I := 1 to Size.X do
      begin
       DrawPicLine( PBuffer(@Screen)^[CurPage*VPageLen+(I-1) shr 1],
       (I-1) {mod 2} and 1, XL, YL, Size.Y, LineBuf );
    {
        Inc( XL, Border[I].X );
        Inc( YL, Border[I].Y );
    }
      asm
        mov   di,I
        shl   di,2
        mov   ax,word ptr border[di]-4
        add   XL,ax
        mov   ax,word ptr Border[di]-4+2
        add   YL,ax
      end;
      end;
    end;

    procedure TRotateApp.Run;
    var
      C:  Char;
    begin
      repeat
        if KeyPressed then
        begin
          C := ReadKey;
          if C = #0 then C := ReadKey;
          case C of
     #72: Move(0,-10);
     #80: Move(0,-10);
     #75: Move(-10,0);
     #77: Move(10,0);
     #81: Rotate(1);
     #79: Rotate(-1);
     '+': Scale(1+ScaleStep);
     '-': Scale(1-ScaleStep);
     #27: Exit;
          end;
        end;
       Draw;
    { You can comment out the line below and do all transformation yourself }
       Update;
       FlipPage;
       Inc( FramesNumber );
      until False;
    end;

    destructor TRotateApp.Done;
    begin
      inherited Done;
      WriteLn( 'Frames per second = ',
        (FramesNumber / ((Time-StartTime)*0.055) ):5:2 );
    end;

    var
      RotateApp: TRotateApp;
    begin
      if not RotateApp.Init then Exit;
      RotateApp.Run;
      RotateApp.Done;
    end.

    {---------------------   UNIT CODE NEEDED HERE -------------------- }

    {
      VGA graphics unit.
      Coded by Mike Shirobokov(MSH) aka Mad Max / Queue members.

      This this the very small part of my gfx unit. I leave only functions used
      by RotateApp.

      Bugs corrected by Alex Grischenko
    }

    unit VGAGraph;

    interface

    uses Objects, Memory;

    const
      HRes  = 360;
      VRes  = 320;
      VPageLen = HRes*VRes div 4;

    {  HRes = 320; VRes=200; Vpagelen=0;}

    type
      PBuffer = ^TBuffer;
      TBuffer = array[ 0..65534 ] of Byte;
      PScreenBuffer = ^TScreenBuffer;
      TScreenBuffer = array[ 0..199, 0..319 ] of Byte;
      TRGBPalette = array[ 0..255 ] of record R,G,B: Byte; end;

      PImage = ^TImage;
      TImage = object( TObject )
        Size: TPoint;
        Palette: TRGBPalette;
        Data: PBuffer;
        constructor Load( Name: String );
    {   This procedures are now killed. If you need them just write me or see
        old mail from me.
        procedure Show( Origin: TPoint; var Buffer );
        procedure ShowRect( Origin: TPoint; NewSize: TPoint; var Buffer ); }
        destructor Done; virtual;
      end;

      PGraphApplication = ^TGraphApplication;
      TGraphApplication = object( TObject )
        constructor Init( ModeX : Boolean );
        procedure Run; virtual;
        destructor Done; virtual;
      end;

    var
      Screen: TScreenBuffer absolute $A000:0;

      procedure SetPalette( var Pal: TRGBPalette );
      procedure Set360x240Mode;
      procedure ShowPage( Page: Integer );

    implementation

    uses PCX;

    constructor TImage.Load( Name: String );
    var
      S: TDosStream;
      I: Integer;
      P: OldPCXPicture;
      Len: Word;
    begin
      inherited Init;
      P.Init( Name );
      if P.Status <> pcxOK then
      begin
        P.Done;
        Fail;
      end;
      Size.X := P.H.XMax - P.H.XMin + 1;
      Size.Y := P.H.YMax - P.H.YMin + 1;
    {
      I use DOS memory allocation 'cuz GetMem can't allocate 64K
      Even thru DPMI.  :-(
      GetMem( Data, Word(Size.X) * Size.Y );
    }
      Len := Word((LongInt(Size.X)*Size.Y+15) div 16);
      LEN:=65536 DIV 16;
      asm
        mov ah,48h
        mov bx,Len
        int 21h
        jnc @mem_ok
        xor ax,ax
    @mem_ok:
        mov word ptr es:[di].Data+2,ax
        xor ax,ax
        mov word ptr es:[di].Data,ax
      end;

      if Data = nil then
      begin
        P.Done;
        Fail;
      end;

      fillchar(Data^,len*16-1,0);

      Move( P.Pal, Palette, SizeOf(Palette) );
      for I := 0 to 255 do
      begin
        Palette[I].R := Palette[I].R shr 2;
        Palette[I].G := Palette[I].G shr 2;
        Palette[I].B := Palette[I].B shr 2;
      end;

      for I := 0 to Size.Y-1 do
        P.ReadLine( Data^[ Word(Size.X)*I ] );
      P.Done;
    end;

    destructor TImage.Done;
    begin
    {
      FreeMem( Data, Word(Size.X)*Size.Y );
    }
      asm
        mov ah,49h
        mov ax,word ptr es:[di].Data+2
        mov es,ax
        int 21h
      end;
      inherited Done;
    end;

    constructor TGraphApplication.Init( ModeX : Boolean );
    begin
      Set360x240Mode
    end;

    procedure TGraphApplication.Run;
    begin
      Abstract;
    end;

    destructor TGraphApplication.Done;
    begin
      asm
        mov ax,3h
        int 10h
      end;
    end;

    procedure SetPalette( var Pal: TRGBPalette );
    var
      I : Integer;
    begin
      for I := 0 to 255 do
      begin
        Port[$3C8] := I;
        Port[$3C9] := Pal[I].R;
        Port[$3C9] := Pal[I].G;
        Port[$3C9] := Pal[I].B;
      end;
    end;

    {  Modified from public-domain mode set code by John Bridges. }

    const
     SC_INDEX  = $03c4;   {Sequence Controller Index}
     CRTC_INDEX = $03d4;   {CRT Controller Index}
     MISC_OUTPUT  = $03c2;   {Miscellaneous Output register}

    { Index/data pairs for CRT Controller registers that differ between
      mode 13h and mode X. }

    CRT_PARM_LENGTH = 17;
    CRTParms : array [1..CRT_PARM_LENGTH] of Word = (

     $6B00,  { Horz total }
     $5901,  { Horz Displayed }
     $5A02,  { Start Horz Blanking }
     $8E03,  { End Horz Blanking }
     $5E04,  { Start H Sync }
     $8A05,  { End H Sync }
     $0d06,  {vertical total}
     $3e07,  {overflow (bit 8 of vertical counts)}
     $ea10,  {v sync start}
     $8c11,  {v sync end and protect cr0-cr7}
     $df12,  {vertical displayed}
     $e715,  {v blank start}
     $0616,  {v blank end}
     $4209,  {cell height (2 to double-scan)}
     $0014,  {turn off dword mode}
     $e317,  {turn on byte mode}
     $2D13 {90 bytes per line}
    );

    procedure Set360x240Mode;
    begin
     asm
     mov     ax,13h  {let the BIOS set standard 256-color}
     int     10h     {mode (320x200 linear)}

     mov     dx,SC_INDEX
     mov     ax,0604h
     out     dx,ax   {disable chain4 mode}
     mov     ax,0100h
     out     dx,ax   {synchronous reset while switching clocks}

     mov     dx,MISC_OUTPUT
     mov     al,0E7h
     out     dx,al   {select 28 MHz dot clock & 60 Hz scanning rate}

     mov     dx,SC_INDEX
     mov     ax,0300h
     out     dx,ax   {undo reset (restart sequencer)}

     mov     dx,CRTC_INDEX {reprogram the CRT Controller}
     mov     al,11h  {VSync End reg contains register write}
     out     dx,al   {protect bit}
     inc     dx      {CRT Controller Data register}
     in      al,dx   {get current VSync End register setting}
     and     al,7fh  {remove write protect on various}
     out     dx,al   {CRTC registers}
     dec     dx      {CRT Controller Index}
     cld
     mov     si,offset CRTParms {point to CRT parameter table}
     mov     cx,CRT_PARM_LENGTH {# of table entries}
    @SetCRTParmsLoop:
     lodsw           {get the next CRT Index/Data pair}
     out     dx,ax   {set the next CRT Index/Data pair}
     push cx
     mov cx,1000
    @loop: loop @loop
     pop cx
     loop    @SetCRTParmsLoop

     mov     dx,SC_INDEX
     mov     ax,0f02h
     out     dx,ax   {enable writes to all four planes}
     mov     ax,$A000{now clear all display memory, 8 pixels}
     mov     es,ax         {at a time}
     sub     di,di   {point ES:DI to display memory}
     sub     ax,ax   {clear to zero-value pixels}
     mov     cx,VRes*HRes/4/2 {# of words in display memory}
     rep     stosw   {clear all of display memory}
     end;
    end;

    procedure ShowPage( Page: Integer );
    begin
      asm
          mov ax,VPageLen
          mul word ptr Page
          mov bx,ax

          mov dx,3d4h
          mov al,0ch
          mov ah,bh
          out dx,ax
          mov dx,3d4h
          mov al,0dh
          mov ah,bl
          out dx,ax
    { Uncomment this waiting for retrace if you see flickering }
    {
          mov dx,3dah
     @@1: in al,dx
          test al,00001000b
          jz @@1
     @@2: in   al,dx
          test al,00001000b
          jnz  @@2
    }
      end;
    end;

    End.

    { --------------------------  UNIT CODE NEEDED HERE -------------}

    {
      256 color PCX bitmaps handling unit.
      NewPCXPicture object are removed to reduce traffic. If you
      need it just contact me or dig in old mail from me.
      Coded by Mike Shirobokov(MSH) aka Mad Max / Queue Members.
      Free sourceware.
    }

    unit PCX;

    interface

    uses Objects;

    type
      TRGBPalette = array[ 0..255 ] of record R,G,B: Byte; end;

      PCXHeader = record
        Creator,
        Version,
        Encoding,
        Bits: Byte;
        XMin,
        YMin,
        XMax,
        YMax,
        HRes,
        VRes: Integer;
        Palette: array [ 1..48 ] of Byte;
        VMode,
        Planes: Byte;
        BytesPerLine,
        PaletteInfo,
        SHRes,
        SVRes: Word;
        Dummy: array [0..53] of Byte;
      end;

    const
      pcxOK   = 0;
      pcxInvalidType = 1;
      pcxNoFile  = 2;

    type
      OldPCXPicture = object
        H:  PCXHeader;
        S:  TBufStream;
        Pal: TRGBPalette;
        Status: Integer;
        constructor Init( AFileName: String );
        procedure ReadLine( var Buffer );
        function ErrorText: String;
        destructor Done;
      end;
    {
      NewPCXPicture = object
        H:  PCXHeader;
        S:  TBufStream;
        Pal: TRGBPalette;
        constructor Init( AFileName: String; HSize: Integer );
        procedure WriteLine( var Buffer );
        destructor Done;
      end;
    }
    implementation

    type
      GetByteFunc = function: Byte;
      ByteArr = array [0..65534] of Byte;
      PByte  = ^ByteArr;

    procedure UnpackString( GetByte: GetByteFunc; var Dest; Size: Integer );
    var
      DestPtr: PByte;
      Count: Integer;
      B:  Byte;
      I:  Integer;
    begin
      DestPtr := @Dest;
      Count := 0;
      while Count < Size do
      begin
        B := GetByte;
        if B < $C0 then
        begin
          DestPtr^[Count] := B;
          Inc(Count);
        end
        else
        begin
          DestPtr^[Count] := GetByte;
          for I := 0 to B-$C1 do
     DestPtr^[Count+I] := DestPtr^[Count];
          Inc( Count, I+1 );
        end;
      end;
    end;

    constructor OldPCXPicture.Init( AFileName: String );
    begin
      S.Init( AFileName, stOpenRead, 2048 );
      if S.Status <> stOk then
      begin
        Status := pcxNoFile;
        Exit;
      end;
      S.Read( H, SizeOf(H) );
      if (H.Planes <> 1) or (H.Encoding <> 1) or (H.Bits <> 8 ) then
      begin
        Status := pcxInvalidType;
        Exit;
      end;
      S.Seek( S.GetSize - SizeOf(Pal) );
      S.Read( Pal, SizeOf(Pal) );
      S.Seek( SizeOf(H) );
      Status := pcxOK;
    end;

    var
      __GetS__: PStream;

    function Get: Byte; far;
    var
      B: Byte;
    begin
      __GetS__^.Read( B, 1 );
      Get := B;
    end;

    procedure OldPCXPicture.ReadLine( var Buffer );
    begin
      __GetS__ := @S;
      UnpackString( Get, Buffer, H.BytesPerLine );
    end;

    function OldPCXPicture.ErrorText: String;
    begin
      case Status of
        pcxOK:
          ErrorText := 'No errors';
        pcxNoFile:
          ErrorText := 'Can''t open file';
        pcxInvalidType:
          ErrorText := 'Only 8 bit PCXs are supported';
      end;
    end;

    destructor OldPCXPicture.Done;
    begin
      S.Done;
    end;

    end.

[Back to GRAPHICS SWAG index] [Back to Main SWAG index] [Original]