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

    {
    ========================================

    GRABIMG.PAS (C) 1994-1996 SCOTT TUNSTALL
    DISTRIBUTE FREELY

    ----------------------------------------

    This program allows you to load in a 256 colour PCX and save
    areas of it as a .IMG file.

    Use the cursor keys to move the cross hairs. Press space when you
    are at the top left of the area you wish to cut, then when the
    second pair of cross hairs appear, move them to the bottom right
    of the image to cut. You will see the size of the image in
    horizontal width & vertical height at the bottom left of the
    screen. When you have a sprite of the desired size defined
    within the crosshairs, press space again.

    If the Shape (it must be less than width/height 255 * 255) can be
    grabbed then you will be asked for a filename for the Shape to
    be saved.

    Standard MS - DOS filenames are required.

    ===============

    For the coders:

    ---------------

    Shape grabbed is from the non planar, unchained VGA mode $13.

    =====================

    File format of image:

    ---------------------

    Byte 0 : Width
    Byte 1 : Height
    Byte 2.. Actual Shape data itself, uncompressed. The data is
             saved row by row, line by line.

    To read it use the LoadShape command present in NEWGRAPH

    ex:
            var p: pointer;
            LoadShape('SPRITE.IMG',p);
            ...

    To display it use the Blit/Block/ClipBlit/ClipBlock commands.

    }

    Uses NEWGRAPH, NWKBDINT, CRT, DOS;

         { NOTE : NWKBDINT - in KEYBOARD.SWG
                  NEWGRAPH - in GRAPHICS.SWG }

    Var BarColour : byte;
        FirstBarX,
        FirstBarY,
        SecondBarX,
        SecondBarY: word;
        Grabbing: boolean;
        BufferSeg,
        BufferOffset:word;
        ThePalette: PaletteType;

    {
    Find the brightest colour available, and, yes I did program
    this, it's not from SWAG or anything like that. Shall I explain
    it to you ?

    Each Colour has it's own Red, Green and Blue value attached to it.
    Each Colour can have Red, Green and Blue component values of 64
    thus giving 262,144 colours (64 * 64 * 64)

    To find the brightest colour you just read the palette entries,
    add up the Red, Green and Blue values and check if they are the
    brightest so far. If they are, take a note of what Colour has
    those values and do until all Colours are scanned. Easy eh? :-)
    }

    Function GetBrightestColour: byte;
    Var Total: byte;
        Count: byte;
        RedTotal,
        GreenTotal,
        BlueTotal, ColourWithBestHue : byte;

        BestHueFound,
        HueValue: longint;

    Begin
         Count:=0;

         BestHueFound:=0;
         ColourWithBestHue:=0;

         HueValue:=0;

         Repeat
               GetPalette(Count,RedTotal,GreenTotal,BlueTotal);
               HueValue:=BlueTotal+(GreenTotal*16)+(RedTotal * 256);
               If HueValue > BestHueFound Then
                  Begin
                  BestHueFound:=HueValue;
                  ColourWithBestHue:=Count;
               End;
               Inc(Count);
         Until Count=0;

         GetBrightestColour:=ColourWithBestHue;
    End;

    Procedure Sort(Var N1, N2: word);
    Var Temp: word;
    Begin
         If N1 > N2  Then
            Begin
            Temp:=N1;
            N1:=N2;
            N2:=Temp;
         End;
    End;

    Procedure GetTheShape;
    Var ShapeName: PathStr;
        Palette: PaletteType;
        OldBarX,
        OldBarY: word;
        TheShapePointer: pointer;
        MemRequired: word;
        Key: char;

    Begin
         OldBarX:=FirstBarX;
         OldBarY:=FirstBarY;

         {
         O.K. As the graphics unit I've written only takes X and Y
         coordinates that are ordered (i.e. define a rectangular
         area) I've got to make sure than X1 is less than X2 and
         Y1 is less than Y2.
         }

         Sort(FirstBarX,SecondBarX);
         Sort(FirstBarY,SecondBarY);

         If (FirstBarX < SecondBarX) And (FirstBarY < SecondBarY) Then
            Begin

            GetAllPalette(Palette);

            MemRequired:= ExtShapeSize((SecondBarX-FirstBarX),
                          (SecondBarY-FirstBarY));

            GetMem(TheShapePointer,MemRequired);
            GetAShape(FirstBarX,FirstBarY,SecondBarX,SecondBarY,TheShapePointer^);

            SetSourceBitmapAddr($a000,0);
            Cls;

            Block(0,0,TheShapePointer^);

            BarColour:=GetBrightestColour;
            SetColour(BarColour);
            OutTextXY(0,192,'SAVE THIS IMAGE (Y/N) :');

            Repeat
                  key:=upcase(readkey);
            Until (key= 'Y') or (key = 'N');

            If key = 'Y' Then
               Begin
               Asm
               MOV AX,2
               INT $10
               End;

               Write('Save Shape as :');
               Readln(ShapeName);

               {$i-}
               SaveShape(ShapeName,TheShapePointer);
               {$i+}
            End;

            FreeShape(TheShapePointer);

            InitVGAMode;
            SetAllPalette(ThePalette);
            ShowBitmap(BufferSeg,BufferOffset);

            FirstBarX:=OldBarX;
            FirstBarY:=OldBarY;

         End;
    End;

    {
    I'm not too keen on this proc.. reckon I will change it later
    when my Bsc is over.
    }

    Procedure UpdateBars(Var HorizontalBar, VerticalBar: word);
    Begin
         If Keydown[72] And (VerticalBar >0) Then
            Dec(VerticalBar);
         If Keydown[80] And (VerticalBar <200) Then
            Inc(VerticalBar);
         If Keydown[75] And (HorizontalBar >=0) Then
            Dec(HorizontalBar);
         If Keydown[77] And (HorizontalBar <320) Then
            Inc(HorizontalBar);
    End;

    Procedure GrabShape;
    Var
        Dist: integer;
        TempString: string[4];

    Begin
         BarColour:=GetBrightestColour;
         HookKeyboardInt;

         Repeat
               ShowBitmap(BufferSeg,BufferOffset);
               SetSourceBitmapAddr($a000,0);

               SetColour(BarColour);

               Line(FirstBarX,0,FirstBarX,199);
               Line(0,FirstBarY,319,FirstBarY);

               If Grabbing Then
                  Begin
                  Line(SecondBarX,0,SecondBarX,199);
                  Line(0,SecondBarY,319,SecondBarY);

                  If SecondBarX > FirstBarX Then
                     Dist:=(SecondBarX - FirstBarX)+1
                  Else
                      Dist:=(FirstBarX - SecondBarX)+1;

                  Str(Dist,TempString);
                  OutTextXY(0,190,'WIDTH: '+TempString);

                  If SecondBarY > FirstBarY Then
                     Dist:=(SecondBarY - FirstBarY)+1
                  Else
                      Dist:=(FirstBarY - SecondBarY)+1;

                  Str(Dist,TempString);
                  OutTextXY(160,190,'HEIGHT:'+TempString);

                  End;

               { Memw[$40:$1a]:=Memw[$40:$1c]; }

               If Not Grabbing Then
                  Begin
                  UpdateBars(FirstBarX, FirstBarY);
                  If Keydown[57] Then Begin
                      Sound(50);
                      Delay(100);
                      NoSound;
                      Grabbing:=True;
                      SecondBarX:=FirstBarX+15;
                      SecondBarY:=FirstBarY+15;
                  End;
                  End
               Else
                   Begin
                   UpdateBars(SecondBarX, SecondBarY);

                   If Keydown[57] Then
                      Begin
                      UnHookKeyBoardInt;
                      SetSourceBitmapAddr(BufferSeg,BufferOffset);
                      GetTheShape;
                      Grabbing:=False;
                      HookKeyBoardInt;
                      End;
                   End;

               { Make sure that bars flicker }

               Until KeyDown[1];
         UnHookKeyboardInt;
    End;

    {
    What this does is allocate memory for the PCX (Assuming 64000
    bytes are free for it) then loads the PCX into RAM, where it
    can be read (but not altered) by this program.
    }

    Procedure LoadPCXIntoBuffer(ThePCXFileName:string);
    Begin
         If MaxAvail > 64000 Then
            Begin
            Bitmap(BufferSeg,BufferOffset);
            SetSourceBitmapAddr(BufferSeg,BufferOffset);
            InitVGAMode;

            LoadPCX(ThePCXFileName,ThePalette);
            SetAllPalette(ThePalette);
            SetSourceBitmapAddr($a000,0);
            CopySourceBitmap;
            End
         Else
             Begin
             Writeln;
             Writeln('Out of memory error. The program needed 64K for the');
             Writeln('PCX buffer but only ',maxavail div 1024,'K was');
             Writeln('available.');
             Writeln;
             Halt;
             End;

    End;

    Procedure FreeBuffer;
    Begin
         FreeBitmap(BufferSeg,BufferOffset);
    End;

    {
    Ask for the name of PCX to load.
    }

    Procedure RequestPCXFile;
    Var PCXName: PathStr;
        DummyFileVar: File;
    Begin
         Writeln;
         Writeln('Enter name of Mode 13h 256 colour PCX file to load :');
         Readln(PCXName);
         Assign(DummyFileVar,PCXName);
         {$i-}
         Reset(DummyFileVar);
         {$i+}

         If IoResult = 0 Then
            LoadPCXIntoBuffer(PCXName)
         Else
             Begin
             Writeln;
             Writeln('Error in loading your .PCX file!');
             Writeln('The filename (and/or path) specified does not exist.');
             Halt;
         End;
    End;

    {
    Main()
    }

    Begin
         Writeln;
         Writeln('PCX Shape grabber  (C) 1995 Scott Tunstall.');
         Writeln;
         Writeln('Written especially for :');
         Writeln('   Scott "B & Q" Ramsay');
         Writeln('   Paul Langa');
         Writeln;

         If ParamCount <>1 Then
            RequestPCXFile
         Else
             LoadPCXIntoBuffer(Paramstr(1));

         Grabbing:=False;
         FirstBarX:=160;
         FirstBarY:=100;
         SecondBarX:=160;
         SecondBarY:=100;

         GrabShape;
         FreeBuffer;
    END.

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