Program Clip_Picture;

  Uses
    Crt;

  Const
    VideoSeg = $0A000;

  Type
    PicType = Array[1..16192] Of Byte;

  Var
    PicPal : Array[1..768] Of Byte;
    QuarterPic    : PicType;
    PictureFN     : String;
    PictureFile   : File of PicType;
    PointerValue,
    Red,
    Green,
    Blue          : Byte;
    ClipXLen,
    ClipYLen      : Integer;
    ByteFile      : File of Byte;


  Procedure VideoMode ( Mode : Byte );

    Begin { VideoMode }
      Asm
        Mov  AH,00
        Mov  AL,Mode
        Int  10h
      End;
    End;  { VideoMode }


  Procedure GetPointerAttrib;

    Begin { GetPointerAttrib }
      Write('Enter pointer value: ');
      Readln(PointerValue);
      Write('Enter pointer attrib RED   intensity: ');
      Readln(Red);
      Write('Enter pointer attrib GREEN intensity: ');
      Readln(Green);
      Write('Enter pointer attrib BLUE  intensity: ');
      Readln(Blue);
    End;  { GetPointerAttrib }


  Procedure LoadPalette;

    Var
      Count : Integer;

    Begin { LoadPalette }
      Port[$3C8] := 0;
      For Count := 1 To 768 Do
        Port[$3C9] := PicPal[Count];
      Port[$3C8] := PointerValue;             {* Set pointer value last *}
      Port[$3C9] := Red;                      {* to overwrite any color *}
      Port[$3C9] := Green;
      Port[$3C9] := Blue;
    End;  { LoadPalette }


  Procedure LoadPicture;

    Begin { LoadPicture }
      Read(PictureFile,QuarterPic);
      Move(QuarterPic,PicPal,768);       {* Get/store the palette *}
      LoadPalette;
      Move(QuarterPic[769],Mem[VideoSeg:0],15424);
      Read(PictureFile,QuarterPic);
      Move(QuarterPic,Mem[VideoSeg:15424],16192);
      Read(PictureFile,QuarterPic);
      Move(QuarterPic,Mem[VideoSeg:31616],16192);
      Read(PictureFile,QuarterPic);
      Move(QuarterPic,Mem[VideoSeg:47808],16192);
      Close(PictureFile);
    End;  { LoadPicture }


  Procedure LowToHigh ( Var First, Second : Integer );

    Var
      Temp : Integer;

    Begin { LowToHigh }
      If First > Second
        Then Begin
          Temp := First;
          First := Second;
          Second := Temp;
        End;
    End;  { LowToHigh }


  Procedure SaveClip ( StartX, StartY, EndX, EndY : Integer );

    Var CountX,CountY : Integer;

    Begin { SaveClip }
      LowToHigh(StartX,EndX);
      LowToHigh(StartY,EndY);
      Assign(ByteFile,'CLIPPIC.DAT');
      ReWrite(ByteFile);
      For CountY := StartY To EndY Do
        For CountX := StartX To EndX Do
          Write(ByteFile,Mem[VideoSeg:CountY*320+CountX]);
      Close(ByteFile);
      ClipXLen := EndX-StartX+1;
      ClipYLen := EndY-StartY+1;
    End;  { SaveClip }


  Procedure ClipPicture;

    Var
      BoxHidden : Array[1..320*2+198*2] Of Byte;


    Procedure DrawBox ( StartX, StartY, EndX, EndY : Integer );

      Var BoxCnt,Count : Integer;

      Begin { DrawBox }
        LowToHigh(StartX,EndX);
        LowToHigh(StartY,EndY);

        {* Store what box touches *}

        Move(Mem[VideoSeg:StartY*320+StartX],BoxHidden,EndX-StartX+1);
        BoxCnt := EndX-StartX+2;
        For Count := StartY+1 To EndY-1 Do
          Begin
            BoxHidden[BoxCnt] := Mem[VideoSeg:Count*320+StartX];
            BoxHidden[BoxCnt+1] := Mem[VideoSeg:Count*320+EndX];
            BoxCnt := BoxCnt + 2;
          End;
        Move(Mem[VideoSeg:EndY*320+StartX],BoxHidden[BoxCnt],EndX-StartX+1);

        {* Draw Box *}

        FillChar(Mem[VideoSeg:StartY*320+StartX],EndX-StartX+1,Chr(PointerValue));
        For Count := StartY+1 To EndY-1 Do
          Begin
            Mem[VideoSeg:Count*320+StartX] := PointerValue;
            Mem[VideoSeg:Count*320+EndX] := PointerValue;
          End;
        FillChar(Mem[VideoSeg:EndY*320+StartX],EndX-StartX+1,Chr(PointerValue));

      End;  { DrawBox }


    Procedure RestoreBoxHidden ( StartX, StartY, EndX, EndY : Integer );

      Var Count,BoxCnt : Integer;

      Begin { RemoveBoxHidden }
        LowToHigh(StartX,EndX);
        LowToHigh(StartY,EndY);

        {* Restore what was in the box *}

        Move(BoxHidden,Mem[VideoSeg:StartY*320+StartX],EndX-StartX+1);
        BoxCnt := EndX-StartX+2;
        For Count := StartY+1 To EndY-1 Do
          Begin
            Mem[VideoSeg:Count*320+StartX] := BoxHidden[BoxCnt];
            Mem[VideoSeg:Count*320+EndX] := BoxHidden[BoxCnt+1];
            BoxCnt := BoxCnt + 2;
          End;
        Move(BoxHidden[BoxCnt],Mem[VideoSeg:EndY*320+StartX],EndX-StartX+1);
      End;  { RemoveBoxHidden }


    Var
      Key : Char;
      TopActive,
      ClipDone : Boolean;
      TopXPos,
      TopYPos,
      CursorXPos,
      CursorYPos  : Integer;
      CursorHidden : Byte;

    Begin { ClipPicture }
      TopActive := False;
      CursorXPos := 0;
      CursorYPos := 0;
      ClipDone := False;
      Repeat
        CursorHidden := Mem[VideoSeg:CursorXPos+CursorYPos*320];
        Mem[VideoSeg:CursorXPos+CursorYPos*320] := PointerValue;
        Repeat Until Keypressed;
        Key := ReadKey;
        Mem[VideoSeg:CursorXPos+CursorYPos*320] := CursorHidden;
        If TopActive
          Then RestoreBoxHidden(TopXPos,TopYPos,CursorXPos,CursorYPos);
        If Ord(Key) = 0
          Then Begin
            Case Ord(ReadKey) Of
{Left}        75  : If CursorXPos > 0 Then Dec(CursorXPos);
{Right}       77  : If CursorXPos < 319 Then Inc(CursorXPos);
{Up}          72  : If CursorYPos > 0 Then Dec(CursorYPos);
{Down}        80  : If CursorYPos < 199 Then Inc(CursorYPos);
            End;
            If TopActive Then DrawBox(TopXPos,TopYPos,CursorXPos,CursorYPos);
          End
          Else Case Upcase(Key) Of
            'T' : If TopActive
                    Then TopActive := False
                    Else Begin
                      TopActive := True;
                      TopXPos := CursorXPos;
                      TopYPos := CursorYPos;
                      DrawBox(TopXPos,TopYPos,CursorXPos,CursorYPos);
                    End;
            'B' : If TopActive
                    Then Begin
                      SaveClip(TopXPos,TopYPos,CursorXPos,CursorYPos);
                      ClipDone := True;
                    End;
            ' ' : If TopActive Then TopActive := False;
            'Q' : Begin
                    VideoMode(3);
                    Halt(1);
                  End;
          End;
      Until ClipDone;
    End;  { ClipPicture }


  Function LeftJustify ( AnyStr : String;  MaxSpaces : Integer ) : String;

    Var
      Count : Integer;
      TempStr : String;

    Begin { LeftJustify }
      TempStr := AnyStr;
      If Length(AnyStr) < MaxSpaces
        Then For Count := 1 To MaxSpaces-Length(AnyStr) Do
          TempStr := TempStr + ' ';
      LeftJustify := TempStr;
    End;  { LeftJustify }


  Procedure FixColorValues;

    Type

      ModifyRec = Record
        ColorFrom,
        ColorTo,
        Red,
        Green,
        Blue    : Byte;
      End;


    Var

      ColorModify : Array[1..256] Of ModifyRec;
      NumColors : Integer;
      Assembly : Boolean;
      StartColor : Byte;
      DoStartColor : Boolean;
      PicFN : String;
      PicFile : Text;
      StoredCnt : Integer;
      PicName : String;


    Procedure PascalOrAssembly;

      Var
        Response : Char;

      Begin { PascalOrAssembly }
        Writeln;
        Response := ' ';
        Repeat
          Write('Write into [A]ssembly or [P]ascal format? ');
          Readln(Response);
        Until Upcase(Response) In ['A','P'];
        Assembly := Upcase(Response) = 'A';
        Writeln;
        Writeln;
      End;  { PascalOrAssembly }


    Procedure GetStartingColor;

      Var
        Response : Char;

      Begin { GetStartingColor }
        Writeln;
        Writeln;
        Writeln('Automatically incrementing the color values will compact the');
        Writeln('palette table.  You may also choose to manually enter in the');
        Writeln('color value.');
        Writeln;
        Repeat
          Writeln('Do you want to [A]utomatically modify the table or [M]anually');
          Write('enter in your own values? ');
          Readln(Response);
        Until Upcase(Response) In ['A','M'];
        DoStartColor := Upcase(Response) = 'A';
        If DoStartColor
          Then Begin
            Write('Enter in the starting value to increment from: ');
            Readln(StartColor);
          End;
      End;  { GetStartingColor }


    Function AlreadyModified ( InB : Byte ) : Boolean;

      Var
        Count : Integer;

      Begin { AlreadyModified }
        AlreadyModified := False;
        For Count := 1 To NumColors Do
          If InB = ColorModify[Count].ColorFrom
            Then AlreadyModified := True;
      End;  { AlreadyModified }


    Function Modified ( InB : Byte ) : Byte;

      Var
        Count : Integer;

      Begin { Modified }
        For Count := 1 To NumColors Do
          If InB = ColorModify[Count].ColorFrom
            Then Modified := ColorModify[Count].ColorTo;
      End;  { Modified }


    Procedure Modify ( InB : Byte );

      Begin { Modify }
        NumColors := NumColors + 1;
        ColorModify[NumColors].ColorFrom := InB;
        ColorModify[NumColors].Red := PicPal[InB*3+1];
        ColorModify[NumColors].Green := PicPal[InB*3+2];
        ColorModify[NumColors].Blue := PicPal[InB*3+3];
        If DoStartColor
          Then ColorModify[NumColors].ColorTo := NumColors+StartColor-1
          Else With ColorModify[NumColors] Do
            Begin
              Write(ColorFrom:4,' [',Red:2,',',Green:2,',',Blue:2,']  -->  ');
              Readln(ColorTo);
            End;
      End;  { Modify }


    Procedure InitTextFile;

      Begin { InitTextFile }
        Write('Enter filename and extension to store text: ');
        ReadLn(PicFN);
        Assign(PicFile,PicFN);
        ReWrite(PicFile);
        If Assembly
          Then Begin
            Writeln(PicFile,'; Picture dimensions');
            Writeln(PicFile,LeftJustify(PicName+'_XLen',16),'EQU     ',ClipXLen,'d');
            Writeln(PicFile,LeftJustify(PicName+'_YLen',16),'EQU     ',ClipYLen,'d');
            Writeln(PicFile);
            Writeln(PicFile,LeftJustify(PicName+'_Pic',16),'LABEL   BYTE');
          End
          Else Begin
            Writeln(PicFile,'{* Picture dimensions *}');
            Writeln(PicFile,LeftJustify(PicName+'_XLen',14),'=       ',ClipXLen,';');
            Writeln(PicFile,LeftJustify(PicName+'_YLen',14),'=       ',ClipYLen,';');
            Writeln(PicFile);
            Writeln(PicFile,PicName+'_Pic : Array[1..',ClipXLen,'*',ClipYLen,'] Of Byte = (');
          End;
      End;  { InitTextFile }


    Procedure StoreByteToPicFile (InB : Byte; EndOfFile: Boolean);

      Begin { StorePicToFile }
        If StoredCnt = 0
          Then If Assembly
            Then Write(PicFile,'                DB      ',InB:3)
            Else Write(PicFile,'        ',InB:3)
          Else Write(PicFile,',',InB:3);
        Inc(StoredCnt);
        If StoredCnt > 12
          Then Begin
            If Assembly
              Then Writeln(PicFile)
              Else If Not EndOfFile Then Writeln(PicFile,',');
            StoredCnt := 0;
          End;
      End;  { StorePicToFile }


    Procedure FinishPicFile;

      Begin { FinishPicFile }
        If Assembly
          Then Writeln(PicFile)
          Else Writeln(PicFile,');');
        Writeln(PicFile);
        Writeln(PicFile);
      End;  { FinishPicFile }


    Procedure StorePicToFile;

      Var
        InByte : Byte;
        CountX,CountY : Integer;

      Begin { StorePicToFile }
        If DoStartColor
          Then Write('Storing picture');
        NumColors := 0;
        Assign(ByteFile,'CLIPPIC.DAT');
        Reset(ByteFile);
        For CountY := 1 To ClipYLen Do
          Begin
            For CountX := 1 To ClipXLen Do
              Begin
                Read(ByteFile,InByte);
                If Not AlreadyModified(InByte)
                  Then Modify(InByte);
                StoreByteToPicFile(Modified(InByte),(CountY = ClipYLen) And (CountX = ClipXLen));
              End;
            If DoStartColor Then Write('.');
          End;
        Close(ByteFile);
        FinishPicFile;
      End;  { StorePicToFile }



    Procedure StorePalToFile;

      Var
        Count : Integer;

      Begin { StorePalToFile }
        Writeln;
        Write('Storing palette');
        If Assembly
          Then Begin
            Writeln(PicFile,LeftJustify(PicName+'_NumColors',16),'EQU     ',NumColors,'d');
            Writeln(PicFile);
            Writeln(PicFile,LeftJustify(PicName+'_Pal',16),'LABEL   BYTE')
          End
          Else Begin
            Writeln(PicFile,LeftJustify(PicName+'_NumColors',14),'= ',NumColors,';');
            Writeln(PicFile);
            Writeln(PicFile,PicName+'_Pal : Array[1..',NumColors,'*4] Of Byte = (');
          End;
        For Count := 1 To NumColors Do
          With ColorModify[Count] Do
            Begin
              If Assembly
                Then Writeln(PicFile,'                DB      ',ColorTo:3,',',Red:3,',',Green:3,',',Blue:3)
                Else Write(PicFile,'        ',ColorTo:3,',',Red:3,',',Green:3,',',Blue:3);
              If (Not Assembly) And (Count <> NumColors)
                Then Writeln(PicFile,',');
              Write('.');
            End;
        If Not Assembly Then Writeln(PicFile,');');
      End;  { StorePalToFile }



    Begin { FixColorValues }
      StoredCnt := 0;
      VideoMode($03);
      Writeln('Clipped picture X length = ',ClipXLen);
      Writeln('Clipped picture Y length = ',ClipYLen);
      PascalOrAssembly;
      GetStartingColor;
      Write('Enter the picture label: ');
      Readln(PicName);
      InitTextFile;
      StorePicToFile;
      StorePalToFile;
      Close(PicFile);
    End;  { FixColorValues }


  Begin { Clip_Picture }
    Write('Enter picture filename and extension: ');
    Readln(PictureFN);
    Assign(PictureFile,PictureFN);
    Reset(PictureFile);
    GetPointerAttrib;
    VideoMode($13);
    LoadPicture;
    ClipPicture;
    FixColorValues;
    Writeln;
    Writeln('Done!');
  End.  { Clip_Picture }
