home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 015 / fqueue.arc / TCOLOR.ARC / TCOLOR.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1986-02-11  |  13.0 KB  |  538 lines
  1. { TurboCOLOR - Changes color of TURBO editor or any TURBO program.
  2.   Copyright 1986 by Scott Reedstrom.
  3.   Released into the public domain for non-commercial use.
  4.   This program may be freely distributed.
  5.   If you find this program usesfull, a $5.00 donation would be appreciated.
  6.   Please send to
  7.      SAR Designs
  8.      774 Doris Ave.
  9.      Shoreview, MN 55126 }
  10.  
  11. const
  12.   esc     = #27 ;
  13.   sbar    =  25 ;
  14.   BufSize = 100 ;
  15.  
  16. type
  17.   Block   = array [0..127] of byte ;
  18.   str10   = string[10] ;
  19.   MonType = (Col,Mono,BW,Unknown) ;
  20.  
  21. var
  22.   TName      : string[30] ;
  23.   ScreenType : MonType ;
  24.   Monitor    : MonType ;
  25.   TurbFile   : file ;
  26.   TurbOut    : file ;
  27.   Header     : Block ;
  28.   Blocks     : array [1..BufSize] of Block ;
  29.   err        : integer ;
  30.   Color      : array[0..5] of integer ;
  31.   ColorBar   : integer ;
  32.  
  33. procedure ToHome ;
  34. begin
  35.   Gotoxy(1,1) ;
  36.   TextColor(White) ;
  37.   TextBackground(Black) ;
  38. end ;
  39.  
  40. procedure InitTurbo ;
  41. begin
  42.   Assign(TurbFile,TName) ;
  43.   {$I-}
  44.   Reset(TurbFile) ;
  45.   {$I+}
  46.   if IOresult <> 0 then
  47.   begin
  48.     writeln('Can''t find file ',TName) ;
  49.     Writeln('  Proper syntax is ');
  50.     Writeln('       TCOLOR [filename.COM]');
  51.     Writeln(' If the filename not provided, it defaults to TURBO.COM.');
  52.     Halt ;
  53.   end ;
  54.   BlockRead(TurbFile,Header,1) ;
  55. end ;
  56.  
  57. function Attr(n:integer):integer ;
  58. var
  59.   fg,bg : integer ;
  60. begin
  61.   case (n div 2) of
  62.     0 : begin fg := 00 ; bg := 00 ; end ;  { blank }
  63.     1 : begin fg := 07 ; bg := 00 ; end ;  { normal display }
  64.     2 : begin fg := 01 ; bg := 00 ; end ;  { underlined }
  65.     3 : begin fg := 00 ; bg := 07 ; end ;  { reverse video }
  66.     4 : begin fg := 08 ; bg := 00 ; end ;  { bright blank }
  67.     5 : begin fg := 15 ; bg := 00 ; end ;  { bright }
  68.     6 : begin fg := 09 ; bg := 00 ; end ;  { bright & underlined }
  69.     7 : begin fg := 08 ; bg := 07 ; end ;  { bright & reversed }
  70.   end {case} ;
  71.   attr := fg + 16*bg ;
  72. end ;
  73.  
  74. function ColAttr(n:integer):integer ;
  75. var
  76.   i,tmp : integer ;
  77. begin
  78.   tmp := 1 ;
  79.   for i := 15 downto 0 do
  80.     if Attr(i)=n then tmp:=i ;
  81.   ColAttr := tmp ;
  82. end ;
  83.  
  84. function Mon(n:integer):MonType ;
  85. begin
  86.   case n of
  87.     0 : Mon := BW ;
  88.     1 : Mon := Col ;
  89.     2 : Mon := BW ;
  90.     3 : Mon := Col ;
  91.     4 : Mon := Col ;
  92.     5 : Mon := Col ;
  93.     6 : Mon := Col ;
  94.     7 : Mon := Mono  ;
  95.   else  Mon := Unknown ;
  96.   end ;
  97. end ;
  98.  
  99. function MonByte:byte ;
  100. type
  101.   regtype = record ax,bx,cx,dx,bp,si,di,ds,es,flags:integer ; end ;
  102. var
  103.   reg : regtype ;
  104. begin
  105.   Reg.AX := $0F00 ;
  106.   Intr($10,Reg) ;
  107.   MonByte := Lo(Reg.Ax) ;
  108. end ;
  109.  
  110. procedure InitColors ;
  111. var
  112.   i : integer ;
  113.   c : char ;
  114. begin
  115.   ScreenType := Mon(MonByte) ;
  116.   if ScreenType = Mono then             { Monochrome screen }
  117.   begin
  118.     Writeln('Monochrome Monitor with a Monochrome Card');
  119.     Color[0] := ColAttr(Header[$6F]) ;
  120.     Color[1] := ColAttr(Header[$70]) ;
  121.     Color[2] := ColAttr(Header[$71]) ;
  122.   end ;
  123.   if ScreenType=BW then  { Color card with B/W monitor }
  124.   begin
  125.     Writeln('Monochrome Monitor with a Color Card');
  126.     Color[0] := Header[$73] and 15 ;
  127.     Color[1] := Header[$73] shr 4  ;
  128.     Color[2] := Header[$74] and 15 ;
  129.     Color[3] := Header[$74] shr 4  ;
  130.     Color[4] := Header[$75] and 15 ;
  131.     Color[5] := Header[$75] shr 4  ;
  132.   end ;
  133.   if ScreenType=Col then   { Color card with Color Monitor }
  134.   begin
  135.     Writeln('Color Monitor');
  136.     Color[0] := Header[$77] and 15 ;
  137.     Color[1] := Header[$77] shr 4  ;
  138.     Color[2] := Header[$78] and 15 ;
  139.     Color[3] := Header[$78] shr 4  ;
  140.     Color[4] := Header[$79] and 15 ;
  141.     Color[5] := Header[$79] shr 4  ;
  142.   end ;
  143.   delay(2000) ;
  144. end ;
  145.  
  146. procedure GotoBar(Bar,Colr:integer) ;
  147. var
  148.   x,y : integer ;
  149. begin
  150.   x := Colr*3+sbar+1 ;
  151.   if ScreenType=Mono then x := x+1 ;
  152.   y := 13+(bar*2) ;
  153.   gotoxy(x,y) ;
  154.   TextColor(White) ;
  155.   TextBackground(Black) ;
  156. end ;
  157.  
  158. procedure DrawText ;
  159. begin
  160.   TextColor(Color[0]) ;
  161.   TextBackground(Color[1]) ;
  162.   if ScreenType=Mono then
  163.   begin
  164.     TextColor(Attr(Color[0]) and 15);
  165.     TextBackground(Attr(Color[0]) shr 4);
  166.   end ;
  167.   GotoXY(1,2) ;
  168.   ClrEol;Writeln('Begin') ;
  169.   ClrEol;Writeln('  This is the color/attributes of normal text. ') ;
  170.   ClrEol;Writeln('  This is the color/attributes of ') ;
  171.   ClrEol;Writeln('    normal, source code text. ') ;
  172.   GotoXY(1,9) ;
  173.   ClrEol;Writeln('  This is the color/attributes of normal text. ') ;
  174.   ClrEol;Writeln('End ;') ;
  175. end ;
  176.  
  177. procedure DrawInfo ;
  178. begin
  179.   TextColor(Color[2]) ;
  180.   TextBackground(Color[3]) ;
  181.   if ScreenType=Mono then
  182.   begin
  183.     TextColor(Attr(Color[1]) and 15);
  184.     TextBackground(Attr(Color[1]) shr 4) ;
  185.   end ;
  186.   GotoXY(1,1) ;
  187.   ClrEol;Writeln('  This is the color/attributes of the dim info line across the top of the screen');
  188. end ;
  189.  
  190. procedure DrawHighl ;
  191. begin
  192.   TextColor(Color[4]) ;
  193.   TextBackground(Color[5]) ;
  194.   if ScreenType=Mono then
  195.   begin
  196.     TextColor(Attr(Color[2]) and 15) ;
  197.     TextBackground(Attr(Color[2]) shr 4) ;
  198.   end ;
  199.   GotoXY(1,6) ;
  200.   ClrEol;Writeln('  This is the color/attributes of highlighted text. ') ;
  201.   ClrEol;Writeln('  This is the color/attributes of ') ;
  202.   ClrEol;Writeln('    highlighted source code text. ') ;
  203. end ;
  204.  
  205. procedure DrawBar(b:integer) ;
  206. var
  207.     i        : integer ;
  208.     fb,fg,bg : integer ;
  209. begin
  210.   for i := 0 to 15 do
  211.   begin
  212.     if ScreenType=Mono then
  213.     begin
  214.       fb := attr(i) ;
  215.       fg := fb and 15 ;
  216.       bg := fb shr 4 ;
  217.       TextColor(fg) ;
  218.       TextBackground(bg) ;
  219.       case (i mod 2) of
  220.         0 : write('-AB');
  221.         1 : write('C--');
  222.       end ;
  223.     end
  224.     else
  225.     begin
  226.       TextColor(i) ;
  227.       Write(#219,#219,#219) ;
  228.     end ;
  229.   end ;
  230. end ;
  231.  
  232. procedure DrawColors ;
  233. var
  234.   b : integer ;
  235. begin
  236.   Gotoxy(sbar-1,11) ;
  237.   TextColor(White) ;
  238.   TextBackground(Black) ;
  239.   Write('╔═════════════════════════════════════════════════╗');
  240.   for b := 0 to 5 do
  241.   begin
  242.     gotoxy(1,12+2*b) ;
  243.     TextColor(White) ;
  244.     TextBackground(Black) ;
  245.     if ScreenType = Mono then
  246.     begin
  247.       if b<3 then
  248.       begin
  249.         case b of
  250.           0 : Write('Normal Text Attr') ;
  251.           1 : Write('Dim Text Attributes') ;
  252.           2 : Write('Highlighted Text Attr') ;
  253.         end {case} ;
  254.         gotoxy(sbar,12+2*b) ;
  255.         DrawBar(b) ;
  256.         GotoBar(b,Color[b]) ;
  257.         Write(#04) ;
  258.       end ;
  259.     end
  260.     else
  261.     begin
  262.       case b of
  263.         0 : Write('Normal Text Color') ;
  264.         1 : Write('Normal Background') ;
  265.         2 : Write('Dim Text Color') ;
  266.         3 : Write('Dim Text Background') ;
  267.         4 : Write('Highlighted Text Color') ;
  268.         5 : Write('Highlighted Text Backg') ;
  269.       end ;
  270.       gotoxy(sbar,12+2*b) ;
  271.       DrawBar(b) ;
  272.       GotoBar(b,Color[b]) ;
  273.       Write(#04) ;
  274.     end ;
  275.     GotoXY(sbar-1,12+2*b) ; Write('║') ;
  276.     GotoXY(sbar-1,13+2*b) ; Write('║') ;
  277.     GotoXY(sbar+49,12+2*b) ; Write('║') ;
  278.     GotoXY(sbar+49,13+2*b) ; Write('║') ;
  279.   end ;
  280.   GotoXY(sbar-1,24);
  281.   Write('╚═════════════════════════════════════════════════╝');
  282. end ;
  283.  
  284. procedure SetColor ;
  285. begin
  286.   if ScreenType=Mono then
  287.   begin
  288.     case ColorBar of
  289.       0 : DrawText ;
  290.       1 : DrawInfo ;
  291.       2 : DrawHighl ;
  292.     end {case} ;
  293.     ToHome ;
  294.   end
  295.   else
  296.   begin
  297.     case ColorBar of
  298.       0 : DrawText ;
  299.       1 : DrawText ;
  300.       2 : DrawInfo ;
  301.       3 : DrawInfo ;
  302.       4 : DrawHighl ;
  303.       5 : DrawHighl ;
  304.     end {case} ;
  305.     ToHome ;
  306.    end ;
  307. end ;
  308.  
  309. procedure DnColor ;
  310. var
  311.   MaxBar : integer ;
  312. begin
  313.   MaxBar := 5 ;
  314.   if (ScreenType=Mono) then MaxBar := 2 ;
  315.   GotoBar(ColorBar,Color[ColorBar]) ;
  316.   Write(#04) ;
  317.   ColorBar := (ColorBar+1) ;
  318.   if Colorbar > MaxBar then ColorBar := 0 ;
  319.   if COlorBar < 0 then ColorBar := MaxBar ;
  320.   GotoBar(ColorBar,Color[ColorBar]) ;
  321.   TextColor(White+blink) ;
  322.   Write(#24) ;
  323.   ToHome ;
  324. end ;
  325.  
  326. procedure UpColor ;
  327. var
  328.   MaxBar : integer ;
  329. begin
  330.   MaxBar := 5 ;
  331.   if (ScreenType=Mono) then MaxBar := 2 ;
  332.   GotoBar(ColorBar,Color[ColorBar]) ;
  333.   Write(#04) ;
  334.   ColorBar := (ColorBar-1) ;
  335.   if Colorbar > MaxBar then ColorBar := 0 ;
  336.   if COlorBar < 0 then ColorBar := MaxBar ;
  337.   GotoBar(ColorBar,Color[ColorBar]) ;
  338.   TextColor(White+blink) ;
  339.   Write(#24) ;
  340.   ToHome ;
  341. end ;
  342.  
  343. procedure RtColor ;
  344. begin
  345.   GotoBar(ColorBar,Color[ColorBar]) ;
  346.   Write(' ') ;
  347.   Color[ColorBar] := Color[ColorBar] + 1 ;
  348.   if ScreenType=Mono then Color[ColorBar] := Color[ColorBar]+1 ;
  349.   if Color[COlorBar] > 15 then Color[ColorBar] := 0 ;
  350.   if Odd(ColorBar) and (Color[ColorBar] > 7) and not(ScreenType=Mono)
  351.     then Color[ColorBar] := 0 ;
  352.   GotoBar(ColorBar,Color[ColorBar]) ;
  353.   TextColor(White+blink) ;
  354.   Write(#24) ;
  355.   SetColor ;
  356. end ;
  357.  
  358. procedure LfColor ;
  359. begin
  360.   GotoBar(ColorBar,Color[ColorBar]) ;
  361.   Write(' ') ;
  362.   Color[ColorBar] := Color[ColorBar] - 1 ;
  363.   if (ScreenType=Mono) then Color[ColorBar] := Color[ColorBar]-1 ;
  364.   if Odd(ColorBar) and (Color[ColorBar] < 0) and not(ScreenType=Mono)
  365.     then Color[ColorBar] := 7 ;
  366.   if Color[ColorBar] < 0 then Color[ColorBar] := 15 ;
  367.   GotoBar(ColorBar,Color[ColorBar]) ;
  368.   TextColor(White+blink) ;
  369.   Write(#24) ;
  370.   SetColor ;
  371. end ;
  372.  
  373. procedure DrawScreen ;
  374. begin
  375.   TextColor(white) ;
  376.   TextBackground(black) ;
  377.   ClrScr ;
  378.   DrawInfo ;
  379.   DrawText ;
  380.   DrawHighl ;
  381.   DrawColors ;
  382.   ColorBar := 1 ;
  383.   UpColor ;
  384.   Gotoxy(1,25) ;
  385.   TextColor(White) ;
  386.   TextBackground(red) ;
  387.   ClrEol ;
  388.   Write('              Use cursor keys to move arrows - press [ESC] to end');
  389.   TOHome ;
  390. end ;
  391.  
  392. procedure ChangeHeader ;
  393. var
  394.   Message : string[30] ;
  395.   i : integer ;
  396. begin
  397.   case ScreenType of
  398.     Mono  : begin
  399.               Header[$6F] := Attr(Color[0]) ;
  400.               Header[$70] := Attr(Color[1]) ;
  401.               Header[$71] := Attr(Color[2]) ;
  402.               Message := 'Customized Mono' ;
  403.             end ;
  404.     BW    : begin
  405.               Header[$73] := Color[0] or (Color[1] shl 4) ;
  406.               Header[$74] := Color[2] or (Color[3] shl 4) ;
  407.               Header[$75] := Color[4] or (Color[5] shl 4) ;
  408.               Message := 'Customized B/W' ;
  409.             end ;
  410.     Col : begin
  411.               Header[$77] := Color[0] or (Color[1] shl 4) ;
  412.               Header[$78] := Color[2] or (Color[3] shl 4) ;
  413.               Header[$79] := Color[4] or (Color[5] shl 4) ;
  414.               Message := 'Customized Color' ;
  415.             end ;
  416.   end ;
  417.   Header[$6D] := $FF ;  { always make actual program default monitor }
  418.   for i := 0 to length(Message) do Header[$55+i] := ord(Message[i]) ;
  419. end ;
  420.  
  421. procedure SaveTurbo ;
  422. var
  423.   RecRead : integer ;
  424. begin
  425.   Write(' - Changing ',TName) ;
  426.   Assign(TurbOut ,'Colored.$$$') ;
  427.   {$I-}
  428.   Rewrite(TurbOut ) ;
  429.   {$I+}
  430.   if IOResult<>0 then
  431.   begin
  432.     Write('Not enough room on disk.  No changes made.');
  433.     Halt ;
  434.   end ;
  435.   Reset(TurbFile) ;
  436.   ChangeHeader ;
  437.   BlockWrite(TurbOut,Header,1) ;
  438.   BlockRead(TurbFile,blocks,1) ;
  439.   repeat
  440.     BlockRead(TurbFile,Blocks,BufSize,RecRead) ;
  441.     BlockWrite(TurbOut,BLocks,RecRead) ;
  442.   until RecRead=0 ;
  443.   close(TurbFile) ;
  444.   close(TurbOut) ;
  445.   {$I-}
  446.   Reset(TurbOut) ;
  447.   {$I+}
  448.   if IOresult=0 then {Good copy}
  449.   begin
  450.     close(TurbOut) ;
  451.     erase(TurbFile) ;
  452.     rename(TurbOut,TName) ;
  453.   end ;
  454. end ;
  455.  
  456. function AreYouSure : boolean ;
  457. var
  458.   c : char ;
  459. begin
  460.   TextColor(White) ;
  461.   TextBackground(red) ;
  462.   gotoXY(1,25);
  463.   ClrEol ;
  464.   Write('  Are you sure you want to leave? ') ;
  465.   read(kbd,c) ;
  466.   write(Upcase(c)) ;
  467.   if UpCase(c) = 'Y' then
  468.   begin
  469.     AreYouSure := true ;
  470.     GotoXY(1,25) ;
  471.     ClrEol ;
  472.     Write('  Want to make changes permanent? ') ;
  473.     read(kbd,c) ;
  474.     write(Upcase(c)) ;
  475.     if UpCase(c) = 'Y' then SaveTurbo ;
  476.   end
  477.   else
  478.   begin
  479.     AreYouSure := false ;
  480.     GotoXY(1,25) ; CLrEol ;
  481.     Write('              Use cursor keys to move arrows - press [ESC] to end');
  482.   end ;
  483.   ToHome ;
  484. end ;
  485.  
  486. procedure ChngColor ;
  487. var
  488.   EndChng : boolean ;
  489.   c : char ;
  490. begin
  491.   DrawScreen ;
  492.   EndChng := false ;
  493.   repeat
  494.     read(kbd,c) ;
  495.     if c=esc then
  496.     begin
  497.       if keypressed then
  498.       begin
  499.         read(kbd,c) ;
  500.         case c of
  501.           #72 : UpColor ;
  502.           #80 : DnColor ;
  503.           #75 : LfColor ;
  504.           #77 : RtColor ;
  505.         end {case} ;
  506.       end
  507.       else if AreYouSure then EndChng := true ;
  508.     end
  509.   until EndChng ;
  510. end ;
  511.  
  512. Procedure WriteBeg ;
  513. var
  514.   c : char ;
  515. Begin
  516.   ClrScr ;
  517.   Writeln(' TurboCOLOR - Changes color of TURBO editor or any TURBO program. ');
  518.   Writeln('   Copyright 1986 by Scott Reedstrom.');
  519.   Writeln('   Released into the public domain for non-commercial use.');
  520.   Writeln('   This program may be freely distributed without charge.');
  521.   Writeln('   If you find this program usesfull, a $5.00 donation would be appreciated.');
  522.   Writeln('   Please send to');
  523.   Writeln('      SAR Designs');
  524.   Writeln('      774 Doris Ave.');
  525.   Writeln('      Shoreview, MN 55126');
  526.   Writeln ;
  527.   Writeln('   Press any key to continue ... ');
  528.   read(kbd,c) ;
  529. end ;
  530.  
  531.  
  532. Begin
  533.   if ParamCount=0 then TName := 'TURBO.COM' else TName := ParamStr(1) ;
  534.   InitTurbo ;
  535.   InitColors ;
  536.   ChngColor ;
  537.   ClrScr ;
  538. end .