home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SIERP.ZIP / SIERP.PAS
Encoding:
Pascal/Delphi Source File  |  1986-04-11  |  2.8 KB  |  124 lines
  1.  
  2.  program Sierpinski(input,output);
  3. {This program was taken from N. Wirth, "Algorithms + Data Structures =
  4. Programs, Prentice-Hall, 1976.  Further information on Sierpinski curves
  5. may be found in "Creative Computing", July 1984.}
  6.  
  7. {$U-   Change the "-" to a "+" if you want Ctrl-Break to interrupt.}
  8.  
  9. {The parameters below are set to draw Sierpinski curves up to level 6.
  10. When the "?" appears pressing "x" will exit the program.  Pressing any
  11. other key will change the palette.}
  12.  
  13. const n=6;h0=256;
  14. type AString = String[80];
  15. var i,h,x,y,x0,y0,xlast,ylast,plotcolor : integer;
  16.  
  17. procedure SwitchToColor;
  18. begin
  19. memw[0000:$0410] := (mem[0000:$0410] and $00cf) or $0010;
  20. Textmode
  21. end;
  22.  
  23. procedure CenterLine(ThisString : AString; xcoord, ycoord: integer);
  24. begin
  25. xcoord := xcoord + 20 - length(ThisString) div 2;
  26. gotoxy(xcoord,ycoord);
  27. write(ThisString);
  28. end;
  29.  
  30. procedure Initialize;
  31. begin
  32. SwitchToColor;
  33. GraphColorMode;
  34. CenterLine('Sierpinski Curve',1,1);
  35. GraphWindow(30,10,319,199);
  36. GraphBackGround(1);
  37. Palette(0);
  38. end;
  39.  
  40. procedure ChangePalette;
  41. var PaletteNumber : integer;
  42.     Ch : char;
  43.  
  44. begin
  45. PaletteNumber := 0;
  46. repeat
  47. read(Kbd, Ch);
  48. PaletteNumber := PaletteNumber+1;
  49. if PaletteNumber > 3 then PaletteNumber := 0;
  50. Palette(PaletteNumber)
  51. until(Ch ='x')
  52. end;
  53.  
  54. procedure plotline;
  55. begin
  56. draw(xlast,ylast,x,y,plotcolor);
  57. xlast :=x;ylast:=y;
  58. end;
  59.  
  60. procedure setplot;
  61. begin
  62. xlast := x; ylast := y;
  63. end;
  64.  
  65. procedure A(i:integer); forward;
  66. procedure B(i:integer); forward;
  67. procedure C(i:integer); forward;
  68. procedure D(i:integer); forward;
  69.  
  70. procedure A;
  71. begin if i > 0 then
  72.     begin A(i-1);x:= x+h;y:=y-h;plotline;
  73.           B(i-1);x:= x+2*h;plotline;
  74.           D(i-1);x:=x+h;y:=y+h;plotline;
  75.           A(i-1)
  76.     end
  77. end;
  78.  
  79. procedure B;
  80. begin if i > 0 then
  81.     begin B(i-1);x:=x-h;y:=y-h;plotline;
  82.           C(i-1);y:=y-2*h;plotline;
  83.           A(i-1);x:=x+h;y:=y-h;plotline;
  84.           B(i-1)
  85.     end
  86. end;
  87.  
  88. procedure C;
  89. begin if i > 0 then
  90.     begin C(i-1);x:=x-h; y:=y+h;plotline;
  91.           D(i-1);x:=x-2*h;plotline;
  92.           B(i-1);x:=x-h;y:=y-h;plotline;
  93.           C(i-1)
  94.     end
  95. end;
  96.  
  97. procedure D;
  98. begin if i > 0 then
  99.     begin D(i-1);x:=x+h;y:=y+h;plotline;
  100.           A(i-1);y:=y+2*h;plotline;
  101.           c(i-1);x:=x-h;y:=y+h;plotline;
  102.           D(i-1)
  103.     end
  104. end;
  105.  
  106. begin
  107. initialize;
  108. plotcolor := 1;
  109. i := 0; h:=h0 div 4; x0 := 2*h; y0 :=3*h;
  110. repeat i:=i+1;x0:=x0-h;
  111.    h:=h div 2; y0:=y0+h;
  112.    x:=x0;y:=y0;setplot;
  113.    A(i);x:=x+h;y:=y-h;plotline;
  114.    B(i);x:=x-h;y:=y-h;plotline;
  115.    C(i);x:=x-h;y:=y+h;plotline;
  116.    D(i);x:=x+h;y:=y+h;plotline;
  117.    plotcolor := plotcolor + 1;if plotcolor > 3 then plotcolor := 1;
  118.    gotoxy(39,25); write(i);
  119.    until (i=n);
  120.    gotoxy(39,24);
  121.    write('?');
  122.    ChangePalette;
  123. end.
  124.