#!/usr/bin/perl 

#draw_ls.cgi -Generate a L system image from a set of params.
#
#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);
use GD;


#
#Subroutines
#
sub DRAW_LSYSTEM;
sub PUSH_PIC;
sub HIST_IMAGE;



#
#Global variables.
#
my $tmp_html_dir='../temp/';
my $tmp_dir='../temp/';
if ($ENV{'MOD_PERL'}) {
  my ($base_dir) = $ENV{'SCRIPT_FILENAME'} =~ /^(.+\/)[^\/]+$/;
  $tmp_dir = $base_dir.$tmp_dir;
}
my $base_url = "http://jimlund.org/ls/";
my $img_type = "png";
my $rand_seed = 0;
my $ls_width = 150;
my $ls_height = 150;
my $lg_size_multiple = 10/3;
my $max_color = 33;
my $matrix_size = 5;
my $max_hist_width = $ls_width * $matrix_size;
my $time_limit = 20;
my $fail_file = 'blank.png';
my $fail_center_file = 'cblank.png';
#$page_result= new CGI; print header;print "T:$tmp_dir<br>\n";
#foreach my $e (sort keys %ENV){print "$e  $ENV{$e}<br>\n";}exit;

#------------------------------
my $ps_file = <<EOM;
%!PS-Adobe-3.0
%%BoundingBox: 0 0 #ls_width# #ls_height#
%%HiResBoundingBox: 0 0 #ls_width# #ls_height#
%%LanguageLevel: 2
%%Orientation: Portrait
%%Pages: 1

%/Width 144 def /Height 144 def 
%/Xcenter Width 2.0 div def
%/Ycenter Height 2.0 div def

/ColorDict 13 dict def
	ColorDict begin
		(red) [ 1.0 0.0 0.0 0.3 ] def
		(pink) [ 1.0 0.6 0.6 1.0 ] def
		(orange) [ 1.0 0.6 0.0 0.8 ] def
		(yellow) [ 1.0 1.0 0.0 1.0 ] def
		(green) [ 0.0 1.0 0.0 0.5 ] def
		(blue) [ 0.0 0.0 1.0 0.2 ] def
		(cyan) [ 0.0 1.0 1.0 0.7 ] def
		(purple) [ 0.7 0.0 1.0 0.4 ] def
		(white) [ 1.0 1.0 1.0 1.0 ] def
		(gray) [ 0.8 0.8 0.8 0.8 ] def
		(black) [ 0.0 0.0 0.0 0.0 ] def
		(brown) [ 0.35 0.2 0.0 0.2 ] def
		(green2) [ 0.20 0.49 0.176 0.5 ] def
	end

%Perl to gernerate color wheel.
%perl -e '@c=(1,0,2);$top=2;@rgb=(0,0,1);$step=0.20;while(@c){printf"\t\t%d [ %2.2f %2.2f %2.2f ] def",++$x,@rgb;if($rgb[$c[0]]<1){$rgb[$c[0]]+=$step;}elsif(int($rgb[$top]*10)){$rgb[$top]-=$step;}else{$top=shift @c;}}'
%
/ColorSet 33 dict def
        ColorSet begin
                0 [ 0.00 0.00 0.00 ] def
                1 [ 0.00 0.00 1.00 ] def
                2 [ 0.00 0.20 1.00 ] def
                3 [ 0.00 0.40 1.00 ] def
                4 [ 0.00 0.60 1.00 ] def
                5 [ 0.00 0.80 1.00 ] def
                6 [ 0.00 1.00 1.00 ] def
                7 [ 0.00 1.00 0.80 ] def
                8 [ 0.00 1.00 0.60 ] def
                9 [ 0.00 1.00 0.40 ] def
                10 [ 0.00 1.00 0.20 ] def
                11 [ 0.00 1.00 0.00 ] def
                12 [ 0.00 1.00 0.00 ] def
                13 [ 0.20 1.00 0.00 ] def
                14 [ 0.40 1.00 0.00 ] def
                15 [ 0.60 1.00 0.00 ] def
                16 [ 0.80 1.00 0.00 ] def
                17 [ 1.00 1.00 0.00 ] def
                18 [ 1.00 0.80 0.00 ] def
                19 [ 1.00 0.60 0.00 ] def
                20 [ 1.00 0.40 0.00 ] def
                21 [ 1.00 0.20 0.00 ] def
                22 [ 1.00 0.00 0.00 ] def
                23 [ 1.00 0.00 0.00 ] def
                24 [ 1.00 0.00 0.20 ] def
                25 [ 1.00 0.00 0.40 ] def
                26 [ 1.00 0.00 0.60 ] def
                27 [ 1.00 0.00 0.80 ] def
                28 [ 1.00 0.00 1.00 ] def
                29 [ 0.80 0.00 1.00 ] def
                30 [ 0.60 0.00 1.00 ] def
                31 [ 0.40 0.00 1.00 ] def
                32 [ 0.20 0.00 1.00 ] def
	end

