#!/usr/bin/perl 

#lsystems.cgi -Generate and select variant L systems objects.
#
#Version: 0.100
#
#Last modified:  1/10
#
#
#---------------------------
#This program is free software; you can redistribute it and/or
#modify it under the terms of the GNU General Public License
#as published by the Free Software Foundation; either version 2
#of the License, or (at your option) any later version.
#
#This program is distributed in the hope that it will be useful,
#but WITHOUT ANY WARRANTY; without even the implied warranty of
#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#GNU General Public License for more details.
#
#You should have received a copy of the GNU General Public License
#along with this program; if not, write to the Free Software
#Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
#---------------------------
#
#Written by Jim Lund, jlund256 at gmail dot com
#
#Web site: http://jimlund.org
#---------------------------


use CGI qw(:standard);


#
#Subroutines
#
sub DIVERSE;
sub PUSH_PIC;
sub LS_LINK;
sub PRINT_HTML;



#
#Global variables.
#
my $log_file = '/data/home/http/jiml/lsystem/code/html/lsystem_log.txt';
my $form_file = '/data/home/http/html/jiml/lsystem/code/html/lsystem.html';
my $tmp_dir = '../temp/';
my $base_url = "http://jimlund.org/ls/lsystems.cgi";
my $img_type  =  "png";
my $rand_seed = 0;
my $ls_width = 150;
my $ls_height = 150;
my $matrix_size = 5;
my $max_recurse = 5; #Can easily take >1 min, > 500M for images with recurse = 6!
my $max_length = 30;
my $max_color = 33;

my @angle = (90,270,45,135,315,60,120,240,300,72,144,216,288,30,150,210,240,300,330,22.5,45,67.5,112.5,157.5,202.5,225,24,48,96,168,192,18,36,54,108,126,162,20,40,80,100,140,160,200,220,260,280,320,340);

#
#Send out output without delay.
#
$|=1;


#
#Read in form values.
#
$page_result= new CGI;


$axiom = $page_result->param("a");
$axiom =~ s/ /+/g;

$f = $page_result->param("f");
$f =~ s/ /+/g;

$g = $page_result->param("g");
$g =~ s/ /+/g;

$x = $page_result->param("x");
$x =~ s/ /+/g;

$y = $page_result->param("y");
$y =~ s/ /+/g;

$angle = $page_result->param("p");
$recurse = $page_result->param("r");
$start_color = $page_result->param("z");

$history_id = $page_result->param("h");

$iteration = $page_result->param("n");


#If the input is too complicated  or wrongly formatted then bail out.
my $bail = 0;
if (length(join("",@new_ls)) > $max_length * 2) { $bail = 1; }
elsif ($y && !$x) { $bail = 1; }
elsif ($g && !$f) { $bail = 1; }
#elsif ($x && !$f) { $bail = 1; }
elsif ($f =~ /X/ && !$x) { $bail = 1; }
elsif ($f =~ s/(L)/L/g != $f =~ s/(J)/J/g) { $bail = 1; }
elsif ($g =~ s/(L)/L/g != $g =~ s/(J)/J/g) { $bail = 1; }
elsif ($x =~ s/(L)/L/g != $x =~ s/(J)/J/g) { $bail = 1; }
elsif ($y =~ s/(L)/L/g != $y =~ s/(J)/J/g) { $bail = 1; }
if ($bail) { print redirect($base_url); }


#Options if called with no input.
if (!$axiom) {
    $axiom = "F--F--F";
    $f = "F+F--F+F";
    $g = '';
    $x = '';
    $y = '';
    $angle = 60;
    $recurse = 3;
}

#First call with new parameters.
if (!$iteration) {

    $iteration = 1;

    $history_id = rand;
    $history_id = substr($history_id,length($history_id)-6);

} else { $iteration++; }



#
#Read in template file.
#
if ($form_file) {
    (open(FORM,'<'.$form_file)) || die "Can't open file $form_file: $!\n";
    @page=<FORM>;
    close FORM || warn "Warning, error closing $form_file: $!\n";
    }
else {die "Can't find the form file!\n";}



#
#Clean input.
#
$iteration=~ s/[^\d]+//g;
$history_id=~ s/[^\d]+//g;
if ($recurse > $max_recurse + 2) { $recurse = $max_recurse - 1; }
$start_color =~ s/[^\d]+//g;
if ($start_color >= $max_color) { $start_color = 0; }

@current_ls = ($axiom, $f, $g, $x, $y, $angle, $recurse, $start_color);

