#!/usr/bin/perl
# ###
# ### ---- 2019-10-26: CODE FOR DEMONSTRATION ONLY 
# ### ---- 2019-10-26: BAD PRACTICES ABOUND (lacks 'use strict' and 
# ###      'use warnings', just to start!)
# ### ---- 2019-10-26: DO NOT USE FOR PRODUCTION CODE
# ###

#
# Please note:
#	1) This program and its author make no
#		guarantees or warranties regarding this
#		program, its usability, etc.-it was written
#		by the author, for the author, for fun.
#	2) This program can be EXTREMELY memory and
#		processor intensive, because of the number
#		of items it may be processing.
# Consider yourselves warned.
#

use Tk;

use vars qw(%controllist);

$program_title   = "Fission simulation";
$program_version = "v.0.1.1";
$blockcount      = "";
$gencount        = "";
&update_header;

$mirror        = 1;     # neutrons reflectable? (1 = yes)
$mirrorpercent = 10;    # percentage reflected (max is 100%)
$repeattime    = 15000; # repeat processing of neutrons (ms)
$dx = 4;    # spacing of atoms in grid (do not set below 3)
$dy = 4;    #
$a_dx =
  ( $dx - 1 );    # size of drawn atoms (0..$a_dx, 0..$a_dy)
$a_dy   = ( $dy - 1 );  #
$maxx   = 320;          # size of grid
$maxy   = 240;          #
$maxndx = 10;           # abs max speed of neutron (integer)
$maxndy = 10;           #
$maxneutron    = 3;  # max neutron per release
$pathflag      = 0;  # draw neutron paths?
$generation    = 0;  # generation count, program maintained
$initial_atoms = 0;  # atom count, program maintained
$maxnc         = 0;  # max neutron count, program maintained
$running       = 0;  # is simulation running?
$initialfissions = 1; # number of atoms to fission initially

srand();

# draw control window
my $mw = MainWindow->new();
$mw->title( $program_title . ' '
      . $program_version . ' '
      . '(Control)' );

my $row = 1;
$mw->Label( -textvariable => \$blockcount )
  ->grid( -row => $row++, -column => 1, -columnspan => 3 );

# $mw->Label( -textvariable => \$gencount )->grid( -row   => $row++, -column => 1, -columnspan => 3 );

$controllist{'graphicx'} = $mw->Scale(
    -from       => 160,
    -to         => 1280,
    -orient     => 'horizontal',
    -resolution => 20,
    -label      => 'Max X:',
    -variable   => \$maxx
)->grid( -row => $row, -column => 1, -columnspan => 1 );
$controllist{'graphicy'} = $mw->Scale(
    -from       => 120,
    -to         => 1020,
    -orient     => 'horizontal',
    -resolution => 20,
    -label      => 'Max Y:',
    -variable   => \$maxy
)->grid( -row => $row, -column => 2, -columnspan => 1 );
$controllist{'initialfissions'} = $mw->Scale(
    -from     => 1,
    -to       => 15,
    -orient   => 'horizontal',
    -label    => 'Initial fissions:',
    -variable => \$initialfissions
)->grid( -row => $row, -column => 3 );
$controllist{'initialfissions'}->set($initialfissions);

$row++;

$controllist{'spacingx'} = $mw->Scale(
    -from     => 3,
    -to       => 10,
    -orient   => 'horizontal',
    -label    => 'Spacing X:',
    -variable => \$dx,
    -command  => sub {
        $controllist{'drawnx'}
          ->configure( -to => ( $dx - 1 ) );
    }
)->grid( -row => $row, -column => 1, -columnspan => 1 );
$controllist{'spacingy'} = $mw->Scale(
    -from     => 3,
    -to       => 10,
    -orient   => 'horizontal',
    -label    => 'Spacing Y:',
    -variable => \$dy,
    -command  => sub {
        $controllist{'drawny'}
          ->configure( -to => ( $dy - 1 ) );
    }
)->grid( -row => $row, -column => 2, -columnspan => 1 );
$controllist{'neutronreflectivity'} = $mw->Scale(
    -from       => 0,
    -to         => 100,
    -orient     => 'horizontal',
    -resolution => 1,
    -label      => 'Mirror effic.(%):',
    -variable   => \$mirrorpercent
)->grid( -row => $row, -column => 3, -columnspan => 1 );

$row++;

