Dear AP Computer Science teacher:

The following are my (sometimes) annotated solutions to the AP Computer
Science free-response questions from 1998-1984.  You should feel free to use
them in whatever way you wish but realize that they are provided as a
resource for you, the teacher, and, as such, you are not authorized to
publish or distribute them beyond normal class use.  They also represent my
own work (in the context of being a Reader, Leader, and Chief Reader for
AP CS) and are not an official ETS document.

One way to best utilize these programs is to write your own solutions to the
various problems and then compare your solutions to what I have provided.
If you have any comments/questions, please feel free to either write or call
me at the address given above.  Thank you for your interest in AP.  I wish
you much success with your AP courses in this and ensuing years.

				Mark


                       SOLUTION - A Exam PROBLEM #1 (1998)


a)  function CodeIsValid(code : CodeType) : Boolean;
    var
        i : integer;
        valid : Boolean;
    
    begin
        if (code.length >= MINLEN) and (code.length <= MAXLEN - 2) then
            begin
                valid := True;
                for i := 1 to code.length do 
                    if not (code.charArray[i] in ['0'..'9', 'A'..'Z']) then
                        valid := False;
                CodeIsValid := valid
            end
        else
            CodeIsValid := False
    end;


b)  procedure AppendCheckSum(var code : CodeType);
    var
        i, sum : integer;
    
    begin
        if CodeIsValid(code) then
          with code do
              begin
                  sum := 0;
                  for i := 1 to length do 
                      if charArray[i] in ['0'..'9'] then
                          sum := sum + DigToInt(charArray[i]);
                  charArray[length + 1] := '-';
                  charArray[length + 2] := IntToDig(sum mod 10);
                  length := length + 2
              end
    end;
                       SOLUTION - A Exam PROBLEM #2 (1998)


a)  function BoxIndex(L : MailList; B : integer) : integer;
    var
        i : integer;
    
    begin
        with L do
            begin
                BoxIndex := 0;
                for i := 1 to NumBoxes do 
                    if MailArray[i].POBox = B then
                        BoxIndex := i
            end
    end;


b)  procedure ProcessMail(var infile : text; var L : MailList);
    var
        box, index : integer;
    
    begin
        while not eof(infile) do
            begin
                readln(infile, box);
                index := BoxIndex(L, box);
                if index <> 0 then
                    L.MailArray[index].MailCount := L.MailArray[index].MailCount + 1
                else
                    begin
                        L.NumBoxes := L.NumBoxes + 1;
                        L.MailArray[L.NumBoxes].POBox := box;
                        L.MailArray[L.NumBoxes].MailCount := 1
                    end
            end
    end;
               SOLUTION - A Exam PROBLEM #3/AB Exam PROBLEM #2 (1998)


a)  procedure ZeroRight(var A: LargeInt; N: integer);
    var
        i: integer;

    begin
        ResetRight(A.Digits);
        for i := 1 to N do
            begin
                SetCurrDigit(A.Digits, 0);
                MoveLeft(A.Digits);
            end;
    end;


b)  procedure AddPowerOfTen(var A: LargeInt; N: integer);
    var
        ten, addValue: LargeInt;
        i: integer;

    begin
        LargeConstruct(ten);
        IntToLarge(10, ten);
        LargeConstruct(addValue);
        IntToLarge(1, addValue);
        for i := 1 to N do
            LargeMultiply(addValue, ten, addValue);
        LargeAdd(A, addValue, A);    {handles both DerivedError and OverFlow}
        LargeDestroy(addValue);
        LargeDestroy(ten);
    end;


c)  procedure LargeRound(var A: LargeInt; N: integer);
    var
        i: integer;

    begin
        if A.Error <> NoError then
            A.Error := DerivedError
        else
            begin
                ResetRight(A.Digits);
                for i := 1 to N - 1 do
                    MoveLeft(A.Digits);
                if CurrDigit(A.Digits) >= 5 then
                    AddPowerOfTen(A, N);    {sets OverFlow if necessary}
                ZeroRight(A, N);            {leaves error flags unchanged}
            end;
    end;
               SOLUTION - A Exam PROBLEM #4/AB Exam PROBLEM #1 (1998)


a)  procedure SetRectBorder(var S : ScreenType; row, col : integer;
                            height, width : integer);

    var
        r, c : integer;
    
    begin
        for r := row to (row + height - 1) do 
            if r <= MAX then
                begin
                    S[r, col] := BLACK;
                    if (col + width - 1) <= MAX then
                        S[r, col + width - 1] := BLACK
                end;
        for c := col To (col + width - 1) do 
            if c <= MAX then
                begin
                    S[row, c] := BLACK;
                    if (row + height - 1) <= MAX then
                        S[row + height - 1, c] := BLACK
                end
    end;


    procedure SetRectBorder(var S : ScreenType; row, col : integer;
                            height, width : integer);
    
    var
        bottom, right, r, c : integer;
    
    begin
        if (col + width - 1) <= MAX then
            right := col + width - 1
        else
            right := MAX;
        if (row + height - 1) <= MAX then
            bottom := row + height - 1
        else
            bottom := MAX;

        for r := row to bottom do 
            S[r, col] := BLACK;
        if (col + width - 1) <= MAX then
            for r := row to bottom do 
                S[r, right] := BLACK;

        for c := col to right do 
            S[row, c] := BLACK;
        if (row + height - 1) <= MAX then
            for c := col To right Do 
                S[bottom, c] := BLACK
    end;


b)  procedure FillRect(var S : ScreenType; row, col : integer);
    
    begin
        if (row <= MAX) and (col <= MAX) then
            if S[row, col] = WHITE then
                begin
                    S[row, col] := BLACK;
                    FillRect(S, row - 1, col);
                    FillRect(S, row + 1, col);
                    FillRect(S, row, col - 1);
                    FillRect(S, row, col + 1)
                end
    end;


    procedure FillRect(var S : ScreenType; row, col : integer);
    var
        rpos, cpos, r, c : integer;
        border : Boolean;
    
    begin
        if (row <= MAX) and (col <= MAX) then
            begin
                rpos := row;
                repeat
                    rpos := rpos - 1
                until S[rpos, col] = BLACK;    {find the top border}
                rpos := rpos + 1;    {bump back inside rectangle}
                cpos := col;
                repeat
                    cpos := cpos - 1
                until S[rpos, cpos] = BLACK;   {find the left border}
                cpos := cpos + 1;    {top left corner inside rectangle}

                r := rpos;    {paint left to right, top to bottom}
                c := cpos;
                border := False;
                repeat
                    repeat
                        S[r, c] := BLACK;
                        c := c + 1;
                        if c <= MAX then
                            if S[r, c] = BLACK then
                                border := True
                    until (c > MAX) or border;        Equivalent form:
                    r := r + 1;                       r := r + 1;
                    c := cpos;                        c := cpos;
                    border := False;                  if r <= MAX then
                    if r <= MAX then                      border := S[r, c] = BLACK;
                        if S[r, c] = BLACK then
                            border := True
                until (r > MAX) or border
            end
    end;
                       SOLUTION - AB Exam PROBLEM #3 (1998)


a)  function FirstMin(L : ListType) : ListType;
    var
        small, temp : ListType;

    begin
        small := L;
        if L <> nil then
            begin
                temp := L^.next;
                while temp <> nil do
                    begin
                        if temp^.data < small^.data then
                            small := temp;
                        temp := temp^.next;
                    end;
            end;
        FirstMin := small;
    end;


b)  procedure RemoveNext(p : ListType);
    var
        temp : ListType;
    
    begin
        if p^.next <> nil then
            begin
                temp := p^.next;
                p^.next := p^.next^.next;
                dispose(temp)
            end
    end;


c)  procedure RemoveDupMins(L : ListType);
    var
        f, t : ListType;
    
    begin
        f := FirstMin(L);
        if f <> nil then
            begin
                t := f;
                while t^.next <> nil do
                    if t^.next^.data = f^.data then
                        RemoveNext(t)
                    else
                        t := t^.next
            end
    end;
                       SOLUTION - AB Exam PROBLEM #4 (1998)


a)  procedure SetSize(t : TreeType);
    
    begin
        if (t^.left = nil) and (t^.right = nil) then
            t^.size := 1
        else
            begin
                t^.size := 1;
                if t^.left <> nil then
                    begin
                        SetSize(t^.left);
                        t^.size := t^.size + t^.left^.size
                    end;
                if t^.right <> nil then
                    begin
                        SetSize(t^.right);
                        t^.size := t^.size + t^.right^.size
                    end
            end
    end;


    procedure SetSize(t : TreeType);
    var
        lval, rval : integer;
    
    begin
        if (t^.left = nil) and (t^.right = nil) then
            t^.size := 1
        else
            begin
                lval := 0;
                if t^.left <> nil then
                    begin
                        SetSize(t^.left);
                        lval := t^.left^.size
                    end;
                rval := 0;
                if t^.right <> nil then
                    begin
                        SetSize(t^.right);
                        rval := t^.right^.size
                    end;
                t^.size := lval + rval + 1
            end
    end;


b)  function FindKth(t : TreeType; k : integer) : integer;
    
    begin
        if t^.left = nil then
            if k = 1 then
                FindKth := t^.data
            else
                FindKth := FindKth(t^.right, k - 1)
        else
            if k = t^.left^.size + 1 then
                FindKth := t^.data
            else
                if k < t^.left^.size + 1 then
                    FindKth := FindKth(t^.left, k)
                else
                    FindKth := FindKth(t^.right, k - (t^.left^.size + 1))
    end;
                      SOLUTION - A Exam PROBLEM #1 (1997)


a)  function Translate(info : BoolArrayType; index : integer) : integer;
    var
        sum : integer;
 
    begin
	sum := 0;
        if info[index] then sum := sum + 4;
        if info[index + 1] then sum := sum + 2;
        if info[index + 2] then sum := sum + 1;
        Translate := sum
    end;


b)  procedure TranslateAll(info : BoolArrayType; var result : ResultArrayType);
    var
        index, count : integer;

    begin
        index := 1;
        for count := 1 to RESULTSIZE do
            begin
                result[count] := Translate(info, index);
                index := index + 3
            end
    end;


    procedure TranslateAll(info : BoolArrayType; var result : ResultArrayType);
    var
        count : integer;

    begin
        for count := 1 to RESULTSIZE do
            result[count] := Translate(info, ((count - 1) * 3) + 1);
    end;


    procedure TranslateAll(info : BoolArrayType; var result : ResultArrayType);
    var
        i, count : integer;

    begin
        i := 1;
        count := 1;
        while (i + 2) <= SIZE do
            begin
                result[count] := Translate(info, i);
                i := i + 3;
                count := count + 1
            end
    end;
                      SOLUTION - A Exam PROBLEM #2 (1997)


a)  procedure GradeDistribution(var gradeFile : text; var grades : GradeType);
    var
        g : char;

    begin
        with grades do
            begin
                count := 0;
                for g := 'A' to 'D' do
                    freq[g] := 0;
                while not eof(gradefile) do
                    begin
                        readln(gradefile, g);
                        freq[g] := freq[g] + 1;
                        count := count + 1
                    end
             end
    end;


b)  procedure PrintAllGrades (grades : GradeType);
    var
        g : char;
        i : integer;

    begin
        for g := 'A' to 'D' do
            begin
                for i := 1 to grades.freq[g] do
                    write(g);
                writeln
            end;
        writeln;
        writeln('Total Grades = ', grades.count)
    end;
              SOLUTION - A Exam PROBLEM #3/AB Exam PROBLEM #2 (1997)


a)  ErrorType = (NoError, Overflow, BadInput, DerivedError, DivideByZero);


b)  only ErrorWrite needs to be changed


c)  procedure LargeDiv(var dividend, divisor, quotient: LargeInt);
    var
        copydivisor, tempdiv, zero, one : LargeInt;

    begin
        if (dividend.Error <> NoError) or (divisor.Error <> NoError) then
            quotient.Error := DerivedError
        else
            begin
                LargeConstruct(zero);
                IntToLarge(0, zero);{OK, but redundant as LargeConstruct inits to 0}
                if LargeEqual(zero, divisor) then
                    quotient.Error := DivideByZero
                else
                    begin
                        LargeConstruct(copydivisor);
                        LargeAssign(copydivisor, divisor);
                        LargeConstruct(tempdiv);
                        LargeAssign(tempdiv, dividend);
                        LargeConstruct(one);
                        IntToLarge(1, one);
                        IntToLarge(0, quotient);  {Quotient is already initialized}
                        while LargeGreaterThan(tempdiv, copydivisor) or
                              LargeEqual(tempdiv, copydivisor) do
                        {alternate: while not LargeLessThan(tempdiv, copydivisor)}
                            begin
                                LargeSubtract(tempdiv, copydivisor, tempdiv);
                                LargeAdd(quotient, one, quotient);
                            end;
                        LargeDestroy(copydivisor);
                        LargeDestroy(tempdiv);
                        LargeDestroy(one);
                    end;
                LargeDestroy(zero);
            end;
    end;
              SOLUTION - A Exam PROBLEM #4/AB Exam PROBLEM #1 (1997)


a)  function NumSpaces(crossWord : CrossWordArray) : integer;
    var
        r, c, count : integer;

    begin
        count := 0;
        for r := 1 to MAXROW do
            for c := 1 to MAXCOL do
                if crossWord[r,c] = SPACE then count := count + 1;
        NumSpaces := count
    end;


