-Pascal : Konversi notasi persamaan matematis-

{*********************************************
* Program 3.4. (PROG3-4.PAS) *
* Konversi notasi persamaan matematis dari *
* notasi infix menjadi notasi postfix (RPN) *
*********************************************}
program KONVERSI_INFIX_KE_POSTFIX;

uses crt;

const Max_Elemen = 255;

type S255 = string[Max_Elemen];
Tumpukan = record
Rinci : S255;
Atas : 0..Max_Elemen
end;

var Infix : S255; {* notasi infix *}
Lagi : char;

{********************************************
* Fungsi untuk menentukan valensi operator *
********************************************}
function VALENSI (Tanda_Op : char) : integer;

begin
case Tanda_Op of
'$' : VALENSI := 3; {* pangkat *}
'*', '/' : VALENSI := 2; {* kali atau bagi *}
'+', '-' : VALENSI := 1; {* plus atau minus *}
'(' : VALENSI := 0 {* kurung buka *}
end
end; {* fungsi VALENSI *}

{************************************************
* Prosedur memasukkan elemen ke dalam tumpukan *
************************************************}
procedure PUSH (var T : Tumpukan; Elemen : char);

begin
T.Atas := T.Atas + 1;
T.Rinci[T.Atas] := Elemen
end; { *** prosedur PUSH *** }
{***********************************************
* Fungsi untuk mengambil elemen dari tumpukan *
*********************************************** }
function POP (var T : Tumpukan) : char;

begin
POP := T.Rinci[T.Atas];
T.Atas := T.ATas - 1
end; { *** fungsi POP *** }

{*************************************
* Prosedur untuk melalukan konversi *
* dan mencetak hasil *
*************************************}
procedure KONVERSI_CETAK (Infix : S255);

var I : integer;
Operator : set of char;
Temp, Kar : char;
T : Tumpukan;
Test : boolean;

begin
{* Himpunan operator yang diijinkan *}
Operator := ['$']+['*']+['/']+['+']+['-'];

{* Melakukan konversi *}
for I := 1 to length(Infix) do
begin
Kar := Infix[I];

{* Kurung buka. Push ke dalam tumpukan *}
if Kar = '(' then PUSH(T, Kar)

{* Kurung tutup. Pop semua elemen tumpukan *
* dan dicetak, sampai elemen atas tumpukan *
* adalah kurung buka. Pop juga elemen ini *
* tetapi tidak perlu ditulis. *}
else if Kar = ')' then
begin
while T.Rinci[T.Atas] <> '(' do
write(POP(T):2);
Temp := POP(T)
end

{* Operator. Test valensinya terhadap *
* valensi elemen atas tumpukan. Jika *
* valensinya lebih kecil, pop elemen atas *
* tumpukan sampai valensi elemen atas *
* tumpukan lebih kecil. Push operator ini *}

else if Kar in Operator then
begin
while (T.Atas <> 0) and (VALENSI(Kar) <= VALENSI(T.Rinci[T.Atas])) do
write(POP(T):2);
PUSH(T, Kar)
end

{* Operand. Langsung dicetak. *}
else if Kar <> ' ' then
write(Kar:2)
end;

if T.Atas <> 0 then
{* Tumpukan masih isi. Pop semua elemen *
* yang masih ada dalam tumpukan *}
repeat
write(POP(T):2)
until T.Atas = 0;
end; { *** prosedur KONVERSI_CETAK *** }

{*****************
* Program utama *
*****************}
begin
clrscr;
writeln('MENGUBAH NOTASI INFIX MENJADI POSTFIX');
writeln('DENGAN MEMANFAATKAN STRUKTUR TUMPUKAN');
writeln('-------------------------------------');
writeln;
repeat

{* Notasi infix yang akan dikonversikan *}
write('Masukkan ungkapan infix: ');
readln(Infix); writeln;
write('Ungkapan postfix: ');

{* Melakukan konversi dan mencetak hasil *}
KONVERSI_CETAK (Infix);

writeln; writeln;
write('Akan mencoba lagi? Y(a)/T(idak): ');
readln(Lagi);
writeln
until not (Lagi in ['Y', 'y'])
end. {* program utama *}

-Pascal: Prosedur-

{*****************************************
* Program 1.1. (PROG1-1.PAS) *
* Contoh program dengan sebuah prosedur *
* dan cara memanggilnya *
*****************************************}

program CONTOH; {* nama program *}

uses crt; {* deklarasi piranti *}

const Ukuran = 5; {* deklarasi konstanta *}

type Tabel = array[1..Ukuran,1..Ukuran] of integer;

{* Deklarasi perubah global *}
var Matrix : Tabel;

