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