home *** CD-ROM | disk | FTP | other *** search
/ Programmer Power Tools / Programmer Power Tools.iso / microcrn / issue_44.arc / OR4.ARC / PULLDOWN.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1988-08-01  |  11.8 KB  |  354 lines
  1. {----------------------------------------------------------------------------}
  2. function   Max_Int          (Int1,Int2:integer) : integer;
  3. begin
  4.    if (Int1 > Int2)
  5.       then Max_Int := Int1
  6.       else Max_Int := Int2;
  7. end;  { End: Max_Int }
  8.  
  9. {----------------------------------------------------------------------------}
  10. type
  11.    sCharDef = set of #0..#255;
  12. {----------------------------------------------------------------------------}
  13. function   LeftJust        (Subject,Target:string) : string;
  14. var L2 : integer;
  15. begin
  16.    L2 := length(Target);
  17.    LeftJust := copy(Subject, 1, L2) + copy(Target, length(subject) + 1, L2);
  18. end;  { End: LeftJust }
  19.  
  20. {----------------------------------------------------------------------------}
  21. function   RightJust       (Subject,Target:string) : string;
  22. var L1,L2 : integer;
  23. begin
  24.    L1 := length(Subject); L2 := length(Target);
  25.    if (L2 > L1)
  26.       then RightJust := copy(Target, 1, L2-L1) + Subject
  27.       else  RightJust := copy(Subject, 1, L2);
  28. end;  { End: RightJust }
  29.  
  30. {----------------------------------------------------------------------------}
  31. function   Center          (Subject,Target:string) : string;
  32. var L1,L2,L3 : integer;
  33. begin
  34.    L1 := length(Subject); L2 := length(Target);
  35.    if (L2 > L1) then begin
  36.       L3 := (L2-L1) div 2;
  37.       Center := copy(Target, 1, L3) + Subject + copy(Target, L3+L1+1, L2);
  38.    end
  39.    else  Center := copy(Subject, 1, L2);
  40. end;  { End: Center }
  41.  
  42. {----------------------------------------------------------------------------}
  43. function   MultiChr        (N:integer;  InChr:char) : string;
  44. var S1 : string[255];
  45. begin
  46.    fillchar(S1, N+1, InChr);
  47.    S1[0] := chr(N);
  48.    MultiChr := S1;
  49. end;  { End: MultiChr }
  50.  
  51. {----------------------------------------------------------------------------}
  52. function   Spaces          (N:integer) : string;
  53. begin
  54.    Spaces := MultiChr(N, #32);
  55. end;  { End: Spaces }
  56.  
  57. {----------------------------------------------------------------------------}
  58. function   DelimParse      (var S:string; var BegPtr:integer; sChr:sCharDef; var Delim:char) : string;
  59. { parses sub-string beginning at BegPtr, ending with string or deliminator. }
  60. { Init BegPtr = 0,  Delim = #0 when returning last substring }
  61. var
  62.    NewPtr : integer;   Ch : char;
  63. label Loop1;
  64. begin
  65.        Delim := #0;   NewPtr := BegPtr;
  66. Loop1: if (NewPtr <= Length(S)) then begin
  67.           NewPtr := NewPtr + 1; Ch := S[NewPtr];
  68.           if not (Ch in sChr) then goto Loop1;
  69.           Delim := Ch;
  70.        end;
  71.        DelimParse := copy(S, BegPtr, NewPtr-BegPtr);
  72.        BegPtr := NewPtr+1;
  73. end;  { End: DelimParse }
  74.  
  75. {----------------------------------------------------------------------------}
  76. type
  77.    MenuText_ad = array [1..16] of string[32];
  78. {----------------------------------------------------------------------------}
  79. procedure  Draw_Window_Box  (X0,Y0,Width,Hieght:integer; HdrStr:string);
  80. var
  81.    i : integer;
  82.    Tmp_Str : string;
  83. begin
  84.    Set_Window_Area(X0,Y0+1,Width+2,Hieght); High_Video; clrscr;
  85.    Set_Window_Area(X0,Y0,Width+2,Hieght+3);
  86.    Med_Video;  gotoXY(1,1);
  87.  
  88.    {draw top line of box:}
  89.    Tmp_Str := #218 + multichr(Width,#196) + #191;
  90.    Tmp_Str := Center(HdrStr,Tmp_Str);
  91.    gotoXY(1,1); write(Tmp_Str);
  92.  
  93.    for i := 1 to Hieght do begin
  94.       gotoXY(1,i+1);       write(#179);
  95.       gotoXY(Width+2,i+1); write(#179);
  96.    end;
  97.  
  98.    {draw bottom line of box:}
  99.    Tmp_Str := #192 + multichr(Width,#196) + #217;
  100.    gotoXY(1,Hieght+2); write(Tmp_Str);
  101. end;  { End: Draw_Window_Box }
  102.  
  103. {----------------------------------------------------------------------------}
  104. procedure  Draw_PullDown_Window  (X0,Y0,SelNo,Width,Hieght:integer; HdrStr:string; aTxStr,aHlStr:MenuText_ad);
  105. var
  106.    i,j : integer;
  107. begin
  108.    {first draw box around window:}
  109.    Draw_Window_Box  (X0,Y0,Width,Hieght,HdrStr);
  110.  
  111.    {now fill it in:}
  112.    Set_Window_Area(X0,Y0,Width+2,Hieght+3);
  113.    for i := 1 to Hieght do begin
  114.       gotoXY(2,i+1);
  115.       Med_Video;
  116.       for j := 1 to length(aTxStr[i]) do begin
  117.          if (i = SelNo) then         Rev_Video  {selection}
  118.          else if (aHlStr[i][j] = '^') then High_Video {Highlight}
  119.          else                         Med_Video; {Normal}
  120.          if (aHlStr[i][j] = '+')
  121.             then write(#254)
  122.             else write(aTxStr[i][j]);
  123.       end;
  124.    end;
  125. end;  {Draw_PullDown_Window}
  126. {----------------------------------------------------------------------------}
  127. procedure  PullDown_Menu (X,Y:integer; HdrStr,TxStr,HlStr:string; var SelNo,Exit_Sw:integer);
  128. label Out,BreakLoop;
  129. var
  130.    Delim1,Delim2,InChar : char;
  131.    Last_SelNo,Dummy_Sw : integer;
  132.    i,j, Hieght,Width, BP1,BP2 : integer;
  133.    aTxStr,aHlStr : MenuText_ad;
  134.  
  135. begin
  136.    Last_SelNo := 0;  Exit_Sw := 0;
  137.    for i := 1 to 16 do aTxStr[i] := '                                ';
  138.  
  139.    {process menu text:}
  140.    Width := 0;  BP1 := 1;  BP2 := 1; Hieght := 0;
  141.    repeat  {break apart strings}
  142.       Hieght := Hieght + 1;                                 { incr array ptr }
  143.       aTxStr[Hieght] := DelimParse(TxStr, BP1, ['/','|'], Delim1);  {BP1 changed}
  144.       aHlStr[Hieght] := DelimParse(HlStr, BP2, ['/','|'], Delim2);  {BP2 changed}
  145.       Width := Max_Int(Width, length(aTxStr[Hieght]));
  146.    until (Delim1=#0);
  147.  
  148.    Draw_PullDown_Window(X,Y,SelNo,Width,Hieght,HdrStr,aTxStr,aHlStr);  {draw window}
  149.  
  150.    repeat
  151.       Last_SelNo := SelNo;
  152.       InChar := GetKey;
  153.       case InChar of
  154.       {control keys:}
  155.       #27: begin  Exit_Sw := 2;  goto Out;  end; {escape}
  156.       #222: if (SelNo > 1)
  157.                then SelNo := SelNo - 1  {up arrow}
  158.                else begin  Exit_Sw := 2;  goto Out;  end; {escape}
  159.       #230: if (SelNo < Hieght) then SelNo := SelNo + 1;  {dn arrow}
  160.       #221: SelNo := 1;  {home}
  161.       #229: SelNo := Hieght;  {end}
  162.       #13: begin
  163.               if (SelNo = 0)
  164.                  then Exit_Sw := 2
  165.                  else Exit_Sw := 1;
  166.               goto Out;
  167.            end;
  168.       'Q': begin  Exit_Sw := 2;  goto Out;  end; {reached only if not defined above}
  169.       else begin  {other}
  170.             for i := 1 to Hieght do begin
  171.                j := pos('^',aHlStr[i]);  {get position of caret}
  172.                if (j > 0) and
  173.                   (InChar = aTxStr[i][j]) then begin  {compare char}
  174.                   SelNo := i;
  175.                   Exit_Sw := 1;
  176.                   goto BreakLoop;
  177.                end;
  178.             end;
  179.             Beep(1500,50); Beep(500,10);
  180. BreakLoop:
  181.          end;
  182.       end;  {end case}
  183.       if (SelNo <> Last_SelNo)
  184.          then Draw_PullDown_Window(X,Y,SelNo,Width,Hieght,HdrStr,aTxStr,aHlStr);  {draw window}
  185.    until  (g_exit_mode > 0);
  186. Out:
  187. end;  {PullDown_Menu}
  188.  
  189. {----------------------------------------------------------------------------}
  190. procedure  Across_Menu(X,Y,SelNo:integer; TxStr,HlStr,SelStr:string);
  191. {writes string at x,y; highlights letters; selection in reverse video}
  192. {Example: TxStr='sel1 sel2';  HlStr='^    ^   ';  SelStr='0--- 1---'}
  193. var
  194.    TXLen,SelLen,i,SelBeginPos,SelEndPos : integer;
  195.    this_char : char;
  196. begin
  197.    TXLen := length(TXStr);
  198.    SelLen := length(SelStr);
  199.    SelBeginPos := Pos(char(SelNo + ord('0')),SelStr);
  200.    SelEndPos := SelBeginPos;
  201.    while (SelStr[SelEndPos+1] = '-') and (SelEndPos < SelLen)
  202.       do SelEndPos := SelEndPos + 1;
  203.    Set_Window_Area(X,Y,80,1);
  204.    for i := 1 to length(TXStr) do begin
  205.       gotoXY(X+i-1,1);
  206.       if ((i >= SelBeginPos) and (i <= SelEndPos)) then Rev_Video  {selection}
  207.       else if (HLStr[i] = '^') then                     High_Video {Highlight}
  208.       else                                              Med_Video; {Normal}
  209.       if (HLStr[i] = '+')
  210.          then write(#254)
  211.          else write(TXStr[i]);
  212.    end;
  213. end;  {Across_Menu}
  214.  
  215. {----------------------------------------------------------------------------}
  216. function  Rem_Tail_Spaces(InStr:string) : string;
  217. label BreakLoop,Out;
  218. var
  219.    i,len : integer;
  220. begin
  221.    len := length(InStr);
  222.    for i := len downto 1 do begin
  223.       if (InStr[i] <> #32) then goto BreakLoop;
  224.    end;
  225.    Rem_Tail_Spaces := '';
  226.    goto Out;
  227. BreakLoop:
  228.    Rem_Tail_Spaces := copy(InStr,1,i);
  229. Out:
  230. end;  {Rem_Tail_Spaces}
  231.  
  232. {----------------------------------------------------------------------------}
  233. procedure  Pathname_Menu(X,Y:integer; var FileName:string; var Exit_Sw:integer);
  234. label Out;
  235. var
  236.    i : integer;
  237.    InChar : char;
  238.    FileStr : string;
  239. begin
  240.    Set_Window_Area(X,Y+1,20+2,5);
  241.    Med_Video;  gotoXY(1,1);
  242.    write(#218);   for i := 1 to 20 do write(#196);   write(#191);
  243.  
  244.    gotoXY(1,2);  write(#179);  write('Enter File Pathname:');  write(#179);
  245.    gotoXY(1,3);  write(#179);  write('                    ');  write(#179);
  246.  
  247.    Med_Video;  gotoXY(1,4);
  248.    write(#192);   for i := 1 to 20 do write(#196);   write(#217);
  249.  
  250.    Exit_Sw := 0;  FileStr := '';
  251.    gotoXY(2,3);
  252.    CursorOn;
  253.    repeat
  254.       InChar := GetKey;
  255.       case InChar of
  256.       'A'..'Z','-','_','.','0'..'9': begin
  257.             if (length(FileStr) < 20) then begin
  258.                FileStr := FileStr + InChar;
  259.                gotoXY(2,3); write(FileStr);
  260.             end;
  261.          end;
  262.       #225,#8: begin
  263.             if (length(FileStr) > 0) then begin
  264.                gotoXY(length(FileStr)+1,3); write(#32);
  265.                gotoXY(length(FileStr)+1,3);
  266.                FileStr := copy(FileStr,1,Length(FileStr)-1);
  267.             end;
  268.          end;
  269.       #13,#222: begin
  270.               FileStr := Rem_Tail_Spaces(FileStr);
  271.               if (FileStr = '')
  272.                  then Exit_Sw := 2
  273.                  else Exit_Sw := 1;
  274.               FileName := FileStr;
  275.               goto Out;
  276.            end;
  277.       #27: begin  FileName := '';  Exit_Sw := 2;  end;
  278.       end;  {end case}
  279.    until (Exit_Sw > 0);
  280. Out:
  281.    CursorOff;
  282. end;  {Pathname_Menu}
  283.  
  284. {----------------------------------------------------------------------------}
  285. procedure  YesNo_Menu(X,Y:integer; Msg:string; var YesNo_Ch:char; var Exit_Sw:integer);
  286. var
  287.    len,i : integer;
  288.    Tmp_Ch,InChar : char;
  289.    FileStr : string;
  290. begin
  291.    len := length(Msg);
  292.    Set_Window_Area(X,Y+1,20+2,4);
  293.    Med_Video;
  294.  
  295.    gotoXY(1,1);  write(#218);  for i := 1 to len + 3 do write(#196);  write(#191);
  296.    gotoXY(1,2);  write(#179);  for i := 1 to len + 3 do write(#32);   write(#179);
  297.    gotoXY(1,3);  write(#192);  for i := 1 to len + 3 do write(#196);  write(#217);
  298.  
  299.    Exit_Sw := 0;
  300.    gotoXY(2,2); write(Msg);
  301.    CursorOn;
  302.    InChar := GetKey;
  303.    case InChar of
  304.    'Y':  begin  Tmp_Ch := 'Y';     Exit_Sw := 1;  YesNo_Ch := 'Y'; end;
  305.    'N':  begin  Tmp_Ch := 'N';     Exit_Sw := 0;  YesNo_Ch := 'N'; end;
  306.    #27:  begin  YesNo_Ch := #0;    Exit_Sw := 2;  YesNo_Ch := #0;  end;
  307.    end;  {end case}
  308.    CursorOff;
  309. end;  {YesNo_Menu}
  310.  
  311. {----------------------------------------------------------------------------}
  312. function  Ck_In_FileName(FileName:string) : integer;
  313. var
  314.    OK : integer;
  315.    InFile : file;
  316. begin
  317.    assign(InFile, FileName);
  318.    {$I-} reset(InFile); {$I+}
  319.    OK := IOresult;
  320.    if (OK = 0) then close(InFile);  {undo any action}
  321.    Ck_In_FileName := OK;
  322.  
  323.    case OK of
  324.    $00: ;
  325.    $01: Msg_Line( 25, 'file does not exist' );
  326.    $F2: Msg_Line( 25, 'file dissapeared' );
  327.    else Msg_Line( 25, 'filename or disk error' );
  328.    end;  {end case}
  329. end;  {Ck_In_FileName}
  330.  
  331. {----------------------------------------------------------------------------}
  332. function  Ck_Out_FileName(FileName:string) : integer;
  333. var
  334.    OK : integer;
  335.    OutFile : file;
  336. begin
  337.    assign(OutFile, FileName);
  338.    {$I-} rewrite(OutFile); {$I+}
  339.    OK := IOresult;
  340.    if (OK = 0) then close(OutFile);  {undo any action}
  341.    Ck_Out_FileName := OK;
  342.  
  343.    case OK of
  344.    $00: ;
  345.    $F0: Msg_Line(25, 'disk write error');
  346.    $F1: Msg_Line(25, 'directory is full');
  347.    $F2: Msg_Line(25, 'file dissapeared');
  348.    else Msg_Line(25, 'filename or disk error');
  349.    end;  {end case}
  350. end;  {Ck_Out_FileName}
  351.  
  352. {----------------------------------------------------------------------------}
  353.  
  354.