Crypto

{
Agung Fitriyanto 7644;
Firman Maulana 7666;
Tri Danarto 7806;
}

program kripto;
uses crt;
var kata1,kata2,kata3,sandi1,sandi2,terj1,terj2,bantu:string;
a,b,c:char;
i,j,k,l:integer;
jalan:boolean;

procedure caribinernya(var tempat:string;x:integer);
{Procedure untuk mengubah suatu nilai integer ke bilangan biner 8 digit
dengan format string (karena tidak ada format biner dalam pascal)untuk
kemudian dikodekan}
begin
if x>127 then begin tempat:=tempat+'1';x:=x-128 end else tempat:=tempat+'0';
if x>63 then begin tempat:=tempat+'1';x:=x-64 end else tempat:=tempat+'0';
if x>31 then begin tempat:=tempat+'1';x:=x-32 end else tempat:=tempat+'0';
if x>15 then begin tempat:=tempat+'1';x:=x-16 end else tempat:=tempat+'0';
if x>7 then begin tempat:=tempat+'1';x:=x-8 end else tempat:=tempat+'0';
if x>3 then begin tempat:=tempat+'1';x:=x-4 end else tempat:=tempat+'0';
if x>1 then begin tempat:=tempat+'1';x:=x-2 end else tempat:=tempat+'0';
if x=1 then begin tempat:=tempat+'1';x:=x-1 end else tempat:=tempat+'0';
end;

procedure cariintegernya(x:string;var y:integer);
{Procedure untuk mengubah suatu nilai biner (dalam variabel berbentuk string)
ke suatu nilai integernya dengan basis 10}
var anu:integer;
begin
y:=0;
if x[1]='1' then y:=y+128;
if x[2]='1' then y:=y+64;
if x[3]='1' then y:=y+32;
if x[4]='1' then y:=y+16;
if x[5]='1' then y:=y+8;
if x[6]='1' then y:=y+4;
if x[7]='1' then y:=y+2;
if x[8]='1' then y:=y+1;
end;

procedure acak(x:string;var y:string);
{Procedure untuk pengkodean dengan subsitusi}
begin
if x='000' then y:='010';
if x='001' then y:='011';
if x='010' then y:='100';
if x='011' then y:='101';
if x='100' then y:='110';
if x='101' then y:='111';
if x='110' then y:='000';
if x='111' then y:='001';
end;

procedure acak2(x:string;var y:string);
{Procedure untuk penerjemahan balik dari suatu kode}
begin
if x='000' then y:='110';
if x='001' then y:='111';
if x='010' then y:='000';
if x='011' then y:='001';
if x='100' then y:='010';
if x='101' then y:='011';
if x='110' then y:='100';
if x='111' then y:='101';
end;

begin
clrscr;
kata1:='';
while kata1='' do
begin
write(' Kata yang mau diacak = ');{Kata yang mau dikodekan}
readln(kata1);
end;

jalan:=true;
while jalan do
begin
a:=kata1[1];{ambil karakter terdepan}
i:=ord(a);{cari nilai ASCII-nya}
caribinernya(sandi1,i);{ubah ke bentuk biner 8 digit}
while length(sandi1)>=3 do {dipotong per-3 untuk dikodekan}
begin
terj1:=sandi1[1]+sandi1[2]+sandi1[3];{ambil 3 karakter terdepan}
acak(terj1,terj2);{pengkodean tiga karakter tadi}
sandi2:=sandi2+terj2; {hasil pengkodean disimpan di sandi2}
delete(sandi1,1,3);{tiga karakter terdepan yang sudah dikodekan dihapus}
end;

while length(sandi2)>=8 do {hasil pengkodean (sandi2) di terjemahkan ke
kode ASCII kembali per 8 digit (1 karakter)}
begin
bantu:='';
for j:=1 to 8 do bantu:=bantu+sandi2[j];{8 karakter terdepan diambil}
cariintegernya(bantu,k);{8 digit bilangan dicari nilai integernya}
kata2:=kata2+char(k);{hasil pengkodean di masukkan ke kata2}
delete(sandi2,1,8);{8 karakter yang sudah dikodekan dihapus}
end;
delete(kata1,1,1);{hapus karakter terdepan dari kata1}
if kata1='' then jalan:=false;{perulangan berhenti jika kata sudah habis}
end;

{Percabangan di bawah ini digunakan jika ternyata jumlah karakter yang
mau dikodekan bukan kelipatan 3 sehingga ada kekurangn digit pada
terjemahan per-3 digit}
if sandi1<>'' then {Sandi1 masih menyisakan karakter yang belum dikodekan}
begin
l:=0;
while length(sandi1)<3 do
begin
sandi1:=sandi1+'0';
l:=l+1;{l merupakan jumlah karakter yang ditambahkan agar genap 3 digit}
end;
terj1:=sandi1;sandi1:='';
acak(terj1,terj2);
sandi2:=sandi2+terj2;
if length(sandi2)>8 then delete(sandi2,9,l);{setelah dikodekan sandi2
dipotong sebanyak penambahannya}
cariintegernya(sandi2,k);
kata2:=kata2+char(k);
end;
writeln(' Kode yang dihasilkan = ',kata2); {Kode final}
readln;
{Untuk jumlah karakter kata1 yang tidak kelipatan 3 maka akan mengakibatkan
sandi1 sebagai variabel penyimpan bilangan-bilangan biner yang akan dikodekan
masih menyimpan beberapa digit sisa, sehingga harus ditambahkan suatu bilangan
ada 2 kemungkinan pada terjemahan per-3 yaitu kurang 1 digit atau 2 digit.
Untuk itu ditambahkan suatu bilangan di belakangnya sehingga:
xx0 --> 000 menjadi 010 atau 00_ menjadi 01_
010 menjadi 100 atau 01_ menjadi 10_
100 menjadi 110 atau 10_ menjadi 11_
110 menjadi 000 atau 11_ menjadi 00_
x00 --> 000 menjadi 010 atau 0__ menjadi 0__
100 menjadi 110 atau 1__ menjadi 1__
kemudian setelah pengacakan 3 digit bilangan tersebut pada penerjemahan ke
bilangan ASCII dipotong kembali pada digit belakang sesuai jumlah penambahan

Sedangkan untuk penerjemahan balik dari suatu kode maka tentunya akan mengalami
kendala yang sama, tapi pada digit yang kurang tersebut ditambahkan bilagan 1
sehingga :
xx1 --> 001 dibaca 111 atau 00_ menjadi 11_
011 dibaca 001 atau 01_ menjadi 00_
101 dibaca 011 atau 10_ menjadi 01_
111 dibaca 101 atau 11_ menjadi 10_
x11 --> 011 dibaca 001 atau 0__ menjadi 0__
111 dibaca 101 atau 1__ menjadi 1__

Dengan metode diatas terjadi kesesuaian dengan penambahan bilangan 0 pada
saat pengkodean.
Untuk membuktikan hal tersebut di bawah ini dibuat sebuah pengkodean balik
dari kode yang sudah dibuat diatas dengan cara seperti yang sudah disebutkan

}

jalan:=true;sandi1:='';sandi2:='';
while jalan do
begin
a:=kata2[1];
i:=ord(a);
caribinernya(sandi1,i);
while length(sandi1)>=3 do
begin
terj1:=sandi1[1]+sandi1[2]+sandi1[3];
acak2(terj1,terj2);
sandi2:=sandi2+terj2;
delete(sandi1,1,3);
end;

while length(sandi2)>=8 do
begin
bantu:='';
for j:=1 to 8 do bantu:=bantu+sandi2[j];
cariintegernya(bantu,k);
kata3:=kata3+char(k);
delete(sandi2,1,8);
end;
delete(kata2,1,1);
if kata2='' then jalan:=false;
end;

if sandi1<>'' then
begin
l:=0;
while length(sandi1)<3 do
begin
sandi1:=sandi1+'1';
l:=l+1;
end;
terj1:=sandi1;sandi1:='';
acak2(terj1,terj2);
sandi2:=sandi2+terj2;
if length(sandi2)>8 then delete(sandi2,9,l);
cariintegernya(sandi2,k);
kata3:=kata3+char(k);
end;
writeln(' Kode yang dibalikkan = ',kata3);
readln;
end.

Ember Queue

Program Ember;

Const
QUEUE_SIZE = 1000000;
MaxA = 4;
MaxB = 3;

Type
TQueue = Record
Sebelumnya : LongInt;
Langkah : Byte;
A, B : Integer;
End;

Var
Queue : Array[0..QUEUE_SIZE] of TQueue;
Langkah : Array[1..QUEUE_SIZE] of Byte;
QPos : LongInt;
QNext : LongInt;
A1, B1 : Integer;
A2, B2 : Integer;
i, j : LongInt;

Procedure Proses;
Begin

QPos := 0;
QNext := 0;

Queue[QPos].Langkah := 0;
Queue[QPos].A := A1;
Queue[QPos].B := B1;

While True do
Begin
If (Queue[QPos].A = A2) And (Queue[QPos].B = B2) Then
Break;

