Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FAQ-S.ZIP/VOTING.PAS

Pascal/Delphi Source File | 1991-04-13 | 13.4 KB | 494 lines

{$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
{$M 65500,0,0 }

unit voting;

interface

uses gentypes,configrt,gensubs,subs1,subs2,userret,overret1,modem;

procedure votingbooth (getmandatory:boolean);

implementation

procedure votingbooth (getmandatory:boolean);
var curtopic:topicrec;
    curtopicnum:integer;

  function votefn (n:integer):sstr;
  begin
    votefn:=bbsdatadir+'VoteFile.'+strr(n)
  end;

  procedure opentopicdir;
  var n:integer;
  begin
    assign (tofile,bbsdatadir+'VOTEDIR.dat');
    reset (tofile);
    if ioresult<>0 then begin
      close (tofile);
      n:=ioresult;
      rewrite (tofile)
    end
  end;

  function numtopics:integer;
  begin
    numtopics:=filesize (tofile)
  end;

  procedure opentopic (n:integer);
  var q:integer;
  begin
    curtopicnum:=n;
    close (chfile);
    assign (chfile,votefn(n));
    reset (chfile);
    if ioresult<>0 then begin
      close (chfile);
      q:=ioresult;
      rewrite (chfile)
    end;
    seek (tofile,n-1);
    read (tofile,curtopic)
  end;

  function numchoices:integer;
  begin
    numchoices:=filesize (chfile)
  end;

  procedure writecurtopic;
  begin
    seek (tofile,curtopicnum-1);
    write (tofile,curtopic)
  end;

  procedure listchoices;
  var ch:choicerec;
      cnt:integer;
  begin
    writehdr ('Your Choices');
    seek (chfile,0);
    for cnt:=1 to numchoices do
      begin
        read (chfile,ch);
        writeln (cnt:2,'.  ',ch.choice);
        if break then exit
      end
  end;

  function addchoice:integer;
  var ch:choicerec;
  begin
    addchoice:=0;
    buflen:=70;
    writestr (^M'Enter new choice: &');
    if length(input)<2 then exit;
    addchoice:=numchoices+1;
    ch.numvoted:=0;
    ch.choice:=input;
    seek (chfile,numchoices);
    write (chfile,ch);
    writelog (20,2,ch.choice)
  end;

  procedure getvote (mandatory:boolean);
  var cnt,chn:integer;
      k:char;
      ch:choicerec;
      tmp:lstr;
      besh,a:boolean;
  begin
    if urec.voted[curtopicnum]<>0 then begin
      writeln ('Sorry, can''t vote twice!!');
      exit
    end;
    a:=ulvl>=curtopic.addlevel;
    tmp:=+^P'Select '^R'['^S'?/List';
    if a then tmp:=tmp+', [A]dd';
    tmp:=tmp+^R']'^P':';
    listchoices;
    repeat
      besh:=false;
      input:=chr(0);
      input:='';
      writestr (tmp);
      chn:=valu(input);
      if chn<1 then begin
        k:=upcase(input[1]);
        if k='?'
          then listchoices
          else if k='A'
            then if a
              then begin
                  besh:=true;
                  chn:=addchoice
              end else writestr ('You may not add choices to this topic!')
    end;
    until (chn>0) or (besh=true);
    if (chn>numchoices) or (chn<0) then begin
      writeln ('Choice # out of range!');
      exit
    end;
    curtopic.numvoted:=curtopic.numvoted+1;
    writecurtopic;
    seek (chfile,chn-1);
    read (chfile,ch);
    ch.numvoted:=ch.numvoted+1;
    seek (chfile,chn-1);
    write (chfile,ch);
    urec.voted[curtopicnum]:=chn;
    writeurec;
    writeln ('Thanks for voting!')
  end;

  procedure showresults;
  var cnt,tpos,n:integer;
      ch:choicerec;
      percent:real;
  begin
    if urec.voted[curtopicnum]=0 then begin
      writeln ('Sorry, You must vote First!!');
      exit
    end;
    seek (chfile,0);
    tpos:=1;
    for cnt:=1 to filesize (chfile) do begin
      read (chfile,ch);
      n:=length(ch.choice)+2;
      if n>tpos then tpos:=n
    end;
    writehdr ('The results so far');
    seek (chfile,0);
    for cnt:=1 to numchoices do if not break then begin
      read (chfile,ch);
      tab (ch.choice,tpos);
      writeln (ch.numvoted)
    end;
    if numusers>0
      then percent:=100.0*curtopic.numvoted/numusers
      else percent:=0;
    writeln (^M,percent:0:0,'% of ',numusers,' have voted.')
  end;

  procedure listtopics;
  var t:topicrec;
      cnt:integer;
  begin
    writehdr ('Voting Topics');
    seek (tofile,0);
    for cnt:=1 to numtopics do
      if not break then begin
        read (tofile,t);
        writeln (cnt:2,'.  ',t.topicname)
      end
  end;

  procedure addtopic;
  var t:topicrec;
      ch:choicerec;
      u:userrec;
      cnt,tpn:integer;
  begin
    if numtopics>=maxtopics then
      begin
        writeln ('No more room to add a topic!');
        exit
      end;
    tpn:=numtopics+1;
    writestr ('Topic name:');
    if length(input)=0 then exit;
    t.topicname:=input;
    t.numvoted:=0;
    writeurec;
    for cnt:=1 to numusers do begin
      seek (ufile,cnt);
      read (ufile,u);
      if u.voted[tpn]<>0
        then
          begin
            u.voted[tpn]:=0;
            seek (ufile,cnt);
            write (ufile,u)
          end
    end;
    readurec;
    writestr ('[Force Topic for Voting]: *');
    t.mandatory:=yes;
    writestr ('[Adding Own Choices Available]:[CR/No]: *');
    if yes then begin
      writestr ('[Min. Level to Add Choices]: *');
      t.addlevel:=valu(input)
    end else t.addlevel:=maxint;
    seek (tofile,tpn-1);
    write (tofile,t);
    opentopic (tpn);
    writeln (^M^B'Enter choices, blank line to end.');
    cnt:=1;
    repeat
      buflen:=70;
      writestr (^R'Choice number '^P+strr(cnt)+^R': &');
      if length(input)>0 then begin
        cnt:=cnt+1;
        ch.numvoted:=0;
        ch.choice:=input;
        write (chfile,ch)
      end
    until (length(input)=0) or hungupon;
    writeln ('Topic created!');
    writelog (20,3,strr(tpn)+' ('+t.topicname+')')
  end;

  procedure maybeaddtopic;
  begin
    writestr ('Create new topic? *');
    if yes then addtopic
  end;

  procedure selecttopic;
  var ch:integer;
  begin
    input:=copy(input,2,255);
    if input='' then input:=' ';
    repeat
      if length(input)=0 then exit;
      ch:=valu(input);
      if ch>numtopics then begin
        ch:=numtopics+1;
        if issysop then maybeaddtopic;
        if numtopics<>ch then exit
      end;
      if (ch<1) or (ch>numtopics) then begin
        if input='?' then listtopics;
        writestr ('Topic # [?/List]:');
        ch:=0
      end
    until (ch>0) or hungupon;
    opentopic (ch)
  end;

  procedure deltopic;
  var un,cnt:integer;
      u:userrec;
      f:file;
      t:topicrec;
      tn:lstr;
  begin
    tn:=tn+^R+' Topic '^S+strr(curtopicnum)+^R' ('+curtopic.topicname+')';
    writestr ('Delete topic '+tn+'? *');
    if not yes then exit;
    writelog (20,1,tn);
    close (chfile);
    erase (chfile);
    cnt:=ioresult;
    for cnt:=curtopicnum to numtopics-1 do begin
      assign (f,votefn(cnt+1));
      rename (f,votefn(cnt));
      un:=ioresult;
      seek (tofile,cnt);
      read (tofile,t);
      seek (tofile,cnt-1);
      write (tofile,t)
    end;
    seek (tofile,numtopics-1);
    truncate (tofile);
    if curtopicnum<numtopics then begin
      writeln ('Adjusting user voting record...');
      writeurec;
      for un:=1 to numusers do begin
        seek (ufile,un);
        read (ufile,u);
        for cnt:=curtopicnum to numtopics do
          u.voted[cnt]:=u.voted[cnt+1];
        seek (ufile,un);
        write (ufile,u)
      end;
      readurec
    end;
    if numtopics>0 then opentopic (1)
  end;

  procedure removechoice;
  var n:integer;
      delled,c:choicerec;
      cnt:integer;
      u:userrec;
  begin
    n:=valu(copy(input,2,255));
    if (n<1) or (n>numchoices) then n:=0;
    while n=0 do begin
      writestr (^M'Choice to delete ['^U'?/List'^P']:');
      n:=valu(input);
      if n=0
        then if input='?'
          then listchoices
          else exit
    end;
    if (n<1) or (n>numchoices) then exit;
    seek (chfile,n-1);
    read (chfile,delled);
    for cnt:=n to numchoices-1 do begin
      seek (chfile,cnt);
      read (chfile,c);
      seek (chfile,cnt-1);
      write (chfile,c)
    end;
    seek (chfile,numchoices-1);
    truncate (chfile);
    curtopic.numvoted:=curtopic.numvoted-delled.numvoted;
    writecurtopic;
    write (^B^M'Choice deleted; updating user voting records...');
    writeurec;
    for cnt:=1 to numusers do begin
      seek (ufile,cnt);
      read (ufile,u);
      u.voted[curtopicnum]:=0;
      seek (ufile,cnt);
      write (ufile,u)
    end;
    readurec;
    writeln (^G^B'Done.')
  end;

  procedure nexttopic;
  begin
    if curtopicnum=numtopics
      then writeln ('No more topics!')
      else opentopic (curtopicnum+1)
  end;

  procedure voteonmandatory;
  var n:integer;
      t:topicrec;
  begin
    for n:=1 to numtopics do
      if urec.voted[n]=0 then begin
        seek (tofile,n-1);
        read (tofile,t);
        if t.mandatory then begin
          opentopic (n);
          clearbreak;
          nobreak:=true;
          writeln (^M'Mandatory voting topic: ['^S,t.topicname,^R']'^M);
       {  listchoices;  }
          getvote (true);
          if urec.voted[curtopicnum]<>0 then begin
            buflen:=1;
            writestr (^M'See results? [CR/No]: *');
            if yes then showresults
          end
        end
      end
  end;

  procedure sysopvoting;
  var q,dum:integer;
      firm:mstr;
  begin
    writelog (19,1,curtopic.topicname);
    repeat
      q:=menu ('Sysop Voting','VSYSOP','QACDR?');
      if hungupon then exit;
      case q of
        2:addtopic;
        3:dum:=addchoice;
        4:deltopic;
        5:removechoice;
        6:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ Voting Sysop Section                ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [A]  s');
writeln ('uAdd Topic                      ║HC║ [Cs');
writeln ('u]  Add Choice                     ║HC║ [s');
writeln ('uD]  Delete Topic                   ║Hs');
writeln ('uC║ [Q]  Quit                           s');
writeln ('u║HC║ [R]  Delete Choice           s');
writeln ('u       ║HC║ [?]  View This Menu   s');
writeln ('u              ║HC╚═══════════════════════════════A');
writeln ('C══════╝');
writeln;
pause;
           end;
      end
    until (q=1) or hungupon or (numtopics=0)
  end;

var q:integer;
label exit;
begin
  cursection:=votingsysop;
  opentopicdir;
  repeat
    if numtopics=0 then begin
      if getmandatory then goto exit;
      writeln ('No Voting Booths right now!');
      if not issysop
        then goto exit
        else
          begin
            writestr ('Make NEW Voting topic #1? *');
            if yes
              then addtopic
              else goto exit
          end
    end
  until (numtopics>0) or hungupon;
  if hungupon then goto exit;
  if getmandatory then begin
    voteonmandatory;
    goto exit
  end;
  opentopic (1);
  writehdr ('The Voting Booths');
  writeln ('Number of topics: ',numtopics);
  repeat
    writeln (^M'Active topic: ['^S,curtopicnum,^R'] ['^S,curtopic.topicname,^R']');
    q:=menu ('Voting','VOTING','QS_VLR#*%@');
    if hungupon then goto exit;
    if q<0
      then
        begin
          q:=-q;
          if q<=numtopics then opentopic (q);
          q:=0
        end
      else
        case q of
          2,8:selecttopic;
          3:nexttopic;
          4:getvote (false);
          5:listchoices;
          6:showresults;
          9:sysopvoting;
         10:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ Voting Section                      ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [L]  s');
writeln ('uList Choices                   ║HC║ [Qs');
writeln ('u]  Quit                           ║HC║ [s');
writeln ('uR]  Results                        ║Hs');
writeln ('uC║ [S]  Select Topic                   s');
writeln ('u║HC║ [V]  Vote on Topic           s');
writeln ('u       ║HC║ [%]  Voting Sysop Sects');
writeln ('uion           ║HC║ [#]  Open Topics');
writeln ('u #                   ║HC║ [*]  Sels');
writeln ('uect Topic                   ║HC║ [CR] s');
writeln ('uNext Topic                     ║HC║ [?s');
writeln ('u]  View This Menu                 ║HC╚═A');
writeln ('C════════════════════════════════════╝');
writeln;
pause;
           end;
        end
  until (q=1) or hungupon or (numtopics=0);
  if numtopics=0 then writeln (^B'No voting topics right now!');
  exit:
  close (tofile);
  close (chfile)
end;

begin
end.