Animasi n Sahring

Ads 468x60px

Giusto odio dignissimos

Giusto odio dignissimos

At vero eos et accusamus et iusto odio dignissimos ducimus qui blanditiis praesentium voluptatum deleniti atque corrupti quos dolores et quas molestias excepturi sint occaecati cupiditate non provident, similique sunt in culpa qui officia...

Read More
Omnis dolor repellendus

Omnis dolor repellendus

At vero eos et accusamus et iusto odio dignissimos ducimus qui blanditiis praesentium voluptatum deleniti atque corrupti quos dolores et quas molestias excepturi sint occaecati cupiditate non provident, similique sunt in culpa qui officia...

Read More
Olimpedit quo minus

Olimpedit quo minus

At vero eos et accusamus et iusto odio dignissimos ducimus qui blanditiis praesentium voluptatum deleniti atque corrupti quos dolores et quas molestias excepturi sint occaecati cupiditate non provident, similique sunt in culpa qui officia...

Read More
Itaque earum rerum

Itaque earum rerum

At vero eos et accusamus et iusto odio dignissimos ducimus qui blanditiis praesentium voluptatum deleniti atque corrupti quos dolores et quas molestias excepturi sint occaecati cupiditate non provident, similique sunt in culpa qui officia...

Read More
Epudiandae sint molestiae

Epudiandae sint molestiae

At vero eos et accusamus et iusto odio dignissimos ducimus qui blanditiis praesentium voluptatum deleniti atque corrupti quos dolores et quas molestias excepturi sint occaecati cupiditate non provident, similique sunt in culpa qui officia...

Read More
Sahut aut reiciendis

Sahut aut reiciendis

At vero eos et accusamus et iusto odio dignissimos ducimus qui blanditiis praesentium voluptatum deleniti atque corrupti quos dolores et quas molestias excepturi sint occaecati cupiditate non provident, similique sunt in culpa qui officia...

Read More

Kamis, 29 Maret 2012

Kumpulan Script Pascal

pada jaman saya kuliah pelajarn basis data pasti akan disuguhkan dengan bahasa pemrograman seperti Pascal atau C++, saya rasa jaman sekarang juga pasti ga jauh berbeda lah, di kesempatan ini saya mau share kumpulan script-script pascal jadul yang masih tersimpan di Hardisk saya, setelah beberapa tahun membeku dalam arsip lama, daripada di recylce kan lebih baik di share, siapa tau ada yang butuh untuk referensi kuliah atau tugas kelompok, mungkin tidak sebanyak yang di harapkan sih, tapi mudah-mudahan cukuplah untuk pembelajaran

menghitung bilangan Fibonacci (rekursif)

{************************************************
* Prosedur untuk menghitung bilangan Fibonacci *
* dengan cara rekursif                         *
************************************************}
function FIBO(N : integer) : integer;

begin
   if (N = 1) or (N = 2) then
      FIBO := 1
   else
      FIBO(N) := FIBO(N - 1) + FIBO(N - 2)
end;

 

menghitung bilangan faktorial (rekursif)


{***************************************************
* Fungsi untuk menghitung bilangan faktorial      *
* dengan cara rekursif                            *
***************************************************}
uses wincrt;
function FAKT(N : integer) : integer;
 
begin
   if N = 0 then
      FAKT := 1
   else
      FAKT  := N * FAKT(N - 1)
end;
 
 

menghitung bilangan Fibinacci (Iterasi)


{*************************************************
* Fungsi untuk menghitung bilangan Fibinacci    *
* dengan cara iterasi                           *
*************************************************}
function FIBO_ITER(N : integer) : integer;
 
var  F, Akhir, Bantu
      I     : integer
 
begin
   I := 1; F := 1; Akhir := 0;
   if N = 0 then F := 0;
   while I <> N do
     begin
       Bantu := F; I := I + 1;
       F := F + Akhir;
       Akhir := Bantu
     end;
   FIBO_ITER := F
end;
 
 

Menyusun permutasi sekelompok karakter (rekursif)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
{******************************************
  * Menyusun permutasi sekelompok karakter *
  * dengan cara rekursif                   *
  ******************************************}
 
program SUSUN_PERMUTASI;
 
uses crt;
 
const Max = 5;
 
