|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 7168 (0x1c00)
Types: TextFile
Names: »RING.PAS«
└─⟦08ea08c61⟧ Bits:30003924 PolyPascal programmer
└─ ⟦this⟧ »RING.PAS«
└─⟦09235ab48⟧ Bits:30003065 Demoprogrammer K-Z til Pascal bog
└─ ⟦this⟧ »RING.PAS«
└─⟦092727b26⟧ Bits:30005927 Demoprogrammer til Pascal bog (Jet-80)
└─ ⟦this⟧ »RING.PAS«
PROGRAM ring;
TYPE
str40 = STRING(.40.);
link = ^ post;
post = RECORD
frem, tilbage : link;
navn : str40;
END;
VAR
top, pp, ud : link;
ch : CHAR;
PROCEDURE indsaet(VAR foerste : link; nypost : link);
VAR
ch : CHAR;
start : link;
BEGIN (* indsaet *)
start := foerste;
IF foerste = NIL (* kæden er tom *)
THEN
BEGIN
foerste := nypost;
foerste^.frem := foerste;
foerste^.tilbage := foerste;
END
ELSE IF nypost^.navn <= foerste^.navn (* før første post *)
THEN
BEGIN
nypost^.frem :=foerste;
nypost^.tilbage :=foerste^.tilbage;
foerste^.tilbage^.frem := nypost;
foerste^.tilbage := nypost;
foerste :=nypost;
END
ELSE (* søg frem til rigtig plads til nypost *)
BEGIN
WHILE (nypost^.navn > foerste^.navn) AND
(foerste^.frem <> start) DO
foerste := foerste^.frem;
IF (foerste^.frem <> start) OR
(nypost^.navn <= foerste^.navn)
THEN (* indsæt før foerste *)
BEGIN
nypost^.frem := foerste;
nypost^.tilbage := foerste^.tilbage;
foerste^.tilbage^.frem := nypost;
foerste^.tilbage := nypost;
foerste := start;
END
ELSE (* indsæt efter foerste *)
BEGIN
nypost^.frem := foerste^.frem;
nypost^.tilbage := foerste;
foerste^.frem^.tilbage := nypost;
foerste^.frem := nypost;
foerste := start;
END;
END;
WRITELN;
WRITE(nypost^.navn, ' er nu indsat i kæden. Tast <RETURN> ');
READLN(ch);
END; (* indsaet *)
PROCEDURE fjern(VAR foerste : link; glpost : link);
VAR
fundet : BOOLEAN;
ch : CHAR;
start : link;
BEGIN (* fjern *)
start := foerste;
IF foerste = NIL (* kæden tom *)
THEN fundet := FALSE
ELSE
BEGIN
WHILE (glpost^.navn > foerste^.navn) AND
(foerste^.frem <> start) DO
foerste := foerste^.frem;
IF glpost^.navn = foerste^.navn
THEN
BEGIN
fundet := TRUE;
IF start^.frem = start
THEN foerste := NIL
ELSE
BEGIN
IF foerste = start
THEN start := start^.frem;
foerste^.tilbage^.frem := foerste^.frem;
foerste^.frem^.tilbage := foerste^.tilbage;
foerste := start;
END;
END
ELSE fundet := FALSE;
END;
IF fundet
THEN WRITELN(glpost^.navn, ' er slettet fra kæden')
ELSE
BEGIN
WRITELN(glpost^.navn, ' findes ikke i kæden');
foerste := start;
END;
WRITE('Tast <RETURN>: ');
READLN(ch);
END; (* fjern *)
PROCEDURE frem(foerste : link);
VAR
pp : link;
ch : CHAR;
BEGIN (* frem *)
pp := foerste;
WRITELN;
WRITELN('Kæden indeholder følgende personer:');
WRITELN;
IF foerste <> NIL
THEN
REPEAT
WRITELN(pp^.navn);
WRITELN;
pp := pp^.frem;
UNTIL pp = foerste;
WRITE('Tast <RETURN>: ');
READLN(ch);
END; (* frem *)
PROCEDURE tilbage(foerste : link);
VAR
pp : link;
ch : CHAR;
BEGIN (* tilbage *)
WRITELN;
WRITELN('Kæden indeholder følgende personer:');
WRITELN;
IF foerste <> NIL
THEN
BEGIN
foerste := foerste^.tilbage;
pp := foerste;
REPEAT
WRITELN(pp^.navn);
WRITELN;
pp := pp^.tilbage;
UNTIL pp = foerste;
END;
WRITE('Tast <RETURN>: ');
READLN(ch);
END; (* tilbage *)
BEGIN (* ring *)
top := NIL;
REPEAT
WRITE(CLRHOM);
GOTOXY(10,1); WRITE('SORTERET DOBBELT-RING');
GOTOXY(10,4); WRITE('I. Indsæt person i kæden.');
GOTOXY(10,6); WRITE('F. Fjerne person fra kæden.');
GOTOXY(10,8); WRITE('U. Udskrive kæden.');
GOTOXY(10,10); WRITE('B. Udskrive kæden bagfra.');
GOTOXY(10,12); WRITE('A. Afslutte programmet.');
GOTOXY(10,14); WRITE('Tast kommando: ');
REPEAT
READ(KBD, ch);
UNTIL ch IN (.'I', 'i', 'F', 'f', 'U', 'u', 'B', 'b',
'A', 'a'.);
WRITELN(ch);
CASE ch OF
'I', 'i' : BEGIN
NEW(pp);
WRITELN;
WRITE('Navn: '); READLN(pp^.navn);
pp^.frem := NIL;
pp^.tilbage := NIL;
indsaet(top, pp);
END;
'F', 'f' : BEGIN
WRITELN;
WRITE('Hvem skal fjernes: ');
READLN(ud^.navn);
fjern(top, ud);
END;
'U', 'u' : frem(top);
'B', 'b' : tilbage(top);
END;
UNTIL ch IN (.'A', 'a'.);
END. (* ring *)
«eof»