{* Prosedur *}
procedure BACA_MATRIX (var Mat : Tabel; N : integer);
var I, J : integer; {* perubah lokal *}

begin {* prosedur *}
for I := 1 to N do
for J := 1 to N do
read(Mat[I,J])
end; {* prosedur BACA_MATRIX *}

{* Prosedur Lain *}
procedure CETAK_MATRIX (Mat : Tabel; N : integer);
var I, J : integer; {* perubah lokal *}

begin {* prosedur *}
for I := 1 to N do
begin
for J := 1 to N do
write(Mat[I,J]:8);
writeln;
end;
end; {* prosedur CETAK_MATRIX *}

begin {* program utama *}
{* Memanggil prosedur *}
BACA_MATRIX(Matrix, Ukuran);
CETAK_MATRIX(Matrix, Ukuran)
end. {* program utama *}

-Pascal : Logistik-

Ini adalah aplikasi untuk Logistik :


Program Logistik;
Uses Wincrt, windos;

Type BarangMasuk= record
Bnyk : array[1..5] of integer;
end;
Type BarangKeluar= record
Bnyk : array[1..5] of integer;
end;
Type DataBarang = Record
Bnyk : array[1..5] of integer;

End;

Const
Hari:array[0..6] of string[9] =
('Minggu', 'Senin','Selasa','Rabu','Kamis','Jumat','Sabtu');
Jns:array[1..5] of string[9] =
('Beras','Pakaian','Minyak','Mi','Jajan');
Satuan:array[1..5] of string[5]=
('Kg','Helai','Lt','Bngks','Bngks');


Var FileBrg : File Of DataBarang;
FileM : File Of BarangMasuk;
FileK : File Of BarangKeluar;
Data : DataBarang;
DtMasuk : BarangMasuk;
DtKeluar : BarangKeluar;
Pil,Ul : Char;
year, m, d, dow :word;
i : Integer;
TBnyk:array[1..5] of integer;

label awal;
procedure PadString(S: String; PadLen: Integer);
begin
Write(S, ' ':PadLen - Length(S));
end;

Procedure BukaFile;
Begin
Assign(FileBrg,'Brg.Dat');
{$I-};
Reset(FileBrg);
{$I+};
End;
Procedure BukaFileMasuk;
Begin
Assign(FileM,'BrgMasuk.Dat');
{$I-};
Reset(FileM);
{$I+};
End;
Procedure BukaFileKeluar;
Begin
Assign(FileK,'BrgKeluar.Dat');
{$I-};
Reset(FileK);
{$I+};
End;


Procedure MENU;
Begin
clrscr;
Gotoxy(34,1);write('MENU PILIHAN');
Gotoxy(34,2);write('============');
Gotoxy(27,4);write('1. Masukan Barang');
Gotoxy(27,5);write('2. Keluarkan Barang ');
Gotoxy(27,6);write('3. Tampilkan Data');
Gotoxy(27,10);write('9. Keluar(Exit)');
Gotoxy(32,12);write('Pilihan[1..9]:');Pil:=Readkey;
End;

{TAMBAH-------------------------TAMBAH}
Procedure Tambah;
Var Lagi : Char;
i,j, banyak : Integer;
Code, jenis, satuan : String;
label cek;

Begin
Lagi :='Y';

BukaFile;
If IOResult<>0 Then
Rewrite(FileBrg);
Repeat
Clrscr;
BukaFile;
If IOResult<>0 Then begin
Rewrite(FileM); end;

writeln(' MASUKAN BARANG ');
Writeln(' ==========================');
getDate(year,m,d,dow);
writeln(Hari[dow],' ', M:0, '-', d:0, '-', year:0);
writeln;

write('Nama Atau Jenis Barang : ');Readln(Jenis);
for j:=1 to Length(Jenis) do begin
Jenis[j]:=Upcase(jenis[j]);
end;

if Jenis='BERAS' then begin i:=1; end
else if Jenis='PAKAIAN' then begin i:=2; end
else if Jenis='MINYAK' then begin i:=3; end
else if Jenis='MI' then begin i:=4; end
else if Jenis='JAJAN' then begin i:=5; end
else begin Writeln('Jenis Barang Yang Akan Dimasukan, Tidak Boleh Masuk Ke Gudang');
goto cek;
end;
write('Banyak Barang : ');Readln(Banyak);
Data.Bnyk[i]:=Data.Bnyk[i]+Banyak;
write(FileBrg,Data);
close (FileBrg);

BukaFileMasuk;
If IOResult<>0 Then begin
Rewrite(FileM); end;

