program pascal antrian

 uses crt;
 var x:array[1..10] of string;
     i,n,pil:integer;
     procedure masuk;
     begin if (n=10) then writeln('sudah penuh') else
        begin n:=n+1;
              readln(x[n]);
        end;
    end;
    procedure keluar;
    begin
        for i:=1 to n-1 do x[i]:=x[i+1];
        n:=n-1;
    end;
    procedure cetak; begin for i:=1 to n do writeln(x[i]);readln;end;
 

program pascal "toko barang"

program toko_maju;
uses crt;
type barang=record
     nama,satuan:string;
     harga:longint;
     stok:byte;
     end;
   
      larik_barang=array[1..20] of barang;
type jual=record
    nama_j:string;
    harga_j:integer;
    jum: byte;
    total:real;
    end;
    larik_jual=array[1..20] of jual;

var bar:larik_barang;jual_brg:larik_jual;
        i,n,m:byte;
        pil:1..10;
        pendapatan:real;

procedure tambah_bar(var x:larik_barang);
var nama_bar:string;
    ketemu:boolean;
begin
ketemu:=false;
write('masukan nama barang yang baru ');readln(nama_bar);
{cek apakah nama_bar sudah ada}
for i:=1 to n do
    if (x[i].nama=nama_bar) then ketemu:=true;
if not ketemu then
begin
    inc(n);
    x[n].nama:=nama_bar;
    write('satuan ? ');readln(x[n].satuan);
    write('harga satuan ? ');readln(x[n].harga);
end
else writeln('barang sudah ada didaftar');
end;

procedure tambah_stok(var x:larik_barang);
var nama_bar:string;
    tamstok,posisi:byte;
    ketemu:boolean;
begin
write(' masukkan nama barang yang akan ditambah stok==>');
readln(nama_bar);
{cek didalam array apakah nama tsb sudah ada diatas belum}
ketemu:=false;
for i:=1 to n do
    if (x[i].nama=nama_bar) then begin ketemu:=true;posisi:=1;end;
if ketemu then
{lakukan penambahan stok}
begin
    write('barang ',nama_bar,' ditambah stok sbanyak = ');
    readln(tamstok);
    x[posisi].stok:=x[posisi].stok+tamstok;
end
else
    writeln('barang belum ada di daftar, lakukan menu pilihan no 1');
end;

procedure cek_stok(var x:larik_barang);
var
nama_bar:string;
ketemu:boolean;

begin
write('masukan nama stok barang yang akan dicek= ');
readln(nama_bar);
{cek didalam array apakah nama tsb sudah ada diatas belum}
ketemu:=false;
for i:=1 to n do
    if (x[i].nama=nama_bar) then begin ketemu:=true;
if ketemu then
      
end

procedure cetak_bar(var x:larik_barang);
begin
writeln('+++++++++++++++++++++++++++++++++++++++++++++++++++++++');
writeln('No  nama barang          satuan       harga       stok ');
writeln('+++++++++++++++++++++++++++++++++++++++++++++++++++++++');
for i:=1 to n do
    writeln(i:2,'  ',x[i].nama:10,'  ',x[i].satuan:15,' ','Rp',x[i].harga:10, ' ',x[i].stok:10);
writeln('+++++++++++++++++++++++++++++++++++++++++++++++++++++++');
end;

procedure penjualan(var x:larik_barang);
var nama_bar:string;
    jumbeli:byte;
    ketemu:boolean;
    posisi:byte;
