Membuat List dengan Pascal

Program JUmlah_Dua_Integer;

Uses Crt;
Const Max = 80;

Type Str80 = string[Max];
     Simpul = ^Data;
     Data   = rECORD
                 Info  : Char;
                 Kiri,Kanan  : Simpul
              End;

Var Bilangan1,
    Bilangan2,
    Bilangan3 : Simpul;
    Angka1,
    Angka2    : Str80;
    I         : Integer;
    Lagi      : char;

Function CEK_BILANGAN(Bil : Str80): boolean;
Var  I        : Integer;
     Angka    : set of char;
     Valid    : boolean;

begin
     Angka    := ['0'..'9'];
     valid    := true;
     for I :=1 to length(Bil) do
         if not(BIL[I] in Angka) then
            begin
              Valid := False;
              I := length(Bil)
            end;
      Cek_Bilangan := valid;
end;

Procedure Awalan(Var Baru : Simpul);

Begin
  New(Baru);
  With Baru^ do
     begin
       Info := char(32);
       Kiri := Baru;
       Kanan := kiri
     end;
end;

Procedure BUAT_LIST(Var List  : Simpul;
                        Bil   : Str80);
var I,Cch_Kar,J,Kode : Integer;
    Baru : Simpul;

Begin
    for I := 1 to length(Bil) do
        begin
          AWALAN(BARU);
          Val(Bil[I],J,Kode);
          Baru^.Info :=chr(J);
          Baru^.Kiri :=List^.Kiri;
          Baru^.Kanan :=List;
          List^.Kiri^.Kanan := Baru;
          List^.Kiri := Baru;
        end;
        List^.Info := chr(length(Bil))
end;

Procedure BACA (Kepala : Simpul);
Var Bantu  : Simpul; Kode  : Integer;

Begin
Bantu := Kepala^.Kanan;

Repeat
  Kode := ord(Bantu^.Info);
  If Kode = 32 then
     Write(' ')
  else
     Write(Kode);
  Bantu := Bantu^.Kanan
Until Bantu = Kepala;
Writeln
End;

Procedure CEK_OPERAND(Var Bil1, Bil2 : Simpul);
Var Jml1,Jml2 : Integer;

Procedure TAMBAH_NOL(Var T : Simpul; C : Integer);
Var Baru : Simpul;
      I  : Integer;

Begin
   For I := 1 to C do
     Begin
       AWALAN(Baru);
       Baru^.Kiri :=T;
       Baru^.Kanan := T^.Kanan;
       T^.Kanan^.Kiri := Baru;
       T^.Kanan := Baru;
       T^.Info := chr(ord(T^.Info)+1)
     end
end;


begin
   jml1  := ord(Bil1^.Info);
   jml2  := ord(Bil2^.Info);
   if jml1 <> jml2 then

   Tambah_Nol(Bil1,Jml1-Jml2)
   Else
   Tambah_Nol(Bil1,Jml1-Jml1)
End;

Procedure HASIL(Var Bil1, Bil2, Bil3 : Simpul);
Var Sisa, Jumlah, Dgt,Dgt1  : Integer;
    Bantu1, Bantu2, Baru    : Simpul;

