lista dwukierunkowa z sortowaniami

program ldwukierunkowa;
uses crt;
const N=100;
type
  ListaPtr=^Lista;
  Lista = record
    value : integer;
    next : ListaPtr;
    prev : ListaPtr;
  end;
procedure Init(var head : ListaPtr; var tail : ListaPtr; var current : ListaPtr);
          begin
               head:=NIL;
               tail:=NIL;
               current:=NIL;
          end;
procedure DodajNaPoczatek(var head : ListaPtr; var tail : ListaPtr; var current : ListaPtr);
          var
             nowy : ListaPtr;
          begin
               New(nowy);
               nowy^.value:=random(N);
               if head = NIL then
               begin
                    nowy^.next:=NIL;
                    nowy^.prev:=NIL;
                    head:=nowy;
                    tail:=nowy;
                    current:=nowy;
               end else
               begin
                    nowy^.next:=head;
                    head^.prev:=nowy;
                    nowy^.prev:=NIL;
                    head:=nowy;
                    current:=nowy;
               end;
          end;
procedure DodajNaKoniec(var head : ListaPtr; var tail : ListaPtr; var current : ListaPtr);
          var
             nowy : ListaPtr;
             i,j : integer;
          begin
               writeln('Ile liczb chcesz dodac : ');
               readln(i);
               for j:=1 to i do
               begin
               New(nowy);
               nowy^.value:=random(N);
               if tail=NIL then
               begin
                    nowy^.next:=NIL;
                    nowy^.prev:=NIL;
                    head:=nowy;
                    tail:=nowy;
                    current:=nowy;
               end else
               begin
                    nowy^.next:=NIL;
                    nowy^.prev:=tail;
                    tail^.next:=nowy;
                    tail:=nowy;
                    current:=nowy;
               end;
               end;
          end;
procedure UsunKoniec(var head : ListaPtr; var tail : ListaPtr; var current : ListaPtr);
          var
             tmp : ListaPtr;
          begin
               if head=NIL then
                  writeln('Lista jest pusta!')
               else if head^.next=NIL then
               begin
                    head:=NIL;
                    tail:=NIL;
               end else
               begin
                    tmp:=tail;
                    tail:=tmp^.prev;
                    tail^.next:=NIL;
                    dispose(tmp);
               end;
          end;
procedure Erase(var head : ListaPtr; var tail : ListaPtr; var current : ListaPtr);
          var
             tmp : ListaPtr;
          begin
               while head<>NIL do
               begin
                    tmp:=head;
                    head:=tmp^.next;
                    dispose(tmp);
               end;
               head:=NIL;
               tail:=NIL;
          end;
procedure Print(var head : ListaPtr);
          var
             tmp : ListaPtr;
          begin
               if head=NIL then writeln('Lista jest pusta')
               else
               begin
                    tmp:=head;
                    while tmp<>NIL do
                    begin
                         writeln(tmp^.value);
                         tmp:=tmp^.next;
                    end;
               end;
          end;
function amount(var head : ListaPtr):integer;
         var
            licznik : integer =0;
            tmp : ListaPtr;
         begin
              tmp:=head;
              while tmp<>NIL do
              begin
                   licznik+=1;
                   tmp:=tmp^.next;
              end;
              amount:=licznik;
         end;
procedure BubbleSort(var head : ListaPtr);
          var
             i,j,m: integer;
             tmp, it2, it3 : ListaPtr;
             zmiana : boolean;
          begin
               m:=amount(head);
               j:=m-1;
               repeat
                        zmiana:=false;
                        it2:=head;
                        if head<>NIL then it3:=head^.next;
                        for i:=1 to j do
                        begin
                             if it2^.value>it3^.value then
                             begin
                                  zmiana:=true;
                                  if it2^.prev <> NIL then
                                  begin
                                       it2^.prev^.next:=it3;
                                       it3^.prev:=it2^.prev;
                                  end else
                                  begin
                                       head:=it3;
                                       head^.prev:=NIL;
                                  end;
                                  tmp:=it3^.next;
                                  it3^.next:=it2;
                                  it2^.next:=tmp;
                                  if tmp <> NIL then tmp^.prev:=it2;
                                  it2^.prev:=it3;
                                  it3:=it2;
                             end;
                             it2:=it3;
                             it3:=it3^.next;
                        end;
                        Dec(j);
               until (j<1) or not(zmiana);
               Print(head);
          end;
