home *** CD-ROM | disk | FTP | other *** search
/ Collection of Hack-Phreak Scene Programs / cleanhpvac.zip / cleanhpvac / MYPROGS.ZIP / PUZZLE.PAS < prev    next >
Pascal/Delphi Source File  |  1995-04-06  |  6KB  |  317 lines
  1. program souris;
  2. uses crt,graph,dos;
  3.  
  4. const max=16360;
  5.       maxp=540;
  6.       ECRAN=$A000;
  7.       lar=27;
  8.       hau=20;
  9.       niveaucomplex=80;
  10.  
  11. type tab= array [1..max] of byte;
  12.      tabp= array [0..24,1..maxp] of byte;
  13.      plateau= array [1..5,1..5] of byte;
  14.      tabnom= array[1..7] of string;
  15.  
  16. var x,y,bouton: integer;
  17.     nbbouton,status: integer;
  18.     fin :boolean;
  19.     image: tab;
  20.     f: file of tab;
  21.     largeimage:word;
  22.     hauteur_image:word;
  23.     place_ecran: word;
  24.     pimage: tabp;
  25.     p: plateau;
  26.     i:integer;
  27.     xp,yp: byte;
  28.     yc,xc: byte;
  29.     niveau: byte;
  30.     nom: tabnom;
  31.  
  32. FUNCTION TestMode(Mode:BYTE):BOOLEAN;
  33. VAR REGS:REGISTERS;
  34. BEGIN
  35.  WITH REGS DO
  36.  BEGIN
  37.   Ah:=$F;
  38.   Intr($10,REGS);
  39.   IF Al<>Mode THEN TestMode:=TRUE
  40.               ELSE TestMode:=FALSE;
  41.  END;
  42. END;
  43.  
  44. PROCEDURE InitMode(Mode:BYTE);
  45. VAR REGS:REGISTERS;
  46. BEGIN
  47.  WITH REGS DO
  48.  BEGIN
  49.   Ah:=0;
  50.   Al:=Mode;
  51.   Intr($10,REGS);
  52.   IF TestMode(mode) THEN Write('Erreur Graphique Fatale !!!!');
  53.  END;
  54. END;
  55.  
  56. procedure conversion;
  57. var i: word;
  58. BEGIN
  59. for i:=1 to max do image[i]:=trunc(image[i]*0.063)+15;
  60. END;
  61.  
  62. procedure AFFICHE_IMAGE;
  63. var i,j: integer;
  64.     n,it: word;
  65. BEGIN
  66.  n:=9;
  67.  i:=0;
  68.  it:=0;
  69.  repeat
  70.  j:=0;
  71.    repeat
  72.      mem[ECRAN:place_ecran+it+j]:=image[n];
  73.      mem[ECRAN:place_ecran+it+j+1]:=image[n];
  74.      mem[ECRAN:place_ecran+it+j+320]:=image[n];
  75.      mem[ECRAN:place_ecran+it+j+321]:=image[n];
  76.      inc(n);
  77.      inc(j);inc(j);
  78.    until j=largeimage*2;
  79.   inc(i);
  80.   it:=it+640;
  81.  until i=hauteur_image;
  82. END;
  83.  
  84. procedure transfere;
  85. var i,j: integer;
  86.     n,it,e: word;
  87. BEGIN
  88. for x:=0 to 23 do
  89.  BEGIN
  90.    n:=1;
  91.    i:=0;
  92.    it:=0;
  93.    e:=((x div 5))*640*hau+(x mod 5)*lar*2;
  94.     repeat
  95.      j:=0;
  96.       repeat
  97.         pimage[x,n]:=mem[ECRAN:place_ecran+it+j+e];
  98.         inc(n);
  99.         inc(j);inc(j);
  100.       until j>=lar*2;
  101.     inc(i);
  102.     it:=it+640;
  103.    until i>=hau;
  104.  END;
  105. for i:=1 to maxp do pimage[24,i]:=0;
  106. END;
  107.  
  108. procedure AFFICHE_petite_IMAGE( x,k : byte);
  109. var i,j: integer;
  110.     n,it,e: word;
  111. BEGIN
  112.  n:=1;
  113.  i:=0;
  114.  it:=0;
  115.  e:=(x div 5)*640*(hau-1)+(x mod 5)*lar*2;
  116.  repeat
  117.  j:=0;
  118.    repeat
  119.      mem[ECRAN:place_ecran+e+it+j]:=pimage[k,n];
  120.      mem[ECRAN:place_ecran+e+it+j+1]:=pimage[k,n];
  121.      mem[ECRAN:place_ecran+e+it+j+320]:=pimage[k,n];
  122.      mem[ECRAN:place_ecran+e+it+j+321]:=pimage[k,n];
  123.      inc(n);
  124.      inc(j);inc(j);
  125.    until j=lar*2;
  126.   inc(i);
  127.   it:=it+640;
  128.  until i=hau-1;
  129. END;
  130.  
  131. procedure mousestatus(var status,nbbouton:integer);
  132. var regs: REGISTERS;
  133. BEGIN
  134.     with regs do
  135.      BEGIN
  136.      ax:=0;
  137.      intr($33,regs);
  138.      status:=ax;
  139.      nbbouton:=bx;
  140.   END;
  141. END;
  142.  
  143. procedure montrepointeur;
  144. var regs: REGISTERS;
  145. BEGIN
  146.   with regs do
  147.     BEGIN
  148.      ax:=1;
  149.      intr($33,regs);
  150.     END;
  151. END;
  152.  
  153. procedure cachepointeur;
  154. var regs: REGISTERS;
  155. BEGIN
  156.   with regs do
  157.     BEGIN
  158.      ax:=2;
  159.      intr($33,regs);
  160.     END;
  161. END;
  162. procedure posetbouton(var x,y,bouton:integer);
  163. var regs: REGISTERS;
  164. BEGIN
  165.   with regs do
  166.     BEGIN
  167.      ax:=3;
  168.      intr($33,regs);
  169.     x:=cx;
  170.     y:=dx;
  171.     bouton:=bx;
  172.     END;
  173. END;
  174.  
  175. procedure lecture;
  176. BEGIN
  177.  assign(f,nom[niveau]);
  178.  reset(f);
  179.  read(f,image);
  180.  close(f);
  181. END;
  182.  
  183. procedure AFF_plateau;
  184. var i,j:byte;
  185. BEGIN
  186.  for i:=1 to 5 do
  187.    for j:=1 to 5 do
  188.       affiche_petite_image((i-1)*5+j-1,p[i,j]);
  189. END;
  190.  
  191. procedure ECHANGE(var xp,yp,x,y:byte);
  192. var tampon:byte;
  193. BEGIN
  194.   tampon:=p[x,y];
  195.   p[x,y]:=p[xp,yp];
  196.   p[xp,yp]:=tampon;
  197.   xp:=x;
  198.   yp:=y;
  199. END;
  200. function GAGNE:boolean;
  201. var i,j,n: byte;
  202.     test: boolean;
  203. BEGIN
  204.  n:=0;
  205.  test:=true;
  206.  for i:=1 to 5 do
  207.    for j:=1 to 5 do
  208.      BEGIN
  209.       if p[i,j]<>n then test:=false;
  210.       inc(n);
  211.      END;
  212. GAGNE:=test;
  213. END;
  214.  
  215. procedure initplateau;
  216. var i,j,n,a,xt,yt: byte;
  217.     y: word;
  218. BEGIN
  219.  n:=0;
  220.  for i:=1 to 5 do
  221.    for j:=1 to 5 do
  222.      BEGIN
  223.       p[i,j]:=n;
  224.       inc(n);
  225.      END;
  226.    for y:=1 to niveaucomplex do
  227.       BEGIN
  228.         xt:=xp;
  229.         yt:=yp;
  230.         a:=random(4);
  231.         case a of
  232.           0: if xp-1>0 then BEGIN xt:=xt-1;echange(xp,yp,xt,yp);END;
  233.           1: if xp+1<6 then BEGIN xt:=xt+1;echange(xp,yp,xt,yp);END;
  234.           2: if yp-1>0 then BEGIN yt:=yt-1;echange(xp,yp,xp,yt);END;
  235.           3: if yp+1<6 then BEGIN yt:=yt+1;echange(xp,yp,xp,yt);END;
  236.         END;
  237.       END;
  238. END;
  239.  
  240. function DEDANS(xi,xs,yi,ys:word):boolean;
  241. BEGIN
  242.   DEDANS:=(x>xi) and (x<xs) and (y>yi) and (y<ys);
  243. END;
  244.  
  245. procedure JEU_MOUSE;
  246. var  xt,yt: byte;
  247. BEGIN
  248.   if DEDANS(place_ecran*2,(place_ecran+largeimage*2)*2,0,200)
  249.      then
  250.       BEGIN
  251.        xt:=(x-place_ecran*2) div (lar*2);
  252.        xt:=xt div 2;
  253.        inc(xt);
  254.        yt:=y div (hau*2);
  255.        inc(yt);
  256.        if ((yt=xp-1) and (xt=yp)) or
  257.             ((yt=xp+1) and (xt=yp)) or
  258.                  ((yt=xp) and (xt=yp-1)) or
  259.                    ((yt=xp) and (xt=yp+1))
  260.                                THEN
  261.                                   BEGIN
  262.                           cachepointeur;
  263.                           affiche_petite_image((xp-1)*5+yp-1,p[yt,xt]);
  264.                           ECHANGE(xp,yp,yt,xt);
  265.                           affiche_petite_image((xp-1)*5+yp-1,p[xp,yp]);
  266.                           montrepointeur;
  267.                                   END;
  268.        END;
  269. END;
  270.  
  271. BEGIN
  272.   writeln('Pour quitter appuyer sur le boutton de gauche et celui de droite');
  273.   writeln('Appuyer sur une touche ');
  274.   readkey;
  275.   randomize;
  276.   niveau:=1;
  277.   nom[1]:='dessin1.tif';
  278.   nom[2]:='dessin2.tif';
  279.   nom[3]:='dessin3.tif';
  280.   nom[4]:='dessin4.tif';
  281.   nom[5]:='dessin5.tif';
  282.   nom[6]:='dessin6.tif';
  283.   nom[7]:='dessin7.tif';
  284.   repeat
  285.   xp:=5;
  286.   yp:=5;
  287.   largeimage:=136;
  288.   hauteur_image:=100;
  289.   place_ecran:=(320-largeimage*2) div 2;
  290.   initmode($13);
  291.   lecture;
  292.   conversion;
  293.   affiche_image;
  294.   transfere;
  295.   clrscr;
  296.   initplateau;
  297.   aff_plateau;
  298.   mousestatus(status,nbbouton);
  299.   if status=0 then halt(1);
  300.      montrepointeur;
  301.      fin:=false;
  302.      repeat
  303.       posetbouton(x,y,bouton);
  304.       if bouton=3 then fin:=true;
  305.       if bouton=1 then jeu_mouse;
  306.       until (fin) or (gagne);
  307.       inc(niveau);
  308.       if not(fin) then BEGIN repeat
  309.                              until keypressed;
  310.                        END;
  311.       if niveau=7 then fin:=true;
  312.   until (fin);
  313.   cachepointeur;
  314.   status:=0;
  315.   initmode($03);
  316.   writeln(' A une prochaine');
  317. END.