Program Berantai Dalam Pascal

Program Berantai;

uses crt;

Type

 Ptrdata =^recordData;

 stringNama = STRING[20];

 RecordData = record

               Nama     : StringNama;

               Jabatan  : STRING [15];

               Lanjutan : ptrData ;

               end;

 var

  ptrAwalHeap : pointer;

  ptrKepala : ptrData;

Procedure BentukDaftar (Var ptrkepala : ptrdata);

Var

 Ptrbaru : PtrData;

 Jawaban : char;

begin

repeat

clrscr;

New(ptrbaru);

Write ('Nama pegawai : ');

Readln (ptrbaru^.nama);

Write ('Jabatan      : ');

Readln (ptrbaru^.jabatan);

Ptrbaru^.lanjutan := ptrkepala;

Ptrkepala := ptrbaru;

Write ('Masukan data lagi (Y/T) ? : ');

Repeat

Jawaban := Upcase (readkey)

Until jawaban IN ['Y','T'];

Writeln (jawaban);

Until jawaban ='T';

end;

Procedure CetakDaftar (ptrkepala : ptrdata);

var

Ptrsementara  : ptrdata;

begin

clrscr;

Writeln ('Isi Daftar Berantai : '); Writeln;

Writeln ('............................................................');

Writeln (' N A M A ' : 20,'J A B A T A N ':26);

Writeln ('............................................................');

Ptrsementara := ptrkepala;

While ptrsementara <> NIL Do

With ptrsementara^Do

Begin

Writeln (nama:20,jabatan:26);

Ptrsementara := lanjutan;

End;

Writeln ('............................................................');

Writeln('tekan Return'); Readln;

End;

Procedure Caridata (ptrkepala:ptrdata;namadicari:stringnama;

var ptrpraposisidata,ptrposisidata:ptrdata);

{untuk mencari data nama dicari pada daftar berantai, hasil}

{-jika data ketemu,maka}

{1. ptrposisidata menunjuk simpul dari data yang dicari}

{2. ptrpraposisidata menunjuk simpul sebelum data yang dicari}

{atau sama dengan NIL, jika ptrposisidata menunjuk yang juga ditunjuk}

{oleh ptrkepala}

{- jika tidak ditemukan,maka ptrposisidata sama dengan NIl}

Var

Ketemu : Boolean;

Begin

PtrPraposisidata := NIL;

PtrPosisidata := ptrkepala;

Ketemu := False;

While (Not ketemu And (ptrposisidata <> NIL)) Do

If Ptrposisidata^.nama <> namadicari Then

Begin

Ptrposisidata := ptrposisidata;

Ptrposisidata := ptrposisidata^.lanjutan

end

else

Ketemu := True;

End;

Procedure HapusIsiDaftar (Var ptrkepala:ptrdata);

Const

String_kosong='';

Var

Namadicari : stringnama;

Ptrposisidata,

Ptrpraposisidata : ptrdata;

Begin

Clrscr;

Writeln ('Masukan nama pegawai dari data yang akan dihapus :');

Readln (namadicari);

If namadicari= string_kosong Then

Exit;

Caridata (ptrkepala, namadicari, ptrpraposisidata, ptrposisidata);

If ptrposisidata = NIL Then

Begin

Writeln ('Data tak ditemukan, tekan enter untuk melanjutkan ');

Readln;

End;

Begin

{Proses penghapusan}

If ptrpraposisidata = NIL then

{simpul yang ditunjukan ptrkepala dihapus}

ptrkepala := ptrkepala^.lanjutan

else

{bukan simpul yang ditunjuk ptrkepala dihapus}

Writeln ('Ok........data sudah dihapus. Tekan enter');

end;

end;{akhir procedure hapusisidaftar}

 Procedure prosesPilihan (var ptrKepala : ptrdata);

 var

  Pilihan : char;

 Begin

  Repeat

   Clrscr;

   TEXTATTR := $70;

   Gotoxy (20,2); WRITE ('     pilihan proses   ');

   TEXTATTR := $07;

 Gotoxy (20,4) ; write ('[1]memasukkan /menambah data');

 Gotoxy (20,5) ; write ('[2]menampilkan isi daftar berantai');

 Gotoxy (20,6) ; write ('[3]menghapus data pada daftar berantai');

 Gotoxy (20,7) ; write ('[4]selesai');

 Gotoxy (20,8) ; write ('..............................................');

 Gotoxy (25,9) ; write ('[1]masukkan kode pilihan [1..4] : ');

Repeat

 Pilihan := UPCASE (READKEY)

