阿狸的打字机

70分 裸的AC自动机

program type2;
type
	node=record
		son:array[0..25]of longint;
		fa,fail,key,e:longint;
	end;
var	a:array[1..100005]of node; sto:longint=1;
	st:array[1..100005]of char; len:longint;
	q,head,next:array[1..100005]of longint;
	ans,lk:array[1..100005]of longint; n:longint;
	ask:array[1..100005,0..2]of longint;
	m:longint;
function getfail(const x:longint):longint;
var	k,w:longint;
begin
	if (x=1)then exit(0);
	k:=a[x].key;
	w:=a[a[x].fa].fail;
	while (w>0)and(a[w].son[k]=0) do w:=a[w].fail;
	if w=0 then exit(1) else exit(a[w].son[k]);
end;
procedure buildac;
var	h,t,x,i:longint;
begin
	h:=0;t:=1;q[1]:=1;
	while h<t do begin
		inc(h);x:=q[h];a[x].fail:=getfail(x);
		for i:=0 to 25 do if a[x].son[i]>0 then begin
			inc(t);q[t]:=a[x].son[i];
		end;
	end;
end;
procedure init;	var ch:char; w,k,i:longint;
begin
	w:=1;
	while not eoln do begin
		inc(len);read(ch);st[len]:=ch;
		case ch of
		'B':w:=a[w].fa;
		'P':begin inc(n); lk[n]:=w; a[w].e:=n; end;
		'a'..'z':begin
			k:=ord(ch)-ord('a');
			if a[w].son[k]=0 then begin
				inc(sto);a[w].son[k]:=sto;
				a[sto].fa:=w;a[sto].key:=k;
			end;
			w:=a[w].son[k];
			end;
		end;
	end;
	buildac;
	readln(m);
	for i:=1 to m do begin
		readln(ask[i][0],ask[i][1]);
		//ask[i][0]:=lk[ask[i][0]];
		ask[i][1]:=lk[ask[i][1]];
		next[i]:=head[ask[i][1]];
		head[ask[i][1]]:=i;
	end;
end;
procedure solve; var w,x,i,p:longint;ch:char;
begin
	w:=1;
	for i:=1 to len do begin
		ch:=st[i];
		case ch of
		'B':w:=a[w].fa;
		'P':begin
			fillchar(ans,sizeof(ans),0);
                        if head[w]=0 then continue;
                        p:=w;
			while w>1 do begin
				x:=w;
				while x>0 do begin
					if a[x].e>0 then inc(ans[a[x].e]);
					x:=a[x].fail;
				end;
				w:=a[w].fa;
			end;
                        w:=p;
			x:=head[w];
			while x<>0 do begin
				ask[x][2]:=ans[ask[x][0]];;
				x:=next[x];
			end;
		end;
		'a'..'z':w:=a[w].son[ord(ch)-ord('a')];
		end;
	end;
	for p:=1 to m do writeln(ask[p][2]);
end;
begin
	assign(input,'input.txt');reset(input);
	assign(output,'output.txt');rewrite(output);
	init;
	solve;
	close(input);close(output);
end.

满分程序（+dfs序优化）

program type2;
type
	node=record
		son:array[0..25]of longint;
		fa,fail,key,e:longint;
	end;
	heap=object
		s:array[1..100005]of longint;
		procedure add(x,k:longint);
		function sum(x:longint):longint;
	end;
	link=^Tnode;
	Tnode=record
		x:longint;
		next:link;
	end;
var	sto:longint=1;
procedure push(var x:link; const t:longint);
var 	p:link;
begin
	new(p); p^.x:=t; p^.next:=x; x:=p;
end;
procedure heap.add(x,k:longint);
begin
	while x<=sto do begin
		inc(s[x],k);
		inc(x,x and (-x));
	end;
end;
function heap.sum(x:longint):longint;
begin
	sum:=0;
	while x>0 do begin
		inc(sum,s[x]);
		dec(x,x and (-x));
	end;
end;

(*	definitions	for 	useful	objects		*)

var	a:array[0..100005]of node;
	st:array[1..100005]of char; len:longint;
	q,head,next:array[0..100005]of longint;
	ge:array[0..100005]of link;
	lk,ls,le:array[0..100005]of longint; n,tt:longint;
	ask:array[1..100005,0..2]of longint;
	m:longint; ans:Heap;
function getfail(const x:longint):longint;
var	k,w:longint;
begin
	if (x=1)then exit(0);
	k:=a[x].key;
	w:=a[a[x].fa].fail;
	while (w>0)and(a[w].son[k]=0) do w:=a[w].fail;
	if w=0 then exit(1) else exit(a[w].son[k]);
end;
procedure buildac;
var	h,t,x,i:longint;
begin
	h:=0;t:=1;q[1]:=1;
	while h<t do begin
		inc(h);x:=q[h];a[x].fail:=getfail(x);
		if x<>1 then push(ge[a[x].fail],x);
		for i:=0 to 25 do if a[x].son[i]>0 then begin
			inc(t);q[t]:=a[x].son[i];
		end;
	end;
end;
procedure DFS(const x:longint); var p:link;
begin
	inc(tt);ls[x]:=tt;
	p:=ge[x];while p<>nil do begin
		DFS(p^.x);p:=p^.next;
	end;le[x]:=tt;
end;
procedure init;	var ch:char; w,k,i:longint;
begin
	w:=1;
	while not eoln do begin
		inc(len);read(ch);st[len]:=ch;
		case ch of
		'B':w:=a[w].fa;
		'P':begin inc(n); lk[n]:=w; a[w].e:=n; end;
		'a'..'z':begin
			k:=ord(ch)-ord('a');
			if a[w].son[k]=0 then begin
				inc(sto);a[w].son[k]:=sto;
				a[sto].fa:=w;a[sto].key:=k;
			end;
			w:=a[w].son[k];
			end;
		end;
	end;
	buildac;
	DFS(1);
	readln(m);
	for i:=1 to m do begin
		readln(ask[i][0],ask[i][1]);
		ask[i][0]:=lk[ask[i][0]];
		ask[i][1]:=lk[ask[i][1]];
		next[i]:=head[ask[i][1]];
		head[ask[i][1]]:=i;
	end;
end;
procedure solve; var w,x,i:longint;ch:char;
begin
	w:=1;
	for i:=1 to len do begin
		ch:=st[i];
		case ch of
		'B':begin
			ans.add(ls[w],-1);
			w:=a[w].fa;
		end;
		'P':begin
			x:=head[w];
			while x<>0 do begin
				ask[x][2]:=ans.sum(le[ask[x][0]])-ans.sum(ls[ask[x][0]]-1);
				x:=next[x];
			end;
		end;
		'a'..'z':begin w:=a[w].son[ord(ch)-ord('a')]; ans.add(ls[w],1); end;
		end;
	end;
	for i:=1 to m do writeln(ask[i][2]);
end;
begin
	assign(input,'input.txt');reset(input);
	assign(output,'output.txt');rewrite(output);
	init;
	solve;
	close(input);close(output);
end.