program ProcessEnquete;
  { Copyright (c) 2001, Tom Verhoeff (TUE) }
  { Process data files for enquete }

{$B-,Q+,R+,S+}

const
  TEST      = False;
  ProgName  = 'procenq';

  Digits    = [ '0' .. '9' ];
  MinAnswer = 0; { for "not answered" }
  MaxAnswer = 9; { for defining arrays, actual max may be smaller }
  MaxQuestion = 100; { for defining tables, actual # may be smaller }

type
  Cardinal  = 0 .. MaxLongInt; { for TurboPascal }
  Answer = MinAnswer .. MaxAnswer; { actual answers 1 .. MaxAnswer }
  QuestionNr = 1 .. MaxQuestion;
  QuestionCount = array [ Answer ] of Cardinal;
    { for qc: QuestionCount, qc[i] = # i-answers to questions }
  QuestionData = record
    qt: String; { text of question }
    qna: 1 .. MaxAnswer; { # answers }
    qc: QuestionCount; { answer counts for question }
    end; { record }
  EnqueteData = record
    title: String;
    nq: 0 .. MaxQuestion; { # questions }
    ma: Answer; { maximum answer actually occurring }
    qd: array [ QuestionNr ] of QuestionData;
    nr: Cardinal; { # respondents processed }
    end; { record }

procedure TrimString ( var s: String );
  { remove leading and trailing spaces }
  begin

    while ( Length ( s ) <> 0 ) and ( s[1] = ' ' ) do begin
      Delete ( s, 1, 1 )
    end { while }

  ; while ( Length ( s ) <> 0 ) and ( s [ Length ( s ) ] = ' ' ) do begin
      Delete ( s, Length ( s ), 1 )
    end { while }

  end; { TrimString }

var
  ed: EnqueteData;

procedure InitQD ( var f: Text; var qd: QuestionData );
  { read question text and number of answers from f, zero all counts }
  var
    a: Answer;
  begin
    with qd do begin
      readln ( f, qna, qt )
    ; TrimString ( qt )

    ; for a := MinAnswer to qna do begin
        qc [ a ] := 0
      end { for a }

    end { with qd }
  end; { InitQD }

procedure InitED ( var ed: EnqueteData );
  var
    fileName: String;
    f: Text;
    q: QuestionNr;
    ior: Integer;
  begin
    fileName := ParamStr ( 1 )
  ; with ed do begin
    ; if TEST then write ( 'Reading questions from "', fileName, '"' )
    ; Assign ( f, fileName )
      {$I-}
    ; reset ( f )
    ; ior := IOResult
      {$I+}
    ; if ior <> 0 then begin { I/O error }
        writeln ( 'I/O error opening file "', fileName, '": ', ior:1 )
      ; Halt ( ior )
      end { if }

    ; readln ( f, title )
    ; if ParamCount > 1 then begin
        title := title + ': ' + ParamStr ( 2 )
      end { if }
    ; nq := 0
    ; ma := 0

    ; while not eof ( f ) do begin
        if eoln ( f ) then begin { skip empty lines }
          readln ( f )
        end { then }
        else begin
          Inc ( nq )
        ; InitQD ( f, qd[nq] )
        ; if qd[nq].qna > ma then begin
            ma := qd[nq].qna
          end { if }
        ; if TEST then write ( '.' )
        end { else }
      end { while }

    ; Close ( f )
    ; if TEST then writeln
    ; if TEST then writeln ( '# questions = ', nq )
    ; if TEST then writeln ( 'max answer  = ', ma )
    ; nr := 0
    end { with ed }
  end; { InitED }

function CharToAnswer ( c: Char ): Answer;
  begin
    CharToAnswer := ord ( c ) - ord ( '0' )
  end; { CharToAnswer }

function AnswerToChar ( a: Answer ): Char;
  begin
    AnswerToChar := chr ( ord ( '0' ) + a )
  end; { AnswerToChar }

procedure ProcessAnswer ( var f: Text; var qd: QuestionData );
  var
    c: Char;
    a: Answer;
  begin
    with qd do begin

      repeat
        read ( f, c )

      ; while c = '#' do begin { skip lines starting with comment char '#' }
          readln ( f )
        ; read ( f, c )
        end { while }

      until c in Digits

    ; a := CharToAnswer ( c )
      { What if a > qna ?  Should warn about this, but how? }
    ; Inc ( qc[a] )
    end { with qd }
  end; { ProcessAnswer }

procedure ProcessLine ( var f: Text {; glob ed} );
  { pre: not eof ( f ) }
  var
    q: QuestionNr;
  begin
    with ed do begin

      for q := 1 to nq do begin
        ProcessAnswer ( f, qd[q] )
      end { for q }

    ; Inc ( nr )
    ; readln ( f )
    end { with ed }
  end; { ProcessLine }

procedure ProcessFile ( var f: Text );
  begin

    while not eof ( f ) do begin
      if eoln ( f ) then
        readln ( f )
      else
        ProcessLine ( f )
    end { while }

  end; { ProcessFile }

function MaxCount ( const qd: QuestionData ): Cardinal;
  var
    a: Answer;
    result: Cardinal;
  begin
    with qd do begin
      result := 0

    ; for a := MinAnswer to qna do begin
        if qc [ a ] > result then begin
          result := qc [ a ]
        end { if }
      end { for a }

    ; MaxCount := result
    end { with qd }
  end; { MaxCount }

function RepString ( n: Cardinal; c: Char ): String;
  { ret: c^n }
  var
    result: String;
    i: Cardinal;
  begin
    result := ''

  ; for i := 1 to n do begin
      result := result + c
    end { for i }

  ; RepString := result
  end; { RepString }
    
function QDtoString ( const qd: QuestionData; scalefactor: Real ): String;
  var
    result: String;
    sep: String;
    tot: Cardinal; { # responses converted }
    n: Cardinal;
    a: Answer;
    i: Cardinal;
  begin
    with qd do begin
      result := ''
    ; sep := ''
    ; tot := 0

    ; for a := MinAnswer to qna do begin
        n := round ( scalefactor * ( tot + qc[a] ) ) - round ( scalefactor * tot )
      ; result := result + sep + RepString ( n, AnswerToChar ( a ) )
      ; { sep := '_' }
      ; tot := tot + qc[a]
      end { for a }

    ; Insert ( '_', result, 16 )
    ; Insert ( '_', result, 11 )
    ; Insert ( '_', result,  6 )
    ; QDtoString := result
    end { with qd }
  end; { QDtoString }

procedure WriteQD ( var f: Text; {const} qd: QuestionData;
    tot: Cardinal; maxans: Answer; verbose: Boolean );
  { pre: tot <> 0 }
  var
    a: Answer;
  begin
    with qd do begin
      if verbose then begin

        for a := MinAnswer to maxans do begin
          if a > qna then
            write ( f, ' ':12 )
          else { a <= qna } begin
            if qc[a] = 0 then
              write ( f, ' ':12 )
            else
              write ( f, ' ', qc[a]:4, '=', 100*qc[a]/tot:3:0, '%' )
          end { else }
        end { for a }

      end { if }
    ; write ( '  ', QDtoString ( qd, 1.0 ) )
    end { with qd }
  end; { WriteQD }

procedure WriteED ( var f: Text; const ed: EnqueteData; verbose: Boolean );
  var
    q: QuestionNr;
    a: Answer;
  begin
    with ed do begin
      writeln ( f, title )

    ; for q := 1 to nq do begin
        write ( f, q:2 )
      ; WriteQD ( f, qd[q], nr, ma, verbose )
      ; writeln ( f )
      end { for q }

    end { with ed }
  end; { WriteED }

procedure WriteQDhtml ( var f: Text; {const} qd: QuestionData;
    tot: Cardinal; maxans: Answer );
  { pre: tot <> 0 }
  var
    a: Answer;
    m: Cardinal; { max count }
  begin
    with qd do begin
      m := MaxCount ( qd )

    ; for a := MinAnswer to maxans do begin
        write ( f, '<td align="right" bgcolor=' )
      ; if a > qna then
          write ( f, '"">', ' ':12 )
        else { a <= qna } begin
          if qc[a] = 0 then
            write ( f, '"white">', '0':12 )
          else { qc[a] > 0 } begin
            if qc[a] = m then { max answer count }
              write ( f, '"red">' )
            else if 2 * qc[a] > m then { not max, but twice exceeds max }
              write ( f, '"yellow">' )
            else
              write ( f, '"lightblue">' )
          ; write ( f, qc[a], '=', 100*qc[a]/tot:3:0, '%' )
          end { else }
        end { else }
      ; write ( f, '</td>' )
      end { for a }

    ; write ( f, '<td bgcolor="lightgreen">', QDtoString ( qd, 20/tot ), '</td>' )
    end { with qd }
  end; { WriteQDhtml }

procedure WriteEDhtml ( var f: Text; const ed: EnqueteData );
  var
    q: QuestionNr;
    a: Answer;
  begin
    with ed do begin
      writeln ( f, '<html><head><title>Results for ', title, '</title></head>' )
    ; writeln ( f, '<body bgcolor="white">' )
    ; writeln ( f, '<h1>Results for <a href="marked-questionnaire.txt">', title, '</a></h1>' )

    ; writeln ( f, '<table border="1">' )
    ; writeln ( f, '<tr><th>Legend</th></tr>' )
    ; writeln ( f, '<tr><td># Respondents = ', nr:1, ' (<a href="responses.txt">raw data</a>)</td></tr>' )
    ; writeln ( f, '<tr><td>Answer 0 = no answer given</td></tr>' )
    ; writeln ( f, '<tr><td bgcolor="red">In red: maximum answer count for question</td></tr>' )
    ; writeln ( f, '<tr><td bgcolor="yellow">In yellow: not max, but twice answer count exceeds max</td></tr>' )
    ; writeln ( f, '</table></p>' )
    ; writeln ( f )

    ; writeln ( f, '<table border="1">' )
    ; write ( f, '<tr><th>#</th><th>Questions \ Answers</th>' )

    ; for a := MinAnswer to ma do begin
        write ( f, '<th>', a:1, '</th>' )
      end { for a }

    ; writeln ( f, '<th>Histogram (5%/digit)</th></tr>' )

    ; for q := 1 to nq do begin
        writeln ( f, '<tr><td align="right">', q:2, '</td>',
                         '<td>', qd[q].qt, '</td>' )
      ; WriteQDhtml ( f, qd[q], nr, ma )
      ; writeln ( f, '</tr>' )
      end { for q }

    ; writeln ( f, '</table><p>' )
    ; writeln ( f, '<address><a href="mailto:T.Verhoeff@tue.nl">T.Verhoeff@tue.nl</a></address>' )
    ; writeln ( f, '</body></html>' )
    end { with ed }
  end; { WriteEDhtml }

procedure UsageError;
  begin
    writeln ( 'Usage: ', ProgName, ' questions-file [ subtitle ]' )
  ; writeln ( '  stdin  = responses-file' )
  ; writeln ( '  stdout = html table with results' )
  ; writeln ( '  questions-file format: ' )
  ; writeln ( '    first line: title of questionnaire' )
  ; writeln ( '    subsequent non-empty lines: # answers, text of question' )
  ; writeln ( '  responses-file format' )
  ; writeln ( '    one respondent per line: digit per answer, spaces ignored' )
  ; writeln ( '    # marks comment to end-of-line' )
  ; Halt
  end; { UsageError }

begin
  if ( ParamCount < 1 ) or ( ParamCount > 2 ) then begin
    UsageError
  end { if }
; if TEST then writeln ( 'Tom''s Enquete Processor' )
; if TEST then writeln

; InitED ( ed )
; ProcessFile ( input )
{; WriteED ( output, ed, false )}
; WriteEDhtml ( output, ed )
end.