Procedure OPER;

    Begin
      Baru^.Kanan  := Bil3^.Kanan;
      Baru^.Kiri   := Bil3;
      Bil3^.Kanan^.Kiri := Baru;
      Bil3^.Kanan  := Baru;
    End;

    Begin
      Bantu1   := Bil1^.Kiri;
      Bantu2   := Bil2^.Kiri;
      Sisa := 0;

    {Program proses 2 Bilanagn}
    Repeat

        Dgt := Ord(Bantu1^.Info);
        Dgt1 := Ord(Bantu2^.Info);
        if Dgt1 = 32 then Dgt1 :=0;
        if Dgt = 32 then Dgt :=0;

        Jumlah := Dgt + Dgt1 + Sisa;

        If Jumlah >= 10 then
           begin
              Jumlah := jumlah - 10;
              Sisa := 1
           end

        Else
        Sisa := 0;
        New(Baru);
        Baru^.Info := chr(Jumlah);
        Oper;
        Bantu1 := Bantu1^.Kiri;
         Bantu2 := Bantu2^.Kiri;
  Until Bantu1 = Bil1;

  If Sisa = 1 then
     Begin
       AWALAN(Baru);
       Baru^.INFO := chr(sisa);
       OPER;
       AWALAN(Baru); AWALAN(Bantu1);
       BARU^.Kanan := Bil1^.Kanan;
       BARU^.Kiri := Bil1;
       BARU^.Kanan := Baru;
       Bantu1^.Kanan := Bil2^.Kanan;
       Bantu1^.Kiri := Bil2;
       Bil2^.Kanan^.Kiri := Bantu1;
       Bil2^.Kanan := Bantu1;
       Bil1^.Info := Chr(ord(Bil1^.Info)+1);
     end;
 end;

{ Program Utama }

Begin
   Repeat
     clrscr;

     Writeln('CONTOH PENGGUNAAN SENARAI BERANTAI PENJUMAHAN 2 BIL');
     wRITEln('---------------------------------------------------');
     write('Bilangan pertama : ');Readln(Angka1);
     write('Bilangan kedua   : ');Readln(Angka2);
     Writeln;

      if  CEK_BILANGAN(Angka1) and
        CEK_BILANGAN(Angka2) then

     begin
         Awalan(Bilangan1); Awalan(Bilangan2);
         Awalan(Bilangan3);
         BUAT_LIST(Bilangan1,Angka1);
         BUAT_LIST(Bilangan2,Angka2);

         Cek_Operand(Bilangan1,Bilangan2);

         HASIL(Bilangan1,Bilangan2,Bilangan3);

         Writeln; Writeln('Hasil perhitungan ');
         Writeln;
         BACA(Bilangan1);BACA(bilangan2);

              For I := 1 to ord(Bilangan1^.Info) do
                Write('-');
              Write(' + ');Writeln;BACA(Bilangan3)
           end
       Else
          Writeln('Ada Karakter tdk sah');
          Writeln; Writeln('Akan coba Lagi ? (Y/T) : ');
          Readln(Lagi);
       Until Not (Lagi in ['Y','y']);
       Readln
End.
Selamat Mencoba....
Semoga Berhasil....

Read More

Membuat Balik Kata dengan Pascal

Program BALIK_KALIMAT;
Uses crt;

Const Elemen      = 255;
Type S255         = String[Elemen];
     Tumpukan     = record
                          Isi   :S255;
                          Atas  : 0..Elemen;
                          end;
var T             : Tumpukan;
    I             : Integer;
    Kalimat       : S255;

{Prosedur inisial Tumpukan}
Procedure Awalan (Var T : Tumpukan);

Begin
T.Atas  :=0;
end;
{Prosedure untuk memasukan kedalam Tumpukan}
Procedure PUSH (var T: Tumpukan; X: char);
Begin
     T.Atas := T.Atas + 1;
     T.Isi[T.atas] :=X
     END;

