home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / graphics / draw630.lbr / GRAFTAL.PQS / GRAFTAL.PAS
Encoding:
Pascal/Delphi Source File  |  1986-12-07  |  6.5 KB  |  225 lines
  1. program graftal;
  2. {$i diablo.lib}
  3. { Program by Ken Birdwell and Steve Estvanik }
  4. { modified by T Meekins }
  5. type
  6.   bytearray = array[0..10000] of byte;
  7.   codearray = array[0..7,0..20] of byte;
  8.   realarray = array[0..10] of real;
  9. var
  10.      code    : codearray;
  11.      graftal : bytearray;
  12.      ang     : realarray;
  13.      leaf    : boolean;
  14.      graftal_len, gen, num_gen, num_ang, i, j : integer;
  15. procedure getcode(var num_var : integer;
  16.                   var code : codearray;
  17.                   var ang : realarray;
  18.                   var num_ang : integer );
  19.   var key : string[20];
  20.      d, g : integer;
  21.      ch : char;
  22.   begin
  23.     write('Enter number of generations: ');
  24.     readln(num_gen);
  25.     for d := 0 to 7 do
  26.        begin
  27.        write('Enter key for ',d :1, ': ');
  28.        readln(key);
  29.        code[d,0] := length(key);
  30.        for g := 1 to code[d,0] do
  31.           case key[g] of
  32.             '0' : code[d,g] := 0;
  33.             '1' : code[d,g] := 1;
  34.             '[' : code[d,g] := 128;
  35.             ']' : code[d,g] := 64;
  36.           end;
  37.       end;
  38.       write('Enter number of angles: ');
  39.       readln(num_ang);
  40.       for g:= 1 to num_ang do
  41.         begin
  42.         write('enter angle (deg) ',g : 2, ': ');
  43.         readln(i);
  44.         ang[g-1] := i*3.1415/180;
  45.         end;
  46.       write('Do you want leaves?');
  47.       readln(ch);
  48.       case ch of
  49.         'y','Y' : leaf := true;
  50.         'n','N' : leaf := false;
  51.       end;
  52.  end;
  53. function findnext(p : integer;
  54.                    var orig : bytearray;
  55.                    var orig_len : integer ) : integer ;
  56. var
  57.     found : boolean;
  58.     depth : integer;
  59.     begin
  60.        depth := 0;
  61.        found := FALSE;
  62.        while (p < orig_len) and not found do
  63.           begin
  64.           p := p + 1;
  65.           if (depth = 0) and (orig[p] < 2 ) then
  66.              begin
  67.              findnext := orig[p];
  68.              found := TRUE;
  69.              end
  70.           else if (depth = 0 and orig[p] and 64) then
  71.              begin
  72.              findnext := 1;
  73.              found := TRUE;
  74.              end
  75.           else if (orig[p] and 128) <> 0 then
  76.              depth := depth +1
  77.           else if (orig[p] and 64) <> 0 then
  78.              depth := depth-1;
  79.           end;
  80.         if (not found) then
  81.           findnext := 1;
  82.     end;
  83. procedure add_new(b2, b1, b0 : integer;
  84.                   var dest : bytearray;
  85.                   var code : codearray;
  86.                   var dest_len : integer;
  87.                   num_ang : integer );
  88.     var d, i : integer;
  89.     begin
  90.         d := b2 * 4 + b1 * 2 + b0;
  91.         for i := 1 to code[d, 0] do
  92.            begin
  93.            dest_len := dest_len + 1;
  94.            case code[d,i] of
  95.               0..63 : dest[dest_len] := code[d,i];
  96.               64    : dest[dest_len] := 64;
  97.               128   : dest[dest_len] := 128 + random(num_ang);
  98.               end;
  99.          end;
  100.      end;
  101. procedure generation (var orig : bytearray;
  102.                       var orig_len : integer;
  103.                       var code : codearray );
  104.    var depth, dest_len,g,a : integer ;
  105.        b0,b1,b2            : byte ;
  106.        stack               : array [0..200] of integer;
  107.        dest                : bytearray;
  108.    begin
  109.       depth := 0;
  110.       dest_len := 0;
  111.       b2 := 1;
  112.       b1 := 1;
  113.       for g := 1 to orig_len do
  114.          begin
  115.          if (orig[g] < 2) then
  116.            begin
  117.            b2 := b1;
  118.            b1 := orig[g];
  119.            b0 := findnext(g, orig, orig_len);
  120.            add_new(b2, b1, b0, dest, code, dest_len, num_ang) ;
  121.            end
  122.          else if (orig[g] and 128) <> 0 then
  123.            begin
  124.            dest_len := dest_len + 1;
  125.            dest[dest_len] := orig[g];
  126.            depth := depth + 1;
  127.            stack[depth] := b1;
  128.            end
  129.          else if (orig[g] and 64) <>0 then
  130.            begin
  131.            dest_len := dest_len + 1;
  132.            dest[dest_len] := orig[g];
  133.            b1 := stack[depth];
  134.            depth := depth - 1;
  135.            end;
  136.          end;
  137.       for a := 1 to dest_len do
  138.          orig[a] := dest[a];
  139.       orig_len := dest_len;
  140.    end;
  141. procedure print_generation(var graftal : bytearray;
  142.                            var graftal_len : integer);
  143.     var p : integer;
  144.     begin
  145.         gotoxy(1,1);
  146.         writeln;
  147.         for p := 1 to graftal_len do
  148.             begin
  149.             if (graftal[p] < 2)          then write(graftal[p]:1);
  150.             if (graftal[p] and 128) <> 0 then write('[');
  151.             if (graftal[p] and 64)  <> 0 then write(']');
  152.             end;
  153.         writeln;
  154.     end;
  155. procedure draw_generation (var graftal : bytearray;
  156.                            var graftal_len : integer;
  157.                            var ang : realarray;
  158.                            var gen : integer);
  159.     var a_ra, a_xp, a_yp       : array[0..50] of real;
  160.         ra, dx, dy, xp, yp, ll : real;
  161.         g, depth               : integer;
  162.     begin
  163.         xp := 250;
  164.         yp := 500;
  165.         ll := 5;
  166.         dx := 0;
  167.         dy := -ll;
  168.         gotoxy(1,1);
  169.         write('Gen ',gen);
  170.         for g := 1 to graftal_len do
  171.       begin
  172.       if (graftal[g] < 2) then
  173.          begin
  174.          { drop shadow }
  175.          { draw (round(xp)-1, round(yp)-1,
  176.                  round(xp+dx)-1,round(yp+dy)-1);}
  177.          draw (round(xp), round(yp),
  178.                round(xp+dx), round(yp+dy));
  179.          xp := xp + dx;
  180.          yp := yp + dy;
  181.          end;
  182.       { start of branch}
  183.       if (graftal[g] and 128) <> 0 then
  184.         begin
  185.         depth := depth + 1;
  186.         a_ra[depth] := ra;
  187.         a_xp[depth] := xp;
  188.         a_yp[depth] := yp;
  189.         ra := ra + ang[graftal[g] and $7f];
  190.         dx := sin(ra)*ll;
  191.         dy := -cos(ra)*ll;
  192.         end;
  193.      { end of branch}
  194.      if (graftal[g] and 64) <> 0 then
  195.         begin
  196.         if leaf then circle (round(xp),round(yp),3);
  197.         ra := a_ra[depth];
  198.         xp := a_xp[depth];
  199.         yp := a_yp[depth];
  200.         depth := depth - 1;
  201.         dx := sin(ra)*ll;
  202.         dy := -cos(ra)*ll;
  203.         end;
  204.      end;
  205.   end;
  206. begin
  207.     clrscr;
  208.     getcode(num_gen, code, ang, num_ang);
  209.     init_diablo;
  210.     clrscr;
  211.     graftal_len := 1;
  212.     graftal[graftal_len] := 1;
  213.     for gen := 1 to num_gen do
  214.         begin
  215.         generation(graftal, graftal_len, code);
  216.         draw_generation(graftal, graftal_len, ang, gen);
  217.         print_generation(graftal, graftal_len);
  218.         end;
  219.    gotoxy(1,1);
  220.    write('Done...');
  221.    readln(i);
  222.    reset_diablo
  223. end.
  224.  
  225.