Pascal Programming

Crypto

noreply@blogger.com (dazchild) — Fri, 6 Jun 2008 02:07:00 -0700

{
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

noreply@blogger.com (dazchild) — Fri, 6 Jun 2008 02:05:00 -0700

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

noreply@blogger.com (dazchild) — Thu, 5 Jun 2008 00:10:00 -0700

{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

noreply@blogger.com (dazchild) — Thu, 5 Jun 2008 00:08:00 -0700

{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

noreply@blogger.com (dazchild) — Thu, 5 Jun 2008 00:05:00 -0700

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

noreply@blogger.com (dazchild) — Thu, 5 Jun 2008 00:03:00 -0700

(**************************************************************)
(******* 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

noreply@blogger.com (dazchild) — Mon, 2 Jun 2008 02:05:00 -0700

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

noreply@blogger.com (dazchild) — Mon, 2 Jun 2008 02:02:00 -0700

(** 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

noreply@blogger.com (dazchild) — Mon, 2 Jun 2008 02:01:00 -0700

(*
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

noreply@blogger.com (dazchild) — Mon, 2 Jun 2008 02:00:00 -0700

{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

noreply@blogger.com (dazchild) — Mon, 2 Jun 2008 01:59:00 -0700
(** 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])

noreply@blogger.com (dazchild) — Mon, 2 Jun 2008 01:40:00 -0700

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

noreply@blogger.com (dazchild) — Mon, 2 Jun 2008 01:38:00 -0700
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?

noreply@blogger.com (dazchild) — Sat, 2 Feb 2008 22:13:00 -0800

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?

noreply@blogger.com (dazchild) — Sat, 2 Feb 2008 22:11:00 -0800

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

noreply@blogger.com (dazchild) — Sat, 2 Feb 2008 22:11:00 -0800
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

noreply@blogger.com (dazchild) — Sat, 2 Feb 2008 22:09:00 -0800
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?

noreply@blogger.com (dazchild) — Sat, 2 Feb 2008 22:09:00 -0800

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

noreply@blogger.com (dazchild) — Sat, 2 Feb 2008 22:06:00 -0800
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

noreply@blogger.com (dazchild) — Sat, 2 Feb 2008 22:04:00 -0800
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

noreply@blogger.com (dazchild) — Sat, 2 Feb 2008 22:01:00 -0800

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

noreply@blogger.com (dazchild) — Sat, 2 Feb 2008 21:58:00 -0800
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.

noreply@blogger.com (dazchild) — Sat, 24 Nov 2007 01:46:00 -0800

[edit] Pointers

Pascal supports the use of pointers:

type
a = ^b;
b = record
x: Integer;
y: Char;
z: a
end;
var
pointer_to_b: a;

Here the variable pointer_to_b is a pointer to the data type b, a record. Pointers can be used before they are declared. This is an exception to the rule that things must be declared before they are used. To create a new record and assign the values 10 and A to the fields a and b in the record, the commands would be;

new(pointer_to_b);

pointer_to_b^.x := 10;
pointer_to_b^.y := 'A';
pointer_to_b^.z := nil;
...

This could also be done using the with statement, as follows

new(pointer_to_b);
with pointer_to_b^ do
begin
x := 10;
y := 'A';
z := nil
end;
...

Note that inside of the scope of the with statement, the compiler knows that a and b refer to the subfields of the record pointer pointer_to_b and not to the record b or the pointer type a.

Linked lists, stacks and queues can be created by including a pointer type field (c) in the record (see also nil and null (computer)).

[edit] Control structures

Pascal is a structured programming language, meaning that the flow of control is structured into standard statements, ideally without 'go to' commands.

while a <> b do writeln('Waiting');

if a > b then
writeln('Condition met')
else
writeln('Condition false');

for i := 1 to 10 do writeln('Iteration: ', i:1);

repeat a := a + 1 until a = 10;

[edit] Procedures and functions

Pascal structures programs into procedures and functions.

program mine(output);
var i : integer;

procedure print(var j: integer);

function next(k: integer): integer;
begin
next := k + 1
end;

begin
writeln('The total is: ', j);
j := next(j)
end;

begin
i := 1;
while i <= 10 do print(i)
end.

Procedures and functions can nest to any depth, and the 'program' construct is the logical outermost block.

Each procedure or function can have its own declarations of goto labels, constants, types, variables, and other procedures and functions, which must all be in that order. This ordering requirement was originally intended to allow efficient single-pass compilation. However, in some dialects the strict ordering requirement of declaration sections is not required.

Language constructs 1

noreply@blogger.com (dazchild) — Sat, 24 Nov 2007 01:43:00 -0800

Pascal, in its original form, is a purely procedural language and includes the traditional array of Algol-like control structures with reserved words such as if, then, else, while, for, and so on. However, pascal also has many data structuring facilities and other abstractions which were not included in the original Algol60, like type definitions, records, pointers, enumerations, and sets. Such constructs were in part inherited or inspired from Simula67, Algol68, and Niklaus Wirth's own AlgolW.

[edit] Hello world

Pascal programs start with the program keyword with a list of external file descriptors as parameters; then follows the main statement block encapsulated by the begin and end keywords. Semicolons separate statements, and the full stop ends the whole program (or unit). Letter case is ignored in Pascal source. Some compilers, Turbo Pascal among them, have made the program keyword optional.

Here is an example of the source code in use for a very simple program:

program HelloWorld(output);
begin
writeln('Hello, World!')
end.

[edit] Data structures

Pascal's simple (atomic) types are real, integer, character, boolean and enumerations, a new type constructor introduced with Pascal:

var
r: Real;
i: Integer;
c: Char;
b: Boolean;
e: (apple, pear, banana, orange, lemon);

Subranges of any ordinal type (any simple type except real) can be made:

var
x: 1..10;
y: 'a'..'z';
z: pear..orange;

In contrast with other programming languages Pascal supports set type:

var
set1: set of 1..10;
set2: set of 'a'..'z';
set3: set of pear..orange;

A set is fundamental concept for modern mathematics, and many algorithms are defined with sets usage. So, an implementation of such algorithm is very suitable for Pascal. Also, set's operations may be realized faster. For example, for many Pascal compilers:

if i in [5..10] then
...

is faster, than

if (i>4) and (i<11) then
...

Types can be defined from other types using type declarations:

type
x = Integer;
y = x;
...

Further, complex types can be constructed from simple types:

type
a = Array [1..10] of Integer;
b = record
x: Integer;
y: Char
end;
c = File of a;

As shown in the example above, Pascal files are sequences of components. Every file has a buffer variable which is denoted by f^. The procedures get (for reading) and put (for writing) move the buffer variable to the next element. Read is introduced such that read(f, x) is the same as x:=f^; get(f);. Write is introduced such that write(f, x) is the same as f^ := x; put(f); The type text is predefined as file of char. While the buffer variable could be used to inspect the next character that would be used (check for a digit before reading an integer), this concept lead to serious problems with interactive programs with early implementations, but was solved later with the "lazy I/O" concept.

In Jensen & Wirth Pascal, strings are represented as packed arrays of chars; they therefore have fixed length and are usually space-padded. Some dialects have a custom string type.

Implementations Pascal

noreply@blogger.com (dazchild) — Sat, 24 Nov 2007 01:40:00 -0800

The first Pascal compiler was designed in Zurich for the CDC 6000 series mainframe computer family. Niklaus Wirth reports that a first attempt to implement it in Fortran in 1969 was unsuccessful due to Fortran's inadequacy to express complex data structures. The second attempt was formulated in the Pascal language itself and was operational by mid-1970. Many Pascal compilers since have been similarly self-hosting, that is, the compiler is itself written in Pascal, and the compiler is usually capable of recompiling itself when new features are added to the language, or when the compiler is to be ported to a new environment. The GNU Pascal compiler is one notable exception, being written in C.

The first successful port of the CDC Pascal compiler to another mainframe was completed by Welsh and Quinn at the Queen's University of Belfast in 1972. The target was the ICL 1900 computer.

The first Pascal compiler written in North America was constructed at the University of Illinois under Donald B. Gillies for the PDP-11 and generated native machine code. Pascal enjoyed great popularity throughout the 1970s and the 1980s.

In order to rapidly propagate the language, a compiler "porting kit" was created in Zurich that included a compiler that generated code for a "virtual" stack machine (i.e. code that lends itself to reasonably efficient interpretation), along with an interpreter for that code - the p-code system. Although the p-code was primarily intended to be compiled into true machine code, at least one system, the notable UCSD implementation, utilized it to create the interpretive UCSD p-System. The P-system compilers were termed P1-P4, with P1 being the first version, and P4 being the last.

A version of the P4 compiler, which created native binaries, was released for the IBM System/370 mainframe computer by the Australian Atomic Energy Commission; it was called the "AAEC Pascal Compiler" after the abbreviation of the name of the Commission. A version of P4 from 1975-6 (based on its internal code, it probably should be called "P5") including source and binaries for the compiler and run-time library files for the PDP-10 mainframe may be downloaded from this link.

In the early 1980s, Watcom Pascal was developed, also for the IBM System 370.

IP Pascal was an implementation of the Pascal programming language using Micropolis DOS, but was moved rapidly to CP/M running on the Z80. It was moved to the 80386 machine types in 1994, and exists today as Windows/XP and Linux implementations.

In the early 1980s, UCSD Pascal was ported to the Apple II and Apple III computers to provide a structured alternative to the BASIC interpreters that came with the machines.

Apple Computer created its own Lisa Pascal for the Lisa Workshop in 1982 and ported this compiler to the Apple Macintosh and MPW in 1985. In 1985 Larry Tesler, in consultation with Niklaus Wirth, defined Object Pascal and these extensions were incorporated in both the Lisa Pascal and Mac Pascal compilers.

In the 1980s Anders Hejlsberg wrote the Blue Label Pascal compiler for the Nascom-2. A reimplementation of this compiler for the IBM PC was marketed under the names Compas Pascal and PolyPascal before it was acquired by Borland. Renamed to Turbo Pascal it became hugely popular, thanks in part to an aggressive pricing strategy and in part to having one of the first full-screen Integrated development environments. Additionally, it was written and highly optimized entirely in assembly language, making it smaller and faster than much of the competition. In 1986 Anders ported Turbo Pascal to the Macintosh and incorporated Apple's Object Pascal extensions into Turbo Pascal. These extensions were then added back into the PC version of Turbo Pascal for version 5.5.

The inexpensive Borland compiler had a large influence on the Pascal community that began concentrating mainly on the IBM PC in the late 1980s. Many PC hobbyists in search of a structured replacement for BASIC used this product. It also began adoption by professional developers. Around the same time a number of concepts were imported from C in order to let Pascal programmers use the C-based API of Microsoft Windows directly. These extensions included null-terminated strings, pointer arithmetic, function pointers, an address-of operator and unsafe typecasts.

However, Borland later decided it wanted more elaborate object-oriented features, and started over in Delphi using the Object Pascal draft standard proposed by Apple as a basis. (This Apple draft is still not a formal standard.) Borland also called this Object Pascal in the first Delphi versions, but changed the name to Delphi Programming Language in later versions. The main additions compared to the older OOP extensions were a reference-based object model, virtual constructors and destructors, and properties. There are several other compilers implementing this dialect, see Object Pascal.

Turbo Pascal, and other derivatives with units or module concepts are modular languages. However, it does not provide a nested module concept or qualified import and export of specific symbols.

Super Pascal was a variant which added non-numeric labels, a return statement and expressions as names of types.

The universities of Zurich, Karlsruhe and Wuppertal have developed an EXtension for Scientific Computing (Pascal XSC), which provides a free solution for programming numerical computations with controlled precision.

In 2005, at the Web 2.0 conference, Morfik Technology introduced a tool which allowed the development of Web applications entirely written in Morfik Pascal. Morfik Pascal is a dialect of Object Pascal, very close to Delphi.