program Contact; const INFILE = 'CONTACT.IN'; OUTFILE= 'CONTACT.OUT'; MAXPAT = 16; SIZE = 2*4096; type Pair = record index:integer; val:Longint; end; TMap =array[0..SIZE-1] of Pair; var table:TMap; MSK :array[0..MAXPAT] of Word; procedure InitPatternTable; var i,p:word; begin p := 0; for i:=0 to MAXPAT-1 do begin p := p shl 1; p := p or 1; MSK[i]:=p; end; for i:=0 to SIZE-1 do begin table[i].index:=i; table[i].val:=0; end; end; procedure PrintPattern(var f:text;i:integer); var s:array[0..MAXPAT-1] of char; j,l:integer; begin for j:=1 to MAXPAT-1 do begin l := MAXPAT-(j+1); if (i and 1)<>0 then s[l]:='1' else s[l]:='0'; i:= i shr 1; end; j := 0; while(s[j]<>'1') do inc(j); inc(j); (* remove leading 1 *) while(j= hiBound) then (* Zero or one item to sort *) exit; if (hiBound-loBound = 1) then begin (* Two items to sort *) if LT(table[loBound] ,table[hiBound]) then begin temp := table[loBound]; table[loBound] := table[hiBound]; table[hiBound] := temp; end; exit; end; pivot := table[(loBound+hiBound) div 2]; (* 3 or more items to sort *) table[(loBound+hiBound) div 2] := table[loBound]; table[loBound] := pivot; loSwap := loBound + 1; hiSwap := hiBound; repeat while (loSwap <= hiSwap) and NOT LT(table[loSwap],pivot) do inc(loSwap); while LT(table[hiSwap],pivot) do dec(hiSwap); if (loSwap < hiSwap) then begin temp := table[loSwap]; table[loSwap] := table[hiSwap]; table[hiSwap] := temp; end; until (loSwap >= hiSwap); table[loBound] := table[hiSwap]; table[hiSwap] := pivot; Quicksort(loBound, hiSwap-1); Quicksort(hiSwap+1, hiBound); end; (* Quicksort *) procedure MakeListing(M:integer; L:integer;N:integer); label done; var T,i,lm:integer; c:LongInt; f:text; begin T := MSK[L]+1; QuickSort(MSK[M-1]+1,MSK[L]); i:=MSK[M-1]+1; lm:=0; assign(f,OUTFILE); rewrite(f); while (lm0) do begin c := table[i].val; write(f,c,' '); while table[i].val = c do begin PrintPattern(f,table[i].index); inc(i); if table[i].val = c then write(f,' ') else writeln(f); if i=T then goto done; end; inc(lm); end; done:; close(f) end; procedure ProcessFile(var f:text; M:integer; L:integer; T:integer); var i,mask,p,mu,pp,li:word; ch:char; b:longInt; goon:boolean; begin write('Scanning file ...'); p := 0; b := 0; { Set the bitmask for pattern length } mask := MSK[L+1]; { Init with first M bits } while b