{ A diisi penuh --> hanya jika A belum penuh}
If Queue[QPos].A < MaxA Then
Begin
QNext := QNext + 1;
Queue[QNext].A := MaxA;
Queue[QNext].B := Queue[QPos].B;
Queue[QNext].Langkah := 1;
Queue[QNext].Sebelumnya := QPos;
End;

{ B diisi penuh --> hanya jika B belum penuh }
If Queue[QPos].B < MaxB Then
Begin
QNext := QNext + 1;
Queue[QNext].A := Queue[QPos].A;
Queue[QNext].B := MaxB;
Queue[QNext].Langkah := 2;
Queue[QNext].Sebelumnya := QPos;
End;

{ A dikosongkan --> hanya jika A tidak kosong }
If Queue[QPos].A > 0 Then
Begin
QNext := QNext + 1;
Queue[QNext].A := 0;
Queue[QNext].B := Queue[QPos].B;
Queue[QNext].Langkah := 3;
Queue[QNext].Sebelumnya := QPos;
End;

{ B dikosongkan --> hanya jika B tidak kosong }
If Queue[QPos].B > 0 Then
Begin
QNext := QNext + 1;
Queue[QNext].A := Queue[QPos].A;
Queue[QNext].B := 0;
Queue[QNext].Langkah := 4;
Queue[QNext].Sebelumnya := QPos;
End;

{ A dipindahkan ke B sampai A kosong --> hanya jika MaxB-B >= A }
If MaxB - Queue[QPos].B >= Queue[QPos].A Then
Begin
QNext := QNext + 1;
Queue[QNext].A := 0;
Queue[QNext].B := Queue[QPos].B + Queue[QPos].A;
Queue[QNext].Langkah := 5;
Queue[QNext].Sebelumnya := QPos;
End;

{ A dipindahkan ke B sampai B penuh --> hanya jika MaxB-B < A }
If MaxB - Queue[QPos].B < Queue[QPos].A Then
Begin
QNext := QNext + 1;
Queue[QNext].A := Queue[QPos].A - (MaxB - Queue[QPos].B);
Queue[QNext].B := MaxB;
Queue[QNext].Langkah := 6;
Queue[QNext].Sebelumnya := QPos;
End;

{ B dipindahkan ke A sampai B kosong --> hanya jika MaxA-A >= B }
If MaxA - Queue[QPos].A >= Queue[QPos].B Then
Begin
QNext := QNext + 1;
Queue[QNext].A := Queue[QPos].A + Queue[QPos].B;
Queue[QNext].B := 0;
Queue[QNext].Langkah := 7;
Queue[QNext].Sebelumnya := QPos;
End;

{ A dipindahkan ke B sampai A penuh --> hanya jika MaxA-A < B }
If MaxA - Queue[QPos].A < Queue[QPos].B Then
Begin
QNext := QNext + 1;
Queue[QNext].A := MaxA;
Queue[QNext].B := Queue[QPos].B - (MaxA - Queue[QPos].A);
Queue[QNext].Langkah := 8;
Queue[QNext].Sebelumnya := QPos;
End;

QPos := QPos + 1;
End;

i := 1;
While True do
Begin
Langkah[i] := Queue[QPos].Langkah;
i := i + 1;
QPos := Queue[QPos].Sebelumnya;
If QPos = 0 Then
Break;
End;

For j := i DownTo 1 do
Begin
Case Langkah[j] of
1: WriteLn('A diisi penuh');
2: WriteLn('B diisi penuh');
3: WriteLn('A dikosongkan');
4: WriteLn('B dikosongkan');
5: WriteLn('A dipindahkan ke B sampai A kosong');
6: WriteLn('A dipindahkan ke B sampai B penuh');
7: WriteLn('B dipindahkan ke A sampai B kosong');
8: WriteLn('B dipindahkan ke A sampai A penuh');
End;
End;

End;

Begin

{ Kondisi Awal }
A1 := 0;
B1 := 0;

{ Kondisi Akhir }
A2 := 2;
B2 := 0;

{ Proses }
Proses;

End.

Binary Search Tree 2

{Searches a binary search tree in O(logn) }

type tree = ^ node;
node = record
left, right : tree;
info : char
end;




function subtree( item : char ) : tree;
{creates a subtree}
var t : tree;
begin
new( t );
t^.info := item;
t^.left := nil;
t^.right := nil;
subtree := t
end;

procedure infix( t : tree);
begin
if t <> nil then begin
infix( t^.left );
write( t^.info );
infix( t^.right )
end
end;


procedure prefix( t : tree);
begin
if t <> nil then begin
write( t^.info );
prefix( t^.left );
prefix( t^.right )
end
end;

procedure postfix( t : tree);
begin
if t <> nil then begin
postfix( t^.left );
postfix( t^.right );
write( t^.info );
end
end;

procedure insert( item : char; var t : tree );
begin
if t = nil then
t := subtree( item )
else if item <= t^.info then insert( item, t^.left) else insert( item, t^.right) end; procedure bst( var root : tree ); {produces a binary search tree} var item : char; begin writeln('type your sentence'); root := nil; while not eoln do begin read( item ); insert( item, root ) end end; procedure search( key: char; var found: boolean; t : tree); begin if (t <> nil) and not found then begin
if key = t^.info then
found := true
else if key < t^.info then
search(key, found, t^.left)
else
search(key, found, t^.right)
end
end;

var root : tree;
found : boolean;
key : char;

begin
bst( root );
infix( root );
writeln;
readln;
writeln( 'type your letter');
found := false;
readln( key );
search( key, found, root);
if found then
writeln( key, ' was found.')
else
writeln( key, ' was not found.');
readln;
readln

end.

Binary Search

{Performs a binary search}
TYPE
tree =^node;
node = record
info : char;
left, right : tree
end;
VAR root: tree;
Number: integer;
{$I Tree }
{Activates: Binary_Tree, Infix, subTree, Height}

procedure search( t : tree; var found : boolean; x : char);
{pre: t points to a tree
post : each node is visited and there n is incremented}

begin
if (t <> nil) and not found then
if x = t^.info then begin
found := true;
writeln( x, ' was found')
end
else if x < t^.info then
search( t^.left, found, x)
else
search( t^.right, found, x)
end;

var found: boolean;
x : char;
BEGIN{main}
Binary_Tree(root);
Infix(root);
writeln;
found := false;
writeln('What value of x do you want?');
readln( x );
search( root, found, x);
writeln(x, ' was found is ', found)
END.

Tree

PROGRAM Tree (Input, Output);
{Written by Jason John Schwarz with Turbo Pascal v6.0.
Purpose: A demonstration binary tree.}

USES CRT;

TYPE
Point = ^Node;
Node = RECORD
Data : REAL;
Left : Point;
Right : Point;
END;{Node}

VAR
Root : Point;

PROCEDURE Initialize;
BEGIN
Root:=NIL;
END;{Initialize}

PROCEDURE Create (Data : REAL);
BEGIN
NEW(Root);
Root^.Data:=Data;
Root^.Left:=NIL;
Root^.Right:=NIL;
END;{Create}

