home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SYSPC22.ZIP / CONFIGUR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-05-10  |  7.4 KB  |  298 lines
  1. overlay procedure configure;
  2.  
  3. const colorstr:array [0..7] of string[7]=
  4.         ('Black','Blue','Green','Cyan','Red','Magenta','Brown','White');
  5.  
  6. procedure options (c:configtype; var prompt,onstr,offstr:lstr);
  7.  
  8.   procedure ret (x1,x2,x3:lstr);
  9.   begin
  10.     prompt:=x1;
  11.     onstr:=x2;
  12.     offstr:=x3
  13.   end;
  14.  
  15. begin
  16.   case c of
  17.     linefeeds:ret('Require line feeds','Yes','No');
  18.     eightycols:ret('Screen width','80 columns','40 columns');
  19.     postprompts:ret('Post prompts during newscan','Yes','No');
  20.     moreprompts:ret('Pause every screen','Yes','No');
  21.     asciigraphics:ret('Use IBM graphics characters','Yes','No');
  22.     showtime:ret('Display time left at prompts','Yes','No');
  23.     lowercase:ret('Upper/lower case','Upper or lower case','Upper case only');
  24.     fseditor:ret('Use full-screen editor','Yes','No')
  25.   end
  26. end;
  27.  
  28. function getattrib (fg,bk:integer; hi,bl:boolean):byte;
  29. begin
  30.   getattrib:=fg+(byte(hi) shl 3)+(bk shl 4)+(byte(bl) shl 7)
  31. end;
  32.  
  33. procedure getcolorvar (attr:byte; var fg,bk:integer; var hi,bl:boolean);
  34. begin
  35.   fg:=attr and 7;
  36.   hi:=(attr and 8)=8;
  37.   bk:=(attr shr 4) and 7;
  38.   bl:=(attr and 128)=128
  39. end;
  40.  
  41. procedure getthing (c:configtype);
  42. var n:integer;
  43.     name,onstr,offstr:lstr;
  44. begin
  45.   options (c,name,onstr,offstr);
  46.   writehdr (name);
  47.   write ('Current setting: '^S);
  48.   if c in urec.config then write (onstr) else write (offstr);
  49.   writeln (^B^M^M'Would you like:');
  50.   writeln ('  1. ',onstr);
  51.   writeln ('  2. ',offstr);
  52.   writestr (^M'Your choice:');
  53.   n:=valu(input);
  54.   if (n>0) and (n<3) then begin
  55.     if n=2
  56.       then urec.config:=urec.config-[c]
  57.       else urec.config:=urec.config+[c];
  58.     writeurec
  59.   end
  60. end;
  61.  
  62. procedure writecolorstr (a:byte);
  63. var fg,bk:integer;
  64.     hi,bl:boolean;
  65. begin
  66.   getcolorvar (a,fg,bk,hi,bl);
  67.   ansicolor (a);
  68.   if bl then write ('Blinking ');
  69.   if hi then write ('Highlighted ');
  70.   write (colorstr[fg]);
  71.   if bk>0 then write (' on ',colorstr[bk])
  72. end;
  73.  
  74. function colorval (str:mstr):integer;
  75. var cnt:integer;
  76. begin
  77.   colorval:=-1;
  78.   if match(str,'None') then begin
  79.     colorval:=0;
  80.     exit
  81.   end;
  82.   for cnt:=0 to 7 do
  83.     if match(str,colorstr[cnt]) then begin
  84.       colorval:=cnt;
  85.       exit
  86.     end
  87. end;
  88.  
  89. procedure badcolor;
  90. var cnt:integer;
  91. begin
  92.   write ('Invalid color!  Valid colors are Black, ');
  93.   for cnt:=1 to 7 do begin
  94.     ansicolor (cnt);
  95.     write (colorstr[cnt]);
  96.     if cnt=7
  97.       then writeln ('.')
  98.       else write (', ');
  99.     if cnt=6
  100.       then write (', and ');
  101.   end;
  102.   writestr ('')
  103. end;
  104.  
  105. procedure getcolor (prompt:mstr; var a:byte);
  106.  
  107.   procedure getacolor (var q:integer; prompt:mstr);
  108.   var n:integer;
  109.   begin
  110.     repeat
  111.       writestr ('Enter new '+prompt+' color:');
  112.       if hungupon or (length(input)=0) then exit;
  113.       n:=colorval(input);
  114.       if n=-1
  115.         then badcolor
  116.         else q:=n
  117.     until n<>-1
  118.   end;
  119.  
  120. var fg,bk:integer;
  121.     hi,bl:boolean;
  122. begin
  123.   if not (ansigraphics in urec.config) then begin
  124.     writestr ('You must have ANSI emulation to see color.');
  125.     exit
  126.   end;
  127.   getcolorvar (a,fg,bk,hi,bl);
  128.   write ('Current ',prompt,' color: ');
  129.   writecolorstr (a);
  130.   writestr (^M^M);
  131.   getacolor (fg,'foreground');
  132.   getacolor (bk,'background');
  133.   writestr ('Highlight the characters? *');
  134.   hi:=yes;
  135.   bl:=false;
  136.   a:=getattrib (fg,bk,hi,bl)
  137. end;
  138.  
  139. procedure emulation;
  140. begin
  141.   writeln (^B^M'Note:  ANSI is required for color.');
  142.   writeln (    '       VT52 or ANSI is required for the full-screen editor.');
  143.   writeln;
  144.   writeln (^B'Please choose your terminal type.'^M^M,
  145.            '   1. ANSI Color'^M,
  146.            '   2. VT52 Emulation'^M,
  147.            '   3. None'^M);
  148.   writestr ('Emulation type:');
  149.   if length(input)=0 then exit;
  150.   urec.config:=urec.config-[ansigraphics,vt52];
  151.   case valu(input) of
  152.     1:urec.config:=urec.config+[ansigraphics];
  153.     2:urec.config:=urec.config+[vt52]
  154.   end
  155. end;
  156.  
  157. procedure getdisplaylen;
  158. var v:integer;
  159. begin
  160.   writeln ('Current display length is: '^S,urec.displaylen);
  161.   writestr (^M'Enter new display length:');
  162.   if length(input)=0 then exit;
  163.   v:=valu(input);
  164.   if (v<21) or (v>43)
  165.     then writeln ('Invalid!')
  166.     else urec.displaylen:=v
  167. end;
  168.  
  169. procedure configurenewscan;
  170. var bd:boardrec;
  171.     bn:integer;
  172.     ac:accesstype;
  173. begin
  174.   opentempbdfile;
  175.   seek (bdfile,0);
  176.   for bn:=0 to filesize(bdfile)-1 do begin
  177.     read (bdfile,bd);
  178.     ac:=getuseraccflag(urec,bn);
  179.     if (ac=letin) or ((ulvl>=bd.level) and (ac=bylevel)) then begin
  180.       writestr ('Newscan '+bd.boardname+' (now '+
  181.                 yesno(not (bn in urec.newscanconfig))+'):');
  182.       if length(input)<>0 then
  183.         if yes
  184.           then urec.newscanconfig:=urec.newscanconfig-[bn]
  185.           else urec.newscanconfig:=urec.newscanconfig+[bn]
  186.     end
  187.   end;
  188.   closetempbdfile
  189. end;
  190.  
  191. procedure showit (s,v:lstr);
  192. begin
  193.   if break then exit;
  194.   tab (s+':',30);
  195.   writeln (^S,v)
  196. end;
  197.  
  198. procedure showthing (c:configtype);
  199. var n:integer;
  200.     name,onstr,offstr:lstr;
  201. begin
  202.   if break then exit;
  203.   options (c,name,onstr,offstr);
  204.   tab (name+':',30);
  205.   write (^S);
  206.   if c in urec.config
  207.     then write (^S,onstr)
  208.     else write (^S,offstr);
  209.   writeln
  210. end;
  211.  
  212. procedure showemulation;
  213. var q:lstr;
  214. begin
  215.   if ansigraphics in urec.config
  216.     then q:='ANSI Color'
  217.     else if vt52 in urec.config
  218.       then q:='VT52 Emulation'
  219.       else q:='None';
  220.   showit ('Terminal type',q)
  221. end;
  222.  
  223. procedure showdisplaylen;
  224. begin
  225.   showit ('Display length',strr(urec.displaylen))
  226. end;
  227.  
  228. procedure showcolor (prompt:mstr; attr:byte);
  229. begin
  230.   if break then exit;
  231.   tab ('  '+prompt+' color:',30);
  232.   writecolorstr (attr);
  233.   writeln
  234. end;
  235.  
  236. procedure yourstatus;
  237. begin
  238.   writehdr ('Your Configuration');
  239.   showthing (linefeeds);
  240.   showthing (eightycols);
  241.   showthing (postprompts);
  242.   showthing (moreprompts);
  243.   showthing (asciigraphics);
  244.  
  245.   showthing (lowercase);
  246.   showemulation;
  247.   showthing (fseditor);
  248.   showdisplaylen;
  249.   if ansigraphics in urec.config then begin
  250.     showcolor ('Prompt',urec.promptcolor);
  251.     showcolor ('Input',urec.inputcolor);
  252.     showcolor ('Regular',urec.regularcolor);
  253.     showcolor ('Statistic',urec.statcolor)
  254.   end
  255. end;
  256.  
  257. var q:integer;
  258. begin
  259.   repeat
  260.     if (not (lowercase in urec.config)) and (ansigraphics in urec.config)
  261.       then begin
  262.         urec.config:=urec.config+[lowercase];
  263.         writestr ('You may not use ANSI in uppercase-only mode.')
  264.       end;
  265.     if (fseditor in urec.config) and
  266.        (urec.config=urec.config-[ansigraphics,vt52])
  267.       then begin
  268.         urec.config:=urec.config-[fseditor];
  269.         writestr ('You may not use the full-screen editor without ANSI or VT52 emulation.')
  270.       end;
  271.     q:=menu ('Configuration','CONFIG','QLWOMGTUEDPIRSNYFA');
  272.     case q of
  273.       2:getthing (linefeeds);
  274.       3:getthing (eightycols);
  275.       4:getthing (postprompts);
  276.       5:getthing (moreprompts);
  277.       6:getthing (asciigraphics);
  278.       7:;
  279.       8:getthing (lowercase);
  280.       9:emulation;
  281.       10:getdisplaylen;
  282.       11:getcolor ('prompt',urec.promptcolor);
  283.       12:getcolor ('input',urec.inputcolor);
  284.       13:getcolor ('regular',urec.regularcolor);
  285.       14:getcolor ('statistic',urec.statcolor);
  286.       15:configurenewscan;
  287.       16:yourstatus;
  288.       17:getthing (fseditor);
  289.       18:begin
  290.           Writestr ('Use ANSI windows? *');
  291.           urec.windows:=yes;
  292.          end;
  293.     end;
  294.     writeurec
  295.   until (q=1) or hungupon
  296. end;
  297.  
  298.