doc/examples/rozdzPun1.log

   1  PROGRAM RozdzielaniePunktow;
   2   #include "classes/gui.inc"
   3 (*Program ma pozwolic odseparowac przy pomocy pewnej krzywej 2 zbiory punktow*)
   4 (*  tak aby ??????? *)
   5   signal ERROR_exec;
   6   CONST
   7
   8       MinX = 0,
   9       MinY = 0,
  10       MaxX = 640,
  11       MaxY = 480,
  12       comX = 30,
  13       comY = 440,
  14       sz   = 30, (*szerokosc paska menu*)
  15        my_ecranMinX = MinX+5,
  16        my_ecranMinY = MinY+sz+3,
  17        my_ecranMaxX= MaxX-5,
  18        my_ecranMaxY= MaxY-(2*sz+1),
  19       exit_posX = 550,
  20       exit_posY = 420,
  21       help_posX = 20,
  22       help_posY = 50,
  23       grubosc = 2,
  24       maly = 1;
  25
  26
  27 (*------------------------------------------------------------------------*)
  28
  29 (*------------------------------------------------------------------------*)
  30 (*               klasa definiujaca procedury graficzne                    *)
  31 (*------------------------------------------------------------------------*)
  32    UNIT graphics : GUI CLASS;
  33
  34
  35       UNIT pauza : PROCEDURE(JakDlugo:integer);
  36       var i : integer;
  37       BEGIN
  38          for i :=1 to JakDlugo do i:=i od;
  39       END pauza;
  40
  41
  42       UNIT waitt : PROCEDURE;
  43       (* wait for a key *)
  44       BEGIN
  45          While GUI_KeyPressed=/= 0 DO OD;
  46       END waitt;
  47
  48       UNIT clear_all : procedure;
  49        begin
  50             call GUI_Rect(my_ecranMinX, my_ecranMinY, my_ecranMaxX,
  51                                      my_EcranMaxY,c_DarkGrey,c_LightGrey);
  52             call GUI_Rect(my_EcranMinX, MaxY-2*sz,
  53                                     my_EcranMaxX,MaxY-5,c_DarkGrey,c_DarkGrey);
  54        end clear_all;
  55
  56       UNIT clear : PROCEDURE(x0,y0,x1,y1,c1,c2: integer);
  57       (* wymaz wszystko w prostokacie (x0,y0)-(y1,y1) *)
  58       (* Zostaw ekran w kolorze c2*)
  59       var i,j,x,y : integer;
  60       BEGIN
  61             x := (x1-x0) div 2;
  62             y := (y1-y0) div 2;
  63             i :=0; j :=0;
  64             while i<=x and j<=y  do
  65                  call GUI_Rect(x0+i,y0+j,x1-i,y1-j,c_black,c_lightGrey);
  66                  i := i+1; j := j+1;
  67             od;
  68             while i>=0 and j>=0  do
  69                  call GUI_Rect(x0+i,y0+j,x1-i,y1-j,c1,c2);
  70                  i := i-1; j :=j-1
  71             od;
  72        END clear;
  73
  74
  75 (**************************************************************************)
  76
  77     UNIT katy : procedure(col1,col2,x,y,u,v,grubosc: integer);
  78     var i : integer;
  79     BEGIN
  80              for i :=0 to grubosc
  81              do
  82                  call GUI_Line(x+i,y+i,u-i,y+i, col1);
  83                  call GUI_Line(x+i,y+i,x+i,v-i, col1)
  84              od;
  85              for i :=0 to grubosc
  86              do
  87                  call GUI_Line(u-i,v-i,x+i,v-i,col2);
  88                  call GUI_Line(u-i,v-i,u-i,y+i, col2);
  89              od;
  90     END katy;
  91
  92
  93     unit comment: procedure(ss:string);
  94        begin
  95            call GUI_Rect(minX+4,maxY-2*sz,maxX-4,maxY-10,c_darkGrey,c_darkGrey);
  96            (* wymazanie obszaru pod komentarze *)
  97            call GUI_writeText(comX+10,comY,unpack(ss),c_white,c_darkGrey);
  98     end comment;
  99
 100     unit YES : function : boolean;
 101     var  c : char;
 102     begin
 103         while (c <> 'y' and c<> 'Y' and c <> 'n' and c<> 'N' ) do
 104                     call GUI_move(comX,comY);
 105                     c:= GUI_ReadChar(comX,comY,c_turq,c_lightGrey) od;
 106         if (c= 'y' or c='Y') then
 107                 result := true else result := false
 108         fi;
 109     end YES;
 110
 111   END graphics;
 112 (*************************************************************************)
 113
 114  BEGIN
 115        pref GRAPHICS block
 116
 117
 118 (*-----------------------------------------------------------------------*)
 119
 120 (*                      M E N U                                          *)
 121 (*-----------------------------------------------------------------------*)
 122         unit option : class(nb : integer);
 123         var Nom : arrayof string;
 124         unit virtual action : procedure(j : integer);
 125         begin
 126         end action;
 127         begin
 128            array Nom dim (1:nb);
 129            inner;
 130         end option;
 131
 132         unit ikona : class(c,x,y,u,v,grubosc : integer, ss : string);
 133         var sub_menu : menu;
 134            unit write_i : procedure;
 135            var i: integer;
 136            begin
 137              call GUI_Rect(x,y,u,v,c_black,c);
 138              call katy(c_white,c_darkGrey,x,y,u,v,grubosc);
 139              call GUI_writeText(x+grubosc+3,y+(v-y)div 2 - 5 ,unpack(ss),c_black,c)
 140            end write_i;
 141
 142            unit wymaz : procedure;
 143            begin
 144                 call GUI_Rect(x,y,u,v,c_black,c_lightGrey);
 145            end wymaz;
 146
 147            unit push : procedure;
 148            (* nacisniecie wybranej ikony *)
 149            begin
 150              call katy(c_darkGrey,c_white,x,y,u,v,grubosc);
 151              call pauza(200);
 152              call katy (c_white,c_darkGrey,x,y,u,v,grubosc);
 153              call pauza(200);
 154            end push;
 155
 156            unit inactive : procedure;
 157            begin
 158              call katy(c_white,c_darkGrey,x,y,u,v,grubosc);
 159              call pauza(500);
 160              call katy (c_darkGrey,c_white,x,y,u,v,grubosc);
 161              call pauza(500);
 162            end inactive;
 163         end ikona;
 164
 165         unit CZY : function(xx,yy:integer,IC:Ikona): boolean;
 166         begin   (* czy mysz nacisnieta  w polozeniu ikony IC *)
 167            result := (IC.x<xx and xx<IC.u
 168                    and IC.y<yy  and yy<IC.v)
 169         end CZY;
 170
 171
 172         unit menu : coroutine(minX,maxX,MinY,MaxY :integer, OPTIONS :option);
 173            (* sz szerokosc paska ikon *)
 174         var ICONES: arrayof IKONA, i,j,nb, x1, y1, dl : integer,
 175             l,r,z,
 176             col,xx,yy   : integer,
 177             boo : boolean;
 178             (* dl and sz  - wymiary ikon w tym menu *)
 179
 180             unit instalation : procedure;
 181             (* rysowanie menu oraz jego ikon *)
 182             var i : integer;
 183             begin
 184                 call GUI_Rect(minX,minY,maxX,maxY,c_black,c_lightGrey);
 185                 (* duzy obszar szary *)
 186
 187                 call GUI_Rect(minX+4,maxY-(2*sz),maxX-4,maxY-4,c_black,c_darkGrey);
 188                 (*obszar dla komentarzy*)
 189                 for i := 1 to nb
 190                 do
 191                     call ICONES(i).write_i
 192                 od;
 193             end instalation;
 194
 195             unit INI : procedure;
 196             var x,y,u,v : integer;
 197             BEGIN
 198                nb := OPTIONS.nb;
 199                dl := (MaxX-Minx) div nb ;
 200
 201                array ICONES dim(1:nb);
 202                x := minX+2; y := minY+2;
 203                u := minX+dl-4;  v := minY+sz;
 204                for i := 1 to nb
 205                do
 206                   ICONES(i) := new ikona(c_lightGrey,x,y,u,v,2,OPTIONS.NOM(i));
 207                   x := x+dl; u := u+dl;
 208                od;
 209             end INI;
 210 handlers
 211    when ERROR_exec :
 212                   call comment(" error exec  ");
 213                   call YES_ikona.write_i;
 214                   call NO_ikona.write_i;
 215                   z :=0;
 216                   while not z=1 do  call GUI_MousePressed(xx,yy,z) od;
 217                   call comment("");
 218                   (* szukam gdzie zostal nacisniety lewy klawisz myszki*)
 219                   if CZY(xx,yy,YES_ikona)
 220                   then
 221                       call YES_ikona.push;
 222                       call clear(minX+5,minY+sz+3,maxX-5,maxY-2*sz-1,c_white,c_lightGrey);
 223                       wind
 224                   fi;
 225                   if CZY(xx,yy,NO_ikona)
 226                   then
 227                       call NO_ikona.push;
 228                       call clear(minX+5,minY+sz+3,maxX-5,maxY-2*sz-1,c_white,c_lightGrey);
 229                       call ENDRUN
 230                   fi;
 231
 232
 233    others         call comment(" ERROR press YES to continue or NO to stop?");
 234
 235                   call YES_ikona.write_i;
 236                   call NO_ikona.write_i;
 237                   z :=0;
 238                   while not z=1 do  call GUI_MousePressed(xx,yy,z) od;
 239                   call comment("");
 240                   (* szukam gdzie zostal nacisniety lewy klawisz myszki*)
 241                   if CZY(xx,yy,YES_ikona)
 242                   then
 243                       call YES_ikona.push;
 244                       call clear(minX+5,minY+sz+3,maxX-5,maxY-2*sz-1,c_white ,c_lightGrey);
 245                       wind
 246                   fi;
 247                   if CZY(xx,yy,NO_ikona)
 248                   then
 249                       call NO_ikona.push;
 250                       call clear(minX+5,minY+sz+3,maxX-5,maxY-2*sz-1,c_white ,c_lightGrey);
 251                       call ENDRUN
 252                   fi;
 253
 254 end handlers;
 255
 256         begin
 257            call INI;
 258            return;
 259            do  (* obsluga menu *)
 260                call instalation;    (* rysowanie ikon z tego menu *)
 261                do
 262                   xx, yy,i := 0;
 263
 264                   while i=0  do
 265                       call GUI_MousePressed(xx,yy,i) ;
 266                   od;
 267
 268                   (* szukam gdzie zostal nacisniety lewy klawisz myszki *)
 269                   for j :=1 to nb
 270                   do
 271                       if czy(xx,yy,ICONES(j))
 272                       then
 273                           call ICONES(j).push;exit;
 274                       fi;
 275                   od;
 276                   if j>0 and j<nb+1
 277                   then
 278                        call OPTIONS.Action(j);
 279                        if j=1 then detach;
 280                              exit
 281                        else
 282                           if ICONES(j).sub_menu<>none then
 283                              attach(ICONES(j).sub_menu);
 284                              exit;
 285                           fi;
 286                        fi;
 287                   fi;
 288                od;
 289            od;
 290         end menu;
 291
 292      unit OPTIONS_MAIN : option class;
 293      unit virtual Action : procedure(j : integer);
 294      var ch : char, i,x : integer, bol : boolean;
 295      begin               (* opcje glownego menu*)
 296
 297          case j
 298             when 1 : call comment("Exit    ");
 299             when 2 : call comment("Ustalanie parametrow.");
 300                                 call Parametry;
 301             when 3 : call comment("Tu ma byc informacja o algorytmie");
 302
 303             when 4 : call WczytajDane(ilCZ, ilB);
 304
 305
 306
 307           esac;
 308       end action;
 309       begin
 310            Nom(1) := "EXIT";
 311            Nom(2) := "PARAMETRY";
 312            Nom(3) := "HELP";
 313            Nom(4) := "ALGORITHMS";
 314       end OPTIONS_MAIN;
 315
 316      unit OPTIONS_START : option class;
 317      unit virtual Action : procedure(j : integer);
 318      var x: integer, boo :boolean;
 319      begin
 320          case j
 321             when 1 : call comment("RETURN    ");
 322             when 2 :
 323                                 call ALG_1(ilcz,ilb);
 324             when 3 :
 325                                 call ALG_2(ilcz,ilb);
 326             when 4 : call comment("ALG_3");
 327                      call clear_all;
 328           esac;
 329       end action;
 330       begin
 331            Nom(1) := "RETURN";
 332            Nom(2) := "ALG_1";
 333            Nom(3) := "ALG_2";
 334            Nom(4) := "ALG_3";
 335       end OPTIONS_START;
 336
 337
 338       unit OPTIONS_help : option class;
 339       var ch : char, i:integer;
 340       unit virtual Action : procedure(j : integer);
 341       begin
 342           case j
 343             when 1 :  call comment(" ");
 344             when 2 :  call comment("NACISNIJ Y lub N");
 345                      if YES then call comment("") fi;
 346             when 3 :  call comment("");
 347          esac;
 348       end Action;
 349       begin
 350            NOM(1) := "RETURN";
 351            NOM(2) := "NEXT";
 352            NOM(3) := "PREV";
 353       end OPTIONS_help;
 354
 355  (*===================================================================*)
 356
 357     unit parametry : procedure;
 358     const pminX = 30, pminY =50, pmaxX= 400, pmaxY=200,
 359              il_ikon =5;
 360     var i ,xx, yy: integer, IK : arrayof IKONA;
 361     begin
 362
 363           array IK dim(1 : il_ikon);
 364           call GUI_Rect(pminX,pminY,pmaxX,pmaxY,c_darkGrey,c_green);
 365           call GUI_WriteText(pminX+10, pminY+10,unpack("Ilosc punktow = "),
 366                                      c_darkGrey,c_green);
 367           call GUI_writeInt(pminX+150,pminY+10,
 368                                                       il_punktow, c_darkGrey,c_green);
 369           call GUI_WriteText(pminX+10, pminY+45,unpack("Jakosc w % = "),
 370                                             c_darkGrey,c_green);
 371            call GUI_writeInt(pminX+150,pminY+45,
 372                                                       jakosc, c_darkGrey,c_green);
 373           IK(1) := new IKONA (6,pminX+200,pminY+10,pminX+250,pminY+35,3,"PLUS");
 374           IK(2) := new IKONA (6,pminX+260,pminY+10,pminX+310,pminY+35,3,"MINUS");
 375           IK(3) := new IKONA (6,pminX+200,pminY+45,pminX+250,pminY+70,3,"PLUS");
 376           IK(4) := new IKONA (6,pminX+260,pminY+45,pminX+310,pminY+70,3,"MINUS");
 377           IK(5) := new IKONA (6,pminX+200,pminY+120,pminX+250,pminY+145,3,"EXIT");
 378           for i:=1 to il_ikon do call IK(i).write_i; od;
 379           (*badanie ktora ikona zostala nacisnieta*)
 380             do
 381                   xx, yy,i := 0;
 382                   while i=0  do
 383                       call GUI_MousePressed(xx,yy,i) ;
 384                   od;
 385
 386                   (* szukam gdzie zostal nacisniety lewy klawisz myszki *)
 387                   for i :=1 to il_ikon do
 388                       if czy(xx,yy,IK(i))
 389                       then
 390                           call IK(i).push; exit
 391                       fi;
 392                   od;
 393                               case i
 394                                   when 1 : il_punktow := il_punktow+10;
 395
 396 call GUI_Rect(pminX+150,pminY+10,pminX+180,pminY+25, c_green,c_green);
 397 call GUI_writeInt(pminX+150,pminY+10,il_punktow, c_darkGrey,c_green);
 398                                   when 2 : il_punktow := il_punktow-10;
 399 call GUI_Rect(pminX+150,pminY+10, pminX+180,pminY+25, c_green,c_green);
 400 call GUI_writeInt(pminX+150,pminY+10, il_punktow, c_darkGrey,c_green);
 401                                    when 3 : jakosc := jakosc+1;
 402 call GUI_Rect(pminX+150,pminY+45, pminX+180,pminY+60, c_green,c_green);
 403 call GUI_writeInt(pminX+150,pminY+45, jakosc, c_darkGrey,c_green);
 404                                   when 4 : jakosc := jakosc-1;
 405 call GUI_Rect(pminX+150,pminY+45, pminX+180,pminY+60, c_green,c_green);
 406 call GUI_writeInt(pminX+150,pminY+45, jakosc, c_darkGrey,c_green);
 407                                   when 5 :  exit;
 408                                esac;
 409              od;
 410              call  clear_all;
 411     end parametry;
 412
 413 (*-------------------------------------------------------------*)
 414    UNIT PokazPunkty : procedure;
 415    var i : integer;
 416    begin
 417       call clear(minX+5,minY+sz+3,maxX-5,maxY-(2*sz+1),c_yellow,c_blue);
 418       for  i := 1 to ilCz do call TabCz(i).rysuj  od;
 419       for  i := 1 to ilB do call TabB(i).rysuj   od;
 420    end PokazPunkty;
 421
 422    UNIT WczytajDane : procedure( output il_cz, il_b : integer);
 423     var pp : punkt;
 424     begin
 425            call clear(minX+5,minY+sz+3,maxX-5,maxY-(2*sz+1),c_yellow,c_blue);
 426            call comment("Losowanie punktow.");
 427            array TabCz dim(1: il_punktow);
 428            array TabB dim(1: il_punktow);
 429
 430             il_cz := 0; il_b := 0;
 431             for i :=1 to il_punktow do
 432                  if random*10 <=6  then (* wylosowany punkt czerwony *)
 433                     il_cz := il_cz + 1;
 434                    pp:= new punkt(10+random*600,40+random*360,c_red);
 435                     call pp.rysuj;
 436                    (* wpisz do uporzadkowanej tablicy czerwonych*)
 437                      call insert(pp,TabCz, il_cz);
 438                  else  (* wylosowany punkt bialy *)
 439                      il_b := il_b +1;
 440                      pp := new punkt(10+random*600,40+random*360,c_white);
 441                      call pp.rysuj;
 442                     (*wpisz do uporzadkowanej tablicy bialych *)
 443                      call insert(pp,TabB, il_b);
 444                 fi;
 445             od;
 446            call comment("");
 447
 448     end WczytajDane;
 449
 450
 451     unit INFO : procedure(ilcz,ilb : integer);
 452     begin
 453          call GUI_WriteText( MinX+10, MaxY -50,
 454          unpack("wylosowano czerowonych : "), c_red,c_darkGrey);
 455          call GUI_WriteInt(MinX+200, MaxY-50,ilcz,c_red,c_darkGrey);
 456          call GUI_WriteText(MinX+10,MaxY-30,
 457          unpack("wylosowano bialych : "),c_white,c_darkGrey);
 458          call GUI_WriteInt(MinX+200, MaxY-30,ilb,c_white,c_darkGrey);
 459          call GUI_WriteText(MinX+250,MaxY-50,unpack("na lewo: "),
 460                                                                   c_black,c_darkGrey);
 461          call GUI_WriteText(MinX+360,MaxY-50,unpack(":: "),
 462                                                                   c_black,c_darkGrey);
 463          call GUI_WriteText(MinX+250,MaxY-30,unpack("na prawo: "),
 464                                                 c_black,c_darkGrey);
 465          call GUI_WriteText(MinX+360,MaxY-30,unpack(":: "),
 466                                                  c_black,c_darkGrey);
 467          call GUI_WriteText(MinX+460,MaxY-50,unpack("ocena: "),
 468                                                 c_black,c_darkGrey);
 469           call STOP_IKONA.write_i;
 470     end INFO;
 471 (*--------------------------------------------------------------*)
 472
 473     Unit ALG_1 : procedure(ilCz,ilB: integer);
 474      var c, i : integer , pp : punkt,
 475            zle, nr, cz, b, yy, ocena, ocenaMax: integer,
 476            Lamana : arrayof punkt;
 477      begin
 478         call PokazPunkty;
 479         ocenaMax := ilCz*ilB;
 480         array Lamana dim(1: il_punktow); yy := 400;
 481         (* wybieram losowo pierwszy odcinek lamanej *)
 482         Lamana(1) := new punkt(10+random*600, yy, c_yellow);
 483         nr := 2; (*numer  punktu lamanej *) yy := yy-40;
 484         call INFO(ilCz, ilB);
 485         zle :=0;
 486         DO (*tworzenie lamanej*)
 487
 488            Lamana(nr):= new punkt(10+random*600, yy,c_yellow);
 489            call GUI_Line(Lamana(nr-1).x, Lamana(nr-1).y,
 490                                  Lamana(nr).x, Lamana(nr).y, c_yellow);
 491
 492             call Zliczanie(Lamana,nr,ilCz,ilB, cz, b);
 493             ocena := cz*(ilB-b) + b*(ilCz-cz);
 494
 495            (*wypisanie informacji o ilosciach punktow na ekranie *)
 496             call WYPISZ_Info(cz,b,ilCz,ilB,ocena);
 497
 498             if GUI_KeyPressed <>0 then
 499               (* zeby przerwac trzeba najpierw nacisnac jakis klucz*)
 500                i := 0;
 501                call GUI_MousePressed(xx,yy,i);
 502                if i=1 and CZY(xx, yy,STOP_IKONA) then call clear_all;exit fi;
 503             fi;
 504             if  ocena> 0.5*ocenaMax then
 505             (*zatwierdzam ten odcinek lamanej *)
 506                    yy := yy-40;
 507                   (* ocenaMax := ocena;*)
 508                    nr := nr+1 ;
 509                    zle := 0;
 510             else (*wycofuje sie z ostatniego odcinka lamanej *)
 511                   call WYMAZ_KONIEC(LAMANA, nr);
 512                   zle := zle +1;
 513                   if zle>10 then
 514                      zle := 0;
 515                      if nr>2 then nr := nr-1; call WYMAZ_KONIEC(LAMANA,nr)
 516                      else
 517                        Lamana(1) := new punkt(10+random*600, 400, c_yellow);
 518                        nr:=2; yy:= 360;
 519                      fi;
 520                   fi;
 521             fi;
 522             if yy <50 then exit fi;
 523             (* jesli lamana dojdzie na sama gore to koniec *)
 524          OD;
 525
 526      end ALG_1;
 527
 528
 529      UNIT WYPISZ_INFO : procedure(cz,b,il_cz,il_b, ocena : integer);
 530      BEGIN
 531      call GUI_Rect(MinX+320,MaxY-60,MinX+360,MaxY-10,c_darkGrey,c_darkGrey);
 532      call GUI_Rect(MinX+390,MaxY-60,MinX+420,MaxY-10,c_darkGrey,c_darkGrey);
 533      call GUI_Rect(MinX+510,MaxY-60,MinX+560,MaxY-10,c_darkGrey,c_darkGrey);
 534      call GUI_WriteInt(MinX+320, MaxY-50, cz,c_red,c_darkGrey);
 535      call GUI_WriteInt(MinX+390, MaxY-50, b,c_white,c_darkGrey);
 536      call GUI_WriteInt(MinX+320, MaxY-30,il_cz-cz,c_red,c_darkGrey);
 537      call GUI_WriteInt(MinX+390, MaxY-30,il_b-b,c_white,c_darkGrey);
 538      call GUI_WriteInt(MinX+510, MaxY-50,ocena ,c_white,c_darkGrey);
 539      END WYPISZ_INFO;
 540
 541      unit Insert: procedure(pp: punkt,Tab : arrayof punkt, il : integer);
 542      (* doloaczanie punktu pp do uporzadkowanej tablicy Tab  o il-elementach *)
 543      var j : integer;
 544      begin
 545            j := il -1;
 546            while  j>0 do
 547                if  pp.mniejsze (Tab(j)) then
 548                  Tab(j+1) := Tab(j);  j := j-1;
 549               else exit fi
 550            od;
 551            Tab(j+1) := pp;
 552      end Insert;
 553
 554      unit punkt : class(x,y,c: integer);
 555          unit mniejsze : function( p : punkt) : boolean;
 556          begin
 557                result := (y< p.y or (y=p.y and x< p.x))
 558          end mniejsze;
 559
 560          unit naLewo : function(p1,p2: punkt):boolean;
 561          begin
 562                if ( (x-p1.x)*(p2.y - p1.y) -(p2.x-p1.x)*(y-p1.y))>0  then
 563                    result := true
 564                else result := false fi
 565          end naLewo;
 566
 567          unit rysuj : procedure;
 568          begin
 569                call GUI_Ellipse(x,y,5,5,0,360,c,c)
 570          end rysuj;
 571     end punkt;
 572
 573     unit WYMAZ_KONIEC: procedure(L : arrayof punkt, nr : integer);
 574     begin
 575           call GUI_Line(L(nr-1).x, L(nr-1).y, L(nr).x, L(nr).y, c_blue);
 576     end WYMAZ_KONIEC;
 577
 578     UNIT ZLICZANIE : procedure(LL: arrayof punkt, nr, ilcz,ilb :integer;
 579               output  cz, b : integer);
 580     (*obliczanie liczby punktow czerwonych i bialych na lewo od lamanej*)
 581      var i, j : integer, boo : boolean;
 582      begin
 583         cz:= 0; (*czerwone na lewo*)
 584         for i := 1 to ilcz do
 585             j := nr;
 586             boo:= true;
 587             while j>1 and boo do
 588                if TabCz(i).naLewo(LL(j-1),LL(j)) then j:= j-1
 589                 else boo := false fi
 590             od;
 591             if boo then cz := cz+1 fi
 592         od ;
 593         b:= 0; (*biale na lewo*)
 594         for i := 1 to ilb do
 595             j := nr;
 596             boo:= true;
 597             while j>1 and boo do
 598                if TabB(i).naLewo(LL(j-1),LL(j)) then j:= j-1
 599                else boo := false fi
 600             od;
 601             if boo then b := b+1 fi
 602         od ;
 603      end ZLICZANIE;
 604
 605      UNIT NaLewo : procedure(p1,p2:punkt; output cz,b : integer);
 606      var i : integer;
 607       begin
 608           cz:= 0; (*czerwone na lewo*)
 609           for i := 1 to ilcz do
 610                if TabCz(i).naLewo(p1,p2) then cz := cz+1 fi
 611          od ;
 612          b:= 0; (*biale na lewo*)
 613          for i := 1 to ilb do
 614                if TabB(i).naLewo(p1,p2) then b := b+1 fi
 615         od ;
 616       end NaLewo;
 617
 618      UNIT chromosom : class(x,y, u,w,ocena: integer);
 619      begin
 620      end chromosom;
 621
 622      UNIT RysujProsta :procedure(x1,y1,x2,y2,c:integer);
 623      begin
 624             (* Narysuj przedluzenie wylosowanej prostej
 625              call GUI_Line(p1.x,400,p2.x,40, c);               *)
 626      end RysujProsta;
 627 (*--------------------------------------------------------------*)
 628
 629
 630      UNIT ALG_2 : procedure(ilCZ, ilB : integer);
 631      var POKOLENIE : arrayof chromosom,
 632           ch : chromosom,
 633           p1, p2 : punkt,
 634           il_pokolen, b, cz,ocena,
 635           ii, i, j,  mocP, il_prob, nrChromosomu : integer,
 636           x,xx,y,yy,mm : integer;
 637
 638      begin
 639           mocP := 10; (*zapamietuje tylko dziesiec najlepszych prob *)
 640
 641           array POKOLENIE dim(1:mocP); (*dwa punkty i ocena*)
 642           nrChromosomu := 0;
 643            il_prob := 20;
 644            il_pokolen := 15;
 645            call PokazPunkty;
 646            call INFO(ilCz, ilB);
 647
 648           for i :=1 to  il_prob do
 649               (* wylosuj dwa punkty*)
 650
 651               p1 := new punkt(10+random*600, 40+random*360, c_yellow);
 652               p2 := new punkt(10+random*600, 40+random*360, c_yellow);
 653              (* narysuj prosta przechodzaca przez te punkty *)
 654               call GUI_Line(p1.x,p1.y,p2.x,p2.y, c_yellow); (*wywolaj RysujProsta*)
 655               x := p1.x + (p2.x-p1.x)*(40-p1.y)/(p2.y-p1.y);
 656               if (x> 600 or x<20) then
 657                       if x<20 then mm := 20 fi ;
 658                     (*tak aby prosta miescila sie w ramce*)
 659                       if x>600 then mm:= 600 fi;
 660                       y := p1.y + (p2.y-p1.y)*(mm-p1.x)/(p2.x-p1.x);
 661               else y := 40 fi;
 662
 663               xx :=p1.x + (p2.x-p1.x)*(400-p1.y)/(p2.y-p1.y);
 664               if (xx> 600 or xx<20) then
 665                        if x<20 then mm := 20 fi ;
 666                       if x>600 then mm:= 600 fi;
 667                       yy := p1.y + (p2.y-p1.y)*(mm-p1.x)/(p2.x-p1.x);
 668               else yy := 400 fi;
 669
 670               call GUI_Line(x,y,xx,yy, c_red);
 671
 672              call NaLewo(p1,p2,cz, b);
 673              ocena := cz*(ilB-b) + b*(ilCz-cz);
 674
 675               (* ocen ja *)
 676               call WYPISZ_INFO(cz,b,ilCz,ilB,ocena);
 677               while  GUI_KeyPressed=0 do od; (*czeka na popchniecie *)
 678                   (*wymaz  prosta*)
 679               call GUI_Line(p1.x, p1.y, p2.x, p2.y, c_blue);
 680                if i<10 then ii := i else ii := mocP fi;
 681
 682                 (*wpisz te prosta do tablicy POKOLENIE , tzn.:*)
 683                 (*metoda insertion sort dolaczam nowy chromosom do tworzonego pokolenia*)
 684                 while ii > 1 do
 685                    if POKOLENIE(ii-1).ocena < ocena then
 686                       POKOLENIE (ii) := POKOLENIE (ii-1);
 687                       ii := ii-1;
 688                    else
 689                        exit
 690                    fi;
 691                 od;
 692                  POKOLENIE (ii) := new chromosom(p1.x, p1.y,p2.x,p2.y, ocena);
 693             od (* koniec  prob*) ;
 694            for j := 1 to il_pokolen do
 695               (* narysuj najlepsza prosta  i jej ocene *)
 696                call GUI_Line(POKOLENIE(1).x,POKOLENIE(1).y,
 697                                       POKOLENIE(1).u,POKOLENIE(1).w, c_yellow);
 698                call GUI_WriteInt(MinX+510, MaxY-50,
 699                                  POKOLENIE(1).ocena,c_white,c_darkGrey);
 700
 701               (* mutacja lub / i  krzyzowanie *)
 702                call mutacja(prMutacji,POKOLENIE) ;
 703               (* if random >pr_krzyzowanie then call krzyzowanie fi;*)
 704               (*wyznaczam nastepne pokolenie*)
 705               (* call ruletka; *)
 706                i := 0;
 707                call GUI_MousePressed(xx,yy,i);
 708                if i = 1 and CZY(xx, yy,STOP_IKONA) then call clear_all; exit fi;
 709           od;
 710      end ALG_2;
 711
 712      UNIT MUTACJA : procedure(prMutacji: integer;
 713                                         inout POKOLENIE: arrayof chromosom);
 714      var i, j, ii, cz, b, mocP, ocena : integer, chr : chromosom;
 715      begin
 716            mocP :=  upper(POKOLENIE);
 717            for i := 1 to mocP do
 718                 if random>prMutacji then
 719                        chr := POKOLENIE(i);
 720                        j := random * 8; (*wylosuj pozycje mutowana*)
 721                       (* zmutuj *)
 722                        case j
 723                             when 0,1 :  chr.x := 10+random*600;
 724                             when 2,3 :  chr.y := 40+random*360;
 725                             when 4,5 :  chr.u := 10+random*600;
 726                             when 6,7 :  chr.w := 40+random*360;
 727                        esac;
 728
 729                        (* chr.ocena :=*)
 730                        (* wylicz ocene zmutowanego chromosomu *)
 731                        call NaLewo(new punkt(chr.x,chr.y,0),new punkt(chr.u,chr.w,0),cz, b);
 732                        ocena := cz*(ilB-b) + b*(ilCz-cz);
 733
 734                       (* wstaw na wlasciwe miejsce  w tablicy POKOLENIE*)
 735                        if chr.ocena > POKOLENIE(i).ocena then
 736                               ii := i;
 737                               while ii>1 do
 738                                       if POKOLENIE(ii-1).ocena < chr.ocena then
 739                                           POKOLENIE (ii) := POKOLENIE (ii-1);
 740                                           ii := ii-1;
 741                                       else    exit
 742                                       fi;
 743                               od;
 744                               POKOLENIE (ii) := chr;
 745                        else
 746                              ii := i;
 747                              while ii < mocP do
 748                                  if POKOLENIE(ii+1).ocena > chr.ocena then
 749                                      POKOLENIE (ii) := POKOLENIE (ii+1);
 750                                      ii := ii+1;
 751                                  else    exit  fi;
 752                             od;
 753                             POKOLENIE (ii) := chr;
 754                        fi;
 755                 fi;
 756             od;
 757     end MUTACJA;
 758
 759      UNIT Krzyzowanie : procedure;
 760      begin
 761      end Krzyzowanie;
 762
 763 (*--------------------------------------------------------------*)
 764
 765      VAR
 766
 767            OK_ikona,YES_ikona,NO_ikona, STOP_IKONA,
 768                                       EXIT_IKONA, CONTINUE_IKONA : IKONA,
 769            menu_main, menu_START : menu,
 770            boo: boolean,
 771                  TabCz, TabB : arrayof punkt,
 772                  xx,yy,r,l,z,i , il_punktow, ilCz, ilB, jakosc : integer,
 773                  prMutacji, prKrzyzowania : real;
 774
 775     handlers
 776       when MEMERROR : call comment("Zabraklo pamieci");
 777                       call waitt;
 778       when ACCERROR : call comment("Reference to none PR GLOWNY");
 779                       call waitt;
 780       when LOGERROR : call comment("Niepoprawny Attach PR GLOWNY");
 781                       call waitt;
 782       when CONERROR : call comment(" Array-index error PR GLOWNY");
 783                       call waitt;
 784       when SYSERROR : call comment("input-output error");
 785                       call waitt;
 786       when NUMERROR : call comment("blad numeryczny");
 787                       call waitt;
 788       others : call comment("Jakis blad ");
 789                       call waitt;
 790     end handlers;
 791
 792
 793    BEGIN  (* tu musi sie wygenerowac menu  *)
 794
 795          YES_ikona := new IKONA(6,450,360,500,385,3,"YES");
 796          NO_ikona  := new IKONA(6,505,360,555,385,3,"NO");
 797          STOP_IKONA :=  new IKONA(c_green,590,430,635,460,3,"STOP");
 798          CONTINUE_IKONA :=
 799                               new IKONA(c_lightGrey,400,350,550,390,3,"  C O N T I N U E");
 800
 801           (* Strona tytulowa *)
 802            CALL GUI_Rect(minX+1,minY+1,maxX-2,maxY-2,c_black,c_lightGrey);
 803
 804            CALL GUI_writeText(250,100,unpack("PROJEKT"), c_black,c_lightGrey);
 805            CALL GUI_writeText(250,200,unpack(
 806                   "R O Z D Z I E L A N I E   P U N K T O W"), c_black,c_lightGrey);
 807
 808            call CONTINUE_IKONA.write_i;
 809             i := 0;
 810             while i<>1 or not CZY(xx,yy,CONTINUE_IKONA) do
 811                    call GUI_MousePressed(xx,yy,i);
 812             od;
 813              call CONTINUE_IKONA.push;
 814
 815
 816            (* creation of main menu *)
 817            menu_main := new menu(minX,maxX,minY,maxY,new OPTIONS_MAIN(4));
 818
 819            menu_main.ICONES(3).sub_menu :=
 820                    new menu(minX,maxX,minY,maxY,new OPTIONS_help(3));
 821
 822            menu_main.ICONES(4).sub_menu :=
 823                    new menu(minX,maxX,minY,maxY,new OPTIONS_START(4));
 824
 825
 826                  il_punktow := 100;
 827                  jakosc := 70;
 828                  prMutacji := 0.7;
 829            attach(menu_main);
 830
 831            call comment("THIS ENDS THE PROGRAM EXECUTION !!!!!");
 832                  call endRun;
 833          END;
 834
 835    END (* block od Grafiki *)
 836 END RozdzileaniePunktow;
 837
 838
 839
 840  \0\0