type  Larik = array[1..Max] of char;
 
var   A           : Larik;    {* larik yang akan
                                  dipermutasikan *}
       C_Permutasi,            {* jumlah permutasi *}
       C_Elemen,               {* cacah karakter *}
       I           : integer;  {* perubah kendali *}
       Lagi        : char;     {* perubah kendali *}
 
{*********************************
  * Prosedur penyusunan permutasi *
  *********************************}
procedure PERMUTASI (var B : integer; A : Larik;
                      K, N : integer);
 
var I    : integer;
     Temp : char;
begin
   if K = N then
      begin
        B := succ(B);
        write('Permutasi ke ', B:2,' : ');
        for I := 1 to N do
           write(A[I]:3);
        writeln;
      end
   else
      for I := K to N do
        begin
          Temp := A[I];
          A[I] := A[K];
          A[K] := Temp;
          PERMUTASI(B, A, K+1, N)
        end
end;         { *** prosedur PERMUTASI *** }
 
{*****************
  * Program utama *
  *****************}
begin
   repeat
     clrscr;
     write('Banyaknya karakter yang akan');
     write(' dipermutasikan: ');
     repeat
       gotoxy(47, 1); write('    ');
       gotoxy(47, 1); readln(C_Elemen)
     until C_Elemen <= Max;
     {* Menyusun karakter yang akan dipermutasikan *}
     for I := 1 to C_Elemen do
        A[I] := chr(I+64);
 
     clrscr;
     write('MENYUSUN PERMUTASI UNTUK ');
     writeln(C_Elemen:2, ' KARAKTER');
     writeln('------------------------------------');
     writeln;
 
     {* Proses mencari permutasi *}
     C_Permutasi := 0;
     PERMUTASI(C_Permutasi, A, 1, C_Elemen);
 
     {* Mencetak hasil *}
     writeln;
     writeln('Banyaknya permutasi: ', C_Permutasi:3);
     writeln;
     write('Akan coba lagi? (Y/T): '); readln(Lagi)
   until not (Lagi in ['Y', 'y'])
end.         { *** program utama *** }

 

Penyelesaian persoalan Menara Hanoi

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
{**********************************************
  * Penyelesaian persoalan Menara Hanoi        *
  * Banyaknya piringan dibatasi sampai 10 buah *
  **********************************************}
 
program MENARA_HANOI;
uses crt;
 
const Max = 10;     {* jumlah maksimum piringan *}
 
var Gerakan,             {* banyaknya pemindahan *}
     Piringan : integer;  {* banyaknya piringan *}
{************************************
  * Prosedur untuk memindah piringan *
  ************************************}
procedure HANOI(var C_Gerak : integer;
                 Cacah : integer; A, B, C : char);
 
begin
   if Cacah > 0 then
      begin
        HANOI(C_Gerak, Cacah-1, A, C, B);
        C_Gerak := succ(C_Gerak);
        write('Langkah ke ', C_Gerak:3);
        write(': pindah piring nomor ', Cacah:2);
        write(' dari tonggak ', A);
        write(' ke tonggak ', C);
        writeln(' (', A, ' -> ', C, ')');
        HANOI(C_Gerak, Cacah-1, B, A, C)
      end
end;         {* prosedur HANOI *}
 
{*****************
  * Program utama *
  *****************}
begin
   clrscr;  Gerakan := 0;
   writeln('PENYELESAIAN MENARA HANOI');
   write('(Piring terkecil diberi nomor 1, ');
   writeln('berikutnya 2 dan seterusnya)');
   write('----------------------------------');
   writeln('---------------------------'); writeln;
 
   {* Mengisikan banyaknya piringan *}
   gotoxy(1, 5);
   write('Banyaknya piringan (max ', Max:2, '): ');
   writeln;
   repeat
     gotoxy(30, 5); write('      ');
     gotoxy(30, 5); readln(Piringan)
   until Piringan <= Max;
 
   {* Proses memindah piringan *}
   HANOI(Gerakan, Piringan, 'A', 'B', 'C');
   {* Mencetak banyaknya gerakan yang diperlukan *}
   write('Piringan sebanyak ', Piringan:2, ' buah');
   write(' memerlukan ',Gerakan:2,' kali pemindahan');
end.

