home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / HTMIX20.ZIP / SE.ZIP / SE.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1992-07-14  |  14.4 KB  |  478 lines
  1. program ScreenEditor;
  2. {┌──────────────────────────────── INFO ────────────────────────────────────┐}
  3. {│ File    : SE.PAS                                                         │}
  4. {│ Author  : Harald Thunem                                                  │}
  5. {│ Purpose : Edit text screens.                                             │}
  6. {│ Updated : July 11 1992                                                   │}
  7. {└──────────────────────────────────────────────────────────────────────────┘}
  8.  
  9. {────────────────────────── Compiler directives ─────────────────────────────}
  10. {$A+   Word align data                                                       }
  11. {$B-   Short-circuit Boolean expression evaluation                           }
  12. {$E-   Disable linking with 8087-emulating run-time library                  }
  13. {$G+   Enable 80286 code generation                                          }
  14. {$R-   Disable generation of range-checking code                             }
  15. {$S-   Disable generation of stack-overflow checking code                    }
  16. {$V-   String variable checking                                              }
  17. {$X-   Disable Turbo Pascal's extended syntax                                }
  18. {$N+   80x87 code generation                                                 }
  19. {$D-   Disable generation of debug information                               }
  20. {────────────────────────────────────────────────────────────────────────────}
  21.  
  22. uses  Dos,
  23.       Screen,
  24.       Common,
  25.       Strings,
  26.       Keyboard;
  27.  
  28. var   DrawChar: char;
  29.       DrawAttr,
  30.       BoxType,
  31.       MainR,
  32.       MainC   : byte;
  33.       Filename: string;
  34.       Dir     : DirStr;
  35.       Name    : NameStr;
  36.       Ext     : ExtStr;
  37.       ShowPos : boolean;
  38.       PosStr  : array[1..5] of record
  39.                                  c: char;
  40.                                  a: byte;
  41.                                end;
  42.  
  43.  
  44. procedure About;
  45. const ARow  = 7;
  46.       ACol  = 13;
  47.       ARows = 10;
  48.       ACols = 54;
  49. var A,i,j: byte;
  50. begin
  51.   Fill(1,1,25,80,White+BlueBG,'▒');
  52.   Fill(ARow,ACol,ARows,ACols,White+LightBlackBG,' ');
  53.   AddShadow(ARow,ACol,ARows,ACols);
  54.   Fill(ARow,ACol,1,ACols,Green+LightWhiteBG,' ');
  55.   WriteC(ARow,ACol+(ACols div 2),SameAttr,'About');
  56.   { Blue }
  57.   Fill(ARow+1,ACol,ARows-1,3,White+LightBlueBG,' ');
  58.   Fill(ARow+1,ACol+ACols-3,ARows-1,3,White+LightBlueBG,' ');
  59.   { Green }
  60.   Fill(ARow+1,ACol+3,ARows-1,3,White+LightGreenBG,' ');
  61.   Fill(ARow+1,ACol+ACols-6,ARows-1,3,White+LightGreenBG,' ');
  62.   { Cyan }
  63.   Fill(ARow+1,ACol+6,ARows-1,3,White+LightCyanBG,' ');
  64.   Fill(ARow+1,ACol+ACols-9,ARows-1,3,White+LightCyanBG,' ');
  65.   { Red }
  66.   Fill(ARow+1,ACol+9,ARows-1,3,White+LightRedBG,' ');
  67.   Fill(ARow+1,ACol+ACols-12,ARows-1,3,White+LightRedBG,' ');
  68.   { Magenta }
  69.   Fill(ARow+1,ACol+12,ARows-1,3,White+LightMagentaBG,' ');
  70.   Fill(ARow+1,ACol+ACols-15,ARows-1,3,White+LightMagentaBG,' ');
  71.   { Change middle attribute }
  72.   for i := (ARow+4) to (ARow+6) do
  73.   for j := ACol to (ACol+ACols-1) do
  74.   begin
  75.     A := ReadAttr(i,j);
  76.     A := A and $7F;
  77.     Attr(i,j,1,1,A);
  78.   end;
  79.   { Text }
  80.   WriteC(ARow+4,ACol+(ACols div 2),SameAttr,'Screen Editor 2.0');
  81.   WriteC(ARow+5,ACol+(ACols div 2),SameAttr,'by');
  82.   WriteC(ARow+6,ACol+(ACols div 2),SameAttr,'Harald  Thunem');
  83.   Inkey(Ch,Key);
  84.   Key := NullKey;
  85. end;
  86.  
  87.  
  88. procedure SelectChar(var DrawChar: char);
  89. const SAttr1 = White+BlackBG;
  90.       SAttr2 = Yellow+RedBG;
  91.       SRow   = 5;
  92.       SCol   = 20;
  93.       SRows  = 10;
  94.       SCols  = 34;
  95. var i: byte;
  96. begin
  97.   GetMem(ScrVar,2*25*80);
  98.   StoreToMem(1,1,25,80,ScrVar^);
  99.   Explode(SRow,SCol,SRows,SCols,SAttr1,SingleBorder);
  100.   AddShadow(SRow,SCol,SRows,SCols);
  101.   WriteC(SRow,SCol-1+(SCols div 2),SAttr1,' Select character ');
  102.   for i := 0 to 255 do
  103.     WriteStr(SRow+1+(i div 32),SCol+1+(i mod 32),SAttr1,Chr(i));
  104.   i := Ord(DrawChar);
  105.   WriteStr(SRow+1+(i div 32),SCol+1+(i mod 32),SAttr2,Chr(i));
  106.   repeat
  107.     InKey(Ch,Key);
  108.     WriteStr(SRow+1+(i div 32),SCol+1+(i mod 32),SAttr1,Chr(i));
  109.     case Key of
  110.       UpArrow   : Dec(i,32);
  111.       DownArrow : Inc(i,32);
  112.       LeftArrow : Dec(i);
  113.       RightArrow: Inc(i);
  114.     end;
  115.     WriteStr(SRow+1+(i div 32),SCol+1+(i mod 32),SAttr2,Chr(i));
  116.   until Key in [Escape,Return];
  117.   if Key=Return then
  118.     DrawChar := Chr(i);
  119.   StoreToScr(1,1,25,80,ScrVar^);
  120.   FreeMem(ScrVar,2*25*80);
  121. end;
  122.  
  123.  
  124. procedure SelectAttr(var DrawAttr: byte);
  125. const SAttr  = White+BlackBG;
  126.       SRow   = 5;
  127.       SCol   = 20;
  128.       SRows  = 10;
  129.       SCols  = 34;
  130. var i: byte;
  131. begin
  132.   GetMem(ScrVar,2*25*80);
  133.   StoreToMem(1,1,25,80,ScrVar^);
  134.   Explode(SRow,SCol,SRows,SCols,SAttr,SingleBorder);
  135.   AddShadow(SRow,SCol,SRows,SCols);
  136.   WriteC(SRow,SCol-1+(SCols div 2),SAttr,' Select attribute ');
  137.   for i := 0 to 255 do
  138.     WriteStr(SRow+1+(i div 32),SCol+1+(i mod 32),i,'▒');
  139.   i := DrawAttr;
  140.   WriteStr(SRow+1+(i div 32),SCol+1+(i mod 32),i,'X');
  141.   repeat
  142.     InKey(Ch,Key);
  143.     WriteStr(SRow+1+(i div 32),SCol+1+(i mod 32),i,'▒');
  144.     case Key of
  145.       UpArrow   : Dec(i,32);
  146.       DownArrow : Inc(i,32);
  147.       LeftArrow : Dec(i);
  148.       RightArrow: Inc(i);
  149.     end;
  150.     WriteStr(SRow+1+(i div 32),SCol+1+(i mod 32),i,'X');
  151.   until Key in [Escape,Return];
  152.   if Key=Return then
  153.     DrawAttr := i;
  154.   StoreToScr(1,1,25,80,ScrVar^);
  155.   FreeMem(ScrVar,2*25*80);
  156. end;
  157.  
  158.  
  159. procedure FillCharOrAttr(var DrawChar: char;  var DrawAttr: byte;  DC: boolean);
  160. var R,C: byte;
  161. begin
  162.   if DC then
  163.     SelectChar(DrawChar)
  164.   else SelectAttr(DrawAttr);
  165.   if Key=Escape then Exit;
  166.   GetMem(ScrVar,2*25*80);
  167.   StoreToMem(1,1,25,80,ScrVar^);
  168.   R := MainR;
  169.   C := MainC;
  170.   Inc(MainR);
  171.   Inc(MainC);
  172.   if DC then
  173.     FillCh(R,C,MainR-R+1,MainC-C+1,DrawChar)
  174.   else Attr(R,C,MainR-R+1,MainC-C+1,DrawAttr);
  175.   repeat
  176.     InKey(Ch,Key);
  177.     StoreToScr(1,1,25,80,ScrVar^);
  178.     case Key of
  179.       UpArrow   : Dec(MainR);
  180.       DownArrow : Inc(MainR);
  181.       LeftArrow : Dec(MainC);
  182.       RightArrow: Inc(MainC);
  183.     end;
  184.     if MainR>CRTRows then MainR:=CRTRows;
  185.     if MainR<1 then MainR:=1;
  186.     if MainC>80 then MainC:=80;
  187.     if MainC<1 then MainC:=1;
  188.     if DC then
  189.       FillCh(R,C,MainR-R+1,MainC-C+1,DrawChar)
  190.     else Attr(R,C,MainR-R+1,MainC-C+1,DrawAttr);
  191.   until Key in [Return,Escape];
  192.   if Key=Escape then
  193.     StoreToScr(1,1,25,80,ScrVar^);
  194.   FreeMem(ScrVar,2*25*80);
  195. end;
  196.  
  197.  
  198. procedure DrawBox(DrawBox: byte);
  199. var R,C: byte;
  200. begin
  201.   GetMem(ScrVar,2*25*80);
  202.   StoreToMem(1,1,25,80,ScrVar^);
  203.   R := MainR;
  204.   C := MainC;
  205.   Inc(MainR,1);
  206.   Inc(MainC,1);
  207.   Box(R,C,MainR-R+1,MainC-C+1,DrawAttr,BoxType,' ');
  208.   repeat
  209.     InKey(Ch,Key);
  210.     StoreToScr(1,1,25,80,ScrVar^);
  211.     case Key of
  212.       UpArrow   : Dec(MainR);
  213.       DownArrow : Inc(MainR);
  214.       LeftArrow : Dec(MainC);
  215.       RightArrow: Inc(MainC);
  216.     end;
  217.     if MainR>CRTRows then MainR:=CRTRows;
  218.     if MainR<1 then MainR:=1;
  219.     if MainC>80 then MainC:=80;
  220.     if MainC<1 then MainC:=1;
  221.     Box(R,C,MainR-R+1,MainC-C+1,DrawAttr,BoxType,#0);
  222.   until Key in [Return,Escape];
  223.   if Key=Escape then
  224.     StoreToScr(1,1,25,80,ScrVar^);
  225.   FreeMem(ScrVar,2*25*80);
  226. end;
  227.  
  228.  
  229. procedure SelectBoxType(var BoxType: byte);
  230. const SRow = 8;
  231.       SCol = 20;
  232.       SRows= 7;
  233.       SCols= 40;
  234. var   i    : byte;
  235. begin
  236.   GetMem(ScrVar,2*25*80);
  237.   StoreToMem(1,1,25,80,ScrVar^);
  238.   Explode(SRow,SCol,SRows,SCols,White+BlackBG,SingleBorder);
  239.   AddShadow(SRow,SCol,SRows,SCols);
  240.   WriteC(SRow,SCol+(SCols div 2),SameAttr,' Select Box Type ');
  241.   WriteStr(SRow+1,SCol+3,White+BlackBG,'Empty Border             -- '+EmptyBorder);
  242.   WriteStr(SRow+2,SCol+3,White+BlackBG,'Single Border            -- '+SBorder);
  243.   WriteStr(SRow+3,SCol+3,White+BlackBG,'Double Border            -- '+DBorder);
  244.   WriteStr(SRow+4,SCol+3,White+BlackBG,'Double Top, Single Side  -- '+DSBorder);
  245.   WriteStr(SRow+5,SCol+3,White+BlackBG,'Single Top, Double Side  -- '+SDBorder);
  246.   i := BoxType+1;
  247.   Attr(SRow+i,SCol+2,1,36,Yellow+RedBG);
  248.   repeat
  249.     InKey(Ch,Key);
  250.     Attr(SRow+i,SCol+2,1,36,White+BlackBG);
  251.     case Key of
  252.       UpArrow  : Dec(i);
  253.       DownArrow: Inc(i);
  254.     end;
  255.     if i<1 then i:=5;
  256.     if i>5 then i:=1;
  257.     Attr(SRow+i,SCol+2,1,36,Yellow+RedBG);
  258.   until Key in [Escape,Return];
  259.   if Key=Return then
  260.     BoxType := i-1;
  261.   StoreToScr(1,1,25,80,ScrVar^);
  262.   FreeMem(ScrVar,2*25*80);
  263. end;
  264.  
  265.  
  266. procedure SaveScrFile(var Filename: string);
  267. const SRow=11;
  268.       SCol=26;
  269. var   Tmp: string;
  270. begin
  271.   GetMem(ScrVar,2*25*80);
  272.   StoreToMem(1,1,25,80,ScrVar^);
  273.   Tmp := Filename;
  274.   Box(SRow+1,SCol,3,26,White+GreenBG,SingleBorder,' ');
  275.   AddShadow(Srow,SCol,4,26);
  276.   Fill(SRow,SCol,1,26,Green+LightWhiteBG,' ');
  277.   WriteC(SRow,SCol+13,SameAttr,'Save File');
  278.   WriteStr(SRow+2,SCol+3,SameAttr,'File :');
  279.   InputString(Tmp,SRow+2,SCol+11,12,Yellow+LightBlackBG,[Escape,Return]);
  280.   StoreToScr(1,1,25,80,ScrVar^);
  281.   FreeMem(ScrVar,2*25*80);
  282.   if Key=Return then
  283.   begin
  284.     Filename := Tmp;
  285.     SaveScreenToFile(Filename);
  286.   end;
  287.   Key := NullKey;
  288. end;
  289.  
  290.  
  291. procedure OpenScrFile(var Filename: string);
  292. var Tmp: string;
  293. begin
  294.   GetDir(0,CurrentPath);
  295.   if Length(CurrentPath)>3 then
  296.     CurrentPath := CurrentPath + '\';
  297.   SearchPath := '*.SCR';
  298.   OpenFile(4,20,Tmp);
  299.   if Key=Return then
  300.     if LoadScreenFromFile(Tmp) then
  301.     begin
  302.       FSplit(Tmp,Dir,Name,Ext);
  303.       Filename := Name+Ext;
  304.     end
  305.     else MessageBox('Error loading file!');
  306.   Key := NullKey;
  307. end;
  308.  
  309.  
  310. procedure Help;
  311. const HRow = 1;
  312.       HCol = 15;
  313.       HRows= 24;
  314.       HCols= 50;
  315. begin
  316.   GetMem(ScrVar,2*25*80);
  317.   StoreToMem(1,1,25,80,ScrVar^);
  318.   Explode(HRow+1,HCol,HRows-1,HCols,White+LightBlackBG,SingleBorder);
  319.   AddShadow(HRow,HCol,HRows,HCols);
  320.   Fill(HRow,HCol,1,HCols,Green+LightWhiteBG,' ');
  321.   WriteC(HRow,HCol+(HCols div 2),SameAttr,'Help');
  322.   WriteStr(HRow+ 2,HCol+3,LightCyan+LightBlackBG,'COMMANDS');
  323.   WriteStr(HRow+ 4,HCol+5,Yellow+LightBlackBG,'F1      ');
  324.   WriteEos(SameAttr,'- This help');
  325.   WriteStr(HRow+ 5,HCol+5,Yellow+LightBlackBG,'F2      ');
  326.   WriteEos(SameAttr,'- Save screen to file');
  327.   WriteStr(HRow+ 6,HCol+5,Yellow+LightBlackBG,'F3      ');
  328.   WriteEos(SameAttr,'- Load screen from file');
  329.   WriteStr(HRow+ 7,HCol+5,Yellow+LightBlackBG,'AltA    ');
  330.   WriteEos(SameAttr,'- Select Attribute');
  331.   WriteStr(HRow+ 8,HCol+5,Yellow+LightBlackBG,'AltB    ');
  332.   WriteEos(SameAttr,'- Draw Box');
  333.   WriteStr(HRow+ 9,HCol+5,Yellow+LightBlackBG,'AltC    ');
  334.   WriteEos(SameAttr,'- Select Character');
  335.   WriteStr(HRow+10,HCol+5,Yellow+LightBlackBG,'AltP    ');
  336.   WriteEos(SameAttr,'- Show Cursor Position');
  337.   WriteStr(HRow+11,HCol+5,Yellow+LightBlackBG,'AltF1   ');
  338.   WriteEos(SameAttr,'- Fill area with Attribute');
  339.   WriteStr(HRow+12,HCol+5,Yellow+LightBlackBG,'AltF2   ');
  340.   WriteEos(SameAttr,'- Fill area with Character');
  341.   WriteStr(HRow+13,HCol+5,Yellow+LightBlackBG,'AltF3   ');
  342.   WriteEos(SameAttr,'- Select Box Type');
  343.   WriteStr(HRow+14,HCol+5,Yellow+LightBlackBG,#27+#24+#25+#26+'    ');
  344.   WriteEos(SameAttr,'- Move Cursor');
  345.   WriteStr(HRow+15,HCol+5,Yellow+LightBlackBG,'Home    ');
  346.   WriteEos(SameAttr,'- Move to upper left corner');
  347.   WriteStr(HRow+16,HCol+5,Yellow+LightBlackBG,'End     ');
  348.   WriteEos(SameAttr,'- Move to lower left corner');
  349.   WriteStr(HRow+17,HCol+5,Yellow+LightBlackBG,'PgUp    ');
  350.   WriteEos(SameAttr,'- Move to upper right corner');
  351.   WriteStr(HRow+18,HCol+5,Yellow+LightBlackBG,'PgDn    ');
  352.   WriteEos(SameAttr,'- Move to lower right corner');
  353.   WriteStr(HRow+19,HCol+5,Yellow+LightBlackBG,'Space   ');
  354.   WriteEos(SameAttr,'- Draw with current Attr and Char');
  355.   WriteStr(HRow+20,HCol+5,Yellow+LightBlackBG,'Char-Key');
  356.   WriteEos(SameAttr,'- Write Char');
  357.   WriteStr(HRow+22,HCol+5,Yellow+LightBlackBG,'AltX    ');
  358.   WriteEos(SameAttr,'- Quit program');
  359.  
  360.   InKey(Ch,Key);
  361.   StoreToScr(1,1,25,80,ScrVar^);
  362.   FreeMem(ScrVar,2*25*80);
  363. end;
  364.  
  365.  
  366. procedure ReadPosBack;
  367. var i: byte;
  368. begin
  369.   for i := 1 to 5 do
  370.   begin
  371.     PosStr[i].C := ReadChar(1,75+i);
  372.     PosStr[i].A := ReadAttr(1,75+i);
  373.   end;
  374. end;
  375.  
  376.  
  377. procedure WritePosBack;
  378. var i: byte;
  379. begin
  380.   for i := 1 to 5 do
  381.   with PosStr[i] do
  382.     WriteStr(1,75+i,A,C);
  383. end;
  384.  
  385.  
  386. procedure WritePos(R,C: byte);
  387. begin
  388.   WriteStr(1,76,White+BlueBG,'  ,  ');
  389.   WriteStr(1,76,SameAttr,StrLF(R,2));
  390.   WriteStr(1,79,SameAttr,StrLF(C,2));
  391. end;
  392.  
  393.  
  394. procedure Main;
  395. var A: byte;
  396. begin
  397.   MainR := 12;
  398.   MainC := 40;
  399.   BoxType := 1;
  400.   ShowPos := false;
  401.   Filename := 'NONAME00.SCR';
  402.   DrawAttr := White+BlueBG;
  403.   DrawChar := 'A';
  404.   repeat
  405.     if ShowPos then
  406.     begin
  407.       ReadPosBack;
  408.       WritePos(MainR,MainC);
  409.     end;
  410.     A := not ReadAttr(MainR,MainC);
  411.     Attr(MainR,MainC,1,1,A);
  412.     Key := NullKey;
  413.     InKey(Ch,Key);
  414.     Attr(MainR,MainC,1,1,not A);
  415.     if ShowPos then WritePosBack;
  416.     case Key of
  417.       UpArrow   : Dec(MainR);
  418.       DownArrow : Inc(MainR);
  419.       LeftArrow : Dec(MainC);
  420.       RightArrow: Inc(MainC);
  421.       TextKey   : begin
  422.                     DrawChar := Ch;
  423.                     WriteStr(MainR,MainC,DrawAttr,DrawChar);
  424.                     Inc(MainC);
  425.                   end;
  426.       Space     : WriteStr(MainR,MainC,DrawAttr,DrawChar);
  427.       AltA      : SelectAttr(DrawAttr);
  428.       AltC      : SelectChar(DrawChar);
  429.       AltB      : DrawBox(BoxType);
  430.       AltP      : ShowPos := not ShowPos;
  431.  
  432.       HomeKey   : begin
  433.                     MainR := 1;
  434.                     MainC := 1;
  435.                   end;
  436.       EndKey    : begin
  437.                     MainR := 25;
  438.                     MainC := 1;
  439.                   end;
  440.       PgUp      : begin
  441.                     MainR := 1;
  442.                     MainC := 80;
  443.                   end;
  444.       PgDn      : begin
  445.                     MainR := 25;
  446.                     MainC := 80;
  447.                   end;
  448.       F1        : Help;
  449.       F2        : SaveScrFile(Filename);
  450.       F3        : OpenScrFile(Filename);
  451.       AltF1     : FillCharOrAttr(DrawChar,DrawAttr,false);
  452.       AltF2     : FillCharOrAttr(DrawChar,DrawAttr,true);
  453.       AltF3     : SelectBoxType(BoxType);
  454.       AltX      : ;
  455.       else        WriteStr(MainR,MainC,DrawAttr,Ch);
  456.     end;
  457.     if MainR>CRTRows then MainR:=CRTRows;
  458.     if MainR<1 then MainR:=1;
  459.     if MainC>80 then MainC:=80;
  460.     if MainC<1 then MainC:=1;
  461.   until Key=AltX;
  462.   Attr(MainR,MainC,1,1,not A);
  463.   if Confirm('Save file before quitting',true) then
  464.     SaveScrFile(Filename);
  465. end;
  466.  
  467.  
  468. begin
  469.   SetCursor(CursorOff);
  470.   SetIntens;
  471.   About;
  472.   ClrScr;
  473.   Main;
  474.   Fill(25,1,1,80,White+BlackBG,' ');
  475.   GoToRC(24,1);
  476.   SetBlink;
  477.   SetCursor(CursorUnderline);
  478. end.