mbirth/pascal
Archived
1
0
Fork 0
Code Pull Requests Activity

Initial commit

Browse Source
This commit is contained in:
Markus Birth
2001-11-30 12:14:44 +01:00
commit bc7c109b0c
380 changed files with 26247 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

53
ITG/AUGENZ.PAS Normal file
View File

@ -0,0 +1,53 @@
program Augensumme;
uses Crt;
const p: char='|';
var A: array[1..12] of longint;
n: longint;
procedure Progress;
begin
case p of
'|': p:='/';
'/': p:='-';
'-': p:='\';
'\': p:='|';
end;
GotoXY(WhereX-1,WhereY);
Write(p);
end;
procedure Calc;
var x: byte;
begin
x := Random(6)+Random(6)+2;
Inc(A[x]);
Inc(A[1]);
end;
procedure Auswertung;
var x: byte;
begin
for x:=2 to 12 do begin
WriteLn(x:2,' Augen: ',A[x]:7,' Treffer = ',(A[x]/A[1])*100:6:2,'%');
end;
end;
begin
WriteLn('<====*====>');
Write('Dr<44>cken Sie eine Taste, um den Versuch zu beenden. ');
repeat
Calc;
if A[1]/50000=A[1] DIV 50000 then Progress;
until keypressed;
ReadKey;
GotoXY(WhereX-1,WhereY); WriteLn(' ');
WriteLn;
Auswertung;
WriteLn;
WriteLn('Bitte eine Taste dr<64>cken');
ReadKey;
end.

76
ITG/AUSFLUG.PAS Normal file
View File

@ -0,0 +1,76 @@
program Bahnausflug;
{ Ein Club plant einen Ausflug mit einer Privatbahn. Dort kostet ein
Tarifkilometer 20 Pf und bei Gruppenreisen hat jeder 6. Reisende eine
Freifahrt. Es ist ein Programm zu schreiben, da<64> die Fahrtkosten pro
Person f<>r eine beliebige Anzahl von Reisenden und Kilometern ermittelt,
wobei die Gesamtkosten auf alle Teilnehmer gleichm<68><6D>ig umgelegt werden. }
uses Crt,VFx;
const money=0.20;
var people,km: longint;
procedure Init;
var mon: string;
begin
TextBackground(0);
ClrScr;
DrawBorder(40,12,15,1,5);
FXWriteC('-=<3D>+ Bahnkostenberechnung +<2B>=-',14);
WriteLn;
TextColor(10);
Str(money:0:2,mon);
WriteCLn('Der Preis pro Tarifkilometer betr<74>gt '+mon+' DM.');
TextColor(11);
WriteLn;
ReadyBeep;
end;
procedure GetData;
begin
Write('Okay, wieviel Leutchens sollen''s denn werden? ');
ReadLn(people);
AckBeep;
if people=1 then Write('Und wieviel Kilometer will diese Person fahren? ')
else Write('Und wieviel Kilometer wollen diese ',people,' Personen fahren? ');
ReadLn(km);
WriteLn;
AckBeep;
end;
procedure PrintData;
var freepeople,restpeople: longint;
geldges,geldpro: extended;
begin
TextColor(15);
freepeople := people div 6;
case freepeople of
0: CWriteLn('Es f<>hrt niemand kostenlos! %%12#(NICHTS IST UMSONST!!)%%15#');
1: WriteLn('Es f<>hrt eine Person kostenlos.');
else
WriteLn('Es fahren ',freepeople:0,' Personen kostenlos.');
end;
restpeople := people - freepeople;
if restpeople=1 then Write('Und diese eine Person mu<6D> ')
else Write('Und ',restpeople,' der ',people,' Personen m<>ssen insgesamt ');
geldges := restpeople * km * money;
WriteLn(geldges:0:2,' DM hinbl<62>ttern.');
geldpro := km * money;
if restpeople>1 then WriteLn('Das hei<65>t, jeder mu<6D> ',geldpro:0:2,' DM hinlegen.');
WriteLn;
TextColor(7);
WriteLn('Vielen Dank, da<64> Sie dieses Program benutzt haben.');
WaitBeep;
WriteLn;
CWriteLn('%%142#=== Dr<44>cken Sie eine Taste! ===%%7#');
ReadKey;
end;
begin
Init;
GetData;
PrintData;
end.

24
ITG/BINSRCH.PAS Normal file
View File

@ -0,0 +1,24 @@
function bin_searchrekursiv(left, right, key: word): word;
var x: word;
begin
if left>right then bin_searchrekursiv:=0
else begin
x := (left+right) DIV 2;
if key < F[x] then bin_searchrekursiv(left, x-1, key)
else if key > F[x] then bin_searchrekursiv(x+1,right, key)
else bin_searchrekursiv := x;
end;
end;
function bin_searchiterativ(key: word): word;
var left, right, x: word;
begin
left := 1;
right := max;
repeat
x := (left + right) DIV 2;
if key<F[x] then right := x-1 else left := x+1;
until (key=F[x]) OR (left>right);
if key=F[x] then bin_searchiterativ := x;
else bin_searchiterativ := 0;
end;

66
ITG/CODING.PAS Normal file
View File

@ -0,0 +1,66 @@
program Coding;
uses Crt;
const satz='ICH BIN HIER UND DU BIST DA! NUN BIN ICH DA UND DU BIST HIER. BLI BLA BLO BL<42><4C> ';
var A: array[1..40,1..40] of char;
procedure Init;
var i,j: byte;
begin
TextMode(co80+Font8x8);
for i:=1 to 40 do begin
for j:=1 to 40 do begin
A[i,j] := ' ';
end;
end;
end;
procedure Ausgabe;
var i,j: byte;
begin
for i:=1 to 40 do begin
for j:=1 to 40 do begin
GotoXY(j,i);
Write(A[j,i]);
end;
end;
ReadKey;
end;
procedure Code(x: string);
var i,j: byte;
begin
Randomize;
for j:=1 to 40 do begin
A[j,j] := x[j];
A[41-j,j] := x[40+j];
end;
for i:=1 to 40 do begin
for j:=1 to 40 do begin
if A[i,j]=' ' then A[i,j]:=Chr(65+Random(26));
end;
end;
end;
procedure Decode;
var i: byte;
begin
ClrScr;
for i:=1 to 40 do begin
GotoXY(i,1);
Write(A[i,i]);
GotoXY(40+i,1);
Write(A[41-i,i]);
end;
end;
begin
Init;
Ausgabe;
Code(satz);
Ausgabe;
Decode;
end.

402
ITG/DISTANCE.PAS Normal file
View File

@ -0,0 +1,402 @@
program Distances; { Autor: Markus Birth <mbirth@webwriters.de> }
uses Crt, Graph, GUI;
type ttabelle = array[1..10,1..10] of word;
cityrec = record
x: integer;
y: integer;
n: string[20];
end;
xyrec = record
x: integer;
y: integer;
end;
const tabelle: ttabelle=(( 0,530,555,289,378,370,569,584,616,596),
(530, 0,249,385,207,478, 68,638,700,513),
(555,249, 0,495,193,588,189,395,457,294),
(289,385,495, 0,307, 93,422,782,844,777),
(378,207,193,307, 0,400,249,482,544,475),
(370,478,588, 93,400, 0,515,875,937,870),
(569, 68,189,422,249,515, 0,578,640,453),
(584,638,395,782,482,875,578, 0,179,139),
(616,700,457,844,544,937,640,179, 0,310),
(596,513,294,777,475,870,453,139,310, 0));
map: array[1..52] of xyrec=((x:33;y: 4),(x:36;y: 5),(x:37;y: 5),
(x:38;y: 7),(x:40;y: 7),(x:41;y: 8),
(x:37;y:13),(x:41;y:14),(x:41;y:22),
(x:42;y:23),(x:41;y:24),(x:40;y:24),
(x:30;y:29),(x:33;y:33),(x:38;y:37),
(x:38;y:40),(x:35;y:42),(x:37;y:46),
(x:32;y:45),(x:27;y:46),(x:22;y:46),
(x:21;y:47),(x:16;y:45),(x:10;y:47),
(x: 8;y:46),(x: 9;y:40),(x:12;y:38),
(x: 3;y:33),(x: 2;y:30),(x: 4;y:28),
(x: 1;y:25),(x: 3;y:21),(x: 2;y:19),
(x: 4;y:18),(x: 7;y:15),(x: 5;y:14),
(x: 7;y:11),(x: 6;y: 9),(x: 8;y: 8),
(x: 9;y: 7),(x:12;y: 7),(x:14;y: 8),
(x:15;y: 6),(x:17;y: 6),(x:18;y: 1),
(x:22;y: 2),(x:23;y: 7),(x:28;y: 6),
(x:27;y: 8),(x:28;y:10),(x:31;y: 6),
(x:33;y: 4));
mapfact: xyrec = (x:7;y:7);
citycount: byte=10;
city: array[1..10] of cityrec=((x:36;y:16;n:'Berlin'),
(x: 7;y:23;n:'Essen'),
(x:15;y:31;n:'Frankfurt am Main'),
(x:23;y:12;n:'Hamburg'),
(x:18;y:22;n:'Kassel'),
(x:24;y: 9;n:'Kiel'),
(x: 8;y:27;n:'K<>ln'),
(x:27;y:43;n:'M<>nchen'),
(x:36;y:40;n:'Passau'),
(x:20;y:41;n:'Ulm'));
desktopcolor=3;
var xmax, ymax, xmed, ymed: word;
cityrp: array[1..10] of xyrec;
WP: array[1..50] of byte;
WPuptodate: boolean;
buttondown: boolean;
{ V2S(x) - Liefert angegebenen Word-Wert als String mit 3 Stellen
Input: word
Output: string }
function V2S(x: word): string;
var tmp: string;
begin
Str(x:3,tmp);
V2S := tmp;
end;
{ Dist(c1,c2) - Liefert Entfernung zwischen St<53>dteindizes c1 und c2
Input: byte, byte
Output: integer }
function Dist(wp1,wp2: byte): integer;
begin
Dist := tabelle[wp1,wp2];
end;
{ WPmax - Liefert Index des letzten Wegpunktes im WP-Array
Input: none
Output: byte }
function WPmax: byte;
var i: byte;
begin
for i:=1 to 50 do if (WP[i]=255) then WPmax := i-1;
end;
{ UpdateDist - Refreshed die Entfernungsanzeige
Input: none
Output: none }
procedure UpdateDist;
var i: byte;
dst: integer;
dis: string;
begin
dst := 0;
if (WPmax>1) then for i:=1 to WPmax-1 do begin
dst := dst + Dist(WP[i],WP[i+1]);
end;
SetFillStyle(SolidFill,7);
SetColor(0);
Bar(53,398,247,457);
SetViewPort(53,398,247,457,ClipOn);
SetTextStyle(TripleXFont,HorizDir,4);
SetTextJustify(RightText,CenterText);
Str(dst:4,dis);
dis := dis + ' km';
OutTextXY(187,17,dis);
SetViewPort(0,0,639,479,ClipOff);
end;
{ ShowGermany - Zeichnet/refreshed die Deutschlandkarte
Input: none
Output: none }
procedure ShowGermany;
const xd=7;
yd=22;
var k,x,y: integer;
begin
Frame(8,26,312,362,0,0,7,1,false);
SetColor(15);
for k:=1 to 51 do line((map[k].x*mapfact.x)+xd,(map[k].y*mapfact.y)+yd,(map[k+1].x*mapfact.x)+xd,(map[k+1].y*mapfact.y)+yd);
SetTextJustify(CenterText,TopText);
SetTextStyle(SmallFont,HorizDir,4);
for k:=1 to 10 do begin
x:=city[k].x*mapfact.x+xd;
y:=city[k].y*mapfact.y+yd;
cityrp[k].x:=x;
cityrp[k].y:=y;
PutPixel(x,y,15);
PutPixel(x+1,y,7);
PutPixel(x-1,y,7);
PutPixel(x,y-1,7);
PutPixel(x,y+1,7);
PutPixel(x-1,y-1,8);
PutPixel(x-1,y+1,8);
PutPixel(x+1,y-1,8);
PutPixel(x+1,y+1,8);
if (WP[1]=k) then SetColor(10)
else if (WP[WPmax]=k) then SetColor(12)
else SetColor(11);
OutTextXY(x+2,y+2,city[k].n);
if (WP[WPmax]=k) OR (WP[1]=k) then OutTextXY(x+3,y+2,city[k].n);
end;
end;
{ UpdatePath - Refreshed die Weglinien
Input: none
Output: none }
procedure UpdatePath;
var i: byte;
begin
ShowGermany;
MoveTo(cityrp[WP[1]].x,cityrp[WP[1]].y);
SetColor(9);
for i:=2 to WPmax do begin
if (i=WPmax) then SetColor(12);
LineTo(cityrp[WP[i]].x,cityrp[WP[i]].y);
end;
end;
{ UpdateWP - Refreshed die Wegpunkte-Liste
Input: none
Output: none }
procedure UpdateWP;
var i: byte;
begin
if (NOT WPuptodate) then begin
SetFillStyle(SolidFill,7);
Bar(328,30,527,397);
SetViewPort(328,30,527,397,ClipOn);
SetColor(0);
for i:=1 to WPmax do begin
SetTextJustify(RightText,CenterText);
SetTextStyle(SmallFont,HorizDir,4);
OutTextXY(19,i*9-5,V2S(i)+'.');
SetTextJustify(LeftText,CenterText);
OutTextXY(20,i*9-5,city[WP[i]].n);
OutTextXY(21,i*9-5,city[WP[i]].n);
SetTextJustify(RightText,CenterText);
SetTextStyle(SmallFont,HorizDir,4);
if i>1 then begin
OutTextXY(160,i*9-5,V2S(Dist(WP[i],WP[i-1])));
end else begin
OutTextXY(160,i*9-5,'---');
end;
Rectangle(167,i*9-8,192,i*9);
SetTextStyle(SmallFont,HorizDir,2);
SetTextJustify(CenterText,CenterText);
OutTextXY(179,i*9-5,'CLEAR');
end;
SetViewPort(0,0,639,479,ClipOff);
UpdateDist;
UpdatePath;
WPuptodate := true;
end;
end;
{ AddWP(x) - H<>ngt Wegpunkt bei Stadt x an das WP-Array an
Input: byte
Output: none }
procedure AddWP(what: byte);
var wpm: byte;
begin
wpm := WPmax;
if (wpm+1>1) then begin
if (WP[wpm]<>what) then begin
if (wpm<49) then begin
WP[wpm+1] := what;
WP[wpm+2] := 255;
WPuptodate:=false;
end else begin
Sound(1200);
Delay(50);
NoSound;
end;
end;
end else begin
WP[1] := what;
WP[2] := 255;
WPuptodate:=false;
end;
UpdateWP;
end;
{ RemoveWP(x) - Entfernt den Wegpunkt mit Index x aus WP
Input: byte
Output: none }
procedure RemoveWP(which: byte);
var i: byte;
begin
for i:=which to 49 do WP[i] := WP[i+1];
WPuptodate:=false;
UpdateWP;
end;
{ Init - Alles, was initialisiert werden mu<6D>, grundlegende Vardefs
Input: none
Output: none }
procedure Init;
var grDriver, grMode: integer;
BGIPath: string;
begin
grDriver := VGA;
grMode := VGAHi;
initp_del := 30;
BGIPath := 'D:\BP\BGI\';
InitGraph(grDriver, grMode, BGIPath);
xmax := GetMaxX+1; { Bildschirmbreite in Pixeln }
ymax := GetMaxY+1; { Bildschirmh<6D>he in Pixeln }
xmed := xmax DIV 2;
ymed := ymax DIV 2;
WP[1] := 255;
WPuptodate := false;
buttondown := false;
om := 0;
SetTextStyle(DefaultFont,HorizDir,1);
SetTextJustify(LeftText,TopText);
SetFillStyle(SolidFill,desktopcolor);
Bar(0,0,xmax-1,ymax-1);
ClearStatus;
end;
{ Outit - Alles, um wieder auf Normalwerte zu kommen ...
Input: none
Output: none }
procedure Outit;
var i,ad,wpm: integer;
begin
wpm := WPmax;
TextMode(CO80);
WriteLn('VMode : ',xmax,'x',ymax);
WriteLn('Center: ',xmed,'x',ymed);
WriteLn;
if wpm>1 then begin
ad := 0;
Write('Strecke: ');
for i:=1 to wpm do begin
if (i>1) then Write(', ',city[WP[i]].n) else Write(city[WP[i]].n);
if (i<wpm) then ad := ad + Dist(WP[i],WP[i+1]);
end;
WriteLn;
WriteLn('Entfernung: ',ad,' km');
WriteLn;
end;
Write('Programm beendet.');
if (wpm>1) then WriteLn(' Viel Vergn<67>gen in ',city[WP[wpm]].n,'!') else WriteLn;
end;
{ StartScreen - Zeichnet Anfangs-Logo und nach Tastendruck den Mainscreen
Input: none
Output: none }
procedure StartScreen;
begin
MakeWindow(120,140,520,340,'Entfernungstabelle');
SetViewPort(123,161,517,337,ClipOn);
SetColor(9);
SetTextStyle(TripleXFont,HorizDir,10);
SetTextJustify(CenterText,CenterText);
OutTextXY(200,24,'GUI');
OutTextXY(200,26,'GUI');
OutTextXY(199,25,'GUI');
OutTextXY(201,25,'GUI');
SetTextStyle(SansSerifFont,HorizDir,2);
OutTextXY(200,100,'GRAPHICAL USER INTERFACE');
SetColor(0);
SetTextStyle(SmallFont,HorizDir,5);
OutTextXY(200,165,'geschrieben von Markus Birth <mbirth@webwriters.de>');
SetTextStyle(SmallFont,VertDir,4);
SetTextJustify(CenterText,TopText);
SetColor(8);
OutTextXY(385,2,'(c)1999 Web - Writers');
SetColor(0);
SetTextStyle(DefaultFont,HorizDir,1);
OutTextXY(200,140,'Initialisiere Farbpalette ...');
Delay(1000);
InitPalette;
SetFillStyle(SolidFill,7);
Bar(0,130,400,150);
SetTextStyle(DefaultFont,HorizDir,1);
SetViewPort(0,0,639,479,ClipOff);
Status('Bitte dr<64>cken Sie irgendeine Taste (Maus oder Tastatur)');
ShowMouse(true);
repeat
MouseStat(mx,my,mb);
StatusTime(false);
until (keypressed) OR (mb<>0);
if keypressed then ReadKey;
ShowMouse(false);
SetFillStyle(SolidFill,desktopcolor);
Bar(120,140,520,340);
ClearStatus;
SetTextStyle(SmallFont,HorizDir,4);
SetColor(15);
OutTextXY(570,440,'Beenden durch Dr<44>cken');
OutTextXY(570,448,'einer Taste oder beider');
OutTextXY(570,456,'Maustasten gleichzeitig.');
MakeWindow(325,5,530,400,'Wegpunkte');
MakeWindow(50,370,250,460,'Entfernung');
MakeWindow(5,5,315,365,'Deutschlandkarte');
end;
{ CheckMouse - <20>berpr<70>fung der Mausposition und evtl. Subroutinen-Ausf<73>hrung
Input: none
Output: none }
procedure CheckMouse;
var i: byte;
over: boolean;
nst: string;
begin
if (mb<>0) then begin
if (NOT buttondown) then ShowMouse(false);
end else buttondown:=false;
over := false;
(* if (mb=0) then Status('X:'+V2S(mx)+' Y:'+V2S(my)); *)
for i:=1 to 10 do begin
if MouseOver(cityrp[i].x-5,cityrp[i].y-5,cityrp[i].x+5,cityrp[i].y+5) then begin
nst:=city[i].n+' (Klicken, um in Wegliste einzuf<75>gen)';
if (oldstat<>nst) then Status(nst);
over := true;
if (mb=1) AND (NOT buttondown) then begin
AddWP(i);
buttondown:=true;
end;
end;
end;
for i:=1 to WPmax do begin
if MouseOver(495,22+i*9,520,30+i*9) then begin
nst:='Klicken, um '+city[WP[i]].n+' aus der Wegliste zu entfernen';
if (oldstat<>nst) then Status(nst);
over := true;
if (mb=1) AND (NOT buttondown) then begin
RemoveWP(i);
buttondown:=true;
end;
end;
end;
if (NOT over) AND (oldstat<>'') then begin
ClearStatus;
oldstat:='';
end;
if (mb<>0) then ShowMouse(true);
end;
begin
Mousereset;
Init;
StartScreen;
ShowGermany;
ShowMouse(true);
repeat
MouseStat(mx,my,mb);
CheckMouse;
until (keypressed) OR (mb=3);
if (keypressed) then ReadKey;
FadeOut;
Outit;
end.

64
ITG/DREIECK.PAS Normal file
View File

@ -0,0 +1,64 @@
program Dreiecke;
uses Crt;
var a,b,c: real;
procedure GetData;
begin
Write('Geben Sie die L<>nge der Seite a ein: '); ReadLn(a);
Write('Und nun Seite b: '); ReadLn(b);
Write('Und jetzt noch c: '); ReadLn(c);
WriteLn('Danke!');
end;
function ProoveANG(x,y,z: real): boolean;
var j,k: real;
begin
j := Sqr(x);
k := Sqr(y);
if j+k>Sqr(z) then ProoveANG:=true else ProoveANG:=false;
end;
function ProovePYT(x,y,z: real): boolean;
var j,k: real;
begin
j := Sqr(x);
k := Sqr(y);
if j+k=Sqr(z) then ProovePYT:=true else ProovePYT:=false;
end;
function Gleichseitig: boolean;
begin
if ((a=b) AND (b=c)) then Gleichseitig:=true else Gleichseitig:=false;
end;
function Gleichschenklig: boolean;
begin
if ((a=b) OR (b=c) OR (a=c)) then Gleichschenklig:=true else Gleichschenklig:=false;
end;
function Rechtwinklig: boolean;
begin
if ((ProovePYT(a,b,c)) OR (ProovePYT(b,c,a)) OR (ProovePYT(a,c,b))) then Rechtwinklig:=true
else Rechtwinklig:=false;
end;
function Spitzwinklig: boolean;
begin
if ((ProoveANG(a,b,c)) AND (ProoveANG(b,c,a)) AND (ProoveANG(a,c,b))) then Spitzwinklig:=true
else Spitzwinklig:=false;
end;
begin
ClrScr;
GetData;
WriteLn;
if Gleichseitig then WriteLn('Das Teil ist gleichseitig!');
if Gleichschenklig then WriteLn('Das Ding ist gleichschenklich!!');
if Rechtwinklig then WriteLn('Und rechtwinklig ist es auch noch!');
if Spitzwinklig then WriteLn('Spitzwinklig ist es! Ja, Spitzwinklig!');
WriteLn;
WriteLn('Ich habe dem nix hinzuzuf<75>gen!');
WriteLn('Fertich, Meister!');
end.

