Írjunk karakteres képernyőn egyszerű eszközökkel megjelenő, egyenrangú útkereszteződés forgalmát szimuláló, programot. A négy irányból érkező forgalmat egy-egy láncolt listában rögzítsük. Ha a programot megállítjuk, akkor az aktuális forgalmi helyzetet mentse lemezre, a következő indításkor erről a forgalmi helyzetről induljon a program. A járműveket a haladási irányba mutató háromszög szemléltesse, az autók legyenek véletlen színűek, járművek megjelenését mi idézzük elő, a megfelelő irányba mutató nyíl megnyomásával. Az áthaladásnál a járművek tartsák be a KRESZ előírásait. Az útkereszteződés elhagyása után a járművek mozgását már nem kell szemléltetni.

A program egy futási képe:

A program listája:

Program XRoad;              

Uses NewDelay, Crt, CrtPlus;
Const LSzM=4;
      O1  =39;
      S2  =12;
      O3  =42;
      S4  =14;
      RV  =500;
      HV  =2000;

Type
RecMut= ^Rec;
Rec   = Record
Ch  : Char;
Szin: Byte;
KMut: RecMut;
End;

KepHely= Record
                Kar,
Atr: Byte;
End;
Scr    = Array[1..25,1..80] Of KepHely;

Var
ARec  : Rec;
URecM,
ARecM : RecMut;

KocsiT: Array[1..LSzM] Of RecMut; 
FNev  : File Of Rec;
DNev  : String; 
Kep   : Scr Absolute $B800:0;

Procedure Felfuz(URecM:RecMut);
Var Szel:Byte; 
Begin
Case URecM^.Ch Of
    #31:Szel:=1;
    #17:Szel:=2;
    #30:Szel:=3;
    #16:Szel:=4;
End;
If KocsiT[Szel]=Nil Then
KocsiT[Szel]:=URecM
Else
Begin
ARecM:=KocsiT[Szel]; 
While ARecM^.KMut<>Nil Do
ARecM:=ARecM^.KMut; 
ARecM^.KMut:=URecM; 
End; 
End;

Procedure Lemezrol; 
Begin
Assign(FNev,DNev);{$I-}Reset(FNev);{$I+}
If IOResult=0 Then
While Not EOF(FNev) Do
Begin
Read(FNev,ARec); 
URecM:=New(RecMut); 
With URecM^ Do
Begin
Ch  := ARec.Ch; 
Szin:= ARec.Szin; 
KMut:= Nil; 
End;
Felfuz(URecM); 
End
Else
ReWrite(FNev);
Close(FNev); 
End;

Procedure Lemezre; 
Var I:Byte; 
Begin
Assign(FNev,DNev);ReWrite(FNev); 
For I:=1 To LSzM Do
Begin
ARecM:=KocsiT[I];
While ARecM<>Nil Do
Begin
With ARec Do
Begin
Ch  :=ARecM^.Ch; 
Szin:=ARecM^.Szin;
KMut:=Nil; 
End;
Write(FNev,ARec); 
ARecM:=ARecM^.KMut; 
End;
End;
Close(FNev); 
End;

Procedure Kepernyo; 
Begin
Szinek(Black,LightGray);
ClrScr;

Szinek(LightGray,Black); 
Window(10,3,71,23);
ClrScr;

GoToXY(25,1);
Write('Útkereszteződés');

GoToXY(10,21);
Write('Autó megjelenése: Nyilakkal  Kilépés: ESC');

Szinek(Green,Black);
Window(12,4,37,11); 

ClrScr;

Window(44,4,69,11); 

ClrScr;

Window(12,15,37,22); 

ClrScr;

Window(44,15,69,22); 
ClrScr;

Window(1,1,80,25); 

Kep[25,1].Atr:=0;
Tunj;
End;

Procedure Kepre;
Var I, 

H, 
    S :Longint; 
Begin
For I:= 4 To 11 Do Kep[I,O1].Kar:=32; 
For I:=44 To 69 Do Kep[S2,I].Kar:=32;
For I:=15 To 22 Do Kep[I,O3].Kar:=32;
For I:=10 To 37 Do Kep[S4,I].Kar:=32;

