home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG013.ARC / SIERPIN.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  4KB  |  156 lines
  1. program SIERPIN3;
  2.  
  3. {  Demonstration program in Turbo Pascal for
  4.          the MicroBee by Bob Burt
  5.  
  6.    Program to set up  PCG on the MicroBee for
  7.    LORES graphics and  PLOT between any  pair
  8.    of x,y coordinates, assuming a screen with
  9.    80 x 24 format. This version operates with
  10.    a plot routine using  integer variables to
  11.    speed up  the  plotting  rate,  but with a
  12.    real variable option  for the x coordinate
  13.    to cover values above 128
  14.  
  15.    Since the  4th  order  width (w) is not an
  16.    integer, only  3 orders  are permitted for
  17.    this version
  18.  
  19.        x coordinate range: 0 to 159
  20.        y coordinate range: 0 to 71
  21.        0,0 at top left of screen
  22.  
  23.   IMPORTANT :  Compiler switch A  must be set
  24.   to  negative  for  the RECURSIVE procedures
  25.             and MAIN code ONLY !
  26.  
  27.   This is the Colour Version   30/06/85       }
  28.  
  29. {$C-}
  30.  
  31. const
  32.   w0 = 160; h0 = 64;
  33.   title = '*** Sierpinski Curves ***';
  34.  
  35. var
  36.   i,n : byte;
  37.   h,w,t1,t2,x,x0,y,y0 : byte;
  38.  
  39. {$I normal.pro}
  40. {$I lores80.pro}
  41. {$I draw.pro}
  42. {$I ploti2.pro}
  43. {$I colinit.pro}
  44.  
  45. {$A-}
  46.  
  47. procedure B(i : byte); forward;
  48.  
  49. procedure C(i : byte); forward;
  50.  
  51. procedure D(i : byte); forward;
  52.  
  53. procedure A(i : byte);
  54. begin if i > 0 then
  55.   begin
  56.     A(i - 1); t1 := x+w; t2 := y-h; plot(x,y,t1,t2); x := t1; y := t2;
  57.     B(i - 1); t1 := x+2*w; plot(x,y,t1,y); x := t1;
  58.     D(i - 1); t1 := x+w; t2 := y+h; plot(x,y,t1,t2); x := t1; y := t2;
  59.     A(i - 1)
  60.   end
  61. end; {A(i)}
  62.  
  63. procedure B;
  64. begin if i > 0 then
  65.   begin
  66.     B(i - 1); t1 := x-w; t2 := y-h; plot(x,y,t1,t2); x := t1; y := t2;
  67.     C(i - 1); t2 := y-2*h; plot(x,y,x,t2); y := t2;
  68.     A(i - 1); t1 := x+w; t2 := y-h; plot(x,y,t1,t2); x := t1; y := t2;
  69.     B(i - 1)
  70.   end
  71. end; {B(i)}
  72.  
  73. procedure C;
  74. begin if i > 0 then
  75.   begin
  76.     C(i - 1); t1 := x-w; t2 := y+h; plot(x,y,t1,t2); x := t1; y := t2;
  77.     D(i - 1); t1 := x-2*w; plot(x,y,t1,y); x := t1;
  78.     B(i - 1); t1 := x-w; t2 := y-h; plot(x,y,t1,t2); x := t1; y := t2;
  79.     C(i - 1)
  80.   end
  81. end; {C(i)}
  82.  
  83. procedure D;
  84. begin if i > 0 then
  85.   begin
  86.     D(i - 1); t1 := x+w; t2 := y+h; plot(x,y,t1,t2); x := t1; y := t2;
  87.     A(i - 1); t2 := y+2*h; plot(x,y,x,t2); y := t2;
  88.     C(i - 1); t1 := x-w; t2 := y+h; plot(x,y,t1,t2); x := t1; y := t2;
  89.     D(i - 1)
  90.   end
  91. end; {D(i)}
  92.  
  93. procedure set_col;
  94. const
  95.   next_line = $50;
  96. var
  97.   col_ram,left,right : integer;
  98.   line,loc,colour : byte;
  99. begin
  100.   port[8] := 78; {colour RAM on, RGB full}
  101.   left := $F800; right := $F84F; colour := 0;
  102.   for col_ram := left to right do
  103.     mem[col_ram] := 4; {line 1, red on black}
  104.   for col_ram := left + next_line*21 to right + next_line*21 do
  105.     mem[col_ram] := 4;
  106.   for line := 2 to 21 do
  107.     begin
  108.       mem[left + next_line] := 4;  {left side }
  109.       mem[right + next_line] := 4; {right side}
  110.       colour := colour + 1;
  111.       if colour = 16 then colour := 1; {avoid black on black!}
  112.       for loc := 1 to 78 do
  113.         mem[left + next_line + loc] := colour;
  114.       left := left + next_line; right := right + next_line
  115.     end; {for line}
  116.   port[8] := 14; {PCG ram on, RGB full}
  117. end; {procedure set_col}
  118.  
  119. begin {main}
  120.   clrscr;
  121.   colinit; {initialise colour procedure}
  122.   color(3,3,0);
  123.   gotoxy(22,8);
  124.   write(title);
  125.   repeat
  126.     gotoxy(10,11); color(4,6,0);
  127.     write(^G,'What order of Curve do you require (1 to 3 only) : ');
  128.     readln(n)
  129.   until (n > 0) and (n < 4);
  130.   gotoxy(53,24); {establish cursor position clear of graphics}
  131.   set_col; {set up colour RAM values}
  132.   i := 0; h := h0 div 4; w := w0 div 4; x0 := 2*w; y0 := 3*h;
  133.   lores80;
  134.   plot(0,0,159,0);     {plot frame}
  135.   plot(0,63,159,63);
  136.   plot(0,1,0,62);
  137.   plot(159,1,159,62);
  138.   repeat
  139.     i := i + 1; x0 := x0 - w;
  140.     h := h div 2; w := w div 2; y0 := y0 + h;
  141.     x := x0; y := y0;
  142.     A(i); t1 := x+w; t2 := y-h; plot(x,y,t1,t2); x := t1; y := t2;
  143.     B(i); t1 := x-w; t2 := y-h; plot(x,y,t1,t2); x := t1; y := t2;
  144.     C(i); t1 := x-w; t2 := y+h; plot(x,y,t1,t2); x := t1; y := t2;
  145.     D(i); t1 := x+w; t2 := y+h; plot(x,y,t1,t2); x := t1; y := t2;
  146.   until i = n;
  147.   color(6,1,7);
  148.   gotoxy(28,24);
  149.   write(title);
  150.   repeat until keypressed;
  151.   clrscr;  {replace chr(128) with chr(32)}
  152.   normal;
  153.   writeln(^G)
  154. end. {main}
  155.  
  156.