Дана строка, подсчитать, сколько различных символов встречается в ней только один раз

uses crt;
var m,d,b,i,k:integer;
begin
write('Количество болтов до ',nmax,' m=');
read(m);
write('Введите диаметр отверстия d=');
read(d);
writeln('Введите диаметры болтов:');
k:=0;
for i:=1 to m do
 begin
  write('Болт ',i,'=');
  read(b);
  if b<d then k:=k+1;
 end;
write('Количество болтов, которые пройдут в отверстие=',k);
end.

uses crt;
var s:string;
    i,k:integer;
begin
writeln('Введите строку:');
read(s);
writeln('Символы встречаются 1 раз:');
k:=0;
for i:=1 to length(s) do
if(pos(s[i],copy(s,1,i-1))=0)and(pos(s[i],copy(s,i+1,length(s)-i))=0)then
 begin
  k:=k+1;
  write(s[i]);
 end;
if k=0 then write('Таких символов нет')
else
 begin
  writeln;
  write('Количество=',k);
 end;
end.

var s:string;
i,j,count:integer;
f:boolean;
begin
readln (s);
Count:=0;
for i:=1 to length (s) do begin f:=false;
  for j:=1 to length (s) do
    if (s[i]=s[j])and(j<>i) then begin
       f:=true;
       Break
    end;
 if not f then begin
    Inc (count);
    writeln (s[i])
  end
end;
Write ('Count = ',count)
 
End.

{ Дана строка подсчитать сколько различных символов встречается в ней только 
один раз, в том порядке, в котором они встречаются в тексте. }
const
  n=255;
var
  s: string;
  a: array[0..n] of integer;
  i,j,k,x: integer;
begin
  readln(s);
  j:= 0;
  for i:= 1 to length(s) do
    begin
      k:= 0;
      x:= ord(s[i]);
      while (k<=j) and (x<>a[k]) do
        inc(k);
      if (k>j) then
        begin
          inc(j);
          a[j] := x;
        end
      else
        a[k] := -1;
    end;
 
  for k:= 0 to j do
    if a[k]>0 then write(chr(a[k]));
  writeln;
  readln;
end.

{ Дана строка подсчитать сколько различных символов встречается в ней только 
один раз, в том порядке, в котором они встречаются в тексте. }
const
  n=255;
var
  s: string;
  a: array[0..n] of integer;
  i,j,k,x: integer;
begin
  readln(s);
  j:= 0;
  for i:= 1 to length(s) do
    begin
      k:= 0;
      x:= ord(s[i]);
      while (k<=j) and (x<>a[k]) and (x+1000<>a[k]) do
        inc(k);
      if (k>j) then
        begin
          inc(j);
          a[j] := x;
        end
      else if x=a[k] then
        a[k]:= a[k]+1000;
    end;
 
  i:= 0;
  for k:= 0 to j do
    if (a[k]>0) and (a[k]<256) then
      begin
        inc(i);
        write(chr(a[k]));
      end;
  writeln;
  writeln(i, ' симв. встречаются по одному разу');
  readln;
end.