{Fungsi untuk me('ngambil elemen dari Tumpukan}
Function POP(var T: Tumpukan): char;
Begin
     POP :=T.Isi[T.Atas];
     T.Atas := T.Atas - 1
     end;

{Program Utama}
Begin;
Clrscr;
Awalan(T);
Writeln('Tumpukan untuk membalik Kalimat');
Writeln;

{Kalimat yang akan dibalik}
Write ('Isi Kalimat Sembarang : ');
readln(Kalimat);

Clrscr;
Writeln('Kalimat Asli :'); Writeln(Kalimat);
Writeln; Writeln ('Setelah dibalik : ');

       {Mempush kalimat ke dalam tumpukan}
       For I := 1 to length(Kalimat) do
       push (T, Kalimat[I]);

        {Mempop Tumpukan shg diperoleh kalimat terbalik}
       For I := 1 to length(Kalimat) do
        Write(POP(T));
        Writeln;

        Readln;
        end.

Read More

Membuat Antrian dengan Pascal

Program ILUSTRASI_ANTRIAN;

uses crt;

const Max_Elemen = 10;

type Antri = array[1..Max_Elemen] of char;

Var Antrian      : Antri;
    Depan,
    Belakang,
    pilih        : integer;
    Elemen       : char;

{ Prosedur untuk menggambar kotak antrian }

procedure KOTAK;
var I : integer;

Begin
  gotoxy(20,15);
  for I := 1 to Max_Elemen*4 + 1 do write('-');
  gotoxy(20,16);
  for I := 1 to Max_Elemen do write ('! ');
  writeln('!'); gotoxy(20,17);

  For I := 1 to Max_Elemen*4 + 1 do
  gotoxy(8,16); write(',<---- Keluar');
  gotoxy(22+Max_Elemen*4+1,16);
  writeln('<-----');
end;

{Prosedur  utk meletak: kan elemnen dalam kotak antrian}
procedure LETAKKAN (x : char; R : Integer);

begin
  gotoxy(18+4*R,16);
  write(X)
end;

{Fungsi ntuk cek keadaan Antrian}

Function Kosong(Q : Antri) : boolean;
BEGIN
  Kosong := (Depan = Belakang)
End;

{Prosedur namabah antrian baru jk blm penuh}

Procedure Tambah(var Antrian : Antri; X : char);

Begin
  if Belakang = Max_Elemen then Belakang := 1
  else Belakang := Belakang + 1;

  if not(KOSONG(Antrian)) then
  begin
    Antrian[Belakang] :=X;
    LETAKKAN (x,bELAKANG)
  END
  Else
    {Antrian penuh}
    Begin
      gotoxy(40,9);
      Write('ANTRIAN SUDAH PENUH');

      repeat
      until keypressed;

      gotoxy(40,9);
      write(' ',30); Belakang := Belakang - 1;
      if Belakang = 0 then
         Belakang := Max_Elemen
    end
End;

{Prosedur hapus Elemen}

function HAPUS(Var Antrian : Antri) : Char;
begin
  if Depan = Max_Elemen then
     Depan := 1
  else
     begin
       Depan := Depan + 1;
       HAPUS := Antrian[depan]
     end
end;

{Program Utama}

Begin

  Clrscr;
  Kotak;
  Depan := 0; Belakang := 0;
  repeat
    for Pilih := 5 to 9 do;
      begin
        gotoxy(40, pilih); write(' ':39)
      end;
  gotoxy(1,1);
  Writeln('DAFTAR MENU PILIHAN');
  Writeln('-------------------');
  Writeln;
  Writeln(' 1. Nambah Elemen Baru ');
  Writeln(' 2. Menghapus Elemen');
  Writeln(' 3. Selesai');
  Writeln; Writeln;
  Writeln(' Pilih salah satu');
  Repeat
     gotoxy(22,9); writeln(' ');
     gotoxy(22,9); readln(pilih)
  Until (pilih >= 1) and (Pilih <= 3);
  case pilih of
      {milih aktifitas}
      1 : begin
          {Nambah elemen ke dalam antrian}
          gotoxy(40,6);
          writeln('Namhah Elemen');
          Writeln('-------------');
          gotoxy(40,8);
          write('Isikah Elemen: ');
          gotoxy(40,9);
          write('Isikan Elemenya : ');
          Readln(Elemen);
          TAMBAH(Antrian,Elemen);
          end;

       2 : Begin
             {Hapus Elemen dari Antrian}
             If not (KOSONG(Antrian)) then
                begin
                  Elemen := Hapus(Antrian);
                  LETAKKAN(' ',Depan)
                END
             else
                begin
                  gotoxy(30,9);
                  writeln('ANTRIAN KOSONG ....');
                  Elemen := readkey;
                  gotoxy (30,9); write(' ':30)
                end
            end
end;
     until pilih = 3
end.

Silahkan dicoba ...
Semoga Berhasil 

Read More