b)  procedure PrintWordsInRow(crossWord : CrossWordArray; r : integer);
    var
        c : integer;

    begin
        c := 2;
        while c <= (MAXCOL - 1) do
            begin
                if (crossWord[r,c] <> SPACE) and (crossWord[r,c + 1] <> SPACE) then
                    begin
                         while crossWord[r,c] <> SPACE) do
                             begin
                                 write(crossWord[r,c]);
                                 c := c + 1
                             end;
                         writeln
                    end
                else
                    c := c + 1;
            end
    end;


    procedure PrintWordsInRow(crossWord : CrossWordArray; r : integer);
    var
        word : boolean;
        c : integer;

    begin
        word := false;
        for c := 2 to MAXCOL do
            begin
                if crossWord[r,c] <> SPACE then
                    if crossWord[r,c + 1] <> SPACE then
                        begin
                            word := true;
                            write(crossWord[r,c])
                        end
                    else if word then
                             begin
                                 writeln(crossWord[r,c]);
                                 word := false
                             end
            end
    end;


    procedure PrintWordsInRow(crossWord : CrossWordArray; r : integer);
    var
        word : boolean;
        c : integer;

    begin
        word := false;
        for c := 2 to MAXCOL do
            begin
                if crossWord[r,c] <> SPACE then
                    if crossWord[r,c + 1] <> SPACE then
                        begin
                            word := true;
                            write(crossWord[r,c])
                        end;
                if (crossWord[r,c] = SPACE) and word then
                    begin
                        writeln(crossWord[r,c - 1]);
                        word := false
                    end
            end
    end;


    procedure PrintWordsInRow(crossWord : CrossWordArray; r : integer);
    var
        c : integer;

    begin
        for c := 2 to MAXCOL - 1 do
            if (crossWord[r,c] <> SPACE) and ((crossWord[r,c+1] <> SPACE) or
                                              (crossWord[r,c-1] <> SPACE)) then
                begin
                    write(crossword[r,c]);
                    if crossWord[r,c+1] = SPACE then
                        writeln;
                end;
    end;


c)  procedure PrintAllWords(crossWord : CrossWordArray);
    var
        r, c : integer;

    begin
        for r := 1 to MAXROW do
            PrintWordsInRow(crossWord, r);
        for c := 1 to MAXCOL do
            PrintWordsInColumn(crossWord, c)
    end;
                      SOLUTION - AB Exam PROBLEM #3 (1997)


a)  function CountNum(t : TreeType; key : integer) : integer;

    begin
        if t = nil then CountNum := 0
        else
            if t^.info = key then
                CountNum := 1 + CountNum(t^.left, key) + CountNum(t^.right, key)
            else
                CountNum := CountNum(t^.left, key) + CountNum(t^.right, key)
    end;


b)  procedure Insert(p : TreeType; key : integer; direction : char);
    var
        t : TreeType;

    begin
        new(t);
        t^.info := key;
        if direction = 'R' then
            begin
                t^.left := nil;
                t^.right := p^.right;
                p^.right := t
            end
        else
            begin
                t^.right := nil;
                t^.left := p^.left;
                p^.left := t
            end
    end;


c)  procedure Separate(t : TreeType);

    begin
        if t <> nil then
            begin
                if t^.left <> nil then
                    if t^.left^.info = t^.info then
                        Insert(t, t^.info - 1, 'L');
                if t^.right <> nil) then
                    if t^.right^.info = t^.info then
                        Insert(t, t^.info - 1, 'R');
                Separate(t^.left);
                Separate(t^.right)
            end
    end;
                      SOLUTION - AB Exam PROBLEM #4 (1997)


a)  function Hash(name : NameType) : integer;

    begin
      hash := (ord(NthChar(name,1)) + ord(NthChar(name,NameLen(name))) mod SIZE) + 1
    end;


b)  function Lookup(table : HashTableType; name : NameType) : boolean;
    var
        index : integer;
        temp : ListType;
        found : boolean;

    begin
        index := Hash(name);
        temp := table[index];
        found := false;
        while (not found) and (temp <> Nil) do
            if NameEq(name, temp^.name) then
                found := true
            else
                temp := temp^.next;
        Lookup := found
    end;


  function Lookup(table : HashTableType; name : NameType) : boolean;
    var
        temp : ListType;

    begin
        temp := table[Hash(name)];
        if temp = nil then
            Lookup := false
        else
            begin
                while (temp^.next <> nil) and not NameEq(name, temp^.name) do
                    temp := temp^.next;
                Lookup := NameEq(name, temp^.name);
            end;
    end;
                      SOLUTION - A Exam PROBLEM #1 (1996)


a)  function LetterAverage(ints : IntArray; letters : LetterArray;
                           grade : char) : real;
    var
        count, sum, i : integer;

    begin
        count := 0;
        sum := 0;
        for i := 1 to NumGrades do
            if letters[i] = grade then
                begin
                    sum := sum + ints[i];
                    count := count + 1
                end;
        if count <> 0 then
            LetterAverage := sum/count
        else
            LetterAverage := 0
    end;


b)  procedure Averages(ints : IntArray;  letters : LetterArray);
    var
        grade : char;

    begin
        for grade := 'A' to 'D' do
            writeln (grade, ' ' , LetterAverage(ints, letters, grade):8:2)
    end;


    procedure Averages(ints : IntArray;  letters : LetterArray);
        {unrolls the loop - perfectly fine in this constrained problem}
    begin
        writeln ('A', ' ' , LetterAverage(ints, letters, 'A'):8:2);
        writeln ('B', ' ' , LetterAverage(ints, letters, 'B'):8:2);
        writeln ('C', ' ' , LetterAverage(ints, letters, 'C'):8:2);
        writeln ('D', ' ' , LetterAverage(ints, letters, 'D'):8:2);
    end;


Grading Notes:
1)  Many students forgot to protect the divide by 0 case in part a

2)  Many students had missing or incorrect calls to LetterAverage in part b
                       SOLUTION - A Exam PROBLEM #2 (1996)


a)  procedure DoCreate(var directory : DirType; var line : LineType);
    var
        nameToInsert, sizeWord, passwordToInsert, temp : StringType;
        position : integer;
        found : boolean;

        ...

        GetWord(line, passwordToInsert);
        if not EqualStr(passwordToInsert, ALLBLANKSTR) then
            begin
                GetWord(line, temp);
                if EqualStr(temp, ALLBLANKSTR) then
                    begin
                        AddNewFile(nameToInsert, NumVal(sizeWord),
                                   passwordToInsert, directory)
                    end
                else
                    begin
                        PrintErrMsg(EXTRAJUNK)
                    end
            end
        else
            begin    {there was no password}
                AddNewFile(nameToInsert, NumVal(sizeWord),
                           passwordToInsert, directory)
            end


    procedure DoCreate(var directory : DirType; var line : LineType);
        {Alternate method - only 1 check for blanks and 1 call to AddNewFile}
    var
        nameToInsert, sizeWord, passwordToInsert, temp : StringType;
        position : integer;
        found : boolean;

        ...

        GetWord(line, passwordToInsert);
        GetWord(line, temp);
        if not EqualStr(temp, ALLBLANKSTR) then
            begin
                PrintErrMsg(EXTRAJUNK)
            end
        else
            begin
                AddNewFile(nameToInsert, NumVal(sizeWord), passwordToInsert,
                           directory)
            end


b)  ChangeDeletion is the only one that must be modified; it does line parsing
               SOLUTION - A Exam PROBLEM #3/AB Exam PROBLEM #1 (1996)


a)  procedure PrintOneWeekLater(d : DateType);
    var
        i : integer;

    begin
        for i := 1 to 7 do
            AdvanceDate(d);
        PrintDate(d)
    end;


b)  function DaysApart(d1, d2 : DateType) : integer;
    var
        count : integer;

    begin
        count := 0;
        if DateEarlier(d1, d2) then
            while not DatesEqual(d1, d2) do
                begin
                    count := count + 1;
                    AdvanceDate(d1)
                end
        else
            while not DatesEqual(d1, d2) do
                begin
                    count := count + 1;
                    AdvanceDate(d2)
                end;
        DaysApart := count
    end;


    function DaysApart(d1, d2 : DateType) : integer;
        {Alternate method - checks earlier date and advances appropriately}
    var
        count : integer;

    begin
        count := 0;
        while not DatesEqual(d1, d2) do
            begin
                if DateEarlier(d1, d2) then
                    AdvanceDate(d1)
                else
                    AdvanceDate(d2);
                count := count + 1
            end;
        DaysApart := count
    end;


    function DaysApart(d1, d2 : DateType) : integer;
        {Another alternate method, using DateEarlier and DateLater}
    var
        count : integer;

    begin
        count := 0;
        while DateEarlier(d1, d2) do
            begin
                count := count + 1;
                AdvanceDate(d1)
            end;
        while DateLater(d1, d2) do
            begin
                count := count + 1;
                AdvanceDate(d2)
            end;
        DaysApart := count
    end;


    function DaysApart(d1, d2 : DateType) : integer;
        {A recursive approach}
    begin
        if not DatesEqual(d1, d2) then
            begin
                if DateEarlier(d1, d2) then
                    AdvanceDate(d1)
                else
                    AdvanceDate(d2);
                DaysApart := 1 + DaysApart(d1, d2)
            end
        else
            DaysApart := 0
    end;


c)
 i) PrintDate - with Alternative I you only need to do a lookup for month, 
                instead of a complicated translation scheme.

ii) DateLater - with Alternative II you just perform a single comparison of
                two integers instead of looking at year, then possibly month, 
                then possibly day.

ii) AdvanceDate - with Alternative II you increment one integer, no worry 
                  about having to check and possibly increment separate month 
                  and year fields
               SOLUTION - A Exam PROBLEM #4/AB Exam PROBLEM #2 (1996)


a)  function SumCross(m : MatrixType; r, c : integer) : integer;
    var
        sum, index : integer;

    begin
        sum := 0;
        for index := 1 to m.numcols do
            sum := sum + m.entries[r, index];
        for index := 1 to m.numrows do
            sum := sum + m.entries[index, c];
        SumCross := sum - m.entries[r, c]
    end;


b)  procedure RemoveCross(var m : MatrixType; r, c : integer);
    var
        row, col : integer;

    begin
        with m do
            begin
               for row := 1 to numrows do
                   for col := c to numcols - 1 do
                       entries[row,col] := entries[row,col + 1];
               numcols := numcols - 1;
               for col := 1 to numcols do
                   for row := r to numrows - 1 do
                       entries[row,col] := entries[row + 1,col];
               numrows := numrows - 1
            end
    end;


Grading Notes:
1)  Many students forgot to subtract overlap element in sum in part a

2)  Many students forgot to decrement the number of rows and columns in part b
                       SOLUTION - AB Exam PROBLEM #3 (1996)


a)  function ValsLess(t : TreeType; k : integer) : boolean;
    begin
        if t = nil then
            ValsLess := true
        else
            ValsLess := (t^.info < k) and ValsLess(t^.left, k) and
                        ValsLess(t^.right, k)
    end;


b)  function IsBST(t : TreeType) : boolean;
    begin
        if t = nil then
            IsBST := true
        else
            IsBST := ValsLess(t^.left, t^.info) and
                     ValsGreater(t^.right, t^.info) and
                     IsBST(t^.left) and IsBST(t^.right)
    end;


    function IsBST(t : TreeType) : boolean;
        {Uses an explicit if test}
    begin
        if t = nil then
            IsBST := true
        else
            if ValsLess(t^.left, t^.info) and ValsGreater(t^.right, t^.info) then
                IsBST := IsBST(t^.left) and IsBST(t^.right)
            else
                IsBST := false
    end;
                       SOLUTION - AB Exam PROBLEM #4 (1996)


a)  The following indicates the changes that are needed:

    DoCreate - declaration

    DoDelete - no change

    IsDeleted - both body and declaration

    Summarize - body


b)  procedure Search(nameToFind : StringType; directory : DirType;
                     var position : PositionType; var found : Boolean);
    begin
        found := false;
        position := directory;
        while (not found) and (position <> nil) do
            begin
                if EqualStr(nameToFind, position^.entry.name) then
                    begin
                         found := true
                    end
                else
                    begin
                         position := position^.next
                    end
            end
    end;


c)  procedure AddNewFile(nameToInsert : StringType; sizeToInsert : integer;
                         var directory : DirType);
    var
        temp : DirType;

    begin
        new(temp);
        temp^.entry.name := nameToInsert;
        temp^.entry.size := sizeToInsert;
        temp^.entry.isDeleted := not DELETED;   {false is OK here}
        temp^.next := directory;
        directory := temp
    end;
                      SOLUTION - A Exam PROBLEM #1 (1995)


a)  function CommaPosition(Name : StringType) : integer;
    var
        i : integer;

    begin
        CommaPosition := 0;
        for i := 1 to Name.Length do 
            if Name.Letters[i] = ',' then CommaPosition := i;
    end;


    function CommaPosition(Name : StringType) : integer;
        {alternate version}
    var
        i : integer;
        found : boolean;

    begin
        found := false;
        i := 1;
        while (i <= Name.Length) and not found do
            if Name.Letters[i] = ',' then
                found := true
            else
                i := i + 1;
        if found then
            CommaPosition := i
        else
            CommaPosition := 0;
    end;


b)  procedure PrintFirstLast(Name : StringType);
    var
        loc,i : integer;
    
    begin
        loc := CommaPosition(name);
        if loc <> 0 then
            begin
                for i := (loc + 1) to Name.Length do
                    write(Name.Letters[i]);
                write(' ');
                for i := 1 to (loc - 1) do
                    write(Name.Letters[i]);
            end
    end;
              SOLUTION - A Exam PROBLEM #2/AB Exam PROBLEM #1 (1995)