begin
    ketemu:=false;
    writeln('selamat berbelanja');
    writeln('masukkan nama barang yang akan dibeli');readln(nama_bar);
        {cek barang ada atau tidak di array barang}
        for i:=1 to n do
            if (x[i].nama=nama_bar) then
            begin ketemu:=true;posisi:=i;end;
        if ketemu then
        begin
            write('berapa buah ',nama_bar,' yang mau dibeli ?');
            readln(jumbeli);
            {cek stok}
            if(x[posisi].stok>= jumbeli) then
            begin
                inc(m);
                jual_brg[m].nama_j:=nama_bar;
                jual_brg[m].harga_j:=x[posisi].harga;
                jual_brg[m].jum:=jumbeli;
                jual_brg[m].total:=jual_brg[m].harga_j*jumbeli;
                x[posisi].stok:=x[posisi].stok-jumbeli;
            end
            else writeln('stok barang tidak cukup');
        end;
            if not ketemu then writeln('barang tidak ada didalam daftar');
            end;
           
            procedure cetak_jual(var y:larik_jual);
            begin
            writeln('============================================================');
            writeln('no   nama barang     harga     jumlah      total   ');
            writeln('============================================================');
            for i:=1 to m do
            begin
                writeln(i:2,'  ',y[i].nama_j:10,'  ','Rp',y[i].harga_j:10,'  ',y[i].jum:8,'  ','Rp',y[i].total:12:2);
                pendapatan:=pendapatan+y[i].total;
            end;
            writeln('===========================================================');
            end;
           
            begin
            repeat
            begin
                clrscr;
                writeln(' TRANSAKSI PENJUALAN TOKO DOMINO');
                writeln('1.Tambah barang');
                writeln('2.Tambah stok');
                writeln('3.Transaksi penjualan');
                writeln('4.Cek ketersediaan barang tertentu');
                writeln('5.Tampilkan barang');
                writeln('6.Tampilkan penjualan');
                writeln('7.Urut barang berdasar nama barang');
                writeln('8.Urut penjualan berdasar jumlah terjual');
                writeln('9.Rekap penjualan hari ini');
                writeln('10.selesai');
                writeln;write('pilihan nomer <1-10> ==> ');readln(pil);
            case pil of
            1: tambah_bar(bar);
            2: tambah_stok(bar);
            3: penjualan(bar);
            {4: cek_stok(bar);}
            5: cetak_bar(bar);
            6: cetak_jual(jual_brg);
            {7: urut_bar(bar);
            8: urut_jual(jual_brg);}
            9: begin
               writeln;
               writeln('jumlah pendapatan hari ini adalah sebesar Rp',pendapatan:8:2);
               end;
            10: writeln('terima kasih sudah mencoba');
            end; {end case}
            readln;
            end
            until (pil=10);
            end.

program pascal stack

uses crt;
const max=10;
type stack=record
    rasa:array[1..max] of string;
    harga:array[1..max] of integer;
    atas,depan,belakang:0..max;
end;

var s,t:stack;
    rasabaru,rasaambil:string;
    hargabaru,hargaambil:integer;
    pilih:1..4;
    lagi:boolean;
    cacah:byte;
  
function ful(s:stack):boolean;
begin
if s.atas=max then ful:=true else ful:=false;
end;

function empty(s:stack):boolean;
begin
if s.atas=0 then empty:=true else empty:=false;
end;

procedure push(var s:stack;r:string;h:integer);
begin
if ful(s) then writeln('tumpukan sudah penuh')
else
begin
    inc(s.atas);
    s.rasa[s.atas]:=r;s.harga[s.atas]:=h;
end;
end;

procedure cariambil(var s:stack);
var cari:string;
    ketemu:boolean;
    i,k,posisi:byte;
    ulang:char;
  
  
begin
    ketemu:=false;t.atas:=0;
    cacah:=0;
    write('yang akan dibeli rasa apa? ');readln(cari);
    for i:=1 to s.atas do
    begin
        if s.rasa[i]=cari then
    begin ketemu:=true;posisi:=1;end;
    end;
    {mengeluarkan kue diatas posisi lokasi ke stack}
    if ketemu then
    begin
    {mengeluarkan kue diatas posisi}
    for k:=s.atas downto posisi+1 do
        begin
        inc(t.atas);t.rasa[t.atas]:=s.rasa[k];
        t.harga[t.atas]:=s.harga[k];
    end;
    s.atas:=posisi;
    {mengeluarkan kue yang diambil dari stack kue}
    rasaambil:=s.rasa[s.atas];hargaambil:=s.harga[s.atas];
    writeln('anda telah membeli bolu rasa ',rasaambil,' seharga Rp',hargaambil:6);
    dec(s.atas);
    {mengambil kue ke posisi semula setelah dijual}
    for k:=t.atas downto 1 do
    begin
        inc(s.atas);
        s.rasa[s.atas]:=t.rasa[k];
        s.harga[s.atas]:=t.harga[k];
    end;
    end
    else
    writeln('maaf rasa yang anda cari sudah habis/tidak tersedia');
  
    writeln;
    {membeli yang dipilih}