Prosedur untuk memasukkan elemen ke dalam tumpukan

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
{******************************************************
* Prosedur untuk memasukkan elemen ke dalam tumpukan *
******************************************************}
procedure PUSH (var T: Tumpukan; var Penuh: boolean;
                     X: integer);
 
begin
   if T.Atas = MaxElemen then
      {* Tumpukan sudah penuh *}
      Penuh := true
   else
      begin
        Penuh := false;
        T.Atas := inc(T.Atas);
        T.Isi[T.Atas] := X
      end
end;

 

Fungsi untuk mempop elemen dari tumpukan

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
{********************************************************
* Fungsi untuk mempop elemen dari tumpukan. Fungsi ini *
* berisi fungsi lain untuk mengetahui kosong tidaknya  *
* tumpukan yang elemennya akan dipop                   *
********************************************************}
function POP (var T : Tumpukan) : integer;
 
{* Fungsi untuk mengetahui kosong tidaknya tumpukan *}
function KOSONG(var T : Tumpukan): boolean;
 
begin
   Kosong := (T.Atas = 0)
end;       {* fungsi KOSONG *}
 
{**************
  * Fungsi POP *
  **************}
begin
   if KOSONG(T) then
      POP := 0
   else
      begin
        POP := T.Isi[T.Atas];
        T.Atas := dec[T.Atas];
      end;
end;       {* fungsi POP *}

 

Pemakaian tumpukan untuk membalik kalimat

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
{*********************************************
  * Pemakaian tumpukan untuk membalik kalimat *
  *********************************************}
program BALIK_KALIMAT;
 
uses crt;
 
const Elemen = 255;   {* batas maksimum karakter *}
 
type S255     = string[Elemen];
      Tumpukan = record
                   Isi  : S255;
                   Atas : 0..Elemen
                 end;
 
var  T       : Tumpukan;  {* nama tumpukan *}
      I       : integer;   {* pencacah *}
      Kalimat : S255;      {* kalimat yang dibalik *}
 
{**********************************
  * Prosedur inisialisasi tumpukan *
  ********************************** }
  procedure AWALAN (var T : Tumpukan);
 
  begin
    T.Atas := 0
  end;         {* prosedur AWALAN *}
 
{*********************************************
  * Prosedur untuk memasukkan elemen ke dalam *
  * tumpukan. Dalam hal ini cacah karakter    *
  * maksimum tidak boleh lebih dari 255       *
  *********************************************}
procedure PUSH (var T : Tumpukan; X : char);
 
begin
   T.Atas := T.Atas + 1;
   T.Isi[T.Atas] := X
end;          {* prosedur PUSH *}
 
{***********************************************
  * Fungsi untuk mengambil elemen dari tumpukan *
  ***********************************************}
  function POP (var T : Tumpukan) : char;
 
  begin
    POP := T.Isi[T.Atas];
    T.Atas := T.Atas - 1
  end;         {* fungsi POP *}
{*****************
  * Program utama *
  *****************}
  begin
    clrscr;
    Awalan(T);
    writeln('TUMPUKAN UNTUK MEMBALIK KALIMAT');
    writeln('-------------------------------');
    writeln;
 
    {* Kalimat yang akan dibalik *}
    write('Isikan sembarang kalimat: ');
    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 isi tumpukan sehingga diperoleh    *
     * kalimat yang dibaca terbalik pembacaannya *}
    for I := 1 to length(Kalimat) do
      write(POP(T));
 
    writeln
end.          {* program utama *}

 

Konversi notasi persamaan matematis

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
{*********************************************
* 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 *}

menghitung nilai rata-rata

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
{***************************************************
* Contoh sebuah fungsi untuk menghitung nilai     *
* rata-rata dari sekumpulan data yang diketahui   *
***************************************************}
uses wincrt;
function RATA(Vektor : Larik; N : integer);
var I : integer;
     R : real;
 
begin
   R := 0;
   for I := 1 to N do
     R := R + Vektor[I];
   RATA := R/N
end;


Mudah-mudahan kumpulan script yang sedikit ini bisa menjadi bahan referensi yang berguna, thanks for reading
Diposting oleh di

Tidak ada komentar:

Posting Komentar

Langganan: Posting Komentar (Atom)

Widgeo