/SetColor { ColorSet exch get aload pop setrgbcolor } def

%Functions to set the color
/CurrentColor 0 def
/. { max_path currentpoint stroke moveto ColorSet length 1 sub CurrentColor eq { 0 } { CurrentColor 1 add } ifelse /CurrentColor exch store CurrentColor ColorSet exch get aload pop setrgbcolor } def

/: { max_path currentpoint stroke moveto 0 CurrentColor eq { ColorSet length 1 sub } { CurrentColor 1 sub } ifelse /CurrentColor exch store CurrentColor ColorSet exch get aload pop setrgbcolor } def


/- { R_angle neg rotate } bind def

/+ { R_angle rotate } bind def

/_ { 180 rotate } bind def


%Starter function:
%R_angle order (axiom) Axiom
/Axiom_recurse false def
/Bscale 0 def
/Axiom {
%Axiom_recurse { } if 
	/Axiom_proc exch def
	/order exch store
	/R_angle exch store
        /StartColor exch def
        /CurrentColor StartColor store
	/Yy exch def
	/Xx exch def
        gsave
	Xx Yy moveto
	1 setlinejoin
	1 setlinecap
	CurrentColor SetColor
	0.05 setlinewidth
	Bscale 0 ne 
	{ Xx 2 mul Bscale div abs 0.95 mul Ascale mul dup scale }
	{ 2 order { 2 sqrt div } repeat dup dup scale /Ascale exch def } ifelse
	order Axiom_proc 
	Axiom_recurse 
	{ stroke /Axiom_recurse false store grestore } 
	{ /Axiom_recurse true store
	  
	  max_path grestore
	  erasepage Backdrop 

	  Xx ll_x ur_x add 2 div sub 
	  Yy ll_y ur_y add 2 div sub 

	  ur_x ll_x sub dup ur_y ll_y sub dup 3 -1 roll 
	  le { pop } { exch pop } ifelse 
          dup 0 eq { pop 1 } if /Bscale exch store 
	  Xx 2 mul Bscale div abs 0.95 mul dup 4 -1 roll mul 3 1 roll mul
	  translate

          newpath Xx Yy StartColor R_angle order /Axiom_proc load Axiom
	}
	ifelse 
} def


%Store the maximum combined extent of the current path and any 
%previously stored path.
/ur_y false def
/ur_x false def
/ll_y false def
/ll_x false def
/max_path {
  gsave initmatrix pathbbox grestore

  ur_y false eq { /ur_y exch store } { dup ur_y gt { /ur_y exch store } { pop } ifelse } ifelse
  ur_x false eq { /ur_x exch store } { dup ur_x gt { /ur_x exch store } { pop } ifelse } ifelse
  ll_y false eq { /ll_y exch store } { dup ll_y lt { /ll_y exch store } { pop } ifelse } ifelse
  ll_x false eq { /ll_x exch store } { dup ll_x lt { /ll_x exch store } { pop } ifelse } ifelse
} def


/F {} def
/Make_F {
  /F_dup exch def
  /F_proc exch def

  F_dup 0 ne
  {
    /F {
      dup 0 ne
      { 1 sub F_dup {dup} repeat F_proc }
      { 2 0 rlineto }
      ifelse pop
    } store
  }
  {
    /F { 2 0 rlineto } store
  } ifelse
} bind def


/G {} def
/Make_G {
  /G_dup exch def
  /G_proc exch def

  G_dup 0 ne
  {
    /G {
      dup 0 ne
      { 1 sub G_dup {dup} repeat G_proc }
      { 2 0 rlineto }
      ifelse pop
    } store
  }
  {
    /G { 2 0 rlineto } store
  } ifelse
} bind def


/MakeBare_F {
  /F { 2 0 rlineto } store
} bind def


/X {} def
/Make_X {
  /X_dup exch def
  /X_proc exch def
  /X {
  dup 0 ne
  {1 sub X_dup {dup} repeat X_proc }
%  { 2 0 rlineto }
%  ifelse pop
  if pop
  } store
} bind def