a)  procedure ReverseArray(var A : ArrayType);
        {manipulates loop index to determine correct array positions to swap}
    var
        i : integer;
    
    begin
        for i := 1 to (N div 2) do
            swap(A[i], A[(N - i) + 1])
    end;


    procedure ReverseArray(var A : ArrayType);
        {uses explicit variables to keep track of positions to swap}
    var
        up,down : integer;

    begin
        up := 1;
        down := N;
        while up <= (N div 2) do        or        while up < down do
            begin
                swap(A[up], A[down]);
                up := up + 1;
                down := down - 1
            end
    end;
    

    procedure ReverseArray(var A : ArrayType);
        {stores elements in temporary array and copies back in reverse order}
    var
        i,j : integer;
        temp : ArrayType;

    begin
        for i := 1 to N do
            temp[i] := A[i];
        j := 1;
        for i := N downto 1 do
            begin
                A[i] := temp[j];
                j := j + 1
            end
    end;


b)  procedure ReverseVertical (var M : array2dtype; Col : integer);
    var
        i : integer;

    begin
        for i := 1 to (N div 2) do
            swap(M[i,Col], M[(N - i) + 1,Col])
    end;


    procedure ReverseVertical (var M : array2dtype; Col : integer);
        {in addition to the alternates given for part a, some students decided
         to USE part A explicitly even though for this part it really doesn't
         work quite cleanly!}
    var
        i : integer;
        temp : ArrayType;

    begin
        for i := 1 to N do
            temp[i] := M[i,Col];
        ReverseArray(temp);
        for i := 1 to N do
            M[i,Col] := temp[i]
    end;


c)  procedure ReverseMatrix(var M : Array2DType);
    var
        i,j : integer;

    begin
       for i := 1 to N do
            ReverseArray(M[i]);
        for j := 1 to N do
            ReverseVertical(M, j)
    end;
              SOLUTION - A Exam PROBLEM #3/AB Exam PROBLEM #3 (1995)


a)
    CatType = (executable, code, data);
    EntryType = record
        name : StringType;
        size : integer;
        isDeleted : boolean;
        category : CatType;
    end;

    other possible options:
        category : StringType;
        category : char;
        category : (executable, code, data);


b)
    ...
    directory.numFiles := directory.numFiles + 1;
    directory.fileTable[directory.numFiles] := entry;
    ...

    or

    ...
    directory.numFiles := directory.numFiles + 1;
    directory.fileTable[directory.numFiles].name := entry.name;
    directory.fileTable[directory.numFiles].size := entry.size;
    directory.fileTable[directory.numFiles].isDeleted := entry.isDeleted;
    directory.fileTable[directory.numFiles].category := entry.category;
    ...

    Note: entry.isDeleted alternative assignments include false or not DELETED


c)
    ...
    GetLine(dirFile, line, gotALine);
    if gotALine then begin
        LinetoEntry(line, entry, ok);
        AddNewFile(entry, directory)
    end;
    ...

    Note: call to AddNewFile may or may not be guarded by checking the
          value of ok
                      SOLUTION - A Exam PROBLEM #4 (1995)


a)  function LengthOfSeq(s : SeqType) : integer;
    var
        count : integer;

    begin
        SetToFirst(s);
        count := 0;
        while not EndOfSeq(s) do begin
            Advance(s);
            count := count + 1
        end;
        LengthOfSeq:= count
    end;


b)  function LenOfIncreasing(s : SeqType) : integer;
    var
        count,oldvalue : integer;
        increasing : Boolean;

    begin
        oldvalue := CurrentValue(s);
        count := 1;
        Advance(s);
        increasing := true;
        while not EndOfSeq(s) and increasing do
            if CurrentValue(s) > oldvalue then begin
                oldvalue := CurrentValue(s);
                count := count + 1;
                Advance(s)
            end
            else
                increasing := false;
        LenOfIncreasing := count
    end;


    function LenOfIncreasing(s : SeqType) : integer;
        {alternate method}
    var
        count,oldvalue : integer;
        increasing : Boolean;

    begin
        count := 1;
        increasing := true;
        while not EndOfSeq(s) and increasing do begin
            oldvalue := CurrentValue(s);
            Advance(s);
            if not EndOfSeq(s) then
                if CurrentValue(s) > oldvalue then
                    count := count + 1
                else
                    increasing := false;
        end;
        LenOfIncreasing := count
    end;
                      SOLUTION - AB Exam PROBLEM #2 (1995)


a)  filling in the table left-to-right, top-to-bottom:

    O(1)    a single assignment to a priority list variable; e.g., p := nil
    O(1)    item is inserted at the front of the list
    O(N)    in the worst case, the item to be inserted will have the lowest
            integer priority and thus must be compared to every element
            in the list before being inserted as the last item
    O(N)    because the list is unsorted, to find the maximal item, every
            item in the list must be examined 


b)  Method 1

    procedure Insert(var p : ListType; info : DataType; pri : integer);
    var
        elt : ListType;

    begin
        new(elt);
        elt^.data := info;
        elt^.priority := pri;
        elt^.next := p;
        p := elt
    end;


    procedure Insert(var p : ListType; info : DataType; pri : integer);
        {alternate version}
    var
        elt : ListType;

    begin
        elt:= p;
        new(p);
        p^.data := info;
        p^.priority := pri;
        p^.next := elt
    end;


    procedure FindMax(p : ListType; var info : DataType; var pri : integer);

    begin
        info := p^.data;
        pri := p^.priority;
        p := p^.next;
        while p <> nil do
            begin
                if p^.priority > pri then
                    begin
                        info := p^.data;
                        pri := p^.priority
                    end;
                p := p^.next
            end
    end;


Method 2

    procedure Insert(var p : ListType;  info : DataType; pri : integer);
    var
        elt,curr,prev : ListType;

    begin
        new(elt);
        elt^.data := info;
        elt^.priority := pri;
        elt^.next := nil;
        if p = nil then    {empty list}
            p := elt
        else
            if pri > p^.priority then    {elt belongs at beginning of list}
                begin
                    elt^.next := p;
                    p := elt
                end
            else    {elt belongs either in middle of list, or at end} 
                begin
                    curr := p;
                    while (curr^.next <> nil) and (pri < curr^.priority) do
                        begin
                            prev := curr;
                            curr := curr^.next
                        end;
                    {post: curr is right after insertion point or right before}
                    if pri > curr^.priority then {elt belongs before curr}
                        begin
                            elt^.next := curr;
                            prev^.next:= elt
                        end
                    else
                            curr^.next:= elt
                end
    end;


    procedure FindMax(p : ListType; var info : DataType; var pri : integer);

    begin
        info := p^.data;
        pri := p^.priority
    end;
                      SOLUTION - AB Exam PROBLEM #4 (1995)


a)  function IsChild(first, second : TreeType) : boolean;

    begin
        if first = nil then
            IsChild := false
        else
            IsChild := (first^.left = second) or (first^.right = second)
    end;


b)  function IsDescendant(first,  second : TreeType) : boolean;

    begin
        if first = nil then
            IsDescendant := false
        else
            if IsChild(first, second) then
                IsDescendant := true
            else
                IsDescendant := IsDescendant(first^.left, second) or
                                IsDescendant(first^.right, second)
    end;


c)  procedure ChangeTree(var t : TreeType);
    var
        temp : TreeType;

    begin
        if t <> nil then
            if HasOneChild(t) then
                begin
                    temp := t;
                    if t^.left = nil then
                        t := t^.right
                    else
                        t := t^.left;
                    dispose(temp);
                    ChangeTree(t)    {many students forgot this call, which}
                                     {must be made since t has changed!}
                end
            else
                begin
                    ChangeTree(t^.left);
                    ChangeTree(t^.right)
                end
    end;


    procedure ChangeTree(var t : TreeType);
        {alternate version, avoids the need to call ChangeTree(t)}
    var
        temp : TreeType;

    begin
        if t <> nil then 
            begin
                ChangeTree(t^.left);
                ChangeTree(t^.right)
                if HasOneChild(t) then
                    begin
                        temp := t;
                        if t^.left = nil then
                            t := t^.right
                        else
                            t := t^.left;
                        dispose(temp);
                    end
            end
    end;


    procedure ChangeTree(var t : TreeType);
        {another alternate:  uses a while loop (correctly) to deal with
         the one-child case}
    var
        temp : TreeType;

    begin
        if t <> nil then
            begin
                while HasOneChild(t) do
                    begin
                        temp := t;
                        if t^.left = nil then
                            t := t^.right
                        else
                            t := t^.left;
                        dispose(temp)
                    end;
                ChangeTree(t^.left);
                ChangeTree(t^.right)
            end
    end;
                      SOLUTION - A Exam PROBLEM #1 (1994)


a)  function ArraySum (A : ArrayType; n : integer) : integer;
    var
        total,k : integer;

    begin
        total := 0;
        for k := 1 to n do
            total := total + A[k];
        ArraySum := total;
    end;    


b)  procedure ComputePartialSums(A : ArrayType; var B : ArrayType)
    var
        total,k : integer;

    begin
        total := 0;
        for k := 1 to MAX do
            begin      {invariant - total is the partial sum of A[1] .. A[k-1]}
                total := total + A[k];
                B[k] := total;               
            end;
    end;


    procedure ComputePartialSums(A : ArrayType; var B : ArrayType)
        {this version uses the previously calculated partial sum stored in B[k-1]}
    var
        k : integer;

    begin
        B[1] := A[1];
        for k := 2 to MAX do
            B[k] := B[k-1] + A[k];               
    end;


    procedure ComputePartialSums(A : ArrayType; var B : ArrayType)
        {in a fit of procedural abstraction, students decided to call part a(!)}
    var
        k : integer;

    begin
        for k := 1 to MAX do
            B[k] := Arraysum(A,k);
    end;


    procedure ComputePartialSums(A : ArrayType; var B : ArrayType)
        {and then there were the students who chose to re-write part A in-line}
    var
        total,k,j : integer;

    begin                                   begin
        for k := 1 to MAX do                    for k := 1 to MAX do
            begin                                   B[k] := 0;
                total := 0;                     for k := 1 to MAX do
                for j := 1 to k do                  for j := 1 to k do
                    total := total + A[j];              B[k] := B[k] + A[j];
                B[k] := total;              end;
            end;
    end;
          SOLUTION - A Exam PROBLEM #2/AB Exam PROBLEM #1 (1994)


a)  procedure CountStudents(var TestScores : text; var NumStudents : integer);

    var
        numScores,k : integer;
        studentID : integer;

    begin
        NumStudents := 0;
        while not eof(TestScores) do
            begin
                NumStudents := NumStudents + 1;
                readln(TestScores,studentID,numScores);
                for k := 1 to numScores do    {skip test scores}
                    readln(TestScores);
            end;
    end;


    procedure CountStudents(var TestScores : text; var NumStudents : integer);
        {this version only counts each line with a leading integer > 100}
    var
        numScores,k : integer;
        studentID : integer;

    begin
        NumStudents := 0;
        while not eof(TestScores) do
            begin
                readln(TestScores,studentID);
                if (studentID > 100) then
                    NumStudents := NumStudents + 1;
            end;
    end;


b)  procedure GetClassAvg(var TestScores : text; var ClassAvg : real);

    var
        total,numScores,k : integer;
        numStudents,studentID,score : integer;
        totalAvg : real;

    begin
        numStudents := 0;
        totalAvg := 0.0;
        while not eof(TestScores) do
            begin
                numStudents := numStudents + 1;
                readln(TestScores,studentID,numScores);
                total := 0;
                for k := 1 to numScores do    {average test scores}
                    begin
                        readln(TestScores,score);
                        total := total + score;
                    end;
                totalAvg := totalAvg + total/numScores;
            end;
        ClassAvg := totalAvg/numStudents;
    end;


    procedure GetClassAvg(var TestScores : text; var ClassAvg : real);
        {uses a "finite state machine" approach; the value of num determines
         whether the value read is an id (and thus the average for the student
         is calculated and accumulated, the count of students is incremented
         and the individual count and total are reset to 0) or a score (and
         thus is accumulated and the individual count is incremented).  This
         is a natural extension of the second version to part a given above.}

    var
        total,numScores,k : integer;
        numStudents,studentID,score : integer;
        totalAvg : real;

    begin
        totalAvg := 0.0;
        numStudents := 0;
        total := 0;
        numScores := 0;
        readln(TestScores, num);
        while not eof(TestScores) do
            begin
                readln(TestScores,num);
                if num > 100 then
                    begin
                        totalAvg := totalAvg + total/numScores;
                        numStudents := numStudents + 1;
                        total := 0;
                        numScores := 0;
                    end
                else
                    begin
                        total := total + num;
                        numScores := numScores + 1;
                    end;
            end;
        numStudents := numStudents + 1;
        totalAvg := totalAvg + total/numScores;
        ClassAvg := totalAvg/numStudents;
    end;
                      SOLUTION - A Exam PROBLEM #3 (1994)


a)  function RectInScreen(S : ScreenType; R : RectangleType) : boolean;

    begin
        if (1 <= R.Row) and (R.Row + R.Height - 1 <= S.NumRows) and
           (1 <= R.Col) and (R.Col + R.Width - 1 <= S.NumCols) then
            RectInScreen := true
        else
            RectInScreen := false;
    end;


    function RectInScreen(S : ScreenType; R : RectangleType) : boolean;
        {uses direct assignment instead of if/else}
    begin
        RectInScreen := (1 <= R.Row) and (R.Row + R.Height - 1 <= S.NumRows)
                        and (1 <= R.Col) and (R.Col + R.Width - 1 <= S.NumCols)
    end;


    function RectInScreen(S : ScreenType; R : RectangleType) : boolean;
        {easier to think about?}
    begin
        RectInScreen := true;
        if (R.Row < 1) or (R.Col < 1) or (R.Row + R.Height - 1 > S.NumRows) or
           (R.Col + R.Width - 1 > S.NumCols) then
            RectInScreen := false;
    end;


b)  procedure BlackOut(var S : ScreenType; R : RectangleType);

    var
        j,k : integer;

    begin
        if RectInScreen(S,R) then
            for j := R.Row to R.Row + R.Height - 1 do
                for k := R.Col to R.Col + R.Width - 1 do
                    S.Pixels[j][k] := false;
    end;