for ($i=0;$i <= $#current_ls;$i++) {$current_ls =~ s/[^\-\d+FGXYLJ\._:]+//g;}


$new_ls = $matrix_size**2 - 1;

for ($i=0;$i < $new_ls;$i++) {
#
#Generate offspring L systems with randomized parameters.
#The first two variations are changes -1 and +1 in $recurse.
#
    if ($i == 0 && $recurse > 1) { 
      @new_ls = ($axiom, $f, $g, $x, $y, $angle, $recurse - 1, $start_color);
    }elsif($i == 1 && $recurse < $max_recurse) {
      @new_ls = ($axiom, $f, $g, $x, $y, $angle, $recurse + 1, $start_color);
    }else{
      @new_ls = &DIVERSE(@current_ls);
    }

#
#Generate link for the new Biomorph.
#
    ($ls_link[$i],$ls_img_link[$i]) = &LS_LINK($iteration,@new_ls);
    }


($skip,$current_ls_img_link) = &LS_LINK($iteration,@current_ls);

$gallery_link = $current_ls_img_link;
$gallery_link =~ s/draw_ls.cgi/gallery.cgi/;


#
#Make up result HTML.
#
&PRINT_HTML;

#
#End of main section.
#




#
#Subroutines
#


#
#Make up result HTML.
#
sub PRINT_HTML {
#Iterate through the template, replacing the active sections with the 
#imported/calculated content.
#

my $gal_iter=$iteration - 1;
my $id_current = "lg_a${axiom}f${f}g${g}x${x}y${y}p${angle}r${recurse}z$start_color";
$id_current =~ s/z$//;


#HTML describing the L system that generates this image.
my $axiom_long = join(" ",split(//,$axiom));
my $f_long = join(" ",split(//,$f));
my $g_long = join(" ",split(//,$g));
my $x_long = join(" ",split(//,$x));
my $y_long = join(" ",split(//,$y));

my $pop_div_html.="<div id='${id_current}_div' style='visibility: hidden;'><div class='center_text'><br>Axiom: $axiom_long";
if ($f) { $pop_div_html .= "<BR>F -&gt; $f_long"; }
if ($g) { $pop_div_html .= "<BR>G -&gt; $g_long"; }
if ($x) { $pop_div_html .= "<BR>X -&gt; $x_long"; }
if ($y) { $pop_div_html .= "<BR>Y -&gt; $y_long"; }
$pop_div_html .=" <BR>Angle: $angle Depth: $recurse</div></div>";


for ($i=0;$i<=$#page;$i++) {
#
#Add in L systems.
#
    if ($page[$i]=~/#ls_history#/i) {$page[$i]=~s/#ls_history#/$current_ls_img_link\&h=$history_id\&n=$iteration/i;}
    if ($page[$i]=~/#ls\d+#/i) {$page[$i]=~s/#ls(\d+)#/$ls_img_link[$1]/i;}
    if ($page[$i]=~/#ls_link\d+#/i) {$page[$i]=~s/#ls_link(\d+)#/$ls_link[$1]/i;}
    if ($page[$i]=~/#ls_current#/i) {$page[$i]=~s/#ls_current#/$current_ls_img_link\&c=1/i;}
    if ($page[$i]=~/#id_current#/i) {$page[$i]=~s/#id_current#/$id_current/i;}
    if ($page[$i]=~/#pop_div#/i) {$page[$i]=~s/#pop_div#/$pop_div_html/i;}

    if ($page[$i]=~/#a#/i) {$page[$i]=~s/#a#/$axiom/i;}
    if ($page[$i]=~/#f#/i) {$page[$i]=~s/#f#/$f/i;}
    if ($page[$i]=~/#g#/i) {$page[$i]=~s/#g#/$g/i;}
    if ($page[$i]=~/#x#/i) {$page[$i]=~s/#x#/$x/i;}
    if ($page[$i]=~/#y#/i) {$page[$i]=~s/#y#/$y/i;}
    if ($page[$i]=~/#z#/i) {$page[$i]=~s/#z#/$start_color/i;}
    if ($page[$i]=~/#p#/i) {$page[$i]=~s/#p#/$angle/i;}
    if ($page[$i]=~/#r#/i) {$page[$i]=~s/#r#/$recurse/i;}

    if ($page[$i]=~/#h#/i) {$page[$i]=~s/#h#/$history_id/i;}
    if ($page[$i]=~/#n#/i) {$page[$i]=~s/#n#/$gal_iter/i;}
    }


#
#Print out page.
#
print header();
print @page;
exit;
}


############################################################################
#Called by: main
#Calls: none
#
#Generate offspring L-systems with randomly tweaked parameters.
#
sub DIVERSE {
my (@new_ls)=@_;

my ($done,$change,$delta);

#
#Initialize random seed, if not done before.
#
if (!$rand_seed) {
    srand (time ^ $$ ^ unpack "%L*", `ps axww | gzip`);
    $rand_seed=1;
    }


#
#Change one parameter by adding or subtracting one unitary part of the L system.
#
while($done < 2) {
 
  $change=int(rand(@new_ls));
  if ($change == 2 && !$new_ls[2]) { next; }
  elsif ($change <= 4) {

    my $atom = int(rand( length($new_ls[$change]) ));

    if (int(rand 2)) { #Shorten this L iterator function.

      #Don't completely delete this L iterator function.
      next if length($new_ls[$change]) == 1; 

      #Don't eliminate all functions from the axiom.
      next if ($change == 0 && $new_ls[$change] =~ s/([FGXY])/$1/g < 2);

      #Shorten by one letter.	
      my $removed = substr($new_ls[$change],$atom,1,""); 
    
      #If the removed letter is a L or J, the one of the other sort must
      #also be removed to keep the pairs even.
      if ($removed eq 'L') { 
        while(substr($new_ls[$change],$atom,1) ne 'J') { $atom++; }
        substr($new_ls[$change],$atom,1,"");
      }elsif ($removed eq 'J') {
        do { $atom--; } until (substr($new_ls[$change],$atom,1) eq 'L');
        substr($new_ls[$change],$atom,1,"");
      }
       
      #If a color change operator (. or :) is removed, remove all adjacent ones as well.
      if ($removed eq '.' || $removed eq ':') {
        my $start = $atom;
        foreach $delta (1,-1) {
          if ($delta == -1) { $atom = $start - 1; }
 
          while ($atom < length($new_ls[$change]) && $atom >= 0) {
            my $next = substr($new_ls[$change],$atom,1);
            if ($next eq '.' || $next eq ':') { substr($new_ls[$change],$atom,1,''); $atom += $delta; }
            else { last; }
          }
        }
      }
   
      $done++;
    }else{ #Add one letter to this L iterator function.

      #Don't add to a blank function.
      next if !$new_ls[$change];

      #Restrict maximum length of this L iterator function.
      next if length($new_ls[$change]) == $max_length; 
      #Restrict maximum length of all L iterator functions.
      next if length(join("",@new_ls)) > $max_length * 2; 

      my @letters = ('F','+','-','_');
      if ($new_ls[2]) { push(@letters,'G'); }
      if ($new_ls[3]) { push(@letters,'X'); }
      if ($new_ls[4]) { push(@letters,'Y'); }
      my $all = join("",@new_ls);
      if ($all =~ /[LJ]/) { push(@letters,'L'); }
      if ($new_ls[7]) { push(@letters,'.',':'); }

      my $rand = int(rand(@letters));
      #If the new letter is L, add a LJ pair.  The L has to come before the J.
      if ($letters[$rand] eq 'L') {

        substr($new_ls[$change],$atom,0,'L');
        my $atom_add = int(rand(length($new_ls[$change])-$atom-1)) + 1;
        substr($new_ls[$change],$atom + $atom_add,0,'J');

        $new_ls[$change] =~ s/LJ//g or $done += 2;

      }elsif($letters[$rand] eq '.' || $letters[$rand] eq ':') {
        my $add = $letters[$rand] x int(rand(5));
        substr($new_ls[$change],$atom,0,$add);
        $done++;
      }else{ 
	#Add a different new letter.
        substr($new_ls[$change],$atom,0,$letters[$rand]);
        $done++;
      }
    }

    #Remove useless paired LJ, +- , and -+.  And .: and :. and __
    $new_ls[$change] =~ s/LJ//g;
    $new_ls[$change] =~ s/-\+//g;
    $new_ls[$change] =~ s/\+-//g;
    $new_ls[$change] =~ s/\.://g;
    $new_ls[$change] =~ s/:\.//g;
    $new_ls[$change] =~ s/__//g;
   
  }elsif($change == 5) {
    do { $new_angle = $angle[int(rand(@angle))]; } until $new_angle != $new_ls[$change];

    $new_ls[$change] = $new_angle;
    $done++; 
  }elsif($change == 6) {
    #Set delta to 0 or 1, skip it other times so changes in delta are rare.
    my $delta = int(rand 6); 
    if (!$delta) { $delta = -1; }
    elsif ($delta > 1) { next; }

    #The iteration must stay between 1 and max_recurse.
    #Sometimes the program starts with recurse higher than the max, in those cases
    #only allow it decrease.
    if ($new_ls[$change] + $delta > 1 && ($new_ls[$change] + $delta <= $max_recurse || $delta == -1)) {
      $new_ls[$change] += $delta;
      $done++;
    }
  }elsif($change == 7) {
    next if $new_ls[$change] eq '';
    $new_ls[$change] = int(rand($max_color));
    $done++;
  }
}
 
return @new_ls;
}



############################################################################
#Called by: main
#Calls: none
#
#Generate link for the new L system.
#
sub LS_LINK {
my ($iteration,@ls)=@_;

my ($axiom, $f, $g, $x, $y, $angle, $recurse, $start_color) = @ls;

my $new_ls_link = "lsystems.cgi?a=$axiom&f=$f&g=$g&x=$x&y=$y&p=$angle&r=$recurse&z=$start_color&n=$iteration&h=$history_id";
$new_ls_link =~ s/&[fgxyz]=(&|$)/$1/g;

my $new_ls_img_link = "draw_ls.cgi?a=$axiom&f=$f&g=$g&x=$x&y=$y&p=$angle&r=$recurse&z=$start_color";
$new_ls_img_link =~ s/&[fgxyz]=(&|$)/$1/g;

return($new_ls_link,$new_ls_img_link);
}


#
#End of program.