home *** CD-ROM | disk | FTP | other *** search
/ The Party 1994: Try This At Home / disk_image.bin / source / gallery / subdirs.exe / MAP / PPATH.PAS < prev    next >
Pascal/Delphi Source File  |  1993-07-16  |  8KB  |  387 lines
  1. {  INSTRUCCIONES:
  2.  
  3.    s  :  salvar puntos de control a fichero
  4.    l  :  cargar puntos de un fichero
  5.    Esc:  salir del programa
  6.  
  7.    PgUp/RePág : Zoom hacia dentro
  8.    PgDn/AvPág : Zoom hacia fuera
  9.  
  10.    Tab : seleccionar siguiente punto de control (el pto seleccionado
  11.          aparece más gordo)
  12.    Shift Tab : seleccionar anterior punto de control.
  13.    Boton derecho ratón : seleccionar punto de control más cercano al
  14.          cursor.
  15.  
  16.    Boton izquierdo ratón : insertar punto de control.
  17.    Insert : Insertar punto de control después del actualmente seleccionado
  18.    Delete : Borrar punto de control seleccionado
  19.  
  20.    Espacio : cambiar posición del punto de control seleccionado a
  21.             la posición del cursor
  22.  
  23.  
  24.    t : Asociar instante de tiempo al punto de control seleccionado.
  25.  
  26. }
  27.  
  28.  
  29.  
  30.  
  31. {$N+}
  32. uses graph, crt;
  33.  
  34. type real=single;
  35.  
  36. procedure InitMouse; assembler;
  37. asm
  38.    mov ax,0
  39.    int $33
  40.    mov ax,7
  41.    mov cx,0
  42.    mov dx,639
  43.    int $33
  44.    mov ax,8
  45.    mov cx,0
  46.    mov dx,479
  47.    int $33
  48. end;
  49.  
  50. procedure SetMouse( X,Y : integer ); assembler;
  51. asm
  52.    mov ax,4
  53.    mov cx,X
  54.    mov dx,Y
  55.    int $33
  56. end;
  57.  
  58. procedure GetMouse(var X,Y : integer); assembler;
  59. asm
  60.     mov ax,3
  61.     int $33
  62.     les di, X
  63.     mov [es:di], cx
  64.     les di, Y
  65.     mov [es:di], dx
  66. end;
  67.  
  68. function GetMouseButton:word; assembler;
  69. asm
  70.   mov ax,3
  71.   int $33
  72.   mov ax, bx
  73. end;
  74.  
  75. type TPoint = array[0..2] of real;
  76.      TSplineFac = array[0..3] of real;
  77.  
  78. var grd,grm : integer;
  79.  
  80.    MAP : array[0..63,0..63] of byte;
  81.  
  82. procedure MakeMap;
  83. var x,y : integer;
  84.     CharMap, s : string;
  85.     I : Text;
  86. begin
  87.   assign(I,'map.gri'); reset(I);
  88.   y := 0;
  89.   repeat
  90.     readln(I,s);
  91.     if s<>'' then
  92.     if s[1]<>';' then begin
  93.       if length(s)<>64 then CharMap := ' '+s
  94.       else begin
  95.         for x := 0 to 63 do
  96.           MAP[y,63-x] := Pos(s[x+1],CharMap)-1;
  97.         inc(y)
  98.       end;
  99.     end;
  100.   until eof(I);
  101.   close(I);
  102. end;
  103.  
  104. var MX0,MX1,MY0,MY1 : real;
  105.     CX, CY : real;
  106.  
  107. function ScaleX(x:real):integer;
  108. begin
  109.   scaleX := round( (x-MX0)/(MX1-MX0)*639 );
  110. end;
  111. function ScaleY(y:real):integer;
  112. begin
  113.   scaleY := round( (y-MY0)/(MY1-MY0)*479 );
  114. end;
  115. function UnScaleX(x:real):real;
  116. begin
  117.   unscaleX := MX0+x*(MX1-MX0)/639;
  118. end;
  119. function UnScaleY(y:real):real;
  120. begin
  121.   unscaleY := MY0+y*(MY1-MY0)/479;
  122. end;
  123.  
  124. procedure DrawMap;
  125. var i,j : integer;
  126.     xs,ys : real;
  127.     x0,x1,y0,y1:integer;
  128.     xx0,xx1,yy0,yy1:integer;
  129.   function Bound(x:integer):integer;
  130.   begin
  131.     if x<0 then x:=0;
  132.     if x>63 then x:=63;
  133.     Bound := x;
  134.   end;
  135. begin
  136.   setcolor( Green );
  137.   xx0:=Bound(round(MX0)); xx1:=Bound(round(MX1));
  138.   yy0:=Bound(round(MY0)); yy1:=Bound(round(MY1));
  139.   for i := xx0 to xx1 do
  140.   for j := yy0 to yy1 do
  141.     if Map[j,i]<>0 then begin
  142.       x0 := ScaleX(i); x1 := ScaleX(i+1);
  143.       y0 := ScaleY(j); y1 := ScaleY(j+1);
  144.       rectangle( x0,y0, x1,y1 );
  145.       line( x0,y0, x1,y1 );
  146.       line( x0,y1, x1,y0 );
  147.   end;
  148. end;
  149.  
  150. var NumPts, SelPt : integer;
  151.     P : array[1..1000] of TPoint;
  152.  
  153. procedure DrawSpline;
  154. var i,j,k : integer;
  155.     F : array[0..1] of TSplineFac;
  156.     t,xx,yy : real;
  157.   procedure SplineFac( var F : TSplineFac; xm1,x0,x1,x2 : real );
  158.   begin
  159.     F[0] := (xm1+4*x0+x1)/6;
  160.     F[1] := (-xm1+x1)/2;
  161.     F[2] := (xm1+x1)/2-x0;
  162.     F[3] := (-xm1+3*(x0-x1)+x2)/6;
  163.   end;
  164.   function IntToStr( i :integer):string;
  165.   var s:string[16];
  166.   begin
  167.     str(i,s);
  168.     IntToStr := s;
  169.   end;
  170. begin
  171.   setcolor(yellow);
  172.   settextstyle(smallfont, horizdir, 2);
  173.   for i := 1 to numPts do begin
  174.      j := round(scaleX(P[i,0])); k := round(scaleY(P[i,1]));
  175.      circle( j, k, 2 );
  176.      if P[i,2]<>-1 then outtextxy( j+5, k-3, IntToStr(round(P[i,2])) );
  177.   end;
  178.   if SelPt<>0 then circle( round(scaleX(P[SelPt,0])), round(scaleY(P[SelPt,1])), 4 );
  179.   for i := 2 to NumPts-2 do begin
  180.  
  181.     for j := 0 to 1 do begin
  182.       SplineFac( F[j], P[i-1,j], P[i,j], P[i+1,j], P[i+2,j] );
  183.     end;
  184.  
  185.     for k := 0 to 20 do begin
  186.       t := k/20;
  187.       xx := F[0,0]+t*(F[0,1]+t*(F[0,2]+t*F[0,3]));
  188.       yy := F[1,0]+t*(F[1,1]+t*(F[1,2]+t*F[1,3]));
  189.       putpixel( round(ScaleX(xx)), round(ScaleY(yy)), White );
  190.     end;
  191.   end;
  192. end;
  193.  
  194. procedure DrawMouse(b:boolean);
  195. var c:byte;
  196.     ccx,ccy : integer;
  197. begin
  198.   if b = true then c:=red else c := black;
  199.   ccx := scaleX(CX);
  200.   ccy := scaleY(CY);
  201.   putpixel(ccx-3,ccy-3,c);
  202.   putpixel(ccx+3,ccy-3,c);
  203.   putpixel(ccx-3,ccy+3,c);
  204.   putpixel(ccx+3,ccy+3,c);
  205.   putpixel(ccx,ccy,c);
  206. end;
  207.  
  208. procedure ReDraw;
  209. begin
  210.   ClearDevice;
  211.   DrawMap;
  212.   DrawSpline;
  213.   DrawMouse(true);
  214. end;
  215.  
  216. procedure UpdateMouse;
  217. var ccx, ccy : integer;
  218. begin
  219.   GetMouse( ccx, ccy );
  220.   if not ( (ccx=scaleX(cx)) and (ccy=scaleY(cy)) ) then begin
  221.     DrawMouse(False);
  222.     cx := unscaleX(ccx);
  223.     cy := unscaleY(ccy);
  224.     DrawMouse(True);
  225.   end;
  226. end;
  227.  
  228. var ch : word;
  229.     escape : boolean;
  230.  
  231. procedure ZoomIn;
  232. var xx,yy:real;
  233. begin
  234.   xx := MX1-MX0;
  235.   MX0 := CX-0.4 *xx;
  236.   MX1 := CX+0.4 *xx;
  237.   yy := MY1-MY0;
  238.   MY0 := CY-0.4 *yy;
  239.   MY1 := CY+0.4 *yy;
  240.   SetMouse( ScaleX(CX),ScaleY(CY) );
  241.   ReDraw;
  242. end;
  243.  
  244. procedure ZoomOut;
  245. var xx,yy:real;
  246. begin
  247.   xx := MX1-MX0;
  248.   MX0 := CX-0.6 *xx;
  249.   MX1 := CX+0.6 *xx;
  250.   yy := MY1-MY0;
  251.   MY0 := CY-0.6 *yy;
  252.   MY1 := CY+0.6 *yy;
  253.   SetMouse( ScaleX(CX),ScaleY(CY) );
  254.   ReDraw;
  255. end;
  256.  
  257. procedure insertpoint;
  258. var i : integer;
  259. begin
  260.   if SelPt<NumPts then for i := NumPts+1 downto SelPt+2 do P[i] := P[i-1];
  261.   inc(NumPts);
  262.   P[SelPt+1,0] := CX;
  263.   P[SelPt+1,1] := CY;
  264.   P[SelPt+1,2] := -1;
  265.   inc(SelPt);
  266.   ReDraw;
  267. end;
  268.  
  269. procedure deletepoint;
  270. var i : integer;
  271. begin
  272.   if SelPt<NumPts then for i := SelPt to NumPts-1 do P[i] := P[i+1];
  273.   dec(NumPts);
  274.   ReDraw;
  275. end;
  276.  
  277. procedure SavePoints;
  278. var s : string;
  279.     f : file;
  280.     i : integer;
  281. begin
  282.   restorecrtmode;
  283.   write('SAVE from file: '); readln(s);
  284.   assign(f,s); rewrite(f,1);
  285.   blockwrite(f,SelPt,2);
  286.   blockwrite(f,NumPts,2);
  287.   blockwrite(f,P,NumPts*SizeOf(TPoint));
  288.   close(f);
  289.   initgraph(grd,grm,'');
  290.   redraw;
  291. end;
  292.  
  293. procedure LoadPoints;
  294. var s : string;
  295.     f : file;
  296.     i : integer;
  297. begin
  298.   restorecrtmode;
  299.   write('LOAD to file: '); readln(s);
  300.   assign(f,s); reset(f,1);
  301.   blockread(f,SelPt,2);
  302.   blockread(f,NumPts,2);
  303.   blockread(f,P,NumPts*SizeOf(TPoint));
  304.   close(f);
  305.   initgraph(grd,grm,'');
  306.   redraw;
  307. end;
  308.  
  309. procedure FindClosestPoint;
  310. var i, besti : integer;
  311.     d, bestd : real;
  312. begin
  313.   besti := 1;
  314.   bestd := 1e6;
  315.   for i := 1 to NumPts do begin
  316.     d := sqr(CX-P[i,0])+sqr(CY-P[i,1]);
  317.     if d<bestd then begin
  318.       bestd := d;
  319.       besti := i
  320.     end;
  321.   end;
  322.   SelPt := besti;
  323.   ReDraw;
  324. end;
  325.  
  326. procedure InputTime;
  327. begin
  328.   restorecrtmode;
  329.   writeln('Timing for control point ',SelPt,'. ');
  330.   writeln;
  331.   write('Time (-1=no time restraint):  '); readln(P[SelPt,2]);
  332.   initgraph(grd,grm,'');
  333.   redraw;
  334. end;
  335.  
  336. BEGIN
  337.   writeln('MAP.GRI and EGAVGA.BGI must be in current directory.');
  338.   delay(500);
  339.   grd := VGA; grm := VGAHi; {640x480}
  340.   initgraph( grd,grm, '' );
  341.   MakeMap;
  342.  
  343.   MX0:=0; MX1:=64; MY0:=0; MY1:=64;
  344.   CX := 32; CY := 32;
  345.   InitMouse;
  346.   SetMouse( ScaleX(CX), ScaleY(CY) );
  347.  
  348.   escape := false;
  349.   NumPts := 0;
  350.   SelPt := 0;
  351.   ReDraw;
  352.   repeat
  353.     if keypressed then begin
  354.       ch := ord(ReadKey);
  355.       if ch=0 then ch := ord(ReadKey)*$100+ch;
  356.       case ch of
  357.        ord('t'): InputTime;
  358.        ord('s'): SavePoints;
  359.        ord('l'): LoadPoints;
  360.        27: escape := true;
  361.        $4900: ZoomIn;
  362.        $5100: ZoomOut;
  363.        9: begin
  364.            inc(SelPt); if SelPt>=NumPts then SelPt := 1;
  365.            ReDraw;
  366.           end;
  367.        $0f00: begin
  368.            dec(SelPt); if SelPt<=0 then SelPt := NumPts;
  369.            ReDraw;
  370.           end;
  371.        $5200: InsertPoint;
  372.        $5300: DeletePoint;
  373.        32: begin
  374.              P[SelPt,0] := CX;
  375.              P[SelPt,1] := CY;
  376.              ReDraw;
  377.           end;
  378.       end;
  379.     end else begin
  380.       UpdateMouse;
  381.       if GetMouseButton=1 then InsertPoint;
  382.       if GetMouseButton=2 then FindClosestPoint;
  383.     end;
  384.   until escape;
  385.   closegraph;
  386. END.
  387.