$controllist{'neutronx'} = $mw->Scale(
    -from       => 1,
    -to         => 20,
    -orient     => 'horizontal',
    -resolution => 0.5,
    -label      => 'Max nX:',
    -variable   => \$maxndx
)->grid( -row => $row, -column => 1, -columnspan => 1 );
$controllist{'neutrony'} = $mw->Scale(
    -from       => 1,
    -to         => 20,
    -orient     => 'horizontal',
    -resolution => 0.5,
    -label      => 'Max nY:',
    -variable   => \$maxndy
)->grid( -row => $row, -column => 2, -columnspan => 1 );
$controllist{'multiplicationfactor'} = $mw->Scale(
    -from       => 0,
    -to         => 5,
    -orient     => 'horizontal',
    -resolution => 0.1,
    -label      => 'Neutrons per fission:',
    -variable   => \$maxneutron
)->grid( -row => $row, -column => 3 );
$controllist{'multiplicationfactor'}->set($maxneutron);

$row++;

$controllist{'drawnx'} = $mw->Scale(
    -from     => 2,
    -to       => ( $dx - 1 ),
    -orient   => 'horizontal',
    -label    => 'Drawn X:',
    -variable => \$a_dx
)->grid( -row => $row, -column => 1, -columnspan => 1 );
$controllist{'drawny'} = $mw->Scale(
    -from     => 2,
    -to       => ( $dy - 1 ),
    -orient   => 'horizontal',
    -label    => 'Drawn Y:',
    -variable => \$a_dy
)->grid( -row => $row, -column => 2, -columnspan => 1 );
$controllist{'repeattime'} = $mw->Scale(
    -from       => 5000,
    -to         => 30000,
    -orient     => 'horizontal',
    -resolution => 500,
    -label      => 'Repeat time,ms:',
    -command    => \&adjusttime
)->grid( -row => $row, -column => 3 );
$controllist{'repeattime'}->set($repeattime);

$row++;

$controllist{'initiate'} = $mw->Button(
    -text       => 'Initiate',
    -background => '#ff3333',
    -command    => sub { $running++; &start_simulation; }
)->grid( -row => $row, -column => 2 );

$mw->Checkbutton(
    -text     => 'Mirror',
    -variable => \$mirror,
    -command  => sub { &update_header; }
)->grid( -row => $row, -column => 1 );
$mw->Checkbutton(
    -text     => 'Paths',
    -variable => \$pathflag,
    -command  => sub { &update_header; }
)->grid( -row => $row, -column => 3 );

$row++;

$mw->Button(
    -text       => 'Done',
    -background => '#6666ff',
    -command    => \&dump_header
)->grid( -row => $row, -column => 2 );

MainLoop;

#
# Subroutines
#

sub start_simulation {

    # draw graphic window
    my $mw2 = MainWindow->new();
    $mw2->title( $program_title . ' '
          . $program_version . ' '
          . '(Graphic)' );
    $mw->Scale->set($repeattime);
    $canvas = $mw2->Canvas(
        -width      => $maxx + 1,
        -height     => $maxy + 1,
        -background => 'black'
    )->pack();

    foreach my $i (
        qw(graphicx graphicy initiate neutronx neutrony neutronreflectivity spacingx spacingy drawnx drawny initialfissions)
      )
    {
        $controllist{$i}->configure( -relief => 'sunken' );
        $controllist{$i}->configure( -state => 'disabled' );
    }

    # initiate reaction
    &first_change;

    # set up process to repeat to handle neutron queue
    $id = $canvas->repeat( $repeattime, \&process_neutron );

}

sub adjusttime {
    $oldrepeattime = $repeattime;
    $repeattime    = $controllist{'repeattime'}->get();

# print( "##### Repeat time changed at ", scalar( localtime() ), " from $oldrepeattime ms to $repeattime ms.\n" );
    &update_header;
    if ( defined($id) ) {
        $id->cancel();
        $id =
          $canvas->repeat( $repeattime, \&process_neutron );
    }
}