UNTIL pilihan IN ['1'..'4'];

Write (pilihan);

CASE pilihan OF

 '1' : BentukDaftar (ptrKepala);

 '2' : Cetakdaftar (ptrKepala);

 '3' : HapusIsiDaftar (ptrKepala);

END;

Until pilihan ='4'

end;

{*program utama*}

Begin

 Mark (PtrAwalHeap) ;

 ptrKepala := NIL;

ProsesPilihan (ptrKepala);

RELEASE (ptrAwalHeap) ;

End.

Program Berantai;

uses crt;

Type

 Ptrdata =^recordData;

 stringNama = STRING[20];

 RecordData = record

               Nama     : StringNama;

               Jabatan  : STRING [15];

               Lanjutan : ptrData ;

               end;

 var

  ptrAwalHeap : pointer;

  ptrKepala : ptrData;

Procedure BentukDaftar (Var ptrkepala : ptrdata);

Var

 Ptrbaru : PtrData;

 Jawaban : char;

begin

repeat

clrscr;

New(ptrbaru);

Write ('Nama pegawai : ');

Readln (ptrbaru^.nama);

Write ('Jabatan      : ');

Readln (ptrbaru^.jabatan);

Ptrbaru^.lanjutan := ptrkepala;

Ptrkepala := ptrbaru;

Write ('Masukan data lagi (Y/T) ? : ');

Repeat

Jawaban := Upcase (readkey)

Until jawaban IN ['Y','T'];

Writeln (jawaban);

Until jawaban ='T';

end;

Procedure CetakDaftar (ptrkepala : ptrdata);

var

Ptrsementara  : ptrdata;

begin

clrscr;

Writeln ('Isi Daftar Berantai : '); Writeln;

Writeln ('............................................................');

Writeln (' N A M A ' : 20,'J A B A T A N ':26);

Writeln ('............................................................');

Ptrsementara := ptrkepala;

While ptrsementara <> NIL Do

With ptrsementara^Do

Begin

Writeln (nama:20,jabatan:26);

Ptrsementara := lanjutan;

End;

Writeln ('............................................................');

Writeln('tekan Return'); Readln;

End;

Procedure Caridata (ptrkepala:ptrdata;namadicari:stringnama;

var ptrpraposisidata,ptrposisidata:ptrdata);

{untuk mencari data nama dicari pada daftar berantai, hasil}

{-jika data ketemu,maka}

{1. ptrposisidata menunjuk simpul dari data yang dicari}

{2. ptrpraposisidata menunjuk simpul sebelum data yang dicari}

{atau sama dengan NIL, jika ptrposisidata menunjuk yang juga ditunjuk}

{oleh ptrkepala}

{- jika tidak ditemukan,maka ptrposisidata sama dengan NIl}

Var

Ketemu : Boolean;

Begin

PtrPraposisidata := NIL;

PtrPosisidata := ptrkepala;

Ketemu := False;

While (Not ketemu And (ptrposisidata <> NIL)) Do

If Ptrposisidata^.nama <> namadicari Then

Begin

Ptrposisidata := ptrposisidata;

Ptrposisidata := ptrposisidata^.lanjutan

end

else

Ketemu := True;

End;

Procedure HapusIsiDaftar (Var ptrkepala:ptrdata);

Const

String_kosong='';

Var

Namadicari : stringnama;

Ptrposisidata,

Ptrpraposisidata : ptrdata;

Begin

Clrscr;

Writeln ('Masukan nama pegawai dari data yang akan dihapus :');

Readln (namadicari);

If namadicari= string_kosong Then

Exit;

Caridata (ptrkepala, namadicari, ptrpraposisidata, ptrposisidata);

If ptrposisidata = NIL Then

Begin

Writeln ('Data tak ditemukan, tekan enter untuk melanjutkan ');

Readln;

End;

Begin

{Proses penghapusan}

If ptrpraposisidata = NIL then

{simpul yang ditunjukan ptrkepala dihapus}

ptrkepala := ptrkepala^.lanjutan

else

{bukan simpul yang ditunjuk ptrkepala dihapus}

Writeln ('Ok........data sudah dihapus. Tekan enter');

end;

end;{akhir procedure hapusisidaftar}

 Procedure prosesPilihan (var ptrKepala : ptrdata);

 var

  Pilihan : char;

 Begin

  Repeat

   Clrscr;

   TEXTATTR := $70;

   Gotoxy (20,2); WRITE ('     pilihan proses   ');

   TEXTATTR := $07;

 Gotoxy (20,4) ; write ('[1]memasukkan /menambah data');

 Gotoxy (20,5) ; write ('[2]menampilkan isi daftar berantai');

 Gotoxy (20,6) ; write ('[3]menghapus data pada daftar berantai');

 Gotoxy (20,7) ; write ('[4]selesai');

 Gotoxy (20,8) ; write ('..............................................');

 Gotoxy (25,9) ; write ('[1]masukkan kode pilihan [1..4] : ');