Grading Notes:

1)  Many students had off-by-one-bugs in the row+height/col+width calculations.
          SOLUTION - A Exam PROBLEM #4/AB Exam PROBLEM #2 (1994)


a)  function StringsEqual(s,t : StringType) : boolean;
        {while allows early exit upon non-matching pair}
    var
        k,len : integer;
        tentativelyEqual : boolean;

    begin
        tentativelyEqual := false;
        if Length(s) = Length(t) then
            begin
                tentativelyEqual := true;
                k := 1;
                len := Length(s);
                while (k <= len) and (tentativelyEqual) do
                    begin
                        if KthChar(s,k) <> KthChar(t,k) then
                            tentativelyEqual := false;
                        k := k + 1;
                    end;
            end;
        StringsEqual := tentativelyEqual ;
    end;


    function StringsEqual(s,t : StringType) : boolean;
        {alternate method, using a for loop instead of a while}
    var
        k : integer;
        tentativelyEqual : boolean;

    begin
        tentativelyEqual := false;
        if Length(s) = Length(t) then
            begin
                tentativelyEqual := true;
                for k := 1 to Length(s) do
                    if KthChar(s,k) <> KthChar(t,k) then
                        tentativelyEqual := false;
            end;
        StringsEqual := tentativelyEqual;
    end;


b)  procedure SubString(s : StringType; First,Size : integer; 
                        var Result : StringType);
    var
        k,last : integer;
    begin
        MakeEmpty(Result);
        Last := First + Size - 1;
        if Last > Length(s) then    {many students missed this check}
            Last := Length(s);
        for k := First to Last do
            AppendChar(Result,KthChar(s,k));
    end;


c)  function FirstOccur(Source,Target : StringType) : integer;

    var
        len,k,location : integer;
        attempt : StringType;

    begin
        location := 0;
        len := Length(target);
        k := 1;
        while (k <= Length(source)) and (location = 0) do
            begin
                SubString(Source,k,len,attempt);
                if StringsEqual(Target,attempt) then
                    location := k;
                k := k + 1;
            end;
        FirstOccur := location;
    end;


    function FirstOccur(Source,Target : StringType) : integer;
        {alternate solution uses two loops, no SubString}
    var
        len,j,k,location : integer;
        okSoFar : boolean;

    begin
        location := 0;
        len := Length(Target);
        j := 1;
        while (j <= Length(Source) - len + 1) and (location = 0) do
            begin
                okSoFar := true;
                for k := 1 to len do
                    if KthChar(Source,j+k-1) <> KthChar(Target,k) then
                        okSoFar := false;                
                if okSoFar then
                    location := j;
                j := j + 1;
            end;
        FirstOccur := location;
    end;
                      SOLUTION - AB Exam PROBLEM #3 (1994)


a)  procedure PrintAll(T : TreeType);

    begin
        if T <> nil then
            begin
                PrintAll(t^.left); {any order of PrintAll/PrintName is ok}
                PrintName(t^.name);
                PrintAll(t^.right);
            end;
    end;


b)  function Location(T : TreeType; N : NameType) : TreeType;

    var
        loc : TreeType;

    begin
        if T = nil then
            loc = nil
        else
            if EqualName(T^.Name,N) then
                loc := T
            else
                begin
                    loc := Location(T^.left,N);
                    if loc = nil then  {must remember to guard the second call}
                        loc := Location(T^.right,N);    {or you will overwrite}
                end;                  {the value returned from the left branch}
        Location := loc;
    end;


c)  procedure PrintSubTree(T : TreeType; N : NameType);

    var
        loc : TreeType;

    begin
        loc := Location(T,N);
        if loc = nil then
            writeln('name not in tree')
        else
            if (loc^.left = nil) and (loc^.right = nil) then
                writeln('none')
            else
                begin
                    PrintAll(T^.left);
                    PrintAll(T^.right);   
                end;
    end;


Grading Notes [part b]:

1)  Watch the use of the function name as a local variable.

Grading Notes [part c]:

1)  Watch the use of "Location" as a local, i.e., "Location(T,N)^.left".
                      SOLUTION - AB Exam PROBLEM #4 (1994)


a)  procedure MergeSort(var P : ListType);

    var
        aux : ListType;

    begin
        if P <> nil then
            if P^.next <> nil then    {must guard against the 1-node case}
                begin                 {or you could recur forever on that node}
                    Split(P,aux);
                    MergeSort(P);
                    MergeSort(aux);
                    Merge(P,aux);
                end;
    end;


    procedure MergeSort(var P : ListType);
        {alternate version}
    var
        aux : ListType;

    begin
        Split(P,aux);
        if (p <> nil) and (aux <> nil) then
            begin
                MergeSort(P);
                MergeSort(aux);
            end;
        Merge(P,aux);
    end;


b)  O(k-squared); justification:  k + (k-1) + (k-2) + ... + 1 ==> O(k**2)


c)  procedure Split(var A : ListType; var B : ListType);
        {counts the nodes; traverses to middle (watch off-by-one-bug); relinks}
    var
        trav : ListType;
    
    begin
        trav := A;
        count := 0;    {count nodes in list A}
        while trav <> NIL do
            begin
                count := count + 1;
                trav := trav^.next;
            end;

        trav := A;    {find middle node}
        for k := 1 to count div 2 - 1 do
            trav := trav^.next;

        B := trav^.next;    {set B and unlink to form two lists}
        trav^.next := NIL;
    end;


    procedure Split(var A : ListType; var B : ListType);
        {link alternate nodes to list A and list B (like dealing cards)}
    var
        trailA,trailB : ListType;

    begin
        trailA := A;
        trailB := A^.next;
        B := trailB;
        while (trailA <> nil) and (trailB <> nil) do
            begin
                trailA^.next := trailB^.next;
                trailA := trailA^.next;
                if trailA <> nil then
                    begin
                        trailB^.next := trailA^.next;
                        trailB := trailB^.next;
                    end;
            end;
    end;


    procedure Split(var A : ListType; var B : ListType);
        {advance once, advance twice, cha-cha}
    var
        trav,trail : ListType;

    begin
        trav := A;
        trail := A;
        while trav^.next <> nil do
            begin  {trav moves ahead two nodes for every node that trail moves}
                trav := trav^.next;
                if trav^.next <> NIL then
                    begin
                        trav := trav^.next;
                        trail := trail^.next
                    end;
            end;
    
        {assertion:  at end of loop, trail references middle element}

        B := trail^.next;    {set B and unlink so two lists are formed}
        trail^.next := NIL;
    end;
                      SOLUTION - A Exam PROBLEM #1 (1993)


a)  function posofmax(a : arraytype) : integer;
   
    var
        maxindex, i : integer;
     
    begin
        maxindex := 1;
        for i := 2 to n do 
            if a[i] > a[maxindex] then
                maxindex := i;
        posofmax := maxindex
    end;


b)  function posof2nd (a : arraytype) : integer;
       
    var
        maxindex, secindex, i : integer;
     
    begin
        maxindex := posofmax(a);
        if maxindex = 1 then
            secindex := 2
        else
            secindex := 1;
        for i := 1 to n do 
            if (a[i] > a[secindex]) and (i <> maxindex) then
                secindex := i;
        posof2nd := secindex
    end ;


c)  procedure zerobetween (var a : arraytype) ;
    
    var
       maxindex, secindex, i : integer;
     
    begin
       maxindex := posofmax(a);
       secindex := posof2nd(a);
       if secindex < maxindex then      {this if/else is not really necessary}
           for i := (secindex + 1) to (maxindex - 1) do  {as only 1 loop will}
              a[i] := 0                                  {ever execute anyway}
       else
           for i := (secindex - 1) downto (maxindex + 1) do 
              a[i] := 0
    end;


Common Mistakes [part a]:
1)  Using PosOfMax as a local variable
2)  Index/value confusion (e.g., returning a[maxindex] instead of maxindex)
3)  Failure to properly init a maximum value (e.g., using a particular value,
    like 0, instead of using the first element of the array)
4)  Comparing a[i] and a[i+1] instead of a[i] against the current max

Grading Notes [part b]:
1)  Far and away, the most common error was failing to correctly initialize
    the secondmax index (it was usually just initialized to 1)

Grading Notes [part c]:
1)  Many different off by one errors were made.  Watch those boundary cases!
          SOLUTION - A Exam PROBLEM #2/AB Exam PROBLEM #2 (1993)


a)  procedure pushright(var a : arraytype; m : integer);
       
    var
        i : integer;
     
    begin
        for i := ncols downto 2 do 
            a[i] := a[i-1];
        a[1] := m
    end;
    

b)  procedure pushalong(var b : array2dtype; m : integer);
        {fairly typical 2-d array code}
    var
        row, col : integer;
     
    begin
        for row := nrows downto 2 do 
            begin
                for col := ncols downto 2 do 
                    b[row,col] := b[row,col-1];
                b[row,1] := b[row-1,ncols] 
            end;
        pushright(b[1],m)
    end;


    procedure pushalong(var b : array2dtype; m : integer);
        {a typical use of pushright, explicitly holding the "push" values}
    var
        hold, hold2, row : integer;
     
    begin
        hold := b[1,ncols];
        pushright(b[1],m);
        for row := 2 to nrows do 
            begin
                hold2 := b[row,ncols];
                pushright(b[row],hold);
                hold := hold2
            end
    end;


    procedure pushalong(var b : array2dtype; m : integer);
        {an elegant use of pushright, in essence, cleanly extending the
         1-d algorithm to the 2-d situation}
    var
        row : integer;
     
    begin
        for row := nrows downto 2 do 
            pushright(b[row],b[row-1,ncols]);
        pushright(b[1],m)
    end;


Grading Notes:
1)  A common error was propagating the same value down the array, in both
    part A and B.
          SOLUTION - A Exam PROBLEM #3/AB Exam PROBLEM #1 (1993)


a)  procedure movefirsttolast(var s : stringtype);

    var
        first : char;

    begin
        first := head(s);
        removehead(s);
        appendchar(s,first)
    end;


    procedure movefirsttolast(var s : stringtype);
        {this version eliminates the local variable}     
    begin
        appendchar(s,head(s));
        removehead(s)
    end;


b)  procedure removeleadingvowels(var s : stringtype);
        {typical while-loop solution}
    var
        done : boolean;
    
    begin
        done := false;
        while not isemptystring(s) and not done do
            if isvowel(head(s)) then
                removehead(s)
            else
                done := true
    end;


    procedure removeleadingvowels(var s : stringtype);
        {canonical recursive solution}
    begin
        if not isemptystring(s) then
            if isvowel(head(s)) then
                begin
                    removehead(s);
                    removeleadingvowels(s)
                end
    end;


c)  procedure removeallvowels(var s : stringtype);
       
    var
        marker : char;
     
    begin
        if not isemptystring(s) then
            begin
                removeleadingvowels(s);
                if not isemptystring(s) then
                    begin
                        marker := head(s);
                        movefirsttolast(s);
                        while head(s) <> marker do
                            if isvowel(head(s)) then
                                removehead(s)    { or removeleadingvowels(s) }
                            else
                                movefirsttolast(s)
                    end
            end
    end;

    The if-else in the WHILE HEAD(S) <> MARKER loop could be replaced with
    the following:
        begin
            removeleadingvowels(s);
            movefirsttolast(s)
        end;


Grading Notes:

1)  In part b, be careful with Pascal's full evaluation of boolean
    expressions; i.e., in the while-loop solution, you could not write
            while not isemptystring(s) and isvowel(head(s)) do
    because if the string were empty, isvowel(head(s)) would still be called
    and head(s) is not allowed to be called when s is empty (check the
    precondition on function head).  Many students made this mistake!
2)  Do NOT violate the abstraction by assuming a particular implementation
    for strings (e.g., using a particular sentinel value in part c).  In
    general, you should strive to teach your students to use packages of
    routines ONLY through the interfaces which are provided.  It is only in
    this manner that they will be successful on "abstraction" questions.
                      SOLUTION - A Exam PROBLEM #4 (1993)


a)  function overlap(a, b : intervaltype) : boolean;
        {typical solution isolating the cases}
    begin
        if ( (a.low <= b.low) and (a.high >= b.high) or
             (b.low <= a.low) and (b.high >= a.high) ) then
            overlap := true
        else
            overlap := false
    end;


    function overlap(a, b : intervaltype) : boolean;
        {this version eliminates the redundant if-else}
    begin
        overlap := ( (a.low <= b.low) and (a.high >= b.high) or
                     (b.low <= a.low) and (b.high >= a.high) )
    end;


    function overlap(a, b : intervaltype) : boolean;
        {my favorite - if one's high is < the other's low, they can't
                       overlap, so negate that and you've got it}
    begin
        overlap := not ( (a.high < b.low) or (b.high < a.low) )
    end;


b)  procedure dounion(a, b : intervaltype; var newint : intervaltype);

    begin
        if a.low < b.low then
            newint.low := a.low
        else
            newint.low := b.low;
        if a.high > b.high then
            newint.high := a.high
        else
            newint.high := b.high
    end;


