lehmer.pas

FASTEST crypt and 32-bit PWD

var
s1:string;
s2:string;
s3:string;
pas:integer;
d:integer;
i:byte;
j:byte;
xxx:extended;
c:char;

begin
s1:=’aaabbbcccdddeeefff’;
j:=length(s1);
pas:=31112;
s2:=”;
//code
for i:=1 to j do begin
xxx:=sin(pas/100)*sin(pas)*11;
d:=trunc(xxx*pas);
pas:=d;
c:=s1[i];
c:=chr(ord(c)+d);
//writeln(c);
s2:=s2+c;
writeln(s2);
end;

pas:=31112;
//decode
j:=length(s2);
for i:=1 to j do begin
xxx:=sin(pas/100)*sin(pas)*11;
d:=trunc(xxx*pas);
pas:=d;
c:=s2[i];
c:=chr(ord(c)-d);
//writeln(c);
s3:=s3+c;
writeln(s3);
end;

writeln(0);
writeln(s1);
writeln(s2);
writeln(s3);
end.

How to negative 24-bit windows bitmap /w any pascal or fpc

(*) works fine

var
f1: file of char;
f2: file of char;
i: longint;
j: longint;
ch:char;
a:char;
b:char;
c:char;

begin
assign(f1,’1.bmp’);
reset(f1);
assign(f2,’neg.bmp’);
rewrite(f2);

j:=filesize(f1) div 1;

for i:=1 to 54 do
begin
read(f1,a);
ch:=a;
write(f2,ch);
end;

j:=j-54;

for i:=1 to j do
begin
read(f1,a);
ch:=chr(255 – ord(a));
write(f2,ch);
end;

close(f1);
close(f2);
end.

Prime numbers generator example code on GNU Fortran

(*) just wow =)

program primes
integer :: n
integer :: a
do n = 1, 32, 1
a = 12*n – 1
print *,a
end do
end

BlackJack-like game on Pure Basic

(+) very fast and easy code.

(++) console game only.

OpenConsole()
PrintN(“===================”)
PrintN(“Igra v kosti do 25.”)
PrintN(“===================”)
PrintN(“”)

s = 0

Repeat
Print(“Brosok igroka!”)
PrintN(“”)
dice = Random(6, 1)
dice2 = Random(6, 1)

Print(Str(dice))
Print(” x “)
Print(Str(dice2))

If dice = dice2
s = s + 2*dice + 2*dice2
EndIf

If dice <> dice2
s = s + dice + dice2
EndIf

PrintN(“”)
PrintN(Str(s))
Print(“Povtorim brosok? (y/n) “)
txt$=Input()

If txt$=”N”
txt$=”n”
EndIf

PrintN(“”)
Until txt$=”n”

Print(“PC vibrasyvaet.. “)
pc = Random(28, 15)
Print(Str(pc))
PrintN(“”)

If pc > 25
pc=0
EndIf
If s > 25
s=0
EndIf

If s > pc
PrintN(“YOU WIN!”)
EndIf

If s < pc
PrintN(“PC WINS!”)
EndIf

If s = pc
PrintN(“DRAW GAME”)
EndIf

Pack and unpack raw image (lossy)

(*) for full-grey 256 colors palette only.

var
f1: file of char;
f2: file of char;
f3: file of char;
i: longint;
j: longint;
ch:char;
a:char;
b:char;
c:char;

begin
assign(f1,’out2.raw’);
reset(f1);
assign(f2,’pack.raw’);
rewrite(f2);

j:=filesize(f1) div 2;

for i:=1 to j do
begin
read(f1,a);
write(f2,a);
read(f1,a);
end;

close(f1);
close(f2);

assign(f3,’unp.raw’);
rewrite(f3);
assign(f1,’pack.raw’);
reset(f1);
ch:=(chr(0));

j:=filesize(f1) div 2;
for i:=1 to j do
begin
read(f1,a);

ch:=chr(ord(a) div 2 + ord(ch) div 2);
write(f3,ch);

read(f1,b);
c:=chr(ord(a) div 2 + ord(b) div 2);
write(f3,a);
write(f3,c);
write(f3,b);
end;

close(f1);
close(f3);

end.

How to negative raw image

(*) works nice.

var
f1: file of char;
f2: file of char;
i: longint;
j: longint;
ch:char;
a:char;
b:char;
c:char;

begin
assign(f1,’out2.raw’);
reset(f1);
assign(f2,’neg.raw’);
rewrite(f2);

j:=filesize(f1) div 1;

for i:=1 to j do
begin
read(f1,a);
ch:=chr(255 – ord(a));
write(f2,ch);
end;

close(f1);
close(f2);
end.

True monochromization with Pascal

(*) my best version.. the

var
f1: file of char;
f2: file of char;
i: longint;
j: longint;
ch:char;
a:char;
b:char;
c:char;

begin
assign(f1,’xxx.raw’);
reset(f1);
assign(f2,’out2.raw’);
rewrite(f2);

j:=filesize(f1) div 3;

for i:=1 to j do
begin
read(f1,a);
read(f1,b);
read(f1,c);
ch:=chr(ord(a) div 3 + ord(b) div 2 + ord(c) div 17);
write(f2,ch);
end;

close(f1);
close(f2);
end.

Monochromization any RAW RGB image

(*) any pascals…

(**) just ripping-off red

var
f1: file of char;
f2: file of char;
i: longint;
j: longint;
ch:char;
begin
assign(f1,’xxx.raw’);
reset(f1);
assign(f2,’out.raw’);
rewrite(f2);

j:=filesize(f1) div 3;

for i:=1 to j do
begin
read(f1,ch);
write(f2,ch);
read(f1,ch);
read(f1,ch);
end;

close(f1);
close(f2);
end.

Another fast factorial /w pascal lng

(*) 101 method of factorization function!!!!1111

program factorialsyeah;

function fastfa(x:byte):longint ;
begin
if x=0 then fastfa:=1;
if x=1 then fastfa:=1;
if x=2 then fastfa:=2;
if x=3 then fastfa:=6;
if x=4 then fastfa:=24;

end;
var
a: longint;
begin
for a:=1 to 1234 do writeln(fastfa(4));
end.

Power of number function fpc

(*) for pascal only…

function pow(x,y:integer):longint;
var
i:integer;
begin
pow:=1;
for i:=1 to y do pow:=pow*x;
end;