write('mau cari rasa lain ? <y/t> ');readln(ulang);

end; {end procedure}

procedure cetak(s:stack);
var i:byte;

begin
if s.atas=0 then writeln('tidak ada kue dalam tumpukan')
else
begin
clrscr;
writeln('PERSEDIAAN KUE DI TOKO BOLU JAYA');
writeln('======================================');
writeln('no     rasa kue      harga ');
writeln('======================================');
for i:=s.atas downto 1 do
    writeln(i:3,'  ',s.rasa[i]:12,'  ',s.harga[i]:17);
writeln('======================================');
end; {end if}
end;

{program utama}
begin
lagi:=true;
while lagi do
begin
     clrscr;
     writeln('    TOKO BOLU JAYA ');
     writeln('1. Menambah kue ke tumpukan');
     writeln('2. mengambil bolu yang dipilih pelanggan');
     writeln('3. cetak stok kue');
     writeln('4. selesai');
     writeln;write('masukan pilihan anda ==>');readln(pilih);
     case pilih of
     1: begin
        write('masukan rasa bolu yang baru : ');readln(rasabaru);
        if (rasabaru='coklat') then hargabaru:=15000 else if (rasabaru='keju') then
        hargabaru:=17000 else if (rasabaru='kacang') then hargabaru:=16000 else
        if (rasabaru='moka') then hargabaru:=14500 else if (rasabaru='stroberi') then
        hargabaru:=16400 else hargabaru:=17500;
        push(s,rasabaru,hargabaru);
        end;
      
     2: cariambil(s);
     3: cetak(s);
     4: begin
        writeln('Terimakasih sudah berbelanja :)');
        lagi:=false;
        end;
end;
readln;
end;
end.

program pascal queue

uses crt;
const max=10;
type antrian=record
    nama:array[1..max] of string;
    belanja:array[1..max] of longint;
    depan,belakang:0..max;
end;
var q:antrian;
    masuk,keluar:string;
    bayarin,bayarout:longint;
    lagi:boolean;
    pilih:1..5;
    cacah:byte;hasil:real;
   
function penuh(q:antrian):boolean;
begin
if q.belakang=max then penuh:=true else penuh:=false;
end;

function kosong(q:antrian):boolean;
begin
if q.belakang=0 then kosong:=true else kosong:=false;
end;

procedure pushq(var q:antrian;m:string;b:longint);
begin
if penuh(q) then writeln('maaf antrian sedang penuh')
else
begin
    inc(q.belakang);
    q.nama[q.belakang]:=m;q.belanja[q.belakang]:=b;
end;
end; {end of procedure pushq}

procedure popq(s:antrian);
var i:byte;
begin
if kosong(q)then writeln('antrian sudah kosong')
else
begin
    keluar:=q.nama[q.depan]; {mengambil antrian paling depan}
    bayarout:=q.belanja[q.depan];
    writeln('yang dilayani adalah Mr/Ms ',keluar,'dengan total belanja Rp',bayarout);
    inc(cacah);hasil:=hasil+bayarout;
    {pergeseran posisi pengantri ke kiri/depan}
    for i:=1 to q.belakang-1 do
    begin
     q.nama[i]:=q.nama[i+1];
     q.belanja[i]:=q.belanja[i+1];
    end;
    dec(q.belakang); {mengurangi jumlah antrian}
end;
end; {end of procedure popq}