/Y {} def
/Make_Y {
  /Y_dup exch def
  /Y_proc exch def
  /Y {
  dup 0 ne
  {1 sub Y_dup {dup} repeat Y_proc }
%  { 2 0 rlineto }
%  ifelse pop
  if pop
  } store
} bind def

/L { gsave gsave max_path stroke grestore } def

/J { grestore } def

%x y size DrawX
/DrawX {
/S exch def
/Y exch def
/Xx exch def
newpath Xx S 2 div sub Y moveto S 0 rlineto stroke
newpath Xx Y S 2 div sub moveto 0 S rlineto stroke
} bind def

/Backdrop {
  Backdrop_color ColorDict exch get aload pop pop setrgbcolor
  0 0 moveto #ls_width# 0 rlineto 0 #ls_height# rlineto #ls_width# -1 mul 0 rlineto closepath fill
} def
EOM
#------------------------------


#
#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;
$start_color = $page_result->param("z");
$angle = $page_result->param("p");
$recurse = $page_result->param("r");
$history_id = $page_result->param("h");
$iteration = $page_result->param("n");
$center_img = $page_result->param("c");


#
#Clean input.
#
for ($i=0;$i <= $#current_ls;$i++) {$current_ls =~ s/[^\-\d+FGXYLJ\._:]+//g;}
$iteration =~ s/[^\d]+//g;
$history_id =~ s/[^\d]+//g;
$center_img =~ s/[^\d]+//g;
$start_color =~ s/[^\d]+//g;
if ($start_color >= $max_color) { $start_color = 0; }


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


#Make a large version of the center image that will show up in the popup.
if ($center_img) { &DRAW_LSYSTEM($center_img,\@current_ls,$lg_size_multiple); }

$tmp_file = &DRAW_LSYSTEM($center_img,\@current_ls);

if ($history_id) { $tmp_file = &HIST_IMAGE($tmp_file); }

#
#Make up result HTML.
#
&PUSH_PIC($tmp_file);


#
#End of main section.
#


#
#Subroutines
#


############################################################################
#Called by: main
#Calls: none
#
#Push out the image.
#
sub PUSH_PIC {
my ($tmp) = @_;

print redirect($base_url.$tmp_html_dir.$tmp);

#print header(-type=>'image/png');
#print $ls_image->$img_type;
#print $ls_image;
exit;
}



############################################################################
#Called by: main
#Calls: none
#
#Draws the L system image.
#
sub DRAW_LSYSTEM {
my ($center_img,$ls_ref,$lg_size_multiple) = @_;

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

my $ls_width = $ls_width;
my $ls_height = $ls_height;

#
#Background color.
#
my $color = 'white';

#File name describes image.
my $file = "a${axiom}f${f}g${g}x${x}y${y}p${angle}r${recurse}z$start_color.".$img_type;
$file =~ s/z\././;

if ($center_img) {
  if ($lg_size_multiple) {
    $file = 'lg_'.$file;
    $ls_width *= $lg_size_multiple;
    $ls_height *= $lg_size_multiple;
  }else{
    $file = 'c'.$file;
    $color = 'gray';
  }
}


#If this image already exists return directly.
if (-e $tmp_dir.$file) { return $file; }


my $start_color_ps = $start_color ? $start_color : 0;

my $ps_file = $ps_file;
$ps_file =~ s/#ls_width#/$ls_width/gs;
$ps_file =~ s/#ls_height#/$ls_height/gs;

$start_x = int($ls_width/2);
$start_y = int($ls_height/2);

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 $f_iter = $f =~ s/([FGXY])/$1/g || 0;
my $g_iter = $g =~ s/([FGXY])/$1/g || 0;
my $x_iter;
my $y_iter;
if ($f) { 
  $x_iter = $x =~ s/([XYFG])/$1/g || 0;
  $y_iter = $y =~ s/([XYFG])/$1/g || 0;
}else{
  $x_iter = $x =~ s/([XY])/$1/g || 0;
  $y_iter = $y =~ s/([XY])/$1/g || 0;
}

my $axiom_long = join(" ",split(//,$axiom));

my $axiom_dup;
if ($x) {
  if ($f) { $axiom_dup = $axiom =~ s/([FGXY])/$1/g - 1; }
  else { $axiom_dup = $axiom =~ s/([XY])/$1/g - 1; }
  $axiom_dup = "$axiom_dup {dup} repeat";
}else{
  $axiom_dup = $axiom =~ s/([FG])/$1/g - 1;
  $axiom_dup = "$axiom_dup {dup} repeat";
}


#The image generated in postscript and then the ImageMagick convert program is used to
#convert it to binary image.  The crop option cuts the image from the full page the
#postscript image is embedded in.

#If the convert program is taking more than $time_limit secs, kill the gs process and return a blank image.

my $convert_process = open (PS,"| ulimit -t $time_limit ; gs -q -dQUIET -dPARANOIDSAFER -dBATCH -dNOPAUSE -dNOPROMPT -dMaxBitmap=500000000 -dAlignToPixels=0 -dGridFitTT=0 -sDEVICE=pngalpha -dTextAlphaBits=4 -dGraphicsAlphaBits=4 -r72x72 -g${ls_width}x$ls_height '-sOutputFile=$tmp_dir$file' -");
#open (PS,">foo");



#Prints out the postscript for drawing this L system.
print PS <<EOM;
$ps_file

/Backdrop_color ($color) def

{$f_long} $f_iter Make_F
{$g_long} $g_iter Make_G
{$x_long} $x_iter Make_X
{$y_long} $y_iter Make_Y
newpath $start_x $start_y $start_color_ps $angle $recurse {$axiom_dup $axiom_long} Axiom
showpage
EOM


close PS or warn "Can't close PS pipe: $!\n";

if (-e $tmp_dir.$file) { return $file; }
else { return $fail_file; }
}



############################################################################
#Called by: main
#Calls: none
#
#Make or append to the history image.
#
sub HIST_IMAGE {
my ($ls_file) = @_;

#Load new/current image.
open(IMAGE,'<'.$tmp_dir.$ls_file) or die "Can't open file $ls_file: $!\n";
    
my $funcname = "newFrom".ucfirst($img_type);

my $ls_image = GD::Image->$funcname(\*IMAGE);

close IMAGE or warn "Warning, error closing $ls_file: $!\n";


if (-e "$tmp_dir$history_id.$img_type") {
    open(IMAGE,'<'."$tmp_dir$history_id.$img_type") or die "Can't open file $history_id.$img_type: $!\n";
    
    my $funcname = "newFrom".ucfirst($img_type);

    my $prev_hist_image = GD::Image->$funcname(\*IMAGE);
    
    close IMAGE or warn "Warning, error closing $history_id.$img_type: $!\n";

    my ($width,$height)=GD::Image::getBounds($prev_hist_image); 


#
#Figure out the size of the history image.
#
    $per_row=int($max_hist_width/$ls_width);
    if (($per_row*$ls_width) < ($max_hist_width/$ls_width)) {$per_row++;}

    $hist_rows=int($iteration/$per_row);
    if (($hist_rows*$per_row) < $iteration) {$hist_rows++;}

    $new_width=$iteration*$ls_width;
    if ($new_width > $max_hist_width) {$new_width=$per_row*$ls_width;}

    $new_height=$hist_rows*$ls_height;

    $addition_x=($iteration-($per_row*($hist_rows-1))-1)*$ls_width;
    $addition_y=($hist_rows-1)*$ls_height;


#
#Make history image.
#
    $hist_image= new GD::Image($new_width,$new_height);
#
#Set background color.
#
    $white = $hist_image->colorAllocate(255,255,255);

#
#Copy in previous history image.
#
    $hist_image->copy($prev_hist_image,0,0,0,0,$width,$height);
#
#Copy in new ls_image.
#
    $hist_image->copy($ls_image,$addition_x,$addition_y,0,0,$ls_width,$ls_height);
    }
else {
    $hist_image=$ls_image;
    }



#
#Write the image to a file.
#
open(IMAGE,'>'."$tmp_dir$history_id.$img_type") or die "Can't open file $history_id.$img_type: $!\n";
    
binmode IMAGE;

print IMAGE $hist_image->$img_type;

close IMAGE or warn "Warning, error closing $history_id.$img_type: $!\n";

#
#Set ls_image so the history image will get sent.
#
return("$history_id.$img_type");
}


#
#Kills the convert process and returns the fail image.
#
sub KILL_TIME {
my ($ps) = @_;

kill 9,$ps;

if ($center_img) { &PUSH_PIC($fail_center_file); }
else { &PUSH_PIC($fail_file); }
}


#
#End of program.