home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / progm / tptools.zip / EDINST.ZIP / EDISCRN.INC < prev    next >
Text File  |  1987-12-21  |  12KB  |  358 lines
  1. {                          EDISCRN.INC
  2.                            EDINST 4.0
  3.              Copyright (c) 1985, 87 by Borland International, Inc.            }
  4.  
  5.   procedure ScreenInstall;
  6.     {-Customize FirstEd's screen.}
  7.   var
  8.     Ch : Char;
  9.     ScreenOfs : LongInt;
  10.  
  11.     function SnowTest : Boolean;
  12.       {-Return true if snow is detected}
  13.     const
  14.       YesOrNo : array[Boolean] of Char = ('N', 'Y');
  15.     var
  16.       Ch : Char;
  17.       I : Integer;
  18.     begin                    {SnowTest}
  19.       Ch := YesOrNo[RetraceMode];
  20.       RetraceMode := False;
  21.       Write('Press any key to begin snow test...');
  22.       while ReadKey = #0 do
  23.         ;
  24.       for I := 1 to 4000 do
  25.         EdFastWrite(' ', 1, 80, LoColor);
  26.       WriteLn;
  27.       RetraceMode := YesNo('Did you see any "snow" on your display?', Ch);
  28.       SnowTest := RetraceMode;
  29.     end;                     {SnowTest}
  30.  
  31.     procedure InstallColors(var AA : AttributeArray);
  32.       {-Install default colors}
  33.       {Note: This routine is designed to be easily incorporated into
  34.        other installation programs for editors based on the Toolbox,
  35.        including MSINST. Only two changes need to be made if more than four
  36.        video attributes are used: (1) FarTopRow and FarBotRow need to be
  37.        adjusted, and (2) the AttrsUsed set needs to be modified accordingly.
  38.        For example, if the block cursor attribute is also used, FarBotRow
  39.        can be increased by 1, and CursorColor would be added to the set.
  40.        If all defined attributes are used, as they are in MicroStar, the
  41.        box on the right (Far) side of the screen will be the same height
  42.        as that on the left side.}
  43.     const
  44.       {if the asterisk is changed to another character, the BoxCharArray
  45.        in DrawAttributeBox must also be changed}
  46.       Choice : string[3] = ' * ';
  47.  
  48.       {Attributes used by FirstEd. For Microstar, use [TxtColor..Alt2Color]}
  49.       AttrsUsed : set of ColorType = [TxtColor..CmdColor];
  50.  
  51.       {box on left}          {box on right (Far side)}
  52.       TopRow = 2; FarTopRow = 8; {for MicroStar, these would be equal}
  53.       BotRow = 21; FarBotRow = 15; {so would these}
  54.       LeftCol = 5; FarLeftCol = 38;
  55.       RtCol = 33; FarRtCol = 76;
  56.  
  57.       {prompt box on the bottom -- also defined by LeftCol and FarRtCol}
  58.       TopPrompt = 23;
  59.       BotPrompt = 25;
  60.  
  61.       {prompts}
  62.       MainPrompt : string[57] =
  63.       'Use  to move highlight, ┘ to select, <Esc> to continue';
  64.       MakeSelectionPrompt =
  65.       'Use '^Z' to move highlight, ┘ to select, <Esc> to cancel';
  66.       AnyKey = 'Press any key to continue...';
  67.       HereIs : string[37] = ' Here is a sample of this attribute. ';
  68.  
  69.     var
  70.       Ch : Char;
  71.       CT, OldCT : ColorType;
  72.       WAA : AttributeArray;
  73.       Row, Col, Attr : Byte;
  74.       Done : Boolean;
  75.       BoxColorArray : array[3..20 {row} , 6..32 {col} ] of Byte;
  76.  
  77.       procedure Prompt(Message : string);
  78.         {-Show message centered in prompt box}
  79.       var
  80.         Width, Col : Byte;
  81.       begin
  82.         Width := Pred(FarRtCol-LeftCol);
  83.         BlankLine[0] := Chr(Width);
  84.         EdFastWrite(BlankLine, Succ(TopPrompt), Succ(LeftCol), LoColor);
  85.         Col := Succ(LeftCol)+((Width-Length(Message)) shr 1);
  86.         EdFastWrite(Message, Succ(TopPrompt), Col, LoColor);
  87.       end;
  88.  
  89.       procedure CalcRowCol(Attr : Byte; var Row, Col : Byte);
  90.         {-Calculate the row and column for an attribute}
  91.       begin
  92.         {calculate row}
  93.         Row := (TopRow+2)+(Attr and $F);
  94.         {calculate column}
  95.         Col := (LeftCol+2)+(3*(Attr div 16));
  96.       end;
  97.  
  98.       procedure DrawChart;
  99.         {-Draw the color chart and initialize BoxColorArray}
  100.       var
  101.         I : Integer;
  102.         Row, Col, Attr : Byte;
  103.       begin
  104.         FillChar(BoxColorArray, SizeOf(BoxColorArray), TiColor);
  105.         for Attr := 0 to 127 do begin
  106.           CalcRowCol(Attr, Row, Col);
  107.           EdFastWrite(Choice, Row, Col, Attr);
  108.           for I := Col to (Col+2) do
  109.             BoxColorArray[Row, I] := (Attr and $F0)+(TiColor and $F);
  110.         end;
  111.       end;
  112.  
  113.       function ColorName(CType : ColorType) : VarString;
  114.         {-Return a string describing the specified ColorType}
  115.       begin                  {ColorName}
  116.         case CType of
  117.           {the following are used by both FirstEd and MicroStar}
  118.           TxtColor : ColorName := 'Normal text';
  119.           BlockColor : ColorName := 'Marked blocks';
  120.           BordColor : ColorName := 'Window status line';
  121.           CmdColor : ColorName := 'Prompt line';
  122.  
  123.           {the following are not used by FirstEd, only by MicroStar}
  124.           CursorColor : ColorName := 'Block cursor';
  125.           MnColor : ColorName := 'Normal menu';
  126.           MfColor : ColorName := 'Menu frame';
  127.           MsColor : ColorName := 'Selected menu item';
  128.           MhColor : ColorName := 'Highlighted character in menu';
  129.           BoldColor : ColorName := 'Bold attribute';
  130.           DblColor : ColorName := 'Doublestrike attribute';
  131.           UndColor : ColorName := 'Underscore attribute';
  132.           SupColor : ColorName := 'Superscript attribute';
  133.           SubColor : ColorName := 'Subscript attribute';
  134.           Alt1Color : ColorName := 'Compressed attribute';
  135.           Alt2Color : ColorName := 'Italic attribute';
  136.         end;
  137.       end;                   {ColorName}
  138.  
  139.       function WhichRow(CType : ColorType) : Byte;
  140.         {-Given a color type, return the row on which the color name should
  141.          be displayed.}
  142.       var
  143.         CT : ColorType;
  144.         LoopCount : Byte;
  145.       begin                  {WhichRow}
  146.         LoopCount := 0;
  147.         for CT := TxtColor to CType do
  148.           if CT in AttrsUsed then
  149.             Inc(LoopCount);
  150.         WhichRow := FarTopRow+3+Pred(LoopCount);
  151.       end;                   {WhichRow}
  152.  
  153.       procedure ColorSample(Attr : Byte);
  154.         {-Change the attribute of the color sample}
  155.       begin
  156.         EdChangeAttribute(Length(HereIs), Succ(FarTopRow), Succ(FarLeftCol), Attr);
  157.       end;
  158.  
  159.       procedure DrawAttributeBox(Attr, Row, Col : Byte);
  160.         {-Draw special box around current selection}
  161.       const
  162.         BoxCharArray : array[ -1..1, -2..2] of string[1] =
  163.         (('┌', '─', '─', '─', '┐'),
  164.          ('│', ' ', '*', ' ', '│'),
  165.          ('└', '─', '─', '─', '┘'));
  166.       var
  167.         A : Byte;
  168.         I, J, RowDelta, ColDelta : Integer;
  169.       begin
  170.         for RowDelta := -1 to 1 do
  171.           for ColDelta := -2 to 2 do begin
  172.             I := Row+RowDelta;
  173.             J := Col+ColDelta;
  174.             A := BoxColorArray[I, J];
  175.  
  176.             {leave the attribute of ' * ' alone}
  177.             case ColDelta of
  178.               -1..1 : if RowDelta = 0 then
  179.                         A := Attr;
  180.             end;
  181.             EdFastWrite(BoxCharArray[RowDelta, ColDelta], I, J, A);
  182.           end;
  183.       end;
  184.  
  185.       procedure ShowChoice(Attr : Byte; FirstCall : Boolean);
  186.         {-Show the currently selected attribute}
  187.       var
  188.         Row, Col : Byte;
  189.       begin
  190.         {remove the previous box, if any}
  191.         if not FirstCall then
  192.           RestoreWindow(WP, False);
  193.  
  194.         {calculate the row and column for the new one}
  195.         CalcRowCol(Attr, Row, Col);
  196.  
  197.         {save the portion of the window that will be overwritten}
  198.         SaveWindow(WP, Pred(Col), Pred(Row), Col+3, Succ(Row), FirstCall);
  199.  
  200.         {draw the box that marks the current attribute}
  201.         DrawAttributeBox(Attr, Row, Succ(Col));
  202.  
  203.         {change the attribute of the sample string too}
  204.         ColorSample(Attr);
  205.       end;
  206.  
  207.       procedure MakeSelection(var Attr : Byte);
  208.         {-Allow user to select an attribute}
  209.       var
  210.         Done : Boolean;
  211.         A : Byte;
  212.       begin                  {MakeSelection}
  213.         WP := nil;
  214.         Done := False;
  215.         A := Attr;
  216.         ShowChoice(A, True);
  217.         Prompt(MakeSelectionPrompt);
  218.         repeat
  219.           case GetCursorCommand of
  220.             ^M :             {select}
  221.               begin
  222.                 Attr := A;
  223.                 Done := True;
  224.               end;
  225.             ^E, ^W :         {up}
  226.               if (A and $F) = 0 then
  227.                 A := A+15
  228.               else
  229.                 A := Pred(A);
  230.             ^X, ^Z :         {down}
  231.               if (A and $F) = $F then
  232.                 A := A-15
  233.               else
  234.                 A := Succ(A);
  235.             ^S :             {left}
  236.               if A <= 15 then
  237.                 A := A+112
  238.               else
  239.                 A := A-16;
  240.             ^D :             {right}
  241.               if A >= 112 then
  242.                 A := A-112
  243.               else
  244.                 A := A+16;
  245.             Escape : Done := True; {cancel}
  246.           end;
  247.           ShowChoice(A, False);
  248.         until Done;
  249.         RestoreWindow(WP, True);
  250.       end;                   {MakeSelection}
  251.  
  252.       procedure HighlightName(OldCT, CT : ColorType);
  253.         {-Highlight name of current selection}
  254.       var
  255.         N : Integer;
  256.       begin
  257.         {number of attribute bytes to change}
  258.         N := Pred(FarRtCol-FarLeftCol);
  259.  
  260.         {remove highlight from OldCT}
  261.         EdChangeAttribute(N, WhichRow(OldCT), Succ(FarLeftCol), LoColor);
  262.  
  263.         {highlight CT}
  264.         EdChangeAttribute(N, WhichRow(CT), Succ(FarLeftCol), EdColor);
  265.       end;
  266.  
  267.     begin                    {InstallColors}
  268.       {initialize}
  269.       WAA := AA;
  270.       SetColor(TiColor);
  271.       ClrScr;
  272.  
  273.       {hide the cursor}
  274.       EdSetCursor(HiddenCursor);
  275.  
  276.       {draw the choices box}
  277.       MakeBox(LeftCol, TopRow, RtCol, BotRow, TiColor);
  278.       EdFastWrite(' Choices ', TopRow, LeftCol+10, TiColor);
  279.  
  280.       {draw the choices}
  281.       for CT := TxtColor to Alt2Color do
  282.         if CT in AttrsUsed then
  283.           EdFastWrite(ColorName(CT), WhichRow(CT), FarLeftCol+3, LoColor);
  284.  
  285.       {draw the menu box on the right}
  286.       MakeBox(FarLeftCol, FarTopRow, FarRtCol, FarBotRow, TiColor);
  287.       EdFastWrite(' Sample ', FarTopRow, FarLeftCol+15, TiColor);
  288.       EdFastWrite('├──────────── Attributes ─────────────┤', FarTopRow+2,
  289.                   FarLeftCol, TiColor);
  290.       EdFastWrite(HereIs, Succ(FarTopRow), Succ(FarLeftCol), TiColor);
  291.  
  292.       {draw the prompt box}
  293.       MakeBox(LeftCol, TopPrompt, FarRtCol, BotPrompt, TiColor);
  294.       Prompt(MainPrompt);
  295.  
  296.       {get choices}
  297.       CT := TxtColor;
  298.       Done := False;
  299.       DrawChart;
  300.       OldCT := CT;
  301.       repeat
  302.         ColorSample(WAA[CT]);
  303.         HighlightName(OldCT, CT);
  304.         OldCT := CT;
  305.         Ch := GetCursorCommand;
  306.         repeat
  307.           case Ch of
  308.             ^M : begin       {select}
  309.                    MakeSelection(WAA[CT]);
  310.                    Prompt(MainPrompt);
  311.                  end;
  312.             ^E, ^W :         {scroll up}
  313.               if CT = TxtColor then
  314.                 CT := Alt2Color
  315.               else
  316.                 CT := Pred(CT);
  317.             ^X, ^Z :         {scroll down}
  318.               if CT = Alt2Color then
  319.                 CT := TxtColor
  320.               else
  321.                 CT := Succ(CT);
  322.             Escape : Done := True; {done}
  323.           end;
  324.         until (CT in AttrsUsed);
  325.       until Done;
  326.  
  327.       {copy the working array to the actual array}
  328.       AA := WAA;
  329.  
  330.       EdSetCursor(NormalCursor);
  331.     end;                     {InstallColors}
  332.  
  333.   begin                      {ScreenInstall}
  334.  
  335.     {Search for screen installation ID string}
  336.     ScreenOfs := FindString(SIDstring, ScreenDefaults, SizeOf(ScreenDefaults));
  337.     if ScreenOfs = 0 then
  338.       HaltError('Screen defaults ID string not found in '+ProgName);
  339.  
  340.     {install colors}
  341.     with ScreenDefaults do
  342.       if (ScreenAdr = $B800) then begin
  343.         {check for snow first}
  344.         GoodColorCard := SnowTest;
  345.         InstallColors(ColorAttr);
  346.       end
  347.       else
  348.         InstallColors(MonoAttr);
  349.  
  350.     {reset screen color}
  351.     SetColor(LoColor);
  352.  
  353.     {write modified defaults}
  354.     if not ModifyDefaults(ScreenOfs, ScreenDefaults, SizeOf(ScreenDefaults)) then
  355.       HaltError('Error writing screen defaults to '+ProgName);
  356.  
  357.   end;                       {ScreenInstall}
  358.