# Dump results, clean up a little, and exit
sub dump_header {
    $blockcount =
      sprintf(
        "Generation: %4d Nuclei: %8d/%8d Neutrons: %8d/%8d",
        $generation, $bc, $initial_atoms, $nc, $maxnc );
    $gencount =
      sprintf( "Repeat time: %6d ms Mirror: %1d Path: %1d",
        $repeattime, $mirror, $pathflag );
    print( $blockcount, "\n", $gencount, "\n\n" );
    for ( my $a = ( $maxx - 1 ) ; $a >= 0 ; $a-- ) {
        for ( my $b = ( $maxy - 1 ) ; $b >= 0 ; $b-- ) {
            delete( $nuclei_array[$a][$b] );
        }
    }
    if ($running) { sleep(10); }
    exit(0);
}

# Update information on control panel
sub update_header {
    $blockcount =
      sprintf(
"Generation: %04d Nuclei: %08d/%08d Neutrons: %08d/%08d",
        $generation, $bc, $initial_atoms, $nc, $maxnc );

# $gencount = sprintf( "Repeat time: %06d ms Mirror: %1d Path: %1d", $repeattime, $mirror, $pathflag );

    #	print($blockcount, "\n");
}

# Get number of neutrons to release from fission
sub neutrons_to_release {
    return ( rand() * $maxneutron );
}

# Handle initial fission in array
sub first_change {
    $generation++;
    my $amax = 0;
    while ( ( $amax + $dx ) < $maxx ) { $amax += $dx; }
    my $bmax = 0;
    while ( ( $bmax + $dy ) < $maxy ) { $bmax += $dy; }
    for ( $a = $amax ; $a >= 0 ; $a -= $dx ) {

        for ( $b = $bmax ; $b >= 0 ; $b -= $dy ) {
            &add_atom( $a, $b );
        }    # end for $b
    }    # end for $a
    $initial_atoms = $bc;

    foreach ( 1 .. $initialfissions ) {
        $i = int( rand( $maxx / $dx ) ) * $dx;
        $j = int( rand( $maxy / $dy ) ) * $dy;

        $torelease = &neutrons_to_release();
        for ( $a = 0 ; $a < $torelease ; $a++ ) {
            push( @flux, &get_neutron( $i, $j ) );
        }    # end for $a
        &remove_atom( $i, $j );
        &update_header;
    }
}

# Draw atoms
sub drawmyrect {
    local ( $i, $j, $color ) = @_;
    $canvas->createRectangle( $i, $j, $i + $a_dx,
        $j + $a_dy, -fill => $color );
}

# Draw neutron path
sub drawmypath {
    local ( $x, $y, $dx, $dy ) = @_;
    $da = $x + $dx;
    $da = 1 if ( $da < 0 );
    $da = ( $maxx - 1 ) if ( $da > $maxx );
    $db = $y + $dy;
    $db = 1 if ( $db < 0 );
    $db = ( $maxy - 1 ) if ( $db > $maxy );
    $canvas->createLine( $x, $y, $da, $db,
        -fill => 'yellow' );
}

#
# Neutrons are handled in the queue as strings,
#  consisting of the form Xd+Yd+Ud+Vd+,
#  where d+ indicates a number (positive or negative),
# and
#  Xddd indicates the x position in the grid
#  Yddd indicates the y position in the grid
#  Uddd indicates the x speed of the neutron
#  Vddd indicates the y speed of the neutron
#

# Convert neutron speed to list of 4 values
sub n_s2c {
    local ($mystring) = @_;
    my $a, $b, $c, $d, @e;
    $mystring =~ s/(\w[+\-]?\d+)/$1:/g;
    ( $a, $b, $c, $d, @e ) = split( ':', $mystring );
    $a =~ s/X//;
    $b =~ s/Y//;
    $c =~ s/U//;
    $d =~ s/V//;
    return ( $a, $b, $c, $d );
}

# Convert list of 4 values to neutron string
sub n_c2s {
    local ( $a, $b, $c, $d ) = @_;
    my $e = sprintf( "X%dY%dU%dV%d", $a, $b, $c, $d );
    return ($e);
}

# Handle movement of neutron
sub move_neutron {
    local ($mystring) = @_;
    my $a, $b, $c, $d, @e;
    ( $a, $b, $c, $d ) = &n_s2c($mystring);
    $a += $c;
    $b += $d;
    $mystring = &n_c2s( $a, $b, $c, $d );
    return ($mystring);
}