c)  procedure addinterval(addint : intervaltype; coll : colltype;
                          var newcoll : colltype) ;
        {this version grows the union interval in the first position of
         the new collection, starting with the new interval, addint and
         adds the non-overlapping intervals all in one pass}
    var
        index : integer;
     
    begin
        newcoll.count := 1;
        newcoll.intvls[1] := addint;
        for index := 1 to coll.count do 
            if overlap(newcoll.intvls[1], coll.intvls[index]) then
                dounion(newcoll.intvls[1], coll.intvls[index], newcoll.intvls[1])
            else
                begin
                    newcoll.count := newcoll.count + 1;
                    newcoll.intvls[newcoll.count] := coll.intvls[index] 
                end
    end;


    procedure addinterval(addint : intervaltype; coll : colltype;
                          var newcoll : colltype);
        {this version first grows the union interval and then makes another
         pass to add non-overlapping intervals to the new collection}
    var
        index : integer;

    begin
        newcoll.count := 1;
        newcoll.intvls[1] := addint;
        for index := 1 to coll.count do 
            if overlap(newcoll.intvls[1], coll.intvls[index]) then
                dounion(newcoll.intvls[1], coll.intvls[index], newcoll.intvls[1]);
        for index := 1 to coll.count do 
            if not overlap(newcoll.intvls[1], coll.intvls[index]) then
                begin
                    newcoll.count := newcoll.count + 1;
                    newcoll.intvls[newcoll.count] := coll.intvls[index] 
                end
    end;


Grading Notes [part a]:

1)  Make sure a value is assigned to the function.
2)  Watch the = case (make sure it's captured).

Grading Notes [part c]:

1)  There must be some attempt to "grow" a union interval and this interval
    must be placed somewhere in the new collection.
                      SOLUTION - AB Exam PROBLEM #3 (1993)


a)  function listsum(l : listtype) : listtype;
        {this version creates the return node and sums in that node}
    var
        sumptr : listtype;
     
    begin
        new(sumptr);
        sumptr^.info := 0;
        sumptr^.next := nil;
        while l <> nil do
            begin
                sumptr^.info := sumptr^.info + l^.info;
                l := l^.next
            end;
        listsum := sumptr
    end;
    
    
    function listsum(l : listtype) : listtype;
        {this version sums into a local first (canonical list sum code), then
         creates the node and assigns the computed sum and returns the node}
    var
        sumptr : listtype;
        sum : integer;
    
    begin
        sum := 0;
        while l <> nil do
            begin
                sum := sum + l^.info;
                l := l^.next
            end;
        new(sumptr);
        sumptr^.info := sum;
        sumptr^.next := nil;
        listsum := sumptr
    end;


b)  function listoflistsums(m : listoflisttype) : listtype;
        {a straightforward iterative solution}
    var
        temp : listtype;
     
    begin
        if m = nil then
            listoflistsums := nil
        else
            begin
                temp := listsum(m^.ptr);
                listoflistsums := temp;
                m := m^ .next;
                while m <> nil do
                    begin
                        temp^.next := listsum(m^.ptr);
                        temp := temp^.next;
                        m := m^.next
                    end
            end
    end;
    
    
    function listoflistsums(m : listoflisttype) : listtype;
        {an alternative iterative solution}
    var
        temp : listoflisttype;
        newsum,prev : listtype;
     
    begin
        temp := m;
        listoflistsums := nil;
        while temp <> nil do
            begin
                newsum := listsum(temp^.ptr);
                if temp = m then
                    listoflistsums := newsum
                else
                    prev^.next := newsum;
                prev := newsum;
                temp := temp^.next
            end
    end;
    
    
    function listoflistsums(m : listoflisttype) : listtype;
        {a terse recursive solution - we didn't see many of these!}
    var
       temp : listtype;
     
    begin
       if m = nil then
           listoflistsums := nil
       else
           begin
               temp := listsum(m^.ptr);
               temp^.next := listoflistsums(m^.next);
               listoflistsums := temp
           end
    end;


Common Mistakes [part a]:

1)  Failure to allocate memory for the return node (via new).
2)  Failure to sum all nodes (e.g., going to list^.next = nil).
3)  Using ListSum as a local variable (watch this - it's a real common
    error, especially since there's no compiler on the exam!)
                      SOLUTION - AB Exam PROBLEM #4 (1993)


a)  function ptrtomax(t : treetype) : treetype;
        {an iterative solution}         
    begin
        while t^.right <> nil do
            t := t^.right;
        ptrtomax := t
    end;

    function ptrtomax(t : treetype) : treetype;
        {a straightforward recursive solution}
    begin
        if t^.right = nil then
            ptrtomax := t
        else
            ptrtomax := ptrtomax(t^.right)
    end;


b)  procedure deletemax(var t : treetype);
        {this version makes each test explicit}
    var
        max : treetype;
     
    begin
        max := ptrtomax(t);
        if max = t then
            begin
                t := t^.left;
                if t <> nil then
                    t^.parent := nil;
                dispose(max)
            end
        else
            begin
                max^.parent^.right := max^.left;
                if max^.left <> nil then
                    max^.left^.parent := max^.parent;
                dispose(max)
           end
    end;


    procedure deletemax(var t : treetype);
        {The above solution can be reduced to the following}
    var
        max : treetype;
     
    begin
        max := ptrtomax(t);
        if max^.parent = nil then
            t := max^.left
        else
            max^.parent^.right := max^.left;
        if max^.left <> nil then
            max^.left^.parent := max^.parent;
        dispose(max)
    end;


c)  procedure deleteleaves(var t : treetype);
        {a straightforward recursive solution}
    begin
        if t <> nil then
            if (t^.left = nil) and (t^.right = nil) then
                begin
                    dispose(t);
                    t := nil
                end
            else
                begin
                    deleteleaves(t^.left);
                    deleteleaves(t^.right)
                end
    end;


Grading Notes [part a]:

1)  Watch the uninitialized local variable used to traverse to the right.
2)  Typical error is while t <> nil

Grading Notes [part b]:

1)  Watch the nil checks and remember that the root's parent is nil and that
    the max might be a leaf (and thus have it's left = nil)!

Grading Notes [part c]:

1)  Make sure nil is checked separately from the leaf check (full evaluation
    rears its ugly head again).
2)  Make sure that the pointer is set to nil after freeing the memory
    (via dispose).
3)  There was no need to look at parent information in this part.
                      SOLUTION - A Exam PROBLEM #1 (1992)


a)  function numvotes(results : resultstype; c : integer) : integer;

    var
	sum, i : integer;
    
    begin
	sum := 0;
	for i := 1 to numdistricts do
	    sum := sum + results[c,i];
	numvotes := sum
    end;


b)  function winner(results : resultstype) : integer;

    var
	maxvotes,currvotes,row : integer;
    
    begin
	winner := 1;
	maxvotes := numvotes(results,1);
	for row := 2 to numcandidates do
	    begin
    		currvotes := numvotes(results,row);
    		if currvotes > maxvotes then
    		    begin
    			winner := row;
    			maxvotes := currvotes
    		    end
    	    end
    end;


Grading Notes [part b]:

1)  Watch init of maxvotes.
2)  Make sure the state variable (maxvotes) is updated when necessary.
3)  Make sure the index is stored and not just the number of votes.
                      SOLUTION - A Exam PROBLEM #2 (1992)


procedure printmostfrequent(var infile : text);

var
    freq : array[0..100] of integer;
    i,grade,currmax : integer;

begin
    for i := 0 to 100 do
	freq[i] := 0;

    while not eof(infile) do
	begin
	    readln(infile,grade);
	    freq[grade] := freq[grade] + 1
	end;

    currmax := 0;
    for i := 0 to 100 do
	if freq[i] > currmax then
	    currmax := freq[i];

    for i := 0 to 100 do
	if freq[i] = currmax then
	    write(output, i:4);
    writeln(output)
end;


Grading Notes:

1)  You really want a frequency counter here, not an array of grades.
2)  Make sure array starts at 0.
3)  As in all "findmax" problems, make sure state variable is initialized and
    updated correctly.
          SOLUTION - A Exam PROBLEM #3/AB Exam PROBLEM #1 (1992)


a)  procedure findcommonletter(w1,w2 : wordtype; var pos1,pos2 : integer);

    var
        i,j : integer;
    
    begin
	for i := 1 to w1.length do
	    for j := 1 to w2.length do
    		if w1.letters[i] = w2.letters[j] then
    		    begin
			pos1 := i;
			pos2 := j
		    end
    end;


b)  procedure printcrosswords(w1,w2 : wordtype);

    var
	pos1,pos2,vert,horiz : integer;

    begin
	findcommonletter(w1,w2,pos1,pos2);

	for vert := 1 to w1.length do
	    if vert <> pos1 then
		begin
		    printchars(' ',pos2 - 1);
		    printchars(w1.letters[vert],1);
		    startnewline
		end
	    else
		begin
		    for horiz := 1 to w2.length do
			printchars(w2.letters[horiz],1);
		    startnewline
		end
    end;


    procedure printcrosswords(w1,w2 : wordtype);
	{This version makes the printing division more explicit.}

    var
	pos1,pos2,vert,horiz : integer;

    begin
	findcommonletter(w1,w2,pos1,pos2);

	for vert := 1 to pos1 - 1 do
	    begin
		printchars(' ',pos2 - 1);
		printchars(w1.letters[vert],1);
		startnewline
	    end;

	for horiz := 1 to w2.length do
	    printchars(w2.letters[horiz],1);
	startnewline;

	for vert := pos1 + 1 to w1.length do
	    begin
		printchars(' ',pos2 - 1);
		printchars(w1.letters[vert],1);
		startnewline
	    end
    end;


Grading Notes[part b]:

1)  Lots of places to get lost with indices.  Must keep very close track of
    which index relates to which word.
2)  Watch the record notations and correctly referencing the fields.
          SOLUTION - A Exam PROBLEM #4/AB Exam PROBLEM #3 (1992)


a)  The following lines need to be changed in the code for AddLongInts:

    Temp := KthDigit(L1,1) + KthDigit(L2,1)
	becomes
    Temp := KthDigit(L,1) * digit

    Temp := KthDigit(L1,k) + KthDigit(L2,k) + Carry;
	becomes
    Temp := KthDigit(L,k) * digit + Carry

    ReplaceDigit(Result,NumSignificantDigits(L1) + 1,1)
	becomes
    ReplaceDigit(Result,NumSignificantDigits(L) + 1,Carry)


b)  function numsignificantdigits(l : longinttype) : integer;
	{This version looks for the first non-zero from the left.}
    var
	i : integer;

    begin
	i := 1;
	while ( (l[i] = 0) and (i <> maxdigits) ) do
	    i := i + 1;
	numsignificantdigits := maxdigits - i + 1
    end;


    function numsignificantdigits(l : longinttype) : integer;
	{This version remembers the last non-zero from the right.}
    var
	i,hold : integer;
	lookingfornonzero : boolean;

    begin
	hold := maxdigits;
	for i := maxdigits downto 1 do
	    if l[i] <> 0 then
		hold := i;
	numsignificantdigits := maxdigits - hold + 1
    end;


c)  InitLongInt requires a change; must mention storing a value into the
        NumSigDigits field.

    ReplaceDigit also requires a change; must mention that NumSigDigits
        field must be updated.

    AddLongInts does NOT require a change.


Grading Notes[part b]:

1)  Must look for the leading non-zero, either scanning from the left or
    remembering from the right.
2)  Be careful if you use the KthDigit function, as it returns the kth digit
    as read from RIGHT to LEFT, but the numbering in this part starts with 1
    AT THE LEFT.  This confused many students (although some still used the
    abstraction correctly).


Grading Notes [part c]:

1)  At the exam reading, it was decided that if a student mentioned storing
    a specific value in InitLongInt, the value must be 1, otherwise no credit.
2)  At the exam reading, it was decided that if a student mentions that the
    code must change to accomodate the record notation, that was deemed ok.
3)  Affirmative answers without supporting reasons were awarded no credit.
                      SOLUTION - AB Exam PROBLEM #2 (1992)


a)  function location(list : listtype; key : integer) : listtype;

    var
	found : boolean;

    begin
	found := false;
	while (not found) and (list <> nil) do
	    if list^.info = key then
		found := true
	    else
		list := list^.next;
	if found then
	    location := list
	else
	    location := nil
    end;


    function location(list : listtype; key : integer) : listtype;
	{This version does not stop when correct node is found.}
    begin
	while list <> nil do
	    begin
		if list^.info = key then
		    location := list;
		list := list^.next    {do NOT guard this with an ELSE!}
	    end;
    end;


b)  procedure movetofront(var list : listtype; key : integer);

    var
	loc : listtype;
    
    begin
	loc := location(list,key);
	if (loc <> nil) and (loc <> list) then
	    begin
		if loc^.prev <> nil then   {not really needed, since loc<>list}
		    loc^.prev^.next := loc^.next;
		if loc^.next <> nil then
		    loc^.next^.prev := loc^.prev;
		loc^.next := list;
		loc^.prev := nil;
		list^.prev := loc;
		list := loc
	    end
    end;


Grading Notes [part b]:

1)  It is very important to test for the first node case and do nothing in
    that case.  The above code will not work correctly if the (loc <> list)
    test is removed.
2)  The first 3 of the last 4 assignment statements can be in any order.
                      SOLUTION - AB Exam PROBLEM #4 (1992)

a)  function isleaf(t : treetype) : boolean;

    begin
	if t = nil then
	    isleaf := false
	else
	    isleaf := (t^.left = nil) and (t^.right = nil)
    end;


b)  function haspathsum(t : treetype; value : integer) : boolean;
	{This is the most straightforward impementation.}

    begin
	if t = nil then
	    haspathsum := false
	else
	    if isleaf(t) then
		haspathsum := t^.info = value
	    else
		haspathsum := haspathsum(t^.left,value - t^.info) or
				  haspathsum(t^.right,value - t^.info)
    end;


    function haspathsum(t : treetype; value : integer) : boolean;
	{This one collapses the tests as much as possible.}

    begin
	if t = nil then
	    haspathsum := false
	else
	    haspathsum := (isleaf(t) and (t^.info = value)) or
				haspathsum(t^.left,value - t^.info) or
				    haspathsum(t^.right,value - t^.info)
    end;


    function haspathsum(t : treetype; value : integer) : boolean;
	{Then there's this one, for those of us who felt we HAD to add.
	 It must make use of an auxiliary procedure.}
    var
	result : boolean;

    procedure pathsum(t : treetype; value,sum : integer; var result : boolean);
    begin
	if t <> nil then
	    begin
		sum := sum + t^.info;
		if isleaf(t) then
		    if sum = value then result := true
		else
		    begin
			pathsum(t^.left,value,sum,flag);
			pathsum(t^.right,value,sum,flag)
		    end
	    end  {no else down here to reset to false; could overwrite a true!}
    end;

    begin
	result := false;
	pathsum(t,value,0,result);
	haspathsum := result	    
    end;
                        SOLUTION - PROBLEM #1 (1991)