For I:=1 To LSzM do
Begin
    S:=0; 
ARecM:=KocsiT[I]; 
While ARecM<>Nil Do
With ARecM^ Do
Begin
Case I Of
        1:Begin
            H:=11-S;
If H>3 Then
Begin
Kep[H,O1].Kar:=31;
Kep[H,O1].Atr:=Szin
End;
End;
        2:Begin
            H:=44+2*S; 
If H<70 Then
Begin
Kep[S2,H].Kar:=17;
Kep[S2,H].Atr:=Szin
End;
End;
        3:Begin
            H:=15+S;
If H<23 Then
Begin
Kep[H,O3].Kar:=30;
Kep[H,O3].Atr:=Szin
End;
End;
        4:Begin
            H:=37-2*S;
If H>11 Then
Begin
Kep[S4,H].Kar:=16;
Kep[S4,H].Atr:=Szin
End;
End;
End;
ARecM:=ARecM^.KMut; 
      Inc(S); 
End;
End;
End;

Procedure Levesz(N:Byte); 
Var I: Byte; 
Begin
If KocsiT[N]=Nil Then Exit; 
KocsiT[N]:=KocsiT[N]^.KMut; 
Case N Of
    1:Begin
For I:=S2 To S4 Do
Begin
Kep[I,O1]:=Kep[I-1,O1]; 
Kep[I-1,O1].Kar:=32; 
Delay(RV); 
End;
Kep[I,O1].Kar:=32; 
End;
    2:Begin
For I:=O3+1 DownTo O1-1 Do
Begin
Kep[S2,I]:=Kep[S2,I+1];
Kep[S2,I+1].Kar:=32;
Delay(RV);
End;
Kep[S2,I].Kar:=32;
End;
    3:Begin
For I:=S4 DownTo S2 Do
Begin
Kep[I,O3]:=Kep[I+1,O3];
Kep[I+1,O3].Kar:=32;
Delay(RV);
End;
Kep[I,O3].Kar:=32;
End;
    4:Begin
For I:=O1-1 To O3+1 Do
Begin
Kep[S4,I]:=Kep[S4,I-1];
Kep[S4,I-1].Kar:=32;
Delay(RV);
End;
Kep[S4,I].Kar:=32;
End;
End;
Kepre; 
End;

Function Valasztas:Byte; 
Var I, 
    M, 
    V: Byte;
    P:  Array[1..LSzM] Of Byte;
Begin
  M:=0;
For I:=1 To LSzM Do P[I]:=0;
For I:=1 To LSzM Do If KocsiT[i]<>Nil Then Inc(M);
Case M Of
LSzM: Valasztas:=Random(LSzM)+1; 
       0: Valasztas:=0; 
Else
Begin
If (KocsiT[1]<>Nil) And
(KocsiT[LSzM]=Nil) 
Then P[1]:=1;
For I:=2 To LSzM Do
If (KocsiT[I]<>Nil) And
        (KocsiT[I-1]=Nil) 
Then P[I]:=1; 
Repeat
          V:=Random(LSzM)+1;
Until P[V]=1; 
Valasztas:=V;
End;
End;
End;

Procedure Vezerlo;
Var Bill:Char;
Begin
Repeat
If Not KeyPressed Then
Begin
      Levesz(Valasztas);
Delay(HV)
End;
If KeyPressed Then Bill:=ReadKey;
If Bill=#27 Then Exit; 
If Bill=#0 Then
Begin
Bill:=ReadKey; 
If Bill In [#72,#75,#77,#80] Then
Begin
URecM:=New(RecMut);
With URecM^ Do
Begin
Case Bill Of
            #72: Ch:=#30;
            #75: Ch:=#17;
            #77: Ch:=#16;
            #80: Ch:=#31;
End;
Szin:=Random(16);
If Szin=7 Then Szin:=15;
Szin:=16*LightGray+Szin; 
KMut:=Nil;
End;
Felfuz(URecM);
Kepre;
Delay(RV);
End;
End;
Until False;
End;

Begin
DNev:='XRoad.Dat';
Lemezrol;
Kepernyo;
Kepre;
Randomize;
Vezerlo;
  Lemezre;
Szinek(Black,LightGray);

ClrScr;
End.