procedure SelectionSort(var head: ListaPtr);
          var
             it1, it2 ,min, tmp : ListaPtr;
          begin
               it1:=head;
               while it1^.next <> NIL do
               begin
                    it2:=it1;
                    min:=it1;
                    while it2^.next<> NIL do
                    begin
                         if it2^.next^.value < min^.value then
                         begin
                              min:=it2^.next;
                         end;
                         it2:=it2^.next;
                    end;
                    if min<>it1 then
                    begin
                         if it1^.prev=NIL then head:=min;
                         if min^.prev=it1 then
                         begin
                              min^.prev:=it1^.prev;
                              it1^.next:=min^.next;
                              min^.next:=it1;
                              it1^.prev:=min;
                              if min^.prev <> NIL then min^.prev^.next := min;
                              if it1^.next <> NIL then it1^.next^.prev := it1;
                         end else
                         begin
                              tmp:=min^.prev;
                              min^.prev:=it1^.prev;
                              if min^.prev <> NIL then min^.prev^.next := min;
                              it1^.prev:=tmp;
                              tmp^.next:=it1;
                              tmp:=min^.next;
                              min^.next:=it1^.next;
                              min^.next^.prev:=min;
                              it1^.next:=tmp;
                              if tmp<>NIL then tmp^.prev:=it1;
                         end;
                         it1:=min;
                    end;
                    it1:=it1^.next;
               end;
               Print(head);
          end;
procedure InsertionSort(var head : ListaPtr);
          var
             nowy, it, it2, newhead : ListaPtr;
          begin
               it := head;
               if it <> NIL then
               begin
                    newhead := it;
                    it := it^.next;
                    newhead^.next := NIL;
                    newhead^.prev := NIL;
               end;
               while it <> NIL do
               begin
                    nowy := it;
                    it := it^.next;
                    it2 := newhead;
                    if(it2^.value > nowy^.value) then
                    begin
                         nowy^.next := it2;
                         it2^.prev := nowy;
                         newhead := nowy;
                         newhead^.prev := NIL;
                    end else
                    begin
                         while (it2^.next <> NIL) and (it2^.next^.value < nowy^.value) do it2 := it2^.next;
                         nowy^.next := it2^.next;
                         if it2^.next <> NIL then it2^.next^.prev := nowy;
                         nowy^.prev := it2;
                         it2^.next := nowy;
                    end;
               end;
               head := newhead;
               Print(head);
          end;
function menu:char;
         begin
              clrscr;
              writeln('[1] - Dodaj zadanie na poczatek listy');
              writeln('[2] - Dodaj zadanie na koniec listy');
              writeln('[3] - Wyswietl liste zadan');
              writeln('[4] - Usun zadanie z konca listy');
              writeln('[5] - Posortuj liste zadan babelkowo');
              writeln('[6] - Posortuj liste zadan przez wybor');
              writeln('[7] - Posortuj liste zadan przez wstawienie');
              writeln('[8] - Wyczysc liste');
              writeln('[Esc] - Wyjscie z programu');
              menu := readkey;
         end;
var
   head, tail, current: ListaPtr;
begin
  randomize;
  Init(head, tail, current);
  repeat
           begin
                clrscr;
                case menu of
                     '1':DodajNaPoczatek(head, tail, current);
                     '2':DodajNaKoniec(head, tail, current);
                     '3':Print(head);
                     '4':UsunKoniec(head, tail, current);
                     '5':BubbleSort(head);
                     '6':SelectionSort(head);
                     '7':InsertionSort(head);
                     '8':Erase(head, tail, current);
                     #27:halt;
                end;
                writeln;
                writeln('Aby wrocic do menu nacisnij [ENTER]');
                readln;
           end;
     until FALSE;
     end.