175
ITG/EXPLODER.PAS Normal file
View File

@ -0,0 +1,175 @@
program Exploder;
{
#016 > filled
#017 < filled
}
uses Crt, DOS, Numbers, VFx;
const StartPath='.\';
var cur: SearchRec;
procedure Init;
begin
TextMode(co80 + Font8x8);
TextBackground(0);
TextColor(7);
end;
procedure SWindow(x1,y1,x2,y2: integer; fg, bg: byte; BType: byte);
var i,j: integer;
Border: string[8];
begin
if BType=1 then Border := 'ڿ<>ٳ<EFBFBD><D9B3><EFBFBD>';
if BType=2 then Border := 'ɻȼ<C9BB><C8BC><EFBFBD><EFBFBD>';
if BType=3 then Border := 'ոԾ<D5B8><D4BE><EFBFBD><EFBFBD>';
if BType=4 then Border := 'ַӽ<D6B7><D3BD><EFBFBD><EFBFBD>';
if BType=5 then Border := '<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>';
if BType=6 then Border := 'ڷԼ<DAB7><D4BC><EFBFBD><EFBFBD>';
DWrite(x1,y1,fg,bg,Border[1]);
DWrite(x2,y1,fg,bg,Border[2]);
DWrite(x1,y2,fg,bg,Border[3]);
DWrite(x2,y2,fg,bg,Border[4]);
for i:=y1+1 to y2-1 do begin
DWrite(x1,i,fg,bg,Border[5]);
DWrite(x2,i,fg,bg,Border[6]);
end;
for i:=x1+1 to x2-1 do begin
DWrite(i,y1,fg,bg,Border[7]);
DWrite(i,y2,fg,bg,Border[8]);
end;
for i:=x1+1 to x2-1 do
for j:=y1+1 to y2-1 do begin
DWrite(i,j,fg,bg,' ');
end;
end;
procedure TurnAround(var x: string);
var i: integer;
tmp: string;
begin
tmp := '';
for i:=Length(x) downto 1 do begin
tmp := tmp + x[i];
end;
x := tmp;
end;
function GetName(x: string): string;
var i: byte;
it: boolean;
begin
it := false;
if (x[1]='.') then begin
GetName:=x;
Exit;
end;
for i:=1 to Length(x) do
if x[i]='.' then begin
GetName := Copy(x,1,i-1);
it := true;
end;
if NOT it then GetName := x;
end;
function GetExt(x: string): string;
var i: byte;
it: boolean;
begin
it := false;
for i:=1 to Length(x) do
if x[i]='.' then begin
GetExt := Copy(x,i+1,Length(x)-i);
it := true;
end;
if NOT it then GetExt := '';
end;
function Fill(x: string): string;
var i: byte;
tmp: string;
begin
tmp := '';
for i:=Length(GetName(x))+1 to 8 do tmp := tmp + ' ';
Fill := tmp;
end;
function Fill2(x: string): string;
var i: byte;
tmp: string;
begin
tmp := '';
for i:=Length(GetExt(x))+1 to 3 do tmp := tmp + ' ';
Fill2 := tmp;
end;
{ Attribute list in binary
1st ReadOnly
2nd Hidden
3rd System
4th VolumeID
5th Directory
6th Archive
7th AnyFile }
procedure Add(var x: string; y: string);
begin
x := x + y;
end;
procedure WriteFile(f: SearchRec); forward;
procedure List;
var binattr: string;
strattr: string;
begin
{ ChDir(StartPath); }
FindFirst('*.*',AnyFile,cur);
while DosError<>18 do begin
binattr := Dec2Bin(cur.attr);
TurnAround(binattr);
if (binattr[5]='1') then TextColor(15)
else if (binattr[2]='1') then TextColor(8)
else if (binattr[3]='1') then TextColor(12)
else if (binattr[1]='1') then TextColor(10)
else if (binattr[4]='1') then TextColor(11)
else TextColor(7);
WriteFile(cur);
WriteLn;
FindNext(cur);
end;
end;
procedure WriteFile(f: SearchRec);
var binattr: string;
strattr: string;
begin
binattr := Dec2Bin(cur.attr);
TurnAround(binattr);
strattr := '';
if (binattr[5]='1') then Add(strattr,'D') else
if (binattr[4]='1') then Add(strattr,'V') else Add(strattr,'-');
if (binattr[6]='1') then Add(strattr,'A') else Add(strattr,'-');
if (binattr[1]='1') then Add(strattr,'R') else Add(strattr,'-');
if (binattr[2]='1') then Add(strattr,'H') else Add(strattr,'-');
if (binattr[3]='1') then Add(strattr,'S') else Add(strattr,'-');
Write(GetName(cur.name),Fill(cur.name),' ',GetExt(cur.name),Fill2(cur.name),'<27>');
if (binattr[5]='1') then Write(#017,' DIR ',#016) else
if (binattr[4]='1') then Write(#017,' VOL ',#016) else Write(cur.size:7);
Write('<27>',strattr);
end;
begin
Init;
SWindow(1,1,80,50,15,1,2);
Window(3,2,78,49);
List;
end.

27
ITG/FAKULT.PAS Normal file
View File

@ -0,0 +1,27 @@
program Fuck_ultaet;
var which: integer;
function Fak_Ite(m: integer): longint;
var i: integer;
tmp: longint;
begin
tmp := 1;
for i:=1 to m do begin
tmp := tmp * i;
end;
Fak_Ite := tmp;
end;
function Fak_Rek(m: integer): longint;
begin
if m=1 then Fak_Rek := 1 else Fak_Rek := m * Fak_Rek(m-1);
end;
begin
WriteLn('======================');
Write('Enter n: '); ReadLn(which);
WriteLn('Iterative: ',Fak_Ite(which));
WriteLn('Recursive: ',Fak_Rek(which));
end.

20
ITG/FENSTER1.PAS Normal file
View File

@ -0,0 +1,20 @@
program Fenster1;
uses crt;
procedure Ueberschrift(Text:string; VF,HF: byte);
begin
window(1,1,80,1);
TextColor(VF);
TextBackground(HF);
ClrScr;
GotoXY(40-(length(Text) DIV 2),1);
Write(Text);
end;
begin
TextBackground(0);
ClrScr;
Ueberschrift('Mal sehen was passiert, wenn die <20>berschrift die Zeilenl<6E>nge sprengt Test Test',10,1);
ReadKey;
end.

35
ITG/FIBONACC.PAS Normal file
View File

@ -0,0 +1,35 @@
program Fibonacci;
{ Die Fibonacci-Folge ist wie folgt aufgebaut: Jeder Wert wird aus der Summe
der zwei vorhergehenden Werte errechnet. Gegeben sind die ersten beiden
Zahlen: 0 und 1.
Der Anfang der Folge sieht so aus: 0,1,1,2,3,5,8,13,21,34,55,89,144,233,
377,610,987,1597,2584,4181,6765,.... }
uses crt;
var i: integer;
function Fibonacci_Loop(n: integer): longint;
var tmp,last1,last2,i: longint;
begin
last1:=0; last2:=0; tmp:=1;
if n>=2 then begin
for i:=1 to n do begin
tmp:=tmp+last2; last2:=last1; last1:=tmp;
end;
Fibonacci_Loop:=tmp;
end else Fibonacci_Loop:=n;
end;
begin
TextMode(C80 + Font8x8);
Window(1,1,40,50);
for i:=0 to 48 do begin
WriteLn(Fibonacci_Loop(i));
end;
Window(40,1,80,50);
for i:=49 to 97 do begin
WriteLn(Fibonacci_Loop(i));
end;
end.

35
ITG/FIBONA_F.PAS Normal file
View File

@ -0,0 +1,35 @@
program Fibonacci_FOR;
{ Die Fibonacci-Folge ist wie folgt aufgebaut: Jeder Wert wird aus der Summe
der zwei vorhergehenden Werte errechnet. Gegeben sind die ersten beiden
Zahlen: 0 und 1.
Der Anfang der Folge sieht so aus: 0,1,1,2,3,5,8,13,21,34,55,89,144,233,
377,610,987,1597,2584,4181,6765,.... }
uses crt;
var i: integer;
function Fibonacci_Loop(n: integer): longint;
var tmp,last1,last2,i: longint;
begin
last1:=0; last2:=0; tmp:=1;
if n>=2 then begin
for i:=1 to n do begin
tmp:=tmp+last2; last2:=last1; last1:=tmp;
end;
Fibonacci_Loop:=tmp;
end else Fibonacci_Loop:=n;
end;
begin
TextMode(C80 + Font8x8);
Window(1,1,40,50);
for i:=0 to 48 do begin
WriteLn(Fibonacci_Loop(i));
end;
Window(40,1,80,50);
for i:=49 to 97 do begin
WriteLn(Fibonacci_Loop(i));
end;
end.

33
ITG/FIBONA_R.PAS Normal file
View File

@ -0,0 +1,33 @@
program Fibonacci_rekursiv;
{ Die Fibonacci-Folge ist wie folgt aufgebaut: Jeder Wert wird aus der Summe
der zwei vorhergehenden Werte errechnet. Gegeben sind die ersten beiden
Zahlen: 0 und 1.
Der Anfang der Folge sieht so aus: 0,1,1,2,3,5,8,13,21,34,55,89,144,233,
377,610,987,1597,2584,4181,6765,.... }
uses crt;
var take: integer;
procedure Fibonacci_Recursive(a,b: longint);
begin
Inc(take);
WriteLn(a:10);
if take<47 then Fibonacci_Recursive(b,a+b);
end;
function Fibo(a: integer): longint;
begin
if (a=1) OR (a=2) then Fibo := 1
else if a=0 then Fibo := 0
else Fibo := Fibo(a-1)+Fibo(a-2);
end;
begin
TextMode(C80 + Font8x8);
take := 0;
Fibonacci_Recursive(0,1);
WriteLn(Fibo(20));
end.

66
ITG/GAUSS.PAS Normal file
View File

@ -0,0 +1,66 @@
program GAUSS;
uses Crt;
type GaRec=record
x: integer;
y: integer;
end;
var n: integer;
P: array[1..500] of GaRec;
A: real;
procedure Init;
var i: integer;
begin
for i:=1 to 500 do begin
P[i].x:=0;
P[i].y:=0;
end;
end;
procedure Input;
var i: integer;
tmp,t2: string;
begin
i:=1;
repeat
Str(i:0,t2);
tmp := 'P'+t2+'(';
Write(tmp);
ReadLn(P[i].x);
Str(P[i].x:0,t2);
tmp := tmp+t2+'|';
GotoXY(1,WhereY-1);
Write(tmp);
ReadLn(P[i].y);
Str(P[i].y:0,t2);
tmp := tmp+t2+')';
GotoXY(1,WhereY-1);
WriteLn(tmp);
Inc(i);
until (P[i-1].x=P[1].x) AND (P[i-1].y=P[1].y) AND (i>2);
n := i-2;
end;
procedure Calc;
var i: integer;
begin
A := 0;
for i:=1 to n do A := A + (P[i].x*P[i+1].y - P[i+1].x*P[i].y);
A := A / 2;
end;
procedure Output;
begin
WriteLn;
WriteLn('Fl<46>cheninhalt: ',A:0:5,' quadratsonstwas');
end;
begin
Init;
Input;
Calc;
Output;
end.

39
ITG/GEWICHT.PAS Normal file
View File

@ -0,0 +1,39 @@
{ Var Geschl:Char;
'Gr<47><72>e, Gewicht, Geschlecht angeben'
VAR Gr,Gew,Geschl eingeben
Geschl='m' ?
nein: Ideal := (gr-100)*0.9
ja: Ideal=(Gr-100)*0.95
Gew <= Ideal*0.98
Ja: 'Fliegengew'
Var Ideal ausgeben
Nein: Gew >= Ideal*1.02
Ja: 'Alter Sack-zu schwer!'
VAR Ideal ausgeben
Nein: 'Gratulation' }
program Gewicht;
uses Crt;
var Gr, Gew, Ideal: real;
Geschl: char;
begin
Write('Gr<47><72>e: ');
ReadLn(Gr);
Write('Gewicht: ');
ReadLn(Gew);
Write('Geschlecht (m/w): ');
Geschl := ReadKey;
WriteLn(Geschl);
WriteLn;
if Geschl='m' then Ideal := (Gr-100)*0.95 else Ideal := (Gr-100)*0.9;
if Gew <= Ideal*0.98 then WriteLn('Fliegengewicht! Idealgewicht: ', Ideal:3:5)
else if Gew >= Ideal*1.02 then WriteLn('Alter Sack-zu schwer! Idealgewicht: ', Ideal:3:5)
else WriteLn('Gratulation!');
WriteLn;
WriteLn('Bitte Taste dr<64>cken...');
ReadKey;
end.

335
ITG/G_U_I.PAS Normal file
View File

@ -0,0 +1,335 @@
program RekGUI;
uses Crt, Graph, DOS, GUI, RekGraph;
const desktopcolor=3;
skier_len: integer=120;
skier_edge: integer=10;
skier_globangle: integer=0;
skier_fixedinit: boolean=true;
haken_len: integer=150;
haken_angle: integer=45;
haken_globangle: integer=0;
haken_fixedinit: boolean=true;
quadrat_len: integer=150;
quadrat_angle: integer=90;
quadrat_globangle: integer=0;
quadrat_fixedinit: boolean=true;
spirale_len: integer=10;
spirale_angle: integer=25;
spirale_globangle: integer=0;
spirale_fixedinit: boolean=true;
var xmax, ymax, xmed, ymed: word;
ExitAll, ExitSetupAll: boolean;
procedure Init;
var grDriver, grMode: integer;
BGIPath: string;
begin
grDriver := VGA;
grMode := VGAHi;
initp_del := 30;
BGIPath := '..\..\BGI\';
InitGraph(grDriver, grMode, BGIPath);
xmax := GetMaxX+1; { Bildschirmbreite in Pixeln }
ymax := GetMaxY+1; { Bildschirmh<6D>he in Pixeln }
xmed := xmax DIV 2;
ymed := ymax DIV 2;
om := 0;
ExitAll := false;
ExitSetupAll := false;
SetTextStyle(DefaultFont,HorizDir,1);
SetTextJustify(LeftText,TopText);
SetFillStyle(SolidFill,desktopcolor);
Bar(0,0,xmax-1,ymax-1);
ClearStatus;
end;
procedure InitGraphs;
begin
skier_del := 50;
haken_del := 50;
quadrat_del := 100;
spirale_del := 50;
end;
procedure Outit;
begin
TextMode(CO80);
WriteLn('VMode : ',xmax,'x',ymax);
WriteLn('Center: ',xmed,'x',ymed);
WriteLn;
WriteLn('Programm beendet.');
end;
function V2S(x: byte): string;
var tmp: string;
begin
Str(x:3,tmp);
V2S := tmp;
end;
procedure ShowSkier;
begin
globangle := skier_globangle;
SetViewPort(13,31,497,397,ClipOn);
MoveTo(180,370);
Skier(skier_len,skier_edge);
SetViewPort(0,0,639,479,ClipOff);
end;
procedure ShowHaken;
begin
globangle := haken_globangle;
SetViewPort(13,31,497,397,ClipOn);
MoveTo(240,180);
Haken(haken_len,haken_angle);
SetViewPort(0,0,639,479,ClipOff);
end;
procedure ShowQuadrat;
begin
globangle := haken_globangle;
SetViewPort(13,31,497,397,ClipOn);
MoveTo(240,180);
Quadrat(quadrat_len,quadrat_angle);
SetViewPort(0,0,639,479,ClipOff);
end;
procedure ShowSpirale;
begin
globangle := spirale_globangle;
SetViewPort(13,31,497,397,ClipOn);
MoveTo(240,180);
Spirale(spirale_len,spirale_angle);
SetViewPort(0,0,639,479,ClipOff);
end;
procedure Palette;
const tx=50;
ty=31;
var i,j: integer;
begin
for j:=1 to 16 do begin
SetTextJustify(RightText,CenterText);
SetColor(0);
OutTextXY(tx,ty+(j-1)*10+5,V2S((j-1)*16));
for i:=0 to 15 do begin
SetFillStyle(SolidFill,(j-1)*16+i);
SetColor((j-1)*15+i);
Bar(tx+i*10,ty+(j-1)*10,tx+i*10+10,ty+(j-1)*10+10);
end;
SetTextJustify(LeftText,CenterText);
SetColor(0);
OutTextXY(tx+162,ty+(j-1)*10+5,V2S((j-1)*16+15));
end;
end;
procedure CheckSetupStat;
begin
if (mb<>0) then ShowMouse(false);
if MouseOver(15,405,525,425) then begin
Status('Hiermit wird die Konfiguration so gespeichert');
case mb of
1: begin
ExitSetupAll := true;
end;
end;
end else if MouseOver(527,405,625,425) then begin
Status('Hier geht''s nach Hause!');
case mb of
1: begin
MakeBeveledButton(527,405,625,425,'EXIT');
ExitSetupAll:=true;
ExitAll:=true;
Delay(buttondelay);
MakeButton(527,405,625,425,'EXIT');
Exit;
end;
end;
end else if (oldstat<>'') then begin
ClearStatus;
oldstat:='';
end;
if (mb<>0) then ShowMouse(true);
end;
procedure SetupData;
var sx,sy,sb: integer;
begin
MakeWindow(10,10,630,430,'Konfiguration');
MakeButton(15,405,525,425,'Einstellungen so <20>bernehmen');
MakeButton(527,405,625,425,'EXIT');
ShowMouse(true);
repeat
MouseStat(mx,my,mb);
CheckSetupStat;
StatusTime(false);
until (mb=3) OR (ExitSetupAll);
if (mb=3) then ExitAll := true;
ShowMouse(false);
end;
procedure BuildWindows;
begin
MakeWindow(10,10,500,400,'Hauptfenster');
MakeWindow(505,10,600,400,'Optionen');
MakeButton(510,385,595,395,'EXIT');
MakeButton(510,373,595,383,'CLEAR');
MakeButton(510,34,595,54,'Skierp.');
MakeButton(510,56,595,76,'Haken');
MakeButton(510,78,595,98,'Quadrat');
MakeButton(510,100,595,120,'Spirale');
MakeButton(510,350,595,371,'SETUP');
end;
procedure CheckStat;
begin
if (mb<>0) then ShowMouse(false);
if MouseOver(510,385,595,395) then begin
Status('Hier geht''s nach Hause!');
case mb of
1: begin
MakeBeveledButton(510,385,595,395,'EXIT');
ExitAll:=true;
Delay(buttondelay);
MakeButton(510,385,595,395,'EXIT');
Exit;
end;
end;
end else if MouseOver(510,373,595,383) then begin
Status('Damit wird das Hauptfenster gel<65>scht!');
case mb of
1: begin
MakeBeveledButton(510,373,595,383,'CLEAR');
SetFillStyle(SolidFill,7);
Bar(13,31,497,397);
Delay(buttondelay);
MakeButton(510,373,595,383,'CLEAR');
end;
end;
end else if MouseOver(510,350,595,371) then begin
Status('Hier kann man die Einstellungen <20>ndern!');
case mb of
1: begin
MakeBeveledButton(510,350,595,371,'SETUP');
SetFillStyle(SolidFill,desktopcolor);
Bar(10,10,500,400);
Delay(buttondelay DIV 2);
Bar(505,10,600,400);
Delay(buttondelay DIV 2);
ExitSetupAll := false;
SetupData;
if NOT ExitAll then begin
SetFillStyle(SolidFill,desktopcolor);
Bar(10,10,630,430);
BuildWindows;
end;
end;
end;
end else if MouseOver(510,34,595,54) then begin
Status('F<>r unsere Wintersportler!');
case mb of
1: begin
MakeBeveledButton(510,34,595,54,'Skierp.');
ShowSkier;
Delay(buttondelay);
MakeButton(510,34,595,54,'Skierp.');
end;
end;
end else if MouseOver(510,56,595,76) then begin
Status('Und das ist f<>r die Angler!');
case mb of
1: begin
MakeBeveledButton(510,56,595,76,'Haken');
ShowHaken;
Delay(buttondelay);
MakeButton(510,56,595,76,'Haken');
end;
end;
end else if MouseOver(510,78,595,98) then begin
Status('Sehen Sie schon viereckig?');
case mb of
1: begin
MakeBeveledButton(510,78,595,98,'Quadrat');
ShowQuadrat;
Delay(buttondelay);
MakeButton(510,78,595,98,'Quadrat');
end;
end;
end else if MouseOver(510,100,595,120) then begin
Status('Ist was verstopft?');
case mb of
1: begin
MakeBeveledButton(510,100,595,120,'Spirale');
ShowSpirale;
Delay(buttondelay);
MakeButton(510,100,595,120,'Spirale');
end;
end;
end else if (oldstat<>'') then begin
ClearStatus;
oldstat:='';
end;
if (mb<>0) then ShowMouse(true);
end;
procedure StartScreen;
begin
MakeWindow(120,140,520,340,'Rekursive Grafikfunktionen');
SetViewPort(123,161,517,337,ClipOn);
SetColor(9);
SetTextStyle(TripleXFont,HorizDir,10);
SetTextJustify(CenterText,CenterText);
OutTextXY(200,24,'GUI');
OutTextXY(200,26,'GUI');
OutTextXY(199,25,'GUI');
OutTextXY(201,25,'GUI');
SetTextStyle(SansSerifFont,HorizDir,2);
OutTextXY(200,100,'GRAPHICAL USER INTERFACE');
SetColor(0);
SetTextStyle(SmallFont,HorizDir,5);
OutTextXY(200,165,'geschrieben von Markus Birth <mbirth@webwriters.de>');
SetTextStyle(SmallFont,VertDir,4);
SetTextJustify(CenterText,TopText);
SetColor(8);
OutTextXY(385,2,'(c)1999 Web - Writers');
SetColor(0);
SetTextStyle(DefaultFont,HorizDir,1);
OutTextXY(200,140,'Initialisiere Farbpalette ...');
Delay(1000);
InitPalette;
SetFillStyle(SolidFill,7);
Bar(0,130,400,150);
SetTextStyle(DefaultFont,HorizDir,1);
SetViewPort(0,0,639,479,ClipOff);
Status('Bitte dr<64>cken Sie irgendeine Taste (Maus oder Tastatur)');
ShowMouse(true);
repeat
MouseStat(mx,my,mb);
StatusTime(false);
until (keypressed) OR (mb<>0);
if keypressed then ReadKey;
ShowMouse(false);
SetFillStyle(SolidFill,desktopcolor);
Bar(120,140,520,340);
end;
begin
Init;
InitGraphs;
StartScreen;
BuildWindows;
MouseReset;
ShowMouse(true);
repeat
MouseStat(mx,my,mb);
CheckStat;
StatusTime(false);
until (mb=3) OR (ExitAll);
ShowMouse(false);
FadeOut;
Outit;
end.

21
ITG/HANOI.INI Normal file
View File

@ -0,0 +1,21 @@
[Hanoi_Main]
Items=5
[Hanoi_Board]
Board_X=600
Board_Middle=400
Board_Y=10
Board_Color=10
[Hanoi_Poles]
Tower_X=10
Tower_Color=12
[Hanoi_Coins]
Item_MaxX=130
Item_MinX=35
Item_Y=20
Item_Color=14
[Hanoi_Texts]
Text_Color=15

290
ITG/HANOI.PAS Normal file
View File

@ -0,0 +1,290 @@
program Towers_of_Hanoi;
uses Crt, Graph, INIFile, BGIP;
const { Hmax=5; }
Gray50: FillPatternType=($AA, $55, $AA, $55, $AA, $55, $AA, $55);
Sound_ON=false;
var xmax, ymax, xmed, ymed: word;
Code: integer;
Hanoi: array[1..3,1..100] of byte;
Item_X: array[1..100] of word;
Board_Up, Board_Down: word;
Tower_Y: word;
Input: char;
Mv_From, Mv_To: byte;
Step: longint;
tmp1,tmp2: string;
T_Center: array[1..3] of word;
Hmax: byte;
Board_X,Board_Middle,Board_Y: word;
Board_Color: byte;
Tower_X: word;
Tower_Color: byte;
Item_MaxX, Item_MinX, Item_Y: word;
Item_Color, Text_Color: byte;
function V2S(x: longint): string;
var tmp: string;
begin
Str(x:0,tmp);
V2S := tmp;
end;
function S2V(x: string): integer;
var tmp,code: integer;
begin
Val(x,tmp,code);
if (code<>0) then begin
WriteLn('Error while VAL ''',x,''': ',code);
Halt;
end else S2V:=tmp;
end;
procedure Init;
var grDriver, grMode: integer;
i,j: byte;
begin
INIFileDebug := false;
OpenINI('D:\LANG\src\bp\itg\hanoi.ini');
Hmax := S2V(INIGet('Hanoi_Main','Items'));
Board_X := S2V(INIGet('Hanoi_Board','Board_X'));
Board_Middle := S2V(INIGet('Hanoi_Board','Board_Middle'));
Board_Y := S2V(INIGet('Hanoi_Board','Board_Y'));
Board_Color := S2V(INIGet('Hanoi_Board','Board_Color'));
Tower_X := S2V(INIGet('Hanoi_Poles','Tower_X'));
Tower_Color := S2V(INIGet('Hanoi_Poles','Tower_Color'));
Item_MaxX := S2V(INIGet('Hanoi_Coins','Item_MaxX'));
Item_MinX := S2V(INIGet('Hanoi_Coins','Item_MinX'));
Item_Y := S2V(INIGet('Hanoi_Coins','Item_Y'));
Item_Color := S2V(INIGet('Hanoi_Coins','Item_Color'));
Text_Color := S2V(INIGet('Hanoi_Texts','Text_Color'));
CloseINI;
grDriver := VGA;
grMode := VGAHi;
InitGraph(grDriver, grMode, BGIPath);
xmax := GetMaxX+1; { Bildschirmbreite in Pixeln }
ymax := GetMaxY+1; { Bildschirmh<6D>he in Pixeln }
xmed := xmax DIV 2;
ymed := ymax DIV 2;
T_Center[1] := xmed-(Board_X DIV 4);
T_Center[2] := xmed;
T_Center[3] := xmed+(Board_X DIV 4);
Board_Up := Board_Middle-(Board_Y DIV 2);
Board_Down := Board_Middle+(Board_Y DIV 2);
Tower_Y := (Hmax+1)*Item_Y;
Step := 0;
for i:=1 to 3 do begin
for j:=1 to Hmax do begin
Hanoi[i,j] := 0;
Hanoi[1,j] := Hmax-j+1;
Item_X[Hmax-j+1] := Trunc(((Hmax-j)/(Hmax-1))*(Item_MaxX-Item_MinX))+Item_MinX;
end;
end;
end;
procedure DrawBoard;
var i,j: byte;
begin
ClearDevice;
for i:=1 to 3 do begin
SetColor(Tower_Color);
SetFillPattern(Gray50,Tower_Color);
Rectangle(T_Center[i]-(Tower_X DIV 2),Board_Up-Tower_Y,T_Center[i]+(Tower_X DIV 2),Board_Up);
FloodFill(T_Center[i],Board_Middle-(Board_Y DIV 2)-(Tower_Y DIV 2),Tower_Color);
SetColor(Text_Color);
SetTextJustify(CenterText, CenterText);
OutTextXY(T_Center[i],Board_Down+10,V2S(i));
SetTextJustify(LeftText, TopText);
end;
SetColor(Board_Color);
Rectangle(xmed-(Board_X DIV 2),Board_Up,xmed+(Board_X DIV 2),Board_Down);
SetFillPattern(Gray50,Board_Color);
FloodFill(xmed,Board_Middle,Board_Color);
for i:=1 to 3 do begin
for j:=1 to Hmax do begin
if Hanoi[i,j]<>0 then begin
SetColor(Item_Color);
SetFillPattern(Gray50,Item_Color);
Rectangle(T_Center[i]-(Item_X[Hanoi[i,j]] DIV 2),Board_Up-(Item_Y*(j-1)),T_Center[i]+(Item_X[Hanoi[i,j]] DIV 2),
Board_Up-(Item_Y*j));
FloodFill(T_Center[i],Board_Up-(Item_Y*j)+(Item_Y DIV 2),Item_Color);
end;
end;
end;
end;
function WhatsLast(Tower: byte): byte;
var i: integer;
tmp: byte;
begin
tmp := 0;
for i:=Hmax downto 1 do begin
if Hanoi[Tower,i]<>0 then begin
tmp := Hanoi[Tower,i];
Break;
end;
end;
if (tmp=0) then tmp:=255;
SetTextJustify(CenterText, CenterText);
OutTextXY(T_Center[Tower],Board_Down+20,V2S(tmp));
SetTextJustify(LeftText, TopText);
WhatsLast := tmp;
end;
function TakeLast(Tower: byte): byte;
var i: integer;
tmp: byte;
begin
for i:=Hmax downto 1 do begin
if Hanoi[Tower,i]<>0 then begin
tmp := Hanoi[Tower,i];
Hanoi[Tower,i] := 0;
Break;
end;
end;
TakeLast := tmp;
end;
procedure PutOnto(Which,Tower: byte);
var i: integer;
begin
for i:=1 to Hmax do begin
if Hanoi[Tower,i]=0 then begin
Hanoi[Tower,i]:=which;
Break;
end;
end;
end;
procedure MoveFromTo(Mv_From, Mv_To: byte);
var temp: byte;
begin
if (WhatsLast(Mv_To)>WhatsLast(Mv_From)) then begin
PutOnto(TakeLast(Mv_From),Mv_To);
Inc(Step);
if (Sound_ON) then begin
Sound(1200);
Delay(75);
NoSound;
end;
end else begin
if (Sound_ON) then begin
Sound(800);
Delay(150);
NoSound;
end;
SetTextJustify(CenterText,CenterText);
SetColor(LightRed);
OutTextXY(xmed,40,'Can''t move Item on Tower '+V2S(Mv_From)+' to Tower '+V2S(Mv_To)+'.');
Delay(1000);
end;
end;
function All(what: byte): word;
var tmp: word;
begin
if what=1 then All:=1 else All:=what+All(what-1);
end;
function CheckWon: boolean;
var i,j: byte;
sum: word;
tmp: boolean;
begin
for i:=2 to 3 do begin
if (WhatsLast(i)=1) then begin
sum := 0;
for j:=1 to Hmax do begin
sum := sum + Hanoi[i,j];
end;
if (sum=All(Hmax)) then begin
tmp:=true;
Break;
end;
end else tmp:=false;
end;
CheckWon := tmp;
end;
procedure Outit;
var i: byte;
begin
TextMode(CO80);
WriteLn('VMode : ',xmax,'x',ymax);
WriteLn('Center: ',xmed,'x',ymed);
for i:=1 to Hmax do begin
WriteLn('Tower_X ',i,': ',Item_X[i]);
end;
WriteLn('Steps needed: ',Step:0);
WriteLn;
if (CheckWon) then WriteLn('Programm siegreich beendet.') else WriteLn('Programm grundlos beendet.');
end;
begin
Init;
repeat
DrawBoard;
if (CheckWon) then begin
if (Sound_ON) then begin
Sound(1000);
Delay(100);
NoSound;
Delay(200);
Sound(1000);
Delay(50);
NoSound;
Delay(100);
Sound(1000);
Delay(50);
NoSound;
Delay(100);
Sound(1400);
Delay(750);
NoSound;
end;
Break;
end;
SetColor(LightGreen);
SetTextJustify(CenterText,BottomText);
OutTextXY(xmed,ymax,'Press X to exit');
SetTextJustify(LeftText,TopText);
SetColor(Text_Color);
Str(Step:3,tmp1);
OutTextXY(550,10,'Step: '+tmp1);
tmp1 := 'Move Item from Tower ';
OutTextXY(10,10,'Press 1, 2 or 3 to select a tower.');
OutTextXY(10,20,tmp1);
Input := ReadKey;
if (Input='1') OR (Input='2') OR (Input='3') then begin
Val(Input,Mv_From,Code);
Str(Mv_From:0,tmp2);
tmp1 := tmp1 + tmp2 + ' to Tower ';
OutTextXY(10,20,tmp1);
Input := ReadKey;
if (Input='1') OR (Input='2') OR (Input='3') then begin
Val(Input,Mv_To,Code);
Str(Mv_To:0,tmp2);
tmp1 := tmp1 + tmp2 + ' ...';
OutTextXY(10,20,tmp1);
MoveFromTo(Mv_From,Mv_To);
end else if (Input<>'x') AND (Input<>'X') then begin
if (Sound_ON) then begin
Sound(800);
Delay(150);
NoSound;
end;
end else Break;
end else if (Input<>'x') AND (Input<>'X') then begin
if (Sound_ON) then begin
Sound(800);
Delay(150);
NoSound;
end;
end;
until (Input='x') OR (Input='X');
Outit;
end.

29
ITG/HANOIT.PAS Normal file
View File

@ -0,0 +1,29 @@
program Bewege_Test;
uses Crt;
var howmuchcanyoutake: integer;
step: integer;
procedure Bewege(n: integer; p1,p2,p3: char);
begin
if n=1 then begin
WriteLn(p1,' --> ',p2);
Inc(step);
end else begin
Bewege(n-1,p1,p3,p2);
Bewege(1,p1,p2,p3);
Bewege(n-1,p3,p2,p1);
end;
end;
begin
ClrScr;
Step := 0;
TextMode(CO80+Font8x8);
Write('Wieviel M<>nzen? ');
ReadLn(howmuchcanyoutake);
Bewege(howmuchcanyoutake,'1','2','3');
WriteLn('Schritte: ',step);
ReadKey;
end.

66
ITG/HASHING.PAS Normal file
View File

@ -0,0 +1,66 @@
program Hashing;
uses Crt;
const max=25;
var mem: array[0..max] of integer;
x,pos: integer;
procedure Init;
var i: integer;
begin
for i:=0 to max do mem[i] := 255;
end;
procedure OutArray;
var i: integer;
begin
for i:=0 to max do begin
if (i/2)=(I DIV 2) then TextColor(10) else TextColor(12);
GotoXY(i*3+1,3); Write(i:3);
GotoXY(i*3+1,4); if (mem[i]<>255) then Write(mem[i]:3);
end;
end;
function Hash(v: integer): integer;
begin
Hash := v MOD 13;
end;
procedure MakeFree(var v: integer);
begin
if (mem[v]<>255) then begin
repeat
Inc(v);
until (mem[v]=255) OR (v>max);
end;
if (v>max) then begin
ClrScr;
TextColor(12);
WriteLn('Array <20>berschritten! Das Feld ist VOLL!');
Halt;
end;
end;
procedure ReadAndSort;
var i: integer;
begin
for i:=1 to 15 do begin
GotoXY(5,5);
ReadLn(x);
pos := Hash(x);
MakeFree(pos);
mem[pos] := x;
OutArray;
end;
end;
begin
TextBackground(0);
TextColor(15);
ClrScr;
Init;
OutArray;
ReadAndSort;
end.

39
ITG/ISBN.PAS Normal file
View File

@ -0,0 +1,39 @@
program ISBNGrab;
uses Crt;
var UrISBN: string;
i,j,co: integer;
function BNS(ISBN: string;which: integer): string;
var NR: array[1..10] of string;
x,lastx,i: integer;
j: string;
begin
i := 1;
lastx := 0;
for x:=0 to Length(ISBN) do begin
if ISBN[x]='-' then begin
NR[i] := Copy(ISBN,lastx+1,x-lastx-1);
Inc(i);
lastx := x;
end;
end;
NR[i] := Copy(ISBN,lastx+1,Length(ISBN));
if which<>0 then BNS := NR[which] else begin
Str(i:0,j);
BNS := j;
end;
end;
begin
Write('ISBN eintippen: ');
ReadLn(UrISBN);
Write('ISBN: ',BNS(UrISBN,1));
Val(BNS(UrISBN,0),j,co);
for i:=2 to j do Write('-',BNS(UrISBN,i));
WriteLn(' (',BNS(UrISBN,0),' Gruppen)');
WriteLn('Buchnr.: ',BNS(UrISBN,3));
ReadKey;
end.

12
ITG/KLAU1_02.PAS Normal file
View File

@ -0,0 +1,12 @@
var a,b,cs,max: integer;
begin
Write('max: ');
ReadLn(max);
for a:=1 to max do begin
for b:=a to max do begin
cs := Sqr(a)+Sqr(b);
if Sqrt(cs)=Int(Sqrt(cs)) then WriteLn(a,'<27>+',b,'<27>=',Sqrt(cs):0:0,'<27>');
end;
end;
end.

114
ITG/LOTTO.PAS Normal file
View File

@ -0,0 +1,114 @@
program Lotto_Ziehung;
uses Crt, CursorOnOff, Dos;
const prog:char='/';
freq=30;
pfreq=10;
var lotto: array[1..49] of longint;
fulr: array[1..freq] of real;
fuls: byte;
pers: byte;
full: real;
isec: longint;
h,m,s,ss: word;
procedure StartClock;
begin
GetTime(h,m,s,ss);
isec := h*3600+m*60+s;
end;
function RunSec: longint;
var nh,nm,ns,nss: word;
nsec: longint;
begin
GetTime(nh,nm,ns,nss);
nsec := nh*3600+nm*60+ns;
RunSec := nsec-isec;
end;
procedure Progress(how,much: real);
var wx,wy: word;
secs,tfull,rest: real;
i: byte;
fsum: real;
begin
secs := RunSec;
if (fuls<freq) then begin
tfull := secs / (how/much);
Inc(fuls);
fulr[fuls] := tfull;
if (full<>0) then rest := full - secs else rest := 0;
end else begin
fsum := 0;
for i:=1 to freq do fsum := fsum + fulr[i];
full := fsum / freq;
rest := full - secs;
fuls := 0;
end;
if (pers>pfreq) then begin
Write(prog,' [',(how/much)*100:6:2,'%] (',secs:4:0,'/',full:4:0,' ',rest:4:0,' left)');
pers := 0;
end else begin
Write(prog);
GotoXY(WhereX+11,WhereY);
Write('(',secs:4:0);
end;
Inc(pers);
GotoXY(14,WhereY);
case prog of
'/': prog:= '-';
'-': prog:= '\';
'\': prog:= '|';
'|': prog:= '/';
end;
end;
procedure init;
var i:byte;
begin
{ clrscr; }
fuls := 0;
full := 0;
pers := 0;
writeLn;
Randomize;
{ RandSeed := 123; }
for i:=1 to 49 do Lotto[i]:=0;
end;
procedure Ziehung;
var i,n: longint;
begin
write('Wieviel Ziehungen? '); ReadLn(n);
StartClock;
CursorOff;
write('Berechne ... ');
for i:=1 to n do begin
if i MOD 100000=0 then Progress(i,n);
inc(Lotto[Random(49)+1]);
end;
GotoXY(wherex-1,wherey); WriteLn(' fertig! ');
CursorOn;
end;
procedure Auswertung;
var z,i,max: byte;
begin
WriteLn('Die 6 h<>ufigsten Ziehungen:');
for z:=1 to 6 do begin
max:=1;
for i:=2 to 49 do if Lotto[i]>Lotto[max] then max:=i;
WriteLn(z:1,': ',max:2,' [',Lotto[max],']');
Lotto[max]:=0;
end;
end;
begin
init;
Ziehung;
auswertung;
end.

46
ITG/MENGELOT.PAS Normal file
View File

@ -0,0 +1,46 @@
uses crt;
type TMenge = SET of 1..49;
var Tip1, Tip2, Tip3: TMenge;
procedure Init(var Menge: TMenge);
begin
(**) Menge := []; (**)
end;
procedure LottoZiehung(var Zahlen: TMenge);
var anzahl, ZufZahl: byte;
begin
anzahl := 0;
repeat
repeat
ZufZahl := random(49)+1;
until NOT (**) (ZufZahl IN Zahlen) (**) ;
(**) Zahlen := Zahlen + [ZufZahl] (**) ;
(**) Inc(anzahl) (**) ;
until anzahl = 6;
end;
procedure Ausgabe(Zahlen: TMenge);
var i: byte;
begin
for i:= (**) 1 to 49 (**) do
(**) if i IN Zahlen then write(i, ' ') (**) ;
(**) writeln (**) ;
end;
begin
clrscr; Randomize;
Init( (**) Tip1 (**) );
LottoZiehung( (**) Tip1 (**) );
Ausgabe( (**) Tip1 (**) );
Init( (**) Tip2 (**) );
LottoZiehung( (**) Tip2 (**) );
Ausgabe( (**) Tip2 (**) );
Init( (**) Tip3 (**) );
LottoZiehung( (**) Tip3 (**) );
Ausgabe( (**) Tip3 (**) );
end.

95
ITG/MIRROR.PAS Normal file
View File

@ -0,0 +1,95 @@
program Mirroring;
uses Crt, Graph, GUI, BGIP;
var xmax,ymax: integer;
omx, omy, omb: integer;
lx,ly,rx,ry: integer;
orx,ory: integer;
ls,rs: boolean;
procedure GraphInit;
var grDriver, grMode : integer;
begin
grDriver := VGA;
{ VGAlo 640x200x16
VGAmed 640x350x16
VGAhi 640x480x16 }
grMode := VGAhi;
InitGraph(grDriver,grMode,BGIPath);
xmax := GetMaxX+1; { Bildschirmbreite in Pixeln }
ymax := GetMaxY+1; { Bildschirmh<6D>he in Pixeln }
end;
procedure GraphOutit;
begin
TextMode(co80 + Font8x8);
end;
function Num2Str(x: longint): string;
var tmp: string;
begin
Str(x:3,tmp);
Num2Str := tmp;
end;
procedure SetRect;
begin
omx := 0;
omy := 0;
omb := 0;
lx := 0; ly := 0;
ls := false;
rs := false;
repeat
repeat
MouseStat(mx,my,mb);
until (mx<>omx) OR (my<>omy) OR (mb<>omb);
if (mb=1) AND NOT (ls) then begin
repeat
MouseStat(mx,my,mb);
until (mb=0);
lx := mx;
ly := my;
ls := true;
end;
rx := mx;
ry := my;
if (lx<>0) AND (ly<>0) AND ((rx<>orx) OR (ry<>ory)) AND NOT (rs) then begin
ShowMouse(false);
SetColor(0);
Rectangle(lx,ly,orx,ory);
SetColor(15);
Rectangle(lx,ly,rx,ry);
ShowMouse(true);
orx := rx;
ory := ry;
end;
if (lx<>0) AND (ly<>0) AND (rx<>0) AND (ry<>0) AND (mb=1) then begin
rs := true;
repeat
MouseStat(mx,my,mb);
until (mb=0);
end;
omx := mx;
omy := my;
omb := mb;
Bar(1,1,150,30);
OutTextXY(1,1,'X:'+Num2Str(mx)+' Y:'+Num2Str(my)+' Buttons:'+Num2Str(mb));
until (ls) AND (rs);
end;
begin
GraphInit;
fo_del := 0;
InitPalette;
MouseReset;
ShowMouse(true);
SetFillStyle(SolidFill,0);
SetTextStyle(SmallFont,HorizDir,4);
SetColor(15);
SetRect;
Alert('Fertich!!');
FadeOut;
GraphOutit;
end.

86
ITG/MITARB.PAS Normal file
View File

@ -0,0 +1,86 @@
program Mitarbeiter;
uses Crt;
{ 1..8 = Abteilung
1..6 = Altersgruppe:
1 - 16-19
2 - 20-24
3 - 25-35
4 - 36-49
5 - 50-60
6 - >60
1..2 = Geschlecht:
1 - m<>nnlich
2 - weiblich }
var Arbeiter: array[1..8,1..6,1..2] of byte;
procedure InitArray;
var i,j: byte;
begin
Randomize;
for i:=1 to 8 do
for j:=1 to 6 do begin
Arbeiter[i,j,1] := Random(250);
Arbeiter[i,j,2] := Random(250);
end;
end;
function GetMalesFromAbt(abt: byte): integer;
var i: byte;
m: integer;
begin
m := 0;
for i:=1 to 6 do begin
m := m + Arbeiter[abt,i,1];
end;
GetMalesFromAbt := m;
end;
function GetFemsFromAbt(abt: byte): integer;
var i: byte;
f: integer;
begin
f := 0;
for i:=1 to 6 do begin
f := f + Arbeiter[abt,i,2];
end;
GetFemsFromAbt := f;
end;
function GetPeopleInAbt(abt: byte): integer;
var i: byte;
a: integer;
begin
a := 0;
for i:=1 to 6 do a := a + Arbeiter[abt,i,1] + Arbeiter[abt,i,2];
GetPeopleInAbt := a;
end;
procedure GetInfo;
var i,j: byte;
m,w: integer;
begin
m := 0;
w := 0;
for i:=1 to 8 do
for j:=1 to 6 do begin
m:=m+Arbeiter[i,j,1];
w:=w+Arbeiter[i,j,2];
end;
WriteLn('Anzahl m<>nnlicher Mitarbeiter firmenweit: ',m);
WriteLn('Anzahl weiblicher Mitarbeiter firmenweit: ',w);
for i:=1 to 8 do WriteLn('Mitarbeiter in Abteilung ',i:1,': ',GetPeopleInAbt(i):4,
' (',GetMalesFromAbt(i):4,' M<>nner/',GetFemsFromAbt(i):4,' Frauen)');
end;
begin
InitArray;
ClrScr;
GetInfo;
ReadKey;
end.

19
ITG/NUMLOOSE.PAS Normal file
View File

@ -0,0 +1,19 @@
program NumberLoose;
var input: string;
function Zahl(S: string): longint;
var i: integer;
tmp: longint;
begin
tmp := 0;
for i:=1 to Length(s) do
if Ord(s[i]) IN [48..57] then tmp:=tmp*10+Ord(s[i])-48;
Zahl := tmp;
end;
begin
Write('blabla eingeben: ');
ReadLn(input);
WriteLn('Ord vom blabla: ',Zahl(input));
end.

36
ITG/PACKEN.PAS Normal file
View File

@ -0,0 +1,36 @@
uses Crt;
const personen: array[1..10] of string=('Bert','','Ernie','Wilma','','Fred','Barney','','Ger<65>llheimer','Horst');
procedure Zaehle;
begin
end;
procedure Ausgabe;
var i: byte;
begin
WriteLn('<==*==>');
for i:=1 to 10 do WriteLn(personen[i]);
ReadKey;
end;
procedure Packe;
var i,a: integer;
begin
for i:=1 to 10 do begin
if (personen[i]='') then begin
for a:=i to 10 do begin
personen[a]:=personen[a+1];
end;
end;
Write(i,': '); Ausgabe;
end;
end;
begin
Zaehle;
Packe;
Ausgabe;
end.

201
ITG/PUMPE.PAS Normal file
View File

@ -0,0 +1,201 @@
program Pumpensteuerung;
uses Crt;
const Full='<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>';
Half='<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>';
Empt=' ';
timemult: integer=10;
B1E: boolean=true;
B2E: boolean=true;
B1D: integer=4;
B2D: integer=4;
B1: real=2950;
B2: real=2750;
var Y1,Y2,Y3,A,B,C,D: boolean;
x: char;
{ 1 Beh<65>lter = 5700 l = in 2 Minuten voll }
procedure Init;
begin
ClrScr;
TextColor(7);
GotoXY(20,18); Write('1 - B1',#127,' an/aus');
GotoXY(20,19); Write('Q - B1',#127,'max +600');
GotoXY(20,20); Write('A - B1',#127,'max -600');
GotoXY(50,18); Write('2 - B2',#127,' an/aus');
GotoXY(50,19); Write('W - B2',#127,'max +600');
GotoXY(50,20); Write('S - B2',#127,'max -600');
GotoXY(35,22); Write('^ - Ventil umschalten');
GotoXY(35,23); Write('E - Zeitraffer +1');
GotoXY(35,24); Write('D - Zeitraffer -1');
GotoXY(33,25); Write('ESC - Simulation beenden');
Randomize;
Y1 := false;
Y2 := false;
Y3 := false;
end;
procedure SetLEDs;
var a: byte absolute 0:1047;
begin
a := 0;
if Y1 then Inc(a,32);
if Y2 then Inc(a,64);
if Y3 then Inc(a,16);
end;
procedure ResetLEDs;
var a: byte absolute 0:1047;
begin
a := 32;
end;
procedure DrawPumpe;
var i: integer;
begin
GotoXY(1,1); if Y1 then TextColor(14) else TextColor(8); Write('Y1 (NUM)');
GotoXY(1,2); if Y2 then TextColor(14) else TextColor(8); Write('Y2 (CAPS)');
GotoXY(1,3); if Y3 then TextColor(14) else TextColor(8); Write('Y3 (SCROLL)');
GotoXY(1,5); if (B1E) then TextColor(15) else TextColor(8);
Write('B1',#127,'max: ',B1D*600:5,' l/min');
GotoXY(1,6); if (B2E) then TextColor(15) else TextColor(8);
Write('B2',#127,'max: ',B2D*600:5,' l/min');
TextColor(15);
GotoXY(1,8); Write('Zeitraffung: ',timemult:2,'x');
if (Y1) OR (Y2) then TextColor(11) else TextColor(7);
GotoXY(40, 5); Write('<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>');
if (Y1) OR (Y2) then TextColor(10+blink); Write('(P)');
TextColor(15);
if NOT (Y1) AND NOT (Y2) then Write(' [0 l/min] ');
if NOT (Y1) AND (Y2) then Write(' [750 l/min] ');
if (Y1) AND NOT (Y2) then Write(' [1450 l/min] ');
if (Y1) AND (Y2) then Write(' [2850 l/min] ');
if (Y1) OR (Y2) then TextColor(11) else TextColor(7);
GotoXY(40, 6); Write('<27>');
GotoXY(39,7); if Y3 then Write(' <20><>') else Write('<27><> ');
GotoXY(25,7);
if NOT (Y3) AND ((Y2) OR (Y1)) then TextColor(11) else TextColor(7);
Write('<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>');
GotoXY(42,7);
if (Y3) AND ((Y2) OR (Y1)) then TextColor(11) else TextColor(7);
Write('<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Ŀ');
for i:=1 to 7 do begin
if (B1E) then TextColor(15) else TextColor(8);
GotoXY(20,7+i); Write('<27>');
if (B1>=950*(8-i)) then Write(Full)
else if (B1>=950*(8-i)-475) then Write(Half)
else Write(Empt);
Write('<27>');
if (B2E) then TextColor(15) else TextColor(8);
GotoXY(50,7+i); Write('<27>');
if (B2>=950*(8-i)) then Write(Full)
else if (B2>=950*(8-i)-475) then Write(Half)
else Write(Empt);
Write('<27>');
end;
if (B1E) then TextColor(15) else TextColor(8);
GotoXY(19,15); Write('<27><><EFBFBD>[',B1:4:0,'l]<5D><>');
GotoXY(19,16); Write('<27>');
if (B2E) then TextColor(15) else TextColor(8);
GotoXY(50,15); Write('<27><>[',B2:4:0,'l]<5D><><EFBFBD>');
GotoXY(61,16); Write('<27>');
GotoXY(31,9); if (A) then TextColor(14) else TextColor(8); Write('<27> A');
GotoXY(31,12); if (C) then TextColor(14) else TextColor(8); Write('<27> C');
GotoXY(47,9); if (B) then TextColor(14) else TextColor(8); Write('B <20>');
GotoXY(47,12); if (D) then TextColor(14) else TextColor(8); Write('D <20>');
end;
procedure CalcSensors;
begin
if (B1>=5700) then A := true else A := false;
if (B1>=2850) then C := true else C := false;
if (B2>=5700) then B := true else B := false;
if (B2>=2850) then D := true else D := false;
end;
procedure CalcSteering;
begin
if (A) AND (B) AND (C) AND (D) then begin
Y1 := false;
Y2 := false;
end;
if NOT (A) AND NOT (B) AND NOT (C) AND NOT (D) then begin
Y1 := true;
Y2 := true;
end;
if ((A) AND NOT (B)) OR (NOT (A) AND (B)) AND (C) AND (D) then begin
Y1 := false;
Y2 := true;
end;
if (NOT (A) AND NOT (B) AND (C) AND (D))
OR ((A) AND NOT (B) AND (C) AND NOT (D))
OR (NOT (A) AND (B) AND NOT (C) AND (D)) then begin
Y1 := true;
Y2 := false;
end;
if (A) AND NOT (B) then Y3 := true;
if (B) AND NOT (A) then Y3 := false;
if (C) AND NOT (D) then Y3 := true;
if (D) AND NOT (C) then Y3 := false;
end;
procedure NimmWas;
var x: integer;
begin
if (B1E) then begin
x := Round(Random(B1D*2)/2)*timemult;
if (B1-x<0) then B1 := 0 else B1 := B1 - x;
end;
if (B2E) then begin
x := Round(Random(B2D*2)/2)*timemult;
if (B2-x<0) then B2 := 0 else B2 := B2 - x;
end;
end;
procedure Pump;
var sp: real;
begin
if NOT (Y1) AND NOT (Y2) then sp := 0;
if NOT (Y1) AND (Y2) then sp := 750 / (600/timemult);
if (Y1) AND NOT (Y2) then sp := 1450 / (600/timemult);
if (Y1) AND (Y2) then sp := 2850 / (600/timemult);
if (Y3) then B2 := B2 + sp else B1 := B1 + sp;
end;
begin
Init;
repeat
CalcSensors;
CalcSteering;
SetLEDs;
NimmWas;
DrawPumpe;
Pump;
Delay(100);
if (keypressed) then x := ReadKey else x := #000;
if (x<>#000) then begin
case x of
'1','!': if (B1E) then B1E := false else B1E := true;
'2','"': if (B2E) then B2E := false else B2E := true;
'q','Q': if B1D<20 then Inc(B1D);
'a','A': if B1D>0 then Dec(B1D);
'w','W': if B2D<20 then Inc(B2D);
's','S': if B2D>0 then Dec(B2D);
'^','<27>': if (Y3) then Y3 := false else Y3 := true;
'e','E': if timemult<50 then Inc(timemult);
'd','D': if timemult>1 then Dec(timemult);
end;
end;
until x=#027;
ResetLEDs;
end.

23
ITG/QUERSUM.PAS Normal file
View File

@ -0,0 +1,23 @@
program Quersumme;
var Zahl: longint;
function Quer(zahl: longint): integer;
var conv: string;
i,q,tmp,ec: integer;
begin
Str(zahl,conv);
q := 0;
for i:=1 to Length(conv) do begin
Val(conv[i],tmp, ec);
if ec=0 then q:=q + tmp;
end;
Quer := q;
end;
begin
Write('Tipp ''ne Ganzzahl ein: ');
ReadLn(Zahl);
WriteLn('Quersumme von ',Zahl:0,' ist ',Quer(Zahl),'.');
end.

23
ITG/QUICKSOR.PAS Normal file
View File

@ -0,0 +1,23 @@
procedure quicksort(anfang,ende : integer; var f : feldtyp);
var links, rechts : integer;
h, vgl : elementtyp;
begin
links := anfang; rechts := ende; vgl := f[(links+rechts) div 2];
if links < rechts then
begin
repeat
while f[links]< vgl do inc(links);
while f[rechts]> vgl do dec(rechts);
if links <= rechts then
begin
h:=f[links];
f[links]:= f[rechts];
f[rechts]:=h;
inc(links); dec(rechts);
end;
until links > rechts;
quicksort(anfang,rechts,f);
quicksort(links,ende,f);
end;
end;

12
ITG/RECORDS.PAS Normal file
View File

@ -0,0 +1,12 @@
program Records;
uses Crt;
type TAdr=record
N,V: string;
A: byte;
end;
var Adr1, Adr2: TAdr;
begin

93
ITG/REKGRAF1.PAS Normal file
View File

@ -0,0 +1,93 @@
Uses CRT,Graph;
var globalwinkel:integer;
graphdriver,graphmode:integer;
Procedure GrafikAn;
begin
graphdriver:=detect;
initgraph(graphdriver,graphmode,'F:\SPRACHEN\BP\BGI');
setgraphmode(graphmode);
end;
Procedure GrafikAus;
begin
clearviewport;
restorecrtmode;
closegraph;
end;
Procedure Init;
begin
clearviewport;
setcolor(14);
moveto (230,400);
globalwinkel:=0;
end;
Procedure turnleft (var winkel:integer);
begin
globalwinkel:=(globalwinkel-winkel) mod 360
end;
Procedure turnright (var winkel:integer);
begin
globalwinkel:=(globalwinkel+winkel) mod 360
end;
Procedure forwd (strecke:integer);
var hilf:real;
begin
hilf:=globalwinkel*pi/180;
linerel(round(strecke*cos(hilf)),
round(strecke*sin(hilf)))
end;
Procedure Haken(Laenge,Winkel : integer);
begin
if Laenge > 1 then
begin
Haken(Laenge - 1, Winkel);
Forwd(Laenge);
TurnLeft(Winkel);
end;
end;
Procedure Quadrat(Laenge,Winkel:integer);
Var seite:integer;
begin
if laenge >1 then
begin
for Seite := 1 to 4 do
begin
forwd(laenge);
Turnleft(winkel);
end;
quadrat((Laenge*3) div 4,Winkel);
end;
end;
procedure spirale(laenge,winkel:integer);
begin
Forwd(Laenge div 2);
Turnright(Winkel);
if laenge < 80 then Spirale(laenge+1,winkel);
end;
procedure skier(laenge,ecke:integer);
var n : byte;
w : integer;
begin
w := 360 div ecke;
if laenge > 30 then
for n := 1 to ecke do
begin
forwd(laenge);
turnleft(w );
skier(laenge div 2,ecke);
end;
end;
begin
GrafikAn;
init; skier(120,10); readkey;
init; Haken(150,45); readkey;
init; Quadrat(150,90); readkey;
init; Spirale(10,25); readkey;
GrafikAus;
end.

33
ITG/REPSTRNG.PAS Normal file
View File

@ -0,0 +1,33 @@
program ConvUmlaut;
uses Crt;
var mystr: string;
procedure ChangeAll(var text: string; what, targ: string);
var x: byte;
begin
while Pos(what,text) > 0 do begin
x := Pos(what,text);
Delete(text,x,1);
Insert(targ,text,x);
end;
end;
begin
ClrScr;
mystr := 'x';
while mystr<>'' do begin
Write('Dein Text mit Umlauten: ');
ReadLn(mystr);
ChangeAll(mystr,'<27>','ae');
ChangeAll(mystr,'<27>','oe');
ChangeAll(mystr,'<27>','ue');
ChangeAll(mystr,'<27>','AE');
ChangeAll(mystr,'<27>','OE');
ChangeAll(mystr,'<27>','UE');
ChangeAll(mystr,'<27>','ss');
Write('Dein Text ohne Umlaute: ');
WriteLn(mystr);
end;
end.

91
ITG/ROBOCARD.PAS Normal file
View File

@ -0,0 +1,91 @@
program RoboCarder;
{ MOD-10 algorithm
first digit: kind of credit card ( 3-AMEX, 4-VISA, 5-MC )
length
------
AMEX - 15 digits
VISA - 16 digits, sometimes 13
all other - 16 digits
validation
----------
begin at the rightmost digit and go to the left.
the odd digits are all sum'd up. the even (every 2nd) digits are
multiplied by 2. if the result is greater than 9, 9 is substracted.
this resulting value is added to the sum.
sum MOD 10 must be 0.
}
uses Crt;
const bigdigit: array[0..9,1..3] of string[5] = ( ('23332','10001','03330'),
{ 1 } ('02100','00100','00300'),
{ 2 } ('33332','23330','33333'),
{ 3 } ('33332','03332','33330'),
{ 4 } ('10010','33313','00030'),
{ 5 } ('13333','33332','33330'),
{ 6 } ('23333','13332','03330'),
{ 7 } ('33313','02300','30000'),
{ 8 } ('23332','23332','03330'),
{ 9 } ('23332','03331','33330'));
var inp: string[16];
procedure CheckValidity(x: string);
var i,sum,tmp,ec: integer;
begin
WriteLn('Number length: ',Length(x));
Val(x[1],tmp,ec);
case tmp of
3: WriteLn('Type: American Express');
4: WriteLn('Type: VISA');
5: WriteLn('Type: MasterCard');
end;
sum := 0;
for i:=1 to Length(x) do begin
Val(x[Length(x)-i+1],tmp,ec);
if i MOD 2=0 then tmp := tmp*2;
if tmp>9 then tmp := tmp-9;
sum := sum + tmp;
end;
WriteLn('Quersumme: ',sum);
if sum MOD 10=0 then WriteLn('VALID') else WriteLn('INVALID!!!');
end;
procedure BigWrite(w: string;x,y: word);
var i,j,k,ec: integer;
tmp: byte;
begin
for k:=1 to Length(w) do begin
for j:=1 to 3 do begin
GotoXY(x+(k-1)*6,y+j-1);
for i:=1 to 5 do begin
Val(w[k],tmp,ec);
case bigdigit[tmp,j][i] of
'0': Write(' ');
'1': Write('<27>');
'2': Write('<27>');
'3': Write('<27>');
end;
end;
end;
end;
end;
begin
ClrScr;
GotoXY(1,7);
Write('Enter Credit Card number: ');
ReadLn(inp);
BigWrite(Copy(inp,1,8),1,1);
BigWrite(Copy(inp,9,8),1,4);
GotoXY(1,8);
CheckValidity(inp);
ReadKey;
end.

87
ITG/SATZANAL.PAS Normal file
View File

@ -0,0 +1,87 @@
program Sentencizer;
uses Crt, VFx;
type TZeichenMenge = Set of Char;
var Ziffern, Buchstaben, Sonstige,
Vokale, Konsonanten, Urmenge, Umlaute: TZeichenMenge;
Zi, Bu, So, Vo, Um, Leer, i : byte;
Satz : String[80];
procedure Input;
begin
Write('Bitte den Satz eingeben: ');
ReadLn(Satz);
WriteLn(' ==> Dankesch<63>n!');
Zi := 0;
Bu := 0;
So := 0;
Vo := 0;
Um := 0;
Leer := 0;
Ziffern := ['0'..'9'];
Buchstaben := ['a'..'z','A'..'Z'];
Sonstige := ['!'..'}']-(Ziffern + Buchstaben);
Vokale := ['a','e','i','o','u','A','E','I','O','U'];
Umlaute := ['<27>','<27>','<27>','<27>','<27>','<27>'];
Konsonanten := Buchstaben - Vokale;
Urmenge := [];
end;
procedure Analyze;
begin
Write(MultiChar('-',80));
Write('Analyse l<>uft: Durchz<68>hlen ... ');
for i:=1 to Length(Satz) do begin
if Satz[i] IN Buchstaben then Inc(Bu)
else if Satz[i] IN Ziffern then Inc(Zi)
else if Satz[i] IN Umlaute then Inc(Um)
else if Satz[i]=' ' then Inc(Leer)
else Inc(So);
if Satz[i] IN Vokale then Inc(Vo);
Urmenge := Urmenge + [Satz[i]];
end;
Write('Ausstreichen ... ');
Vokale := Vokale * Urmenge;
Konsonanten := Konsonanten * Urmenge;
Ziffern := Ziffern * Urmenge;
Umlaute := Umlaute * Urmenge;
Sonstige := Sonstige * Urmenge;
WriteLn('fertig!');
end;
procedure OutputSet(which: TZeichenMenge);
var Ch: char;
begin
for Ch:=' ' to '<27>' do
if Ch IN which then Write(Ch);
WriteLn;
end;
procedure Output;
begin
Write(MultiChar('-',80));
WriteLn('Originalsatz: ',Satz);
WriteLn('Anzahl Buchstaben: ',Bu);
WriteLn('Anzahl Vokale : ',Vo,' -- Konsonanten: ',Bu-Vo);
WriteLn('Anzahl Umlaute : ',Um);
WriteLn('Anzahl Ziffern : ',Zi);
WriteLn('Anzahl Leerzeichn: ',Leer);
WriteLn('Anzahl sonstiges : ',So);
WriteLn;
Write('Vokale : '); OutputSet(Vokale);
Write('Konsonanten: '); OutputSet(Konsonanten);
Write('Umlaute : '); OutputSet(Umlaute);
Write('Ziffern : '); OutputSet(Ziffern);
Write('sonstiges : '); OutputSet(Sonstige);
end;
begin
ClrScr;
Input;
Analyze;
Output;
end.

75
ITG/SEARCH.PAS Normal file
View File

@ -0,0 +1,75 @@
program Searches;
const max=30000;
var F: array[1..max] of word;
S4: word;
sp: integer;
comp: integer;
procedure Init;
var x: word;
i: word;
begin
comp := 0;
x := 0;
for i:=1 to max do begin
x := x + Random(3) + 1;
F[i] := x;
end;
end;
procedure SearchFor;
var x: integer;
begin
WriteLn('Geben Sie die Arrayposition des zu suchenden Elements ein!');
Write('(Zahl zwischen 1 und ',max:0,'): ');
ReadLn(x);
S4 := F[x];
Write('Suche jetzt nach ',S4,' ');
end;
function bin_searchrekursiv(left, right, key: word): word;
var x,n: word;
begin
Inc(comp);
Write('.');
if left>right then bin_searchrekursiv:=0
else begin
x := (left+right) DIV 2;
if key < F[x] then bin_searchrekursiv:=bin_searchrekursiv(left, x-1, key)
else if key > F[x] then bin_searchrekursiv:=bin_searchrekursiv(x+1,right, key) else bin_searchrekursiv := x;
end;
end;
function bin_searchiterativ(key: word): word;
var left, right, x: word;
begin
left := 1;
right := max;
repeat
x := (left + right) DIV 2;
if key<F[x] then right := x-1 else left := x+1;
Inc(comp);
Write('.');
until (key=F[x]) OR (left>right);
if key=F[x] then bin_searchiterativ := x
else bin_searchiterativ := 0;
end;
procedure Stats;
begin
WriteLn(' gefunden an Stelle ',sp:0);
Write(comp:0,' Vergleichsoperation');
if (comp>1) then WriteLn('en') else WriteLn;
end;
begin
Randomize;
Init;
SearchFor;
{ sp := bin_searchiterativ(S4); }
sp := bin_searchrekursiv(1,max,S4);
Stats;
WriteLn('<=======****=======>');
end.

50
ITG/SECHSER.PAS Normal file
View File

@ -0,0 +1,50 @@
program Sechsen;
var take: longint;
sixs: longint;
thrw: longint;
succ: boolean;
function Throw: byte;
begin
Throw := Random(6)+1;
end;
procedure TripleThrowUntilSix;
var i,t: byte;
begin
Write(take:5,'#',sixs:5,'#',thrw:8,' : ');
succ := false;
for i:=1 to 3 do begin
t:=Throw;
Write(t,' ');
Inc(thrw);
if t=6 then begin
WriteLn;
Inc(sixs);
Inc(take);
Exit;
end;
end;
Inc(take);
WriteLn;
end;
begin
sixs := 0;
thrw := 0;
take := 0;
Randomize;
repeat
TripleThrowUntilSix;
until take=1000;
WriteLn(' TAKE sixes throws : # # #');
WriteLn('<===========>');
WriteLn('Takes: ',take);
WriteLn('Sixes: ',sixs);
WriteLn('Fails: ',thrw-sixs);
WriteLn('Thrws: ',thrw);
WriteLn('Quota of throws: ',(sixs/thrw)*100:3:2,' per cent');
WriteLn('Quota of takes : ',(sixs/take)*100:3:2,' per cent');
end.

202
ITG/SORT.PAS Normal file
View File

@ -0,0 +1,202 @@
program Sorts;
uses Crt, VFx;
const max = 200;
type elementtype = integer;
Arraytype = array[0..max] of elementtype;
var count: integer;
xarr: arraytype;
oarr: arraytype;
procedure Banner(what: string);
begin
drwdmax:=0;
DrawBorder(Length(what) DIV 2+5,3,15,1,6);
Write(' ',what);
ReadKey;
Window(1,1,80,50);
TextBackground(0);
ClrScr;
end;
procedure Check(var f:arraytype);
var i,cnt: integer;
begin
i:=0;
cnt:=0;
repeat
Inc(i);
Inc(cnt);
until (F[i]=0) AND (F[i-1]=0);
F[0] := cnt;
end;
procedure Init;
begin
TextMode(co80 + Font8x8);
Randomize;
end;
(***************************************************************************
************ Array-Initialisierungen **************************************
***************************************************************************)
procedure Init_clear(var f:arraytype);
var i: integer;
begin
for i:=1 to max do F[i]:=0;
end;
procedure Init_Random(var f:arraytype);
var i: integer;
begin
{ for i:=1 to max do f[i]:=(Random(65535)-32767); }
for i:=1 to max do f[i]:=Random(32768);
F[0]:=max;
end;
procedure Init_Inc(var f:arraytype);
var i: integer;
begin
for i:=1 to max do F[i]:=i;
F[0]:=max;
end;
procedure Init_Dec(var f:arraytype);
var i: integer;
begin
for i:=1 to max do F[i]:=max-i+1;
F[0]:=max;
end;
procedure OutArray(f: arraytype; var fo: arraytype);
const maxlines=50;
var i: integer;
begin
for i:=1 to F[0] do begin
if i<=maxlines then GotoXY(1,i)
else if i<=maxlines*2 then GotoXY(20,i-maxlines)
else if i<=maxlines*3 then GotoXY(40,i-maxlines*2)
else if i<=maxlines*4 then GotoXY(60,i-maxlines*3);
TextColor(7);
Write(i:3,': ');
if (F[i]<>Fo[i]) then TextColor(14) else TextColor(7);
Write(F[i]:10);
{ Delay(5); }
end;
fo := f;
{ ReadKey; }
Delay(100);
end;
procedure Swap(var x1,x2: elementtype);
var tmp: elementtype;
begin
tmp := x1;
x1 := x2;
x2 := tmp;
end;
procedure Sort_Bubblesort(var f:arraytype);
var i: integer;
canswap: boolean;
tmp: elementtype;
begin
repeat
canswap:=false;
for i:=1 to F[0]-1 do begin
if F[i]>F[i+1] then begin
Swap(F[i],F[i+1]);
canswap := true;
end;
end;
until (NOT canswap);
end;
procedure Sort_Simple(var f:arraytype);
var i,j: integer;
tmp: elementtype;
begin
for i:=1 to F[0]-1 do
for j:=i+1 to F[0] do
if F[j]<F[i] then begin
Swap(F[i],F[j]);
end;
end;
procedure Sort_Selectionsort(var f:arraytype);
var i,j,minpos: integer;
tmp: elementtype;
begin
for i:=1 to F[0]-1 do begin
minpos := i;
for j:=i+1 to F[0] do if F[j]<F[minpos] then minpos:=j;
Swap(F[i],F[minpos]);
end;
end;
procedure Sort_Insertionsort(n: integer; var f:arraytype);
var h,i,j: integer;
begin
for i:=2 to n do begin
h := f[i];
f[1] := h;
j := i-1;
while h<f[j] do begin
f[j+1] := f[j];
if (i>2) then Dec(j) else exit;
end;
f[j+1] := h;
OutArray(xarr,oarr);
end;
end;
procedure Sort_Shellsort(n: integer; var f:arraytype);
var i,j,k,m: integer;
goon: boolean;
hilf: elementtype;
begin
m := n DIV 2;
repeat
for i:=1 to n-m do begin
while f[i+m] < f[i] do begin
hilf := f[i+m];
j := i;
goon := true;
while (j>0) AND goon do begin
if hilf<f[j] then begin
f[j+m] := f[j];
j := j-m;
end else goon := false;
end;
f[j+m] := hilf;
end;
end;
m := m DIV 2;
OutArray(xarr,oarr);
until m=0;
end;
begin
Init;
Banner('Init_Random');
Init_Random(xarr);
{ Banner('Init_Inc');
Init_Inc(xarr); }
{ Banner('Init_Dec');
Init_Dec(xarr); }
oarr := xarr;
OutArray(xarr,oarr);
{ Sort_Bubblesort(xarr); }
{ Sort_Selectionsort(xarr); }
{ Sort_Simple(xarr); }
{ Sort_Insertionsort(xarr[0], xarr); }
Sort_Shellsort(xarr[0], xarr);
{ OutArray(xarr,oarr); }
end.

149
ITG/SORTCOMB.PAS Normal file
View File

@ -0,0 +1,149 @@
PROGRAM Combsorttest;
USES crt,graph,dos;
TYPE feld_ = array[0..3000] of word;
VAR x : feld_;
{Grafik initialisieren}
PROCEDURE graf;
VAR gd,gm : integer;
BEGIN
gd:=detect;
{evtl. Grafikpfad <20>ndern}
initgraph(gd,gm,'c:\schuls~1\tp\bgi');
if graphresult<>0 then halt(1);
END;
{Zufallszahlen erzeugen}
PROCEDURE zufall(n : integer;var a : feld_);
VAR i : integer;
BEGIN
randomize;
for i:=1 to n do
a[i]:=random(n)+1;
END;
{ "Je nachdem, wie tief die Spalte geht!" (Zitat: Fr<46>bel) }
PROCEDURE combsortdar;
VAR x : feld_;
s,s1,s2 : string;
sorted : boolean;
i,j,top,gap,h,n,z,z1,z2 : integer;
BEGIN
n:=25;z:=0;z1:=0;z2:=0;
setfillstyle(1,0);setcolor(15);
bar(0,0,getmaxx,getmaxy);
zufall(n,x);
for i:=1 to n do begin
str(x[i],s);
if x[i]<10 then s:='0'+s;
outtextxy(50+i*20,100,s);
end;
outtextxy(70,320,'Vergleichsabstand : 25');
outtextxy(70,300,'Durchgang : 00');
outtextxy(70,350,'Vertauschungen : 00');
outtextxy(70,360,'Vergleiche : 00');
gap:=n;
repeat
inc(z);
gap:=trunc(gap/1.3); { Neue Schrittweite }
if gap=0 then gap:=1
else
if (gap=9) or (gap=10) then gap:=11;
setcolor(red);
str(gap,s);if gap<10 then s:='0'+s;
bar(230,320,250,330);outtextxy(230,320,s);
setcolor(15);
str(z,s);if z<10 then s:='0'+s;
bar(230,300,250,310);outtextxy(230,300,s);
sorted:=true; { Variable auf "sortiert" setzen }
top:=n-gap; { Obergrenze f<>r Sortieren festlegen }
for i:=1 to top do begin
inc(z1);
setcolor(15);
str(z1,s);if z1<10 then s:='0'+s;
bar(230,360,250,370);outtextxy(230,360,s);
setcolor(blue);
str(x[i],s1);if x[i]<10 then s1:='0'+s1;
outtextxy(50+i*20,100,s1);
str(x[i+gap],s2);if x[i+gap]<10 then s2:='0'+s2;
outtextxy(50+(i+gap)*20,100,s2);
setcolor(green);
line(60+i*20,95,60+i*20,80);
line(60+(i+gap)*20,95,60+(i+gap)*20,80);
line(60+i*20,80,60+(i+gap)*20,80);
bar(20,65,600,75);
outtextxy(16+round((i+gap/2)*20),65,'VERGLEICHEN');
delay(100);
bar(20,65,600,75);
if x[i]>x[i+gap] then begin { Vergleich von Elementen im Abstand "gap" }
inc(z2);
setcolor(15);
str(z2,s);if z2<10 then s:='0'+s;
bar(230,350,250,358);outtextxy(230,350,s);
setcolor(green);
outtextxy(16+round((i+gap/2)*20),65,'VERTAUSCHEN');
for j:=100 to 120 do begin
setcolor(blue);
outtextxy(50+i*20,j,s1);
outtextxy(50+(i+gap)*20,50+j div 2,s2);
delay(1);
bar(50+i*20,j,70+i*20,j+10);bar(50+(i+gap)*20,50+j div 2,70+(i+gap)*20,60+j div 2);
end;
for j:=1 to (gap*20) do begin
setcolor(blue);
outtextxy(50+i*20+j,120,s1);
outtextxy(50+(i+gap)*20-j,110,s2);
delay(1);
bar(50+i*20+j,120,70+i*20+j,130);bar(50+(i+gap)*20-j,110,70+(i+gap)*20-j,120);
end;
for j:=120 downto 100 do begin
setcolor(blue);
outtextxy(50+i*20,j,s1);
outtextxy(50+(i+gap)*20,50+j div 2,s2);
delay(1);
bar(50+i*20,j,70+i*20,j+10);bar(50+(i+gap)*20,50+j div 2,70+(i+gap)*20,60+j div 2);
end;
bar(20,65,600,75);
h:=x[i];x[i]:=x[i+gap];x[i+gap]:=h; { Vertauschung, wenn "falsch" }
sorted:=false; { Variable auf "nicht fertig sortiert" setzen }
end;
setcolor(0);
line(60+i*20,95,60+i*20,80);
line(60+(i+gap)*20,95,60+(i+gap)*20,80);
line(60+i*20,80,60+(i+gap)*20,80);
setcolor(15);
str(x[i],s1);if x[i]<10 then s1:='0'+s1;
outtextxy(50+i*20,100,s1);
str(x[i+gap],s2);if x[i+gap]<10 then s2:='0'+s2;
outtextxy(50+(i+gap)*20,100,s2);
end;
until sorted and (gap=1);
END;
PROCEDURE auswahl;
VAR c : char;
BEGIN
repeat
setfillstyle(1,0);
bar(0,0,getmaxx,getmaxy);
setcolor(15);
outtextxy(260,100,'C O M B S O R T');
outtextxy(260,120,'###############');
outtextxy(220,200,'1...DEMONSTRATION');
outtextxy(220,220,'2...ENDE');
repeat
c:=readkey;
until c<>'';
case c of
'1': combsortdar;
end;
until c='2';
END;
BEGIN
graf;
auswahl;
closegraph;
END.

29
ITG/TEST1_02.PAS Normal file
View File

@ -0,0 +1,29 @@
program SortName;
uses Crt;
var Nam: array[1..3] of string;
i: integer;
procedure Swap(var i1,i2: string);
var tmp: string;
begin
tmp := i1;
i1 := i2;
i2 := tmp;
end;
begin
for i:=1 to 3 do begin
Write('Geben Sie den ',i,'. Namen ein: ');
ReadLn(Nam[i]);
end;
if Nam[3]<Nam[1] then Swap(Nam[3],Nam[1]);
if Nam[2]<Nam[1] then Swap(Nam[2],Nam[1]);
if Nam[3]<Nam[2] then Swap(Nam[3],Nam[2]);
for i:=1 to 3 do begin
WriteLn('Name ',i,': ',Nam[i]);
end;
WriteLn('Bitte eine Taste dr<64>cken!');
ReadKey;
end.

260
ITG/TIERFELD.PAS Normal file
View File

@ -0,0 +1,260 @@
program Tiersuche_im_Feld;
uses Crt, CursorOnOff;
type TBuchQuadrat = array[1..20,1..20] of char;
const DesktopCol=2;
Quadrat: TBuchQuadrat =
(('A','M','S','E','L','L','E','R','O','F','M','R','U','W','D','N','A','B','O','A'),
('L','E','G','I','U','H','E','G','N','A','L','H','C','S','N','A','N','D','U','L'),
('B','O','C','K','B','U','E','N','A','Y','H','O','R','N','I','S','S','E','H','L'),
('N','H','A','H','E','H','S','U','A','L','U','C','H','S','T','S','R','L','U','I'),
('R','P','N','E','Z','N','A','W','R','E','H','D','R','A','P','O','E','L','R','G'),
('E','A','I','E','R','E','W','I','E','S','E','L','R','E','C','H','L','I','U','A'),
('P','V','U','C','E','T','R','A','D','N','A','P','C','H','C','E','S','R','G','T'),
('I','I','G','H','T','S','O','B','N','A','L','H','S','S','O','C','T','G','N','O'),
('V','A','N','W','T','U','D','A','A','P','T','E','U','Z','Y','H','E','B','A','R'),
('M','N','I','A','A','G','N','R','R','M','I','M','S','I','O','T','R','L','K','H'),
('M','I','P','N','N','N','O','S','A','I','L','E','L','E','T','T','A','R','C','S'),
('E','U','L','R','S','A','K','C','W','H','T','T','N','G','E','M','A','S','U','H'),
('R','B','W','B','E','L','L','H','H','C','I','A','N','E','A','N','I','A','K','C'),
('E','B','B','E','E','I','E','E','E','S','S','U','T','O','I','F','R','N','C','V'),
('I','E','L','O','F','T','E','W','D','H','E','N','B','C','I','B','E','T','U','F'),
('H','V','M','L','R','F','O','G','O','V','E','R','H','A','O','P','D','I','K','A'),
('E','L','E','E','L','L','A','R','A','U','P','E','I','R','K','F','R','L','R','H'),
('R','E','G','E','L','E','N','M','K','N','W','E','S','P','E','A','A','O','A','C'),
('E','I','N','D','E','B','U','A','T','E','S','I','E','M','A','U','M','P','C','S'),
('T','F','L','O','W','P','A','N','T','H','E','R','N','R','E','T','S','E','E','S'));
var whats: string;
times: byte;
procedure DrawBorder(x1,y1,x2,y2,FG,BG: byte);
const frame='<27>';
var i,j,xlen,ylen: byte;
tox,toy: byte;
xc,yc: byte;
max: byte;
DDel: byte;
begin
CursorOff;
xlen := (x2-x1);
ylen := (y2-y1);
TextColor(FG);
TextBackground(BG);
if xlen>ylen then max:=xlen else max:=ylen;
DDel:=400 DIV max;
for i:=0 to max do begin
tox:=(xlen*i) DIV max;
toy:=(ylen*i) DIV max;
for j:=0 to 100 do begin
xc := (x1+(tox*(100-j) DIV 100));
yc := (y1+(toy*j DIV 100));
if (xc>x1) AND (yc>y1) AND (xc<x2) AND (yc<y2) then begin
GotoXY(xc,yc);
Write(' ');
end;
xc := (x2-(tox*(100-j) DIV 100));
yc := (y2-(toy*j DIV 100));
if (xc>x1) AND (yc>y1) AND (xc<x2) AND (yc<y2) then begin
GotoXY(xc,yc);
Write(' ');
end;
end;
GotoXY(x1+tox,y1);
Write(frame);
GotoXY(x1,y1+toy);
Write(frame);
GotoXY(x2-tox,y2);
Write(frame);
GotoXY(x2,y2-toy);
Write(frame);
Delay(DDel);
end;
for i:=x1+1 to x2-1 do begin
for j:=y1+1 to y2-1 do begin
GotoXY(i,j);
Write(' ');
end;
end;
CursorOn;
end;
procedure WriteMash;
var x,y: byte;
begin
TextColor(15);
TextBackground(1);
for y:=1 to 20 do begin
for x:=1 to 20 do begin
GotoXY(4+x,4+y);
Write(Quadrat[y,x]);
end;
end;
end;
procedure Init;
begin
TextMode(CO80+Font8x8);
ClrScr;
DrawBorder(1,1,79,49,14,DesktopCol);
DrawBorder(53,13,71,21,0,3);
TextColor(0);
TextBackground(3);
GotoXY(55,15);
Write('Richtungsschema');
GotoXY(60,17);
Write('8 1 2');
GotoXY(60,18);
Write('7 ');
TextColor(15);
WritE('X');
TextColor(0);
Write(' 3');
GotoXY(60,19);
Write('6 5 4');
DrawBorder(3,3,26,26,15,1);
WriteMash;
CursorOff;
end;
procedure Outit;
begin
DrawBorder(1,1,79,49,0,0);
TextMode(CO80);
end;
function Get(x,y,dir,len: byte): string;
var i: byte;
ax,ay: byte;
tmp: string;
begin
i:=len;
ax:=x;
ay:=y;
tmp:='';
repeat
tmp:=tmp+Quadrat[ay,ax];
case dir of
1: Dec(ay);
2: begin Inc(ax); Dec(ay); end;
3: Inc(ax);
4: begin Inc(ax); Inc(ay); end;
5: Inc(ay);
6: begin Dec(ax); Inc(ay); end;
7: Dec(ax);
8: begin Dec(ax); Dec(ay); end;
end;
Dec(i);
until i=0;
Get:=tmp;
end;
procedure Input;
var i: byte;
tmp: string;
begin
DrawBorder(33,5,73,11,11,1);
TextColor(11);
TextBackground(1);
GotoXY(43,7);
WriteLn('Geben Sie ein Tier an');
TextColor(15);
GotoXY(38,9);
CursorOn;
ReadLn(tmp);
CursorOff;
whats:='';
for i:=1 to Length(tmp) do whats:=whats+UpCase(tmp[i]);
DrawBorder(33,5,73,11,DesktopCol,DesktopCol);
TextColor(15);
end;
procedure Mark(x,y,dir,len,fg,bg: byte);
var ax,ay,i: byte;
begin
TextColor(fg);
TextBackground(bg);
ax:=x; ay:=y;
i:=len;
repeat
GotoXY(4+ax,4+ay);
if (ay>=1) AND (ay<=20) AND (ax>=1) AND (ax<=20) then Write(Quadrat[ay,ax]);
case dir of
1: Dec(ay);
2: begin Inc(ax); Dec(ay); end;
3: Inc(ax);
4: begin Inc(ax); Inc(ay); end;
5: Inc(ay);
6: begin Dec(ax); Inc(ay); end;
7: Dec(ax);
8: begin Dec(ax); Dec(ay); end;
end;
Dec(i);
until i=0;
Delay(30);
TextBackground(0);
TextColor(15);
end;
procedure Search(what: string);
var i,j,k: byte;
ox,oy: byte;
tmp: string;
begin
TextBackground(0);
ox:=1;
oy:=1;
for i:=1 to 20 do begin
for j:=1 to 20 do begin
(* Mark(j,i,1,1,9,1); *)
if (Quadrat[i,j]=what[1]) then begin
for k:=1 to 8 do begin
tmp:=Get(j,i,k,Length(what));
(* Mark(j,i,k,Length(what),0,1); *)
if tmp=what then begin
Window(5,30,75,46);
GotoXY(ox,oy);
Inc(times);
WriteLn('Hab ''',what,''' bei (',j:2,'|',i:2,') gefunden. Richtung ',k,', L<>nge ',Length(what));
ox:=WhereX; oy:=WhereY;
Window(1,1,80,50);
Mark(j,i,k,Length(what),0,7);
Delay(50);
end;
(* Mark(j,i,k,Length(what),15,1); *)
end;
end;
(* Mark(j,i,1,1,15,1); *)
end;
end;
window(5,30,75,46);
GotoXY(ox,oy);
if (times=0) then begin
WriteLn('Hab nix gefunden - versuch'' was anderes.');
end;
end;
procedure ClearErg;
begin
DrawBorder(3,28,77,47,DesktopCol,DesktopCol);
DrawBorder(3,28,77,47,15,0);
end;
begin
Init;
repeat
times:=0;
{ WriteMash; }
ClearErg;
Input;
if (whats<>'') then begin
Search(whats);
WriteLn;
WriteLn('[ Taste dr<64>cken, um fort zu fahren ]');
window(1,1,80,50);
ReadKey;
end;
until whats='';
Outit;
end.

137
ITG/TIMECALC.PAS Normal file
View File

@ -0,0 +1,137 @@
program TimeCalc; { Unterrichtsstoff der 12. Klasse - L<>sung von Markus Birth }
uses Crt,Strings;
var tstr: string[40];
h1,m1,s1,hs1: integer;
h2,m2,s2,hs2: integer;
hf,mf,sf,hsf: integer;
procedure GetData(which: string;var h,m,s,hs: integer);
var i,ec,tmp,oldi: integer;
begin
Write('Geben Sie die ',which,' Zeit ein [hh:mm.ss,tt]: ');
ReadLn(tstr);
oldi := 1;
for i:=1 to Length(tstr) do begin
if ((tstr[i]=':') OR (tstr[i]='.') OR (tstr[i]=',')) then begin
Val(Copy(tstr,oldi,i-oldi),tmp,ec);
oldi := i+1;
case tstr[i] of
':': h:=tmp;
'.': m:=tmp;
',': s:=tmp;
end;
end;
end;
Val(Copy(tstr,oldi,Length(tstr)-oldi+1),tmp,ec);
hs:=tmp;
end;
procedure AddData(h1,m1,s1,hs1,h2,m2,s2,hs2: integer; var hf,mf,sf,hsf: integer; Add: boolean);
begin
if Add then begin
hsf := hs1 + hs2;
sf := s1 + s2;
mf := m1 + m2;
hf := h1 + h2;
sf := sf + hsf DIV 100;
hsf := hsf MOD 100;
mf := mf + sf DIV 60;
sf := sf MOD 60;
hf := hf + mf DIV 60;
mf := mf MOD 60;
end else begin
hsf := hs1 - hs2;
sf := s1 - s2;
mf := m1 - m2;
hf := h1 - h2;
while hsf<0 do begin
hsf := hsf + 100;
sf := sf - 1;
end;
while sf<0 do begin
sf := sf + 60;
mf := mf - 1;
end;
while mf<0 do begin
mf := mf + 60;
hf := hf - 1;
end;
end;
end;
procedure TimeOut(h,m,s,t: integer);
begin
WriteLn(h:2,':',m:2,'.',s:2,'''',t:2,'''''');
end;
procedure DataOut(Add: boolean);
begin
Write(' ');
TimeOut(h1,m1,s1,hs1);
if Add then Write('+') else Write('-');
TimeOut(h2,m2,s2,hs2);
WriteLn('<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>');
AddData(h1,m1,s1,hs1,h2,m2,s2,hs2,hf,mf,sf,hsf,Add);
Write(' ');
TimeOut(hf,mf,sf,hsf);
WriteLn('<27><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>');
end;
procedure SwapVals(var h1,m1,s1,t1,h2,m2,s2,t2: integer);
var tmp: integer;
begin
tmp := h1;
h1 := h2;
h2 := tmp;
tmp := m1;
m1 := m2;
m2 := tmp;
tmp := s1;
s1 := s2;
s2 := tmp;
tmp := t1;
t1 := t2;
t2 := tmp;
end;
procedure Time2Secs(h,m,s: integer; var sec: longint);
begin
sec := h*3600 + m*60 + s;
end;
procedure Secs2Time(sec: longint; var h,m,s: integer);
begin
h := sec div 3600;
sec := sec mod 3600;
m := sec div 60;
s := sec mod 60;
end;
begin
ClrScr;
GetData(' erste',h1,m1,s1,hs1);
GetData('zweite',h2,m2,s2,hs2);
Window(1,4,26,10);
DataOut(true);
Window(26,4,52,10);
DataOut(false);
Window(52,4,78,10);
SwapVals(h1,m1,s1,hs1,h2,m2,s2,hs2);
DataOut(false);
Window(1,1,80,25);
GotoXY(1,11);
WriteLn;
WriteLn('*** Bitte dr<64>cken Sie eine Taste ***');
ReadKey;
end.

347
ITG/VISUAL.PAS Normal file
View File

@ -0,0 +1,347 @@
program Visualization;
uses Crt, Graph, BGIP;
const CompareColor = 14;
HaveToSwapC = 12;
MarkDelay = 500;
Bool_Active = 11;
Bool_AText = 0;
Bool_Disabl = 9;
Bool_DText = 15;
var xmax, ymax, xmed, ymed: word;
xarr: array[1..10] of byte;
procedure InitGraphics;
var grDriver, grMode: integer;
begin
grDriver := VGA;
grMode := VGAHi;
InitGraph(grDriver, grMode, BGIPath);
xmax := GetMaxX+1; { Bildschirmbreite in Pixeln }
ymax := GetMaxY+1; { Bildschirmh<6D>he in Pixeln }
xmed := xmax DIV 2;
ymed := ymax DIV 2;
end;
procedure Outit;
begin
TextMode(CO80);
WriteLn('VMode : ',xmax,'x',ymax);
WriteLn('Center: ',xmed,'x',ymed);
WriteLn;
WriteLn('Programm beendet.');
end;
function V2S(x: byte): string;
var tmp: string;
begin
Str(x,tmp);
V2S := tmp;
end;
procedure SwapVal(var x1,x2: integer);
var tmp: integer;
begin
tmp := x1;
x1 := x2;
x2 := tmp;
end;
procedure SwapValB(var x1,x2: byte);
var tmp: byte;
begin
tmp := x1;
x1 := x2;
x2 := tmp;
end;
procedure InitArray;
var i: byte;
begin
Randomize;
for i:=1 to 10 do xarr[i] := Random(256);
end;
procedure MakeBox(el: byte;x,y: integer);
var tw: word;
begin
SetTextJustify(CenterText,CenterText);
tw := TextWidth(V2S(xarr[el]));
SetFillStyle(SolidFill,1);
Bar(x-tw DIV 2-2,y-5,x+tw DIV 2+2,y+5);
SetColor(11);
SetLineStyle(SolidLn,0,NormWidth);
Rectangle(x-tw DIV 2-2,y-5,x+tw DIV 2+2,y+5);
SetColor(15);
OutTextXY(x,y+1,V2S(xarr[el]));
end;
procedure ClearBox(el: byte;x,y: integer);
var tw: word;
begin
SetFillStyle(SolidFill,0);
tw := TextWidth(V2S(xarr[el]));
Bar(x-tw DIV 2-2,y-5,x+tw DIV 2+2,y+5);
end;
procedure OutArrayPlain(title: string);
var i: byte;
begin
ClearViewPort;
for i:=1 to 10 do begin
MakeBox(i,64*i-32,40);
SetColor(7);
OutTextXY(64*i-32,30,V2S(i));
end;
SetColor(14);
OutTextXY(320,15,title);
end;
procedure Mark(el,col: byte);
var tw: word;
x : integer;
begin
tw := TextWidth(V2S(xarr[el]));
x := 64*el-32;
SetColor(col);
SetLineStyle(SolidLn,0,ThickWidth);
Line(x-tw DIV 2-2,48,x+tw DIV 2+2,48);
end;
procedure Connect(el1,el2,col,depth: byte);
var x: integer;
begin
SetColor(col);
Mark(el1,col);
Mark(el2,col);
x := 64*el1-32;
MoveTo(x,49);
SetLineStyle(SolidLn,0,NormWidth);
LineTo(x,49+depth*20);
x := 64*el2-32;
LineTo(x,49+depth*20);
LineTo(x,49);
end;
procedure ClearConns;
begin
SetFillStyle(SolidFill,0);
Bar(5,47,635,149);
end;
procedure Swap(el1,el2: byte);
var i: integer;
x1,x2: integer;
lo,hi: integer;
m1,m2: integer;
SwapDelay: integer;
begin
if (el1=el2) then Exit;
x1 := 64*el1-32;
x2 := 64*el2-32;
if (x2<x1) then begin
SwapVal(x1,x2);
SwapValB(el1,el2);
end;
SwapDelay := 1000 DIV (x2-x1);
for i:=40 to 80 do begin
ClearBox(el1,x1,i);
MakeBox(el1,x1,i+1);
ClearBox(el2,x2,i);
MakeBox(el2,x2,i+1);
Delay(SwapDelay);
end;
for i:=x1 to x2-1 do begin
m1 := i;
m2 := x1+x2-i;
ClearBox(el1,m1,81);
MakeBox(el1,m1+1,81);
ClearBox(el1,m2,81);
MakeBox(el2,m2-1,81);
Delay(SwapDelay);
end;
for i:=80 downto 40 do begin
ClearBox(el2,x1,i+1);
MakeBox(el2,x1,i);
ClearBox(el1,x2,i+1);
MakeBox(el1,x2,i);
Delay(SwapDelay);
end;
SwapValB(xarr[el1],xarr[el2]);
end;
procedure ShowValue(desc: string;val: integer;el,col,depth: byte);
var OT: string;
begin
SetFillStyle(SolidFill,0);
Bar(0,320+depth*10-5,640,320+depth*10+5);
SetColor(col);
SetTextJustify(LeftText,CenterText);
OT := desc+': '+V2S(val);
OutTextXY(5,320+depth*10,OT);
if (el<>0) then begin
Mark(el,10);
SetLineStyle(SolidLn,0,NormWidth);
MoveTo(64*el-32,49);
LineTo(64*el-32,320+depth*10);
LineTo(TextWidth(OT)+10,320+depth*10);
Delay(MarkDelay);
SetColor(0);
MoveTo(64*el-32,49);
LineTo(64*el-32,320+depth*10);
LineTo(TextWidth(OT)+10,320+depth*10);
SetColor(CompareColor);
MoveTo(64*el-32,49);
LineTo(64*el-32,69);
Mark(el,CompareColor);
end;
end;
procedure Bool(text1,text2: string;what: boolean;depth: byte);
var OT: string;
begin
SetTextJustify(CenterText,CenterText);
if (what) then begin
SetFillStyle(SolidFill,Bool_Active);
SetColor(Bool_AText);
OT := text1;
end else begin
SetFillStyle(SolidFill,Bool_Disabl);
SetColor(Bool_DText);
OT := text2;
end;
Bar(320,240+(depth-1)*20,639,240+(depth)*20);
OutTextXY(480,240+(depth)*20-10,OT);
end;
{###########################################################################
###########################################################################
##################### SORTIER ALGORITHMEN #################################
###########################################################################
###########################################################################}
procedure Sort_Simple;
var i,j: integer;
begin
for i:=1 to 9 do
for j:=i+1 to 10 do begin
Connect(i,j,CompareColor,1);
Delay(MarkDelay);
if xarr[j]<xarr[i] then begin
Connect(i,j,HaveToSwapC,1);
Delay(MarkDelay);
ClearConns;
Swap(i,j);
end;
ClearConns;
end;
end;
procedure Sort_Selectionsort;
var i,j,minpos: integer;
begin
for i:=1 to 9 do begin
minpos := i;
ShowValue('minpos',minpos,0,15,1);
for j:=i+1 to 10 do begin
Connect(i,j,CompareColor,1);
Delay(MarkDelay);
if xarr[j]<xarr[minpos] then begin
minpos:=j;
ShowValue('minpos',minpos,j,10,1);
Delay(MarkDelay);
end;
ClearConns;
end;
if (i<>minpos) then begin
Connect(i,minpos,HaveToSwapC,1);
Delay(MarkDelay);
ClearConns;
end;
Swap(i,minpos);
end;
end;
procedure Sort_Bubblesort;
var i: integer;
canswap: boolean;
begin
repeat
canswap:=false;
Bool('Konnte was tauschen','Konnte (noch) nichts tauschen',canswap,1);
for i:=1 to 9 do begin
Connect(i,i+1,CompareColor,1);
Delay(MarkDelay);
if xarr[i]>xarr[i+1] then begin
Connect(i,i+1,HaveToSwapC,1);
Delay(MarkDelay);
ClearConns;
Bool('TAUSCHE','',true,1);
Swap(i,i+1);
canswap := true;
end;
Bool('Konnte was tauschen','Konnte (noch) nichts tauschen',canswap,1);
ClearConns;
end;
until (NOT canswap);
end;
{###########################################################################
###########################################################################
######################### DER LETZTE REST #################################
###########################################################################
###########################################################################}
procedure WaitForKey;
var x: byte;
begin
repeat
x := Random(16);
SetColor(x);
SetTextJustify(CenterText,CenterText);
OutTextXY(320,240,'SORTIERUNG ABGESCHLOSSEN - bitte eine Taste dr<64>cken');
Delay(1);
until keypressed;
ReadKey;
end;
procedure Simplest_DEMO;
begin
InitArray;
OutArrayPlain('einfachste Sortierung');
Sort_Simple;
WaitForKey;
end;
procedure Selection_DEMO;
begin
InitArray;
OutArrayPlain('Selectionsort');
Sort_Selectionsort;
WaitForKey;
end;
procedure Bubble_DEMO;
begin
InitArray;
OutArrayPlain('Bubblesort');
Sort_Bubblesort;
WaitForKey;
end;
begin
InitGraphics;
{ Simplest_DEMO; }
Selection_DEMO;
Bubble_DEMO;
Outit;
end.

35
ITG/VISUAL2.INI Normal file
View File

@ -0,0 +1,35 @@
D:\LANG\BP\BGI
2000
15
8
5
0
1
50
1
10
30
0
1
10
0
INI-Datei f<>r VISUAL2.EXE (bzw. VISUAL2.PAS)
Copyright (c)1999 by Markus Birth <mbirth@webwriters.de>
1. Zeile: BGI-Path
2. Zeile: Pre-Delay vor Grafikanzeige
3. Zeile: Punktfarbe
4. Zeile: Spurfarbe
5. Zeile: einfachstes Sort (normal): -Faktor
6. -Delay
7. Zeile: einfachstes Sort (quick): -Faktor
8. -Delay
9. Zeile: Selectionsort: -Faktor
10. -Delay
11. Zeile: Bubblesort: -Faktor
12. -Delay
13. Zeile: Quicksort: -Faktor
14. -Delay
15. Zeile: Arraytype (0-Random, 1-aufsteigend, 2-absteigend)

926
ITG/VISUAL2.PAS Normal file
View File

@ -0,0 +1,926 @@
program Visualization2;
uses Crt, Graph, VFx, BGIP;
const cnt: byte=0;
abo: boolean=false;
firstrun: boolean=true;
Simple_quick:boolean=false;
DataFile='visual2.ini';
Arraytypes: array[0..2] of string[20]=('zufall','aufsteigend','absteigend');
var xmax, ymax, xmed, ymed: word;
xarr,oarr: array[0..639] of integer;
pretime, opretime: integer;
slow_, fact_, oslow_, ofact_: array[1..11] of integer;
slow,fact: integer;
sel: byte;
DotCol, TrailCol, oDotCol, oTrailCol: byte;
{BGIPath,} oBGIPath: string;
Arraytype, oArraytype, OAT: byte;
function GetIniString(line: byte): string;
var f: text;
i: integer;
tmp: string;
begin
Assign(f,DataFile);
{$I-}
Reset(f);
if IOResult<>0 then begin
TextMode(co80);
WriteLn('Fehler beim Lesen der ',Datafile,' ... existiert die auch?');
WriteLn('... und sind wir auch im richtigen Verzeichnis????');
WriteLn;
WriteLn('Egal ... ich leg'' mir selbst eine an ... ');
Rewrite(f);
if IOResult<>0 then begin
WriteLn('Schei<65>e ... nicht mal das geht auf diesem Sau-Rechner ...');
WriteLn('Mu<4D>t wohl doch DU das Problem l<>sen .... sieh'' mal zu, da<64>');
WriteLn('Du mehr Rechte auf dieses Verzeichnis bekommst!');
WriteLn;
Halt;
end;
WriteLn(f,'D:\BP\BGI');
WriteLn(f,'2000');
WriteLn(f,'15');
WriteLn(f,'8');
WriteLn(f,'5');
WriteLn(f,'0');
WriteLn(f,'1');
WriteLn(f,'50');
WriteLn(f,'1');
WriteLn(f,'10');
WriteLn(f,'30');
WriteLn(f,'0');
WriteLn(f,'1');
WriteLn(f,'10');
WriteLn(f,'0');
WriteLn(f,'');
WriteLn(f,'INI-Datei f<>r VISUAL2.EXE (bzw. VISUAL2.PAS)');
WriteLn(f,'');
WriteLn(f,' Copyright (c)1999 by Markus Birth <mbirth@webwriters.de>');
WriteLn(f,'');
WriteLn(f,' 1. Zeile: BGI-Path');
WriteLn(f,' 2. Zeile: Pre-Delay vor Grafikanzeige');
WriteLn(f,' 3. Zeile: Punktfarbe');
WriteLn(f,' 4. Zeile: Spurfarbe');
WriteLn(f,' 5. Zeile: einfachstes Sort (normal): -Faktor');
WriteLn(f,' 6. -Delay');
WriteLn(f,' 7. Zeile: einfachstes Sort (quick): -Faktor');
WriteLn(f,' 8. -Delay');
WriteLn(f,' 9. Zeile: Selectionsort: -Faktor');
WriteLn(f,'10. -Delay');
WriteLn(f,'11. Zeile: Bubblesort: -Faktor');
WriteLn(f,'12. -Delay');
WriteLn(f,'13. Zeile: Quicksort: -Faktor');
WriteLn(f,'14. -Delay');
WriteLn(f,'15. Zeile: Arraytype (0-Random, 1-aufsteigend, 2-absteigend)');
Close(f);
WriteLn('Sooo, das w<>re geschafft! Wenn Du jetzt das Programm nocheinmal');
WriteLn('aufrufst, m<><6D>te alles funktionieren!');
Halt;
end;
{$I+}
for i:=1 to line do ReadLn(f,tmp);
Close(f);
GetIniString := tmp;
end;
function Str2Val(st: string): integer;
var tmp, ec: integer;
begin
Val(st,tmp,ec);
if (ec<>0) then begin
TextMode(co80);
WriteLn('Fehler beim Umwandeln eines Strings in einen numerischen Wert.');
WriteLn('Stimmen die Eintr<74>ge in der INI-Datei??');
Halt;
end;
Str2Val := tmp;
end;
procedure ReadIni;
var tmp: string;
begin
BGIPath := GetIniString(1);
pretime := Str2Val(GetIniString(2));
DotCol := Str2Val(GetIniString(3));
TrailCol := Str2Val(GetIniString(4));
fact_[1] := Str2Val(GetIniString(5));
slow_[1] := Str2Val(GetIniString(6));
fact_[11] := Str2Val(GetIniString(7));
slow_[11] := Str2Val(GetIniString(8));
fact_[2] := Str2Val(GetIniString(9));
slow_[2] := Str2Val(GetIniString(10));
fact_[3] := Str2Val(GetIniString(11));
slow_[3] := Str2Val(GetIniString(12));
fact_[4] := Str2Val(GetIniString(13));
slow_[4] := Str2Val(GetIniString(14));
Arraytype := Str2Val(GetIniString(15));
end;
procedure InitGraphics;
var grDriver, grMode: integer;
begin
grDriver := VGA;
grMode := VGAHi;
InitGraph(grDriver, grMode, BGIPath);
xmax := GetMaxX+1; { Bildschirmbreite in Pixeln }
ymax := GetMaxY+1; { Bildschirmh<6D>he in Pixeln }
xmed := xmax DIV 2;
ymed := ymax DIV 2;
end;
procedure Outit;
begin
TextBackground(0);
ClrScr;
WriteLn('Dieses Programm wurde Ihnen pr<70>sentiert von ..... nein, nicht Krombacher!');
WriteLn('Aber daf<61>r von Markus Birth, Sch<63>ler der 12. Klasse im Jahrgang 1998/99');
WriteLn;
WriteLn;
WriteLn('VMode : ',xmax,'x',ymax);
WriteLn('Center: ',xmed,'x',ymed);
WriteLn;
WriteLn('Programm beendet.');
end;
function V2S(x: byte): string;
var tmp: string;
begin
Str(x,tmp);
V2S := tmp;
end;
procedure SwapVal(var x1,x2: integer);
var tmp: integer;
begin
tmp := x1;
x1 := x2;
x2 := tmp;
end;
function InArray(what: integer): boolean;
var i: word;
tmp: boolean;
begin
tmp := false;
for i:=0 to 639 do begin
if xarr[i]=what then begin
tmp := true;
Exit;
end;
end;
InArray := tmp;
end;
procedure InitArray;
var i: word;
tmp: integer;
begin
Randomize;
for i:=0 to 639 do begin
case Arraytype of
0: xarr[i] := Random(480);
1: if (i<480) then xarr[i] := i else xarr[i] := 479;
2: if (i<480) then xarr[i] := 479-i else xarr[i] := 0;
end;
oarr[i] := xarr[i];
end;
end;
procedure OutArray;
var i: word;
begin
if (keypressed) then begin
abo := true;
Exit;
end;
Inc(cnt);
if (cnt>=fact) then begin
cnt := 0;
for i:=0 to 639 do begin
PutPixel(i,479-oarr[i],TrailCol);
PutPixel(i,479-xarr[i],DotCol);
oarr[i]:=xarr[i];
end;
Delay(slow);
end;
end;
procedure PutBigPixel(x,y: word;c: byte);
begin
PutPixel(x-1,y-1,c);
PutPixel(x-1,y,c);
PutPixel(x-1,y+1,c);
PutPixel(x,y-1,c);
PutPixel(x,y,c);
PutPixel(x,y+1,c);
PutPixel(x+1,y-1,c);
PutPixel(x+1,y,c);
PutPixel(x+1,y+1,c);
end;
{###########################################################################
###########################################################################
##################### SORTIER ALGORITHMEN #################################
###########################################################################
###########################################################################}
procedure Sort_Simple;
var i,j: integer;
yi,yj: integer;
begin
for i:=0 to 638 do begin
for j:=i+1 to 639 do begin
yi := 479-xarr[i];
yj := 479-xarr[j];
{ PutBigPixel(j,yj,12); }
if xarr[j]<xarr[i] then begin
SwapVal(xarr[i],xarr[j]);
if NOT Simple_quick then OutArray;
end;
{ Delay(5);
PutBigPixel(j,yj,0);
PutPixel(j,479-xarr[j],15); }
if (abo) then Exit;
end;
if (abo) then Exit;
if Simple_quick then OutArray;
end;
end;
procedure Sort_Selectionsort;
var i,j,minpos: integer;
begin
for i:=0 to 638 do begin
minpos := i;
for j:=i+1 to 639 do begin
if xarr[j]<xarr[minpos] then begin
minpos:=j;
end;
end;
SwapVal(xarr[i],xarr[minpos]);
OutArray;
if (abo) then Exit;
end;
end;
procedure Sort_Bubblesort;
var i: integer;
canswap: boolean;
begin
repeat
canswap:=false;
for i:=0 to 638 do begin
if xarr[i]>xarr[i+1] then begin
SwapVal(xarr[i],xarr[i+1]);
OutArray;
canswap := true;
end;
if (abo) then Exit;
end;
until (NOT canswap) OR (abo);
end;
{#################################}
procedure Sort_Insertionsort;
var h,i,j: integer;
begin
for i:=2 to 638 do begin
h := xarr[i];
xarr[0] := h;
j := i-1;
while h<xarr[j] do begin
xarr[j+1] := xarr[j];
OutArray;
if (i>2) then Dec(j) else exit;
end;
xarr[j+1] := h;
if (abo) then Exit;
end;
end;
procedure Sort_QuickSort(sta,sto: integer; var f: array of integer);
var li, re: integer;
h, vgl: integer;
begin
li:=sta; re:=sto; vgl:=f[(li+re) DIV 2];
if li<re then begin
repeat
while f[li]<vgl do Inc(li);
while f[re]>vgl do Dec(re);
if li<=re then begin
SwapVal(f[li],f[re]);
inc(li); dec(re);
OutArray;
end;
until (li>re) OR (abo);
if (NOT abo) then begin
Sort_QuickSort(sta,re,f);
Sort_QuickSort(li,sto,f);
end;
end;
end;
{###########################################################################
###########################################################################
######################### DER LETZTE REST #################################
###########################################################################
###########################################################################}
procedure WaitForKey;
var x: byte;
begin
repeat
x := Random(16);
SetColor(x);
SetTextJustify(CenterText,CenterText);
OutTextXY(320,240,'SORTIERUNG ABGESCHLOSSEN - bitte eine Taste dr<64>cken');
Delay(1);
until keypressed;
ReadKey;
end;
procedure DoIt(what: byte);
begin
InitArray;
InitGraphics;
OutArray;
Delay(pretime);
slow := slow_[what];
fact := fact_[what];
case what of
1: Sort_Simple;
11: begin
Simple_quick := true;
Sort_Simple;
end;
2: Sort_Selectionsort;
3: Sort_Bubblesort;
4: Sort_Quicksort(0,639,xarr);
end;
cnt := fact;
OutArray;
ReadyBeep;
ReadKey;
TextMode(co80);
end;
function KeyValid(sel: char): boolean;
begin
if (sel IN ['A'..'E','a'..'e','s','S','X','x']) then KeyValid := true
else KeyValid := false;
end;
procedure UpdateAType;
var ofxwd: integer;
begin
ofxwd := fxwd;
fxwd := 650;
if (OAT<>255) then begin
GotoXY(46,20);
WriteLR(Arraytypes[OAT],1);
end;
GotoXY(46,20);
WriteLR(Arraytypes[ArrayType],15);
OAT := ArrayType;
fxwd := ofxwd;
end;
function Menu: byte;
var sel: char;
begin
OAT := 255;
TextBackground(0);
TextMode(co80 + Font8x8);
ClrScr;
DrawBorder2(1,1,79,50,11,1);
if firstrun then fxwd := 650 else fxwd := 10;
GotoXY(1,3);
TextColor(8);
CursorOff;
WriteC('--==+ Visualization 2 +==--');
Delay(300);
FXWriteC('--==+ Visualization 2 +==--',15);
GotoXY(29,6); FXWrite('[ ] Simplesort (normal)',11);
GotoXY(29,8); FXWrite('[ ] Simplesort (quick)',11);
GotoXY(29,10); FXWrite('[ ] Selectionsort',11);
GotoXY(29,12); FXWrite('[ ] Bubblesort',11);
GotoXY(29,14); FXWrite('[ ] Quicksort',11);
GotoXY(29,20); FXWrite('[ ] Zahlenfolge: ',11);
GotoXY(29,24); FXWrite('[ ] Voreinstellungen <20>ndern',11);
GotoXY(29,26); FXWrite('[ ] Programm beenden',11);
fxwd := 10;
GotoXY(30,6); FXWrite('A',14);
GotoXY(30,8); FXWrite('B',14);
GotoXY(30,10); FXWrite('C',14);
GotoXY(30,12); FXWrite('D',14);
GotoXY(30,14); FXWrite('E',14);
GotoXY(30,20); FXWrite('T',14);
GotoXY(30,24); FXWrite('S',14);
GotoXY(30,26); FXWrite('X',14);
if firstrun then fxwd := 650;
UpdateAType;
firstrun := false;
GotoXY(1,30);
FXWriteC('Dr<44>cken Sie einen der gelben Buchstaben (auf der Tastatur).',7);
Menu := 0;
repeat
sel := ReadKey;
if (NOT KeyValid(sel)) AND NOT (sel IN ['t','T']) then begin
Sound(400);
Delay(100);
NoSound;
end else begin
Sound(1200);
Delay(50);
NoSound;
end;
if (sel IN ['t','T']) then begin
Inc(ArrayType);
if (ArrayType>2) then ArrayType := 0;
UpdateAType;
end;
until KeyValid(sel);
case sel of
'a','A': Menu := 1;
'b','B': Menu := 2;
'c','C': Menu := 3;
'd','D': Menu := 4;
'e','E': Menu := 5;
'x','X': Menu := 0;
's','S': Menu := 128;
end;
end;
procedure WriteLet(b: char;text: string;c: byte);
begin
TextColor(c);
Write('[');
TextColor(14);
Write(UpCase(b));
TextColor(c);
Write('] ',text);
end;
procedure OutSetup;
begin
GotoXY(5,10); WriteLet('A','BGI-Pfad: ',10);
TextColor(15); Write(BGIPath);
GotoXY(5,12); WriteLet('B','Pre-Delay: ',10);
TextColor(15); Write(pretime:0);
GotoXY(30,12); WriteLet('C','Punktfarbe: ',10);
TextColor(15); Write(DotCol:3,' ');
TextColor(DotCol); Write('<27>');
GotoXY(55,12); WriteLet('D','Spurfarbe: ',10);
TextColor(15); Write(TrailCol:3,' ');
TextColor(TrailCol); Write('<27>');
GotoXY(5,15); WriteLet('E','einfachstes Sort (normal)',11);
GotoXY(45,15); WriteLet('F','einfachstes Sort (quick)',11);
GotoXY(5,19); WriteLet('G','Selectionsort',11);
GotoXY(45,19); WriteLet('H','Bubblesort',11);
GotoXY(5,23); WriteLet('I','Quicksort',11);
TextColor(8);
GotoXY(45,25); Write('Zahlenfolge: ',ArrayTypes[ArrayType]);
GotoXY(11,16); Write('Faktor: ',fact_[1]);
GotoXY(11,17); Write('Delay : ',slow_[1]);
GotoXY(51,16); Write('Faktor: ',fact_[11]);
GotoXY(51,17); Write('Delay : ',slow_[11]);
GotoXY(11,20); Write('Faktor: ',fact_[2]);
GotoXY(11,21); Write('Delay : ',slow_[2]);
GotoXY(51,20); Write('Faktor: ',fact_[3]);
GotoXY(51,21); Write('Delay : ',slow_[3]);
GotoXY(11,24); Write('Faktor: ',fact_[4]);
GotoXY(11,25); Write('Delay : ',slow_[4]);
GotoXY(7,47);
WriteLet('O','Eingaben <20>bernehmen',15); Write(' ');
WriteLet('S','Eingaben sichern',15); Write(' ');
WriteLet('X','Abbrechen',15);
end;
function Setup_KeyValid(what: char): boolean;
begin
if (what IN ['A'..'I','a'..'i','o','O','s','S','x','X']) then Setup_KeyValid:=true
else Setup_KeyValid := false;
end;
procedure DoHelp;
begin
window(5,28,75,45);
TextBackground(1);
ClrScr;
window(6,29,74,44);
TextColor(14);
WriteLn('--==+ HILFE +==--');
WriteLn;
TextColor(15);
end;
procedure HelpDone;
begin
window(1,1,80,50);
TextBackground(2);
end;
procedure ClearHelp;
begin
window(5,28,75,45);
TextBackground(2);
ClrScr;
window(1,1,80,50);
end;
procedure Setup_GetVal(var v: integer);
var tmp: string;
tmp2, ec: integer;
wx, wy: word;
begin
wx := WhereX;
wy := WhereY;
repeat
GotoXY(wx,wy);
Write(Space(10));
GotoXY(wx,wy);
ReadLn(tmp);
Val(tmp,tmp2,ec);
if (ec<>0) then ErrorBeep;
until (tmp='') OR (ec=0);
if (tmp<>'') then v := tmp2;
AckBeep;
end;
procedure Setup_GetByte(var v: byte);
var tmp: string;
tmp2, ec: integer;
wx, wy: word;
begin
wx := WhereX;
wy := WhereY;
repeat
GotoXY(wx,wy);
Write(Space(5));
GotoXY(wx,wy);
ReadLn(tmp);
Val(tmp,tmp2,ec);
if (ec<>0) then ErrorBeep;
until (tmp='') OR (ec=0);
if (tmp<>'') then v := tmp2;
AckBeep;
end;
procedure Setup_BGIpath;
var tmp: string;
begin
GotoXY(5,10);
TextColor(10+blink); Write('[ ]');
GotoXY(6,10);
TextColor(14+blink); Write('A');
DoHelp;
WriteLn('Geben Sie den Pfad zu den BGI-Dateien an.');
WriteLn;
WriteLn('Beispiel: C:\SCHULS~1\TP\BGI');
WriteLn;
WriteLn('Um den alten Wert zu behalten, einfach [ENTER] dr<64>cken.');
HelpDone;
GotoXY(19,10); Write(Space(50));
GotoXY(19,10);
TextColor(15);
ReadLn(tmp);
if (tmp<>'') then BGIpath := tmp;
ClearHelp;
GotoXY(5,10); TextColor(10); Write('[ ]');
GotoXY(6,10); TextColor(14); Write('A');
GotoXY(19,10);TextColor(15); Write(BGIpath);
end;
procedure Setup_PreDelay;
var tmp: string;
tmp2, ec: integer;
begin
GotoXY(5,12);
TextColor(10+blink); Write('[ ]');
GotoXY(6,12);
TextColor(14+blink); Write('B');
DoHelp;
WriteLn('Geben Sie die Zeit an, die vor der Grafikanzeige gewartet werden');
WriteLn('soll. Dies ist bei den neueren Monitoren n<>tig, da sie einige');
WriteLn('Zeit ben<65>tigen, um in den Grafikmodus zu schalten.');
WriteLn;
WriteLn('Beispiel: 2000 - f<>r 2 Sekunden');
WriteLn;
WriteLn('Um den alten Wert zu behalten, einfach [ENTER] dr<64>cken.');
HelpDone;
GotoXY(20,12); TextColor(15);
Setup_GetVal(pretime);
ClearHelp;
GotoXY(5,12); TextColor(10); Write('[ ]');
GotoXY(6,12); TextColor(14); Write('B');
GotoXY(20,12); Write(Space(10));
GotoXY(20,12);TextColor(15); Write(pretime:0);
end;
procedure ColTab;
begin
WriteLn(' 0 1 2 3 4 5 6 7');
CWriteLn('%%0#<23><><EFBFBD><EFBFBD>%%1#<23><><EFBFBD><EFBFBD>%%2#<23><><EFBFBD><EFBFBD>%%3#<23><><EFBFBD><EFBFBD>%%4#<23><><EFBFBD><EFBFBD>%%5#<23><><EFBFBD><EFBFBD>%%6#<23><><EFBFBD><EFBFBD>%%7#<23><><EFBFBD><EFBFBD>');
CWriteLn('%%8#<23><><EFBFBD><EFBFBD>%%9#<23><><EFBFBD><EFBFBD>%%10#<23><><EFBFBD><EFBFBD>%%11#<23><><EFBFBD><EFBFBD>%%12#<23><><EFBFBD><EFBFBD>%%13#<23><><EFBFBD><EFBFBD>%%14#<23><><EFBFBD><EFBFBD>%%15#<23><><EFBFBD><EFBFBD>');
WriteLn(' 8 9 10 11 12 13 14 15');
end;
procedure Setup_DotCol;
var tmp: string;
tmp2,ec: integer;
begin
GotoXY(30,12);
TextColor(10+blink); Write('[ ]');
GotoXY(31,12);
TextColor(14+blink); Write('C');
DoHelp;
WriteLn('Geben Sie die Farbe f<>r die aktiven Punkte an.');
WriteLn;
WriteLn('Die Zahl mu<6D> zwischen 0 und 255 liegen.');
WriteLn('Um den alten Wert zu behalten, einfach [ENTER] dr<64>cken.');
WriteLn;
WriteLn('Beispiele:');
WriteLn;
ColTab;
HelpDone;
GotoXY(46,12); TextColor(15);
Setup_GetByte(DotCol);
ClearHelp;
GotoXY(30,12); TextColor(10); Write('[ ]');
GotoXY(31,12); TextColor(14); Write('C');
GotoXY(46,12); Write(Space(5));
GotoXY(46,12);TextColor(15); Write(DotCol:3,' '); TextColor(DotCol); Write('<27>');
end;
procedure Setup_TrailCol;
var tmp: string;
tmp2,ec: integer;
begin
GotoXY(55,12);
TextColor(10+blink); Write('[ ]');
GotoXY(56,12);
TextColor(14+blink); Write('D');
DoHelp;
WriteLn('Geben Sie die Farbe f<>r die ehemaligen Punkte an.');
WriteLn;
WriteLn('Die Zahl mu<6D> zwischen 0 und 255 liegen. 0 deaktiviert die Funktion.');
WriteLn('Um den alten Wert zu behalten, einfach [ENTER] dr<64>cken.');
WriteLn;
WriteLn('Beispiele:');
WriteLn;
ColTab;
HelpDone;
GotoXY(70,12); TextColor(15);
Setup_GetByte(TrailCol);
ClearHelp;
GotoXY(55,12); TextColor(10); Write('[ ]');
GotoXY(56,12); TextColor(14); Write('D');
GotoXY(70,12); Write(Space(5));
GotoXY(70,12);TextColor(15); Write(TrailCol:3,' '); TextColor(TrailCol); Write('<27>');
end;
procedure Setup_Algos(x,y: word;c: char;t: string;no: byte);
var key: char;
begin
GotoXY(x,y); TextColor(11+blink); Write('[ ]');
GotoXY(x+1,y); TextColor(14+blink); Write(c);
GotoXY(x+4,y); TextColor(15); Write(t);
GotoxY(x+2,y+1); WriteLet('1','Faktor:',11);
TextColor(15); Write(' ',fact_[no]);
GotoXY(x+2,y+2); WriteLet('2','Delay :',11);
TextColor(15); Write(' ',slow_[no]);
repeat
DoHelp;
WriteLn('Dr<44>cken Sie "1" oder "2" um den Faktor oder das Delay zu <20>ndern.');
WriteLn('"X", wenn Sie hier nichts <20>ndern wollen.');
WriteLn;
WriteLn('Faktor - ist die Beschleunigung, d.h. es wird nur noch jeder Xte');
WriteLn(' Zustand auf dem Bildschirm ausgegeben, was die');
WriteLn(' Bearbeitung und Visualisierung ungemein beschleunigt.');
WriteLn;
WriteLn('Delay - die Wartedauer zwischen zwei Ausgaben. Bei schnellen Algo-');
WriteLn(' rithmen sollte man ein Delay setzen, damit die Visuali-');
WriteLn(' sierung in einer vern<72>nftigen Geschwindigkeit abl<62>uft.');
HelpDone;
key := ReadKey;
case key of
'1': begin
GotoXY(x+2,y+1); TextColor(11+blink); Write('[ ]');
GotoXY(x+3,y+1); TextColor(14+blink); Write('1');
GotoXY(x+6,y+1); TextColor(15); Write('Faktor:');
GotoXY(x+14,y+1); TextColor(15);
DoHelp;
WriteLn('Der Faktor gibt an, wieviel Zust<73>nde w<>hrend der Visualisierung');
WriteLn('<27>bersprungen werden sollen. Es wird nur jeder Xte Zustand');
WriteLn('angezeigt. Die Zahl kann im Bereich von 1 bis 32767 liegen,');
WriteLn('aber man sollte sie nicht gr<67><72>er als etwa 100 w<>hlen, da sonst');
WriteLn('die Visualisierung etwas merkw<6B>rdig aussieht.');
WriteLn;
WriteLn('Um den Wert nicht zu <20>ndern, einfach [ENTER] dr<64>cken.');
HelpDone;
Setup_GetVal(fact_[no]);
if (fact_[no]<1) then fact_[no]:=1;
GotoXY(x+2,y+1); WriteLet('1','Faktor:',11);
TextColor(15);
GotoXY(x+14,y+1); Write(Space(10));
GotoXY(x+14,y+1); Write(fact_[no]);
end;
'2': begin
GotoXY(x+2,y+2); TextColor(11+blink); Write('[ ]');
GotoXY(x+3,y+2); TextColor(14+blink); Write('2');
GotoXY(x+6,y+2); TextColor(15); Write('Delay :');
GotoXY(x+14,y+2); TextColor(15);
DoHelp;
WriteLn('Das Delay gibt an, wieviel Millisekunden zwischen der Anzeige');
WriteLn('der einzelnen Zust<73>nde "gewartet" werden sollen. Die Zahl kann');
WriteLn('im Bereich von 0 bis 32767 liegen, sollte aber nie gr<67><72>er als');
WriteLn('ca. 500 (<28> Sekunde) gew<65>hlt werden, da man sonst Stunden vor');
WriteLn('dem Rechner sitzen kann, ohne gro<72> was zu sehen.');
WriteLn;
WriteLn('Um den Wert nicht zu <20>ndern, einfach [ENTER] dr<64>cken.');
HelpDone;
Setup_GetVal(slow_[no]);
GotoXY(x+2,y+2); WriteLet('2','Delay :',11);
TextColor(15);
GotoXY(x+14,y+2); Write(Space(10));
GotoXY(x+14,y+2); Write(slow_[no]);
end;
end;
until (key IN ['x','X']);
ClearHelp;
GotoXY(x,y); WriteLet(c,t,11);
TextColor(8);
GotoXY(x+2,y+1); Write(' Faktor:');
GotoXY(x+2,y+2); Write(' Delay :');
GotoXY(x+14,y+1); Write(Space(10));
GotoXY(x+14,y+1); Write(fact_[no]);
GotoXY(x+14,y+2); Write(Space(10));
GotoXY(x+14,y+2); Write(slow_[no]);
end;
procedure Setup_SimpleSN;
var key: char;
begin
Setup_Algos(5,15,'E','einfachstes Sort (normal)',1);
end;
procedure Setup_SimpleSQ;
begin
Setup_Algos(45,15,'F','einfachstes Sort (quick)',11);
end;
procedure Setup_SelectionS;
begin
Setup_Algos(5,19,'G','Selectionsort',2);
end;
procedure Setup_BubbleS;
begin
Setup_Algos(45,19,'H','Bubblesort',3);
end;
procedure Setup_QuickS;
begin
Setup_Algos(5,23,'I','Quicksort',4);
end;
procedure Setup_SaveVals;
var f: text;
begin
Assign(f,DataFile);
{$I-}
Rewrite(f);
if IOResult<>0 then begin
TextMode(co80);
WriteLn('Fehler beim Schreiben der INI-Datei ... haben Sie genug Rechte?');
WriteLn('Ist die Datei VISUAL2.INI nicht schreibgesch<63>tzt? Ist genug Platz');
WriteLn('vorhanden?');
WriteLn;
Halt;
end;
{$I+}
WriteLn(f,BGIPath);
WriteLn(f,pretime:0);
WriteLn(f,DotCol:0);
WriteLn(f,TrailCol:0);
WriteLn(f,fact_[1]:0);
WriteLn(f,slow_[1]:0);
WriteLn(f,fact_[11]:0);
WriteLn(f,slow_[11]:0);
WriteLn(f,fact_[2]:0);
WriteLn(f,slow_[2]:0);
WriteLn(f,fact_[3]:0);
WriteLn(f,slow_[3]:0);
WriteLn(f,fact_[4]:0);
WriteLn(f,slow_[4]:0);
WriteLn(f,ArrayType:0);
WriteLn(f,'');
WriteLn(f,'INI-Datei f<>r VISUAL2.EXE (bzw. VISUAL2.PAS)');
WriteLn(f,'');
WriteLn(f,' Copyright (c)1999 by Markus Birth <mbirth@webwriters.de>');
WriteLn(f,'');
WriteLn(f,' 1. Zeile: BGI-Path');
WriteLn(f,' 2. Zeile: Pre-Delay vor Grafikanzeige');
WriteLn(f,' 3. Zeile: Punktfarbe');
WriteLn(f,' 4. Zeile: Spurfarbe');
WriteLn(f,' 5. Zeile: einfachstes Sort (normal): -Faktor');
WriteLn(f,' 6. -Delay');
WriteLn(f,' 7. Zeile: einfachstes Sort (quick): -Faktor');
WriteLn(f,' 8. -Delay');
WriteLn(f,' 9. Zeile: Selectionsort: -Faktor');
WriteLn(f,'10. -Delay');
WriteLn(f,'11. Zeile: Bubblesort: -Faktor');
WriteLn(f,'12. -Delay');
WriteLn(f,'13. Zeile: Quicksort: -Faktor');
WriteLn(f,'14. -Delay');
WriteLn(f,'15. Zeile: Arraytype (0-Random, 1-aufsteigend, 2-absteigend)');
Close(f);
AckBeep;
end;
procedure Setup_Abort;
begin
BGIPath := oBGIPath;
pretime := opretime;
slow_ := oslow_;
fact_ := ofact_;
DotCol := oDotCol;
TrailCol := oTrailCol;
ArrayType:= oArrayType;
end;
procedure Setup_SavePre;
begin
oBGIPath := BGIPath;
opretime := pretime;
oslow_ := slow_;
ofact_ := fact_;
oDotCol := DotCol;
oTrailCol := TrailCol;
oArrayType:= ArrayType;
end;
procedure Setup;
var sel: char;
begin
Setup_SavePre;
DrawBorder2(2,5,78,49,15,2);
GotoXY(1,7);
FXWriteC('Voreinstellungen <20>ndern',15);
OutSetup;
repeat
sel := ReadKey;
if NOT Setup_KeyValid(sel) then begin
Sound(400);
Delay(100);
NoSound;
end else begin
Sound(1200);
Delay(50);
NoSound;
end;
case sel of
'a','A': Setup_BGIpath;
'b','B': Setup_PreDelay;
'c','C': Setup_DotCol;
'd','D': Setup_TrailCol;
'e','E': Setup_SimpleSN;
'f','F': Setup_SimpleSQ;
'g','G': Setup_SelectionS;
'h','H': Setup_BubbleS;
'i','I': Setup_QuickS;
's','S': Setup_SaveVals;
'x','X': Setup_Abort;
end;
until (sel IN ['o','O','x','X','s','S']);
end;
begin
ReadIni;
repeat
sel := Menu;
abo := false;
case sel of
1: Doit(1);
2: Doit(11);
3: Doit(2);
4: Doit(3);
5: Doit(4);
128: Setup;
end;
until (sel=0);
Outit;
end.

5
ITG/WAHLEN.PAS Normal file
View File

@ -0,0 +1,5 @@
uses Crt;const S:array[1..3,1..4] of word=((825,999,637,723),(436,638,345,451),(652,821,504,633));var B:array[1..3] of word;
P:array[1..4] of word;procedure A;var i,j:byte;begin for i:=1 to 3 do for j:=1 to 4 do begin P[j]:=P[j]+S[i,j];
B[i]:=B[i]+S[i,j];end;end;procedure C;var i,j:byte;begin WriteLn('<=========*=========>');Write(' ');
WriteLn('ROT BLAU GELB GR<47>N ====');for i:=1 to 3 do begin Write('Bezirk ',i,' ');for j:=1 to 4 do Write(S[i,j]:4,' ');
WriteLn(B[i]:4);end;Write('======== ');for i:=1 to 4 do Write(P[i]:4,' ');WriteLn;end;begin A;C;ReadKey;end.

63
ITG/WASSRTMP.PAS Normal file
View File

@ -0,0 +1,63 @@
program Wassertemp;
uses Crt;
const un='<27>C';
var l: real;
T1,T2,Tw: real;
procedure CalcTemp(l,T1,T2,Tw: real);
var x: real;
begin
if ((Tw>T1) AND (Tw>T2)) then begin
TextColor(12);
WriteLn('Du Idiot! Hast Du ''ne Mikrowelle neben Deiner Badewanne?');
WriteLn('Das Wasser kann doch nicht w<>rmer werden, wie die max. Temp!');
Exit;
end;
if ((Tw<T1) AND (Tw<T2)) then begin
TextColor(12);
WriteLn('Du Arsch! Hast Du etwa Deinen K<>hlschrank in der Badewanne?');
WriteLn('Das Wasser kann doch nicht k<>lter als die k<>lteste Temp. werden!');
Exit;
end;
x := ((Tw-T2)*l)/(T1-T2);
WriteLn('Daf<61>r brauchst Du ',x:0:2,'l Wasser mit einer Temperatur von ',T1:0:2,un,' und');
WriteLn(l-x:0:2,'l Wasser mit einer Temperatur von ',T2:0:2,un,' und fertig ist die');
WriteLn('gew<65>nschte Mixtur.');
end;
begin
ClrScr;
TextColor(15);
WriteLn('-=+ MBUWTBPADIU +=-'); { Markus Birth's ultimatives WasserTemperatur }
WriteLn; { Berechnungs Programm Aus Dem InformatikUnterricht }
TextColor(7);
Write('Wieviel Liter sollen rein? ');
ReadLn(l);
Write('Was f<>r ''ne Temperatur hat die erste Wasserquelle (in ',un,')? ');
ReadLn(T1);
Write('Und die zweite, h<>h? ');
ReadLn(T2);
WriteLn;
Write('Und wie warm soll es denn jetzt werden (in ',un,')? ');
ReadLn(Tw);
WriteLn;
WriteLn('Na, dann wollen wir mal schau''n ...');
Delay(500);
Write('*knatter* ');
Delay(500);
Write('*ratter* ');
Delay(500);
Write('*klapper* ');
Delay(500);
WriteLn('*pling*');
WriteLn;
CalcTemp(l,T1,T2,Tw);
TextColor(7);
WriteLn;
WriteLn('Fertich, Meista! Nu'' dr<64>ck'' mal auf ''ne Taste!!');
ReadKey;
end.

55
ITG/WEEKDAY.PAS Normal file
View File

@ -0,0 +1,55 @@
program DayOfYear;
uses Crt;
var d,m,y,h,Rest,WD: integer;
procedure GetDate;
begin
Write('Tag : '); ReadLn(d);
Write('Monat : '); ReadLn(m);
Write('Jahr (4stellig): '); ReadLn(y);
end;
procedure CalcWD;
begin
if (m=1) OR (m=2) then begin
Inc(m,12);
Dec(y);
end;
h := y DIV 100;
Rest := y MOD 100;
WriteLn('h',h,' Rest',Rest);
WD := (d+(m+1)*26 DIV 10+5*Rest DIV 4+h DIV 4-2*h-1) MOD 7;
end;
procedure OutWD1;
begin
Write('OutWD1: Das war ein ');
case WD of
0: Write('Sonntag');
1: Write('Montag');
2: Write('Dienstag');
3: Write('Mittwoch');
4: Write('Donnerstag');
5: Write('Freitag');
6: Write('Samstag');
end;
WriteLn('. [',WD,']');
end;
procedure OutWD2;
const Days:array[0..6] of string=('Sonntag','Montag','Dienstag','Mittwoch',
'Donnerstag','Freitag','Samstag');
begin
Write('OutWD2: Das war ein ',Days[WD],'. [',WD,']');
end;
begin
ClrScr;
WriteLn('Problemzonen: 19.5.2000');
GetDate;
CalcWD;
OutWD1;
OutWD2;
end.

178
ITG/WEIHNACH.PAS Normal file
View File

@ -0,0 +1,178 @@
program Froehliche_Weihnacht;
uses Crt, Graph, BGIP;
const pdel=10;
bdel=100;
bdis=20;
var xmax, ymax: word;
oy: integer;
procedure InitGraphics;
var grDriver, grMode : integer;
begin
grDriver := VGA;
grMode := VGAhi;
InitGraph(grDriver,grMode,BGIPath);
xmax := GetMaxX+1; { Bildschirmbreite in Pixeln }
ymax := GetMaxY+1; { Bildschirmh<6D>he in Pixeln }
end;
procedure OutitGraphics;
begin
TextMode(CO80);
WriteLn('Programm beendet.');
end;
procedure DrawStaffs;
begin
SetLineStyle(SolidLn, 0, NormWidth);
SetColor(8);
Rectangle(10,100,15,400);
SetColor(6);
Rectangle(11,101,14,399);
Rectangle(12,101,13,399);
SetColor(8);
Rectangle(625,100,630,400);
SetColor(6);
Rectangle(626,101,629,399);
Rectangle(627,101,628,399);
end;
function y(x: integer): integer;
const fac=0.001;
xcen=320;
ypos=195;
var ot: string;
t: integer;
begin
t := Round(-fac*(x-xcen)*(x-xcen)+ypos);
{ if Abs(t-oy)>3 then begin
Str(x,ot);
OutText(ot+';');
Str(t,ot);
OutText(ot);
end;
oy := t; }
y := t;
end;
procedure DrawLine;
var i: integer;
begin
MoveTo(13,y(13));
SetColor(8);
for i:=13 to 627 do begin
LineTo(i,y(i));
end;
end;
procedure BlowTorch(i: word;col: byte);
const fcol=7; { Farbe der Lampenfassung }
pcol=15; { Farbe des Kontakts }
gcol=8; { Farbe des Glas }
var j: integer;
begin
{ Just a 3x3 rectangle }
{ PutPixel(i-1,y(i)-1,col);
PutPixel(i-1,y(i),col);
PutPixel(i-1,y(i)+1,col);
PutPixel(i,y(i)-1,col);
PutPixel(i,y(i),col);
PutPixel(i,y(i)+1,col);
PutPixel(i+1,y(i)-1,col);
PutPixel(i+1,y(i),col);
PutPixel(i+1,y(i)+1,col); }
{ A nice lamp }
PutPixel(i,y(i)-2,pcol); { Kontakt }
for j:=-1 to 1 do PutPixel(i-1,y(i)+j,fcol); { Sockel }
for j:=-1 to 1 do PutPixel(i,y(i)+j,fcol);
for j:=-1 to 1 do PutPixel(i+1,y(i)+j,fcol);
PutPixel(i-2,y(i)+2,gcol); { Lampe }
PutPixel(i+2,y(i)+2,gcol);
PutPixel(i-2,y(i)+6,gcol);
PutPixel(i+2,y(i)+6,gcol);
for j:=3 to 5 do PutPixel(i-3,y(i)+j,gcol);
for j:=3 to 5 do PutPixel(i+3,y(i)+j,gcol);
for j:=-1 to 1 do PutPixel(i+j,y(i)+7,gcol);
for j:=3 to 5 do PutPixel(i-2,y(i)+j,col); { Licht }
for j:=2 to 6 do PutPixel(i-1,y(i)+j,col);
for j:=2 to 6 do PutPixel(i,y(i)+j,col);
for j:=2 to 6 do PutPixel(i+1,y(i)+j,col);
for j:=3 to 5 do PutPixel(i+2,y(i)+j,col);
end;
procedure AnimateTorches_LineBlink;
var i: integer;
begin
Randomize;
for i:=13 to 627 do begin
if i/bdis=Int(i/bdis) then begin
BlowTorch(i,0);
end;
end;
repeat
for i:=13 to 627 do begin
if i/bdis=Int(i/bdis) then begin
BlowTorch(i,Random(16));
Delay(pdel);
end;
end;
Delay(bdel);
until keypressed;
ReadKey;
end;
procedure AnimateTorches_RandomBlink;
var i: integer;
begin
Randomize;
for i:=13 to 627 do begin
if i/bdis=Int(i/bdis) then begin
BlowTorch(i,0);
end;
end;
repeat
i := (Random(630 DIV bdis))*bdis+20;
BlowTorch(i,Random(16));
Delay(pdel);
until keypressed;
ReadKey;
end;
procedure AnimateTorches_ShiftBlink;
const maxt=630 DIV bdis-1;
var i: integer;
lc: array[0..maxt] of byte;
begin
Randomize;
for i:=13 to 627 do begin
if i/bdis=Int(i/bdis) then begin
BlowTorch(i,0);
end;
end;
repeat
for i:=maxt downto 1 do lc[i]:=lc[i-1];
lc[0] := Random(16);
for i:=0 to maxt do begin
BlowTorch(i*bdis+20,lc[i]);
end;
Delay(bdel);
until keypressed;
ReadKey;
end;
begin
InitGraphics;
DrawStaffs;
DrawLine;
AnimateTorches_ShiftBlink;
OutitGraphics;
end.

333
ITG/rekGui.pas Normal file
View File

@ -0,0 +1,333 @@
program RekGUI;
uses Crt, Graph, DOS, GUI, RekGraph, BGIP;
const desktopcolor=3;
skier_len: integer=120;
skier_edge: integer=10;
skier_globangle: integer=0;
skier_fixedinit: boolean=true;
haken_len: integer=150;
haken_angle: integer=45;
haken_globangle: integer=0;
haken_fixedinit: boolean=true;
quadrat_len: integer=150;
quadrat_angle: integer=90;
quadrat_globangle: integer=0;
quadrat_fixedinit: boolean=true;
spirale_len: integer=10;
spirale_angle: integer=25;
spirale_globangle: integer=0;
spirale_fixedinit: boolean=true;
var xmax, ymax, xmed, ymed: word;
ExitAll, ExitSetupAll: boolean;
procedure Init;
var grDriver, grMode: integer;
begin
grDriver := VGA;
grMode := VGAHi;
initp_del := 30;
InitGraph(grDriver, grMode, BGIPath);
xmax := GetMaxX+1; { Bildschirmbreite in Pixeln }
ymax := GetMaxY+1; { Bildschirmh<6D>he in Pixeln }
xmed := xmax DIV 2;
ymed := ymax DIV 2;
om := 0;
ExitAll := false;
ExitSetupAll := false;
SetTextStyle(DefaultFont,HorizDir,1);
SetTextJustify(LeftText,TopText);
SetFillStyle(SolidFill,desktopcolor);
Bar(0,0,xmax-1,ymax-1);
ClearStatus;
end;
procedure InitGraphs;
begin
skier_del := 50;
haken_del := 50;
quadrat_del := 100;
spirale_del := 50;
end;
procedure Outit;
begin
TextMode(CO80);
WriteLn('VMode : ',xmax,'x',ymax);
WriteLn('Center: ',xmed,'x',ymed);
WriteLn;
WriteLn('Programm beendet.');
end;
function V2S(x: byte): string;
var tmp: string;
begin
Str(x:3,tmp);
V2S := tmp;
end;
procedure ShowSkier;
begin
globangle := skier_globangle;
SetViewPort(13,31,497,397,ClipOn);
MoveTo(180,370);
Skier(skier_len,skier_edge);
SetViewPort(0,0,639,479,ClipOff);
end;
procedure ShowHaken;
begin
globangle := haken_globangle;
SetViewPort(13,31,497,397,ClipOn);
MoveTo(240,180);
Haken(haken_len,haken_angle);
SetViewPort(0,0,639,479,ClipOff);
end;
procedure ShowQuadrat;
begin
globangle := haken_globangle;
SetViewPort(13,31,497,397,ClipOn);
MoveTo(240,180);
Quadrat(quadrat_len,quadrat_angle);
SetViewPort(0,0,639,479,ClipOff);
end;
procedure ShowSpirale;
begin
globangle := spirale_globangle;
SetViewPort(13,31,497,397,ClipOn);
MoveTo(240,180);
Spirale(spirale_len,spirale_angle);
SetViewPort(0,0,639,479,ClipOff);
end;
procedure Palette;
const tx=50;
ty=31;
var i,j: integer;
begin
for j:=1 to 16 do begin
SetTextJustify(RightText,CenterText);
SetColor(0);
OutTextXY(tx,ty+(j-1)*10+5,V2S((j-1)*16));
for i:=0 to 15 do begin
SetFillStyle(SolidFill,(j-1)*16+i);
SetColor((j-1)*15+i);
Bar(tx+i*10,ty+(j-1)*10,tx+i*10+10,ty+(j-1)*10+10);
end;
SetTextJustify(LeftText,CenterText);
SetColor(0);
OutTextXY(tx+162,ty+(j-1)*10+5,V2S((j-1)*16+15));
end;
end;
procedure CheckSetupStat;
begin
if (mb<>0) then ShowMouse(false);
if MouseOver(15,405,525,425) then begin
Status('Hiermit wird die Konfiguration so gespeichert');
case mb of
1: begin
ExitSetupAll := true;
end;
end;
end else if MouseOver(527,405,625,425) then begin
Status('Hier geht''s nach Hause!');
case mb of
1: begin
MakeBeveledButton(527,405,625,425,'EXIT');
ExitSetupAll:=true;
ExitAll:=true;
Delay(buttondelay);
MakeButton(527,405,625,425,'EXIT');
Exit;
end;
end;
end else if (oldstat<>'') then begin
ClearStatus;
oldstat:='';
end;
if (mb<>0) then ShowMouse(true);
end;
procedure SetupData;
var sx,sy,sb: integer;
begin
MakeWindow(10,10,630,430,'Konfiguration');
MakeButton(15,405,525,425,'Einstellungen so <20>bernehmen');
MakeButton(527,405,625,425,'EXIT');
ShowMouse(true);
repeat
MouseStat(mx,my,mb);
CheckSetupStat;
StatusTime(false);
until (mb=3) OR (ExitSetupAll);
if (mb=3) then ExitAll := true;
ShowMouse(false);
end;
procedure BuildWindows;
begin
MakeWindow(10,10,500,400,'Hauptfenster');
MakeWindow(505,10,600,400,'Optionen');
MakeButton(510,385,595,395,'EXIT');
MakeButton(510,373,595,383,'CLEAR');
MakeButton(510,34,595,54,'Skierp.');
MakeButton(510,56,595,76,'Haken');
MakeButton(510,78,595,98,'Quadrat');
MakeButton(510,100,595,120,'Spirale');
MakeButton(510,350,595,371,'SETUP');
end;
procedure CheckStat;
begin
if (mb<>0) then ShowMouse(false);
if MouseOver(510,385,595,395) then begin
Status('Hier geht''s nach Hause!');
case mb of
1: begin
MakeBeveledButton(510,385,595,395,'EXIT');
ExitAll:=true;
Delay(buttondelay);
MakeButton(510,385,595,395,'EXIT');
Exit;
end;
end;
end else if MouseOver(510,373,595,383) then begin
Status('Damit wird das Hauptfenster gel<65>scht!');
case mb of
1: begin
MakeBeveledButton(510,373,595,383,'CLEAR');
SetFillStyle(SolidFill,7);
Bar(13,31,497,397);
Delay(buttondelay);
MakeButton(510,373,595,383,'CLEAR');
end;
end;
end else if MouseOver(510,350,595,371) then begin
Status('Hier kann man die Einstellungen <20>ndern!');
case mb of
1: begin
MakeBeveledButton(510,350,595,371,'SETUP');
SetFillStyle(SolidFill,desktopcolor);
Bar(10,10,500,400);
Delay(buttondelay DIV 2);
Bar(505,10,600,400);
Delay(buttondelay DIV 2);
ExitSetupAll := false;
SetupData;
if NOT ExitAll then begin
SetFillStyle(SolidFill,desktopcolor);
Bar(10,10,630,430);
BuildWindows;
end;
end;
end;
end else if MouseOver(510,34,595,54) then begin
Status('F<>r unsere Wintersportler!');
case mb of
1: begin
MakeBeveledButton(510,34,595,54,'Skierp.');
ShowSkier;
Delay(buttondelay);
MakeButton(510,34,595,54,'Skierp.');
end;
end;
end else if MouseOver(510,56,595,76) then begin
Status('Und das ist f<>r die Angler!');
case mb of
1: begin
MakeBeveledButton(510,56,595,76,'Haken');
ShowHaken;
Delay(buttondelay);
MakeButton(510,56,595,76,'Haken');
end;
end;
end else if MouseOver(510,78,595,98) then begin
Status('Sehen Sie schon viereckig?');
case mb of
1: begin
MakeBeveledButton(510,78,595,98,'Quadrat');
ShowQuadrat;
Delay(buttondelay);
MakeButton(510,78,595,98,'Quadrat');
end;
end;
end else if MouseOver(510,100,595,120) then begin
Status('Ist was verstopft?');
case mb of
1: begin
MakeBeveledButton(510,100,595,120,'Spirale');
ShowSpirale;
Delay(buttondelay);
MakeButton(510,100,595,120,'Spirale');
end;
end;
end else if (oldstat<>'') then begin
ClearStatus;
oldstat:='';
end;
if (mb<>0) then ShowMouse(true);
end;
procedure StartScreen;
begin
MakeWindow(120,140,520,340,'Rekursive Grafikfunktionen');
SetViewPort(123,161,517,337,ClipOn);
SetColor(9);
SetTextStyle(TripleXFont,HorizDir,10);
SetTextJustify(CenterText,CenterText);
OutTextXY(200,24,'GUI');
OutTextXY(200,26,'GUI');
OutTextXY(199,25,'GUI');
OutTextXY(201,25,'GUI');
SetTextStyle(SansSerifFont,HorizDir,2);
OutTextXY(200,100,'GRAPHICAL USER INTERFACE');
SetColor(0);
SetTextStyle(SmallFont,HorizDir,5);
OutTextXY(200,165,'geschrieben von Markus Birth <mbirth@webwriters.de>');
SetTextStyle(SmallFont,VertDir,4);
SetTextJustify(CenterText,TopText);
SetColor(8);
OutTextXY(385,2,'(c)1999 Web - Writers');
SetColor(0);
SetTextStyle(DefaultFont,HorizDir,1);
OutTextXY(200,140,'Initialisiere Farbpalette ...');
Delay(1000);
InitPalette;
SetFillStyle(SolidFill,7);
Bar(0,130,400,150);
SetTextStyle(DefaultFont,HorizDir,1);
SetViewPort(0,0,639,479,ClipOff);
Status('Bitte dr<64>cken Sie irgendeine Taste (Maus oder Tastatur)');
ShowMouse(true);
repeat
MouseStat(mx,my,mb);
StatusTime(false);
until (keypressed) OR (mb<>0);
if keypressed then ReadKey;
ShowMouse(false);
SetFillStyle(SolidFill,desktopcolor);
Bar(120,140,520,340);
end;
begin
Init;
InitGraphs;
StartScreen;
BuildWindows;
MouseReset;
ShowMouse(true);
repeat
MouseStat(mx,my,mb);
CheckStat;
StatusTime(false);
until (mb=3) OR (ExitAll);
ShowMouse(false);
FadeOut;
Outit;
end.