# Check if neutron remains in grid, is reflected,
# or escapes
sub neutron_in_bounds {
    local (*mystring) = @_;
    my $a, $b, $c, $d, $isin;
    ( $a, $b, $c, $d ) = &n_s2c($mystring);
    $isin = (&get_neutron_inside_axis( $a, $maxx )
          && &get_neutron_inside_axis( $b, $maxy ) );
    if ( ( !($isin) ) && ($mirror) ) {
        if ( int( rand() * 100 ) < $mirrorpercent ) {
            $mystring =
              &n_c2s( $a, $b, ( 0 - $c ), ( 0 - $d ) );
            $mystring = &move_neutron($mystring);
            $isin     = !($isin);
            print "+-neutron reflected\n";
        }
    }
    return ($isin);
}

# Process the neutron queue
sub process_neutron {
    my @processed = ();
    $generation++;
    print( scalar( localtime() ), "\n" );
    while ( $current = shift(@flux) ) {
        (
            $neutron_x,  $neutron_y, $neutron_dx,
            $neutron_dy, @junk
        ) = &n_s2c($current);
        &drawmypath(
            $neutron_x,  $neutron_y,
            $neutron_dx, $neutron_dy
        ) if ($pathflag);
        $current = &move_neutron($current);
        ( $neutron_x, $neutron_y, $neutron_dx, $neutron_dy )
          = &n_s2c($current);
        if ( &neutron_in_bounds( \$current ) ) {
            if ( $nuclei_array[$neutron_x][$neutron_y] ) {
                $torelease = &neutrons_to_release();
                $nc--;
                for ( $a = 0 ; $a < $torelease ; $a++ ) {
                    push(
                        @processed,
                        &get_neutron(
                            $neutron_x, $neutron_y
                        )
                    );
                }    # end for $a
                &remove_atom( $neutron_x, $neutron_y );
                print "\t\treleased: ", int($torelease),
                  "\n";
            }
            else {
                push( @processed, $current );
            }    # end if $nuclei_array
        }
        else {
            $nc--;
            print "--neutron escaped\n";
            &update_header;
        }    # end if get_neutron_inside_axis
    }    # end while $neutron
    foreach $current (@processed) {
        push( @flux, $current );
    }
    &update_header;
    &dump_header() if ( ( $nc <= 0 ) or ( $bc <= 0 ) );
}

# Check that a value is within its bounds
sub get_neutron_inside_axis {
    local ( $v, $maxv ) = @_;
    return ( abs( $v - ( $maxv / 2 ) ) <= ( $maxv / 2 ) );
}

# Get x speed for a new neutron
sub get_neutron_dx {
    return (
        int( ( rand() * $maxndx ) - ( $maxndx / 2 ) ) );
}

# Get y speed for a new neutron
sub get_neutron_dy {
    return (
        int( ( rand() * $maxndy ) - ( $maxndy / 2 ) ) );
}

# Create values for a new neutron
sub get_neutron {
    local ( $x, $y ) = @_;
    $n_dx = 0;
    $n_dy = 0;
    while ( ( $n_dx == 0 ) and ( $n_dy == 0 ) ) {
        $n_dx = &get_neutron_dx;
        $n_dy = &get_neutron_dy;
    }
    $node = &n_c2s( $x, $y, $n_dx, $n_dy );
    $nc++;
    $maxnc++;
    &update_header;
    printf( "\tnew neutron (#%d)- {%s}\n", $nc, $node );
    return ($node);
}

# Change status and appearance of atom
sub change_atom {
    local ( $i, $j, $value ) = @_;
    if   ( $value == 1 ) { $color = 'red';  $bc++; }
    else                 { $color = 'blue'; $bc--; }
    $nuclei_array[$i][$j] = $value;
    &update_header;

# foreach my $c ( '00', '33', '66', '99', 'cc', 'ff' ) {
#     foreach my $d ( '00', '33', '66', '99', 'cc', 'ff' ) {
#         foreach my $e ( '00', '33', '66', '99', 'cc', 'ff' ) {
#             &drawmyrect( $i, $j, '#' . $c . $d . $e );
#         }
#     }
# }
# select( undef, undef, undef, 0.1 );
    &drawmyrect( $i, $j, $color );
}

# Set atom to existing
sub add_atom {
    local ( $i, $j ) = @_;
    &change_atom( $i, $j, 1 );
    $bc++;
}

# Set atom to no longer exist
sub remove_atom {
    local ( $i, $j ) = @_;
    printf( "\tatom %d, %d removed\n", $i, $j );
    &change_atom( $i, $j, 0 );
    $bc--;
}