procedure cetak(var q:antrian);
var i:byte;
begin
if kosong(q) then writeln('daftar antrian kosong')
else
begin
writeln('********************************');
writeln('| DAFTAR PENGANTRI SAAT INI   ');
writeln('********************************');
writeln('| posisi        nama      belanja ');
writeln('********************************');
for i:=1 to q.belakang do
    writeln(i:3,q.nama[i]:10,' ',q.belanja[i]:8);
end;
writeln('********************************');
end; {end of procedure cetak}

begin {program cetak}
q.depan:=1;q.belakang:=0;
lagi:=true;
while lagi do
begin
    clrscr;
    writeln('-ANTRIAN DI KASIR TOKO MAJU JAYA-');
    writeln('1. Antrian masuk');
    writeln('2. Layanan kasir');
    writeln('3. Cetak antrian');
    writeln('4. Cek pendapatan sementara');
    writeln('5. Toko tutup dan tampilkan pendapatan hari inu');
    write('pilih 1-5 ==> ');readln(pilih);
case pilih of
1:begin
    write('nama baru ==>');readln(masuk);
    write('jumlah belanja ==> Rp.');readln(bayarin);
    pushq(q,masuk,bayarin);
  end;
 2:popq(q);
 3:cetak(q);
 4:begin
    writeln('hasil sementara penjualan adalah Rp.',hasil:8:2);
    writeln('jumlah pengunjung sementara ',cacah,'orang');
    end;
 5:begin
    writeln('pendapatan total hari ini adalah Rp.',hasil:8:2);
    writeln('Pengunjung hari ini sebanyak ',cacah,'orang');
    lagi:=false;
    end;
 end;
 readln;
 end;
 end.

program pascal linklist

program linklist;
uses crt;
type
    pointer=^TypeData;
    TypeData=record
        nama:string;
        Berikutnya:pointer;
    end;
var
    list,akhir:pointer;
   
procedure masuk_depan(Var L : Pointer;X:string);
var
    baru:pointer;
begin
    new(baru);
    baru^.nama:=X;
    baru^.berikutnya:=nil;
    if L = nil then
    begin
        L:=baru;akhir:=baru;
    end
    else
    begin
        baru^.berikutnya:=L;
        L:=baru;
    end;
end;

procedure sisip_tengah(var L : pointer;X,Y:string);
var
    baru,bantu:pointer;
begin
    bantu:=L;
    while bantu^.berikutnya<> nil do
    begin
        if bantu^.nama=y then
        begin
            new(baru);
            baru^.nama:=x;
            baru^.berikutnya:=bantu^.berikutnya;
            bantu^.berikutnya:=baru;
        end;
        bantu:=bantu^.berikutnya;
    end;
end;

procedure masuk_belakang(var L:pointer;x:string);
var
    baru,bantu:pointer;
begin
    new(baru);
    baru^.nama:=X;
    baru^.berikutnya:=nil;
    bantu:=L;
    while bantu^.berikutnya <> nil do
        bantu:=bantu^.berikutnya;
    bantu^.berikutnya:=baru;
    { akhir^.next:=baru;
    akhir:=baru;akhir^.next:=nil;}
end;

procedure hapus_depan(var L:pointer);
var
    bantu:pointer;
begin
    bantu:=L;
    if L=Nil then writeln('List kososng..!')
    else
        begin
            L:=L^.berikutnya;
            dispose(bantu);
        end;
end;

procedure hapus_tengah(var L:pointer;X:string);
var
    bantu,hapus:pointer;
begin
    if L = nil then writeln('List Kosong')
    else
        begin
            bantu:=L;
            new(hapus);
            while bantu^.berikutnya <> nil do
            begin
                if bantu^.berikutnya^.nama=X then
                begin   
                    hapus:=bantu^.berikutnya;
                    bantu^.berikutnya:=hapus^.berikutnya;
                    dispose(hapus);
                end
                else
                    bantu:=bantu^.berikutnya;
            end;
        end;
