Hathanh.inp

{Hathanh.inp}
Var S:String;
dem,k,i:Byte;
ch:Char;
Begin
S:=`Hathanh`;
k:=length(s);
For i:=1 to k do s[i]:=upcase(s[i]);
While s<>`` do
Begin
ch:=S[1]; dem:=0;
While pos(ch,s)>0 do
Begin
k:=pos(ch,s);
dem:=dem+1;
Delete(s,k,1);
End;
Writeln(`Ki tu `,ch, ` xuat hien `,dem);
End;
Readln;
End.

Program Bai4_38;
Uses CRT;
Var S: String;
x,y,x1,y1:Integer;
Begin
clrscr;
Write(` Nhap toa do x1 , y1= `);
Readln(x1,y1);
s:=``;x:=0;y:=0;
If (x1<>0) and (y1<>0) Then
Begin
While x<=abs(x1) do
Begin
If x1 >0 Then S:=S+`E` Else S:=S+`W`;
x:=x+1;
End;
While y<=abs(y1) do
Begin
If y1>0 Then S:=S+`N` Else S:=S+`S`;
y:=y+1;
End;
If x1>0 Then
If y1>0 Then s:=s+`WS` Else s:=s+`WN`
Else If y1>0 Then s:=s+`SE` Else s:=s+`EN`;
End
Else
Begin
If x1 = 0 Then
Begin
s:=s+`E`;
For x:=1 to abs(y1)+1 do
If y1>0 Then s:=s+`N`
Else s:=s+`S`;
s:=s+`W`;
If y1>0 Then s:=s+`S` Else s:=s+`N`;
End;
If y1 = 0 Then
Begin
s:=s+`N`;
For y:=1 to abs(x1)+1 do
If x1>0 Then s:=s+`E`
Else s:=s+`W`;
s:=s+`S`;
If x1>0 Then s:=s+`W` Else s:=s+`E`;
End;
End;
Writeln(` Chuong trinh: `,s);
Readln;

End.

Bài Josephus
Uses Crt;
Var a:Array[1..100]of 0..1;
i,n,d,b:Byte;
Begin
Clrscr;
Write(` Nhap n = `);
Readln(n); {d:=1;}
Fillchar(a,sizeof(a),1);
i:=1; b:=1;d:=0;
While d Begin
If (a[i] =1) And (b=3) Then
Begin
a[i]:=0;b:=1;
d:=d+1;
End;
If a[i]=1 then b:=b+1;
if i=n Then i:=1 Else i:=i+1;
End;
For i:=1 to n do If a[i]=1 Then Write(i,` `);
Readln;
End.