DtMasuk.Bnyk[i]:=DtMasuk.Bnyk[i]+Banyak;
write(FileM,DtMasuk);
close (FileM);
cek:
write('Mau Tambah Data Lagi [y/t]:');Lagi:=Upcase(Readkey);

Until Lagi <> 'Y';
Clrscr;
Writeln('Barang berhasil masuk tanggal ', M:0, '-', d:0, '-', year:0);

writeln;
Writeln(' ===================================');
Writeln('| NO | Jenis | Banyak Barang |');
Writeln(' ===================================');
for j:=1 to 4 do begin
Write('|',j:2,' | ');PadString(Jns[j],12);Writeln('| ',DtMasuk.Bnyk[j],' ':5,' |');
end;
Writeln(' ===================================');
Writeln;
Write('Tekan Tombol Apapun Untuk Melanjutkan');Readkey;
End;
{ENDTAMBAH-------------------------ENDTAMBAH}

{Keluar-------------------------------Keluar}
Procedure keluar;
Var FileBrgKluar : File Of DataBarang;
Lagi,Klr : Char;
Ada : Boolean;
i,j : Integer;
Banyak : Integer;
Jenis : String;
label
cek;
Begin
Ul :='Y';
Lagi :='Y';
Clrscr;
BukaFile;
If IOResult <> 0 Then begin
Write('Maaf Data Masih Kosong!');
Readkey;
end
else begin
Repeat


Writeln(' BARANG KELUAR ');
Writeln(' ==========================');
getDate(year,m,d,dow);
writeln(Hari[dow],' ', M:0, '-', d:0, '-', year:0);
writeln;
write('Jenis Barang : ');Readln(Jenis);

Read(FileBrg,Data);
for j:=1 to Length(Jenis) do begin
Jenis[j]:=Upcase(jenis[j]);end;
if Jenis='BERAS' then begin i:=1; end
else if Jenis='PAKAIAN' then begin i:=2; end
else if Jenis='MINYAK' then begin i:=3; end
else if Jenis='MI' then begin i:=4; end
else if Jenis='JAJAN' then begin i:=5; end
else begin Writeln('Jenis Barang Yang Akan Dikelurakan, Tidak Ada Di Gudang');
goto cek; end;

write('Berapa banyak : ');Readln(Banyak);
if Banyak>Data.Bnyk[i] then begin writeln('Barang Yang Diminta Tidak Cukup'); goto Cek; end

else begin
Data.Bnyk[i]:=Data.Bnyk[i]-Banyak;
write(FileBrg,Data);
close (FileBrg);

BukaFileKeluar;
If IOResult<>0 Then begin
Rewrite(FileK); end;

DtKeluar.Bnyk[i]:=DtKeluar.Bnyk[i]+Banyak;
write(FileK,DtKeluar);
close (FileK);
writeln(Jenis,' Keluar, Sebanyak ', Banyak);end;

Cek:
writeln('Mau Mengeluarkan Barang Lagi [Y/T]:');
Lagi:=Upcase(Readkey);

Until Lagi <> 'Y';
Clrscr;
Writeln('Barang berhasil masuk keluar', M:0, '-', d:0, '-', year:0);

writeln;
Writeln(' ===================================');
Writeln('| NO | Jenis | Banyak Barang |');
Writeln(' ===================================');
for j:=1 to 4 do begin
Write('|',j:2,' | ');PadString(Jns[j],12);Writeln('| ',DtKeluar.Bnyk[j],' ':5,' |');
end;
Writeln(' ===================================');
Writeln;
Write('Tekan Tombol Apapun Untuk Melanjutkan');Readkey;

End;
end;
{KELUAR END----------------------------------------------------KELUAR END}

Procedure Tampil;
Var j :Integer;

Begin
clrscr;
BukaFile;
If IOResult <> 0 Then begin
Write('Maaf Data Masih Kosong!');
Readkey;
end
Else
Begin


Writeln(' DATA BARANG ');
Writeln(' ===================================');
getDate(year,m,d,dow);
writeln(Hari[dow],' ', M:0, '-', d:0, '-', year:0);
writeln;
Writeln(' ===================================');
Writeln('| NO | Jenis | Banyak Barang |');
Writeln(' ===================================');
Read(FileBrg,Data);
for j:=1 to 4 do begin

Write('|',j:2,' | ');PadString(Jns[j],12);Writeln('| ',Data.Bnyk[j],' ':5,' |');
end;
Writeln(' ===================================');
Writeln;
Write('Tekan Tombol Apapun Untuk Melanjutkan');Readkey;
end;
end;

Begin
awal:
Repeat
Menu;
Case Pil Of
'1' : Tambah;
'2' : Keluar;
'3' : Tampil;
End;
Until (Pil='9');
DoneWinCrt;
End.