end;

procedure hapus_belakang(var L:pointer);
var
    baru,bantu:pointer;
begin
    bantu:=L;
    if bantu = nil then writeln('List Kososng')
    else
        begin
            while bantu^.berikutnya^.berikutnya <> nil do
                bantu:=bantu^.berikutnya;
            new(baru);
            baru:=bantu^.berikutnya;
            bantu^.berikutnya:=nil;
            dispose(baru);
        end;
end;

procedure cetak(L:pointer);
var
    bantu:pointer;
begin
    bantu:=L;
    while bantu <> nil do
    begin
        write(bantu^.nama,' ');
        bantu:=bantu^.berikutnya;
    end;
end;

var namabaru,namasisip,namahapus:string;
    pil,n:integer;
    lagi:boolean;
begin
    lagi:=true;
    new(list);
    list:=nil;
    while lagi do
    begin
        clrscr;
        writeln('1. Tambah Depan');
        writeln('2. Tambah Belakang');
        writeln('3. Sisip Nama');
        writeln('4. Cetak List');
        writeln('5. Hapus Depan');
        writeln('6. Hapus Tengah');
        writeln('7. Hapus Belakang');
        writeln('8. Selesai');
        write('pilihan anda -> (1-8) ');readln(pil);
        case pil of
            1:
            begin
                writeln('MASUK DEPAN');
                write('Masukkan nama baru : ');readln(namabaru);
                masuk_depan(list,namabaru);
            end;
           
            2:
            begin   
                writeln('MASUK BELAKANG');
                write('Masukkan namabaru : ');readln(namabaru);
                masuk_belakang(list,namabaru);
            end;
           
            3:
            begin
                writeln('SISIP NAMA');
                write('masukkan nama yang akan disisipi : ');readln(namabaru);
                write('Disisipi Setelah nama : ');readln(namasisip);
                sisip_tengah(list,namabaru,namasisip);
            end;
           
            4:cetak(list);
           
            5:
            begin
                writeln('HAPUS DEPAN');
                hapus_depan(list);
                cetak(list);
                writeln;
            end;
           
            6:
            begin
                writeln('HAPUS TENGAH');
                write('masukkan nama yang akan dihapus : ');readln(namahapus);
                hapus_tengah(list,namahapus);
                cetak(list);
            end;
           
            7:
            begin
                writeln('HAPUS BELAKANG');
                hapus_belakang(list);
                cetak(list);
                writeln;
            end;
           
            8:
            begin
                writeln('Terima kasih sudah mencoba program ini');
                lagi:=false;
            end;
        end;
        readln;
    end;
end.

program pascal penjulan

program toko_beras;
uses crt;
type rec_beras=record
     merk:string;
     harga:longint;
     stok:byte;
     end;
     array_beras=array[1..20] of rec_beras;
type rec_beli=record
     merk,nama:string;
     jum:byte;
     total:longint;
     end;
     array_beli=array[1..20] of rec_beli;
var  beras,sementara:array_beras;
     pembeli:array_beli;
     i,j,pil,n,m:byte;
     pendapatan:longint;
     ketemu:boolean;

procedure tambah_merk(var x:array_beras);
var merkbaru:string;
begin
     ketemu:=false;
     writeln('menambah merk beras baru');
     write('masukkan merk beras   : ');readln(merkbaru);
     {cek merk sudah ada/belum}
     for i:=1 to n do
     begin
          if (x[i].merk=merkbaru) then
          begin
          ketemu:=true;
          writeln('Merk tersebut sudah ada');
          end;
     end;
if not ketemu then
begin
     inc(n);
     x[n].merk:=merkbaru;
     write('harga per kg ? ');readln(x[n].harga);
end;
end;

procedure tambah_stok(var x:array_beras);
var tanya_merk:string;
    ada:boolean;
    posisi,tambah:byte; 
