fork download
copy 
  1. use strict;
  2. use warnings;
  3.  
  4. our %formula_per_k;
  5. INIT {
  6.     my $braces_re;
  7.     $braces_re = qr{
  8.         (?:
  9.             (?> [^{}]+ )
  10.         |
  11.             \{ (??{ $braces_re }) \}
  12.         )*
  13.     }sx;
  14.  
  15.     # List all functions that you want to allow in formulas.  All other words will be interpretted as variables.
  16.     my @FORMULA_FUNCS = qw(sqrt exp log);
  17.  
  18.     # Load the data via a file.
  19.     my $data = do { local $/; <DATA> };
  20.  
  21.     # Parse K blocks
  22.     while ( $data =~ m{ ^K \s+ (\w+) \s* \{ ( $braces_re ) \} }mgx ) {
  23.         my ( $name, $params ) = ( $1, $2 );
  24.  
  25.         # Parse LOL block
  26.         next if $params !~ m{ LOL \s* \{ ( $braces_re ) \} }mx;
  27.         my $lol = $1;
  28.  
  29.         # Start building anonymous subroutine
  30.         my $conditions = '';
  31.  
  32.         # Parse Conditions and Formulas
  33.         while (
  34.             $lol =~ m{
  35.                     COND \s* \{ (.*?) \} \s* 
  36.                     FORMULA \s* \{ (.*?) \}
  37.                 }gx
  38.             )
  39.         {
  40.             my ( $cond, $formula ) = ( $1, $2 );
  41.  
  42.             # Remove Excess spacing and translate variable into perl scalar.
  43.             for ( $cond, $formula ) {
  44.                 s/^\s+|\s+$//g;
  45.                 s{([a-zA-Z]+)}{
  46.                     my $var = $1;
  47.                     $var = "\$hashref->{$var}" if ! grep {$var eq $_} @FORMULA_FUNCS;
  48.                     $var
  49.                 }eg;
  50.             }
  51.  
  52.             $conditions .= "return $formula if $cond; ";
  53.         }
  54.  
  55.         my $code = "sub {my \$hashref = shift; ${conditions} return; }";
  56.  
  57.         my $sub = eval $code;
  58.         if ($@) {
  59.             die "Invalid formulas in $name: $@";
  60.         }
  61.  
  62.         $formula_per_k{$name} = $sub;
  63.     }
  64. }
  65.  
  66. sub formula_per_k {
  67.     my ( $k, $vars ) = @_;
  68.  
  69.     die "Unrecognized K value '$k'" if !exists $formula_per_k{$k};
  70.  
  71.     return $formula_per_k{$k}($vars);
  72. }
  73.  
  74. print "'K1', {d => .1}   = " . formula_per_k( 'K1', { d => .1 } ) . "\n";
  75. print "'K1', {d => .05}  = " . formula_per_k( 'K1', { d => .05 } ) . "\n";
  76. print "'K3', {d => .02}  = " . formula_per_k( 'K3', { d => .02 } ) . "\n";
  77. print "'K3', {d => .021} = " . formula_per_k( 'K3', { d => .021 } ) . "\n";
  78.  
  79. __DATA__
  80. ... #OTHER STUFFS
  81. K K1 {
  82.     LOL {
  83.         COND { d < 0.01 }
  84.         FORMULA { -0.2 + 3.3*sqrt(d) }
  85.         COND { d >= 0.01 }
  86.         FORMULA { -0.2 + 3.3*sqrt(d+0.4) }
  87.     }
  88. }
  89. ... #OTHER STUFFS
  90. K K2 {
  91.     LOL {
  92.         COND { d < 0.03 }
  93.         FORMULA { -2.2 + 1.3*sqrt(d) }
  94.         COND { d >= 0.03 }
  95.         FORMULA { -2.2 + 1.3*sqrt(d+0.8) }
  96.     }
  97. }
  98. ... #OTHER STUFFS
  99. K K3 {
  100.     LOL {
  101.         COND { d < 0.02 }
  102.         FORMULA { -4.3 + 0.3*sqrt(d) }
  103.         COND { d >= 0.02 }
  104.         FORMULA { -4.3 + 0.3*sqrt(d+0.3) }
  105.     }
  106. }
  107. ... #OTHER STUFF
  108.  
Success #stdin #stdout 0s 3748KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
'K1', {d => .1}   = 2.13345237791561
'K1', {d => .05}  = 2.01370729772479
'K3', {d => .02}  = -4.13029437251523
'K3', {d => .021} = -4.13002941430942
https://ideone.com/Yb8IIj
language:
Perl (perl 5.28.1)
created:
11 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!