function isincreasing(list : listtype) : boolean;
     
var
    i : integer;
    increasing : boolean;
    
begin
    with list do
        begin
            i := 0;
            increasing := true;
            while increasing and (i < (length - 1)) do
                begin
                    i := i + 1;
                    if items[i+1] <= items[i] then
                        begin
                            increasing := false
                        end
                end;
            isincreasing := increasing
         end
end;


Grading Notes:

1)  Watch the boundary cases (especially if a FOR or REPEAT loop solution is
    attempted).
2)  Make sure the state variable is both set to the correct value and not set
    and reset on each iteration (i.e., adding an ELSE increasing := true to
    the above IF statement).
3)  Make sure that the record is referenced (either by a WITH or ny using
    list.length and list.items).




                        SOLUTION - PROBLEM #2 (1991)


function mintime(hours : arraytype; start,destination : integer) : integer;

var
    min,i : integer;
    
begin
    min := hours[start,destination];
    for i := 1 to n do 
        if (hours[start,i] + hours[i,destination]) < min then
            min := hours[start,i] + hours[i,destination];
    mintime := min
end;


Grading Notes:

1)  Watch the init of the local min.  It should be hours[start,destination]
    or the named constant MAXINT (i.e., a specific value, like 32767, is not
    a valid init).
2)  Make sure the loop goes to n (not 4, as in the sample given on the exam)!
3)  Make sure the comparison and reassignment is correct.
                        SOLUTION - PROBLEM #3 (1991)


a)  Fewer manipulations for Scheme 1 vs. Scheme 2:

    NumOccurrences:  you can directly access the appropriate array element
                     vs. having to scan the entire array


    Fewer manipulations for Scheme 2 vs. Scheme 1:

    MakeEmpty:  set count field to 0 vs. having to 0 each array element


b & c)  Scheme 1:

        Const
            MaxElts = 100;
        Type
            ListType = array[1..MaxElts] of integer;


        procedure makeempty(var list : listtype);
    
        var
            i : integer
    
        begin
            for i := 1 to maxelts do
                list[i] := 0
        end;
    
    
        procedure insert(var list : listtype; value : integer);
    
        begin
            list[value] := list[value] + 1
        end;
    

        function numoccurrences(list : listtype; key : integer) : integer;
    
        begin
            numoccurrences := list[key]
        end;


b & c)  Scheme 2:

        Const
            MaxElts = 500;
        Type
            ListType = record
                           Count : integer;
                           Items : array[1..MaxElts] of integer;
                       end;


        procedure makeempty(var list : listtype);
    
        begin
            list.count := 0
        end;
    
    
        procedure insert(var list : listtype; value : integer);
    
        begin
            list.count := list.count + 1;
            list.items[list.count] := value
        end;
    

        function numoccurrences(list : listtype; key : integer) : integer;

        var
            occur,i : integer;
    
        begin
            occur := 0;
            for i := 1 to list.count do
                if list.items[i] = key then
                    occur := occur + 1;
            numoccurrences := occur
        end;
                        SOLUTION - PROBLEM #4 (1991)


a)  procedure insertzerosecond (var list : listtype);

    var
        temp : listtype;
    
    begin
        temp := list^.next;
        new(list^.next);
        list^.next^.data := 0;
        list^.next^.next := temp
    end;


b)  procedure padlist (var list : listtype);
      {This version pads after the current cell and then recurs down the list.}

    begin
        if list <> nil then
            if list^.next <> nil then
                begin
                    insertzerosecond (list);
                    padlist(list^.next^.next)
                end
    end;


    procedure padlist2 (var list : listtype);
      {This version makes the recursive call and pads on the way back up the
       list.}

    begin
        if list <> nil then
            if list^.next <> nil then
                begin
                    padlist2 (list^.next);
                    insertzerosecond (list)
                end
    end;
                        SOLUTION - PROBLEM #5 (1991)


a)  function nodecount(tree : treetype) : integer;

    begin
        if tree = nil then
            nodecount := 0
        else
            nodecount := 1 + nodecount(tree^.left) + nodecount(tree^.right)
    end;


b)  function leafcount(tree : treetype) : integer;

    begin
       if tree = nil then
           leafcount := 0
       else
           if (tree^.left = nil) and (tree^.right = nil) then
               leafcount := 1
           else
               leafcount := leafcount(tree^.left) + leafcount(tree^.right)
    end;


c)  function height(tree : treetype) : integer;
       {This version uses local variables to calculate left and right
        heights to subsequently compare.}

    var
        lheight,rheight : integer;
    
    begin
        if tree = nil then
            height := 0
        else
            begin
                lheight := 1 + height(tree^.left);
                rheight := 1 + height(tree^.right);
                height := max(lheight, rheight)
            end
    end;


    function height(tree : treetype) : integer;
       {This version does the left/right calculations in-line.}

    begin
        if tree = nil then
            height := 0
        else
            height := max( 1 + height(tree^.left), 1 + height(tree^.right) )
    end;


    function height(tree : treetype) : integer;
       {This version moves the addition of one (to count the current node)
        outside the left/right calculations.}

    begin
        if tree = nil then
            height := 0
        else
            height := 1 + max( height(tree^.left), height(tree^.right) )
    end;


d)  function width(tree : treetype) : integer;
       {This version uses locals to calculate intermediate results.}
     
    var
        rootpath,lwidth,rwidth,subtreemax : integer;
    
    begin
        if tree = nil then
            width := 0
        else
            begin
                lwidth := width(tree^.left);
                rwidth := width(tree^.right);
                subtreemax := max(lwidth,rwidth);
                rootpath := 1 + height(tree^.left) + height(tree^.right);
                width := max(subtreemax,rootpath)
            end
    end;


    function width(tree : treetype) : integer;
       {This version does all calculations in-line.}

    begin
        if tree = nil then
            width := 0
        else
            width := max( 1 + height(tree^.left) + height(tree^.right),
                          max( width(tree^.left), width(tree^.right) ) )
    end;


Grading Notes:

1)  Be careful of using the function name as a local variable.
2)  The last part (d) should have been written right from the spec provided
    in the problem statement.
                        SOLUTION - PROBLEM #1 (1990)


function finalscore(scores : arraytype) : real;
    {This version sums all the numbers and determines the min in one pass
     and then subtracts the min from the sum after the pass.}
var
    count,min,sum : integer;

begin
    min := scores[1];
    sum := 0;
    for count := 1 to numscores do
	begin
	    sum := sum + scores[count];
	    if scores[count] < min then
		min := scores[count]
	end;
    finalscore := (sum - min) / (numscores - 1)
end;


function finalscore(scores : arraytype) : real;
    {This version never adds the min into the sum (a value is either less
     than the current min, so the current min is added into the sum,
     or it is >= to the current min, so it is added into the sum).}
var
    count,min,sum : integer;

begin
    min := scores[1];
    sum := 0;
    for count := 2 to numscores do
	begin
	    if scores[count] < min then
		begin
                    sum := sum + min;
                    min := scores[count]
                end
            else
                sum := sum + scores[count];
	end;
    finalscore := sum / (numscores - 1)
end;


Grading Notes:

1)  Watch the init of min.  It should be Scores[1], Scores[NumScores], or
    maxint (must use the constant name, not a particular value, e.g., 32767)
2)  Make sure that the min score is actually dropped from the sum.
3)  Make sure numscores is decreased by 1 in average computation.
                        SOLUTION - PROBLEM #2 (1990)


procedure countcorrect(var answerfile,responsefile,countfile : text);
   {This version stores the correct answers, so that answerfile is scanned
    only once.}
type
    correctarray = array[1..maxquestions] of char;

var
    correct : correctarray;
    count,numquestions,numcorrect,id : integer;
    answer : char;
    
begin
    count := 0;
    while not eof(answerfile) do    {Unknown # of questions, <= maxquestions}
	begin
	    count := count + 1;
	    readln(answerfile, correct[count])
	end;
    numquestions := count;

    while not eof(responsefile) do    {Unknown # of students}
	begin
	    numcorrect := 0;
	    for count := 1 to numquestions do
		begin
		    read(responsefile, answer);
		    if answer = correct[count] then
			numcorrect := numcorrect + 1
		end;
	    readln(responsefile,id);
	    writeln(countfile,id:1,' ',numcorrect:3)
	end;
end;


procedure countcorrect(var answerfile,responsefile,countfile : text);
   {This version scans answerfile as many times as there are students, but
    doesn't require any extra storage.  Note the two different interior loop
    guards which are possible.}
var
    numcorrect,id : integer;
    answer,correctans : char;
    
begin
    while not eof(responsefile) do
	begin
	    numcorrect := 0;
	    reset(answerfile);
	    while not eof(answerfile) do
            { Could have used while responsefile^ <> ' ' instead of this}
		begin
		    readln(answerfile,correctans);
		    read(responsefile, answer);
		    if correctans = answer then
			numcorrect := numcorrect + 1
		end;
	    readln(responsefile,id);
	    writeln(countfile,id:1,' ',numcorrect:3)
	end;
end;
                        SOLUTION - PROBLEM #3 (1990)


function samepattern(s,t : stringtype) : boolean;
   {'Standard' solution}
var
    i,j : integer;
    match : boolean;    {NOTE: a separate local variable is not necessary}

begin
    match := true;
    for i := 1 to n-1 do
	for j := i+1 to n do
	    begin
		if (s[i] = s[j]) and (t[i] <> t[j]) then
		    match := false;
		if (s[i] <> s[j]) and (t[i] = t[j]) then
		    match := false
	    end;
    samepattern := match
end;


function samepattern(s,t : stringtype) : boolean;
   {simple variant on 'Standard' solution}
var
    i,j : integer;

begin
    samepattern := true;  {this version also doesn't use the extra local var}
    for i := 1 to n-1 do
	for j := i+1 to n do
	    if not ( ((s[i] = s[j]) and (t[i] = t[j])) or 
		     ((s[i] <> s[j]) and (t[i] <> t[j])) ) then
			 samepattern := false
end;


function samepattern(s,t : stringtype) : boolean;
   {another variant on 'Standard' solution}
var
    i,j : integer;
    match : boolean;

begin
    match := true;
    for i := 1 to n-1 do
	for j := i+1 to n do
	    if not ( (s[i] = s[j]) = (t[i] = t[j]) ) then  {watch the parens!}
		 match := false;
    samepattern := match
end;


Grading Notes:

1)  Watch for code that only returns the value of the last comparison made.
    A typical example of this would be to modify the IF in the last solution
    given above to the following IF/ELSE:
              if not ((s[i] = s[j]) = (t[i] = t[j])) then match := false
              else match := true
2)  Don't want to compare only adjacent elements.


                               ****  OVER  ****

function samepattern(s,t : stringtype) : boolean;
   {Converts characters in T to corresponding characters from S.  Stores
    result of conversion in a new array which is then compared to S.
    Conversion is done by holding a position fixed and running down T
    from that point looking for matching characters.  If a match is found,
    and the symbol is not already used, the corresponding character of S
    is placed in the new array.  The fixed position is then advanced one and
    the process is repeated.}
var
    i,j : integer;
    Sused,Tused : set of char;
    ConvertTtoSsymbols : stringtype;
    
begin
    for i := 1 to n do
	ConvertTtoSsymbols[i] := ' ';
    Sused := [ ];
    Tused := [ ];
    for i := 1 to n do 
	begin
	    for j := i to n do 
		if (t[j] = t[i]) and (not (t[j] in Tused)) and
		   (not (s[j] in Sused)) then
			ConvertTtoSsymbols[j] := s[i] ;
	    Sused := Sused + [ s[i] ];
	    Tused := Tused + [ t[i] ]
	end;
    samepattern := ConvertTtoSsymbols = s
end;


function samepattern(s,t : stringtype) : boolean;
   {Keep a table which maps the symbols in S to those in T and the symbols
    in T to those in S.  Use the map to convert the pattern in S to T symbols
    and the pattern in T to S symbols.  If both converted strings match the
    original strings, then the same pattern appeared in both original
    strings.  The map is constructed in the following fashion: look at each
    character in S and see what is in the corresponding position in T.  Store
    that character from T in the table, if a character isn't already there.
    Take whatever character is in the table (either the one you just put
    there, or the one that was there already) and put that in the
    corresponding position in the ConvertStoTsymbols string.  Simultaneously
    perform the task going from T to S.}
var
    i : integer;
    ch : char;
    MapStoT,MapTtoS : array ['a'..'z'] of char;
    ConvertStoTsymbols,ConvertTtoSsymbols : stringtype;
    
begin
    for ch := 'a' to 'z' do 
	begin
	    MapStoT[ch] := ' ';
	    MapTtoS[ch] := ' '
	end;
    for i := 1 to n do 
	begin
	    if MapStoT[ s[i] ] = ' ' then
		MapStoT[ s[i] ] := t[i];
	    ConvertStoTsymbols[i] := MapStoT[ s[i] ];
	    if MapTtoS[ t[i] ] = ' ' then
		MapTtoS[ t[i] ] := s[i];
	    ConvertTtoSsymbols[i] := MapTtoS[ t[i] ] 
	end;
    samepattern := (ConvertStoTsymbols = t) and (ConvertTtoSsymbols = s)
end;


function samepattern(s,t : stringtype) : boolean;
   {Maps characters in S and T to a canonical form.  The form used takes
    the first character in each string and assign it an A; find all
    subsequent occurrences of the same character in the original string
    and assign them As in the canonical string.  Move to the next position
    in each of the canonical strings.  If it is a blank (that position hasn't
    been mapped yet), assign the next character in sequence (B, C, etc.) to
    that position in the canonical string.  Find all occurrences of the
    corresponding character in the original string and assign the appropriate
    canonical character in the corresponding positions in the canonical
    string.  Repeat until the strings are exhausted, then compare canonical
    forms.}
var
    i,j : integer;
    CanonSch,CanonTch : char;
    CanonS,CanonT : stringtype;
    
begin
    for i := 1 to n do 
	begin
	    CanonS[i] := ' ';
	    CanonT[i] := ' '
	end;
    CanonSch := pred('A');
    CanonTch := pred('A');
    for i := 1 to n do 
	begin
	    if CanonS[i] = ' ' then
		begin
		    CanonSch := succ(CanonSch);
		    CanonS[i] := CanonSch;
		    for j := i+1 to n do
			if s[i] = s[j] then CanonS[j] := CanonSch
		end;
	    if CanonT[i] = ' ' then
		begin
		    CanonTch := succ(CanonTch);
		    CanonT[i] := CanonTch;
		    for j := i+1 to n do 
			if t[i] = t[j] then CanonT[j] := CanonTch
		end
	end;
    samepattern := CanonS = CanonT
end;
                        SOLUTION - PROBLEM #4 (1990)


a)  procedure writelnstring(str : stringtype);

    var
	temp : stringtype;

    begin
	temp := str;
	while temp <> nil do
	    begin
		write(temp^.ch);
		temp := temp^.next
	    end;
	writeln
    end;