PROCEDURE AddNode (Data :REAL; Root : Point);
VAR
Temp : Point;
BEGIN
NEW(Temp);
IF Data>=Root^.Data THEN Root^.Right:=Temp;
IF Data=Root^.Data) THEN
IF Root^.Right<>NIL THEN Add(Data,Root^.Right)
ELSE AddNode(Data,Root);
IF (Data<>NIL THEN Add(Data,Root^.Left)
ELSE AddNode(Data,Root);
END;{Root=NIL}
END;{Add}

PROCEDURE InOrder (Root : Point);
BEGIN
IF Root <> NIL THEN BEGIN
InOrder(Root^.Left);
WRITELN(Root^.Data);
InOrder(Root^.Right);
END;{Root<>NIL}
END;{InOrder}

PROCEDURE PreOrder (Root : Point);
BEGIN
IF Root <> NIL THEN BEGIN
WRITELN(Root^.Data);
PreOrder(Root^.Left);
PreOrder(Root^.Right);
END;{Root<>NIL}
END;{PreOrder}

PROCEDURE PostOrder (Root : Point);
BEGIN
IF Root<>NIL THEN BEGIN
PostOrder(Root^.Left);
PostOrder(Root^.Right);
WRITELN(Root^.Data);
END;{Root<>NIL}
END;{PostOrder}

PROCEDURE GetData;
VAR Data : REAL;
BEGIN
WRITE(Output,'What is the new number?');
READLN(Input,Data);
Add(Data,Root);
END;{GetData}

PROCEDURE Loop;
VAR
Choice : CHAR;
BEGIN
REPEAT
Choice:=CHR(0);
GetData;
CLRSCR;
WRITELN(Output,'InOrder Tree:');
InOrder(Root);
WRITELN(Output,'PostOrder Tree:');
PostOrder(Root);
WRITELN(Output,'PreOrder Tree:');
PreOrder(Root);
WRITE(Output,'Do you wish to add another number?');
READLN(Input,Choice);
UNTIL Choice IN ['N','n'];
END;{Loop}

BEGIN
Initialize;
Loop;
END.

Binary Search Tree

(**************************************************************)
(******* BINARY SEARCH TREE ADT ********)
(**************************************************************)

TYPE
KeyType = Integer; (* the type of key in Info part *)

TreeElementType = RECORD (* the type of the user's data *)
Key : KeyType;
(* other fields as needed. *)
END; (* TreeElementType *)

TreePtrType = ^TreeNodeType;

TreeNodeType = RECORD
Info : TreeElementType; (* the user's data *)
Left : TreePtrType; (* pointer to left child *)
Right : TreePtrType (* pointer to right child *)
END; (* TreeNodeType *)

TreeType = TreePtrType;

TraversalType = (Preorder, Inorder, Postorder);

(******************************************************)

PROCEDURE CreateTree
(VAR Tree : TreeType);

(* Initializes Tree to empty state. *)

BEGIN (* CreateTree *)
Tree := NIL
END; (* CreateTree *)

(*************************************************)

PROCEDURE FindNode
( Tree : TreeType;
KeyValue : KeyType;
VAR NodePtr : TreePtrType;
VAR ParentPtr : TreePtrType);

(* Find the node that contains KeyValue; set NodePtr to *)
(* point to the node and ParentPtr to point to its parent; *)

VAR
Found : Boolean; (* KeyValue found in tree? *)

BEGIN (* FindNode *)

(* Set up to search. *)
NodePtr := Tree;
ParentPtr := NIL;
Found := False;

(* Search until no more nodes to search or until found. *)
WHILE (NodePtr <> NIL) AND NOT Found DO
IF NodePtr^.Info.Key = KeyValue
THEN Found := True

ELSE (* Advance pointers. *)
BEGIN

ParentPtr := NodePtr;

IF NodePtr^.Info.Key > KeyValue
THEN NodePtr := NodePtr^.Left
ELSE NodePtr := NodePtr^.Right

END (* advance pointers *)
END; (* FindNode *)

(********************************************************)

PROCEDURE RetrieveElement
(Tree : TreeType;
KeyValue : KeyType;
VAR Element : TreeElementType;
VAR ValueInTree : Boolean);

(* Searches the binary search tree for the element whose *)
(* key is KeyValue, and returns a copy of the element. *)

VAR
NodePtr : TreePtrType; (* pointer to node with KeyValue *)
ParentPtr : TreePtrType; (* used for FindNode interface *)

BEGIN (* RetrieveElement *)

(* Find node in tree that contains KeyValue. *)
FindNode (Tree, KeyValue, NodePtr, ParentPtr);

ValueInTree := (NodePtr <> NIL);

IF ValueInTree
THEN Element := NodePtr^.Info

END; (* RetrieveElement *)

(***********************************************************)

PROCEDURE ModifyElement
(VAR Tree : TreeType;
ModElement : TreeElementType);

(* ModElement replaces existing tree element with same key. *)
VAR
NodePtr : TreePtrType; (* pointer to node with KeyValue *)
ParentPtr : TreePtrType; (* used for FindNode interface *)

BEGIN (* ModifyElement *)

(* Find the node with the same key as ModElement.Key. *)
FindNode (Tree, ModElement.Key, NodePtr, ParentPtr);

(* NodePtr points to the tree node with same key. *)
NodePtr^.Info := ModElement

END; (* ModifyElement *)

(***************************************************************)

PROCEDURE InsertElement
(VAR Tree : TreeType;
Element : TreeElementType);

(* Add Element to the binary search tree. Assumes that no *)
(* element with the same key exists in the tree. *)

VAR
NewNode : TreePtrType; (* pointer to new node *)
NodePtr : TreePtrType; (* used for FindNode call *)
ParentPtr : TreePtrType; (* points to new node's parent *)

BEGIN (* InsertElement *)

(* Create a new node. *)
New (NewNode);
NewNode^.Left := NIL;
NewNode^.Right := NIL;
NewNode^.Info := Element;

(* Search for the insertion place. *)
FindNode (Tree, Element.Key, NodePtr, ParentPtr);

(* IF this is first node in tree, set Tree to NewNode; *)
(* otherwise, link new node to Node(ParentPtr). *)
IF ParentPtr = NIL
THEN Tree := NewNode (* first node in the tree *)
ELSE (* Add to the existing tree. *)
IF ParentPtr^.Info.Key > Element.Key
THEN ParentPtr^.Left := NewNode
ELSE ParentPtr^.Right := NewNode

END; (* InsertElement *)

(**********************************************************)
{ The following code has been commented out:
PROCEDURE InsertElement
(VAR Tree : TreeType;
Element : TreeElementType);

(* Recursive version of InsertElement operation. *)

BEGIN (* InsertElement *)

IF Tree = NIL
THEN (* Base Case: allocate new leaf Node(Tree) *)
BEGIN
New (Tree);
Tree^.Left := NIL;
Tree^.Right := NIL;
Tree^.Info := Element
END (* IF Tree = NIL *)

ELSE (* General Case: InsertElement into correct subtree *)
IF Element.Key < Tree^.Info.Key
THEN InsertElement (Tree^.Left, Element)
ELSE InsertElement (Tree^.Right, Element)

END; (* InsertElement *)
}

(**********************************************************)

PROCEDURE DeleteElement
(VAR Tree : TreeType;
KeyValue : KeyType);

(* Deletes the element containing KeyValue from the binary *)
(* search tree pointed to by Tree. Assumes that this key *)
(* value is known to exist in the tree. *)

VAR
NodePtr : TreePtrType; (* pointer to node to be deleted *)
ParentPtr : TreePtrType; (* pointer to parent of delete node *)

(********************* Nested Procedures ***********************)

PROCEDURE FindAndRemoveMax
(VAR Tree : TreePtrType;
VAR MaxPtr : TreePtrType);

BEGIN (* FindAndRemoveMax *)

IF Tree^.Right = NIL
THEN (* Base Case: maximum found *)
BEGIN
MaxPtr := Tree; (* return pointer to max node *)
Tree := Tree^.Left (* unlink max node from tree *)
END (* Base Case *)

ELSE (* General Case: find and remove from right subtree *)
FindAndRemoveMax (Tree^.Right, MaxPtr)

END; (* FindAndRemoveMax *)

(*************************************************************)

PROCEDURE DeleteNode
(VAR NodePtr : TreePtrType);

(* Deletes the node pointed to by NodePtr from the binary *)
(* search tree. NodePtr is a real pointer from the parent *)
(* node in the tree, not an external pointer. *)

VAR
TempPtr : TreePtrType; (* node to delete *)

BEGIN (* DeleteNode *)

(* Save the original pointer for freeing the node. *)
TempPtr := NodePtr;

(* Case of no children or one child: *)
IF NodePtr^.Right = NIL
THEN NodePtr := NodePtr^.Left

ELSE (* There is at least one child. *)
IF NodePtr^.Left = NIL
THEN (* There is one child. *)
NodePtr := NodePtr^.Right

ELSE (* There are two children. *)
BEGIN
(* Find and remove the replacement value from *)
(* Node(NodePtr)'s left subtree. *)
FindAndRemoveMax (NodePtr^.Left, TempPtr);

(* Replace the delete element. *)
NodePtr^.Info := TempPtr^.Info

END; (* There are two children. *)

(* Free the unneeded node. *)
Dispose (TempPtr)

END; (* DeleteNode *)
(*****************************************************************)

BEGIN (* DeleteElement *)

(* Find node containing KeyValue. *)
FindNode (Tree, KeyValue, NodePtr, ParentPtr);

(* Delete node pointed to by NodePtr. ParentPtr points *)
(* to the parent node, or is NIL if deleting root node. *)
IF NodePtr = Tree
THEN (* Delete the root node. *)
DeleteNode (Tree)
ELSE
IF ParentPtr^.Left = NodePtr
THEN (* Delete the left child node. *)
DeleteNode (ParentPtr^.Left)
ELSE (* Delete the right child node. *)
DeleteNode (ParentPtr^.Right)

END; (* DeleteElement *)

(***********************************************************)

{The following procedure has been commented out:
PROCEDURE DeleteElement
(VAR Tree : TreeType;
KeyValue : KeyType);

(* Recursive version of DeleteElement operation. *)

BEGIN (* DeleteElement *)

IF KeyValue = Tree^.Info.Key
THEN (* Base Case : delete this node *)
DeleteNode (Tree)

ELSE
IF KeyValue < Tree^.Info.Key
THEN (* General Case 1: delete node from left subtree *)
DeleteElement (Tree^.Left, KeyValue)
ELSE (* General Case 2: delete node from right subtree *)
DeleteElement (Tree^.Right, KeyValue)

END; (* DeleteElement *)
}

(****************************************************************)

PROCEDURE PrintTree
(Tree : TreeType;
TraversalOrder : TraversalType);

(* Print all the elements in the tree, in the order *)
(* specified by TraversalOrder. *)

(********************** Nested Procedures ************************)

PROCEDURE PrintNode
(Element : TreeElementType);

BEGIN (* PrintNode *)

Writeln (Element.Key);
(* other statements as needed *)

END; (* PrintNode *)

(*********************************************************)

PROCEDURE PrintInorder
(Tree : TreeType);

(* Prints out the elements in a binary search tree in *)
(* order from smallest to largest. This procedure is *)
(* a recursive solution. *)

BEGIN (* PrintInorder *)

(* Base Case: If Tree is NIL, do nothing. *)
IF Tree <>NIL
THEN

BEGIN (* General Case *)

(* Traverse left subtree to print smaller values. *)
PrintInorder(Tree^.Left);

(* Print the information in this node. *)
PrintNode(Tree^.Info);
(* Traverse right subtree to print larger values. *)
PrintInorder(Tree^.Right)

END (* General Case *)
END; (* PrintInorder *)

(***************************************************************)

PROCEDURE PrintPreorder
(Tree : TreeType);

(* Print out the elements in a binary search tree in *)
(* preorder. This procedure is a recursive solution. *)

BEGIN (* PrintPreorder *)

(* Base Case: IF Tree is NIL, do nothing. *)
IF Tree <> NIL
THEN (* General Case *)
BEGIN

(* Print the value of this node. *)
PrintNode(Tree^.Info);

(* Traverse the left subtree in preorder. *)
PrintPreorder(Tree^.Left);

(* Traverse the left subtree in preorder. *)
PrintPreorder(Tree^.Right)

END (* General Case *)
END; (* PrintPreorder *)

(***********************************************************)

PROCEDURE PrintPostorder
(Tree : TreeType);

(* Prints out the elements in a binary search tree in *)
(* postorder. This procedure is a recursive solution. *)

BEGIN (* PrintPostorder *)

(* Base Case: If Tree is NIL, do nothing. *)
IF Tree <> NIL
THEN (* General Case *)
BEGIN

(* Traverse the left subtree in postorder. *)
PrintPostorder(Tree^.Left);

(* Traverse the right subtree in postorder. *)
PrintPostorder(Tree^.Right);

(* Print the value of this node. *)
PrintNode(Tree^.Info)

END (* General Case *)
END; (* PrintPostorder *)
(********************************************************)

BEGIN (* PrintTree *)

(* Call internal print procedure according to TraversalOrder. *)
CASE TraversalOrder OF
Preorder : PrintPreorder (Tree);
Inorder : PrintInorder (Tree);
Postorder : PrintPostorder (Tree)
END (* CASE *)

END; (* PrintTree *)

(***********************************************************)

PROCEDURE DestroyTree
(VAR Tree : TreeType);

(* Removes all the elements from the binary search tree *)
(* rooted at Tree, leaving the tree empty. *)

BEGIN (* DestroyTree *)

(* Base Case: If Tree is NIL, do nothing. *)
IF Tree <> NIL
THEN (* General Case *)
BEGIN

(* Traverse the left subtree in postorder. *)
DestroyTree (Tree^.Left);

(* Traverse the right subtree in postorder. *)
DestroyTree (Tree^.Right);

(* Delete this leaf node from the tree. *)
Dispose (Tree);

END (* General Case *)
END; (* DestroyTree *)

(***********************************************************)

Insertion Sort

program insertion(input,output);
const
MAX = 10;
var
a : array[1..MAX] of integer;
i, n : integer;

procedure insertion_sort;
var
i, pos : integer;
value : integer;
done : boolean;
begin
for i := 2 to n do
begin

value := a[i];
pos := i;
done := false;
while not done do
begin
if pos <= 1 then
done := true
else if value >= a[pos-1] then
done := true
else
begin
a[pos] := a[pos-1];
pos := pos-1
end
end; {while}

a[pos] := value;

end {for}
end;

begin { main }
writeln('How many number would you like to sort (max=',MAX:2,') ?');
readln(n);

writeln('Enter in ',n:1,' numbers:');
for i := 1 to n do
read(a[i]);

insertion_sort;

for i := 1 to n do
write(a[i]:1,' ');
writeln
end.

Heap sort algorithm

(** Heap sort algorithm.
*
* Author: Paulo Roma
* Date: 22/04/2008.
* http://en.wikipedia.org/wiki/Heapsort
* http://www2.hawaii.edu/~copley/665/HSApplet.html
*)

program Heap_Sort;

type SArray = array of integer;
var Asize: integer;
var A: SArray;
var i: integer;

(** swap.
*
* Swaps two given values.
*
* @param a,b values to be swaped.
*)

procedure swap ( var a, b: integer );
var temp: integer;
begin
temp := a;
a := b;
b := temp;
end;

(** siftDown.
*
* Sifts downward to establish the heap property.
*
* @param A array.
* @param start heap root.
* @param end_ represents the limit of how far down the heap to sift.
*)

procedure siftDown ( var A: SArray; start, end_: integer );
var root, child: integer;
begin
root := start;

// While the root has at least one child
while ( root * 2 + 1 <= end_ ) do begin
child := root * 2 + 1; // left child
// If the child has a sibling and
// the child's value is less than its sibling's
if ( child < end_ ) and ( A[child] < A[child + 1] ) then
child := child + 1; // point to the right child instead
if ( A[root] < A[child] ) then begin // out of max-heap order
swap ( A[root], A[child] );
root := child; // repeat to continue sifting down the child
end
else
break;
end;
end;

(** heapify.
*
* Builds a heap from the bottom up.
*
* The heapify function can be thought of as building a
* heap from the bottom up, successively sifting downward
* to establish the heap property.
*
* @param A array.
* @param count number of elements in A.
*)

procedure heapify ( var A: SArray; count: integer );
var start: integer;
begin
// start is assigned the index in A of the last parent node
start := (count - 1) div 2;

while ( start >= 0 ) do begin
// sift down the node at start index to the proper place,
// such that all nodes below the start index are in heap order
siftDown (A, start, count-1);
start := start - 1;
// after sifting down the root all nodes/elements are in heap order
end;
end;

(** heapSort.
*
* Sorts A=(A0, A1, ..., An) into nondecreasing order of keys.
* This algorithm has a worst case computational time of O(n log n).
* Not stable.
*
* Heapsort primarily competes with quicksort,
* another very efficient, general purpose, and
* nearly-in-place, comparison-based sort algorithm.
*
* Heapsort inserts the input list elements into a heap data structure.
* The largest value (in a max-heap) or the smallest value
* (in a min-heap) are extracted until none remain,
* the values being extracted in sorted order.
* The heap's invariant is preserved after each
* extraction, so the only cost is that of extraction.
*
* During extraction, the only space required is that needed to store
* the heap. In order to achieve constant space overhead, the heap
* is stored in the part of the input array that has not yet been sorted.
* (The structure of this heap is described at Binary heap:
* Heap implementation.)
*
* Heapsort uses two heap operations: insertion and root deletion.
* Each extraction places an element in the last empty location of
* the array. The remaining prefix of the array stores the
* unsorted elements.
*
* @param A array to be sorted.
* @param n number of elements to be sorted.
*)

procedure heapSort( var A: SArray; n: integer );
var end_: integer;
begin
// first place A in max-heap order
heapify ( A, n );

end_ := n - 1;
while ( end_ > 0 ) do begin
// swap the root (maximum value) of the heap
// with the last element of the heap
swap( A[end_], A[0]);
// decrease the size of the heap by one,
// so that the previous max value
// will stay in its proper placement
end_ := end_ - 1;
// put the heap back in max-heap order
siftDown (A, 0, end_);
end;
end;

begin
write ( 'Enter number of elements: ' );
read ( Asize );
// alocate an array from 0 to Asize-1
// the array index is always zero-based
SetLength ( A, Asize );
// generate the seed
randomize;
// fill A with random numbers in the range [0..99]
for i := 0 to Asize-1 do
A[i] := random (100);

// print original array
for i := 0 to Asize-1 do begin
write (A[i]); write (' ');
end;
writeln;

// sort
heapSort ( A, Asize );

// print sorted array
for i := 0 to Asize-1 do begin
write (A[i]); write (' ');
end;
writeln;
end.

Tower Of Hanoi

(*
http://en.wikipedia.org/wiki/Tower_of_Hanoi
http://www.cut-the-knot.org/recurrence/hanoi.shtml
Recurrence: T(h) = 2T(h-1) + 1 = 2**h - 1 --> O(2**h)
*)

program Hanoi_Tower;
// number of disks
var nd: integer;

(** Hanoi.
*
* A game invented by the French mathematician Edouard Lucas in 1883.
*
* 1. Move the top N-1 disks from Src to Aux (using Dst as an intermediary peg)
* 2. Move the bottom disk from Src to Dst
* 3. Move N-1 disks from Aux to Dst (using Src as an intermediary peg)
*
* @param n number of disks.
* @param from source peg.
* @param to_ destination peg.
* @param by intermediary peg.
*)
procedure Hanoi(n: integer; from, to_, by: char);
begin
if (n=1) then
writeln('Move the plate from ', from, ' to ', to_)
else begin
Hanoi(n-1, from, by, to_);
Hanoi(1, from, to_, by);
Hanoi(n-1, by, to_, from);
end;
end;

begin
write ( 'Enter number of disks: ' );
readln ( nd );
Hanoi (nd,'A','B','C')
end.

Merge Sort

{confronti tra algortitmi}


type INTARRAY = array[1..100000] of integer;

procedure gen_array(var A:INTARRAY; N:integer);
var i:integer;
begin
for i:=1 to N do A[i]:=Random(10*N);
end;

{copia l'array X in Y}
procedure copy_array(var X, Y:INTARRAY; n:integer);
var i:integer;
begin
for i := 0 to N do Y[i] := X[i];
end;

function min(a,b:integer):integer;
begin if a else min := b;
end;

procedure print_array(var A:INTARRAY; N:integer);
var i:integer;
begin
for i:=1 to min(n, 100) do
begin
write(A[i]:6);
if ((i mod 10)= 0) then writeln;
end;
if (n>100) then writeln('......'); //writeln('array troppo lungo da scrivere');
end;

procedure InsSort(var A: INTARRAY; N: integer);
var i, j, t, indM: integer;
begin {Insertion Sort }
for i := 1 to N-1 do
begin
indM:=i;
for j:=i+1 to N do
if A[j] t:= A[i];
A[i]:=A[indM];
A[indM] := t;
end;
end;

procedure Merge (var A: INTARRAY; p, q, r: integer);
var i, j, k: integer;
var B: INTARRAY;
begin { Merge }
i := p;
j := q + 1;
k := p;
while ((i <= q) and (j <= r)) do
begin
if (A[i] < A[j])
then begin
B[k] := A[i];
i := i + 1;
end
else begin
B[k] := A[j];
j := j + 1;
end;
k := k + 1;
end;
while (i <= q) do
begin
B[k] := A[i];
k := k + 1;
i := i + 1;
end;
while (j <= r) do
begin
B[k] := A[j];
k := k + 1;
j := j + 1;
end;
for k := p to r do A[k] := B[k];
end;

procedure MergeSort (var A: INTARRAY; p, r: integer);
var q: integer;
begin { MergeSort }
if (p < r) then
begin
q := (p + r) div 2;
MergeSort (A, p, q);
MergeSort (A, q + 1, r);
Merge (A, p, q, r);
end;
end;


var data: INTARRAY;
var A: INTARRAY;
var i, j, key:integer;


// Programma principale
var N:integer;
begin
write('numero elementi: ');
readln(N);
gen_array(data, N);

copy_array(data, A, N);

writeln('array in input: ');
print_array(data, N);
writeln('pronto ad ordinare con isertion sort: ');
readln;
InsSort(data, N);
writeln('array dopo ordinamento:');
print_array(data, N);

copy_array(A, data, N);
writeln('pronto ad ordinare con merge sort: ');
readln;
MergeSort(data, 1, N);
writeln('array dopo ordinamento:');
print_array(data, N);
writeln('programma finito');
readln;
end.

Bubble Sort

(** Bubble sort algorithm.
*
* Author: Paulo Roma
* Date: 21/04/2008.
* http://en.wikipedia.org/wiki/Bubble_sort
*)

program Bubble_Sort;

type SArray = array of integer;
var Asize: integer;
var A: SArray;
var i: integer;

(** bubbleSort.
*
* Sorts A=(A0, A1, ..., An) into nondecreasing order of keys.
* This algorithm has a worst case computational time of O(n**2).
* Stable.
*
* Bubble sort is a straightforward and simplistic method of sorting
* data that is used in computer science education.
* The algorithm starts at the beginning of the data set.
* It compares the first two elements, and if the first is greater
* than the second, it swaps them. It continues doing this
* for each pair of adjacent elements to the end of the data set.
* It then starts again with the first two elements, repeating until
* no swaps have occurred on the last pass. While simple, this algorithm
* is highly inefficient and is rarely used except in education.
* A slightly better variant, cocktail sort, works by inverting the
* ordering criteria and the pass direction on alternating passes.
* Its average case and worst case are both O(n**2).
*
* Large elements at the beginning of the list do not pose a problem,
* as they are quickly swapped. Small elements towards the end,
* however, move to the beginning extremely slowly.
* This has led to these types of elements being named rabbits and
* turtles, respectively.
*
* @param A array to be sorted.
* @param n number of elements to be sorted.
*)

procedure bubbleSort( var A: SArray; n: integer );
var swapped: boolean;
var i, temp: integer;
begin
repeat
swapped := false;
n := n - 1;
for i := 0 to n-1 do begin
if ( A[i] > A[i+1] ) then begin
// swap
temp := A[i];
A[i] := A[i+1];
A[i+1] := temp;
swapped := true;
// every time one pass of this loop is completed,
// the largest element has been moved to the end
// of the array
end
end;
until not swapped;
end;

begin
write ( 'Enter number of elements: ' );
read ( Asize );
// alocate an array from 0 to Asize-1
// the array index is always zero-based
SetLength ( A, Asize );
// generate the seed
randomize;
// fill A with random numbers in the range [0..99]
for i := 0 to Asize-1 do
A[i] := random (100);

// print original array
for i := 0 to Asize-1 do begin
write (A[i]); write (' ');
end;
writeln;

// sort
bubbleSort ( A, Asize );

// print sorted array
for i := 0 to Asize-1 do begin
write (A[i]); write (' ');
end;
writeln;
end.

Program TLSort (4 type Sorting and The Time[Effectivity])

program TLSort;

Uses Dos,crt;

Const maks   = 20000; {dpt ditambahkan selama tidak out of memory}

Type  indeks = 1..maks;{Indeks Data}

	  Data   = array[indeks] of integer;



var Banyak, i : integer;

    A,B       : Data; {Data A=data Awal, Data B:Data Setelah Pengurutan}

    jam1,mnt1,dtk1,mdtk1 : word; {waktu awal pengurutan}

    jam2,mnt2,dtk2,mdtk2 : word; {waktu akhir pengurutan}



Procedure Identitas; {Prosedur identitas program ini}

begin

   GotoXy(20,5); Writeln('Muchamad Dachlan Zaim (M0507028)');

   GotoXy(20,6); Writeln('   Program Uthek2 Pointer v.1   ');

   GotoXy(20,7); Writeln('      Tanggal 20 Maret 2008     ');  

end;



Procedure BuatData(var X:Data; n:integer);

begin    {Prosedur untuk membuat data secara random}

   randomize;

   for i := 1 to n do X[i] := random(10000);

end;



Procedure CetakData(X:data);

begin  {Prosedur untuk mencetak data bilangan}

   for i := 1 to Banyak do writeln(i:10,'  ',A[i]); 

end;



Procedure ulang(X:data;var Y:data; n:integer);

begin {prosedur untuk memindahkan data yang belum diurut(X) dengan yang sudah urut(Y)}

  for i:=1 to n do Y[i]:=X[i];

end;



procedure bubbleSort(X:Data; var Y:data; n:integer);

var swap     : boolean; {Prosedur pengurutan dengan bubble sort}

    i, titip : integer;

begin

  repeat

    swap := false; 

    for i:=1 to n-1 do 

       begin

       if (X[i]>X[i+1]) then 

          begin

          titip  := X[i];   {Pengecekan satu per satu bilangan sebelum dan sesudah}

          X[i]   := X[i+1]; {jika bil sebelum>bil sesudah, maka bil tersebut ditukar}

          X[i+1] := titip;  {penempatannya}

          swap   := true;

          end

       end;

  until not(swap);

  Ulang(X,Y,n);

end;



procedure selectionSort(X:Data; var Y:data; n: integer);

var i, j, min, titip: integer;

begin

  for i:=1 to n-1 do 

    begin

    min := i;

    for j:=i to n do 

       begin

       if (X[j]       end;

    titip  := X[i];   {}

    X[i]   := X[min]; {}

    X[min] := titip;  {}

    end;

  Ulang(X,Y,n);

end;



procedure insertionSort(X:Data; var Y:data; n:integer);

var i, j, nilai: integer; wis:boolean;

begin

  for i:=2 to n do 

    begin

    nilai := X[i];

    j     := i-1;

    wis   := false;

    while not(wis) do

	    begin

	      if j<= 1 then wis := true

	      else if nilai>=a[j-1] then wis := true

	      else begin

	           a[j] := a[j-1];

	           j    := j-1

               end

	    end;

    a[j] := nilai;

    end;

  ulang(X,Y,n);

end;







Procedure MergeSort(X:Data; var Y:data; n:integer);

  procedure merge(var X:Data; p,q,r: integer);

  var i,j,k: integer;

      Y: Data;

  begin

    i := p;   k := p;   j := q+1;

    while ((i<=q) and (j<=r)) do 

       begin

       if ( X[i] <= X[j] ) then 

            begin

            Y[k] := X[i];

            i    := i+1;

            end

       else begin

            Y[k] := X[j];

            j    := j+1

            end;

       k := k+1;

       end;

    while ( i <= q ) do 

       begin

       Y[k] := X[i];

       k    := k+1; 

       i    := i+1;

       end;

    while (j<=r) do 

       begin

       Y[k] := X[j];

       k    := k+1; 

       j    := j+1;

       end;  

    for i:=p to r do X[i]:=Y[i];  

  end; 



  procedure merge2(var X:Data; p,r:integer);

  var q: integer;

  begin

     if (p        begin

        q:=(p+r)div 2;

        merge2(X, p, q);

        merge2(X, q+1, r);

        merge (X, p, q, r);

        end;

  end;

begin

  Merge2(A,1,Banyak);

  ulang(X,Y,n);

end;





Function L0(w: word):string ;

var s : string ;

begin

  Str(w:0,s);

  if w<10 then s:='0' + s;

  L0 := s ;

end ;



Procedure CetakWaktu(jamB,jamA,mntB,mntA,dtkB,dtkA,mdtkB,mdtkA:word);

var jamC,mntC,dtkC,mdtkC:word;

begin

  jamC:=0; mntC:=0; dtkC:=0; mdtkC:=0;

  writeln(L0(jamA),' : ',L0(mntA),' : ',L0(dtkA),' : ',L0(mdtkA));

  writeln(L0(jamB),' : ',L0(mntB),' : ',L0(dtkB),' : ',L0(mdtkB));

  if(mdtkB-mdtkA)<0 then begin mdtkC:=mdtkB+100-mdtkA; dtkB:=dtkB-1;end

    else mdtkC:=mdtkB-mdtkA;

  if(dtkB-dtkA)<0   then begin dtkC:=dtkB+60-dtkA;    mntB:=mntB-1;end

    else dtkC:=dtkB-dtkA; 

  if(mntB-mntA)<0   then begin mntC:=mntB+60-mntA;    jamB:=jamB-1;end

    else mntC:=mntB-mntA;

  jamC:=jamB-jamA;  

  WriteLn(L0(jamC),' : ',L0(mntC),' : ',L0(dtkC),' : ',L0(mdtkC));  

end;



Procedure Menu;

begin

  clrscr;

  identitas;

  write('Masukkan Banyak Bilangan yang Akan dirandom: ' ); read(Banyak);

  BuatData(A,Banyak);

  CetakData(A);  

  readln;

  getTime(jam1,mnt1,dtk1,mdtk1); BubbleSort(A,B,Banyak);  getTime(jam2,mnt2,dtk2,mdtk2);

  Writeln('Waktu Bubble'); 

  CetakWaktu(jam2,jam1,mnt2,mnt1,dtk2,dtk1,mdtk2,mdtk1);

  readln;

  getTime(jam1,mnt1,dtk1,mdtk1); InsertionSort(A,B,Banyak);  getTime(jam2,mnt2,dtk2,mdtk2);

  Writeln('Waktu Insertion'); 

  CetakWaktu(jam2,jam1,mnt2,mnt1,dtk2,dtk1,mdtk2,mdtk1);

  readln;

  getTime(jam1,mnt1,dtk1,mdtk1); SelectionSort(A,B,Banyak);  getTime(jam2,mnt2,dtk2,mdtk2);

  Writeln('Waktu Selection'); 

  CetakWaktu(jam2,jam1,mnt2,mnt1,dtk2,dtk1,mdtk2,mdtk1);

  readln;

  getTime(jam1,mnt1,dtk1,mdtk1); MergeSort(A,B,Banyak);  getTime(jam2,mnt2,dtk2,mdtk2);

  Writeln('Waktu Merge'); 

  CetakWaktu(jam2,jam1,mnt2,mnt1,dtk2,dtk1,mdtk2,mdtk1);

  readln;

  Write('Mau lihat hasil Datanya?? '); readln;

  

  CetakData(A);

  readln;

end;



begin

  Menu; 

end.

Program TLQueue

Program Queue;
Uses Wincrt;
Type antrian = ^node; {Program QUEUE menggunakan Record}
node = Record
isi : String[10];
next : antrian; End;
Var dpn, blk, baru : antrian;
x,y : String[10];
i : integer;

Function IsEmpty: boolean; {Fungsi digunakan untuk menge-cek apakah antrian kosong ato tidak}
Begin {Meng-cek apakah node Depan dan Belakang Kosong atau tidak??}
IsEmpty := (dpn=nil) and (blk=nil);
End;

Procedure Cetak; {Cetak Antrian secara FIFO(First In First Out)}
Var bantu : antrian;
Begin
writeln; write(' Hasil Cetak Data = ');
If not(IsEmpty) then {Cek dulu apakah kosong atau tidak}
Begin
bantu := dpn; {Variabel bantu untuk tambahan, apabila bantu tidak kosong, maka diCETAK}
While bantu <> nil do {antrian maju dan diulangi sampai variabel bantu kosong isinya}
Begin
write(bantu^.isi:5);
bantu := bantu^.next;
End;
End
Else write('Antrian KOSONG, Tidak Ada Yang Bisa Dicetak !!');
writeln;
write(' ===================================================================== ');
End;

Procedure Buat; {Prosedur untuk membuat antrian/menambah antrian di belakang}
Var baru : antrian;
Begin
new(baru);
baru^.isi := x;
baru^.next := nil;
If IsEmpty then {Apabila Antrian kosong maka buat baru di antrian tersebut}
Begin {Jika tidak, maka buat baru setelah antrian tersebut}
dpn := baru;
blk := baru;
End
Else Begin
blk^.next := baru;
blk := baru;
End;
End;

Function Cari(x : String): boolean; {Fungsi pencarian data "X" di antrian}
Var ada : boolean; bantu : antrian;
Begin
ada := false;
bantu := dpn;
Repeat {Pengulangan cek pada tiap node apakah "x" ada di dalamnya?? Jika tidak maka lanjut ke node selanjutnya}
If (bantu^.isi = x) then ada := true {sampai ada=TRUE atau tidak ada sama sekali}
Else bantu := bantu^.next;
Until ada or (bantu = nil);
cari := ada;
End;

Procedure TambahBlk; {Tambah Belakang sebenarnya hanya menggunakan prosedur Buat}
Begin
writeln;
write('Masukkan Data Yang Akan Ditambahkan Dibelakang Data = '); readln(x);
Buat;
End;

Procedure AmbilDpn; {Prosedur mengambil depan untuk menjadi data "x"}
Var bantu : antrian;{Akan tetapi, tidak dilakukan apapun terhadap data ini??}
Begin
writeln;
write(' Elemen Terdepan Data Adalah = '); write(dpn^.isi);
write('Tekan ENTER utk Ambil Data Tersebut = '); readln;
baru := dpn;
If not(isEmpty) then
Begin
dpn := dpn^.next;
baru := nil;
End
Else write('antrian kosong');
End;

Procedure HapusDpn; {Prosedur untuk menhapus data terdepan}
Var bantu : antrian;
Begin
If not (isEmpty) then
Begin
dpn := dpn^.next;
If dpn=nil then blk := nil;
End
Else write('antrian kosong');
End;

Procedure HapusBlk; {Prosedur untuk menghapus data belakang}
Var bantu, baru : antrian;
Begin
bantu := dpn;
If not (isEmpty) then
Begin
While bantu^.next^.next <> nil do bantu := bantu^.next;
new(baru);
baru := bantu^.next;
bantu^.next := nil;
baru := nil;
End
Else write('antrian kosong');
End;

Procedure HapusX; {Prosedur untuk menghapus data "X"}
Var bantu, hapus : antrian;
Begin
bantu := dpn;
new(hapus);
If cari(x)=true then
Begin
hapus := bantu^.next;
bantu^.next := hapus^.next;
hapus := nil;
End
Else bantu := bantu^.next;
End;

Procedure SisipDpn; {Prosedur untuk Sisip Depan, tetapi belum berhasil sampai saat ini}
Var baru, bantu : antrian;
Begin
bantu := dpn;
While bantu^.next <> nil do
Begin
If bantu^.next^.isi = x then
Begin
new(baru);
baru^.isi := y;
baru^.next := bantu^.next;
bantu^.next := baru;
End;
bantu := bantu^.next;
End;
End;

Procedure SisipBlk; {Prosedur untuk Sisip BElakang, tetapi belum berhasil sampai saat ini}
Var bantu, baru : antrian;
Begin
bantu := dpn;
While bantu^.next <> nil do
Begin
If bantu^.isi=x then
Begin
new(baru);
baru^.isi := y;
baru^.next := bantu^.next;
bantu^.next := baru;
End;
bantu := bantu^.next;
End;
End;

Procedure Identitas; {Prosedur Identitas akan muncul pada program}
Begin
gotoXY(10, 1); write('Program "Q U E U E"');
gotoXY(10, 2); write('Muchamad Dachlan Zaim (M0507028)');
gotoXY(10, 3); write('Ilmu Komputer 2007');
gotoXY(10, 4); write('Tanggal 20 Mei 2008, 18.00 WIB');
gotoXY(6, 5); write('=====================================================================');
End;

Procedure Menu; {Prosedur untuk menampilkan semuanya, termasuk menu utama juga !!!}
Var pil,lagi : char;
Begin
clrscr;
Identitas;
Cetak;
gotoXY(30,10); write('"==== Modifikasi Data QUEUE ===="');
gotoXY(10,12); write('a. Input Awal');
gotoXY(10,13); write('b. Cari Data X');
gotoXY(10,14); write('c. Tambah Data di Belakang/ Enqueue');
gotoXY(10,15); write('d. Ambil Data Teratas dan Simpan di X');
gotoXY(10,16); write('e. Hapus Data Terdepan');
gotoXY(10,17); write('f. Hapus Data Belakang');
gotoXY(10,18); write('g. Hapus Data X');
gotoXY(10,19); write('h. Sisip Data di Depan');
gotoXY(10,20); write('i. Sisip Data di Belakang');
gotoXY(10,21); write('j. Keluar');

Repeat
gotoXY(40,23); Clreol; write('Pilihan anda (a-j) = '); readln(pil);

CASE upcase(pil) OF
'A' : Begin
lagi := 'Y';
clrscr;
gotoXY(10,5); write('=== Daftar Makanan "RestoRUN" ===');writeln;
While upcase(lagi)='Y' do
Begin
write(' Nama Makanan = '); readln(x);writeln;
buat;
repeat
write(' Ada lagi (Y/T) ? '); readln(lagi);writeln;
until upcase(lagi) in['Y','T']
End;
cetak; readln; menu;
End;
'B' : Begin
clrscr;
gotoXY(25,6); write('Makanan Apa Yang anda Cari = '); readln(x);
If not(isEmpty) then
Begin
cari(x);
If (cari(x)=true) then
Begin
gotoXY(25,10); write('Makanan "',x,'" Tersedia Dalam Daftar Makanan ');
End
Else Begin
gotoXY(25,10); write('Makanan "',x,'" Tidak Tersedia Di Daftar Makanan');
End;
End
Else write('antrian kosong');
cetak; readln; menu;
End;
'C' : Begin tambahblk; cetak; readln; menu; end;
'D' : Begin ambildpn; cetak; readln; menu; end;
'E' : Begin writeln; write('Tekan ENTER Untuk Hapus Depan... '); readln; hapusdpn; cetak; readln; menu;End;
'F' : Begin writeln; write('Tekan ENTER Untuk Hapus Belakang...'); readln; hapusblk; cetak; readln; menu;End;
'G' : Begin
write(' Data Yang Akan Dihapus = '); readln(x);
hapusX; cetak; readln; menu;
End;
'H' : Begin
write(' Data Yang Akan Disisipkan = '); readln(y); writeln;
write(' Disisip Didepan Data = '); readln(x);
If cari(x)=true then sisipdpn;
cetak; readln; menu;
End;
'I' : Begin
write(' Data Yang Akan Disisipkan = '); readln(y); writeln;
write(' Disisip Dibelakang Data = '); readln(x);
If cari(x)=true then sisipblk;
cetak; readln; menu;
End;
'J' : donewincrt;
End;
Until upcase(pil) in['A'..'J'];
End;


{----MAIN PROGRAM----}
Begin
screensize.x := 95;
screensize.y := 400;
menu;
End.{AKHIR PROGRAM UTAMA}

Is it possible for a compiler to be ISO 7185 Pascal compliant and Borland Delphi compliant as well?

GNU GPC is such a compiler. It will take switches that configure it for either ISO 7185 use or Borland use. Note that several of the differences between the languages are compatible between the languages without the need for an option. Here is a list of ISO 7185 to Delphi differences, and whether they require a configuration option, and why. See the section "Differences between the languages", for details on each difference.

1. Procedure and function parameters.

Requires a configuration option: No

Reason: In delphi mode, the keyword procedure or function in a procedure or function header is an error. In ISO 7185 Pascal, it introduces a procedure or function parameter. This makes it essentially an extension to Delphi.

2. Interprocedural gotos.

Requires a configuration option: No

Reason: Such gotos cause an error in Delphi, so it behaves as simple extension.

3. File buffer access, "get" and "put" procedures.

Requires a configuration option: No

Reason: There are no get or put procedures in Delphi, and access to a file variable is illegal, so both of these act as simple extensions.

4. Sized variant record allocation.

Requires a configuration option: No

Reason: Allocating a variant record with new with Delphi is illegal, so it behaves as a simple extension.

5. "pack" and "unpack" functions.

Requires a configuration option: No

Reason: There are no pack or unpack procedures in Delphi, so it behaves as a simple extension. Note that in most cases, pack and unpack don't need to actually do anything, since arrays are allocated to the nearest byte on most microprocessors.

6. { and (*, } and *) are not synonyms.

Requires a configuration option: Yes

Reason: There is no way to have a single behavior that covers both the ISO 7185 and Delphi definition of how comments work.

7. Requires compiler directives to make a standard program.

Requires a configuration option: No

Reason: The compiler can simply ignore this comment.

8. End of line returns ASCII codes.

Requires a configuration option: Yes (or a different runtime library)

Reason: There is no way to satisfy both program standards. An eoln is either a space or the underlying ASCII characters.

9. Default field widths.

Requires a configuration option: Yes (or a different runtime library)

Reason: The basic behavior of the compiler must be changed.

So of the 9 basic differences between the standards, 3 of them are mutually incompatible between the two languages, and require options to change the basic workings of the compiler. The 6 remaining differences that are simply additions to the Delphi language can also be thought of as "freebies" that can be added to any Delphi compatible compiler in order to enable it to be closer to the ISO 7185 standard without compromising its Delphi processing in any way.

Is it possible to write in a Pascal subset that will be acceptable to both ISO 7185 Pascal and Delphi?

Sure. You can use the ISO 7185 "level 0" Pascal with the following omissions:

1. Do not use procedure or function parameters. These have different syntax in ISO 7185 and Delphi.

2. Do not use intraprocedural gotos (gotos that leave the current procedure or function). If you need a deep nested bailout to a higher level procedure, try setting an error variable and checking that after each procedure/function call that might have an error, then skipping either out of the routine, or to the goto point.

3. Do not use file buffer handling (such as f^ accesses, where f is a file), nor the built in routines "get" and "put". Basically, this just means you cannot use the lookahead buffering that ISO 7185 Pascal provides.

4. Do not size your variant records with "new". Delphi knows about variant records, but not how to size them (at least not the standard way). This will have no functional effect on your program, it will just take more runtime space.

5. Always use the keyword "packed" on a string that is intended to be printed with "writeln". Delphi does not require this, but ISO 7185 does.

6. Always include the files "input" and/or "output" in the program header if they are used in the program (and remember that write/read with no file parameter is a defacto reference). Delphi simply ignores these header parameters, so they don't hurt.

7. Always use format specifications to set the width that will be output for integers. This will remove differences from varying default fields.

8. Don't use external files other than input and output, since most Delphi does nothing with header files).

9. Borland Delphi has the requirement that an

{$APPTYPE CONSOLE}

must exist at the top after the program header. If your non-Delphi compiler ignores this as a comment, then you can add it to also be compatible with Delphi. If your ISO 7185 compiler also treats "$" in a comment as an option, you are going to have to be prepared to remove it as need be.

Finally, note that you MUST also comply with the ISO 7185 standard requirements for this to work. For example, ISO 7185 forbids gotos into program structures like "for" loops, etc, whereas delphi does not. There are many other such restrictions of ISO 7185 that are relaxed in Delphi, not to mention the many Delphi extensions that you need to refrain from using (of course, all Pascal compilers have extensions, so that would apply to them as well). Also remember: Pascal originally had no "string" type. This might seem strange, but C (for example) does not have one either. Instead, you use an array of characters (which is not the same thing!). See other sections of this FAQ.

The old bit of cross compiler checking that applies here is to run a check compile on all of the different compilers you plan to be compatible with frequently. This will tell you about problems with different compilers before they get out of hand.

For this author's point of view, I lived with mutiple Pascal compilers for years, and made it work by isolating system specific code to modules that implemented that on a particular platform. For example, I had a set of routines in a module I called "basicio.pas" that contained things like opentext(f, filename), closetext(f) and similar functions. Then, this module is simply recoded or swapped out to move to a different compiler.

Antrian Melingkar

Antrian Melingkar
uses wincrt;
type lingkar=array[1..10] of char;
type ling=record
nilai:lingkar;
dep:integer;
bel:integer;
isi:integer;
end;
var n:integer;
antrian:ling;
{---------------------------------------------------------------------}
procedure push(var antrian:ling;x:char);
7
begin
if antrian.isi=n then write('antrian penuh')
else
begin
if antrian.bel=n then antrian.bel:=1
else antrian.bel:=antrian.bel+1;
antrian.nilai[antrian.bel]:=x;
antrian.isi:=antrian.isi+1;
end;
end;
{---------------------------------------------------------------------}
procedure pop(var antrian:ling;var x:char);
begin
if antrian.isi=0 then write('antrian kosong')
else
begin
antrian.dep:=antrian.dep+1;
if antrian.dep=n+1 then antrian.dep:=1;
x:=antrian.nilai[antrian.dep];
antrian.nilai[antrian.dep]:=' ';
antrian.isi:=antrian.isi-1;
end;
end;
{---------------------------------------------------------------------}
var i,ingin:integer;
x:char;
begin
n:=5;
i:=0;
repeat
i:=i+1;
write('antrian ke - ',i,' = ');readln(x);
push(antrian,x);
until i=n;
for i:=1 to antrian.bel do write(antrian.nilai[i],' ');
readln;
repeat
write('Anda ingin 0. Udah, 1. Push, 2. pop');readln(ingin);
if ingin<>0 then
case ingin of
1: begin
write('nilai yang akan masuk : ');readln(x);
push(antrian,x);
for i:=1 to n do
write(antrian.nilai[i],' ');
writeln;
end;
2: begin
x:=' ';
pop(antrian,x);
writeln('Data keluar = ',x);
for i:=1 to n do
write(antrian.nilai[i],' ');
writeln;
end;
end
until ingin=0;
end.

Program Tumpukan

Program Tumpukan;
uses wincrt;
const MaxElemen=5;
type Tumpukan =record
isi:array[1..MaxElemen] of integer;
atas: 0..MaxElemen
end;
type isi=array[0..maxelemen] of integer;
const isilama1:isi=(3,7,2,6,4,8);
isibaru1:isi=(4,8,3,6,5,1);
var
Nilailama,Nilaibaru:isi;
T:tumpukan;
{---------------------------------------------------------------------}
Procedure Ganti_NilaiStack(T:tumpukan;Nilailama,Nilaibaru:isi);
var
penuh,habis: boolean;
x,i:integer;
{---------------------------------------------------------------------}
procedure push( var T:tumpukan; var penuh:boolean;x:integer);
begin
if T.atas = maxElemen then penuh:=true
else
begin
penuh :=false;
T.isi[T.atas]:=x;
T.atas:=T.atas+1;
end;
end;
{---------------------------------------------------------------------}
procedure pop(var T:tumpukan;var habis:boolean; var x:integer);
begin
if T.atas =0 then habis:=true
else
begin
habis:=false;
T.atas:=T.atas-1;
x:=T.isi[T.atas];
end;
end;
{---------------------------------------------------------------------}
begin
clrscr;
write('Nilai Lama Sebelum Masuk Tumpukan : ');
for i:=0 to maxelemen do
write(isilama1[i]);
writeln;
write('Nilai Baru Sebelum Masuk Tumpukan : ');
for i:=0 to maxelemen do
write(isibaru1[i]);
writeln;
penuh:=false;
while penuh=false do
begin
push(T,penuh,Nilailama[T.atas]);
end;
write('Isi Tumpukan Lama : ');
while T.atas<>0 do
begin
pop(T,habis,x);
write(x);
end;
writeln;penuh:=false;
while penuh=false do
begin
push(T,penuh,Nilaibaru[T.atas]);
end;
write('Isi Tumpukan Baru : ');
while T.atas<>0 do
begin
pop(T,habis,x);
write(x);
end;
end;
{---------------------------------------------------------------------}
begin
Nilailama:=isilama1;Nilaibaru:=isibaru1;
Ganti_NilaiStack(T,Nilailama,Nilaibaru);
readkey;
end.

Is it possible to have a module (unit) under Delphi that converts it to ISO 7185 use?

It is not possible for several reasons. First, there are several differences between the languages that are purely syntactic in nature, such as the way comments work. Second, there is no way to write, for example, file handling functions that accept all types of files. Third, there are features such as interprocedure gotos that only the compiler can implement.

I have seen many claims in the past that it is "easy to bridge the differences between ISO Pascal and the Delphi language", but it is usually apparent that those making the claim haven't read the ISO 7185 standard in any detail. It simply isn't that easy.

Program Ganjil Genap

Program ganjil_genap;
uses wincrt;
var
bil, i,g1,g2,j1,j2,n: integer;
rt1,rt2:real;
begin
write('Masukkan Banyaknya Data ' );readln(n);
for i := 1 to n do
begin
write('Bilangan ke:',i ,' ');readln(bil);
if bil mod 2 = 0 then
j1:=j1 +1;
g1:=g1+bil;
if bil mod 2 =1 then
j2:=j2+1;
g2:=g2+bil;
end;
rt1:=g1/j1;
rt2:=g2/j2;
writeln('Jumlah bil. Ganjil=' ,j2);
writeln('Jumlah bil. Genap=' ,j1);
writeln('Rerata Ganjil=' ,rt2:4:2);
writeln('Rerata Genap=' ,rt1:4:2);
end.

Program Baca berpasangan

Program Baca_berpasangan;
Uses WinCrt;
Var
X,Y,Rx,Ry,Jx,Jy : real;
Nx,Ny,i : integer;
Begin
ClrScr;
Write('Masukkan Banyaknya X :');Readln(Nx);
Write('Masukkan Banyaknya Y :');Readln(Ny);
If Nx = Ny then
For i:=1 to Nx Do
begin
Write('Data X ke-',i,' = ');Readln(X);
Write('Data Y ke-',i,' = ');Readln(Y);
Jx:=Jx+X;
Jy:=Jy+Y;
end
else if Nx > Ny then
begin
For i:=1 to Ny Do
begin
Write('Data X ke-',i,' = ');Readln(X);
Write('Data Y ke-',i,' = ');Readln(Y);
Jx:=Jx+X;
Jy:=Jy+Y;
end;
i:=Ny+1;
Repeat
Write('Data X ke-',i,' = ');Readln(X);
Jx:=Jx+X;
i:=i+1;
until i>Nx;
end
else if Nx < Ny then
begin
For i:=1 to Nx Do
begin
Write('Data X ke-',i,' = ');Readln(X);
Write('Data Y ke-',i,' = ');Readln(Y);
Jx:=Jx+X;
Jy:=Jy+Y;
end;
i:=Nx+1;
Repeat
Write('Data Y ke-',i,' = ');Readln(Y);
Jy:=Jy+Y;
i:=i+1;
until i>Ny;
end;
Rx:=Jx/Nx;
Ry:=Jy/Ny;
writeln('Rata-rata dari data X = ',Rx:6:2);
writeln('Rata-rata dari data Y = ',Ry:6:2);
end.

Differences between the languages Borland Delphi

Because Borland Delphi is a widely used version of Pascal, it is useful to compare the two languages. Note that here are presented only the differences between Borland Delphi and the basic ISO 7185 standard. Undiscussed are any extensions provided by Borland Delphi. In other words, this section answers the question "why doesn't my standard Pascal program run under Borland Delphi?", and perhaps "what can I write in Borland Delphi that will also be compatible with the ISO 7185 standard?".

1. Procedures and functions may not appear as parameters (it is true that it can be done, but a non-standard syntax must be used).

2. Goto statements cannot reference targets outside procedure/function bodies (so called "intraprocedural gotos").

3. No file buffer variable handling. Standard Pascal has file "buffer variables", and "get" and "put" procedures to operate on them. This functionality is not present in Borland Delphi.

4. No "sized" dynamic variable allocation. Given a variant record, the size of a particular variant cannot be specified as per the standard. I.e., the following statement is invalid:

new(p, t)

Where t is a variant record tag type.

5. The functions "pack" and "unpack" are not implemented.

6. { and (*, } and *) are not synonyms of each other as required by the standard. Ie.:

{ comment *)

is not valid in Borland Delphi (Delphi uses the scheme of allowing the different comment types to indicate nested comments).

7. It is not possible to construct a standard program without compiler directives. At minimum:

{$APPTYPE CONSOLE}

is required.

8. Does not replace eoln with space as the standard requires. When reading through the end of a line, the eoln character is supposed to be replaced with a space in ISO 7185. Instead, reading through eoln in Borland Delphi gives the character code for carriage return (13), followed by line feed (10).

9. Numbers and booleans are not printed out in their "default" field widths, but are printed in the minimum amount of space. For example:

write('>', 5, '<');

Outputs:

>5<

in Delphi, but:

> 5<

(spaces depend on compiler integer width) in ISO 7185.

For booleans:

write('>', true, '<');

outputs:

>true<

in Delphi, but:

> true<

In ISO 7185.

Comparision of Pascal and Borland Delphi

Pascal is a programming language, developed in 1970 by Niklaus Wirth.

An alternative dialect was created by Borland Corporation. Their language went through several versions and names, such as Turbo Pascal, Borland Pascal, and finally Delphi Pascal.

This page briefly goes over the differences between those dialects of the language.

The title of this page "Comparison between Pascal and Delphi" was chosen because Borland uses the name "Delphi" exclusively for their version of the language. It is correct to refer to "Pascal" in general as Niklaus Wirth's original language (and derivatives) and Borland's dialect as "Delphi". When referring to Borland's previous dialects, the terms "Turbo Pascal", and "Borland Pascal" apply.

The Term ISO 7185 or ISO 7185 Pascal is used here as synonymous with Niklaus Wirth's programming language Pascal. The ISO 7185 standard is the standardized version of Niklaus Wirth's language, as he has stated several times.