Repeat

 Pilihan := UPCASE (READKEY)

UNTIL pilihan IN ['1'..'4'];

Write (pilihan);

CASE pilihan OF

 '1' : BentukDaftar (ptrKepala);

 '2' : Cetakdaftar (ptrKepala);

 '3' : HapusIsiDaftar (ptrKepala);

END;

Until pilihan ='4'

end;

{*program utama*}

Begin

 Mark (PtrAwalHeap) ;

 ptrKepala := NIL;

ProsesPilihan (ptrKepala);

RELEASE (ptrAwalHeap) ;

End.

Program Binary_Tree

Program Binary_Tree;
Uses crt;
Type
 Ptr    = ^Pohon ;
 Pohon  = Record
             Isi        : byte;
             Left,Right : ptr;
          End;
Var
 Root,Now : ptr;
 x,y,cari : byte;

Procedure Push(var Tree:ptr; data,level:byte);
Var now : ptr;
 Begin
  If tree = nil then
   Begin
    New(Now);
    Now^.isi   := data;
    Now^.left  := nil;
    Now^.right := nil;
    Tree := Now;
   End else
  If data < Tree^.isi then
   Push (Tree^.left,data,level)
  else
  If data >=Tree^.isi then
   Push (Tree^.right, data,level)
 End;

Procedure Input(var Tree:ptr; Nilai, selisih, Level : byte);
Var x : byte;
 Begin
  If (level < 6) then
   Begin
    Push(Tree,Nilai,Level);
    Input (Tree^.left, Nilai-selisih, selisih div
   2,level+1);
    Input(Tree^.Right,Nilai+selisih, selisih div
   2,level+1);
    End;
  End;

Procedure Show (var Tree:ptr; x,y,sel:byte);
Var i:byte;
Begin
  Gotoxy(x,y); write(Tree^.isi);
  If (Tree^.left <> nil) or (Tree^.right <> nil) then
    Begin
     Gotoxy(x-sel, y+1); write('| ');
     Gotoxy(x+sel, y+1); write('| ');
     For I :=  (x-sel)+1 to (x+sel)-1 do
      Begin
       Gotoxy(I,y+1); write('-');
      End;
       Gotoxy(x,y+1); write('| ');
    End;
  Inc(y,2);
  If Tree^.left <> nil then
    Show(Tree^.left, x-sel, y, sel div 2);
  If Tree^.Right <> nil then
    Show(Tree^.Right, x+sel, y, sel div 2);
End;

Procedure Search (var Tree:ptr; X,Y, Selisih, cari:byte);
Begin
 Inc (y,2);
 If cari < Tree^.isi then
 Begin
   If Tree^.left <> nil then
  Search(Tree^.Left, x-selisih, y, selisih div 2, cari)
 End else
 If cari > Tree^.Isi then
   Begin
     If Tree^.Right <> nil then

   Search(Tree^.Left, x+selisih, y, selisih div 2, cari)
 End else
 If cari = Tree^.isi then
   Begin
     Dec(y,2);
     Gotoxy(x,y); textcolor(10); write(cari); readkey;
     Gotoxy(x,y); textcolor(15); write(cari);
   End;
 If( (Tree^.left=nil) or (Tree^.right=nil)) and (cari <>
      Tree^.isi) then
   Begin
     Gotoxy(2,2); write('Data Tidak Ada'); readkey;
     Gotoxy(2,2); ClrEol;
   End;
 End;

Procedure CursorOff;assembler;
  Asm
    Mov ah,1
    Mov cx,0100h;
    Int 10h;
  End;
Procedure CursorOn;assembler;
  Asm
    Mov ah, 1
    Mov cx,0607h;
    Int 10h;
  End;

{*Program Utama*}
Begin
  Clrscr;
  Textcolor(15);
  Randomize;
  X := random(20);
    Input (Root, x+30, (x+30) div 2,1);
    Repeat
      Show (Root,40, 5, 20);
      Gotoxy(2,1); clreol;write ('find 0 = Quit :   ');
      Readln(cari);
      Now := Root; x:=40; y:=5;
      cursorOff;
      if cari <> 0 then search(Now,x,y,20,cari);
      cursorOn;
    until cari = 0;
end.