b)  procedure printfemaleancestors(tree : treeptr)

    begin
	if tree <> nil then
	    begin
		if tree^.left <> nil then
		    writelnstring(tree^.left^.name);
		printfemaleancestors(tree^.left);
		printfemaleancestors(tree^.right);
	    end;
    end;




                        SOLUTION - PROBLEM #5 (1990)


a)  Initialization:  set all elements of Pairs to 0

    Running time O(k*k)


b)  An array of linked lists (of the y strings).  Insert is done at the
    beginning of the list and is O(1).  PrintSecondElements is O(n), where
    n is the number of pairs with first element x that have been inserted
    in the collection.


c)  A binary tree of the x strings, ordered lexicographically.  Each element
    of the binary tree would point at a linked list (of the y strings).  If
    the tree is balanced, Insert is O(log n + 1), log n to find the position
    of x in the tree, and 1 to insert the y string at the beginning of the
    linked list.  PrintSecondElements is O(log n + m), log n to find the x
    string, and m to print all the associated y strings on the linked list.


Grading Notes:

1)  Some form of hash table would be OK for (c), but its design should be
    specified.
                        SOLUTION - PROBLEM #1 (1989)


procedure replace(var s : stringtype; chtoreplace,chtouse : char);

var
    i : integer;

begin
    with s do
	for i := 1 to length do
	    if chars[i] = chtoreplace then
		chars[i] := chtouse
end;




                        SOLUTION - PROBLEM #2 (1989)


procedure printavailable(theater : theatertype);

var
    row : char;
    seat : integer;
    rowcount,total : integer;

begin
    total := 0;
    writeln('Row   Available seats');
    writeln;
    for row := minrow to maxrow do
	begin
	    write(' ',row,'   ');
	    rowcount := 0;
	    for seat := minseat to maxseat do
		if theater[row,seat] then
		    begin
			rowcount := rowcount + 1;
			write(' ',seat:1)
		    end;
	    if rowcount = 0 then write(' None available')
	    else total := total + rowcount;
	    writeln;
	end;
    writeln;
    writeln('The total number of seats available is ',total:1,'.')
end;
                        SOLUTION - PROBLEM #3 (1989)


procedure writethreedigits(n : integer);

begin
    write(n div 100 : 1);
    write((n div 10) mod 10 : 1);
    write(n mod 10 : 1)
end;

procedure writewithcommas(n : integer);

begin
    if n < 1000 then
	write(n:3)
    else
	begin
	    writethreedigits(n mod 1000); <----
	    write(',');                       |
	    writewithcommas(n div 1000)   <----
	end;
end;


a)  123; 123,123 or 123,456,123


b)  interchange the two lines marked with arrows


c)  instead of writing individual integers, call digittochar and concat:

    procedure appendthreedigits(var s : stringtype; n : integer);

    begin
        concat(s, DigitToChar(n div 100) );
        concat(s, DigitToChar((n div 10) mod 10) );
        concat(s, DigitToChar(n mod 10) )
    end;

    procedure appendnum(var s : stringtype; n : integer);

    begin
        if n < 1000 then
            begin
                if n >= 100 then concat(s, DigitToChar(n div 100) );
                if n >= 10 then concat(s, DigitToChar((n div 10) mod 10) );
                concat(s, DigitToChar(n mod 10) )
            end
        else
            begin
                appendnum(s, n div 1000);
                concat(s, ',');
                appendthreedigits(s, n mod 1000)
            end
    end;
                        SOLUTION - PROBLEM #4 (1989)


procedure eliminateduplicates(var list : ptrnode);

var temp : ptrnode;

begin
    if list <> nil then
	if list^.next <> nil then
	    if list^.data = list^.next^.data then
		begin
		    temp := list;
		    list := list^.next;
		    dispose(temp);
		    eliminateduplicates(list)
		end
	    else
		eliminateduplicates(list^.next)
end;



Alternate version (Iterative version I, removes trailing duplicate node):


procedure eliminateduplicates(var list : ptrnode);

var p,temp :ptrnode;

begin
    if list <> nil then
	begin
	    p := list;
	    while p^.next <> nil do
		begin
		    if p^.data = p^.next^.data then
			begin
			    temp := p^.next;
			    p^.next := p^.next^.next;
			    dispose(temp)
			end
		    else
			p := p^.next
		end;
	end;
end;

                               ****  OVER  ****

Alternative version (iterative version II, removes leading duplicate node):

    This code is much harder to get correct; consider how to handle more than
    2 initial duplicates.  I decided to remove all duplicates starting with
    the second node (comparing against the third) and continuing from there.
    I then go back and check the first against the second after the entire
    list has been traversed.  This allows me to make only one change to the
    head of the list.


procedure eliminateduplicates(var list : ptrnode);

var  p,prev : ptrnode;

begin
    if list <> nil then
	if list^.next <> nil then
	    begin
		prev := list;
		p := list^.next;
		while p^.next <> nil do
		    begin
			if p^.data = p^.next^.data then
			    begin
				prev^.next := p^.next;
				dispose(p);
				p := prev^.next
			    end
			else
			    begin
				prev := p;
				p := p^.next
			    end
		    end;

		{there may be a remaining initial duplicate to be removed}

		if list^.data = list^.next^.data then
		    begin
			prev := list;
			list := list^.next;
			dispose(prev)
		    end
	    end    {matches the initial if list^.next <> nil test}
end;
                        SOLUTION - PROBLEM #5 (1989)


a)
TYPE
    childrentype = ^childrec;
    childrec = record
		   child : treeptr;
		   next : childrentype
	       end;


b)
function generaltreesum(t : treeptr) : integer;

var
    sum : integer;
    temp : childrentype;

begin
    if t <> nil then
	begin
	    sum := t^.data;    {or 0}
	    temp := t^.children;
	    while temp <> nil do
		begin
		    sum := sum + generaltreesum(temp^.child);
		    temp := temp^.next
		end;
           generaltreesum := sum    {+ t^.data, if above init to 0 is done}
	end
    else
	generaltreesum := 0
end;



Alternate version (mutually recursive):


function generaltreesum(t : treeptr) : integer;

	function kidsum(c : childrentype) : integer;
    
	begin
	    if c <> nil then
		kidsum := generaltreesum(c^.child) + kidsum(c^.next)
	    else
		kidsum := 0
	end;

begin
    if t <> nil then
	generaltreesum := t^.data + kidsum(t^.children)
    else
	generaltreesum := 0
end;
                        SOLUTION - PROBLEM #1 (1988)


function numdigits(number : integer) : integer;

var
    count : integer;

begin
    number := abs(number);
    count := 1;
    while (number div 10) <> 0 do
        begin
            count := count + 1;
            number := number div 10
        end;
    numdigits := count
end;


You may wonder why the call to abs(number) is made in an assignment
statement rather than the loop guard.  You only need to take the absolute
value of number once; it is more efficient to do it before the loop so that
it is not called each time the guard is evaluated.  This is NOT a grading
issue, but a matter of personal preference.  I repeat, this would NOT lose
any points on a free-response solution.
                        SOLUTION - PROBLEM #2 (1988)


a)  Single integer:
	Adv - easier to implement TimeSum operation
	D/A - harder to implement PrintTime operation

    Record:
	Adv - easier to implement PrintTime operation
	D/A - much harder to implement TimeSum operation


b/c/d)  Single integer implementation:

TYPE
    elapsedtimetype = integer;


procedure printtime(t : elapsedtimetype);

begin
    write(t div 3600:2,' ',t div 60 mod 60:2,' ',t mod 60:2)
end;


procedure timesum(t1,t2 : elapsedtimetype; var sum : elapsedtimetype);

begin
    sum := t1 + t2
end;



Record implementation:

TYPE
    elapsedtimetype = record
			hours, minutes, seconds : integer
		      end;


procedure printtime(t : elapsedtimetype);

begin
    with t do
	writeln(hours:2,' ',minutes:2,' ',seconds:2)
end;
 

procedure timesum(t1,t2 : elapsedtimetype; var sum : elapsedtimetype);

var
    totseconds,totminutes : integer

begin
    totseconds := t1.seconds + t2.seconds;
    sum.seconds := totseconds mod 60;
    totminutes := t1.minutes + t2.minutes + totseconds div 60;
    sum.minutes := totminutes mod 60;
    sum.hours := t1.hours + t2.hours + totminutes div 60
end;
                        SOLUTION - PROBLEM #3 (1988)


procedure expand(var m:matrixtype; factor : integer);

var
    row,col : integer;	{target row and column position}

begin
    with m do
	begin
	    numrows := numrows * factor;
	    numcols := numcols * factor;

	    for row := numrows downto 1 do
	      for col := numcols downto 1 do
	        numbers[row,col] := numbers[(row-1) div factor + 1,(col-1) div factor + 1]
	end
end;



Alternate version (perhaps easier to follow):


procedure expand(var m:matrixtype; factor : integer);

var
    orow,ocol,	{original row and column position}
    row,col : integer;	{target row and column position}

begin
    with m do
	begin
	    numrows := numrows * factor;
	    numcols := numcols * factor;

	    for row := numrows downto 1 do
		for col := numcols downto 1 do
		    begin
			if col mod factor = 0 then
			    ocol := col div factor
			else
			    ocol := col div factor + 1;

			if row mod factor = 0 then
			    orow := row div factor
			else
			    orow := row div factor + 1;

			numbers[row,col] := numbers[orow,ocol]
		    end
	end
end;
                        SOLUTION - PROBLEM #4 (1988)


procedure reverse(var head : ptrnode);

var
    prev,follow : ptrnode;

begin
    if head <> nil then
        if head^.next <> nil then
            begin
                prev := head;
                head := head^.next;
                prev^.next := nil;
                while head^.next <> nil do
                    begin
                        follow := head^.next;
                        head^.next := prev;
                        prev := head;
                        head := follow
                    end;
                head^.next := prev
            end
end;




                        SOLUTION - PROBLEM #5 (1988)


function mirrortree(t : treetype) : treetype;

var
    temptree : treetype;

begin
    if t = nil then
        mirrortree := nil
    else
        begin
            new(temptree);
            temptree^.data := t^.data;
            temptree^.left := mirrortree(t^.right);
            temptree^.right := mirrortree(t^.left);
            mirrortree := temptree
        end
end;
                        SOLUTION - PROBLEM #1 (1987)


function minimum(head : ptrnode) : ptrnode;

var
    temp,currmin : ptrnode;

begin
    currmin := head;
    temp := head^.next;
    while temp <> nil do
	begin
	    if temp^.info < currmin^.info then
		currmin := temp;
	    temp := temp^.next		    
	end;
    minimum := currmin
end;


Grading Notes:

1)  Watch local declarations - MUST save the pointer (not just the integer)
2)  Watch for things like minimum^ (illegal function reference)
                        SOLUTION - PROBLEM #2 (1987)


procedure compact(var l : listtype);

{Post:  length returned after compaction is # of nonzero elements, not the
        original length}

var
    i,j : integer;

begin
    j := 0;
    for i := 1 to l.length do
        if l.numbers[i] <> 0 then
            begin
                j := j + 1;
                l.numbers[j] := l.numbers[i]
            end;
    l.length := j
end;
       


Alternate version (less efficient [n-squared]):


procedure compact(var l : listtype);

{Post:  length returned after compaction is # of nonzero elements, not the
        original length}

var
    i,j : integer;

begin
    i := 1;
    while i <= l.length do
	if l.numbers[i] = 0 then
	    begin
		for j := i+1 to l.length do    {push rest of elements up}
		    l.numbers[j-1] := l.numbers[j];
		l.length := l.length - 1    {necessary for proper termination}
	    end    {* note, i is NOT advanced if that slot was 0 *}
	else       {* this is necessary to handle consecutive zeroes *}
	    i := i + 1    {check next element}
end;


Grading Notes:

1)  There should only be one parameter, of type ListType and it MUST be a
    VAR parameter.
2)  Loops should only go as far as the length field of the record.
                        SOLUTION - PROBLEM #3 (1987)


function tokenexists(var infile : text) : boolean;

var
    ch : char;