begin
     ada:=false;
     write('masukkan merk beras yang akan ditambah / diisi stok : ');readln(tanya_merk);
     {mengecek merk di array}
     for i:=1 to n do
     begin
         if  (x[i].merk=tanya_merk) then
         begin    
                  ada:=true;posisi:=i;
         end;
     end;
     if ada then {jika merk sudah ada di array, lakukan penambahan stok}
     begin
          write('tambah stok berapa kg ? ');readln(tambah);
          x[posisi].stok:=x[posisi].stok+tambah;
     end
     else writeln('merk tersebut belum ada ');

end;

procedure pembelian;
var beli_beras:string;
    tersedia:boolean;
    posisi:byte;

begin
     writeln('PEMBELIAN BERAS');
     write('masukkan merk beras yang akan dibeli: ');readln(beli_beras);
     {mengecek ketersediaan beras di larik beras}
     for i:=1 to n do
     begin
         if (beras[i].merk=beli_beras) and (beras[i].stok>0) then
         begin  tersedia:=true;posisi:=i; end;
     end;
     {jika beras available lakukan pembelian}
     if tersedia then
     begin
          inc(m);
          pembeli[m].merk:=beli_beras;
          write('masukkan nama pembeli = ');readln(pembeli[m].nama);
          write('beli berapa kg = ');readln(pembeli[m].jum);
          pembeli[m].total:=pembeli[m].jum*beras[posisi].harga;
          beras[posisi].stok:=beras[posisi].stok-(pembeli[m].jum); {mengurangi stok}
     end
     else writeln ('merk beras atau stok tidak tersedia');
end;

procedure cetak_beras(var x:array_beras);
begin
writeln('-------------------------------------');
writeln(' No  Merk         Stok   Harga per kg');
writeln('-------------------------------------');
for i:=1 to n do with x[i] do
    writeln(i:2,' ',merk:12,' ',stok:4,' ','Rp',harga:10);
writeln('-------------------------------------');
end;

procedure sorting_beras(var x:array_beras);
var temp:rec_beras;
begin
{mengisi array bayangan}
for i:=1 to n do sementara[i]:=x[i];
{mengurutkan array bayangan}
for i:=1 to n-1 do
begin
     for j:=i+1 to n do
     begin
          if (sementara[i].merk > sementara[j].merk) then
          begin
               temp:=sementara[i];
               sementara[i]:=sementara[j];
               sementara[j]:=temp;
          end;
     end;
end;
end;{end procedure sorting}

procedure cetak_beli(var y:array_beli);
begin
     writeln('----------------------------------------------------------------');
     writeln(' NO  Merk Beras  Pembeli     jumlah beli (kg)    Total Bayar');
     writeln('----------------------------------------------------------------');
     for i:=1 to m do with y[i] do
     begin
          pendapatan:=pendapatan+total;
         writeln(i:2,' ',merk:12,' ', nama:10,' ',jum:18,' ','Rp',total:15);
     end;
     writeln('-----------------------------------------------------------------');
end;
         

{program utama}
begin
repeat
begin
     clrscr;
     writeln('  TOKO BERAS  LARISO');
     writeln('********************************');
     writeln('1. Tambah merk beras           *');
     writeln('2. Tambah stok beras           *');
     writeln('3. Pembelian                   *');
     writeln('4. Sorting Beras berdasar merk *');
     writeln('5. Cetak stok Beras            *');
     writeln('6. Cetak Pembelian             *');
     writeln('7. Rekap pendapatan            *');
     writeln('8. Tutup                       *');
     writeln('********************************');
     write('Pilih menu ==> ');readln(pil);
     case pil of
     1: tambah_merk(beras);
     2: tambah_stok(beras);
     3: pembelian;
     4: begin sorting_beras(beras);cetak_beras(sementara);end;
     5: cetak_beras(beras);
     6: cetak_beli(pembeli);
     7: begin
        writeln('Hari ini terjadi ',m,' pembelian, dengan pendapatan Rp', pendapatan);
        writeln('Lancar terusss');
        end;
     8: writeln('Terimakasih');
     end;
     readln;
end
until (pil=8);
end.