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