begin
    tokenexists := false;
    while not eoln(infile) do
	begin
	    read(infile,ch);
	    if ch = ':' then
		if infile^ = '=' then
		    tokenexists := true
        end
end;


Grading Note:

Watch for embedded string (i.e. '::=').  Many seemingly good solutions
missed the embedded occurrence.  As an example, here's an alternate while
loop which misses the embedded occurrence:

    while not eoln(infile) do
	begin
	    read(infile,ch);
	    if ch = ':' then
		if not eoln(infile) then    {in case ':' is last chartacter}
		    begin
			read(infile,nextch);
			if nextch = '=' then
			    tokenexists := true
		    end;
	end;
                        SOLUTION - PROBLEM #4 (1987)


a)  Postcondition:  returns a ... a      b ...b  a   ...a
                             1     pos-1  1    m  pos    n


b)  Code:  if pos = 1 then
              insert := concatenate(str2,str1)
           else
              if pos = length(str1) + 1 then
                  insert := concatenate(str1,str2)
              else
                  insert := concat( concat(extract(str1,1,pos-1),str2), 
                                    extract(str1,pos,length(str1)) )




                        SOLUTION - PROBLEM #5 (1987)


procedure eraseobject(var image : imagetype; row,col : integer);

begin
    if (row >= 1) and (row <= size) and (col >= 1) and (col <= size) then
  	if image[row,col] = black then
  	    begin
  		image[row,col] := white;
  		eraseobject(image,row-1,col);
  		eraseobject(image,row+1,col);
  		eraseobject(image,row,col-1);
  		eraseobject(image,row,col+1)
  	    end
end;


Grading Notes:

1)  Must check bounds FIRST (can all be done simultaneously)
2)  Must check color (no recursive call if white).  This check CANNOT be
    done in the same IF test as the bounds check (will cause an array
    reference error due to full evaluation of the boolean expression).
                        SOLUTION - PROBLEM #1 (1986)


function numnodes(first : pointer) : integer;

{Assumes there is no header node}

var
    count : integer;
    temp : pointer;

begin
    count := 0;
    temp := first;
    while temp <> nil do
	begin
	    count := count + 1;
	    temp := temp^.link
	end;
    numnodes := count
end;



Alternate, recursive solution:


function numnodes(first : pointer) : integer;

{Assumes there is no header node}

begin
    if first <> nil then
        numnodes := 1 + numnodes(first^.link)
    else
	numnodes := 0
end;
                        SOLUTION - PROBLEM #2 (1986)


function inversion(list : sequence; n : lengthtype) : integer;

var
    count : integer;
    i,j : lengthtype;

begin
    count := 0;
    for i := 1 to n - 1 do
	for j := i to n do
	    if list[i] > list[j] then
		count := count + 1;
    inversion := count
end;




                        SOLUTION - PROBLEM #3 (1986)


procedure numberleaves(tree : treetype; var nextnum : integer);

begin
    if tree <> nil then
	begin
	    numberleaves(tree^.right,nextnum);
	    if (tree^.left = nil) and (tree^.right = nil) then  {check if leaf}
		begin
		    tree^.datum := nextnum;
		    nextnum := nextnum + 1
		end;
	    numberleaves(tree^.left,nextnum)
	end;
end;
                        SOLUTION - PROBLEM #4 (1986)


program compact(input,output,infile,outfile);

var
    infile,outfile : text;


procedure handleblanks(var numblanks : integer);

begin
    numblanks := 0;
    while infile^ = ' ' do
	begin
	    get(infile);
	    numblanks := numblanks + 1
	end;
end;


procedure copyline(numblanks : integer);

var
    dummy : char;

begin
    write(outfile,numblanks:1,' ');
    while not eoln(infile) do
	begin
	    read(infile,dummy);
	    write(outfile,dummy)
	end;
    readln(infile);
    writeln(outfile)
end;


procedure scanandwrite;

var
    numblanks : integer;

begin
    reset(infile);
    rewrite(outfile);
    while not eof(infile) do
	begin
	    handleblanks(numblanks);
	    copyline(numblanks)
	end
end;


begin
    scanandwrite
end.
                        SOLUTION - PROBLEM #5 (1986)


Since the specification for the problem states that the program must do
BOTH the search and the list operations quickly, a structure that can be
searched in O(log n) time or better and displayed in O(n) time is desired.
Realize that this can be done by an array as well as a linked structure.

Using a structure that required DUPLICATION of records lost 1 point in
grading, e.g. two arrays, or a separate tree and linked list.


a)  A binary tree, ordered by name and threaded in increasing order of
    contribution.  ALTERNATIVE: an array of records, ordered by name, with
    an index field to 'thread' the array by contribution.


b)  A 'normal' binary search of the tree (see below) has time O(log n):
	if namekey < node^.name then
	    search left subtree
	else
	    if namekey > node^.name then
		search right subtree
	    else
		report name found and return pointer


c)  Traverse the linked list which is provided by the contributions thread
    as stated above.  This operation takes O(n).


d)  CONST
	maxchar = 20;

    TYPE
	stringtype = array[1..maxchar] of char;
	ptr = ^node;
	node = record
	           name, city : stringtype;
	           amount : real;
	           left, right, next : ptr
	       end;

    VAR
	root, contriblist : ptr;
                        SOLUTION - PROBLEM #1 (1985)


procedure rotate(var s : list; n : integer);

var
    temp : item;
    i : integer;

begin
    temp := s[n];
    for i := n downto 2 do
	s[i] := s[i-1];
    s[1] := temp
end;


Grading Notes:

1)  "s" must be a var parameter.
2)  Make sure loop runs in the proper direction.
3)  Must store correct value (s[n]) before entering the loop.
4)  temp must be of type "item".
                        SOLUTION - PROBLEM #2 (1985)


Approaches:
    1)  alternately move nodes into two disjoint lists
    2)  first, count the number of nodes in the original list, then traverse
        half-way and split into two disjoint lists at the midpoint
    3)  traverse the list, advancing one pointer two nodes and another
        pointer one.  When the first returns to the start, the second will
        be halfway around.


procedure split(p : ptr; var q : ptr);    {Approach 1}

var
    pend,qend : ptr;

begin
    q := p^.link;
    qend := q;
    pend := p;
    while qend^.link <> p do
	begin
	    pend^.link := qend^.link;
	    pend := pend^.link;
	    qend^.link := pend^.link;
	    qend := qend^.link
	end;
    qend^.link := q;
    pend^.link := p
end;


procedure split(p : ptr; var q : ptr);    {Approach 1 - Alternate version}

var
    runner,holdp,holdq : ptr;
    isodd : boolean;

begin
    q := p^.link;
    isodd := true;
    runner := q^.link;
    holdp := p;
    holdq := q;
    while runner <> p do
	begin
	    if isodd then
		begin
		    holdp^.link := runner;
		    holdp := holdp^.link;
		end
	    else
		begin
		    holdq^.link := runner;
		    holdq := holdq^.link
		end;
	    isodd := not isodd;
	    runner := runner^.link
	end;
    holdp^.link := p;
    holdq^.link := q
end;

                               ****  OVER  ****

procedure split(p : ptr; var q : ptr);    {Approach 2}

var
    index,count : integer;
    pend,qend : ptr;

begin
    pend := p;    
    qend := p;
    count := 0;

    repeat
	qend := qend^.link;
	count := count + 1
    until qend^.link = p;    {Count the nodes}

    for index := 1 to (count div 2) do
	pend := pend^.link;

    q := pend^.link;
    pend^.link := p;
    qend^.link := q
end;


procedure split(p : ptr; var q : ptr);    {Approach 3}

var
    temp : ptr;

begin
    q := p;
    temp := p;
    repeat
	q := q^.link;
	temp := temp^.link^.link
    until temp = p;
    temp := temp^.link;
    p^.link := q^.link;
    q^.link := temp
end;
                        SOLUTION - PROBLEM #3 (1985)


program prob3(input,output,phone);

const
    n = 5;
    m = 8;

type
    location = array[1..n,1..m] of boolean;

var
    phone : text;
    tellocs : location;


procedure init;

var
    i,j : integer;

begin
    for i := 1 to n do
	for j := 1 to m do
            tellocs[i,j] := false;
end;


procedure readfile;

var
   i,numphones,row,column : integer;

begin
    reset(phone);
    readln(phone,numphones);
    for i := 1 to numphones do
	begin
	    readln(phone,row,column);
	    tellocs[row,column] := true
	end
end;

                               ****  OVER  ****

function suff(row,col : integer) : boolean;

begin
    if (row < n) and (col > 1) then
       suff := tellocs[row,col-1] or tellocs[row+1,col-1] or tellocs[row+1,col]
    else
	if (row < n) and (col = 1) then
	    suff := tellocs[row+1,col]
	else
	    if (row = n) and (col > 1) then
		suff := tellocs[row,col-1]
	    else
		suff := false
end;


procedure evaluate;

var
    i,j : integer;

begin
    for i := 1 to n do
	for j := 1 to m do
	    if (not tellocs[i,j]) and (not suff(i,j)) then
		writeln('No phone at nor near ',i:2,j:2)
	    else
		if (tellocs[i,j]) and (suff(i,j)) then
		    writeln('Phone at and near ',i:2,j:2)
end;


begin
    init;
    readfile;
    evaluate
end.
                        SOLUTION - PROBLEM #4 (1985)


a)  Two operations:
	printing a line
	copying aline or lines


b)  I would use a doubly linked list of lines.  Since all operations except
list must be O(1), I would maintain internal pointers to the previous and
next lines as well as external pointers to the first line, last line and
current line.

TYPE
    stringtype = array[1..maxchar] of char;    {holds a line's characters}

    ptr = ^line;
    line = record
	       linedata : stringtype;    {characters for the line}
	       previous, next : ptr    {pointers to previous and next lines}
	   end;                        {to implement a doubly linked list}

VAR
    top, bottom, current : ptr;    {external pointers into the list}


c)  Implementation of the next command:
	if current <> bottom then
	    current := current^.next
	else
	    writeln('Error, no next line in structure!');


    Implementation of the insert command:

	{assume newline is a pointer to the line to be inserted}

	newline^.next := current^.next;
	current^.next := newline;
	newline^.previous := current;
	if current <> bottom then
	    newline^.next^.previous := newline
	else
	    bottom := newline;
                        SOLUTION - PROBLEM #5 (1985)


procedure mark(p : nodeptr);

begin
    if p <> nil then
        if p^.marker = false then
            begin	
                p^.marker := true;
                mark(p^.left);
                mark(p^.right)
            end;
end;


Grading Notes:

1)  Can't use "and" instead of 2 if's.  This causes a dereference nil error.
2)  MUST check state of marker.  If not, the routine will loop forever.
3)  MUST traverse preorder.  If not, endless loop is possible (chain of
    left links).
                        SOLUTION - PROBLEM #1 (1984)


program readin(input,output);

const
    max = 8;

type
    arr = array[1..max] of integer;

var
    a : arr;


procedure readline(var a : arr);

var
    i : integer;

begin
    write('Enter 8 numbers -> ');
    for i := 1 to max do
	read(a[i]);
    readln
end;


procedure displayrev(a : arr);

var
    i : integer;

begin
    for i := max downto 1 do
	write(a[i]:5);
    writeln
end;


function negcount(a : arr) : integer;

var
    i,count : integer;

begin
    count := 0;
    for i := 1 to max do
	if a[i] < 0 then
	    count := count + 1;
    negcount := count
end;


begin
    writeln;
    readline(a);
    writeln;
    displayrev(a);
    writeln;
    writeln(negcount(a):1,' of the integers are negative.')
end.
                        SOLUTION - PROBLEM #2 (1984)


procedure insert(n : integer; var l : list);

var
    temp : nodeptr;

begin
    with l do
	if first = nil then
	    begin
		new(first);
		first^.datum := n;
		first^.next := nil;
		last := first
	    end
	else
	    if n > 0 then
		begin
		    new(last^.next);
		    last := last^.next;
		    last^.datum := n;
		    last^.next := nil
		end
	    else
		begin
		    temp := first;
		    new(first);
		    first^.datum := n;
		    first^.next := temp
		end
end;
                        SOLUTION - PROBLEM #3 (1984)


function treesum(x : treeptr) : real;

begin
    if x = nil then
	treesum := 0
    else
	treesum := x^.data + treesum(x^.left) + treesum(x^.right)
end;




                        SOLUTION - PROBLEM #4 (1984)


You don't want a 2-dimensional array, since that would take O(n * n) space,
and the specification requires space be linear in the number of non-zero
elements.  I would use a linked list of linked lists, i.e. a linked list of
the rows with non-zero elements, and each cell in that list would contain a
row reference and a pointer to a list of the the non-zero elements of that
particular row.  Each cell in the secondary list would contain the row and
column number as well as the value of the non-zero data.  See diagram below.
                        SOLUTION - PROBLEM #5 (1984)


a)  The search function scans one array, looking for an element greater
    than or equal to the current element in the other array.  It then scans
    the other array in the same manner.  It continues this alternation until
    either running out of room in one array or finding an element which
    occurs in both arrays.

    function search(g,h : list) : boolean;

    var
	gindex, hindex : integer;

    begin
	gindex := 1;
	hindex := 1;
	repeat
	    while (g[gindex] < h[hindex]) and (gindex < n) do
		gindex := gindex + 1;
	    while (h[hindex] < g[gindex]) and (hindex < n) do
		hindex := hindex + 1
	until (gindex = n) or (hindex = n) or (g[gindex] = h[hindex]);
	search := g[gindex] = h[hindex]
    end;


b)  In the case where the arrays are unsorted, the best you can do is to step
    through the first array one element at a time, looking for each element
    in the other array with a linear search.  This method is O(n * n),
    compared with O(n) for the algorithm implemented in part a.